1 /* ***********************************************************
  2    *                                                         *
  3    *                                                         *
  4    * Copyright, (C) Honeywell Information Systems Inc., 1981 *
  5    *                                                         *
  6    *                                                         *
  7    *********************************************************** */
  8 
  9 /* ******************************************************
 10    *                                                    *
 11    *                                                    *
 12    * Copyright (c) 1972 by Massachusetts Institute of   *
 13    * Technology and Honeywell Information Systems, Inc. *
 14    *                                                    *
 15    *                                                    *
 16    ****************************************************** */
 17 
 18 
 19 linus_invoke:
 20      proc (sci_ptr, lcb_ptr);
 21 
 22 /* DESCRIPTION:
 23 
 24    This  request specifies that the requests contained in the designated macro
 25    segment  are to be executed.  Arguments are optionally passed to the macro.
 26    This  feature  provides  the  capability  to invoke a pre-defined series of
 27    LINUS requests.
 28 
 29 
 30 
 31    HISTORY:
 32 
 33    77-06-01 J. C. C. Jagernuath: Initially written.
 34 
 35    80-01-04 Rickie E.  Brinegar: Modified to add the pop_all entry point.
 36 
 37    80-01-15 Rickie E.  Brinegar: to return an error message when the number of
 38    invokes exceed linus_data_$max_invocs.
 39 
 40    82-02-11 Paul W. Benjamin: ssu_ conversion.
 41 
 42    82-06-21 Al Dupuis: removed unreferenced variable iox_$user_io.
 43 
 44    82-08-31  DJ Schimke: Replaced the calls to the undocumented entrypoint
 45    syn_$syn_attach_ with a calls to iox_$attach_ptr. Declared iox_$attach_ptr
 46    and attach_description and added the iocb include file.
 47    This is in response to phx13314.
 48 */
 49 ^L
 50 %include iocb;
 51 %page;
 52 %include linus_lcb;
 53 %page;
 54 %include linus_char_argl;
 55 %page;
 56 %include linus_invoc_stack;
 57 %page;
 58 %include ssu_prompt_modes;
 59 ^L
 60           dcl     sci_ptr                ptr;               /* for ssu_ */
 61 
 62           dcl     STREAM_INPUT           fixed bin options (constant) int static init (1);
 63 
 64           dcl     path_name              char (char_argl.arg.arg_len (1)) based (char_argl.arg.arg_ptr (1));
 65           dcl     argument               char (char_argl.arg.arg_len (l)) based (char_argl.arg.arg_ptr (l));
 66           dcl     lcbpa                  char (16);
 67           dcl     lcbpl                  fixed bin (21);
 68           dcl     macro_path             char (168);
 69           dcl     macro_arg              char (mac_len) based (mac_ptr);
 70           dcl     popped_on_pi           bit (1);
 71           dcl     scipa                  char (16);
 72           dcl     scipl                  fixed bin (21);
 73           dcl     static_sci_ptr         ptr int static;    /* Change this if linus allows recursion */
 74           dcl     temp_lcb_ptr           ptr;
 75           dcl     tmp_char               char (char_argl.arg.arg_len (l + 1)) based (char_argl.arg.arg_ptr (l + 1));
 76 
 77           dcl     attach_description     char (37);         /* "syn_ "||sw_name */
 78           dcl     sw_name                char (32);
 79           dcl     dot_linus              char (6);
 80           dcl     (
 81                   iocb_ptr               init (null),
 82                   ref_ptr                init (null),
 83                   mac_ptr                init (null),
 84                   env_ptr                init (null),
 85                   tmp_ptr                init (null)
 86                   )                      ptr;
 87           dcl     (l, i)                 fixed bin;
 88           dcl     (addr, before, fixed, null, rel, substr) builtin;
 89           dcl     (icode, code, mac_len, out_code) fixed bin (35);
 90           dcl     (
 91                   error_table_$not_attached,
 92                   linus_error_$no_input_arg,
 93                   linus_error_$too_many_invocs,
 94                   sys_info$max_seg_size,
 95                   linus_data_$i_id,
 96                   linus_data_$max_invocs
 97                   )                      fixed bin (35) ext;
 98           dcl     cleanup                condition;
 99           dcl     unique_chars_          entry (bit (*)) returns (char (15));
100           dcl     cu_$decode_entry_value entry (entry, ptr, ptr);
101           dcl     ioa_$rsnnl             entry () options (variable);
102           dcl     iox_$attach_name       entry (char (*), ptr, char (*), ptr, fixed bin (35));
103           dcl     iox_$attach_ptr        entry (ptr, char (*), ptr, fixed bin (35));
104           dcl     iox_$open              entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
105           dcl     iox_$find_iocb         entry (char (*), ptr, fixed bin (35));
106           dcl     iox_$move_attach       entry (ptr, ptr, fixed bin (35));
107           dcl     iox_$detach_iocb       entry (ptr, fixed bin (35));
108           dcl     iox_$destroy_iocb      entry (ptr, fixed bin (35));
109           dcl     iox_$close             entry (ptr, fixed bin (35));
110           dcl     linus_convert_code     entry (fixed bin (35), fixed bin (35), fixed bin (35));
111           dcl     ssu_$abort_line        entry options (variable);
112           dcl     ssu_$abort_subsystem   entry options (variable);
113           dcl     ssu_$arg_count         entry (ptr, fixed bin);
114           dcl     ssu_$arg_ptr           entry (ptr, fixed bin, ptr, fixed bin (21));
115           dcl     ssu_$get_info_ptr      entry (ptr) returns (ptr);
116           dcl     ssu_$set_prompt_mode   entry (ptr, bit (*));
117           dcl     iox_$user_input        ext ptr;
118 ^L
119           ca_ptr = null;
120 
121           mac_len, icode = 0;
122 
123           on cleanup call clean_up;
124 
125           static_sci_ptr = sci_ptr;
126 
127           call ssu_$arg_count (sci_ptr, nargs_init);
128           if nargs_init = 0 then
129                call error (linus_error_$no_input_arg, "");
130           if lcb.ivs_ptr ^= null then do;
131                     ivs_ptr = lcb.ivs_ptr;                  /* No need to allocate invoke structure */
132                     if invoc_stack.ninvocs ^< linus_data_$max_invocs then
133                          call error (linus_error_$too_many_invocs, "");
134                end;
135           else do;
136                     allocate invoc_stack in (lcb.static_area); /* Invoke stack needs to be allocated */
137                     lcb.ivs_ptr = ivs_ptr;
138                     invoc_stack.ninvocs = 0;
139                end;
140           dot_linus = "      ";                             /* Append .linus to pathname if necessary */
141           allocate char_argl in (lcb.static_area);
142           do i = 1 to nargs_init;
143                call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i));
144           end;
145           if char_argl.arg.arg_len (1) > 6 then
146                dot_linus = substr (path_name, char_argl.arg.arg_len (1) - 5);
147           if dot_linus ^= ".linus" then
148                macro_path = path_name || ".linus";
149           else macro_path = path_name;
150           call cu_$decode_entry_value (linus_invoke, ref_ptr, env_ptr);
151           sw_name = unique_chars_ ("0"b) || ".linus_invoke";/* Unique switch name */
152           call ioa_$rsnnl ("^p", lcbpa, lcbpl, lcb_ptr);
153           call ioa_$rsnnl ("^p", scipa, scipl, sci_ptr);
154           call iox_$attach_name (sw_name, iocb_ptr,
155                "linus_invoke_ " || macro_path || " " || substr (lcbpa, 1, lcbpl) || " " || substr (scipa, 1, scipl),
156                ref_ptr, icode);
157           if icode ^= 0 then
158                call error (icode, before (macro_path, " "));
159           call iox_$open (iocb_ptr, STREAM_INPUT, "0"b, icode);
160           if icode ^= 0 then
161                call error (icode, before (macro_path, " "));
162 
163           if invoc_stack.ninvocs = 0                        /* save actual attachment of user_input */
164           then do;                                          /* if we are grabbing it away */
165                     sw_name = unique_chars_ ("0"b) || ".linus_input"; /* another unique switch */
166                                                             /* creating a new switch */
167                     call iox_$find_iocb (sw_name, lcb.actual_input_iocbp, icode);
168                     if icode ^= error_table_$not_attached & icode ^= 0
169                     then call error (icode, "Creating IO control block.");
170                     call iox_$move_attach (iox_$user_input, lcb.actual_input_iocbp, icode);
171                     if icode ^= 0
172                     then call error (icode, "Moving attachment of user input.");
173                end;
174           else do;
175                     call iox_$detach_iocb (iox_$user_input, icode);
176                     if icode ^= 0
177                     then call error (icode, "Detaching user input.");
178                end;
179           attach_description = "syn_ " || iocb_ptr -> iocb.name;
180           call iox_$attach_ptr (iox_$user_input, attach_description, ref_ptr, icode);
181           if icode ^= 0
182           then call error (icode, "Attaching user input.");
183 
184           invoc_stack.ninvocs = invoc_stack.ninvocs + 1;    /* Push invoke stack */
185           invoc_stack.invoc.iocb_ptr (invoc_stack.ninvocs) = lcb.is_ptr;
186           lcb.is_ptr = iocb_ptr;
187           invoc_stack.invoc.arg_ptr (invoc_stack.ninvocs) = lcb.cal_ptr;
188           if char_argl.nargs = 1 then
189                lcb.cal_ptr = null;
190           else do;                                          /* Prepare optional arguments for macro segment */
191                     nargs_init = char_argl.nargs - 1;
192                     allocate char_argl in (lcb.static_area) set (tmp_ptr);
193                     do l = 1 to nargs_init;
194                          tmp_ptr -> char_argl.nargs = l;
195                          mac_len, tmp_ptr -> char_argl.arg.arg_len (l) = char_argl.arg.arg_len (l + 1);
196                          allocate macro_arg in (lcb.static_area);
197                          macro_arg = tmp_char;
198                          tmp_ptr -> char_argl.arg.arg_ptr (l) = mac_ptr;
199                          mac_ptr = null;
200                     end;
201                     lcb.cal_ptr = tmp_ptr;
202                     tmp_ptr = null;
203                end;
204 
205           call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT); /* turn off prompting */
206 
207           if ca_ptr ^= null
208           then free char_argl;
209           return;
210 ^L
211 error:
212      proc (err_code, string);
213 
214           dcl     err_code               fixed bin (35);
215           dcl     string                 char (*);
216 
217           call clean_up;
218           call linus_convert_code (err_code, out_code, linus_data_$i_id);
219           call ssu_$abort_line (sci_ptr, out_code, string);
220 
221      end error;
222 ^L
223 clean_up:
224      proc;
225 
226           dcl     i                      fixed bin;
227 
228           if mac_ptr ^= null then
229                free macro_arg;
230           if tmp_ptr ^= null then do;
231                     do i = 1 to tmp_ptr -> char_argl.nargs;
232                          mac_ptr = tmp_ptr -> char_argl.arg.arg_ptr (i);
233                          mac_len = tmp_ptr -> char_argl.arg.arg_len (i);
234                          free macro_arg;
235                     end;
236                     free tmp_ptr -> char_argl;
237                end;
238           if ca_ptr ^= null
239           then free char_argl;
240 
241      end clean_up;
242 ^L
243 pop:
244      entry (lcb_ptr, code);                                 /* Pop invoke stack */
245 
246           code = 0;
247           ivs_ptr = lcb.ivs_ptr;
248           if lcb.cal_ptr ^= null then do;
249                     do i = 1 to lcb.cal_ptr -> char_argl.nargs;
250                          mac_len = lcb.cal_ptr -> char_argl.arg.arg_len (i);
251                          mac_ptr = lcb.cal_ptr -> char_argl.arg.arg_ptr (i);
252                          free macro_arg;
253                     end;
254                     free lcb.cal_ptr -> char_argl;          /* Free current argument list */
255                end;
256           call iox_$close (lcb.is_ptr, icode);
257           if icode ^= 0 then
258                call error (icode, "");
259           else call iox_$detach_iocb (lcb.is_ptr, icode);
260           if icode ^= 0 then
261                call error (icode, "");
262           lcb.cal_ptr = invoc_stack.invoc.arg_ptr (invoc_stack.ninvocs);
263                                                             /* Pop pointer to argument list */
264           lcb.is_ptr = invoc_stack.invoc.iocb_ptr (invoc_stack.ninvocs);
265                                                             /* Pop pointer to input stream */
266           call iox_$detach_iocb (iox_$user_input, code);
267           if code = 0
268           then do;
269 
270                     if lcb.is_ptr ^= iox_$user_input
271                     then do;
272                               attach_description = "syn_ " || lcb.is_ptr -> iocb.name;
273                               call iox_$attach_ptr (iox_$user_input, attach_description, ref_ptr, code);
274                          end;
275                     else do;
276                               call iox_$move_attach (lcb.actual_input_iocbp, iox_$user_input, code);
277                               if code = 0
278                               then call iox_$destroy_iocb (lcb.actual_input_iocbp, code);
279                          end;
280                end;
281           invoc_stack.ninvocs = invoc_stack.ninvocs - 1;
282           if invoc_stack.ninvocs = 0 then do;
283                     free invoc_stack;
284                     lcb.ivs_ptr = null;
285                end;
286           return;
287 ^L
288 pop_all_on_pi:                                              /* called by ssu_ pi handler */
289      entry (sci_ptr);
290 
291           temp_lcb_ptr = ssu_$get_info_ptr (sci_ptr);
292           popped_on_pi = "1"b;
293           goto common_pop_all;
294 
295 pop_all:
296      entry (lcb_ptr, code);                                 /* Throw away the invoke stack */
297 
298 
299           code = 0;
300           temp_lcb_ptr = lcb_ptr;
301           popped_on_pi = "0"b;
302 
303 common_pop_all:
304           if temp_lcb_ptr -> lcb.is_ptr ^= iox_$user_input then do;
305                     call iox_$close (temp_lcb_ptr -> lcb.is_ptr, icode); /* close and detach the current stream */
306                     call iox_$detach_iocb (temp_lcb_ptr -> lcb.is_ptr, icode);
307                     temp_lcb_ptr -> lcb.is_ptr = iox_$user_input;
308                     if temp_lcb_ptr -> lcb.cal_ptr ^= null then do;
309                               ca_ptr = temp_lcb_ptr -> lcb.cal_ptr;
310                               do l = 1 to char_argl.nargs;
311                                    free argument;
312                               end;
313                               free char_argl;
314                               temp_lcb_ptr -> lcb.cal_ptr = null;
315                          end;
316                     if temp_lcb_ptr -> lcb.ivs_ptr ^= null then do;
317                               ivs_ptr = temp_lcb_ptr -> lcb.ivs_ptr;
318                               do i = 2 to invoc_stack.ninvocs;
319                                    call iox_$close (invoc_stack.invoc.iocb_ptr (i), icode);
320                                    call iox_$detach_iocb (invoc_stack.iocb_ptr (i), icode);
321                                    if invoc_stack.invoc.arg_ptr (i) ^= null then do;
322                                              ca_ptr = invoc_stack.invoc.arg_ptr (i);
323                                              do l = 1 to char_argl.nargs;
324                                                   free argument;
325                                              end;
326                                              free char_argl;
327                                         end;
328                               end;
329                               free invoc_stack;
330                               temp_lcb_ptr -> lcb.ivs_ptr = null;
331                          end;
332                     call iox_$detach_iocb (iox_$user_input, icode);
333                     if icode = 0
334                     then call iox_$move_attach (temp_lcb_ptr -> lcb.actual_input_iocbp, iox_$user_input, icode);
335                     if icode = 0
336                     then call iox_$destroy_iocb (temp_lcb_ptr -> lcb.actual_input_iocbp, icode);
337                     if icode = 0
338                     then do;
339                               if temp_lcb_ptr -> lcb.prompt_flag
340                               then call ssu_$set_prompt_mode (static_sci_ptr, PROMPT | DONT_PROMPT_AFTER_NULL_LINES | PROMPT_IF_TYPEAHEAD);
341                          end;
342                     else if popped_on_pi
343                     then call ssu_$abort_subsystem (sci_ptr, icode);
344                     else code = icode;
345                end;
346 
347 
348      end linus_invoke;