1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23 menu_create:
24 procedure options (variable);
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 declare get_system_free_area_ entry () returns (ptr);
57 declare requote_string_ entry (character (*)) returns (character (*));
58
59
60 declare arg char (al) based (ap);
61 declare al fixed bin (21);
62 declare ap ptr;
63 declare alp ptr;
64 declare code fixed bin (35);
65 declare nargs fixed bin;
66 declare af_value char (afl) varying based (afp);
67 declare afl fixed bin (21);
68 declare afp ptr;
69 declare active bit (1) aligned;
70 declare complain entry variable options (variable);
71 declare answer char (3) var;
72 declare myname char (32);
73 declare pathname_present bit (1);
74 declare swname_present bit (1);
75 declare brief bit (1);
76 declare valid_args fixed bin;
77 declare pathname char (168);
78 declare dirname char (168);
79 declare ename char (32);
80
81 declare 1 auto_query_info like query_info;
82
83 declare menu_namep ptr;
84 declare menu_name_len fixed bin;
85 declare menu_name char (menu_name_len) based (menu_namep);
86
87 declare iocbp ptr;
88 declare menu_ptr ptr;
89
90 declare SUFFIX char (5) internal static options (constant) init ("value");
91
92 declare (
93 error_table_$active_function,
94 error_table_$bad_conversion,
95 error_table_$badopt,
96 error_table_$bigarg,
97 error_table_$noarg,
98 error_table_$noentry,
99 error_table_$too_many_args
100 ) fixed bin (35) ext static;
101
102
103 declare (addr, empty, max, null, rtrim, size)
104 builtin;
105 ^L
106 call set_flavor_of_command ("menu_create", "0"b);
107
108 menu_create_block:
109 begin;
110 declare 1 mf aligned like menu_format;
111 declare 1 auto_menu_requirements
112 aligned like menu_requirements;
113
114 declare (n_choices, n_headers, n_trailers)
115 fixed bin;
116 declare max_choice_len fixed bin (21);
117 declare max_line_len fixed bin (21);
118
119 declare (keep_trying, create) bit (1) aligned;
120
121 declare command_query_ entry () options (variable);
122
123 declare option_keys_ptr pointer;
124 declare option_keys_len fixed bin (21);
125 declare option_keys (option_keys_len) char (1) unal based (option_keys_ptr);
126
127 if nargs < 2
128 then goto USAGE;
129
130 dirname, ename, pathname = "";
131 pathname_present, brief, create = "0"b;
132 call get_menu_name ();
133
134 call scan_controls ();
135 n_choices = max (n_choices, 1);
136 n_headers = max (n_headers, 1);
137 n_trailers = max (n_trailers, 1);
138 begin;
139 declare argx fixed bin;
140 declare choices (n_choices) char (max_choice_len) varying;
141 declare headers (n_headers) char (max_line_len) varying;
142 declare trailers (n_trailers) char (max_line_len) varying;
143 declare (choicex, headerx, trailerx)
144 fixed bin;
145
146 choicex, headerx, trailerx = 0;
147 choices (*), headers (*), trailers (*) = "";
148 do argx = 2 to nargs;
149 call arg_getter (argx, ap, al, (0));
150 if arg = "-option" | arg = "-opt"
151 then call snarf (choicex, choices);
152 else if arg = "-header" | arg = "-he"
153 then call snarf (headerx, headers);
154 else if arg = "-trailer" | arg = "-tr"
155 then call snarf (trailerx, trailers);
156 end;
157
158 auto_menu_requirements.version = menu_requirements_version_1;
159
160
161 call menu_$create (choices, headers, trailers, addr (mf), option_keys, null,
162 addr (auto_menu_requirements), menu_ptr, code);
163 if code ^= 0
164 then call gen_err (code, "Could not create the menu object.");
165
166 if ^pathname_present
167 then call get_default_vseg_path ();
168
169 keep_trying = "1"b;
170 answer = "";
171 do while (keep_trying);
172 call menu_$store (dirname, ename, menu_name, create, menu_ptr, code);
173 if code = error_table_$noentry
174 then do;
175 if brief
176 then answer = "yes";
177 else do;
178 call get_query_info (code);
179 call command_query_ (addr (auto_query_info), answer, myname,
180 "Segment not found: ^a. Do you wish to create it?", pathname);
181 end;
182 if answer = "yes"
183 then do;
184 keep_trying = "1"b;
185 create = "1"b;
186 end;
187 else call gen_err (code, rtrim (pathname));
188 end;
189 else if code ^= 0
190 then call gen_err (code, "Trying to store " || menu_name || " in " || pathname || " .");
191 else keep_trying = "0"b;
192 end;
193
194 return;
195
196
197 snarf:
198 procedure (ix, larr);
199 declare ix fixed bin parameter;
200
201 declare larr (*) char (*) varying parameter;
202
203 ix = ix + 1;
204 argx = argx + 1;
205 call arg_getter (argx, ap, al, (0));
206 larr (ix) = arg;
207 end snarf;
208
209 end;
210
211
212 ^L
213
214
215
216 scan_controls:
217 procedure ();
218 declare argx fixed bin;
219 declare get_line_length_$switch
220 entry (ptr, fixed bin (35)) returns (fixed bin);
221
222 max_choice_len, max_line_len = 0;
223 n_choices, n_headers, n_trailers = 0;
224
225
226 option_keys_ptr = addr (MENU_OPTION_KEYS);
227 option_keys_len = hbound (MENU_OPTION_KEYS, 1);
228 mf.version = menu_format_version_1;
229 mf.max_width = get_line_length_$switch ((null ()), code);
230 if code ^= 0
231 then do;
232 code = 0;
233 mf.max_width = 80;
234 end;
235
236 mf.max_height = 0;
237 mf.n_columns = 1;
238 mf.flags = "0"b;
239 mf.pad_char = " ";
240
241 do argx = 2 to nargs;
242 call arg_getter (argx, ap, al, (0));
243
244 if arg = "-header" | arg = "-he"
245 then call accumulate (n_headers, max_line_len);
246 else if arg = "-trailer" | arg = "-tr"
247 then call accumulate (n_trailers, max_line_len);
248 else if arg = "-option" | arg = "-opt"
249 then call accumulate (n_choices, max_choice_len);
250
251 else if arg = "-columns" | arg = "-col"
252 then mf.n_columns = get_next_arg_num ();
253
254 else if arg = "-center_headers" | arg = "-ceh"
255 then mf.center_headers = "1"b;
256 else if arg = "-no_center_headers" | arg = "-nceh"
257 then mf.center_headers = "0"b;
258 else if arg = "-center_trailers" | arg = "-cet"
259 then mf.center_trailers = "1"b;
260 else if arg = "-no_center_trailers" | arg = "-ncet"
261 then mf.center_trailers = "0"b;
262 else if arg = "-line_length" | arg = "-ll"
263 then mf.max_width = get_next_arg_num ();
264 else if arg = "-pad"
265 then mf.pad_char = get_next_arg_char ();
266 else if arg = "-pathname" | arg = "-pn"
267 then do;
268 pathname_present = "1"b;
269 call get_next_arg ();
270 call get_menu_seg_info ();
271 end;
272 else if arg = "-brief" | arg = "-bf"
273 then brief = "1"b;
274 else if arg = "-option_keys" | arg = "-okeys"
275 then do;
276 call get_next_arg ();
277 option_keys_ptr = addr (arg);
278 option_keys_len = length (arg);
279 end;
280 else do;
281 call complain (error_table_$badopt, myname, "^a", arg);
282 goto ERROR_EXIT;
283 end;
284 end;
285
286 return;
287
288
289 accumulate:
290 procedure (count, maxlen);
291 declare count fixed bin parameter;
292
293 declare maxlen fixed bin (21) parameter;
294
295 call get_next_arg ();
296 count = count + 1;
297 maxlen = max (maxlen, al);
298 end accumulate;
299
300
301 get_next_arg_num:
302 procedure returns (fixed bin);
303 declare x fixed bin (35);
304 declare cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
305 declare nscode fixed bin (35);
306
307 call get_next_arg ();
308 x = cv_dec_check_ (arg, nscode);
309 if nscode ^= 0
310 then do;
311 call complain (error_table_$bad_conversion, myname, "Not a decimal number: ^a.", arg);
312 goto ERROR_EXIT;
313 end;
314
315 return (x);
316 end get_next_arg_num;
317
318 get_next_arg_char:
319 procedure returns (char (1) aligned);
320 declare c char (1) aligned;
321 call get_next_arg ();
322 if al > 1
323 then do;
324 call complain (error_table_$bigarg, myname, "The pad argument must be a single character.");
325 goto ERROR_EXIT;
326 end;
327 c = arg;
328 return (c);
329 end get_next_arg_char;
330
331 get_next_arg:
332 procedure ();
333 if argx = nargs
334 then goto MISSING;
335 argx = argx + 1;
336 call arg_getter (argx, ap, al, (0));
337 end get_next_arg;
338 end scan_controls;
339
340
341 MISSING:
342 call complain (error_table_$noarg, myname, "missing arg after ^a.", arg);
343 goto ERROR_EXIT;
344 end menu_create_block;
345 ^L
346 menu_get_choice:
347 entry options (variable);
348 call set_flavor_of_command ("menu_get_choice", "1"b);
349
350 get_menu_choice_begin:
351 begin;
352 declare funk ptr;
353 declare funky_area area (512);
354
355 declare dfkey_string_ptr ptr;
356 declare dfkey_string_len fixed bin (21);
357 declare dfkey_string char (dfkey_string_len) based (dfkey_string_ptr) unal;
358 declare fkey bit (1) aligned;
359 declare keyno fixed bin;
360 declare argx fixed bin;
361
362 pathname_present, swname_present = "0"b;
363 funk, dfkey_string_ptr = null ();
364 dfkey_string_len = 0;
365 call get_menu_name ();
366
367 do argx = 2 to nargs;
368 call arg_getter (argx, ap, al, code);
369 if code ^= 0
370 then call gen_err (code, "");
371 if arg = "-pathname" | arg = "-pn"
372 then do;
373 call get_next_choice_arg ();
374 call get_menu_seg_info ();
375 pathname_present = "1"b;
376 end;
377 else if arg = "-io_switch" | arg = "-is"
378 then do;
379 call get_next_choice_arg ();
380 call get_switch ();
381 swname_present = "1"b;
382 end;
383 else if arg = "-function_keys" | arg = "-fkeys"
384 then do;
385 call get_next_choice_arg ();
386 funk = make_function_key_info (arg);
387 end;
388 else if arg = "-default_function_keys" | arg = "-dfkeys"
389 then do;
390 call get_next_choice_arg ();
391 dfkey_string_ptr = addr (arg);
392 dfkey_string_len = length (arg);
393 end;
394 else go to BAD_OPT;
395 end;
396
397 if ^swname_present
398 then iocbp = iox_$user_io;
399 if ^pathname_present
400 then call get_default_vseg_path ();
401
402 call lookup_menu ();
403
404 if funk = null ()
405 then funk = get_function_key_info ();
406
407 call menu_$get_choice (iocbp, menu_ptr, funk, fkey, keyno, code);
408 if code ^= 0
409 then goto USAGE;
410
411 call result (key_str ());
412 return;
413 ^L
414
415
416
417 get_next_choice_arg:
418 proc ();
419
420 argx = argx + 1;
421 call arg_getter (argx, ap, al, code);
422 if code ^= 0
423 then call gen_err (code, "");
424
425 end get_next_choice_arg;
426
427 key_str:
428 procedure () returns (char (8) aligned);
429 declare s char (8) aligned;
430 declare ioa_$rsnnl entry () options (variable);
431 call ioa_$rsnnl ("^[F^]^d", s, (0), fkey, keyno);
432 return (s);
433 end key_str;
434
435
436 get_function_key_info:
437 procedure () returns (pointer);
438 declare f ptr;
439 declare fx fixed bin;
440 declare ttt_info_$function_key_data
441 entry (char (*), ptr, ptr, fixed bin (35));
442 declare error_table_$no_table fixed bin (35) ext static;
443 funky_area = empty ();
444
445 call ttt_info_$function_key_data (get_term_type_name (), addr (funky_area), f, code);
446 if code = error_table_$no_table
447 then do;
448 code = 0;
449 if dfkey_string_ptr = null ()
450 then f = make_function_key_info ("0123456789");
451 else f = make_function_key_info (dfkey_string);
452 end;
453 else if code ^= 0
454 then do;
455 call complain (code, myname, "Getting function key data.");
456 goto ERROR_EXIT;
457 end;
458 else do;
459 if dfkey_string_ptr ^= null () & f -> function_key_data.highest + 1 < dfkey_string_len
460 then f = make_function_key_info (dfkey_string);
461 else do;
462 do fx = 1 to dfkey_string_len;
463 if (substr (dfkey_string, fx, 1) ^= " ")
464 & (f -> function_key_data.function_keys.sequence_length (fx - 1, KEY_PLAIN) = 0)
465 then do;
466 f = make_function_key_info (dfkey_string);
467 goto GOT_FUNCTION_KEY_INFO;
468 end;
469 end;
470 end;
471 end;
472 GOT_FUNCTION_KEY_INFO:
473 return (f);
474
475
476 get_term_type_name:
477 procedure () returns (char (32));
478 declare 1 ti aligned like terminal_info;
479
480 ti.version = terminal_info_version;
481 call iox_$control (iox_$user_io, "terminal_info", addr (ti), code);
482 if code ^= 0
483 then do;
484 call complain (code, myname, "Getting terminal type.");
485 goto ERROR_EXIT;
486 end;
487 return (ti.term_type);
488 end get_term_type_name;
489 end get_function_key_info;
490
491
492 make_function_key_info:
493 procedure (string) returns (pointer);
494 declare string char (*);
495 declare sequence char (2 * length (string)) based (sequence_ptr);
496 declare sequence_ptr pointer;
497 declare i fixed bin;
498
499 function_key_data_highest = length (string) - 1;
500 allocate function_key_data in (funky_area);
501 allocate sequence in (funky_area);
502 function_key_data.version = function_key_data_version_1;
503 function_key_data.highest = function_key_data_highest;
504 function_key_data.sequence.seq_ptr = addr (sequence);
505 function_key_data.sequence.seq_len = length (sequence);
506 function_key_data.home.sequence_index (*) = 0;
507 function_key_data.home.sequence_length (*) = 0;
508 function_key_data.left.sequence_index (*) = 0;
509 function_key_data.left.sequence_length (*) = 0;
510 function_key_data.up.sequence_index (*) = 0;
511 function_key_data.up.sequence_length (*) = 0;
512 function_key_data.right.sequence_index (*) = 0;
513 function_key_data.right.sequence_length (*) = 0;
514 function_key_data.down.sequence_index (*) = 0;
515 function_key_data.down.sequence_length (*) = 0;
516 function_key_data.function_keys.sequence_index (*, *) = 0;
517 function_key_data.function_keys.sequence_length (*, *) = 0;
518 do i = 0 to length (string) - 1;
519 if substr (string, i + 1, 1) ^= " "
520 then do;
521 substr (sequence, i * 2 + 1, 2) = byte (27) || substr (string, i + 1, 1);
522 function_key_data.function_keys.sequence_index (i, KEY_PLAIN) = i * 2 + 1;
523 function_key_data.function_keys.sequence_length (i, KEY_PLAIN) = 2;
524 end;
525 end;
526
527 return (addr (function_key_data));
528
529 end make_function_key_info;
530
531 end get_menu_choice_begin;
532 ^L
533 menu_display:
534 entry options (variable);
535 call set_flavor_of_command ("menu_display", "0"b);
536
537 menu_display_begin:
538 begin;
539
540 declare argx fixed bin;
541
542 pathname_present, swname_present = "0"b;
543 call get_menu_name ();
544
545 do argx = 2 to nargs;
546 call arg_getter (argx, ap, al, code);
547 if code ^= 0
548 then call gen_err (code, "");
549 if arg = "-pathname" | arg = "-pn"
550 then do;
551 call get_next_display_arg ();
552 call get_menu_seg_info ();
553 pathname_present = "1"b;
554 end;
555 else if arg = "-io_switch" | arg = "-is"
556 then do;
557 call get_next_display_arg ();
558 call get_switch ();
559 swname_present = "1"b;
560 end;
561 else go to BAD_OPT;
562 end;
563
564 if ^swname_present
565 then iocbp = iox_$user_output;
566 if ^pathname_present
567 then call get_default_vseg_path ();
568
569 call lookup_menu ();
570
571 call menu_$display (iocbp, menu_ptr, code);
572 if code ^= 0
573 then call gen_err (code, menu_name);
574
575 return;
576
577 get_next_display_arg:
578 proc ();
579
580 argx = argx + 1;
581 call arg_getter (argx, ap, al, code);
582 if code ^= 0
583 then call gen_err (code, "");
584
585 end get_next_display_arg;
586
587 end menu_display_begin;
588 ^L
589 menu_describe:
590 entry options (variable);
591 call set_flavor_of_command ("menu_describe", "1"b);
592
593 menu_describe_begin:
594 begin;
595
596 declare 1 mr aligned like menu_requirements;
597 declare ioa_ entry () options (variable);
598 declare argx fixed bin;
599 dcl width_flag bit (1);
600 dcl height_flag bit (1);
601 dcl count_flag bit (1);
602
603 width_flag = "0"b;
604 height_flag = "0"b;
605 count_flag = "0"b;
606 pathname_present = "0"b;
607 call get_menu_name ();
608
609 do argx = 2 to nargs;
610 call arg_getter (argx, ap, al, code);
611 if code ^= 0
612 then call gen_err (code, "");
613 if arg = "-pathname" | arg = "-pn"
614 then do;
615 call get_next_desc_arg ();
616 call get_menu_seg_info ();
617 pathname_present = "1"b;
618 end;
619 else if arg = "-width"
620 then width_flag = "1"b;
621 else if arg = "-height"
622 then height_flag = "1"b;
623 else if arg = "-count" | arg = "-ct"
624 then count_flag = "1"b;
625 else go to BAD_OPT;
626 end;
627
628 if ^pathname_present
629 then call get_default_vseg_path ();
630
631 call lookup_menu ();
632
633 if active
634 then do;
635 if (width_flag & height_flag) | (width_flag & count_flag) | (height_flag & count_flag)
636 then code = error_table_$too_many_args;
637 if ^(width_flag | height_flag | count_flag)
638 then code = error_table_$noarg;
639 end;
640 if code ^= 0
641 then goto USAGE;
642
643 mr.version = menu_requirements_version_1;
644 call menu_$describe (menu_ptr, addr (mr), code);
645 if code ^= 0
646 then goto USAGE;
647 if ^active
648 then do;
649 if ^width_flag & ^height_flag & ^count_flag
650
651 then call ioa_ ("Height: ^d; Width: ^d; ^d Option^[s^]", mr.n_options, mr.width_needed,
652 mr.n_options, (mr.n_options > 1));
653 else call ioa_ ("^[Height: ^d; ^;^s^]^[Width: ^d; ^;^s^]^[^d Option^[s^]^;^s^s^]", height_flag,
654 mr.n_options, width_flag, mr.width_needed, count_flag, mr.n_options,
655 (mr.n_options > 1));
656 end;
657 else do;
658 if width_flag
659 then call describe ("-width");
660 else if height_flag
661 then call describe ("-height");
662 else call describe ("-count");
663 end;
664 return;
665
666
667 describe:
668 procedure (which);
669 declare which char (*) parameter;
670 declare v char (8) aligned;
671 declare n fixed bin;
672 declare (char, ltrim, rtrim) builtin;
673
674 if which = "-width"
675 then n = mr.width_needed;
676 else if which = "-height"
677 then n = mr.lines_needed;
678 else if which = "-count" | which = "-ct"
679 then n = mr.n_options;
680 else goto BAD_OPT;
681 v = rtrim (ltrim (char (n)));
682 call result (v);
683 end describe;
684
685 get_next_desc_arg:
686 proc ();
687
688 argx = argx + 1;
689 call arg_getter (argx, ap, al, code);
690 if code ^= 0
691 then call gen_err (code, "");
692
693 end get_next_desc_arg;
694
695 end menu_describe_begin;
696 return;
697 ^L
698 menu_list:
699 entry options (variable);
700
701 call set_flavor_of_command ("menu_list", "1"b);
702
703 menu_list_begin:
704 begin;
705 declare ioa_ entry () options (variable);
706 %include menu_list_info;
707 declare argx fixed bin;
708 declare starname character (128);
709 declare starname_present bit (1);
710
711 starname_present = "0"b;
712 pathname_present = "0"b;
713
714 if nargs > 0
715 then do argx = 1 to nargs;
716 call arg_getter (argx, ap, al, (0));
717 if character (arg, 1) = "-"
718 then do;
719 if arg = "-pathname" | arg = "-pn"
720 then do;
721 call get_next_list_arg;
722 call get_menu_seg_info;
723 pathname_present = "1"b;
724 end;
725 else go to BAD_OPT;
726 end;
727 else do;
728 if starname_present
729 then call gen_err (error_table_$too_many_args, "Only one starname may be given.");
730 starname = arg;
731 starname_present = "1"b;
732 end;
733 end;
734
735 if ^starname_present
736 then starname = "**";
737
738 if ^pathname_present
739 then call get_default_vseg_path;
740
741 menu_list_info_ptr = null ();
742 call menu_$list (dirname, ename, starname, get_system_free_area_ (), menu_list_info_version_1,
743 menu_list_info_ptr, code);
744
745 if code ^= 0
746 then call gen_err (code, "");
747 if active
748 then af_value = "";
749
750 do argx = 1 to menu_list_info.n_names;
751 begin;
752 declare name character (menu_list_info.names (argx).length)
753 defined (menu_list_info.name_string)
754 position (menu_list_info.names (argx).position);
755 if active
756 then af_value = af_value || requote_string_ (name) || " ";
757 else call ioa_ ("^a", name);
758
759 end;
760 end;
761 if active
762 then af_value = rtrim (af_value);
763
764 get_next_list_arg:
765 procedure;
766
767 if argx = nargs
768 then call gen_err (error_table_$noarg, "No pathname supplied with -pathname.");
769 argx = argx + 1;
770 call arg_getter (argx, ap, al, (0));
771 end get_next_list_arg;
772
773 end menu_list_begin;
774
775 return;
776
777 menu_delete:
778 entry options (variable);
779
780 call set_flavor_of_command ("menu_delete", "0"b);
781
782 menu_delete_begin:
783 begin;
784
785 declare argx fixed bin;
786 pathname_present = "0"b;
787
788 call get_menu_name ();
789
790 do argx = 2 to nargs;
791 call arg_getter (argx, ap, al, (0));
792
793 if arg = "-pathname" | arg = "-pn"
794 then do;
795 call get_next_delete_arg ();
796 call get_menu_seg_info ();
797 pathname_present = "1"b;
798 end;
799 else go to BAD_OPT;
800 end;
801
802 if ^pathname_present
803 then call get_default_vseg_path;
804
805 call menu_$delete (dirname, ename, menu_name, code);
806 if code ^= 0
807 then call gen_err (code, "Could not delete menu " || menu_name || " from segment " || pathname);
808
809
810 get_next_delete_arg:
811 procedure;
812 if argx = nargs
813 then call gen_err (error_table_$noarg, "");
814
815 argx = argx + 1;
816
817 call arg_getter (argx, ap, al, (0));
818 end get_next_delete_arg;
819
820 end menu_delete_begin;
821 return;
822 ^L
823
824
825
826
827
828 lookup_menu:
829 procedure ();
830
831 call menu_$retrieve (dirname, ename, menu_name, null, menu_ptr, code);
832 if code ^= 0
833 then call gen_err (code, "Looking up menu: " || menu_name || " in " || pathname);
834
835 end lookup_menu;
836
837 get_menu_name:
838 proc ();
839
840 call arg_getter (1, ap, al, code);
841 if code ^= 0
842 then call gen_err (code, "");
843 menu_namep = ap;
844 menu_name_len = al;
845
846 end get_menu_name;
847
848
849
850
851
852
853 get_menu_seg_info:
854 procedure ();
855 declare expand_pathname_$add_suffix
856 entry (character (*), character (*), character (*), character (*),
857 fixed binary (35));
858
859 call expand_pathname_$add_suffix (arg, SUFFIX, dirname, ename, code);
860 if code ^= 0
861 then call gen_err (code, arg);
862 pathname = rtrim (dirname) || ">" || rtrim (ename);
863
864 end get_menu_seg_info;
865
866
867
868 get_switch:
869 procedure ();
870
871 call iox_$look_iocb (arg, iocbp, code);
872 if code ^= 0
873 then call gen_err (code, "Looking for switch: " || arg);
874
875 end get_switch;
876
877 result:
878 procedure (v);
879 declare v char (8) aligned parameter;
880 declare ioa_ entry () options (variable);
881 if active
882 then af_value = v;
883 else call ioa_ ("^a", v);
884 end result;
885 ^L
886
887 set_flavor_of_command:
888 procedure (name, active_ok);
889
890
891
892
893 declare name char (*) parameter;
894 declare active_ok bit (1) aligned parameter;
895
896 declare active_fnc_err_ entry () options (variable);
897 declare com_err_ entry () options (variable);
898 declare cu_$arg_list_ptr entry (pointer);
899 declare cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
900 declare error_table_$not_act_fnc
901 fixed bin (35) ext static;
902
903 myname = name;
904 call cu_$arg_list_ptr (alp);
905 call cu_$af_return_arg (nargs, afp, afl, code);
906 if code = 0
907 then do;
908 active = "1"b;
909 complain = active_fnc_err_;
910
911 if ^active_ok
912 then code = error_table_$active_function;
913 if code ^= 0
914 then goto USAGE;
915 end;
916 else if code = error_table_$not_act_fnc
917 then do;
918 code = 0;
919 active = "0"b;
920 complain = com_err_;
921 afp = null ();
922 end;
923 else do;
924 call com_err_ (code, myname);
925 goto ERROR_EXIT;
926 end;
927 end set_flavor_of_command;
928
929
930 arg_getter:
931 procedure (argn, argp, argl, acode);
932 declare argn fixed bin parameter;
933 declare argp pointer parameter;
934 declare argl fixed bin (21) parameter;
935 declare acode fixed bin (35) parameter;
936 declare cu_$af_arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), pointer);
937 declare cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
938 if active
939 then call cu_$af_arg_ptr_rel (argn, argp, argl, acode, alp);
940 else call cu_$arg_ptr_rel (argn, argp, argl, acode, alp);
941 end arg_getter;
942
943
944 get_default_vseg_path:
945 proc ();
946
947 declare user_info_ entry (char (*), char (*), char (*));
948 declare user_info_$homedir entry (char (*));
949
950 declare person_id char (22);
951
952 call user_info_ (person_id, "", "");
953 call user_info_$homedir (dirname);
954 ename = rtrim (person_id) || ".value";
955 pathname = rtrim (dirname) || ">" || ename;
956
957 end get_default_vseg_path;
958
959
960 get_query_info:
961 proc (code);
962
963 declare code fixed bin (35);
964
965 auto_query_info.version = query_info_version_5;
966 auto_query_info.yes_or_no_sw = "1"b;
967 auto_query_info.suppress_name_sw = "0"b;
968 auto_query_info.suppress_spacing = "0"b;
969 auto_query_info.cp_escape_control = "00"b;
970 auto_query_info.status_code = code;
971 auto_query_info.query_code = 0;
972 auto_query_info.question_iocbp = null;
973 auto_query_info.answer_iocbp = null;
974 auto_query_info.repeat_time = 0;
975 auto_query_info.explanation_ptr = null;
976 auto_query_info.explanation_len = 0;
977
978 end get_query_info;
979 ^L
980
981 gen_err:
982 procedure (a_code, a_str);
983
984 declare a_code fixed bin (35);
985 declare a_str char (*);
986
987 call complain (code, myname, "^a", a_str);
988 go to ERROR_EXIT;
989
990 end gen_err;
991
992 USAGE:
993 call complain (code, myname, "Usage: ^a MENU {-control_args}", myname);
994 go to ERROR_EXIT;
995
996 BAD_OPT:
997 call complain (error_table_$badopt, myname, "^a", arg);
998 goto ERROR_EXIT;
999
1000 ERROR_EXIT:
1001 return;
1002 ^L
1003 %include menu_dcls;
1004 %include iox_dcls;
1005 %include terminal_info;
1006 %include access_mode_values;
1007 %include query_info;
1008 %include function_key_data;
1009 end menu_create;