1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   4         *                                                         *
   5         *********************************************************** */
   6 
   7 /****^  HISTORY COMMENTS:
   8   1) change(1985-09-03,LJAdams), approve(1985-11-06,MCR7278),
   9      audit(1986-02-19,Gilcrease), install(1986-02-19,MR12.0-1021):
  10      This is the driver program for the history
  11      comment programs that provide tracking of software changes and ensure that
  12      the format and placement of software change notices are standard.
  13   2) change(1986-04-17,LJAdams), approve(1986-04-17,MCR7386),
  14      audit(1986-05-19,Gilcrease), install(1986-06-05,MR12.0-1071):
  15      When using an active function, if there is an invalid argument given set
  16      return string to false.  If there was an invalid argument do not take
  17      operand of argument as a comment spec for ADD, CHECK, or INSTALL.
  18   3) change(1986-05-05,LJAdams), approve(1986-05-05,MCR7386),
  19      audit(1986-05-19,Gilcrease), install(1986-06-05,MR12.0-1071):
  20      Added ability to fill or not fill comments using the -fill or -no_fill
  21      arguments.
  22   4) change(1986-09-02,LJAdams), approve(1986-09-02,MCR7526),
  23      audit(1986-11-05,GDixon), install(1986-11-12,MR12.0-1213):
  24      Reformatted error messages to be consistent.
  25 
  26      hcom get with no fields specified was not returning all fields available.
  27   5) change(2016-01-15,Swenson), approve(2016-01-15,MCR10006):
  28      Fix history_comment to use 4-digit years and be able to handle current
  29      date/times when there are existing history comments without thinking that
  30      the new ones are in the past.
  31                                                    END HISTORY COMMENTS */
  32 
  33 history_comment:
  34 hcom:
  35      proc;
  36 
  37 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
  38 /*                                                                                        */
  39 /* This command is used to insert history_comments into source_programs.                  */
  40 /* The command uses the pnotice_language_info_ database (created by CDS) to obtain        */
  41 /* information on the source language segment.                                            */
  42 /*                                                                                        */
  43 /* Status:                                                                                */
  44 /* 0) Created          June 1985 by LJ Adams                                              */
  45 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
  46 ^L
  47 
  48 /*  A U T O M A T I C  */
  49           dcl     code                   fixed bin (35),
  50                   control                fixed bin,
  51                   current_date           char (10),
  52                   error_msg              char (100) varying,
  53                   (i, j)                 fixed bin (24),
  54                   operation              fixed bin,         /* used to indicate if operation has been set     */
  55                   Sactive_function_err   bit (1),
  56                   Sfill_arg              bit (1),
  57                   user_name              char (24),
  58                   valid                  bit (1) init ("0"b);
  59 
  60 
  61 /*  E X T E R N A L   E N T R I E S  */
  62           dcl     cu_$generate_call      entry (entry, ptr),
  63                   cv_entry_              entry (char (*), ptr, fixed bin (35)) returns (entry),
  64                   date_time_$format      entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var),
  65                   get_temp_segments_     entry (char (*), (*) ptr, fixed bin (35)),
  66                   hcom_cfix_validate_    entry (char (*) var, char (*) var, char (*) var, bit (1), char (*) var, char (*) var, char (100) var),
  67                   hcom_default_validate_ entry (char (*) var, char (*) var, char (*) var, bit (1), char (*) var, char (*) var, char (100) var),
  68                   hcom_site_validate_    entry options (variable),
  69                   hcom_process_path_     entry (ptr),
  70                   ioa_                   entry () options (variable),
  71                   release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)),
  72                   requote_string_        entry (char (*)) returns (char (*)),
  73                   user_info_             entry (char (*), char (*), char (*));
  74 
  75 /*  I N T E R N A L   S T A T I C  */
  76           dcl     FALSE                  bit (1) int static options (constant) init ("0"b),
  77                   NL                     char (1) int static options (constant) init ("
  78 "),
  79                   TRUE                   bit (1) int static options (constant) init ("1"b);
  80 
  81           dcl     ctl                    (9, 2) char (20) var int static options (constant) init (
  82                                          "-summary", "-sm", /* control args that take an operand.             */
  83                                          "-approve", "-apv",
  84                                          "-install", "-in",
  85                                          "-validate", "-vdt",
  86                                          "-critical_fix", "-cfix",
  87                                          "-fill", "-fi",
  88                                          "-no_fill", "-nfi",
  89                                          "-original", "-orig",
  90                                          "-field_names", "-fn");
  91 
  92 /*  E X T E R N A L   S T A T I C  */
  93           dcl     (error_table_$active_function,
  94                   error_table_$bad_arg,
  95                   error_table_$badopt,
  96                   error_table_$bigarg,
  97                   error_table_$improper_data_format,
  98                   error_table_$inconsistent,
  99                   error_table_$noarg)    fixed bin (35) ext static;
 100 
 101 /*  B U I L T I N  */
 102           dcl     (addr, after, before, clock, codeptr, convert, hbound, index, lbound,
 103                   length, maxlength, null, rtrim, string, substr, verify)
 104                                          builtin;
 105 
 106 /*  C O N D I T I O N S  */
 107           dcl     (cleanup,
 108                   linkage_error)         condition;
 109 ^L
 110 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 111 
 112 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 113 /*                                                                                        */
 114 /* 1) Initialize error routine and argument structure.                                    */
 115 /* 2) Find out how we were invoked (command/af).                                          */
 116 /* 3) Determine what operation is being performed.                                        */
 117 /*                                                                                        */
 118 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 119 
 120           Pd = addr (auto_hcom_data);
 121           call check_error$init ();
 122           call init$args;
 123           call get_invocation_type (d.Saf);
 124 
 125           do while (get_arg () & d.ag.op.name = NOTSET);    /* get operation value     */
 126                if index (arg, "-") = 1 then do;             /* control args that take  */
 127                          control = NOTSET;                  /*   an operand            */
 128                          do j = lbound (ctl, 2) to hbound (ctl, 2) while (control = NOTSET);
 129                               do i = lbound (ctl, 1) to hbound (ctl, 1) while (control = NOTSET);
 130                                    if arg = ctl (i, j) then control = i;
 131                                    if i = hbound (ctl, 1) then /* -fn takes multiple ops  */
 132                                         if check_arg$field_name () then ;
 133                                         else /* other control args take */
 134                                              if get_arg () then ; /*  exactly one operand.   */
 135                               end;
 136                          end;                               /* diagnose bad control    */
 137                     end;                                    /*  args later.            */
 138                else do;
 139                          do j = lbound (oper, 2) to hbound (oper, 2) while (d.ag.op.name = NOTSET);
 140                               do i = lbound (oper, 1) to hbound (oper, 1) while (d.ag.op.name = NOTSET);
 141                                    if arg = oper (i, j) then d.ag.op.name = i;
 142                               end;
 143                          end;
 144                          if d.ag.op.name = NOTSET then
 145                               call check_error$fatal (error_table_$bad_arg, CALLER, "^3x^a is not a valid operation.^/^3xSyntax: ^[[^]hcom operation path {-control_args}^[]^]
 146 ^3xOperation: ^a^6(, ^a^),^/^3x^a^(, ^a^)", arg, d.Saf, d.Saf, oper (*, 1));
 147                     end;
 148           end;
 149           if d.ag.op.name = NOTSET then
 150                call check_error$fatal (error_table_$noarg, CALLER, "^3xAn operation must be given.^/^3xSyntax:    ^[[^]hcom operation path {-control_args}^[]^]
 151 ^3xOperation: ^a^6(, ^a^),^/^3x^a^(, ^a^)", d.Saf, d.Saf, oper (*, 1));
 152 ^L
 153 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 154 /*                                                                                        */
 155 /* 1) Set argument defaults based upon the operation.                                     */
 156 /* 2) Check active function (af) invocations to be sure the specified operation is        */
 157 /*    allowed as an active function.  Set default af return value.                        */
 158 /*                                                                                        */
 159 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 160 
 161           if d.ag.op.name = ADD then
 162                d.ag.input.select.sm, d.ag.input.select.apv = INPUTxxx;
 163 
 164           if d.ag.op.name = CHECK then /* set defaults                                    */
 165                d.ag.ctl.errors = ^d.Saf;
 166           else if d.ag.op.name = INSTALL then do;
 167                     d.ag.input.select.in = INPUTxxx;
 168                     d.ag.ctl.errors = ^d.Saf;
 169                end;
 170 
 171           if d.Saf then do;                                 /* active function                                */
 172                     if d.ag.op.name = CHECK | d.ag.op.name = EXISTS |
 173                          d.ag.op.name = INSTALL | d.ag.op.name = COMPARE then
 174                                                             /* set default return value                       */
 175                          call set_return_arg ("true");
 176                     else if d.ag.op.name = GET then ;
 177                     else call check_error$fatal (error_table_$active_function, CALLER, "^/^3x^a is not a valid active function operation.",
 178                               oper (d.ag.op.name, 1));      /* diagnose operations which don't work as AF     */
 179                end;
 180           else do;                                          /* Some commands hold their true/false result     */
 181                     if d.ag.op.name = EXISTS then /* in an hcom-provided pseudo-return value.       */
 182                          call set_return_arg ("true");      /* This result is then printed when all segs      */
 183                end;                                         /* are processed.                                 */
 184 ^L
 185 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 186 /*                                                                                        */
 187 /* 1) Scan arguments, and store control arg and operand values in the d.ag substructure.  */
 188 /*    a) since each control arg is accepted for several operations, control argument      */
 189 /*       matching and operand processing is done in a series of check_arg functions.      */
 190 /*       These functions return TRUE if the control arg was accepted, and FALSE           */
 191 /*       otherwise.  If TRUE and the control arg requires operands, then the check_arg    */
 192 /*       function has already processed the operands.                                     */
 193 /*    b) Noncontrol arguments are positional in order of appearance in the argument       */
 194 /*       list.  First comes the operation name, then the source pathname.  All remaining  */
 195 /*       noncontrol args are part of the comment specifier string.                        */
 196 /*                                                                                        */
 197 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 198 
 199           call reprocess_args (1);                          /* Rescan the entire argument list.               */
 200           operation = NOTSET;                               /* Even though we know what the operation is, we  */
 201                                                             /*   must skip over the operation name in the     */
 202                                                             /*   arg list.  The operation variable determines */
 203                                                             /*   whether or not we have already seen this name*/
 204 
 205           do while (get_arg ());
 206                if index (arg, "-") = 1 then do;             /* process control args                           */
 207                          go to OP_CTL_ARGS (d.ag.op.name);
 208 
 209 OP_CTL_ARGS (1):                                            /* ADD                                            */
 210                          if check_arg$summary () then ;
 211                          else if check_arg$apv () then ;
 212                          else if check_arg$cfix () then ;
 213                          else if check_arg$install () then ;
 214                          else if check_arg$vdt () then ;
 215                          else if check_arg$fill () then ;
 216                          else call check_arg$ERROR;
 217                          goto END_OP_CTL_ARGS;
 218 
 219 OP_CTL_ARGS (2):                                            /* ADD_FIELD                                      */
 220                          if check_arg$apv () then ;
 221                          else if check_arg$cfix () then ;
 222                          else if check_arg$audit () then ;
 223                          else if check_arg$install () then ;
 224                          else if check_arg$vdt () then ;
 225                          else if check_arg$orig () then ;
 226                          else call check_arg$ERROR;
 227                          goto END_OP_CTL_ARGS;
 228 
 229 OP_CTL_ARGS (3):                                            /* CHECK                                          */
 230                          if check_arg$orig () then ;
 231                          else if check_arg$error () then ;
 232                          else if check_arg$vdt () then ;
 233                          else call check_arg$ERROR;
 234                          goto END_OP_CTL_ARGS;
 235 
 236 OP_CTL_ARGS (4):                                            /* COMPARE                                        */
 237                          if check_arg$orig () then ;
 238                          else if check_arg$vdt () then ;
 239                          else call check_arg$ERROR;
 240                          goto END_OP_CTL_ARGS;
 241 
 242 OP_CTL_ARGS (5):                                            /* DISPLAY                                        */
 243                          if check_arg$orig () then ;
 244                          else if check_arg$vdt () then ;
 245                          else call check_arg$ERROR;
 246                          goto END_OP_CTL_ARGS;
 247 
 248 OP_CTL_ARGS (6):                                            /* EXISTS                                         */
 249                          if check_arg$orig () then ;
 250                          else if check_arg$vdt () then ;
 251                          else call check_arg$ERROR;
 252                          goto END_OP_CTL_ARGS;
 253 
 254 OP_CTL_ARGS (7):                                            /* FORMAT                                         */
 255                          if check_arg$orig () then ;
 256                          else if check_arg$rnb () then ;
 257                          else if check_arg$vdt () then ;
 258                          else if check_arg$fill () then ;
 259                          else call check_arg$ERROR;
 260                          goto END_OP_CTL_ARGS;
 261 
 262 OP_CTL_ARGS (8):                                            /* GET                                            */
 263                          if check_arg$orig () then ;
 264                          else if check_arg$field_name () then ;
 265                          else if check_arg$vdt () then ;
 266                          else call check_arg$ERROR;
 267                          goto END_OP_CTL_ARGS;
 268 
 269 OP_CTL_ARGS (9):                                            /* INSTALL                                        */
 270                          if check_arg$orig () then ;
 271                          else if check_arg$error () then ;
 272                          else if check_arg$apv () then ;
 273                          else if check_arg$cfix () then ;
 274                          else if check_arg$install_required () then ;
 275                          else if check_arg$vdt () then ;
 276                          else call check_arg$ERROR;
 277                          goto END_OP_CTL_ARGS;
 278 
 279 OP_CTL_ARGS (10):                                           /* REPLACE_FIELD                                  */
 280                          if check_arg$orig () then ;
 281                          else if check_arg$no_summary () then ;
 282                          else if check_arg$apv () then ;
 283                          else if check_arg$cfix () then ;
 284                          else if check_arg$audit () then ;
 285                          else if check_arg$install () then ;
 286                          else if check_arg$vdt () then ;
 287                          else if check_arg$fill () then ;
 288                          else call check_arg$ERROR;
 289                          goto END_OP_CTL_ARGS;
 290 
 291 END_OP_CTL_ARGS:
 292                     end;
 293 
 294                else if operation = NOTSET then /* First positional arg is operation keyword.        */
 295                     operation = d.ag.op.name;
 296 
 297                else if operation ^= NOTSET & d.ag.source.path = "" then
 298                     d.ag.source.path = arg;                 /* Second positional arg is the path name.        */
 299 
 300                else if operation ^= NOTSET & d.ag.source.path ^= "" then do;
 301                          if d.ag.op.name = ADD | d.ag.op.name = CHECK | /* Third positional arg is a comment spec       */
 302                               d.ag.op.name = INSTALL then do;
 303                                    if Sactive_function_err then
 304                                         ;
 305                                    else do;
 306                                              call set_return_arg ("false");
 307                                              call check_error (error_table_$bad_arg, CALLER, "^3x^a^/^3xA comment specifier is not valid for the ^a operation.",
 308                                                   arg, oper (d.ag.op.name, 1));
 309                                         end;
 310                               end;
 311                          else
 312                               call get_com_spec ();
 313                     end;
 314           end;                                              /* get_arg                                        */
 315 ^L
 316 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 317 /*                                                                                        */
 318 /* 1) Diagnose command when no source pathname is given.                                  */
 319 /* 2) Diagnose use of old/new/diff com_spec when -original not given.                     */
 320 /* 3) Set operation type (modify source vs no-modify) based upon operation name.          */
 321 /* 4) Based upon type of operation, set default control argument values for unset         */
 322 /*    control arguments, for cases where defaults depend upon what related control args   */
 323 /*    WERE given by the user.                                                             */
 324 /*                                                                                        */
 325 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 326 
 327           if d.ag.source.path = "" then /* missing pathname                               */
 328                call check_error (error_table_$noarg, CALLER, "^/^3xPathname of a source program must be given.");
 329 
 330           if d.orig.path = "" then
 331                if d.com_spec.selected.old | d.com_spec.selected.new | d.ag.op.name = COMPARE then
 332                     call check_error (error_table_$inconsistent, CALLER, "^3x-original must be given with the old or new comment specifier, or the compare operation.");
 333 
 334           if d.ag.op.name = ADD | d.ag.op.name = ADD_FIELD | /* set MODIFY operations                         */
 335                d.ag.op.name = FORMAT | d.ag.op.name = INSTALL |
 336                d.ag.op.name = REPLACE_FIELD then
 337                d.ag.op.type = MODIFY;
 338           else
 339                d.ag.op.type = NO_MODIFY;
 340 
 341           if d.ag.op.name = ADD then do;                    /* set default input control args                 */
 342                     if d.ag.input.select.sm = NOxxx then
 343                          d.ag.input.select.sm = INPUTxxx;   /*   summary field is required for ADD op.        */
 344                end;
 345           else if d.ag.op.name = ADD_FIELD then do;
 346                     if d.ag.input.select.sm = NOxxx & d.ag.input.select.apv = NOxxx &
 347                          d.ag.input.select.aud = NOxxx & d.ag.input.select.in = NOxxx then
 348                          d.ag.input.select.apv = INPUTxxx;
 349                end;
 350           else if d.ag.op.name = GET then
 351                if string (d.ag.output) = FALSE then do i = 1 to hbound (d.field_array, 1);
 352                                                             /* if GET op and no flds specified return all flds*/
 353                          substr (string (d.ag.output), i, 1) = TRUE;
 354                          d.field_array (i) = i;
 355                     end;
 356                else if d.ag.op.name = REPLACE_FIELD then do;
 357                          if d.ag.input.select.sm = NOxxx & d.ag.input.select.apv = NOxxx &
 358                               d.ag.input.select.aud = NOxxx & d.ag.input.select.in = NOxxx then
 359                               call check_error (error_table_$noarg, CALLER, "^/^3xField input control arguments are required for the replace_field operation.");
 360                          if Sfill_arg then
 361                               if d.ag.input.select.sm = INPUTxxx |
 362                                    d.ag.input.select.sm = OPERANDxxx then ;
 363                               else
 364                                    call check_error (error_table_$bad_arg, CALLER, "^/^3xThe -fill/-no_fill arg can only be used if -sm or -ism is also specified.");
 365                     end;
 366 ^L
 367           if string (d.com_spec.selected) = FALSE & /* set default com_spec                         */
 368                d.com_spec.Nrange = 0 then do;               /* values.                                        */
 369                     if d.ag.op.name = ADD_FIELD then do;
 370                               d.com_spec.selected.unaud = (d.ag.input.select.aud >= OPERANDxxx);
 371                               d.com_spec.selected.unapv = (d.ag.input.select.apv >= OPERANDxxx);
 372                               d.com_spec.selected.unin = (d.ag.input.select.in >= OPERANDxxx);
 373                               d.com_spec.selected.aud = (d.ag.input.select.aud = CLEARxxx);
 374                               d.com_spec.selected.apv = (d.ag.input.select.apv = CLEARxxx);
 375                               d.com_spec.selected.in = (d.ag.input.select.in = CLEARxxx);
 376                          end;
 377                     else if d.ag.op.name = CHECK then do;
 378                               if d.ag.orig.path ^= "" then
 379                                    d.com_spec.selected.new = TRUE;
 380                               else
 381                                    d.com_spec.selected.icpt = TRUE;
 382                          end;
 383                     else if d.ag.op.name = DISPLAY then do;
 384                               if d.ag.orig.path ^= "" then
 385                                    d.com_spec.selected.new = TRUE;
 386                               else
 387                                    d.com_spec.selected.all = TRUE;
 388                          end;
 389                     else if d.ag.op.name = EXISTS | d.ag.op.name = FORMAT |
 390                          d.ag.op.name = INSTALL then
 391                          d.com_spec.selected.all = TRUE;
 392                     else if d.ag.op.name = GET | d.ag.op.name = REPLACE_FIELD then
 393                          call check_error (error_table_$noarg, CALLER, "^/^3xComment specifiers are required for the ^a operation.",
 394                               oper (d.ag.op.name, 1));
 395                end;
 396 
 397           if d.ag.input.value.approve_value ^= "" then do;  /* validate the approve value if given            */
 398                     valid = FALSE;
 399                     if d.Scfix then do;
 400                                                             /* critical fix                                   */
 401                               call hcom_cfix_validate_ ((CALLER), APPROVAL_FIELD_NAME, d.ag.input.value.approve_value, valid,
 402                                    d.ag.input.value.approve_value, "", error_msg);
 403                               if ^valid then
 404                                    call check_error (-1, CALLER, "^3xInvalid approve value:  ^a^/^3x^a", d.ag.input.value.approve_value, error_msg);
 405                          end;
 406                     else do;
 407                               call d.ag.vdt ((CALLER), APPROVAL_FIELD_NAME, d.ag.input.value.approve_value, valid,
 408                                    d.ag.input.value.approve_value, "", error_msg);
 409                               if ^valid & error_msg = "" then do; /* user answered no to mcr question                   */
 410                                         Serror_has_occurred = TRUE;
 411                                         goto FATAL_ERROR;
 412                                    end;
 413                               else if ^valid then
 414                                    call check_error (-1, CALLER, "^3xInvalid approve value:  ^a^/^3x^a", d.ag.input.value.approve_value, error_msg);
 415                          end;
 416                end;
 417           if d.ag.input.value.install_id ^= "" then do;     /* validate the install id if given               */
 418                     valid = FALSE;
 419                     if d.Scfix then
 420                          call hcom_cfix_validate_ ((CALLER), INSTALL_FIELD_NAME, d.ag.input.value.install_id, valid,
 421                               d.ag.input.value.install_id, "", error_msg);
 422                     else
 423                          call d.ag.vdt ((CALLER), INSTALL_FIELD_NAME, d.ag.input.value.install_id, valid, d.ag.input.value.install_id, "", error_msg);
 424                     if ^valid then
 425                          call check_error (-1, CALLER, "^3xInvalid install id:  ^a^/^3x^a", d.ag.input.value.install_id, error_msg);
 426                end;
 427 
 428 
 429 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 430 /*                                                                                        */
 431 /* 1) Stop execution if any errors were reported earlier.                                 */
 432 /* 2) Establish cleanup handler for temporary segments.                                   */
 433 /* 3) Get all temp segments needed for any hcom operation.                                */
 434 /* 4) Call hcom_process_path_ to process all the arguments.                               */
 435 /* 5) Release all temp segments and return.                                               */
 436 /*                                                                                        */
 437 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 438 
 439           if check_error$error_has_occurred () then do;
 440                if d.Saf then
 441                   call set_return_arg ("false");
 442                go to FATAL_ERROR;
 443                end;
 444 
 445           on cleanup call hcom_janitor ();
 446 
 447           call get_temp_segments_ (CALLER, temp_seg_array, code);
 448           call check_error$fatal (code, CALLER, "^/^3xError obtaining temporary segments.");
 449 
 450           call hcom_process_path_ (addr (d));
 451 
 452           if d.ag.op.name = EXISTS & ^d.Saf then
 453                call ioa_ ("^a", ret);
 454 
 455 FATAL_ERROR:
 456           call hcom_janitor ();
 457           return;
 458 
 459 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 460 ^L
 461 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 462 
 463 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 464 /*                                                                                        */
 465 /* The check_arg function entrypoints return TRUE if the current control argument is one  */
 466 /* accepted by a given entrypoint; and FALSE otherwise.  If TRUE is returned and the      */
 467 /* control argument accepts operands, then check_arg processes the operands.  Values in   */
 468 /* the d.ag structure are adjusted appropriately based upon the given control argument    */
 469 /* and its operands.                                                                      */
 470 /*                                                                                        */
 471 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 472 
 473 check_arg:
 474      proc;
 475 
 476 check_arg$apv:
 477      entry returns (bit (1));
 478 
 479           if arg = "-approve" | arg = "-apv" then do;
 480                     if get_op ("An approval value is required.  For example, MCR6734.", arg) then do;
 481                               if op = "" then do;
 482                                         d.ag.input.value.approve_value = "";
 483                                         d.ag.input.value.approve_dt = "";
 484                                         d.ag.input.apv = CLEARxxx;
 485                                    end;
 486                               else do;
 487                                         if length (op) > maxlength (d.ag.input.approve_value) then
 488                                              call check_error (error_table_$bigarg, CALLER, "^3x-approve ^a^/An approve value must^/^3xbe <= ^d characters long.", d.ag.input.approve_value, maxlength (d.ag.input.value.approve_value));
 489 
 490                                         d.ag.input.value.approve_value = op;
 491                                         d.ag.input.value.approve_dt = current_date;
 492                                         d.ag.input.apv = OPERANDxxx;
 493                                    end;
 494                          end;
 495                     return (TRUE);
 496                end;
 497           else if arg = "-input_approve" | arg = "-iapv" then do;
 498                     d.ag.input.value.approve_value = "";
 499                     d.ag.input.value.approve_dt = "";
 500                     d.ag.input.apv = INPUTxxx;
 501                     return (TRUE);
 502                end;
 503           else if arg = "-no_approve" | arg = "-napv" then do;
 504                     d.ag.input.value.approve_value = "";
 505                     d.ag.input.value.approve_dt = "";
 506                     d.ag.input.apv = NOxxx;
 507                     return (TRUE);
 508                end;
 509           return (FALSE);
 510 
 511 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 512 ^L
 513 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 514 
 515 check_arg$audit:
 516      entry returns (bit (1));
 517 
 518           if arg = "-audit" | arg = "-aud" then do;
 519                     d.ag.input.value.audit_person = rtrim (user_name);
 520                     d.ag.input.value.audit_dt = current_date;
 521                     d.ag.input.aud = OPERANDxxx;
 522                     return (TRUE);
 523                end;
 524           else if arg = "-no_audit" | arg = "-naud" then do;
 525                     d.ag.input.value.audit_person = "";
 526                     d.ag.input.value.audit_dt = "";
 527                     d.ag.input.aud = NOxxx;
 528                     return (TRUE);
 529                end;
 530           return (FALSE);
 531 
 532 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 533 check_arg$cfix:
 534      entry returns (bit (1));
 535 
 536           if arg = "-cfix" then do;
 537                     d.Scfix = TRUE;
 538                     if d.ag.input.apv = OPERANDxxx & index (d.ag.input.value.approve_value, "fix_") = 0 then
 539                          call check_error (error_table_$bad_arg, CALLER, "^3x-approve ^a^/The cfix arg has been specified a critical fix number is required.",
 540                               d.ag.input.approve_value);
 541                     d.ag.vdt = hcom_cfix_validate_;
 542                     return (TRUE);
 543                end;
 544           return (FALSE);
 545 
 546 
 547 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 548 
 549 check_arg$error:
 550      entry returns (bit (1));
 551 
 552           if arg = "-errors" | arg = "-er" then do;
 553                     d.ag.ctl.errors = TRUE;
 554                     return (TRUE);
 555                end;
 556           else if arg = "-no_errors" | arg = "-ner" then do;
 557                     d.ag.ctl.errors = FALSE;
 558                     return (TRUE);
 559                end;
 560           return (FALSE);
 561 
 562 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 563 ^L
 564 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 565 
 566 check_arg$field_name:
 567      entry returns (bit (1));
 568 
 569           dcl     (field, i, j, k)       fixed bin,
 570                   match                  fixed bin (1),
 571                   (OPTIONAL              init (0),
 572                   REQUIRED               init (1)) fixed bin (1) int static options (constant);
 573 
 574           dcl     field_name             (9, 2) char (20) var int static options (constant) init (
 575                                          "change_date", "cdt", /* 1*/
 576                                          "change_person_id", "cpi", /* 2*/
 577                                          "approve_date", "apvdt", /* 3*/
 578                                          "approve_id", "apvi", /* 4*/
 579                                          "audit_date", "auddt", /* 5*/
 580                                          "audit_person_id", "audpi", /* 6*/
 581                                          "install_date", "indt", /* 7*/
 582                                          "install_id", "ini", /* 8*/
 583                                          "summary", "sm");  /* 9*/
 584 
 585           d.field_array (*), k = 0;
 586 
 587           if arg = "-field_name" | arg = "-fn" then do;     /* multiple -fn controls   */
 588                                                             /*   add to existing names */
 589                     if get_op ("One or more field names are required.", arg) then ;
 590                     do match = REQUIRED, OPTIONAL by 1 while (get_op ("", arg));
 591                          field = 0;
 592                          do j = lbound (field_name, 2) to hbound (field_name, 2) while (field = 0);
 593                               do i = lbound (field_name, 1) to hbound (field_name, 1) while (field = 0);
 594                                    if op = field_name (i, j) then
 595                                         field = i;
 596                               end;
 597                          end;
 598 
 599                          if field > 0 then do;
 600                                    substr (string (d.ag.output), field, 1) = TRUE;
 601                                    k = k + 1;               /* store fld no so display can be positional      */
 602                                    d.field_array (k) = field;
 603                               end;
 604                          else if match = REQUIRED then do;
 605                                    call check_error (-1, CALLER, "^3xUnknown history comment field name: ^a ^a", arg, op);
 606                                    return (TRUE);
 607                               end;
 608                          else do;
 609                                    call put_op ();
 610                                    return (TRUE);
 611                               end;
 612                     end;
 613                     return (TRUE);
 614                end;
 615           return (FALSE);
 616 
 617 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 618 ^L
 619 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 620 check_arg$fill:
 621      entry returns (bit (1));
 622 
 623           if arg = "-no_fill" | arg = "-nfi" then do;
 624                     d.ag.ctl.fill = FALSE;
 625                     Sfill_arg = TRUE;
 626                     return (TRUE);
 627                end;
 628           else if arg = "-fill" | arg = "-fi" then do;
 629                     d.ag.ctl.fill = TRUE;
 630                     Sfill_arg = TRUE;
 631                     return (TRUE);
 632                end;
 633 
 634           return (FALSE);
 635 ^L
 636 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 637 
 638 check_arg$install_required:
 639      entry returns (bit (1));
 640 
 641           if arg = "-no_install" | arg = "-nin" then
 642              return (FALSE);
 643 
 644 check_arg$install:
 645      entry returns (bit (1));
 646 
 647           if arg = "-install" | arg = "-in" then do;
 648                     if get_op ("An install id is required.  For example, MR12.0-00234.", arg) then do;
 649                               if op = "" then do;
 650                                         d.ag.input.value.install_id = "";
 651                                         d.ag.input.value.install_dt = "";
 652                                         d.ag.input.in = CLEARxxx;
 653                                    end;
 654                               else do;
 655                                         if Lop > maxlength (d.ag.input.install_id) then
 656                                              call check_error (error_table_$bigarg, CALLER, "^3x-install ^a^/An install value must be <= ^d",
 657                                                   op, maxlength (d.ag.input.value.install_id));
 658 
 659                                         d.ag.input.value.install_id = op;
 660                                         d.ag.input.value.install_dt = current_date;
 661                                         d.ag.input.in = OPERANDxxx;
 662                                    end;
 663                          end;
 664                     return (TRUE);
 665                end;
 666 
 667           else if arg = "-input_install" | arg = "-iin" then do;
 668                     d.ag.input.value.install_id = "";
 669                     d.ag.input.value.install_dt = "";
 670                     d.ag.input.in = INPUTxxx;
 671                     return (TRUE);
 672                end;
 673 
 674           else if arg = "-no_install" | arg = "-nin" then do;
 675                     d.ag.input.value.install_id = "";
 676                     d.ag.input.value.install_dt = "";
 677                     d.ag.input.in = NOxxx;
 678                     return (TRUE);
 679                end;
 680 
 681           return (FALSE);
 682 
 683 
 684 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 685 
 686 check_arg$orig:
 687      entry returns (bit (1));
 688 
 689           if arg = "-original" | arg = "-orig" then do;
 690                     if get_op ("   Pathname of original version of the segment is required.", arg) then
 691                          d.ag.orig.path = op;
 692                     return (TRUE);
 693                end;
 694           return (FALSE);
 695 
 696 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 697 ^L
 698 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 699 
 700 check_arg$rnb:
 701      entry returns (bit (1));
 702 
 703           if arg = "-renumber" | arg = "-rnb" then do;
 704                     d.ag.ctl.renumber = TRUE;
 705                     return (TRUE);
 706                end;
 707           else if arg = "-no_renumber" | arg = "-nrnb" then do;
 708                     d.ag.ctl.renumber = FALSE;
 709                     return (TRUE);
 710                end;
 711           return (FALSE);
 712 
 713 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 714 ^L
 715 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 716 
 717 check_arg$no_summary:
 718      entry returns (bit (1));
 719 
 720           if arg = "-no_summary" | arg = "-nsm" then do;
 721                     d.ag.input.value.summary = "";
 722                     d.ag.input.sm = NOxxx;
 723                     return (TRUE);
 724                end;
 725 
 726 check_arg$summary:
 727      entry returns (bit (1));
 728 
 729           if arg = "-summary" | arg = "-sm" then do;
 730                     if get_op ("A change summary is required.", arg) then do;
 731                               if op = "" then do;
 732                                         call check_error (error_table_$bad_arg, CALLER, "^3x^a """" Clearing the summary field is not allowed.", arg);
 733                                    end;
 734                               else do;
 735                                         if length (op) > maxlength (d.ag.input.summary) then
 736                                              call check_error (error_table_$bigarg, CALLER, "^3xOperand of -summary must be <= ^d characters
 737                long.", op, maxlength (d.ag.input.value.summary));
 738 
 739                                         d.ag.input.value.summary = op || NL;
 740                                         d.ag.input.sm = OPERANDxxx;
 741                                    end;
 742                          end;
 743                     return (TRUE);
 744                end;
 745           else if arg = "-input_summary" | arg = "-ism" then do;
 746                     d.ag.input.value.summary = "";
 747                     d.ag.input.sm = INPUTxxx;
 748                     return (TRUE);
 749                end;
 750           return (FALSE);
 751 
 752 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 753 ^L
 754 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 755 
 756 check_arg$vdt:
 757      entry returns (bit (1));
 758 
 759           if arg = "-validate" | arg = "-vdt" then do;
 760                     if get_op ("A validation routine acceptable to cv_entry_ is required.", arg) then do;
 761                               d.ag.vdt = cv_entry_ (op, codeptr (FATAL_ERROR), code);
 762 
 763                               call check_error (code, CALLER, "^3x^a ^a^/^3xInvalid validation entry name",
 764                                    arg, op);
 765                          end;
 766                     return (TRUE);
 767                end;
 768           return (FALSE);
 769                                                             /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 770 ^L
 771 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 772 
 773 check_arg$ERROR:
 774      entry;
 775 
 776           call check_error (error_table_$badopt, CALLER, "^3x^a^/^3xfor the ^a operation.", arg, oper (d.ag.op.name, 1));
 777           if d.Saf then do;
 778                     call set_return_arg ("false");
 779                     Sactive_function_err = TRUE;
 780                end;
 781 
 782           return;
 783 
 784      end check_arg;
 785 
 786 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 787 ^L
 788 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 789 
 790           dcl     Serror_has_occurred    bit (1);           /* On if check_error has detected an error.       */
 791 
 792 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 793 /*                                                                                        */
 794 /* Syntax:  dcl check_error entry options(variable);                                      */
 795 /*          call check_error (code, procedure_name, ioa_ctl_str, args);                   */
 796 /*     or:  dcl check_error$fatal entry options(variable);                                */
 797 /*          call check_error$fatal (code, procedure_name, ioa_ctl_str, args);             */
 798 /*                                                                                        */
 799 /* Function: calls com_err_ or active_fnc_error_ as appropriate, to report an error on    */
 800 /* behalf of vtm.  check_error continues processing after the error is reported (but      */
 801 /* only if the user types "start" after active_fnc_err_ is called), whereas               */
 802 /* check_error$fatal stops all processing after the error message is printed.             */
 803 /*                                                                                        */
 804 /* Args:                                                                                  */
 805 /* code (fixed bin(35))                                                                   */
 806 /*    a status code.                                                                      */
 807 /* procedure_name (char(*))                                                               */
 808 /*    name of the procedure reporting the error.                                          */
 809 /* ioa_ctl_str                                                                            */
 810 /*    error message                                                                       */
 811 /* args                                                                                   */
 812 /*    args ioa_ will substitute into the error message.                                   */
 813 /*                                                                                        */
 814 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 815 
 816 
 817 check_error:
 818      proc options (variable);
 819 
 820           dcl     Pcode                  ptr,
 821                   Serrors_are_fatal      bit (1),           /* On if errors are fatal.                        */
 822                   code                   fixed bin (35) based (Pcode);
 823 
 824           dcl     com_err_               entry () options (variable),
 825                   cu_$arg_list_ptr       entry returns (ptr),
 826                   cu_$arg_ptr            entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 827 
 828 
 829           Serrors_are_fatal = FALSE;
 830           go to COMMON;
 831 ^L
 832 check_error$fatal:
 833      entry options (variable);
 834 
 835           Serrors_are_fatal = TRUE;
 836           go to COMMON;
 837 
 838 COMMON:   call cu_$arg_ptr (1, Pcode, 0, 0);                /* Access error table code argument.              */
 839           if code = 0 then return;                          /* If non-zero, this ISN'T an error.              */
 840           Serror_has_occurred = TRUE;
 841           if code = -1 then code = 0;                       /* No error table code fits the desired err msg.  */
 842           call cu_$generate_call (com_err_, cu_$arg_list_ptr ());
 843           if Serrors_are_fatal then do;
 844                if d.Saf then
 845                   call set_return_arg ("false");
 846                go to FATAL_ERROR;
 847                end;
 848           return;
 849 
 850 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 851 
 852 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 853 /*                                                                                        */
 854 /* Syntax:  call check_error$init();                                                      */
 855 /*                                                                                        */
 856 /* Function:  Initializes switch indicating that no errors occurred so far.               */
 857 /*                                                                                        */
 858 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 859 
 860 check_error$init:
 861      entry;
 862 
 863           Serror_has_occurred = FALSE;
 864           return;
 865 
 866 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 867 
 868 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 869 /*                                                                                        */
 870 /* Syntax:  error_has_occurred = check_error$error_has_occurred();                        */
 871 /*                                                                                        */
 872 /* Function:  tell callers if any errors have occurred so far.                            */
 873 /*                                                                                        */
 874 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 875 
 876 
 877 check_error$error_has_occurred:
 878      entry returns (bit (1));
 879 
 880           return (Serror_has_occurred);
 881 
 882      end check_error;
 883 
 884 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 885 ^L
 886 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 887 
 888           dcl     Iarg                   fixed bin,         /* Current argument being processed.              */
 889                   Larg                   fixed bin (21),    /* Length of current argument.                    */
 890                   Lop                    fixed bin (21),    /* Length of current ctl arg operand.             */
 891                   Lret                   fixed bin (21),    /* Max length of AF return value.                 */
 892                   Nargs                  fixed bin,         /* Number of arguments.                           */
 893                   Parg                   ptr,               /* Ptr to current argument.                       */
 894                   Pop                    ptr,               /* Ptr to current operand.                        */
 895                   Pret                   ptr,               /* Ptr to AF return value.                        */
 896                   arg                    char (Larg) based (Parg),
 897                   op                     char (Lop) based (Pop),
 898                   ret                    char (Lret) varying based (Pret),
 899                   true_false_value       char (5) varying,
 900                   (arg_ptr               variable,
 901                   cu_$af_arg_ptr,
 902                   cu_$arg_ptr)           entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
 903                   cu_$af_return_arg      entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
 904                   (err                   variable,
 905                   active_fnc_err_,
 906                   com_err_)              entry () options (variable);
 907 
 908 get_invocation_type:                                        /* Were we invoked as command or af?  Arg count?  */
 909      proc (Saf);
 910 
 911           dcl     Saf                    bit (1) aligned;
 912 
 913           call cu_$af_return_arg (Nargs, Pret, Lret, code);
 914           if code = 0 then do;
 915                     Saf = TRUE;
 916                     arg_ptr = cu_$af_arg_ptr;
 917                     err = active_fnc_err_;
 918                     ret = "";
 919                end;
 920           else do;
 921                     Saf = FALSE;
 922                     arg_ptr = cu_$arg_ptr;
 923                     err = com_err_;
 924                     Pret = addr (true_false_value);
 925                     Lret = maxlength (true_false_value);
 926                     ret = "";
 927                end;
 928           Iarg = 0;                                         /* No args processed so far.                      */
 929 
 930      end get_invocation_type;
 931 
 932 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 933 ^L
 934 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 935 
 936 get_arg:
 937      proc returns (bit (1));                                /* Returns TRUE if another argument exists.       */
 938                                                             /*   Its value is accessible via arg variable.    */
 939 
 940           if Iarg + 1 > Nargs then
 941                return (FALSE);
 942           Iarg = Iarg + 1;
 943           call arg_ptr (Iarg, Parg, Larg, code);
 944           return (TRUE);
 945 
 946 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 947 
 948 get_op:
 949      entry (str, arg1) returns (bit (1));                   /* Returns TRUE if another argument exists.       */
 950                                                             /*   Its value is accessible via op variable.     */
 951 
 952           dcl     str                    char (*),
 953                   arg1                   char (*);
 954 
 955           if Iarg + 1 > Nargs then do;
 956                     if str ^= "" then
 957                          call check_error (error_table_$noarg, CALLER, "^3xOperand of ^a^/^a", arg1, str);
 958                     return (FALSE);
 959                end;
 960           Iarg = Iarg + 1;
 961           call arg_ptr (Iarg, Pop, Lop, code);
 962           return (TRUE);
 963 
 964 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 965 
 966 put_arg:                                                    /* Return argument or      */
 967 put_op:                                                     /* operand to list of      */
 968      entry;                                                 /* unprocessed d.ag.       */
 969 
 970           Iarg = Iarg - 1;
 971           return;
 972 
 973 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 974 
 975 
 976 reprocess_args:                                             /* Reprocess argument list again, starting with   */
 977      entry (Ith_arg);                                       /*   the Ith argument.                            */
 978 
 979           dcl     Ith_arg                fixed bin;
 980 
 981           Iarg = Ith_arg - 1;                               /* get_arg adds 1 before reading an arg.          */
 982           return;
 983 
 984      end get_arg;
 985 
 986 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 987 ^L
 988 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 989 
 990 set_return_arg:                                             /* Set AF return value.                           */
 991      proc (str);
 992 
 993           dcl     str                    char (*);
 994 
 995           ret = str;
 996           return;
 997 
 998 add_to_return_arg:
 999      entry (str);
1000 
1001           if ret = "" then
1002                ret = requote_string_ (str);
1003           else do;
1004                     ret = ret || " ";
1005                     ret = ret || requote_string_ (str);
1006                end;
1007           return;
1008 
1009 
1010 add_to_return_arg_var:
1011      entry (str_var);
1012 
1013           dcl     str_var                char (*) varying;
1014 
1015           if ret = "" then
1016                ret = requote_string_ ((str_var));
1017           else do;
1018                     ret = ret || " ";
1019                     ret = ret || requote_string_ ((str_var));
1020                end;
1021           return;
1022 
1023      end set_return_arg;
1024 
1025 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1026 ^L
1027 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1028 
1029 get_com_spec:
1030      proc;
1031 
1032           dcl     from_arg               char (80) var,
1033                   (spec, i, j)           fixed bin,
1034                   to_arg                 char (80) var;
1035 
1036           dcl     specs                  (11, 2) char (12) var int static options (constant) init (
1037                                          "all", "a",        /*  1 */
1038                                          "old", "~",        /*  2 */
1039                                          "new", "~",        /*  3 */
1040                                          "complete", "cpt", /*  4 */
1041                                          "incomplete", "icpt", /*  5 */
1042                                          "approved", "apv", /*  6 */
1043                                          "unapproved", "unapv", /*  7 */
1044                                          "audited", "aud",  /*  8 */
1045                                          "unaudited", "unaud", /*  9 */
1046                                          "installed", "in", /* 10 */
1047                                          "uninstalled", "unin"); /* 11 */
1048 
1049           spec = 0;
1050           do j = lbound (specs, 2) to hbound (specs, 2) while (spec = 0);
1051                do i = lbound (specs, 1) to hbound (specs, 1) while (spec = 0);
1052                     if arg = specs (i, j) then
1053                          spec = i;
1054                end;
1055           end;
1056           if spec > 0 then
1057                substr (string (d.com_spec.selected), spec, 1) = TRUE;
1058 
1059           else do;
1060                     d.com_spec.Nrange = d.com_spec.Nrange + 1;
1061                     d.com_spec.range (d.Nrange) = 0;
1062                     from_arg = before (arg, ":");
1063                     to_arg = after (arg, ":");
1064                     d.com_spec.from (d.Nrange) = get_range (from_arg);
1065 
1066                     if to_arg ^= "" then /* one part                                      */
1067                          d.com_spec.to (d.Nrange) = get_range (to_arg);
1068                end;                                         /*range*/
1069           return;
1070 ^L
1071 get_range:
1072      proc (arg_in) returns (1 like d.com_spec.range.from);
1073 
1074           dcl     arg_in                 char (80) var;
1075           dcl     1 arg_out              like d.com_spec.range.from;
1076 
1077           dcl     operand                char (80) var,
1078                   addend                 char (80) var;
1079 
1080           operand, addend = "";
1081           arg_out = 0;
1082           arg_out.set = SET;
1083 
1084           if index (arg_in, "+") > 0 then do;
1085                     operand = before (arg_in, "+");
1086                     addend = after (arg_in, "+");
1087                     arg_out.op = PLUS;
1088                end;
1089           else if index (arg_in, "-") > 0 then do;
1090                     operand = before (arg_in, "-");
1091                     addend = after (arg_in, "-");
1092                     arg_out.op = MINUS;
1093                end;
1094           else do;
1095                     operand = arg_in;
1096                     addend = "";
1097                     arg_out.op = UNSET;
1098                end;
1099 
1100           if verify (operand, "0123456789") = 0 then
1101                arg_out.no = convert (arg_out.no, operand);
1102           else do;
1103                     if operand = "first" | operand = "f" then
1104                          arg_out.no = 1;
1105                     else if operand = "last" | operand = "l" then
1106                          arg_out.set = LAST;
1107                     else call check_error$fatal (error_table_$badopt, CALLER, "^3x^a.", arg_in);
1108                end;
1109 
1110           if addend ^= "" then do;
1111                     if verify (addend, "0123456789") = 0 then
1112                          arg_out.addend = convert (arg_out.addend, addend);
1113                     else
1114                          call check_error (error_table_$improper_data_format, CALLER, "^/^3xThe addend must be numeric:  ^a", addend);
1115                end;
1116 
1117           return (arg_out);
1118 
1119      end get_range;
1120 
1121      end get_com_spec;
1122 
1123 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1124 ^L
1125 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1126 
1127 
1128 hcom_janitor:
1129      proc;
1130 
1131           dcl     code                   fixed bin (35);
1132 
1133           if temp_seg_array (1) ^= null then
1134                call release_temp_segments_ (CALLER, temp_seg_array, code);
1135 
1136      end hcom_janitor;
1137 
1138 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1139 ^L
1140 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1141 
1142 
1143 init$args:
1144      proc;
1145 
1146           current_date = date_time_$format ("^9999yc-^my-^dm", clock (), "", "");
1147           call user_info_ (user_name, "", "");
1148 
1149           d.ag.op.name = NOTSET;
1150           d.ag.op.type = NO_MODIFY;
1151 
1152           Sactive_function_err = FALSE;
1153           Sfill_arg = FALSE;
1154 
1155           on linkage_error
1156                begin;
1157                     d.Ssite = FALSE;
1158                     d.ag.vdt = hcom_default_validate_;
1159                     goto CONTINUE;
1160                end;
1161 
1162           d.ag.vdt = hcom_site_validate_;
1163           d.Ssite = TRUE;
1164 
1165 CONTINUE:
1166           d.ag.ctl.renumber = FALSE;
1167           d.ag.ctl.errors = TRUE;
1168           d.ag.ctl.fill = TRUE;
1169           d.ag.source.path, d.ag.source.dir, d.ag.source.ent, d.ag.source.comp = "";
1170           d.ag.source.ent_type = 0;
1171           d.ag.orig = d.ag.source;
1172           d.ag.input.select = NOxxx;
1173           d.ag.input.value.change_dt = current_date;
1174           d.ag.input.value.seqno = 0;
1175           d.ag.input.value.selected = FALSE;
1176           d.ag.input.value.Ieq = 0;
1177           d.ag.input.value.comment_no = 0;
1178           d.ag.input.value.change_person = rtrim (user_name);
1179           d.ag.input.value.approve_dt = "";
1180           d.ag.input.value.approve_value = "";
1181           d.ag.input.value.audit_dt = "";
1182           d.ag.input.value.audit_person = "";
1183           d.ag.input.value.install_dt = "";
1184           d.ag.input.value.install_id = "";
1185           d.ag.input.value.summary = "";
1186           d.ag.output = FALSE;
1187 
1188           d.com_spec.selected = FALSE;
1189           d.com_spec.matched = FALSE;
1190           d.com_spec.Nrange, d.com_spec.range = 0;
1191 
1192           d.check_error$fatal = check_error$fatal;
1193           d.set_return_arg = set_return_arg;
1194           d.add_to_return_arg = add_to_return_arg;
1195           d.add_to_return_arg_var = add_to_return_arg_var;
1196           d.Saf = FALSE;
1197           d.Scfix = FALSE;
1198           d.Scfix_found = FALSE;
1199 
1200           d.seg_arch.dir, d.seg_arch.ent, d.seg_arch.comp = "";
1201           d.seg_arch.comp_type = NOCOMP;
1202           d.seg_arch.Pseg = null;
1203           d.seg_arch.Lseg, d.seg_arch.Lsegbc = 0;
1204 
1205           d.seg = d.seg_arch, by name;
1206           d.seg.Lseg_in, d.seg.Lseg_out = 0;
1207           d.seg.ec_version, d.seg.type, d.seg.text_pos = 0;
1208           d.seg.cmt_bgn, d.seg.cmt_end = "";
1209           d.seg.Pbox = null;
1210           d.seg.Loldbox = 0;
1211           d.seg.Lnewbox = 0;
1212 
1213           d.orig_seg = d.seg;
1214 
1215           d.temp_seg = null;
1216 
1217      end init$args;
1218 
1219 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1220 ^L
1221 %include hcom_data;
1222 
1223           dcl     1 auto_hcom_data       like d automatic;
1224 
1225 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1226 ^L
1227 %include hcom_field_names;
1228      end history_comment;