1 /****^  *********************************************************
   2         *                                                       *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1990 *
   4         *                                                       *
   5         * Copyright (c) 1972 by Massachusetts Institute of      *
   6         * Technology and Honeywell Information Systems, Inc.    *
   7         *                                                       *
   8         ********************************************************* */
   9 
  10 
  11 
  12 /****^  HISTORY COMMENTS:
  13   1) change(90-05-16,Kallstrom), approve(90-05-16,MCR8176),
  14      audit(90-06-21,Blackmore), install(90-07-17,MR12.4-1022):
  15      fixed menu_get_choice so that the -dfkeys string is not used when the
  16      number of characters in the string is the same as the number of function
  17      keys defined for the terminal type.
  18                                                    END HISTORY COMMENTS */
  19 
  20 
  21 /* format: style2 */
  22 
  23 menu_create:
  24      procedure options (variable);                          /* COMMAND */
  25 
  26 /* The menu commands from MTB 494
  27    menu_create, menu_display, menu_get_choice, menu_describe
  28 
  29    James R. Davis 21 Jan 81
  30 */
  31 
  32 /* Maintained by Suzanne Krupp.
  33 
  34    Modified 06/08/81 by Suzanne Krupp to use menu_$store_menu and
  35      menu_$retrieve menu to store retrieve menus from segments.
  36 
  37    Modified 06/30/81 by Suzanne Krupp to change maximum allowed options
  38      from 35 to 61.
  39 
  40   Modified July 1981 BIM for cleanup to store/retrieve, list, delete.
  41 
  42   Audit changes October 1981 BIM.
  43 
  44   Modified November 1981 MRJ to fake function key data when not found in TTT
  45                              and to add control arg to specify options selectors.
  46 
  47   Modified 10 February 1982 by Chris Jones to initialize dfkey_string_len.
  48 
  49   84-03-12 Davids: Modified argument processing of menu_describe entry to
  50   allow more robust handling. You can now specify any combination of
  51   -width, -height, and -count and things will work. There is no longer
  52   any "knowledge" of how many arguments should be present. This fixes
  53   TR phx15650
  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;               /* to arg list */
  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);        /* MENU seg path */
  78           declare dirname                char (168);        /* MENU seg dir */
  79           declare ename                  char (32);         /* MENU seg entryname */
  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                                                             /* create starts out false, so we can query */
 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;                                    /* do while */
 193 
 194                     return;
 195 
 196 
 197 snarf:
 198      procedure (ix, larr);
 199           declare ix                     fixed bin parameter;
 200                                                             /* I/O index into array */
 201           declare larr                   (*) char (*) varying parameter;
 202                                                             /* I/O array of lines */
 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;                                         /* non quick begin block */
 210 
 211 /* Internal Procedures for create follow */
 212 ^L
 213 
 214 
 215 /* look thru the command args, count headers, trailers, and options, and set format */
 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 /* defaults */
 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;                      /* new get_line_length_ isnt in yet */
 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;                                              /* control arg loop */
 285 
 286           return;
 287 
 288 
 289 accumulate:
 290      procedure (count, maxlen);
 291           declare count                  fixed bin parameter;
 292                                                             /* input/output */
 293           declare maxlen                 fixed bin (21) parameter;
 294                                                             /* input/output */
 295           call get_next_arg ();
 296           count = count + 1;                                /* found another */
 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);                              /* COMMAND/AF */
 348           call set_flavor_of_command ("menu_get_choice", "1"b);
 349 
 350 get_menu_choice_begin:
 351           begin;
 352                declare funk                   ptr;          /* to function key info */
 353                declare funky_area             area (512);   /*  where to allocate funk info */
 354                                                             /* like this we don't have to free, and we know the data is small */
 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;                   /* we do output on *'s */
 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 /* internal procedures for get_menu_choice */
 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;                                /* make sure all required function keys are present */
 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                                                             /* no flags set - print everything */
 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 /* COMMON UTILITIES FOR THE VARIOUS COMMANDS AND ACTIVE FUNCTIONS */
 825 
 826 /* This procedure finds a menu in a menu segment. */
 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 /* This one assumes that first arg is PATH of menu, and finds it.
 849    It may be OK for the seg not to exist (if we will create it).
 850    Sets GLOBAL variables for directory, etc.
 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 /* This MUST be quick, or it will get the wrong arg list.
 891    In Hoc Signo Ursus
 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;