1
2
3
4
5
6
7
8
9
10 menu_:
11 procedure;
12 return;
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
62
63
64
65
66
67 declare 1 menu aligned based (menu_ptr),
68 2 version char (8) init (MENU_VERSION),
69 2 window_requirements,
70 3 height fixed bin,
71 3 width fixed bin,
72 2 n_options fixed bin,
73 2 flags unaligned,
74 3 case_insensitive bit (1) unal,
75 3 mbz1 bit (17) unal,
76 2 asterixed_option fixed bin (17) unal,
77
78 2 option_info (61),
79 3 key char (1) unal,
80 3 pad bit (27) unal,
81 3 line fixed bin,
82 3 col fixed bin,
83 2 lines (lines_alloc refer (menu.height)) unal char (chars_alloc refer (menu.width));
84
85 declare menu_ptr pointer;
86 declare menu_segment_ptr ptr;
87
88 declare MENU_VERSION char (8) aligned internal static options (constant) init ("menu_v_3");
89
90 declare lines_alloc fixed bin (21);
91 declare chars_alloc fixed bin (21);
92
93
94
95
96 declare (
97 P_choices (*) char (*) varying,
98 P_create_sw bit (1) aligned,
99 P_dname char (*),
100 P_ename char (*),
101 P_menu_name char (*),
102 P_headers (*) char (*) varying,
103 P_trailers (*) char (*) varying,
104 P_format_ptr pointer,
105 P_keys (*) char (1) unal,
106 P_areap pointer,
107 P_needs_ptr pointer,
108 P_menu_ptr pointer,
109 P_code fixed bin (35),
110 P_window pointer,
111 P_function_key_info_ptr
112 pointer,
113 P_fkeyp bit (1) aligned,
114 P_selection fixed bin,
115 P_starname character (*),
116 P_list_ptr pointer,
117 P_mli_version fixed bin
118 ) parameter;
119
120 declare (
121 error_table_$unimplemented_version,
122 error_table_$noentry
123 ) fixed bin (35) external static;
124
125 declare created_sw bit (1) aligned;
126
127 declare (addr, copy, currentsize, dimension, divide, hbound, index, length, lbound, max, mod, null, sign)
128 builtin;
129
130 declare add_char_offset_ entry (pointer, fixed bin (21)) returns (pointer) reducible;
131 declare get_system_free_area_ entry () returns (ptr);
132 declare get_user_free_area_ entry () returns (pointer);
133 declare hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
134 fixed bin (35));
135 declare hcs_$terminate_noname entry (ptr, fixed bin (35));
136 declare hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
137 declare value_$init_seg entry (ptr, fixed bin, ptr, fixed bin (19), fixed bin (35));
138 declare value_$get_data entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35))
139 ;
140 declare value_$set_data entry (ptr, bit (36) aligned, char (*), ptr, fixed bin (18), ptr, ptr,
141 fixed bin (18), fixed bin (35));
142 declare value_$list_data_names entry (pointer, bit (36) aligned, pointer, pointer, pointer, fixed binary (35));
143
144
145 declare cleanup condition;
146 ^L
147 create_menu:
148 create:
149 entry (P_choices, P_headers, P_trailers, P_format_ptr, P_keys, P_areap, P_needs_ptr, P_menu_ptr, P_code);
150 common_create:
151 begin;
152 declare n_choices fixed bin;
153 declare (header_ct, menu_ct, trailer_ct)
154 fixed bin;
155 declare menu_et_$too_few_keys fixed bin (35) ext static;
156 declare menu_et_$higher_than_max
157 fixed bin (35) external static;
158 declare menu_et_$too_many_options
159 fixed bin (35) ext static;
160 declare menu_et_$keys_not_unique
161 fixed bin (35) ext static;
162
163 P_code = 0;
164 P_menu_ptr = null ();
165 menu_format_ptr = P_format_ptr;
166 menu_requirements_ptr = P_needs_ptr;
167 n_choices = dimension (P_choices, 1);
168
169
170 if menu_format.version ^= menu_format_version_1 | menu_requirements.version ^= menu_requirements_version_1
171 then call ERROR (error_table_$unimplemented_version);
172 if menu_format.pad ^= "0"b
173 then call ERROR (error_table_$unimplemented_version);
174 if n_choices = 0
175 then ;
176 if n_choices > dimension (P_keys, 1)
177 then call ERROR (menu_et_$too_few_keys);
178 if n_choices > hbound (menu.option_info, 1)
179 then call ERROR (menu_et_$too_many_options);
180 if ^all_keys_unique (n_choices)
181 then call ERROR (menu_et_$keys_not_unique);
182
183
184 header_ct = sign (length (P_headers (1))) * dimension (P_headers, 1);
185 menu_ct = divide (n_choices, menu_format.n_columns, 17) + sign (mod (n_choices, menu_format.n_columns));
186 trailer_ct = sign (length (P_trailers (1))) * dimension (P_trailers, 1);
187 lines_alloc = header_ct + menu_ct + trailer_ct;
188
189 if menu_format.max_height > 0
190 then if lines_alloc > menu_format.max_height
191 then call ERROR (menu_et_$higher_than_max);
192
193 chars_alloc = menu_format.max_width;
194
195 begin;
196 declare based_area area based (areap);
197 declare areap ptr;
198
199 if P_areap ^= null
200 then areap = P_areap;
201 else areap = get_system_free_area_ ();
202
203 allocate menu in (based_area);
204 end;
205
206
207
208 menu.version = MENU_VERSION;
209 menu.height = lines_alloc;
210 menu.width = chars_alloc;
211 menu.n_options = n_choices;
212 menu.flags = ""b;
213 menu.case_insensitive = not_mixed_cases (n_choices);
214 menu.asterixed_option = 0;
215
216 menu.lines (*) = " ";
217 call format_screen ();
218 P_menu_ptr = menu_ptr;
219
220 call fill_requirements_from_menu ();
221
222 return;
223 ^L
224 all_keys_unique:
225 procedure (kc) returns (bit (1) aligned);
226 declare kc fixed bin parameter;
227
228 declare i fixed bin;
229 declare (index, substr) builtin;
230 declare key_overlay char (kc) defined (P_keys);
231 do i = 1 to kc - 1;
232 if index (substr (key_overlay, kc + 1), P_keys (i)) > 0
233 then return ("0"b);
234 end;
235 return ("1"b);
236 end all_keys_unique;
237
238 not_mixed_cases:
239 proc (kc) returns (bit (1) unal);
240
241 dcl kc fixed bin;
242
243 dcl key_overlay char (kc) defined (P_keys);
244 dcl UPPER_CASE_LETTERS char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") internal static options (constant);
245 dcl LOWER_CASE_LETTERS char (26) init ("abcdefghijklmnopqrstuvwxyz") internal static options (constant);
246
247 if (search (key_overlay, UPPER_CASE_LETTERS) = 0) & (search (key_overlay, LOWER_CASE_LETTERS) = 0)
248 then return ("0"b);
249 if (search (key_overlay, UPPER_CASE_LETTERS) ^= 0) & (search (key_overlay, LOWER_CASE_LETTERS) ^= 0)
250 then return ("0"b);
251 return ("1"b);
252
253 end not_mixed_cases;
254 ^L
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278 format_screen:
279 procedure;
280 declare i fixed bin;
281 declare (first_header_line, first_menu_line, first_trailer_line)
282 fixed bin;
283 declare chars_per_box fixed bin;
284 declare first_option_char fixed bin (21);
285 declare extra fixed bin;
286
287 first_header_line = 1;
288 first_menu_line = first_header_line + header_ct;
289 first_trailer_line = first_menu_line + menu_ct;
290
291
292 do i = 1 to header_ct;
293 menu.lines (first_header_line + i - 1) =
294 format (P_headers (i), menu_format.center_headers, menu_format.pad_char, menu_format.max_width);
295 end;
296 do i = 1 to trailer_ct;
297 menu.lines (first_trailer_line + i - 1) =
298 format (P_trailers (i), menu_format.center_trailers, menu_format.pad_char, menu_format.max_width);
299 end;
300
301 chars_per_box = divide (menu_format.max_width, menu_format.n_columns, 17);
302 extra = mod (menu_format.max_width, menu_format.n_columns);
303 first_option_char = (header_ct * menu.width) + 1;
304
305 format_boxes:
306 begin;
307 declare 1 boxes (0:menu_ct - 1) defined (menu.lines) position (first_option_char),
308 2 row (0:menu_format.n_columns - 1),
309 3 constant,
310 4 lp char (2) unal,
311 4 k char (1) unal,
312 4 rp char (2) unal,
313 3 name char (chars_per_box - 5) unal,
314 2 pad char (extra) unal;
315 declare menu_line fixed bin;
316 declare menu_row fixed bin;
317
318 do i = 1 to hbound (P_choices, 1);
319 menu.option_info (i).key = P_keys (i);
320 call get_box_coords (i, menu_row, menu_line);
321 menu.option_info (i).line = first_menu_line + menu_line;
322 menu.option_info (i).col = 3 + menu_row * chars_per_box;
323
324 boxes (menu_line).row (menu_row).lp = " (";
325 boxes (menu_line).row (menu_row).k = P_keys (i);
326 boxes (menu_line).row (menu_row).rp = ") ";
327 boxes (menu_line).row (menu_row).name = P_choices (i);
328 end;
329 end format_boxes;
330 return;
331
332 get_box_coords:
333 procedure (mi, bx, by);
334 declare mi fixed bin parameter;
335
336 declare (by, bx) fixed bin parameter;
337
338
339 by = mod (mi - 1, menu_ct);
340 bx = divide (mi - 1, menu_ct, 17);
341 end get_box_coords;
342
343
344
345
346
347 format:
348 procedure (raw, center, padc, ll) returns (char (200) varying);
349 declare raw char (*) varying parameter;
350 declare center bit (1) unal parameter;
351 declare padc char (1) aligned parameter;
352 declare ll fixed bin parameter;
353 declare lbuf char (200) varying;
354 declare lct fixed bin;
355
356 if ^center
357 then lbuf = raw;
358 else do;
359 lct = divide (max (0, ll - length (raw)), 2, 17);
360 lbuf = copy (padc, lct);
361 lbuf = lbuf || raw;
362 lbuf = lbuf || copy (padc, lct + mod (lct, 2));
363 end;
364 return (lbuf);
365 end format;
366 end format_screen;
367
368 end common_create;
369 ^L
370 display_menu:
371 display:
372 entry (P_window, P_menu_ptr, P_code);
373 call setup ();
374 begin;
375
376 declare window_display_ entry (pointer, (*) char (*) unal, fixed bin (35));
377
378 call window_display_ (P_window, menu.lines, P_code);
379 if menu.asterixed_option > 0
380 then do;
381 call cursor_to_option ((menu.asterixed_option));
382 call window_$overwrite_text (P_window, "*", P_code);
383 end;
384 call window_$sync (P_window, P_code);
385 end;
386 return;
387 ^L
388 get_choice:
389 entry (P_window, P_menu_ptr, P_function_key_info_ptr, P_fkeyp, P_selection, P_code);
390 call setup ();
391 function_key_data_ptr = P_function_key_info_ptr;
392 if function_key_data_ptr ^= null
393 then if function_key_data.version ^= function_key_data_version_1
394 then call ERROR (error_table_$unimplemented_version);
395
396 begin;
397 declare c char (1);
398 declare cc char (1);
399 declare ck char (1);
400 declare opx fixed bin;
401 declare possible bit (1) aligned;
402 declare fkeyb char (32) varying;
403 declare pseq char (pseql) based (pseqp);
404 declare pseql fixed bin (21);
405 declare pseqp ptr;
406
407 if menu.asterixed_option ^= 0
408 then do;
409 call cursor_to_option ((menu.asterixed_option));
410 call window_$overwrite_text (P_window, menu.option_info (menu.asterixed_option).key, P_code);
411 if P_code ^= 0
412 then go to RETURN;
413 call window_$sync (P_window, P_code);
414 if P_code ^= 0
415 then go to RETURN;
416 end;
417
418 call cursor_to_option (1);
419 do while ("1"b);
420 c = read_a_char ();
421 if menu.case_insensitive
422 then cc = upper_case (c);
423 else cc = c;
424
425 do opx = 1 to menu.n_options;
426 if menu.case_insensitive
427 then ck = upper_case ((menu.option_info (opx).key));
428 else ck = menu.option_info (opx).key;
429 if cc = ck
430 then do;
431 call cursor_to_option (opx);
432 P_fkeyp = "0"b;
433 P_selection = opx;
434
435 call window_$overwrite_text (P_window, "*", P_code);
436 if P_code ^= 0
437 then go to RETURN;
438 menu.asterixed_option = opx;
439 call window_$sync (P_window, P_code);
440 go to RETURN;
441
442
443 end;
444 end;
445 if function_key_data_ptr ^= null
446 then possible = "1"b;
447 else possible = "0"b;
448 fkeyb = c;
449 do while (possible);
450 possible = "0"b;
451 do opx = lbound (function_key_data.function_keys, 1)
452 to hbound (function_key_data.function_keys, 1);
453 pseql = function_key_data.function_keys (opx, KEY_PLAIN).sequence_length;
454 pseqp =
455 add_char_offset_ (function_key_data.seq_ptr,
456 (function_key_data.function_keys (opx, KEY_PLAIN).sequence_index) - 1);
457
458 if length (pseq) = length (fkeyb) & pseq = fkeyb
459 then do;
460 P_fkeyp = "1"b;
461 P_selection = opx;
462 return;
463 end;
464 else if ^possible
465 then if length (pseq) > length (fkeyb)
466
467 then if index (pseq, fkeyb) = 1
468
469 then possible = "1"b;
470 end;
471 if possible
472 then fkeyb = fkeyb || read_a_char ();
473 end;
474
475
476 call window_$bell (P_window, (0));
477
478 end;
479
480 read_a_char:
481 procedure returns (char (1));
482 declare ac char (1);
483 begin;
484 declare break character (1) varying;
485 call window_$get_unechoed_chars (P_window, 1, ac, (0), break, P_code);
486 if P_code ^= 0
487 then goto ERROR_EXIT;
488 if length (break) = 1
489 then ac = break;
490
491 end;
492 return (ac);
493 end read_a_char;
494
495 upper_case:
496 proc (c) returns (char (1));
497
498 dcl c char (1);
499
500 if (rank (c) < rank ("a")) | (rank (c) > rank ("z"))
501 then return (c);
502 else return (byte (rank (c) - (rank ("a") - rank ("A"))));
503
504 end upper_case;
505 end;
506 ^L
507 store_menu:
508 store:
509 entry (P_dname, P_ename, P_menu_name, P_create_sw, P_menu_ptr, P_code);
510
511 call setup ();
512 menu_segment_ptr = null;
513 created_sw = "0"b;
514 on cleanup call term_menu ();
515
516 call hcs_$initiate (P_dname, P_ename, "", 0, 1, menu_segment_ptr, P_code);
517 if P_code = error_table_$noentry & P_create_sw
518 then do;
519 created_sw = "1"b;
520 call hcs_$make_seg (P_dname, P_ename, "", RW_ACCESS_BIN, menu_segment_ptr, P_code);
521 if menu_segment_ptr = null
522 then go to SEG_ERR;
523 call value_$init_seg (menu_segment_ptr, 0, null, 0, P_code);
524 if P_code ^= 0
525 then go to SEG_ERR;
526
527 end;
528
529 if menu_segment_ptr = null
530 then go to SEG_ERR;
531
532 menu.asterixed_option = 0;
533
534 call value_$set_data (menu_segment_ptr, "01"b, value_name (P_menu_name), P_menu_ptr, currentsize (menu), null,
535 null, (0), P_code);
536
537 if P_code = 0
538 then created_sw = "0"b;
539 call term_menu ();
540
541 return;
542
543
544 delete_menu:
545 delete:
546 entry (P_dname, P_ename, P_menu_name, P_code);
547
548 P_code = 0;
549 created_sw = "0"b;
550 on cleanup call term_menu;
551 call hcs_$initiate (P_dname, P_ename, "", 0, 1, menu_segment_ptr, P_code);
552 if menu_segment_ptr = null
553 then go to SEG_ERR;
554
555
556
557
558 call value_$set_data (menu_segment_ptr, "01"b, value_name (P_menu_name), null, 0, null, null, (0), P_code);
559
560 call term_menu ();
561 return;
562
563 retrieve_menu:
564 retrieve:
565 entry (P_dname, P_ename, P_menu_name, P_areap, P_menu_ptr, P_code);
566
567 P_code = 0;
568 P_menu_ptr = null;
569 menu_segment_ptr = null;
570 created_sw = "0"b;
571 on cleanup call term_menu ();
572
573 call hcs_$initiate (P_dname, P_ename, "", 0, 1, menu_segment_ptr, P_code);
574 if menu_segment_ptr = null
575 then go to SEG_ERR;
576
577 begin;
578
579 declare areap ptr;
580
581 if P_areap = null
582 then areap = get_user_free_area_ ();
583 else areap = P_areap;
584
585 call value_$get_data (menu_segment_ptr, "01"b, value_name (P_menu_name), areap, menu_ptr, (0), P_code);
586 if P_code ^= 0
587 then go to SEG_ERR;
588
589 end;
590
591
592 if menu.version ^= MENU_VERSION
593 then do;
594 P_code = error_table_$unimplemented_version;
595 go to SEG_ERR;
596 end;
597
598 P_menu_ptr = menu_ptr;
599 call term_menu ();
600
601 return;
602
603
604 SEG_ERR:
605 call term_menu ();
606
607 go to ERROR_EXIT;
608
609 list_menus:
610 list:
611 entry (P_dname, P_ename, P_starname, P_areap, P_mli_version, P_list_ptr, P_code);
612
613
614 if P_mli_version ^= menu_list_info_version_1
615 then do;
616 P_code = error_table_$unimplemented_version;
617 return;
618 end;
619
620 call LIST (P_dname, P_ename, P_starname, P_areap, P_list_ptr, P_code);
621 return;
622
623 LIST:
624 procedure (dname, ename, starname, area_ptr, list_ptr, code);
625 declare (dname, ename, starname)
626 character (*);
627 declare area_ptr pointer;
628 declare list_ptr pointer;
629 declare (i, listx, vlistx) fixed bin (21);
630 declare code fixed bin (35);
631 declare auto_area_ptr pointer;
632 declare the_general_area area based (auto_area_ptr);
633
634 if area_ptr = null ()
635 then auto_area_ptr = get_user_free_area_ ();
636 else auto_area_ptr = area_ptr;
637
638 code = 0;
639
640 list_ptr, menu_segment_ptr, menu_list_info_ptr, match_info_ptr, value_list_info_ptr = null ();
641
642 on cleanup
643 begin;
644 if menu_list_info_ptr ^= null
645 then free menu_list_info;
646 if match_info_ptr ^= null
647 then free match_info;
648 if value_list_info_ptr ^= null
649 then free value_list_info;
650 if menu_segment_ptr ^= null
651 then call hcs_$terminate_noname (menu_segment_ptr, (0));
652 end;
653
654 call hcs_$initiate (dname, ename, "", 0, 1, menu_segment_ptr, code);
655 if menu_segment_ptr = null
656 then go to SEG_ERR;
657
658 alloc_name_count = 1;
659 alloc_max_name_len = length (value_name (starname));
660 allocate match_info;
661
662 match_info.version = match_info_version_1;
663 match_info.name_array (1).exclude_sw = "0"b;
664 match_info.name_array (1).regexp_sw = "0"b;
665 match_info.name_array (1).pad = ""b;
666 match_info.name_array (1).name = value_name (starname);
667
668 call value_$list_data_names (menu_segment_ptr, "01"b, match_info_ptr, get_system_free_area_ (),
669 value_list_info_ptr, code);
670 free match_info;
671 if code ^= 0
672 then return;
673
674
675 menu_list_n_names = value_list_info.pair_count;
676 menu_list_name_string_length =
677 sum (value_list_info.name_len) - (value_list_info.pair_count * length (".menu_"));
678
679 allocate menu_list_info in (the_general_area);
680
681 menu_list_info.version = menu_list_info_version_1;
682
683 listx = 1;
684 do i = 1 to value_list_info.pair_count;
685 menu_list_info.position (i) = listx;
686 menu_list_info.length (i) = value_list_info.name_len (i) - length (".menu_");
687
688 vlistx = value_list_info.name_index (i);
689
690 substr (menu_list_info.name_string, listx, menu_list_info.length (i)) =
691 substr (value_list_info.chars, vlistx, menu_list_info.length (i));
692 listx = listx + menu_list_info.length (i);
693 end;
694
695 list_ptr = addr (menu_list_info);
696 free value_list_info;
697 call hcs_$terminate_noname (menu_segment_ptr, (0));
698 end LIST;
699
700
701
702
703 term_menu:
704 procedure ();
705
706 declare hcs_$terminate_noname entry (ptr, fixed bin (35));
707 declare delete_$ptr entry (pointer, bit (6), character (*), fixed binary (35));
708
709 if menu_segment_ptr ^= null
710 then if created_sw
711 then call delete_$ptr (menu_segment_ptr, "100101"b, "", (0));
712 else call hcs_$terminate_noname (menu_segment_ptr, (0));
713
714 end term_menu;
715
716 value_name:
717 procedure (name) returns (character (*));
718 declare name character (*);
719
720 return (rtrim (name) || ".menu_");
721 end value_name;
722 ^L
723 describe_menu:
724 describe:
725 entry (P_menu_ptr, P_needs_ptr, P_code);
726
727 call setup ();
728 menu_requirements_ptr = P_needs_ptr;
729 if menu_requirements.version ^= menu_requirements_version_1
730 then do;
731 P_code = error_table_$unimplemented_version;
732 return;
733 end;
734
735 call fill_requirements_from_menu ();
736 return;
737
738
739 fill_requirements_from_menu:
740 procedure ();
741
742 menu_requirements.lines_needed = menu.height;
743 menu_requirements.width_needed = menu.width;
744 menu_requirements.n_options = menu.n_options;
745 end fill_requirements_from_menu;
746
747
748
749 destroy_menu:
750 destroy:
751 entry (P_menu_ptr, P_code);
752 call setup ();
753 free menu_ptr -> menu;
754 return;
755
756
757
758 setup:
759 procedure ();
760 P_code = 0;
761 if P_menu_ptr -> menu.version ^= MENU_VERSION
762 then call ERROR (error_table_$unimplemented_version);
763 menu_ptr = P_menu_ptr;
764 end setup;
765
766
767 cursor_to_option:
768 procedure (e);
769 declare e fixed bin parameter;
770 call window_$position_cursor (P_window, menu.option_info (e).line, menu.option_info (e).col, P_code);
771 if P_code ^= 0
772 then goto ERROR_EXIT;
773
774 end cursor_to_option;
775
776
777 ERROR:
778 procedure (code);
779 declare code fixed bin (35) parameter;
780 P_code = code;
781 goto ERROR_EXIT;
782 end ERROR;
783
784 RETURN:
785 ERROR_EXIT:
786 return;
787 ^L
788 %include menu_dcls;
789 %include window_dcls;
790 %include function_key_data;
791 %include access_mode_values;
792 %include value_structures;
793 %include menu_list_info;
794 end menu_;