1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1990   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(90-05-23,Gray), approve(90-05-23,MCR8175), audit(90-06-21,Huen),
 17      install(90-07-04,MR12.4-1019):
 18      Added cleanup handler to the condition handler to fix case where the
 19      condition command does a non-local goto.
 20                                                    END HISTORY COMMENTS */
 21 
 22 
 23 on:
 24      procedure () options (variable);
 25 
 26 /* This command/active function provides the capability to trap  conditions during
 27    the execution of a command line.  The user may specify a command line to be
 28    invoked on detection of the condition.
 29 
 30    Usage:           on conditions action_line {-control_args} subject_line
 31 
 32    */
 33 
 34 /* Rewritten 24 April 1978 by G. Palter */
 35 /* Modified 12/16/80, W. Olin Sibert, to add -retry_command_line control argument */
 36 /* Modified 83-06-16, T. Oke, to only trim whitespace from the software msg. */
 37 
 38           dcl     argument               character (argument_lth) based (argument_ptr);
 39           dcl     argument_lth           fixed binary (21);
 40           dcl     argument_ptr           pointer;
 41 
 42           dcl     return_value           character (return_value_lth) varying based (return_value_ptr);
 43           dcl     return_value_lth       fixed binary (21);
 44           dcl     return_value_ptr       pointer;
 45 
 46           dcl     active_function        bit (1) aligned;
 47           dcl     get_arg                entry (fixed binary (21), pointer, fixed binary (21), fixed binary (35)) variable;
 48           dcl     complain               entry () options (variable) variable;
 49 
 50           dcl     code                   fixed binary (35);
 51 
 52           dcl     argument_count         fixed binary (21);
 53 
 54           dcl     (have_condlist, have_action, in_command,
 55                   restart_sw, retry_sw, call_cl_sw, call_cp_sw, long_sw, brief_sw) bit (1) aligned;
 56 
 57           dcl     subject                character (subject_lth) aligned based (subject_ptr);
 58           dcl     subject_lth            fixed binary (21);
 59           dcl     subject_ptr            pointer;
 60 
 61           dcl     subject_used           fixed binary (21);
 62 
 63           dcl     first_subject          character (256) aligned;
 64 
 65           dcl     new_subject            character (new_subject_lth) aligned based (new_subject_ptr);
 66           dcl     new_subject_lth        fixed binary (21);
 67           dcl     new_subject_ptr        pointer;
 68 
 69           dcl     condlist               character (condlist_lth) based (condlist_ptr);
 70           dcl     condlist_lth           fixed binary (21);
 71           dcl     condlist_ptr           pointer;
 72 
 73           dcl     action                 character (action_lth) based (action_ptr);
 74           dcl     action_lth             fixed binary (21);
 75           dcl     action_ptr             pointer;
 76 
 77           dcl     exclude                character (exclude_lth) based (exclude_ptr);
 78           dcl     exclude_lth            fixed binary (21);
 79           dcl     exclude_ptr            pointer;
 80 
 81           dcl     system_area            area based (system_area_ptr);
 82           dcl     system_area_ptr        pointer;
 83 
 84           dcl     (idx, idx2, name_lth)  fixed binary (21);
 85 
 86           dcl     invocation_depth       fixed binary;
 87 
 88           dcl     WHITESPACE             character (5) static options (constant) initial ("
 89           ^K^L");                                                     /* NL SP HT VT FF */
 90           dcl     PUNCTUATION            character (2) static options (constant) initial (" ,");
 91           dcl     NL                     character (1) static options (constant) initial ("
 92 ");
 93 
 94           dcl     (error_table_$badopt,
 95                   error_table_$inconsistent,
 96                   error_table_$not_act_fnc,
 97                   error_table_$wrong_no_of_args) fixed binary (35) external;
 98 
 99           dcl     iox_$user_io           pointer external;
100 
101           dcl     active_fnc_err_        entry () options (variable);
102           dcl     com_err_               entry () options (variable);
103           dcl     condition_             entry (character (*), entry);
104           dcl     condition_interpreter_ entry (pointer, pointer, fixed binary (21), fixed binary,
105                                          pointer, character (*), pointer, pointer);
106           dcl     cu_$af_arg_ptr         entry (fixed binary (21), pointer, fixed binary (21), fixed binary (35));
107           dcl     cu_$af_return_arg      entry (fixed binary (21), pointer, fixed binary (21), fixed binary (35));
108           dcl     cu_$arg_count          entry (fixed binary (21));
109           dcl     cu_$arg_ptr            entry (fixed binary (21), pointer, fixed binary (21), fixed binary (35));
110           dcl     cu_$cl                 entry () options (variable);
111           dcl     cu_$cp                 entry (pointer, fixed binary (21), fixed binary (35));
112           dcl     get_system_free_area_  entry () returns (pointer);
113           dcl     ioa_$ioa_switch        entry () options (variable);
114 
115           dcl     (any_other, cleanup)   condition;
116 
117           dcl     (addr, empty, index, length, max, null, search, substr, verify) builtin;
118 ^L
119 
120 /* Initialization */
121 
122           call cu_$af_return_arg (argument_count, return_value_ptr, return_value_lth, code);
123 
124           if code = 0
125           then do;                                          /* invoked as an active function */
126                     active_function = "1"b;
127                     get_arg = cu_$af_arg_ptr;
128                     complain = active_fnc_err_;
129                     return_value = "false";                 /* assume nothin raised */
130                end;
131 
132           else if code = error_table_$not_act_fnc
133           then do;                                          /* command */
134                     active_function = "0"b;
135                     call cu_$arg_count (argument_count);
136                     get_arg = cu_$arg_ptr;
137                     complain = com_err_;
138                end;
139 
140           else do;                                          /* strange error */
141                     call com_err_ (code, "on");
142                     return;
143                end;
144 
145 
146           have_condlist,                                    /* seen list of conditions to trap */
147                have_action,                                 /* seen action to perfom */
148                in_command = "0"b;                           /* fetching subject line */
149 
150           subject_ptr = addr (first_subject);               /* use automatic space */
151           subject_lth = length (first_subject);
152 
153           first_subject = "";
154 
155           subject_used = 0;                                 /* empty at the moment */
156 
157           condlist_ptr,
158                action_ptr,
159                exclude_ptr = null ();
160 
161           condlist_lth,
162                action_lth,
163                exclude_lth = 0;                             /* list of conditions to exclude */
164 
165 
166           restart_sw,                                       /* automatic restart */
167                retry_sw,                                    /* retry the command line if the condition occurs */
168                call_cl_sw,                                  /* invoke the listener */
169                call_cp_sw,                                  /* have some action to perform */
170                long_sw,                                     /* print long message */
171                brief_sw = "0"b;                             /* print no messages */
172 
173 
174           system_area_ptr = get_system_free_area_ ();
175 
176 
177           on cleanup
178                begin;
179                     if subject_ptr ^= addr (first_subject) then
180                          free subject in (system_area);     /* free storage */
181                end;
182 ^L
183 
184 /* Process argument list */
185 
186           do idx = 1 to argument_count;
187 
188                call get_arg (idx, argument_ptr, argument_lth, code);
189                if code ^= 0 then do;
190                          call complain (code, "on", "Fetching argument #^d", idx);
191                          go to RETURN;
192                     end;
193 
194 
195                if in_command
196                then do;                                     /* in subject command line */
197 CLARG:
198                          if subject_used + argument_lth + 1 > subject_lth
199                          then do;                           /* must allocate more room for command line */
200                                    new_subject_lth = max ((2 * subject_lth), (subject_lth + argument_lth));
201                                    allocate new_subject in (system_area) set (new_subject_ptr);
202                                    new_subject = subject;
203                                    if subject_ptr ^= addr (first_subject) then
204                                         free subject in (system_area); /* free old copy */
205                                    subject_ptr = new_subject_ptr;
206                                    subject_lth = new_subject_lth;
207                               end;
208                          substr (subject, (subject_used + 1), argument_lth) = argument;
209                          subject_used = subject_used + argument_lth + 1;
210                     end;
211 
212 
213                else do;                                     /* process options, conditions, etc */
214 
215                          if substr (argument, 1, 1) = "-"
216                          then do;                           /* an option */
217                                    if (argument = "-restart") | (argument = "-rt")
218                                    then if retry_sw
219                                         then do;
220                                                   call complain (error_table_$inconsistent, "on", """-restart"" and ""-retry_command_line"".");
221                                                   goto RETURN;
222                                              end;
223                                         else restart_sw = "1"b;
224 
225                                    else if argument = "-cl"
226                                    then if active_function
227                                         then do;            /* -cl not allowed for active function */
228                                                   call complain (error_table_$badopt, "on", "Active function may not use ""-cl"".");
229                                                   go to RETURN;
230                                              end;
231                                         else call_cl_sw = "1"b;
232 
233                                    else if (argument = "-exclude") | (argument = "-ex")
234                                    then do;
235                                              idx = idx + 1; /* -exclude takes a list of conditions */
236                                              call get_arg (idx, argument_ptr, argument_lth, code);
237                                              if code ^= 0 then do;
238                                                        call complain (code, "on", "Condition list for ""-exclude"".");
239                                                        go to RETURN;
240                                                   end;
241                                              if exclude_ptr ^= null () then do;
242                                                        call complain (error_table_$wrong_no_of_args, "on", """-exclude"" may only be used once.");
243                                                        go to RETURN;
244                                                   end;
245                                              exclude_ptr = argument_ptr;
246                                              exclude_lth = argument_lth;
247                                         end;
248 
249                                    else if (argument = "-long") | (argument = "-lg")
250                                    then if brief_sw
251                                         then do;            /* -brief and -long */
252                                                   call complain (error_table_$inconsistent, "on", """-long"" and ""-brief"".");
253                                                   go to RETURN;
254                                              end;
255                                         else long_sw = "1"b;
256 
257                                    else if (argument = "-brief") | (argument = "-bf")
258                                    then if long_sw
259                                         then do;            /* -brief and -long */
260                                                   call complain (error_table_$inconsistent, "on", """-long"" and ""-brief"".");
261                                                   go to RETURN;
262                                              end;
263                                         else brief_sw = "1"b;
264 
265                                    else if (argument = "-retry_command_line") | (argument = "-rcl")
266                                    then if restart_sw
267                                         then do;
268                                                   call complain (error_table_$inconsistent, "on", """-restart"" and ""-retry_command_line"".");
269                                                   goto RETURN;
270                                              end;
271                                         else retry_sw = "1"b;
272 
273                                    else do;
274                                              call complain (error_table_$badopt, "on", """^a"".", argument);
275                                              go to RETURN;
276                                         end;
277                               end;
278 
279 
280                          else do;                           /* condition list, action, or start of subject */
281                                    if ^have_condlist
282                                    then do;
283                                              have_condlist = "1"b;
284                                              condlist_ptr = argument_ptr;
285                                              condlist_lth = argument_lth;
286                                         end;
287 
288                                    else if ^have_action
289                                    then do;
290                                              have_action = "1"b;
291                                              action_ptr = argument_ptr;
292                                              action_lth = argument_lth;
293                                         end;
294 
295                                    else do;
296                                              in_command = "1"b;
297                                              go to CLARG;
298                                         end;
299                               end;
300                     end;
301           end;
302 
303 
304           if subject_used = 0 then do;
305                     call complain (0, "on", "Usage:  on conditions action {-control_args} subject");
306                     go to RETURN;
307                end;
308 
309           subject_used = subject_used - 1;                  /* elimintate trailing space */
310 
311           if action_lth ^= 0
312           then if verify (action, WHITESPACE) ^= 0
313                then call_cp_sw = "1"b;                      /* actually something to do */
314 
315 
316 /* Set up handlers and invoke the subject line */
317 
318           idx = 1;
319 
320           do while (substr (condlist, idx) ^= "");          /* while something left */
321                name_lth = search (substr (condlist, idx), PUNCTUATION) - 1;
322                if name_lth < 0 then name_lth = length (condlist) - idx + 1; /* rest of list */
323 
324                call condition_ ((substr (condlist, idx, name_lth)), handler);
325 
326                idx = idx + name_lth;
327                idx2 = verify (substr (condlist, idx), PUNCTUATION) - 1;
328                if idx2 > 0 then idx = idx + idx2;
329           end;
330 
331 
332 RETRY_COMMAND:
333           invocation_depth = 0;                             /* nothing raised yet */
334 
335           call cu_$cp (addr (subject), subject_used, (0));
336 
337 
338 RETURN:
339           if subject_ptr ^= addr (first_subject) then
340                free subject in (system_area);
341 
342           return;
343 ^L
344 
345 handler:
346      procedure (mc_ptr, condition_name, wc_ptr, info_ptr, continue_sw);
347 
348 /* This internal procedure is invoked to handle any of the conditions being
349    trapped.  It process all control arguments.
350    */
351 
352           dcl     mc_ptr                 pointer;           /* machine conditions */
353           dcl     condition_name         character (*);     /* the conditions raised */
354           dcl     wc_ptr                 pointer;           /* wall crossing */
355           dcl     info_ptr               pointer;           /* software information */
356           dcl     continue_sw            bit (1);           /* ON if the condition should continue up */
357 
358 %include condition_info_header;
359 
360           dcl     1 software_data        aligned like condition_info_header based (info_ptr);
361 
362           dcl     small_area             area;
363           dcl     (idx, idx2, idx3)      fixed binary (21);
364           dcl     name_lth               fixed binary (21);
365 
366           dcl     error_msg              character (error_msg_lth) based (error_msg_ptr);
367           dcl     error_msg_lth          fixed binary (21);
368           dcl     error_msg_ptr          pointer;
369 
370           dcl     old_invocation_depth  fixed binary;
371 
372           dcl     software_msg           character (256) varying;
373 
374           dcl     length                 builtin;
375 
376 
377 /* Scan exclude list to see if we should ignore this condition */
378 
379           if exclude_lth ^= 0 then do;
380                     idx = 1;
381 
382                     do while (substr (exclude, idx) ^= "");
383                          name_lth = search (substr (exclude, idx), PUNCTUATION) - 1;
384                          if name_lth < 0 then name_lth = length (exclude) - idx + 1; /* rest of list */
385 
386                          if condition_name = substr (exclude, idx, name_lth) then do;
387                                    continue_sw = "1"b;      /* give it to superiors */
388                                    return;
389                               end;
390 
391                          idx = idx + name_lth;
392                          idx2 = verify (substr (exclude, idx), PUNCTUATION) - 1;
393                          if idx2 > 0 then idx = idx + idx2;
394                     end;
395                end;
396 
397 
398 /* Print a message if requested */
399 
400           if ^brief_sw then do;
401                     software_msg = "";
402 
403                     if info_ptr ^= null then
404                          if software_data.version >= 1 then
405                               if length (software_data.info_string) > 0 then do;
406                                         software_msg = software_data.info_string;
407                                         if verify (substr (software_msg, length (software_msg), 1), WHITESPACE) = 0 then
408                                              software_msg = substr (software_msg, 1, length (software_msg) - 1);
409                                    end;
410 
411                     call ioa_$ioa_switch (iox_$user_io, "on:  Condition ""^a"" raised.  ^a",
412                          condition_name, software_msg);
413                end;
414 
415 
416 /* Check for recursive signalling */
417 
418           old_invocation_depth = invocation_depth;
419 on        cleanup invocation_depth = old_invocation_depth;
420           invocation_depth = invocation_depth + 1;
421 
422           if invocation_depth > 2 then go to RETURN;        /* bad loop */
423           else if invocation_depth > 1 then do;
424                     call ioa_$ioa_switch (iox_$user_io, "on:  Recursive signalling of ""^a"".", condition_name);
425                     go to RETURN;
426                end;
427 
428 
429 /* If an active function, indicate a condition was trapped */
430 
431           if active_function then
432                return_value = "true";
433 
434 
435 /* Print detailed information if requested */
436 
437           if long_sw then do;
438                     call condition_interpreter_ (addr (small_area), error_msg_ptr, error_msg_lth,
439                          3, mc_ptr, condition_name, wc_ptr, info_ptr);
440 
441                     idx = 1;
442                     idx2 = index (error_msg, "Error");      /* trim the message somewhat */
443                     if (idx2 > 0) & (idx2 < 4) then
444                          idx = idx2 + 6;
445 
446                     idx2 = verify (substr (error_msg, idx), " ");
447                     if idx2 > 0 then
448                          idx = idx + idx2 - 1;
449 
450                     idx2 = idx;
451                     do idx3 = idx to error_msg_lth;
452                          if substr (error_msg, idx3, 1) = NL then do;
453                                    call ioa_$ioa_switch (iox_$user_io, "^a", substr (error_msg, idx2, idx3 - idx2));
454                                    idx2 = idx3 + 1;
455                               end;
456                     end;
457                end;                                         /* no need to free it as the area is in automatic */
458 
459 
460 /* Invoke the action command line, call the listener, and restart */
461 
462           if call_cp_sw then
463                call cu_$cp (action_ptr, action_lth, (0));
464 
465           invocation_depth = old_invocation_depth;
466 
467           if call_cl_sw then do;
468                     on any_other system;
469                     call cu_$cl ((36)"0"b);
470                     revert any_other;
471                end;
472 
473           if restart_sw then
474                if info_ptr = null () then
475                     return;                                 /* can probably restart */
476                else if software_data.cant_restart then
477                     call ioa_$ioa_switch (iox_$user_io, "on:  Can not restart ""^a"".", condition_name);
478                else return;
479 
480           if retry_sw then /* Try the command line again */
481                goto RETRY_COMMAND;
482 
483           go to RETURN;                                     /* abort */
484 
485      end handler;
486 
487      end on;