1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61 do:
62 procedure () options (variable);
63
64 declare P_info_ptr ptr parameter,
65 P_sci_ptr ptr parameter;
66
67 declare (addcharno, addr, addwordno, binary, copy, divide, hbound, index, lbound, length, ltrim, maxlength, min, mod,
68 null, rtrim, substr, verify) builtin;
69
70 declare (active_function_error, any_other, area, cleanup)
71 condition;
72
73 declare abort_line bit (1) aligned,
74 allocated_buffer_max_len fixed bin (21),
75 allocated_buffer_ptr ptr,
76 arg_count fixed bin (17),
77 arg_list_ptr ptr,
78 arg_offset fixed bin (17),
79 entrypoint fixed bin (2),
80 error_value_len fixed bin (21),
81 error_value_ptr ptr,
82 execute bit (1) aligned,
83 expansion_buffer char (256) varying,
84 expansion_max_len fixed bin (21),
85 expansion_ptr ptr,
86 inhibit_error bit (1) aligned,
87 rescan_type fixed bin (17),
88 return_value_max_len fixed bin (21),
89 return_value_ptr ptr,
90 sci_ptr ptr,
91 status fixed bin (35),
92 trace bit (1) aligned,
93 unique char (15) aligned;
94
95 declare allocated_buffer char (allocated_buffer_max_len) varying based (allocated_buffer_ptr),
96 command char (length (expansion)) based (addwordno (addr (expansion), 1)),
97 expansion char (expansion_max_len) varying based (expansion_ptr),
98 return_value char (return_value_max_len) varying based (return_value_ptr),
99 system_area area based (get_system_free_area_ ());
100
101 declare abort_line_mode (2) bit (1) aligned static initial ((2) ("1"b)),
102 execute_mode (2) bit (1) aligned static initial ((2) ("1"b)),
103 inhibit_error_mode (2) bit (1) aligned static initial ((2) ("0"b)),
104 trace_mode (3) bit (1) aligned static initial ((3) ("0"b));
105
106 declare AMPERSAND char (1) static options (constant) initial ("&"),
107 BLANK char (1) static options (constant) initial (" "),
108 QUOTE char (1) static options (constant) initial (""""),
109 WHITE char (5) static options (constant) initial ("^L^K
110 ");
111
112 declare (
113 DO_ENTRY initial (1),
114 EXECUTE_ENTRY initial (2),
115 SUBSTITUTE_ENTRY initial (3)
116 ) fixed bin (2) static options (constant);
117
118 declare (
119 ILLEGAL_CHARACTER initial (1),
120 ILLEGAL_END_CONTROL_STRING initial (2),
121 ILLEGAL_END_ERROR_VALUE initial (3),
122 ILLEGAL_INTEGER initial (4),
123 ILLEGAL_KEYWORD initial (5),
124 ILLEGAL_UNCLOSED initial (6)
125 ) fixed bin (3) static options (constant);
126
127 declare (
128 NO_QUOTE_MODIFIER initial (1),
129 PROTECT_QUOTES_MODIFIER initial (2),
130 REQUOTE_MODIFIER initial (3)
131 ) fixed bin (2) static options (constant);
132
133 declare MY_NAME (3) char (20) static options (constant)
134 initial ("do", "execute_string", "substitute_arguments"),
135 MY_SHORT_NAME (3) char (4) varying static options (constant) initial ("do", "exs", "sbag");
136
137 declare (
138 PARSER_EXPLICIT_CONTROL_STRING
139 initial (1),
140 PARSER_FOUND_CONTROL_STRING initial (2),
141 PARSER_WANTS_CONTROL_STRING initial (3),
142 PARSER_WANTS_ERROR_VALUE initial (4)
143 ) fixed bin (3) static options (constant);
144
145 declare REASONS (6) char (85) varying static options (constant)
146 initial ("An invalid character terminates substitution construct ^a.",
147 "Substitution construct ^a is incomplete at the end of the control string.",
148 "Substitution construct ^a is incomplete at the end of the error value.",
149 "The parenthesized part of substitution construct ^a must be an unsigned integer.",
150 "^a is not a valid substitution construct.",
151 "There is no "")"" terminating substitution construct ^a.");
152
153 declare SPECIAL_CONDITIONS (5) char (24) varying static options (constant)
154 initial ("alrm", "cput", "quit", "program_interrupt", "record_quota_overflow");
155
156 declare (
157 COMMAND_USAGE char (39) initial ("{-control_args} {control_string {args}}"),
158 EXS_AF_USAGE char (37) initial ("{-control_args} control_string {args}"),
159 SBAG_AF_USAGE char (21) initial ("control_string {args}") char (21)
160 ) static options (constant);
161
162 declare NO_FROM_WARNING char (95) static options (constant)
163 initial ("""&^[q^;r^]f&n"" must be used instead of argument designator ^a.^[
164 Type ""start"" to continue.^]");
165
166 declare TRUNCATION_WARNING char (127) static options (constant) initial ("
167 Only the first ^d characters of the expanded ^[error value^;control string^]
168 can be returned.^[ Type ""start"" to continue.^]");
169
170 declare (
171 error_table_$badopt,
172 error_table_$command_line_overflow,
173 error_table_$inconsistent,
174 error_table_$noarg,
175 error_table_$not_act_fnc,
176 ssu_et_$null_request_line,
177 ssu_et_$request_line_aborted,
178 ssu_et_$subsystem_aborted
179 ) fixed bin (35) external;
180
181 declare iox_$error_output ptr external;
182
183 declare active_fnc_err_ entry () options (variable),
184 active_fnc_err_$suppress_name entry () options (variable),
185 com_err_ entry () options (variable),
186 com_err_$suppress_name entry () options (variable),
187 condition_interpreter_ entry (ptr, ptr, fixed bin (17), fixed bin (17), ptr, char (*), ptr, ptr),
188 continue_to_signal_ entry (fixed bin (35)),
189 cu_$af_return_arg_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
190 cu_$arg_list_ptr entry () returns (ptr),
191 cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
192 cu_$cp entry (ptr, fixed bin (21), fixed bin (35)),
193 cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35)),
194 find_condition_info_ entry (ptr, ptr, fixed bin (35)),
195 get_system_free_area_ entry () returns (ptr),
196 ioa_ entry () options (variable),
197 ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
198 bit (1) aligned),
199 ioa_$ioa_switch entry () options (variable),
200 requote_string_ entry (char (*)) returns (char (*)),
201 ssu_$abort_line entry () options (variable),
202 ssu_$abort_subsystem entry () options (variable),
203 ssu_$arg_ptr entry (ptr, fixed bin (17), ptr, fixed bin (21)),
204 ssu_$evaluate_active_string entry (ptr, ptr, char (*), fixed bin (17), char (*) var, fixed bin (35)),
205 ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35)),
206 ssu_$get_subsystem_and_request_name
207 entry (ptr) returns (char (72) varying),
208 ssu_$get_request_name entry (ptr) returns (char (32)),
209 ssu_$print_message entry () options (variable),
210 ssu_$return_arg entry (ptr, fixed bin (17), bit (1) aligned, ptr, fixed bin (21)),
211 unique_chars_ entry (bit (*) aligned) returns (char (15) aligned);
212 %page;
213 %include condition_info;
214 %page;
215 %include cp_active_string_types;
216 %page;
217
218
219 entrypoint = DO_ENTRY;
220
221 go to STANDALONE;
222
223 exs:
224 execute_string:
225 entry () options (variable);
226
227 entrypoint = EXECUTE_ENTRY;
228
229 go to STANDALONE;
230
231 sbag:
232 substitute_args:
233 substitute_arguments:
234 entry () options (variable);
235
236 entrypoint = SUBSTITUTE_ENTRY;
237
238 STANDALONE:
239 sci_ptr = null ();
240
241 go to COMMON;
242
243 ssu_do_request_:
244 entry (P_sci_ptr, P_info_ptr);
245
246 entrypoint = DO_ENTRY;
247
248 go to SUBSYSTEM;
249
250 ssu_execute_string_request_:
251 entry (P_sci_ptr, P_info_ptr);
252
253 entrypoint = EXECUTE_ENTRY;
254
255 go to SUBSYSTEM;
256
257 ssu_substitute_args_request_:
258 entry (P_sci_ptr, P_info_ptr);
259
260 entrypoint = SUBSTITUTE_ENTRY;
261
262 SUBSYSTEM:
263 sci_ptr = P_sci_ptr;
264
265 go to COMMON;
266 %page;
267
268
269 COMMON:
270 allocated_buffer_max_len, error_value_len = 0;
271 allocated_buffer_ptr, arg_list_ptr, error_value_ptr = null ();
272 expansion_max_len = maxlength (expansion_buffer);
273 expansion_ptr = addr (expansion_buffer);
274 trace = trace_mode (entrypoint);
275 unique = "";
276
277 on cleanup
278 begin;
279 if allocated_buffer_ptr ^= null () then free allocated_buffer in (system_area);
280 end;
281
282 if sci_ptr = null ()
283 then call check_arguments (cu_$arg_list_ptr ());
284 else call ssu_$return_arg (sci_ptr, arg_count, ("0"b), return_value_ptr, return_value_max_len);
285
286 if return_value_ptr = null ()
287 then go to COMMAND (entrypoint);
288 else go to FUNCTION (entrypoint);
289
290 COMMAND (1):
291 COMMAND (2):
292 call execute_string_command ();
293
294 if ^execute then go to EGRESS;
295
296 if inhibit_error then on any_other call any_other_handler ();
297
298 if sci_ptr = null ()
299 then call cu_$cp (addr (command), length (command), status);
300 else call ssu_$execute_line (sci_ptr, addr (command), length (command), status);
301
302 revert any_other;
303
304 if status ^= 0 then call execute_string_command_error ();
305
306 go to EGRESS;
307
308 COMMAND (3):
309 call substitute_args_command ();
310
311 EGRESS:
312 revert active_function_error, any_other;
313
314 if allocated_buffer_ptr ^= null () then free allocated_buffer in (system_area);
315
316 return;
317 %page;
318 FUNCTION (1):
319 FUNCTION (3):
320 call substitute_args_function ();
321
322 go to EGRESS;
323
324 FUNCTION (2):
325 call execute_string_function ();
326
327 if error_value_ptr ^= null ()
328 then do;
329 if sci_ptr = null () then on active_function_error call active_function_error_handler ();
330 if inhibit_error then on any_other call any_other_handler ();
331 end;
332
333 if sci_ptr = null ()
334 then call cu_$evaluate_active_string (null (), command, rescan_type, return_value, status);
335 else call ssu_$evaluate_active_string (sci_ptr, null (), command, rescan_type, return_value, status);
336
337 revert active_function_error, any_other;
338
339 if status ^= 0 then call execute_string_function_error ();
340
341 go to EGRESS;
342
343 SUBSTITUTE_ERROR_VALUE:
344 revert active_function_error, any_other;
345
346 call expand_error_value ();
347
348 go to EGRESS;
349 %page;
350
351
352
353
354 active_function_error_handler:
355 procedure ();
356
357 declare 1 CI aligned like condition_info;
358
359 if trace
360 then do;
361 CI.version = condition_info_version_1;
362 call find_condition_info_ (null (), addr (CI), (0));
363 call condition_interpreter_ (null (), null (), 0, 0, CI.mc_ptr, (CI.condition_name), CI.wc_ptr,
364 CI.info_ptr);
365 end;
366
367 go to SUBSTITUTE_ERROR_VALUE;
368
369 end active_function_error_handler;
370 %page;
371
372
373
374
375 any_other_handler:
376 procedure ();
377
378 declare conditionx fixed bin (17);
379
380 declare 1 CI aligned like condition_info;
381
382 CI.version = condition_info_version_1;
383 call find_condition_info_ (null (), addr (CI), (0));
384
385 if length (CI.condition_name) > length ("command_")
386 then if substr (CI.condition_name, 1, length ("command_")) = "command_" then go to CONTINUE;
387
388 do conditionx = lbound (SPECIAL_CONDITIONS, 1) to hbound (SPECIAL_CONDITIONS, 1);
389
390 if CI.condition_name = SPECIAL_CONDITIONS (conditionx) then go to CONTINUE;
391 end;
392
393 if return_value_ptr = null () | trace
394 then call condition_interpreter_ (null (), null (), 0, 0, CI.mc_ptr, (CI.condition_name), CI.wc_ptr,
395 CI.info_ptr);
396
397 if error_value_ptr ^= null ()
398 then go to SUBSTITUTE_ERROR_VALUE;
399 else go to EGRESS;
400
401 CONTINUE:
402 call continue_to_signal_ ((0));
403
404 return;
405
406 end any_other_handler;
407 %page;
408
409
410 check_arguments:
411 procedure (P_arg_list_ptr) options (non_quick);
412
413 declare P_arg_list_ptr ptr parameter;
414
415 arg_list_ptr = P_arg_list_ptr;
416
417 call cu_$af_return_arg_rel (arg_count, return_value_ptr, return_value_max_len, status, arg_list_ptr);
418 if status = 0 then return;
419 if status = error_table_$not_act_fnc then return;
420
421 call com_err_ (status, MY_NAME (entrypoint), "Can't get argument count.");
422
423 go to EGRESS;
424
425 end check_arguments;
426 %page;
427 execute_string_command:
428 procedure () options (non_quick);
429
430 declare arg_len fixed bin (21),
431 arg_ptr ptr,
432 argx fixed bin (17),
433 control_string_len fixed bin (21),
434 control_string_ptr ptr,
435 parser fixed bin (3),
436 saved_parser fixed bin (3);
437
438 declare arg char (arg_len) based (arg_ptr),
439 control_string char (control_string_len) based (control_string_ptr);
440
441 if arg_count = 0 then call usage (COMMAND_USAGE);
442
443 abort_line = abort_line_mode (entrypoint);
444 execute = execute_mode (entrypoint);
445 inhibit_error = inhibit_error_mode (entrypoint);
446 parser = PARSER_WANTS_CONTROL_STRING;
447
448 do argx = 1 to arg_count while (parser ^= PARSER_FOUND_CONTROL_STRING);
449
450 call get_argument (argx);
451
452 if parser = PARSER_EXPLICIT_CONTROL_STRING then parser = PARSER_FOUND_CONTROL_STRING;
453 else if substr (arg, 1, min (1, length (arg))) = "-"
454 then if arg = "-abort_line" | arg = "-abl" then abort_line = "1"b;
455 else if arg = "-brief" | arg = "-bf" then trace = "0"b;
456 else if arg = "-control_string" | arg = "-cs" then parser = PARSER_EXPLICIT_CONTROL_STRING;
457 else if arg = "-go" then execute = "1"b;
458 else if arg = "-inhibit_error" | arg = "-ihe" | arg = "-absentee" | arg = "-abs"
459 then inhibit_error = "1"b;
460 else if arg = "-long" | arg = "-lg" then trace = "1"b;
461 else if arg = "-no_abort_line" | arg = "-nabl" then abort_line = "0"b;
462 else if arg = "-no_go" | arg = "-nogo" then execute = "0"b;
463 else if arg = "-no_inhibit_error" | arg = "-nihe" | arg = "-interactive" | arg = "-ia"
464 then inhibit_error = "0"b;
465 else go to BADOPT;
466 else parser = PARSER_FOUND_CONTROL_STRING;
467 end;
468
469 if parser = PARSER_WANTS_CONTROL_STRING
470 then do;
471 abort_line_mode (entrypoint) = abort_line;
472 execute_mode (entrypoint) = execute;
473 inhibit_error_mode (entrypoint) = inhibit_error;
474 trace_mode (entrypoint) = trace;
475 go to EGRESS;
476 end;
477
478 if parser ^= PARSER_FOUND_CONTROL_STRING then go to NOARG;
479
480 arg_offset = argx - 1;
481
482 call expand ();
483
484 return;
485 %page;
486 execute_string_function:
487 entry ();
488
489 inhibit_error = "0"b;
490 parser = PARSER_WANTS_CONTROL_STRING;
491 rescan_type = ATOMIC_ACTIVE_STRING;
492
493 do argx = 1 to arg_count while (parser ^= PARSER_FOUND_CONTROL_STRING);
494
495 call get_argument (argx);
496
497 if parser = PARSER_EXPLICIT_CONTROL_STRING then parser = PARSER_FOUND_CONTROL_STRING;
498 else if parser = PARSER_WANTS_ERROR_VALUE
499 then do;
500 error_value_len = arg_len;
501 error_value_ptr = arg_ptr;
502 parser = saved_parser;
503 end;
504 else if substr (arg, 1, min (1, length (arg))) = "-"
505 then if arg = "-brief" | arg = "-bf" then trace = "0"b;
506 else if arg = "-control_string" | arg = "-cs" then parser = PARSER_EXPLICIT_CONTROL_STRING;
507 else if arg = "-error_value" | arg = "-erv"
508 then do;
509 saved_parser = parser;
510 parser = PARSER_WANTS_ERROR_VALUE;
511 end;
512 else if arg = "-inhibit_error" | arg = "-ihe" then inhibit_error = "1"b;
513 else if arg = "-long" | arg = "-lg" then trace = "1"b;
514 else if arg = "-no_inhibit_error" | arg = "-nihe" then inhibit_error = "0"b;
515 else if arg = "-no_rescan" | arg = "-nrsc" then rescan_type = ATOMIC_ACTIVE_STRING;
516 else if arg = "-rescan" | arg = "-rsc" then rescan_type = NORMAL_ACTIVE_STRING;
517 else if arg = "-rescan_tokens" | arg = "-rsct" then rescan_type = TOKENS_ONLY_ACTIVE_STRING;
518 else go to BADOPT;
519 else parser = PARSER_FOUND_CONTROL_STRING;
520 end;
521
522 if parser = PARSER_WANTS_CONTROL_STRING then call usage (EXS_AF_USAGE);
523
524 if parser ^= PARSER_FOUND_CONTROL_STRING then go to NOARG;
525
526 if error_value_ptr = null () & inhibit_error
527 then call error (error_table_$inconsistent, "-inhibit_error without -error_value");
528
529 if error_value_ptr ^= null () then inhibit_error = inhibit_error | inhibit_error_mode (entrypoint);
530
531 arg_offset = argx - 1;
532
533 call expand ();
534
535 return;
536 %page;
537 execute_string_command_error:
538 entry ();
539
540 if sci_ptr = null ()
541 then do;
542 if status = 100 | ^trace then return;
543 end;
544 else if status = ssu_et_$null_request_line then return;
545 else if status = ssu_et_$subsystem_aborted then call ssu_$abort_subsystem (sci_ptr);
546 else if status = ssu_et_$request_line_aborted & ^trace
547 then if abort_line
548 then call ssu_$abort_line (sci_ptr);
549 else return;
550
551 if abort_line then call error (status, "Executing ^a.", requote_string_ (command));
552
553 call warn (status, "Executing ^a.", requote_string_ (command));
554
555 return;
556
557 execute_string_function_error:
558 entry ();
559
560 if error_value_ptr = null ()
561 then do;
562 if status = error_table_$command_line_overflow
563 then do;
564 call warn (status, "Result truncated to ^d characters^[ evaluating ^a^].",
565 return_value_max_len, trace, requote_string_ (command));
566 return;
567 end;
568
569 if sci_ptr ^= null ()
570 then if status = ssu_et_$subsystem_aborted then call ssu_$abort_subsystem (sci_ptr);
571 else if status = ssu_et_$request_line_aborted & ^trace then call ssu_$abort_line (sci_ptr);
572
573 if trace then call error (status, "Evaluating ^a.", requote_string_ (command));
574
575 return;
576 end;
577
578 expand_error_value:
579 entry ();
580
581 arg_len = error_value_len;
582 arg_ptr = error_value_ptr;
583
584 expansion_max_len = return_value_max_len;
585 expansion_ptr = return_value_ptr;
586
587 call expand ();
588
589 return;
590 %page;
591
592
593
594
595
596
597 substitute_args_command:
598 entry ();
599
600 if arg_count = 0 then call usage (COMMAND_USAGE);
601
602 parser = PARSER_WANTS_CONTROL_STRING;
603
604 do argx = 1 to arg_count while (parser ^= PARSER_FOUND_CONTROL_STRING);
605
606 call get_argument (argx);
607
608 if parser = PARSER_EXPLICIT_CONTROL_STRING then parser = PARSER_FOUND_CONTROL_STRING;
609 else if substr (arg, 1, min (1, length (arg))) = "-"
610 then if arg = "-brief" | arg = "-bf" then trace = "0"b;
611 else if arg = "-control_string" | arg = "-cs" then parser = PARSER_EXPLICIT_CONTROL_STRING;
612 else if arg = "-long" | arg = "-lg" then trace = "1"b;
613 else go to BADOPT;
614 else parser = PARSER_FOUND_CONTROL_STRING;
615 end;
616
617 if parser = PARSER_WANTS_CONTROL_STRING
618 then do;
619 trace_mode (entrypoint) = trace;
620 go to EGRESS;
621 end;
622
623 if parser ^= PARSER_FOUND_CONTROL_STRING then go to NOARG;
624
625 arg_offset = argx - 1;
626
627 call expand ();
628
629 call ioa_ ("^a", expansion);
630
631 return;
632 %page;
633
634
635
636
637
638
639 substitute_args_function:
640 entry ();
641
642 if arg_count = 0 then call usage (SBAG_AF_USAGE);
643
644 arg_offset, argx = 1;
645
646 call get_argument (argx);
647
648 expansion_max_len = return_value_max_len;
649 expansion_ptr = return_value_ptr;
650
651 call expand ();
652
653 return;
654
655 BADOPT:
656 call error (error_table_$badopt, "^a", requote_string_ (arg));
657
658 NOARG:
659 call error (error_table_$noarg, "Following ^a.", requote_string_ (arg));
660 %page;
661 error:
662 procedure () options (variable);
663
664 declare arg_list_ptr ptr,
665 buffer char (256),
666 buffer_used fixed bin (21),
667 fatal bit (1) aligned,
668 status_ptr ptr;
669
670 declare buffer_overlay char (buffer_used) based (addr (buffer)),
671 status fixed bin (35) based (status_ptr);
672
673 fatal = "1"b;
674
675 go to COMMON;
676
677 warn:
678 entry () options (variable);
679
680 fatal = "0"b;
681
682 COMMON:
683 arg_list_ptr = cu_$arg_list_ptr ();
684 call cu_$arg_ptr_rel (1, status_ptr, (0), (0), arg_list_ptr);
685 call ioa_$general_rs (arg_list_ptr, 2, 3, buffer, buffer_used, "0"b, "0"b);
686
687 if sci_ptr = null ()
688 then do;
689 if return_value_ptr = null ()
690 then call com_err_ (status, MY_NAME (entrypoint), "^a", buffer_overlay);
691 else call active_fnc_err_ (status, MY_NAME (entrypoint), "^a", buffer_overlay);
692 if fatal then go to EGRESS;
693 end;
694 else if fatal then call ssu_$abort_line (sci_ptr, status, "^a", buffer_overlay);
695 else call ssu_$print_message (sci_ptr, status, "^a", buffer_overlay);
696
697 return;
698
699 end error;
700 %page;
701
702
703
704
705
706
707
708 expand:
709 procedure ();
710
711 declare buffer_overflow bit (1) aligned,
712 command_name char (72) varying,
713 construct_pos fixed bin (21),
714 control_string_pos fixed bin (21),
715 nstring picture "zzzz9",
716 from_sw bit (1) aligned,
717 parm_count fixed bin (17),
718 quote_multiplier fixed bin (21),
719 quote_scan_pos fixed bin (21),
720 requote_last bit (1) aligned,
721 requote_sw fixed bin (2),
722 skip fixed bin (21),
723 string_len fixed bin (21),
724 string_ptr ptr;
725
726 declare construct char (control_string_pos - construct_pos)
727 based (addcharno (addr (control_string), construct_pos)),
728 string char (string_len) based (string_ptr);
729
730 buffer_overflow, from_sw = "0"b;
731 control_string_len = arg_len;
732 control_string_pos, quote_scan_pos = 0;
733 control_string_ptr = arg_ptr;
734 expansion = "";
735 parm_count = arg_count - arg_offset;
736 quote_multiplier = 1;
737 requote_last = "0"b;
738 requote_sw = NO_QUOTE_MODIFIER;
739
740 do while (control_string_pos < length (control_string));
741
742 string_len = index (substr (control_string, control_string_pos + 1), AMPERSAND) - 1;
743 if string_len < 0 then string_len = length (control_string) - control_string_pos;
744
745 if string_len > 0
746 then do;
747 string_ptr = addcharno (control_string_ptr, control_string_pos);
748 call add_string ();
749 control_string_pos = control_string_pos + string_len;
750 end;
751
752 if control_string_pos >= length (control_string) then go to EXPANDED;
753
754 construct_pos = control_string_pos;
755 control_string_pos = control_string_pos + length (AMPERSAND) + 1;
756
757 if control_string_pos > length (control_string) then go to END;
758
759 argx = index ("0123456789!(&&cfnqr", substr (control_string, control_string_pos, 1)) - 1;
760 go to DISPATCH (argx);
761
762 DISPATCH (-1):
763 call illegal (ILLEGAL_CHARACTER);
764
765 DISPATCH (0):
766 DISPATCH (1):
767 DISPATCH (2):
768 DISPATCH (3):
769 DISPATCH (4):
770 DISPATCH (5):
771 DISPATCH (6):
772 DISPATCH (7):
773 DISPATCH (8):
774 DISPATCH (9):
775 if from_sw
776 then do;
777 if argx = 0 then argx = 1;
778
779 from_sw = "0"b;
780
781 do argx = argx to parm_count;
782
783 call expand_arg ();
784
785 if argx < parm_count
786 then do;
787 string_len = length (BLANK);
788 string_ptr = addr (BLANK);
789 call add_string ();
790 end;
791 end;
792 end;
793 else if argx <= parm_count then call expand_arg ();
794
795 requote_sw = NO_QUOTE_MODIFIER;
796
797 go to SCAN_NEXT;
798
799 DISPATCH (10):
800 if unique = "" then unique = unique_chars_ (""b);
801 string_len = length (unique);
802 string_ptr = addr (unique);
803 call add_string ();
804 go to SCAN_NEXT;
805
806 DISPATCH (11):
807 string_len = index (substr (control_string, control_string_pos + 1), ")") - 1;
808 if string_len < 0 then call illegal (ILLEGAL_UNCLOSED);
809 string_ptr = addcharno (control_string_ptr, control_string_pos);
810 control_string_pos = control_string_pos + string_len + length (")");
811
812 string_len = length (rtrim (string, WHITE));
813 if string_len = 0 then call illegal (ILLEGAL_INTEGER);
814
815 skip = verify (string, WHITE) - 1;
816 string_len = string_len - skip;
817 string_ptr = addcharno (string_ptr, skip);
818 if verify (string, "0123456789") ^= 0 then call illegal (ILLEGAL_INTEGER);
819 if length (ltrim (string, "0")) > 5
820 then argx = parm_count + 1;
821 else argx = binary (string, 17, 0);
822
823 go to DISPATCH (0);
824
825 DISPATCH (12):
826 string_len = length (AMPERSAND);
827 string_ptr = addr (AMPERSAND);
828 call add_string ();
829
830 go to SCAN_NEXT;
831
832 DISPATCH (13):
833 if control_string_pos + length ("n") > length (control_string) then go to END;
834 control_string_pos = control_string_pos + length ("n");
835 if substr (control_string, control_string_pos, length ("n")) ^= "n"
836 then call illegal (ILLEGAL_CHARACTER);
837
838 if ^from_sw
839 then do;
840 call warn (0, NO_FROM_WARNING, requote_sw = PROTECT_QUOTES_MODIFIER,
841 requote_string_ (construct), return_value_ptr ^= null () & sci_ptr = null ());
842 from_sw = "1"b;
843 end;
844
845 argx = parm_count;
846
847 go to DISPATCH (0);
848
849 DISPATCH (14):
850 control_string_pos = control_string_pos + length ("ontrol_string");
851 if control_string_pos > length (control_string) then call illegal (ILLEGAL_KEYWORD);
852 if substr (control_string, construct_pos + 2, length ("control_string")) ^= "control_string"
853 then call illegal (ILLEGAL_KEYWORD);
854
855 argx = 0;
856 requote_sw = PROTECT_QUOTES_MODIFIER;
857
858 go to DISPATCH (0);
859
860 DISPATCH (15):
861 from_sw = "1"b;
862
863 if control_string_pos >= length (control_string) then go to END;
864 control_string_pos = control_string_pos + 1;
865
866 argx = index ("01234567899((&", substr (control_string, control_string_pos, 1)) - 1;
867 go to DISPATCH (argx);
868
869 DISPATCH (16):
870 nstring = parm_count;
871 string_len = verify (nstring, BLANK) - 1;
872 string_ptr = addcharno (addr (nstring), string_len);
873 string_len = length (nstring) - string_len;
874 call add_string ();
875
876 go to SCAN_NEXT;
877
878 DISPATCH (17):
879 requote_sw = PROTECT_QUOTES_MODIFIER;
880 go to AFTER_QUOTE_MODIFIER;
881
882 DISPATCH (18):
883 requote_sw = REQUOTE_MODIFIER;
884
885 AFTER_QUOTE_MODIFIER:
886 if control_string_pos >= length (control_string) then go to END;
887 control_string_pos = control_string_pos + 1;
888
889 argx = index ("01234567899((&&f", substr (control_string, control_string_pos, 1)) - 1;
890 go to DISPATCH (argx);
891
892 SCAN_NEXT:
893 end;
894
895
896
897
898 EXPANDED:
899 if trace
900 then do;
901 if sci_ptr = null ()
902 then command_name = MY_NAME (entrypoint);
903 else command_name = ssu_$get_subsystem_and_request_name (sci_ptr);
904 call ioa_$ioa_switch (iox_$error_output, "^[[^a^[ -error_value^]]^;^a^s^]: (^d) ^a",
905 return_value_ptr ^= null (), command_name,
906 return_value_ptr = expansion_ptr & entrypoint = EXECUTE_ENTRY, length (command),
907 requote_string_ (command));
908 end;
909
910 return;
911
912
913
914
915
916
917 END:
918 if entrypoint = EXECUTE_ENTRY & expansion_ptr = return_value_ptr
919 then call illegal (ILLEGAL_END_ERROR_VALUE);
920 else call illegal (ILLEGAL_END_CONTROL_STRING);
921 %page;
922
923
924
925
926
927 add_quotes:
928 procedure ();
929
930 declare old_len fixed bin (21);
931
932 declare 1 expansion_overlay aligned based (expansion_ptr),
933 2 len fixed bin (21),
934 2 str char (0 refer (expansion_overlay.len));
935
936 call check_buffer ();
937
938 old_len = expansion_overlay.len;
939 expansion_overlay.len = expansion_overlay.len + string_len;
940 substr (expansion_overlay.str, old_len + 1, string_len) = copy (QUOTE, string_len);
941
942 if buffer_overflow then go to EXPANDED;
943
944 return;
945
946 add_string:
947 entry ();
948
949 call check_buffer ();
950
951 expansion = expansion || string;
952
953 if buffer_overflow then go to EXPANDED;
954
955 return;
956
957 end add_quotes;
958 %page;
959
960
961
962
963 allocate_buffer:
964 procedure ();
965
966 declare new_buffer_ptr ptr,
967 old_buffer_max_len fixed bin (21);
968
969 new_buffer_ptr = null ();
970 old_buffer_max_len = allocated_buffer_max_len;
971
972 on cleanup
973 begin;
974 if new_buffer_ptr ^= null () & new_buffer_ptr ^= allocated_buffer_ptr
975 then free new_buffer_ptr -> allocated_buffer in (system_area);
976 end;
977
978 on area go to AREA_HANDLER;
979
980 allocated_buffer_max_len =
981 maxlength (expansion) + string_len + length (control_string) + 8 * parm_count;
982
983 allocate allocated_buffer in (system_area) set (new_buffer_ptr);
984
985 new_buffer_ptr -> allocated_buffer = expansion;
986 expansion_max_len = allocated_buffer_max_len;
987
988 if allocated_buffer_ptr ^= null ()
989 then do;
990 allocated_buffer_max_len = old_buffer_max_len;
991 free allocated_buffer in (system_area);
992 end;
993
994 allocated_buffer_ptr, expansion_ptr = new_buffer_ptr;
995
996 return;
997
998 AREA_HANDLER:
999 call error (0, "Can't allocate a buffer large enough to hold the expanded control string.");
1000
1001 end allocate_buffer;
1002 %page;
1003
1004
1005
1006
1007
1008
1009
1010 Note
1011
1012
1013
1014
1015
1016
1017 check_buffer:
1018 procedure ();
1019
1020 if length (string) ^= 0 then requote_last = "0"b;
1021
1022 if length (expansion) + length (string) <= maxlength (expansion) then return;
1023
1024 if expansion_ptr = return_value_ptr
1025 then do;
1026 buffer_overflow = "1"b;
1027 string_len = maxlength (expansion) - length (expansion);
1028 call warn (error_table_$command_line_overflow, TRUNCATION_WARNING, expansion_max_len,
1029 entrypoint = EXECUTE_ENTRY, return_value_ptr ^= null () & sci_ptr = null ());
1030 return;
1031 end;
1032
1033 call allocate_buffer ();
1034
1035 return;
1036
1037 end check_buffer;
1038 %page;
1039
1040
1041
1042
1043
1044
1045
1046
1047 expand_arg:
1048 procedure ();
1049
1050 declare arg_pos fixed bin (21);
1051
1052 call get_argument (argx + arg_offset);
1053
1054 if requote_sw = NO_QUOTE_MODIFIER
1055 then do;
1056 string_len = arg_len;
1057 string_ptr = arg_ptr;
1058 call add_string ();
1059 return;
1060 end;
1061
1062 do while (quote_scan_pos < length (expansion));
1063
1064 string_len = index (substr (expansion, quote_scan_pos + 1), QUOTE) - 1;
1065 if string_len < 0 then string_len = length (expansion) - quote_scan_pos;
1066
1067 quote_scan_pos = quote_scan_pos + string_len;
1068 if quote_scan_pos < length (expansion)
1069 then do;
1070 string_len = verify (substr (expansion, quote_scan_pos + 1), QUOTE) - 1;
1071 if string_len < 0 then string_len = length (expansion) - quote_scan_pos;
1072 quote_scan_pos = quote_scan_pos + string_len;
1073
1074 if mod (string_len, quote_multiplier) = 0
1075 then do while (mod (string_len, 2 * quote_multiplier) ^= 0);
1076 string_len = string_len - quote_multiplier;
1077 quote_multiplier = 2 * quote_multiplier;
1078 end;
1079 else do while (string_len ^= 0);
1080 quote_multiplier = divide (quote_multiplier, 2, 21, 0);
1081 string_len = mod (string_len, quote_multiplier);
1082 end;
1083 end;
1084 end;
1085
1086 if requote_sw = REQUOTE_MODIFIER
1087 then do;
1088 if requote_last
1089 then expansion = substr (expansion, 1, length (expansion) - quote_multiplier);
1090 else do;
1091 string_len = quote_multiplier;
1092 call add_quotes ();
1093 end;
1094 quote_multiplier = 2 * quote_multiplier;
1095 end;
1096
1097 if quote_multiplier = 1
1098 then do;
1099 string_len = arg_len;
1100 string_ptr = arg_ptr;
1101 call add_string ();
1102 end;
1103 else do;
1104 arg_pos = 0;
1105
1106 do while (arg_pos < length (arg));
1107
1108 string_len = index (substr (arg, arg_pos + 1), QUOTE) - 1;
1109 if string_len < 0 then string_len = length (arg) - arg_pos;
1110 if string_len > 0
1111 then do;
1112 string_ptr = addcharno (addr (arg), arg_pos);
1113 call add_string ();
1114 arg_pos = arg_pos + string_len;
1115 end;
1116
1117 if arg_pos < length (arg)
1118 then do;
1119 string_len = verify (substr (arg, arg_pos + 1), QUOTE) - 1;
1120 if string_len < 0 then string_len = length (arg) - arg_pos;
1121 arg_pos = arg_pos + string_len;
1122
1123 string_len = string_len * quote_multiplier;
1124 call add_quotes ();
1125 end;
1126 end;
1127 end;
1128
1129 if requote_sw = REQUOTE_MODIFIER
1130 then do;
1131 string_len, quote_multiplier = divide (quote_multiplier, 2, 17, 0);
1132 call add_quotes ();
1133 requote_last = "1"b;
1134 end;
1135
1136 quote_scan_pos = length (expansion);
1137
1138 return;
1139
1140 end expand_arg;
1141 %page;
1142
1143
1144
1145
1146
1147 illegal:
1148 procedure (reason);
1149
1150 declare reason fixed bin (3) parameter;
1151
1152 if control_string_pos > length (control_string) then control_string_pos = length (control_string);
1153
1154 expansion_buffer = requote_string_ (construct);
1155
1156 call error (0, REASONS (reason), expansion_buffer);
1157
1158 end illegal;
1159
1160 end expand;
1161 %page;
1162 Note
1163
1164
1165
1166
1167 get_argument:
1168 procedure (P_argx);
1169
1170 declare P_argx fixed bin (17) parameter;
1171
1172 if sci_ptr = null ()
1173 then do;
1174 call cu_$arg_ptr_rel (P_argx, arg_ptr, arg_len, status, arg_list_ptr);
1175 if status ^= 0 then call error (status, "Can't get argument #^d.", P_argx);
1176 end;
1177 else call ssu_$arg_ptr (sci_ptr, P_argx, arg_ptr, arg_len);
1178
1179 return;
1180
1181 end get_argument;
1182 %page;
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194 usage:
1195 procedure (usage_string);
1196
1197 declare usage_string char (*) parameter;
1198
1199 expansion_buffer = "Usage: ";
1200 if return_value_ptr ^= null () then expansion_buffer = expansion_buffer || "[";
1201 if sci_ptr = null ()
1202 then expansion_buffer = expansion_buffer || MY_SHORT_NAME (entrypoint);
1203 else expansion_buffer = expansion_buffer || rtrim (ssu_$get_request_name (sci_ptr));
1204 expansion_buffer = expansion_buffer || BLANK;
1205 expansion_buffer = expansion_buffer || usage_string;
1206 if return_value_ptr ^= null () then expansion_buffer = expansion_buffer || "]";
1207
1208 if sci_ptr = null ()
1209 then if return_value_ptr = null ()
1210 then call com_err_$suppress_name (0, MY_NAME (entrypoint), "^a", expansion_buffer);
1211 else call active_fnc_err_$suppress_name (0, MY_NAME (entrypoint), "^a", expansion_buffer);
1212 else call ssu_$abort_line (sci_ptr, 0, "^a", expansion_buffer);
1213
1214 go to EGRESS;
1215
1216 end usage;
1217
1218 end execute_string_command;
1219
1220 end do;