1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   4         *                                                         *
   5         * Copyright (c) 1972 by Massachusetts Institute of        *
   6         * Technology and Honeywell Information Systems, Inc.      *
   7         *                                                         *
   8         *********************************************************** */
   9 
  10 update_seg:  us:    procedure
  11                     options ( rename (( alloc_, smart_alloc_ )) );
  12 
  13 
  14 /*
  15 
  16           This procedure is the first-generation user interface to the Multics
  17           Online Updater.  Facilities are provided for batching several segments
  18           which must be installed together into a single operation, for error
  19           recovery (consisting of restoring the affected libraries to a consistent
  20           state), and for deinstallation.  Flexible options are provided for
  21           setting names and acl's on installed segments.
  22 
  23           All calls to update_seg are of the form:
  24 
  25                     update_seg function args options
  26 
  27 
  28           "function" may be: set_defaults (sd), print_defaults (pd), init (in),
  29           print (pr), add, replace (rp), move (mv), delete (dl), install,
  30           de_install, clear, and list (ls).  All installation requests
  31           are placed in a list of updater tasks;  these tasks are then
  32           compiled into a list of installation operations in which the
  33           most sensitive operations (adding names to target segments)
  34           come last in the list, and are processed nearly simultaneously.
  35           Error recovery during processing may be inhibited if desired.  Actions
  36           performed may be logged on the console (before or after processing)
  37           via the "print" function.
  38 ^L
  39           P. Bos, June 1972
  40           G. Dixon, February 1973
  41           P. Kelley, May 1973
  42           P. Kelley, March 1980
  43             1) Added optional pathname specification to the "-log"
  44                control argument with the "initiate" function.
  45             2) Added the "-initial_acl" & "-iacl" control arguments for
  46                the add, replace, move operations.
  47                MIS version number changed to 1.5
  48           E. N. Kittlitz, March 1981
  49             Changed MIS version number to 1.6 for entry_bound support
  50             in upd_install_task_ and upd_copy_seg_task_.
  51             Modified 1984-12-05 BIM to pass signal_io_ conditions.
  52 */
  53 
  54 /****^  HISTORY COMMENTS:
  55   1) change(1986-07-17,GDixon), approve(1986-08-18,MCR7494),
  56      audit(1986-08-18,Martinson), install(1986-08-19,MR12.0-1129):
  57      Add -fill and -no_fill control arguments to control filling of the
  58      -log description.
  59   2) change(2019-10-21,GDixon), approve(2019-10-26,MCR10068),
  60      audit(2019-11-03,Swenson), install(2019-11-03,MR12.6g-0033):
  61      - Eliminate bogus "tabs have been converted to a single space" message when
  62        us initiate -log -no_fill is given.
  63      - Prevent changes to line structure of log description.  -fill will
  64        wrap long lines to a new line; -no_fill will leave line lengths unchanged.
  65                                                    END HISTORY COMMENTS */
  66 
  67 /*^L*/
  68 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
  69 
  70      dcl  com_err_                      entry options (variable),
  71           command_query_                entry options (variable),
  72           condition_                    entry (char(*), entry),
  73           condition_interpreter_        entry (ptr, ptr, fixed bin, fixed bin, ptr, char(*), ptr, ptr),
  74           continue_to_signal_           entry (fixed bin(35)),
  75           cu_$arg_count                 entry (fixed bin),
  76           cu_$arg_ptr                   entry (fixed bin, ptr, fixed bin, fixed bin(35)),
  77           cu_$cl                        entry,
  78           cu_$level_get                 entry returns (fixed bin),
  79           cv_dec_check_                 entry (char(*), fixed bin(35)) returns (fixed bin(35)),
  80           cv_mode_                      entry (char(*), bit(36) aligned, fixed bin(35)),
  81           cv_userid_                    entry (char(*)) returns (char(32)),
  82           date_time_                    entry (fixed bin(71), char(*) aligned),
  83           date_time_$fstime             entry (fixed bin(35), char(*) aligned),
  84           equal_                        entry (ptr, ptr, ptr, fixed bin(35)),
  85           expand_path_                  entry (ptr, fixed bin, ptr, ptr, fixed bin(35)),
  86           find_condition_info_          entry (ptr, ptr, fixed bin(35)),
  87           get_group_id_$tag_star        entry returns (char(32) aligned),
  88           get_process_id_               entry returns (bit(36) aligned),
  89           get_wdir_                     entry returns (char(168) aligned),
  90           hcs_$delentry_file            entry (char(*), char(*), fixed bin(35)),
  91           ioa_$ioa_stream               entry options (variable),
  92           ios_$attach                   entry (char(*), char(*), char(*), char(*), bit(72) aligned),
  93           ios_$detach                   entry (char(*), char(*), char(*), bit(72) aligned),
  94           msa_manager_$area_handler     entry (ptr, char(*), ptr, ptr, bit(1) aligned),
  95           msa_manager_$make_special     entry (fixed bin, char(*), char(*), ptr, fixed bin, ptr, fixed bin(35)),
  96           msa_manager_$initiate         entry (char(*), char(*), ptr, fixed bin, ptr, fixed bin(35)),
  97           msa_manager_$terminate        entry (ptr, fixed bin(35)),
  98           msf_manager_$adjust           entry (ptr, fixed bin, fixed bin(24), bit(3), fixed bin(35)),
  99           msf_manager_$close            entry (ptr),
 100           msf_manager_$open             entry (char(*), char(*), ptr, fixed bin(35)),
 101           upd_print_acl_                entry (ptr, fixed bin, bit(*)),
 102           reversion_                    entry (char(*)),
 103           set_lock_$lock                entry (bit(36) aligned, fixed bin, fixed bin(35)),
 104           set_lock_$unlock              entry (bit(36) aligned, fixed bin(35)),
 105           suffixed_name_$find           entry (char(*), char(*), char(*), char(*), fixed bin(2), fixed bin(5),
 106                                         fixed bin(35)),
 107           suffixed_name_$new_suffix     entry (char(*), char(*), char(*), char(*), fixed bin(35)),
 108           upd_add_task_$init            entry (ptr, ptr),
 109           upd_add_task_$reset           entry (ptr),
 110           upd_gen_call_                 entry (ptr, ptr),
 111           upd_print_err_                entry options (variable),
 112           upd_task_                     entry (bit(1), ptr, entry, ptr),
 113           upd_thread_task_              entry (ptr, ptr);
 114 
 115      dcl  upd_install_task_             entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
 116                                         (3) char(168), (3) char(32), (3) fixed bin(5), (3) ptr, (3) fixed bin, (3) ptr,
 117                                         (3) fixed bin, bit(36) aligned, ptr, fixed bin(18), bit(1), char(168) aligned,
 118                                         fixed bin(35), fixed bin(35)),
 119           upd_install_task_$init        entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
 120                                         bit(1), bit(1), ptr, char(32) aligned),
 121           upd_describe_task_            entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
 122                                         ptr, char (168) aligned, ptr, fixed bin(35) ),
 123           upd_subtask_                  entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
 124                                         ptr, ptr);
 125 
 126      dcl (addr, baseno, clock, dim, fixed, index, length, max, mod, null, size, substr)
 127                                         builtin;
 128 
 129      dcl (error_table_$bad_conversion,
 130           error_table_$bad_ring_brackets,
 131           error_table_$badcall,
 132           error_table_$badopt,
 133           error_table_$dirseg,
 134           error_table_$fatal_error,
 135           error_table_$improper_data_format,
 136           error_table_$invalid_lock_reset,
 137           error_table_$segno_in_use,
 138           error_table_$locked_by_this_process,
 139           error_table_$lock_wait_time_exceeded,
 140           error_table_$moderr,
 141           error_table_$namedup,
 142           error_table_$noentry,
 143           error_table_$not_done,
 144           error_table_$out_of_bounds,
 145           error_table_$out_of_sequence,
 146           error_table_$seg_not_found,
 147           error_table_$seglock,
 148           error_table_$too_many_names,
 149           error_table_$too_many_acl_entries,
 150           error_table_$wrong_no_of_args)
 151                                         fixed bin(35) ext static;
 152 
 153      dcl  (sys_info$default_max_length,
 154            sys_info$max_seg_size)       fixed bin ext static;
 155 
 156      dcl  area                          area based (Pmsa_ptr);        /* all allocations will be within log segment */
 157 
 158      dcl (argp, fp, p, q, inp, rqp, desp)          ptr;
 159 
 160      dcl  (logp, msa_ptr)               ptr int static init (null);   /* log segment pointer */
 161 
 162      dcl  Pmsa_ptr                      ptr based (msa_ptr);
 163 
 164      dcl  a                             fixed bin,          /* used by acl, name options */
 165           argi                          fixed bin,          /* argument index */
 166           argl                          fixed bin,          /* argument length */
 167           code                          fixed bin(35),      /* status code */
 168           f                             fixed bin,          /* updater function called */
 169           fail                          fixed bin,          /* from -severity option */
 170           fl                            fixed bin,          /* length of function arg */
 171          (i, j)                         fixed bin,          /* random */
 172           mode                          fixed bin(5),       /* argument to suffixed_name_$find */
 173           n                             fixed bin,          /* used by acl, ringbracket, name options */
 174           nargs                         fixed bin,          /* argument count */
 175           npath                         fixed bin,          /* number of non-control (i.e. pathname) args */
 176           option                        fixed bin,          /* code for control arg being processed */
 177           r                             fixed bin,          /* temp used by ringbracket option */
 178           state                         fixed bin,          /* used in decoding acl option */
 179           status                        bit(72) aligned,    /* an I/O system status code. */
 180           type                          fixed bin(2);       /* argument to suffixed_name_$find */
 181 
 182      dcl  arg                           char(argl) based (argp);      /* argument */
 183 
 184      dcl  answer                        char(3) aligned,    /* answer to a query */
 185           date                          char(24) aligned,   /* a date-time string */
 186           dir (3)                       char(168),          /* dirname array */
 187           doc_dir                       char(168) aligned,  /* documentation directory */
 188           docsw                         bit(1) init ("0"b), /* ON if documentation directory being changed */
 189           dummy                         char(1),            /* dummy char string */
 190           eqseg                         char(32),           /* entryname to match = */
 191           fcbp                          ptr,      /* ptr to _^Hfile _^Hcontrol _^Hblock used by msf_manager_ */
 192           function                      char(fl) based (fp),/* updater function invoked */
 193           init_log_segment              char(168) aligned,            /* pathname of opt. "init" log segment */
 194           listdir                       char(168),                    /* dirname of installation list segment */
 195           Llistdir                      fixed bin,                    /* length of non-blank part of listdir */
 196           listseg                       char(32),                     /* entryname of installation list segment */
 197           logdir                        char(168) int static,         /* dirname of current installation log */
 198           logseg                        char(32) int static,/* entryname of log */
 199           maxl                          fixed bin(18) init (0), /* max seg length */
 200           proc                          char(10) aligned int static init ("update_seg"),  /* for com_err_ */
 201           seg (3)                       char(32),           /* entryname array */
 202           tseg                          char(32),           /* temp. entryname */
 203           Version_No                    char(4) aligned int static init ("1.6"), /* MIS Version No. */
 204           xxx                           char(16);           /* part of com_err_ comment */
 205 
 206      dcl  ctlw                          bit(36) aligned,    /* control word for task procedures */
 207           eqsw                          bit(1) aligned,     /* non-zero if = may be decoded */
 208           nofillsw                      bit(1) aligned,     /* non-zero for "-no_fill" */
 209           rstrtsw                       bit(1) aligned,     /* non-zero for "-restart" option */
 210           stopsw                        bit(1) aligned,     /* non-zero for "-stop" option */
 211           sws                           bit(36) aligned;    /* option word for segment request */
 212 
 213      dcl  owp ptr;                                          /* ptr to option switches               */
 214                                                             /* meaning of switches depends upon     */
 215                                                             /* function being performed, so...      */
 216      dcl  1 request_option_word         aligned based (owp),/* breakdown of sws by "request" actions */
 217            (2 archivesw                 bit (1),            /* "-archive" */
 218             2 old_namesw                bit (1),            /* "-old_name" */
 219             2 spec_segsw                bit (1),            /* "-special_seg" */
 220             2 logsw                     bit (1),            /* "-log" */
 221             2 defersw                   bit (1),            /* "-defer" */
 222             2 mlsw                      bit (1),            /* "-max_length" */
 223             2 pad                       bit (30)) unal;
 224 
 225      dcl  1 print_option_word           aligned based (owp),/* breakdown of sws by "print"/"list" actions */
 226            (2 errorsw                   bit (1),            /* "-error" */
 227             2 briefsw                   bit (1),            /* "-brief" */
 228             2 longsw                    bit (1),            /* "-long" */
 229             2 log_sw                    bit (1),            /* "-log" */
 230             2 pad                       bit (32)) unal;
 231 
 232      dcl  1 clear_option_word           aligned based (owp),/* breakdown of sws by "clear" actions */
 233            (2 cerrorsw                  bit (1),            /* "-error" */
 234             2 uidsw                     bit (1),            /* "-uid" */
 235             2 pad                       bit (34)) unal;
 236 
 237      dcl  1 install_option_word         aligned based (owp),/* breakdown of sws by "install" actions */
 238            (2 stopsw                    bit (1),            /* "-stop" */
 239             2 pad                       bit (35)) unal;
 240 
 241      dcl  1 init_option_word            aligned based (owp),/* breakdown of sws by "init" actions */
 242            (2 restartsw                 bit (1),            /* "-restart" */
 243             2 padd                      bit (2),
 244             2 log_sw                    bit (1),            /* "-log" */
 245             2 pad                       bit (32)) unal;
 246 
 247      dcl (endlabel, errlabel)           label local;        /* used for install/de_install functions */
 248 
 249      dcl  faultlabel                    label local init (logerr);
 250                                                             /* used to recover from seg_fault errors during */
 251                                                             /* installation object segment initialization. */
 252 
 253      dcl  1 stat                        based (addr (status)),/* overlay for I/O status code */
 254             2 code                      fixed bin(35);      /* a system status code */
 255 
 256 
 257      dcl  1 global_default              aligned int static, /* per-process default acl, rb's */
 258             2 log_directory             char (168) aligned init (""),/* default is "working_dir" */
 259             2 rb (3)                    fixed bin init (1,5,5), /* default is " 1,5,5 " */
 260             2 acl,                                          /* n.b. not same as "acl" array */
 261               3 n                       fixed bin init (1), /* 1 entry to start with */
 262               3 a1,                                         /* default is "re *.*.*" */
 263                 4 userid                char(32) init ("*.*.*"),
 264                 4 mode                  bit(36) init ("1100"b),
 265                 4 bits                  bit(36) init ("0"b),
 266                 4 code                  fixed bin(35) init (0),
 267               3 a2 (29),                                    /* leave room for 30 entries in default acl */
 268                 4 userid                char(32),
 269                 4 mode                  bit(36),
 270                 4 pad                   bit(36),
 271                 4 code                  fixed bin(35);
 272 
 273      dcl  1 t                           aligned,            /* all acl, rb, name args fill in here */
 274             2 log_directory             char (168) aligned, /* -sld */
 275             2 rb (3)                    fixed bin,          /* -rb */
 276             2 acl (3),                                      /* -acl, -deleteacl, -setacl */
 277               3 n                       fixed bin,          /* acl count */
 278               3 a (30),                                     /* acl array */
 279                 4 userid                char(32),           /* user name */
 280                 4 mode                  bit(36),            /* mode (rew) */
 281                 4 pad                   bit(36),            /* padding     */
 282                 4 code                  fixed bin(35),      /* error code   */
 283             2 names (3),                                    /* -names, -deletenames, -addnames */
 284               3 n                       fixed bin,          /* name count */
 285               3 a (30),                                     /* name array */
 286                 4 name                  char(32),           /* name */
 287                 4 pcode                 fixed bin(35),      /* installation code */
 288                 4 rcode                 fixed bin(35);      /* de_installation code */
 289 
 290      dcl  1 default                     aligned based,      /* overlay for "t", "global_default" */
 291             2 log_directory             char (168) aligned, /* documentation dir */
 292             2 rb (3)                    fixed bin,          /* ring brackets */
 293             2 acl,                                          /* default acl */
 294               3 n                       fixed bin,          /* acl count */
 295               3 a (30),                                     /* acl array */
 296                 4 userid                char(32),           /* user name */
 297                 4 mode                  bit(36),            /* mode            */
 298                 4 pad                   bit(36),            /* padding */
 299                 4 code                  fixed bin(35);      /* error code */
 300 
 301      dcl  1 acl (n)                     aligned based,      /* single acl array */
 302             2 userid                    char(32),           /* .. used for allocations */
 303             2 mode                      bit(36),
 304             2 pad                       bit(36),
 305             2 code                      fixed bin(35);
 306 
 307      dcl  1 names (n)                   aligned based,      /* single names array */
 308             2 name                      char(32),           /* .. also for allocations */
 309             2 pcode                     fixed bin(35),      /* installation status code */
 310             2 rcode                     fixed bin(35);      /* de_installation status code */
 311 
 312      dcl  1 in                          aligned based(inp), /* args for upd_install_task_$init call */
 313             2 temp                      ptr init (null),    /* pointer to its internal temps */
 314             2 taskp                     ptr init (null),    /* its task pointer */
 315             2 code                      fixed bin(35) init (0), /* status code */
 316             2 sev                       fixed bin init (0), /* severity code */
 317             2 seqno                     fixed bin init (0), /* sequence no (no special task ordering) */
 318             2 io_name                   char (32) aligned init (""); /* name of io seg */
 319 
 320      dcl  1 desc                        aligned based (desp), /* args for upd_describe_task_ task call */
 321             2 taskp                     ptr init (null),    /* its task pointer */
 322             2 code                      fixed bin(35) init (0), /* status code */
 323             2 sev                       fixed bin init (0), /* severity code */
 324             2 seqno                     fixed bin init (1), /* sequence no. */
 325             2 temp                      ptr init (null);    /* ptr to temps */
 326 
 327      dcl  1 rq                          aligned based(rqp), /* args for upd_install_task_ call */
 328             2 temp                      ptr init (null),    /* pointer to his internal temps */
 329             2 taskp                     ptr init (null),    /* his task pointer */
 330             2 ap (3)                    ptr init ((3) null),/* acl array pointers */
 331             2 np (3)                    ptr init ((3) null),/* name array pointers */
 332             2 an (3)                    fixed bin init ((3) 0),       /* acl counts */
 333             2 nn (3)                    fixed bin init ((3) 0),       /* name counts */
 334             2 code                      fixed bin(35) init (0),       /* status code */
 335             2 sev                       fixed bin init (0), /* severity code */
 336             2 seqno                     fixed bin init (0), /* sequence no. (no ordering) */
 337             2 dir (3)                   char(168) unal,     /* dirname array */
 338             2 seg (3)                   char(32) unal,      /* entryname array */
 339             2 rb (3)                    fixed bin(5),       /* ring brackets for target seg */
 340             2 maxlen                    fixed bin(18),      /* max length attribute */
 341             2 options                   bit(36);            /* installation options (-archive, -oldnames, etc.) */
 342 
 343      dcl  1 log                         aligned based (logp),         /* installation log */
 344             2 version                   char(4) aligned,    /* updater version number */
 345             2 init_id                   bit(36),            /* process id of process which initialized it last */
 346             2 selfp                     ptr,                /* pointer to self, to remember segment no. */
 347             2 areap                     ptr,                /* addr (log.area) */
 348             2 linkp                     ptr,                /* task linkage table root pointer */
 349             2 listp                     ptr,                /* task list root pointer */
 350             2 processp                  ptr,                /* copy of listp, modified by upd_subtask_ */
 351             2 nullp                     ptr,                /* static null pointer */
 352             2 lock,                                         /* items related to locking io seg while its in use */
 353               3 word                    bit(36) aligned,    /* lock word */
 354               3 group_id                char(32) aligned,   /* process group id of user who locked log */
 355             2 fcn (4),                                      /* items related to groups of update_seg functions */
 356               3 group_id                char(32) aligned,   /* process group id of last user to perform one */
 357                                                             /* of the functions in this group on this log. */
 358               3 date                    fixed bin(35),      /* date on which function was performed. */
 359             2 sw                        aligned,            /* random switches */
 360              (3 full_recovery           bit(1),             /* on if segs can be deleted in de_installation   */
 361               3 special_segs            bit(1),             /* on if special segs are being installed */
 362               3 error                   bit(1),             /* on if errors occurred in install/de_install */
 363               3 logging_sw              bit(1)) unal,       /* on if any documentation is being performed */
 364             2 d,                                            /* defaults for this installation */
 365               3 log_directory           char (168) aligned, /* default documentation dir */
 366               3 rb (3)                  fixed bin,          /* default ring brackets */
 367               3 acl,                                        /* default access control list for new segments */
 368                 4 n                     fixed bin,          /* number of entries in default acl */
 369                 4 a (30),                                   /* out of a maximum of 30 */
 370                   5 userid              char(32),           /* user name for this entry */
 371                   5 mode                bit(36),            /* mode */
 372                   5 bits                bit(36),            /* padding */
 373                   5 code                fixed bin(35),      /* error code */
 374             2 description               ptr,                /* ptr to documentation reason description */
 375             2 t,                                            /* args for task call to upd_subtask_ */
 376               3 taskp                   ptr,                /* his task pointer */
 377               3 temp                    ptr,                /* pointer to his internal temps */
 378               3 code                    fixed bin(35),      /* status code for him */
 379               3 sev                     fixed bin,          /* severity code */
 380               3 seqno                   fixed bin,          /* task sequence number (=32767) */
 381             2 area                      area;               /* rest of segment */
 382 
 383      dcl  function_table (20)           char(16) aligned int static init (
 384                                         "set_defaults",     /*  (1) */
 385                                         "print_defaults",   /*  (2) */
 386                                         "initiate",         /*  (3) */
 387                                         "print",            /*  (4) */
 388                                         "add",              /*  (5) */
 389                                         "replace",          /*  (6) */
 390                                         "move",             /*  (7) */
 391                                         "delete",           /*  (8) */
 392                                         "install",          /*  (9) */
 393                                         "de_install",       /* (10) */
 394                                         "clear",            /* (11) */
 395                                         "list",             /* (12) */
 396                                         "sd",               /* (13) (1) */
 397                                         "pd",               /* (14) (2) */
 398                                         "in",               /* (15) (3) */
 399                                         "pr",               /* (16) (4) */
 400                                         "rp",               /* (17) (6) */
 401                                         "mv",               /* (18) (7) */
 402                                         "dl",               /* (19) (8) */
 403                                         "ls");              /* (20)(12) */
 404 
 405      dcl  function_index (20)           fixed bin int static init (
 406                                         1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
 407                                         1, 2, 3, 4,    6, 7, 8,            12);
 408 
 409      dcl  option_table (44)             char(16) aligned int static init (
 410                                         "-acl",             /* (1) */
 411                                         "-delete_acl",      /* (2) */
 412                                         "-set_acl",         /* (3) */
 413                                         "-ring_brackets",   /* (4) */
 414                                         "-name",            /* (5) */
 415                                         "-delete_name",     /* (6) */
 416                                         "-add_name",        /* (7) */
 417                                         "-old_name",        /* (8) */
 418                                         "-archive",         /* (9) */
 419                                         "-severity",        /* (10) */
 420                                         "-restart",         /* (11) */
 421                                         "-stop",            /* (12) */
 422                                         "-error",           /* (13) */
 423                                         "-brief",           /* (14) */
 424                                         "-long",            /* (15) */
 425                                         "-special_seg",     /* (16) */
 426                                         "-log",             /* (17) */
 427                                         "-defer",           /* (18) */
 428                                         "-uid",             /* (19) */
 429                                         "-set_log_dir",     /* (20) */
 430                                         "-max_length",      /* (21) */
 431                                         "-da",              /* (22) (2) */
 432                                         "-sa",              /* (23) (3) */
 433                                         "-rb",              /* (24) (4) */
 434                                         "-nm",              /* (25) (5) */
 435                                         "-dn",              /* (26) (6) */
 436                                         "-an",              /* (27) (7) */
 437                                         "-onm",             /* (28) (8) */
 438                                         "-ac",              /* (29) (9) */
 439                                         "-sv",              /* (30) (10) */
 440                                         "-rt",              /* (31) (11) */
 441                                         "-er",              /* (32) (13) */
 442                                         "-bf",              /* (33) (14) */
 443                                         "-lg",              /* (34) (15) */
 444                                         "-ss",              /* (35) (16) */
 445                                         "-df",              /* (36) (18) */
 446                                         "-sld",             /* (37) (20) */
 447                                         "-ml",              /* (38) (21) */
 448           /* The next 6 control arguments don't follow the above ordering. */
 449           /* Too many unecessary changes would have been required.         */
 450                                         "-initial_acl",     /* (39) (22) */
 451                                         "-iacl",            /* (40) (22) */
 452                                         "-fill",            /* (41) (23) */
 453                                         "-fi",              /* (42) (23) */
 454                                         "-no_fill",         /* (43) (24) */
 455                                         "-nfi");            /* (44) (24) */
 456 
 457      dcl  option_index (44)             fixed bin int static init (
 458           1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21,
 459              2, 3, 4, 5, 6, 7, 8, 9, 10, 11,     13, 14, 15, 16,     18,     20, 21,
 460           22, 22, 23, 23, 24, 24);
 461 
 462      dcl  option_matrix (24, 12)        fixed bin int static init (
 463                                         1,  0,  1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  /*  (1) -acl */
 464                                         0,  0,  0,  0,  2,  2,  2,  0,  0,  0,  0,  0,  /*  (2) -deleteacl */
 465                                         0,  0,  0,  0,  3,  3,  3,  0,  0,  0,  0,  0,  /*  (3) -setacl */
 466                                         4,  0,  4,  0,  4,  4,  4,  0,  0,  0,  0,  0,  /*  (4) -ring_brackets */
 467                                         0,  0,  0,  0,  5,  5,  5,  0,  0,  0,  0,  0,  /*  (5) -names */
 468                                         0,  0,  0,  0,  6,  6,  6,  0,  0,  0,  0,  0,  /*  (6) -deletenames */
 469                                         0,  0,  0,  0,  7,  7,  7,  0,  0,  0,  0,  0,  /*  (7) -addnames */
 470                                         0,  0,  0,  0,  0,  8,  0,  0,  0,  0,  0,  0,  /*  (8) -oldnames */
 471                                         0,  0,  0,  0,  9,  9,  9,  0,  0,  0,  0,  0,  /*  (9) -archive */
 472                                         0,  0,  0,  0,  0,  0,  0,  0, 10, 10,  0,  0,  /* (10) -severity */
 473                                         0,  0, 11,  0,  0,  0,  0,  0,  0,  0,  0,  0,  /* (11) -restart */
 474                                         0,  0,  0,  0,  0,  0,  0,  0, 12, 12,  0,  0,  /* (12) -stop */
 475                                         0,  0,  0, 13,  0,  0,  0,  0,  0,  0, 13,  0,  /* (13) -error */
 476                                         0,  0,  0, 14,  0,  0,  0,  0,  0,  0,  0, 14,  /* (14) -brief */
 477                                         0,  0,  0, 15,  0,  0,  0,  0,  0,  0,  0, 15,  /* (15) -long */
 478                                         0,  0,  0,  0, 16, 16, 16, 16,  0,  0,  0,  0,  /* (16) -special_seg */
 479                                         0,  0, 17, 17, 17, 17, 17, 17,  0,  0,  0,  0,  /* (17) -log */
 480                                         0,  0,  0,  0, 18, 18, 18, 18,  0,  0,  0,  0,  /* (18) -defer */
 481                                         0,  0,  0,  0,  0,  0,  0,  0,  0,  0, 19,  0,  /* (19) -uid */
 482                                        20,  0, 20,  0,  0,  0,  0,  0,  0,  0,  0,  0,  /* (20) -set_log_dir */
 483                                         0,  0,  0,  0, 21, 21, 21,  0,  0,  0,  0,  0,  /* (21) -max_length */
 484                                         0,  0,  0,  0, 22, 22, 22,  0,  0,  0,  0,  0,  /* (22) -initial_acl */
 485                                         0,  0, 23,  0,  0,  0,  0,  0,  0,  0,  0,  0,  /* (23) -fill */
 486                                         0,  0, 24,  0,  0,  0,  0,  0,  0,  0,  0,  0); /* (24) -no_fill */
 487 
 488      dcl  path_matrix (12, 3)           fixed bin int static init (
 489                                         0, 0, 0,            /* set_defaults */
 490                                         1, 0, 0,            /* print_defaults */
 491                                         1, 0, 0,            /* init */
 492                                         1, 0, 0,            /* print */
 493                                         1, 3, 0,            /* add */
 494                                         1, 2, 3,            /* replace */
 495                                         2, 3, 0,            /* move */
 496                                         2, 0, 0,            /* delete */
 497                                         1, 0, 0,            /* install */
 498                                         1, 0, 0,            /* de_install */
 499                                         1, 0, 0,            /* clear */
 500                                         1, 0, 0);           /* list */
 501 
 502      dcl  pmax (12)                     fixed bin int static init (0, 1, 1, 1, 2, 3, 2, 1, 1, 1, 1, 1),
 503           pmin (12)                     fixed bin int static init (0, 0, 0, 0, 2, 2, 2, 1, 0, 0, 0, 0);
 504 
 505      dcl  fail_max                      fixed bin(35) int static init (5),
 506           fail_min                      fixed bin(35) int static init (1);
 507 
 508      dcl  1 query_info                  aligned int static, /* command_query_ info structure. */
 509             2 version                   fixed bin init (2),
 510             2 yes_no_sw                 bit(1) unal init ("1"b),
 511             2 suppress_name             bit(1) unal init ("0"b),
 512             2 status                    fixed bin(35) init (0),
 513             2 code                      fixed bin(35) init (0);
 514 
 515      dcl  cleanup                       condition;          /* capture this condition */
 516 
 517 /*^L*/
 518 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 519 
 520           owp = addr(sws);
 521 
 522           call cu_$arg_count (nargs);                       /* get number of arguments */
 523           if nargs = 0 then do;                             /* no arguments, tell user format */
 524                call com_err_ (error_table_$wrong_no_of_args, (proc),
 525                     "^/Calling sequence is:^-^a <function> <args> <options>",
 526                     (proc));
 527                return;                                      /* exit to user */
 528                end;
 529           argi = 1;                                         /* first arg */
 530           call cu_$arg_ptr (argi, fp, fl, code);            /* get pointer and length */
 531           if code ^= 0 then                                 /* unlikely */
 532                go to argerr;                                /* but check anyway */
 533           do i = 1 to dim (function_table, 1);              /* first arg is updater function */
 534                if function = function_table(i) then do;     /* search table for a match */
 535                     f = function_index(i);                  /* found; get function code; */
 536                     on cleanup begin;                       /* set up handler to unlock log and detach streams */
 537                          call ios_$detach ( "installation_list_", "", "", status);
 538                          call ios_$detach ( "installation_error_", "", "", status);
 539                          call unlock_log;
 540                          end;
 541                     go to init(f);                          /* and go process call */
 542                     end;
 543                end;
 544           call com_err_(error_table_$badcall, (proc), "Unknown updater function specified. ""^a""", function);
 545           return;                                           /* return to user */
 546 
 547 
 548 init(1):                                                    /* "set_defaults" function */
 549 join0:    p = addr (t);                                     /* will be used to overlay "default" */
 550           q = addr (global_default);                        /* copy current defaults for this process */
 551           p -> default = q -> default;                      /* .. so arg processor can update them */
 552           go to join1;                                      /* go look at args */
 553 
 554 
 555 init(2):  npath = 0;                                        /* "print_defaults" function, allow log pathname */
 556           go to join1;                                      /* go get args */
 557 
 558 
 559 init(3):  npath = 0;                                        /* "initiate" function, we expect a pathname */
 560           rstrtsw = "0"b;                                   /* reset "-restart" switch */
 561           sws = "0"b;                                       /* reset switches */
 562           nofillsw = "0"b;                                  /* -log -fill is the default.                     */
 563           go to join0;                                      /* go get global defaults */
 564 
 565 init(11): endlabel = return;                                /* "clear" function; return to user after processing */
 566 init(4):                                                    /* "print" function */
 567 init(12): sws = "0"b;                                       /* "list" function; reset option switches */
 568           npath = 0;                                        /* assume no log pathname supplied */
 569           go to join1;                                      /* skip to argument processor */
 570 
 571 
 572 init(5):                                                    /* "add" function */
 573 init(6):                                                    /* "replace" function */
 574 init(7):                                                    /* "move" function */
 575 init(8):  npath = 0;                                        /* "delete" function */
 576           fail = 1;                                         /* make any error a fatal error. */
 577           call init_log ("1"b);                             /* make sure there is an installation object segment. */
 578           do i = 1 to 3;                                    /* three of everything, by sheer coincidence */
 579                dir(i), seg(i) = "";                         /* blank out all pathname args */
 580                t.acl(i).n, t.names(i).n = 0;                /* no names or acls yet */
 581                end;
 582           p = addr (t);                                     /* first part overlaid by "default" */
 583           q = addr (log.d);                                 /* will use installation defaults */
 584           p -> default = q -> default;                      /* copies default ringbrackets and acl */
 585           if f ^= 5 then                                    /* want acl only for add function */
 586                t.acl(1).n = 0;                              /* zero acl count for any other */
 587           if (f = 6) | (f = 7) then do i = 1 to 3;          /* if "replace" or "move", then we'll  */
 588                t.rb(i) = 0;                                 /* determine default rings via upd_ring_task_$list   */
 589                end;                                         /* for the "old" segment, unless "-rb" option appears later */
 590           npath = 0;                                        /* no pathnames yet */
 591           sws = "0"b;                                       /* no options either */
 592           maxl = sys_info$default_max_length;               /* default  */
 593           go to join1;                                      /* skip to arg processor */
 594 
 595 
 596 init(9):  stopsw = "0"b;                                    /* "install" function; reset "-stop" switch */
 597 init(10): npath = 0;                                        /* "de_install" function. */
 598           fail = 1;                                         /* any error is fatal, by default. */
 599 
 600 
 601 join1:    option = 0;                                       /* here to process argument list; zero option code */
 602           eqsw = "0"b;                                      /* first pathname can't have "=" */
 603 nxtarg:   argi = argi + 1;                                  /* increment arg counter */
 604           if argi > nargs then                              /* that's all there are */
 605                go to aend(option);                          /* go finish up current option if any */
 606           call cu_$arg_ptr (argi, argp, argl, code);        /* get pointer, length for this arg */
 607           if code ^= 0 then do;                             /* unlikely error */
 608                argp = addr (dummy);                         /* avoid null pointer reference */
 609                argl = 0;                                    /* didn't get nothin' */
 610 argerr:        call com_err_(code, (proc), """^a"" (arg ^d)", arg, argi);       /* complain to user */
 611                go to return;                                /* and let him figure it out */
 612                end;
 613           if substr (arg, 1, 1) = "-" then                  /* argument is option specifier */
 614                go to aend(option);                          /* go finish up last option */
 615           else                                              /* not a control arg, */
 616                go to aarg(option);                          /* go process normal arg */
 617 
 618 ckopt:    if argi > nargs then                              /* reenter here after aend(i), check arg count again */
 619                go to start(f);                              /* exit from arg processor if done */
 620           do i = 1 to dim (option_table, 1);                /* search option table for this control arg */
 621                if arg = option_table(i) then do;            /* found it */
 622                     option = option_matrix(option_index(i), f);/* very table-driven program */
 623                     if option = 0 then                      /* option not permitted for this function */
 624                          go to badopt;                      /* pretend we never heard of it */
 625                     go to abgn(option);                     /* ok option, go process */
 626                     end;
 627                end;
 628 badopt:   call com_err_(error_table_$badopt, (proc), "^a", arg);/* unknown updater option */
 629           go to return;                                     /* go unlock log segment, if its locked */
 630 
 631 logerr:   call com_err_(error_table_$out_of_sequence, (proc), "^/^a.^/^a^a ^a.",
 632                "No installation object (io) segment is active", "Type:  """,
 633                (proc), "initiate <io_path_name>""  to initiate an io segment");
 634                                                             /* error return after log initiation failure */
 635 return:   call unlock_log;                                  /* standard return point from update_seg; unlock log */
 636 return_without_unlocking:
 637           return;
 638 /*^L*/
 639 
 640 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 641 
 642 
 643 aarg(0):  npath = npath + 1;                                /* here for pathname argument */
 644           if npath > pmax(f) then                           /* is that too many? */
 645                go to path_err;                              /* then tell user. */
 646           if arg ^= "" then do;                             /* leave hooks for funny functions */
 647                j = path_matrix (f, npath);                  /* find out where to put it */
 648                dir(j), seg(j) = "";                         /* clear the place, cause expand_path_ doesn't */
 649                call expand_path_(argp, argl, addr (dir(j)), addr (seg(j)), code);
 650                if code ^= 0 then                            /* bad pathname syntax */
 651                     go to argerr;                           /* go tell user */
 652                i = index (seg(j), "=");                     /* see if entryname includes "=" components */
 653                if i ^= 0 then if eqsw then do;              /* ahaa! */
 654                     tseg = seg(j);                          /* copy entryname (equal_ blows it otherwise) */
 655                     call equal_(addr (eqseg), addr (tseg), addr (seg(j)), code);
 656                     if code ^= 0 then                       /* bad "=" syntax */
 657                          go to argerr;                      /* go complain */
 658                     end;
 659                eqseg = seg(j);                              /* following args may use "=" option, if not already */
 660                eqsw = "1"b;                                 /* cheaper to test than eqseg ^= "" */
 661                end;
 662           go to nxtarg;                                     /* go process next argument */
 663 
 664 aend(0):  go to ckopt;                                      /* no deferrred processing, go check new arg */
 665 
 666 
 667 abgn(1):                                                    /* "-acl" option */
 668 abgn(2):                                                    /* "-deleteacl" option */
 669 abgn(3):  a = option;                                       /* "-setacl" option; get index for which acl (1, 2, 3) */
 670           state = 0;                                        /* first arg to option is mode */
 671           n = 0;                                            /* nothing yet */
 672           go to nxtarg;                                     /* and jump back in again */
 673 
 674 aarg(1):                                                    /* "-acl" option arg */
 675 aarg(2):                                                    /* "-deleteacl" option arg */
 676 aarg(3):  if state = 0 then do;                             /* "-setacl" option arg */
 677                n = n + 1;                                   /* starts a new acl entry */
 678                if n > dim (t.acl.a, 2) then do;             /* limit number of ACLe's to max we can store */
 679                     call com_err_(error_table_$too_many_acl_entries, (proc),
 680                          "^/Only  ^d  acl entries may be specified after the  ^a  control argument.",
 681                          dim (t.acl.a, 2), (option_table(option)));
 682                     go to return;                           /* unlock log, if necessary, and return to user */
 683                     end;
 684                t.acl(a).a(n).code = 0;                      /* reset status code */
 685                if a = 2 then do;                            /* is this "-deleteacl"? */
 686                     t.acl(a).a(n).mode = "0"b;              /* yes, no mode arg */
 687                     go to aarg2a;                           /* arg is userid each time */
 688                     end;
 689                call cv_mode_(arg, t.acl(a).a(n).mode, code);/* go convert mode to binary */
 690                if code ^= 0 then                            /* bad mode specification */
 691                     go to argerr;                           /* go complain */
 692                t.acl(a).a(n).userid = "*.*.*";              /* assume *.*.* in case no userid specified */
 693                state = 1;                                   /* next arg should be userid */
 694                end;
 695           else do;                                          /* arg is userid */
 696 aarg2a:        t.acl(a).a(n).userid = cv_userid_(arg);      /* get userid in standard format */
 697                state = 0;                                   /* next arg will be mode again */
 698                end;
 699           go to nxtarg;                                     /* go get next argument */
 700 
 701 aend(1):                                                    /* "-acl" option terminated */
 702 aend(2):                                                    /* "-deleteacl" option terminated */
 703 aend(3):  t.acl(a).n = n;                                   /* "-setacl" option terminated; record acl size */
 704           go to ckopt;                                      /* and go check new option */
 705 
 706 
 707 abgn(4):  n = 0;                                            /* "-ring_brackets", tell the rest */
 708           go to nxtarg;                                     /* go get next argument */
 709 
 710 aarg(4):  n = n + 1;                                        /* should be a ring bracket */
 711           r = cv_dec_check_(arg, code);                     /* go convert to binary */
 712           if code ^= 0 then do;                             /* conversion error */
 713                code = error_table_$bad_conversion;
 714                go to argerr;                                /* gripe bitch complain */
 715                end;
 716           if r <= 0 then                                    /* we don't allow ring brackets of 0 or less */
 717                go to rberr;                                 /* save hardcore the trouble */
 718           if r > 7 then                                     /* and nobody allows ringbrackets bigger than 7 */
 719                go to rberr;                                 /* gripe */
 720           if n ^= 1 then if r < t.rb(n-1) then do;          /* better not be smaller than last one */
 721 rberr:         code = error_table_$bad_ring_brackets;       /* set error code */
 722                go to argerr;                                /* and go tell user what he can do with them */
 723                end;
 724           t.rb(n) = r;                                      /* record ring bracket */
 725           if n = 3 then                                     /* -rb option is self-terminating */
 726                option = 0;                                  /* pathname may follow */
 727           go to nxtarg;                                     /* go get next argument */
 728 
 729 aend(4):  if n = 0                                          /* "-ring_bracket" option terminated */
 730                then do;                                     /* bit he didn't give us any rings! */
 731                     n = 1;                                  /* start him off at ring 1 */
 732                     t.rb(n) = max((cu_$level_get()), 5);    /* default him to highest he can handle */
 733                     end;
 734           if n < 3                                          /* finish up the three rings */
 735                then do i = n+1 to 3;
 736                     t.rb(i) = max((cu_$level_get()), t.rb(i-1), 5);/* default him to highest */
 737                     end;
 738           option = 0;                                       /* finished with the rings */
 739           go to ckopt;                                      /* go check next option */
 740 
 741 
 742 abgn(5):                                                    /* "-names" option */
 743 abgn(6):                                                    /* "-deletenames" option */
 744 abgn(7):  a = option - 4;                                   /* "-addnames" option; get array index (1, 2, 3) */
 745           n = 0;                                            /* nobody home yet */
 746           go to nxtarg;                                     /* go get next arg */
 747 
 748 aarg(5):                                                    /* "-names" option arg */
 749 aarg(6):                                                    /* "-deletenames" option arg */
 750 aarg(7):  n = n + 1;                                        /* "-addnames" option arg; increment count */
 751           if n > dim (t.names.a, 2) then do;                /* limit number of names to max we can store */
 752                call com_err_(error_table_$too_many_names, (proc),
 753                     "^/Only  ^d  names may be specified after the  ^a  control argument.",
 754                     dim (t.names.a, 2), (option_table (option)));
 755                go to return;                                /* unlock log and return to user */
 756                end;
 757           t.names(a).a(n).name = arg;                       /* put name in array */
 758           t.names(a).a(n).pcode = error_table_$not_done;    /* initialize install code */
 759           t.names(a).a(n).rcode = 0;                        /* and de_install code */
 760           go to nxtarg;                                     /* go process next argument */
 761 
 762 aend(5):                                                    /* "-names" option terminated */
 763 aend(6):                                                    /* "-deletenames" option terminated */
 764 aend(7):  t.names(a).n = n;                                 /* "-addnames" option terminated; record array size */
 765           go to ckopt;                                      /* and go check up on new option */
 766 
 767 
 768 abgn(8):  old_namesw = "1"b;                                /* "-oldnames" */
 769           go to endopt;                                     /* skip */
 770 
 771 
 772 abgn(9):  archivesw = "1"b;                                 /* "-archive" */
 773           go to endopt;
 774 
 775 
 776 abgn(10): go to nxtarg;                                     /* "-severity"; no initialization necessary */
 777 
 778 aarg(10): fail = cv_dec_check_ (arg, code);                 /* convert severity to a number */
 779           if code ^= 0 then do;                             /* conversion failed? Tell user. */
 780                call com_err_(error_table_$bad_conversion, (proc), "Argument  ^a  ^a.",
 781                     arg, "could not be converted to a severity number");
 782                go to return;                                /* unlock log and return to user */
 783                end;
 784           go to nxtarg;
 785 
 786 aend(10): if (fail < fail_min) | (fail > fail_max) then do; /* Severity outside allowable bounds. */
 787                call com_err_(error_table_$out_of_bounds, (proc), "^d^/^a  ^d  to  ^d.", fail,
 788                     "Failure severity must be a number from", (fail_min), (fail_max));
 789                return;
 790                end;
 791           go to ckopt;
 792 
 793 
 794 abgn(11): rstrtsw = "1"b;                                   /* "-restart" */
 795           substr (sws, 1, 1) = "1"b;
 796           go to endopt;
 797 
 798 
 799 abgn(12): stopsw = "1"b;                                    /* "-stop" */
 800           go to endopt;
 801 
 802 
 803 abgn(13): substr (sws, 1, 1) = "1"b;                        /* "-error" */
 804           go to endopt;
 805 
 806 
 807 abgn(14): briefsw = "1"b;                                   /* "-brief" */
 808           go to endopt;
 809 
 810 
 811 abgn(15): longsw = "1"b;                                    /* "-long" */
 812           go to endopt;
 813 
 814 
 815 abgn(16): spec_segsw = "1"b;                                /* "-special_seg" */
 816           go to endopt;
 817 
 818 
 819 abgn(17): substr (sws, 4, 1) = "1"b;                        /* "-log" */
 820           if f = 3                                          /* if "initiate" function, then possible pathname follows*/
 821                then go to nxtarg;                           /* optional pathname argument may follow */
 822                else go to endopt;                           /* else no pathname is allowed */
 823 
 824                                                             /* opt. pathname of "initiate" function*/
 825 aarg(17): init_log_segment = "";                            /* set 1st to null */
 826           call expand_path_ ( argp, argl, addr(init_log_segment), null, code);
 827           if code ^= 0
 828                then go to argerr;
 829           go to endopt;                                     /* terminate this option */
 830 
 831 aend(17): init_log_segment = "";                            /* no pathname was supplied */
 832           go to ckopt;                                      /* find out what arg really is */
 833 
 834 abgn(18): defersw = "1"b;                                   /* "-defer" */
 835           go to endopt;
 836 
 837 
 838 abgn(19): uidsw = "1"b;                                     /* "-uid" */
 839           go to endopt;
 840 
 841 
 842 abgn(20): goto nxtarg;                                      /* "-set_log_dir" option */
 843                                                             /* go pick up pathname of documentation dir. */
 844 
 845 aarg(20): doc_dir = "";                                     /* get ready to test expected path */
 846           if arg ^= "" then
 847                call expand_path_(argp, argl, addr(doc_dir), null, code);
 848           if code ^= 0
 849                then goto argerr;                            /* bad pathname syntax */
 850           t.log_directory = doc_dir;                        /* update our temporary */
 851           docsw = "1"b;
 852           goto endopt;
 853 
 854 
 855 aend(20): code = error_table_$wrong_no_of_args;             /* means we didn't get expected arg */
 856           goto argerr;
 857 
 858 
 859 abgn(21): mlsw = "1"b;                                      /* "-max_length" */
 860           go to nxtarg;
 861 
 862 
 863 aarg(21): maxl = cv_dec_check_ (arg, code);                 /* check for numeric arg */
 864           if code ^= 0 then do;
 865                call com_err_ (error_table_$bad_conversion, (proc), "Argument  ^a  ^a.",
 866                     arg,  "could not be converted to a proper length" );
 867                go to return;
 868                end;
 869           go to endopt;                                     /* self terminating */
 870 
 871 
 872 aend(21): maxl = sys_info$max_seg_size;                     /* default to highest */
 873           go to ckopt;                                      /* check new option */
 874 
 875 
 876 abgn(22): substr(sws, 7, 1) = "1"b;                         /* "-initial_acl" */
 877           if f = 5                                          /* if "add" function then */
 878                then t.acl(1).n = 0;                         /* reset default acl */
 879           go to endopt;                                     /* self-terminating option */
 880 
 881 
 882 abgn(23): nofillsw = "0"b;                                  /* "-fill" */
 883           go to endopt;
 884 
 885 
 886 abgn(24): nofillsw = "1"b;                                  /* "-no_fill" */
 887           go to endopt;
 888 
 889 
 890 endopt:   option = 0;                                       /* self-terminating options */
 891           go to nxtarg;                                     /* go get next argument if any */
 892 
 893 /*^L*/
 894 
 895 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 896 
 897 
 898 start(1): p = addr (global_default);                        /* "set_defaults" function */
 899           q = addr (t);                                     /* copy updated defaults back to static storage */
 900           p -> default = q -> default;                      /* quick copy */
 901           return;                                           /* done */
 902 
 903 
 904                                                             /* "print_defaults" function */
 905 start(2): call ios_$attach ("installation_list_", "syn", "user_output", "w", status);
 906           faultlabel = start2a;                             /* recover from a segment fault error in case */
 907                                                             /* someone deleted the "current" installation */
 908                                                             /* object segment from under our noses. */
 909           call init_log ((npath > 0));                      /* validate current log pointer, unless user specified */
 910                                                             /* his own object seg as an option. */
 911           if logp = null then                               /* if no log is "current", then */
 912                go to start2a;                               /* we can't very well print its defaults. */
 913           p = addr (log.d);                                 /* otherwise, print its path name and defaults */
 914           call ioa_$ioa_stream ("installation_list_",
 915                "^/Defaults for  ^a>^a^/^5xring brackets:^/^-^d,^d,^d^/^5xACL:",
 916                logdir, logseg, p->default.rb(1), p->default.rb(2), p->default.rb(3));
 917           call upd_print_acl_ (addr (p->default.acl.a), p->default.acl.n, "100"b);
 918           if p->default.log_directory ^= ""                 /* if default log dir was set */
 919                then call ioa_$ioa_stream ("installation_list_", /* then tell the user */
 920                     "^5xdocumentation directory:^/^-^a", p->default.log_directory);
 921 start2a:  p = addr (global_default);                        /* print the global defaults, at the very least */
 922           call ioa_$ioa_stream ("installation_list_",
 923                "^/Global defaults^/^5xring brackets:^/^-^d,^d,^d^/^5xACL:",
 924                p->default.rb(1), p->default.rb(2), p->default.rb(3));
 925           call upd_print_acl_ (addr (p->default.acl.a), p->default.acl.n, "100"b);
 926           if p->default.log_directory ^= ""                 /* if global default log dir was set */
 927                then call ioa_$ioa_stream ("installation_list_", /* then tell the user */
 928                     "^5xdocumentation directory:^/^-^a", p->default.log_directory);
 929           call ioa_$ioa_stream ("installation_list_", "");  /* space up paper */
 930           go to clean_up;                                   /* detach streams, and quit. */
 931 
 932 
 933 start(3): call init_log (rstrtsw);                          /* "init" function, see about log */
 934           p = addr (log.d);                                 /* copy acl, rb defaults into log segment */
 935           q = addr (t);                                     /* consist of global defaults updated by args */
 936           p -> default = q -> default;                      /* quick copy */
 937           log.fcn(1).date = fs_date();                      /* record date that log was changed. */
 938           log.fcn(1).group_id = log.lock.group_id;          /* record installer's name in create-log slot */
 939           if docsw then                                     /* we're going to change the documentation dir */
 940                if log.processp ^= null then                 /* if we've already "installed" then */
 941                                                             /* we can't change it.                  */
 942                     call com_err_ (error_table_$out_of_sequence, (proc), "^/^a ^a>^a^/^a.^/^a.",
 943                          "Installation object (io) segment", logdir, logseg, "has previously been installed",
 944                          "The documentation directory has not be changed");
 945           if logsw then do;                                 /* there's a description coming... */
 946                if log.processp ^= null then                 /* if desc. task already allocated, then can't change it */
 947                     call com_err_ (error_table_$out_of_sequence, (proc), "^/^a ^a>^a^/^a.^/^a^/^a",
 948                          "Installation object (io) segment", logdir, logseg, "has previously been installed",
 949                          "The installation description cannot be changed.",
 950                          "As a result, the ""-log"" argument has been ignored.");
 951                else
 952                     call get_reason(Pmsa_ptr, nofillsw, log.description);
 953                                                             /* pick up the typed lines */
 954                                                             /* we'll allocate the task at "install" time */
 955                end;
 956           go to return;                                     /* unlock log and return to installer */
 957 
 958 
 959 start(4): call init_log ("1"b);                             /* "print" function, see about log */
 960           call ios_$attach ("installation_list_", "syn", "user_output", "w", status);
 961           call ios_$attach ("installation_error_", "syn", "error_output", "w", status);
 962                                                             /* attach the installation output streams         */
 963           if logsw then do;                                 /* print the documentation description only */
 964                if log.description ^= null then              /* looks like something's there */
 965                                                             /* pass only minimum args */
 966                     call upd_describe_task_ ( "000001"b, log.nullp, log.nullp, 0, 0, log.nullp, 0,
 967                          log.nullp, log.d.log_directory, log.description, log.fcn(3).date);
 968                goto skip_print;                             /* skip other print functions */
 969                end;
 970           ctlw = substr("000001"b || sws,1, length(ctlw));  /* form print control word */
 971           call condition_("task_linkage_err_", linkage_err);/* set up handler for linkage errors */
 972           call upd_task_("0"b, (log.listp), upd_gen_call_, addr (ctlw));
 973                                                             /* go process task list */
 974 skip_print:
 975           call ioa_$ioa_stream ("installation_list_", "");  /* insert a blank line after the output. */
 976           go to clean_up;
 977 
 978 
 979 start(5):                                                   /* "add" function */
 980 start(6):                                                   /* "replace" function */
 981 start(7):                                                   /* "move" function */
 982 start(8): if log.processp ^= null then do;                  /* "delete" function; make sure installation */
 983                                                             /* requests can still be added to log */
 984                call com_err_ (error_table_$out_of_sequence, (proc), "^/^a ^a>^a^/^a.^/^a.",
 985                     "Installation object (io) segment", logdir, logseg, "has previously been installed",
 986                     "No more installation requests may be added to the segment");
 987                go to return;                                /* unlock log and return to installer */
 988                end;
 989           if npath < pmin(f) then do;                       /* check minimum pathname count */
 990 path_err:      if pmin(f) = pmax(f) then                    /* specialize form of error msg. */
 991                     eqseg = "^/^a^/^a  ""^a""  ^a:  ^d.";   /* min # of paths = max # */
 992                else
 993                     eqseg = "^/^a^/^a  ""^a""  ^a:  ^d  or  ^d.";     /* min # of paths < max # paths */
 994                call com_err_(error_table_$wrong_no_of_args, (proc), eqseg,
 995                     "The number of path names which must be specified",
 996                     "with the", (function_table(f)), "function is", (pmin(f)), (pmax(f)));
 997                go to return;                                /* unlock log and return to installer */
 998                end;
 999           if f = 6 then if npath = 2 then do;               /* third arg is optional for replace */
1000                dir(3) = dir(2);                             /* if omitted, third path becomes directory part  */
1001                seg(3) = seg(1);                             /* of second path, and entryname part of first    */
1002                                                             /* path, meaning put new seg in old directory.    */
1003                end;
1004           if ( f = 5 | f = 6) then if npath = 2 then        /* if we're adding/replacing and only 2 paths given,        */
1005                if t.names(1).n ^= 0 then                    /* and  "-name" option was issued,                */
1006                     seg(3) = t.names(1).a(1).name;          /* then entryname part of third path becomes      */
1007                                                             /* first name in "-name" array"                   */
1008           call condition_ ("area", msa_manager_$area_handler );
1009                                                             /* set up handler for "area" condition  */
1010           allocate rq in (area);                            /* get some space to put things for this call */
1011           do i = 1 to 3;                                    /* three of everything (coincidence?) */
1012                rq.dir(i) = dir(i);                          /* dirname */
1013                rq.seg(i) = seg(i);                          /* entryname */
1014                rq.rb(i) = t.rb(i);                          /* ring brackets */
1015                n = t.acl(i).n;                              /* get count for this acl entry */
1016                if n ^= 0 then do;                           /* anything there? */
1017                     allocate acl in (area) set (p);         /* yes, make us an acl */
1018                     q = addr (t.acl(i).a(1));               /* get pointer to temporary one */
1019                     p -> acl = q -> acl;                    /* copy acl into log segment */
1020                     rq.ap(i) = p;                           /* set pointer and length in request block */
1021                     rq.an(i) = n;                           /* for call to upd_install_task_ */
1022                     end;
1023                n = t.names(i).n;                            /* get count for name array entry */
1024                if n ^= 0 then do;                           /* same as for acl */
1025                     allocate names in (area) set (p);       /* we got one, allocate space in log */
1026                     q = addr (t.names(i).a(1));             /* get pointer to names array */
1027                     p -> names = q -> names;                /* copy names */
1028                     rq.np(i) = p;                           /* set pointer */
1029                     rq.nn(i) = n;                           /* and size */
1030                     end;
1031                end;
1032           rq.options = sws;                                 /* copy option switches */
1033           rq.maxlen = maxl;                                 /* max length */
1034           ctlw = "01"b;                                     /* allocating task only, no processing */
1035           errlabel = command_ignored;                       /* no error recovery either */
1036           call ios_$attach ("installation_error_", "syn", "error_output", "w", status);
1037                                                             /* attach error stream in case one occurs.        */
1038           call condition_("task_error_", task_error);       /* set up condition handler for task errors */
1039           call condition_("task_linkage_err_", linkage_err);/* .. for linkage errors */
1040           call condition_("thread_task_", thread_task);     /* .. for task threading */
1041           call upd_add_task_$init (Pmsa_ptr, log.linkp);    /* tell tasker where area and link list are */
1042           call upd_install_task_(ctlw, Pmsa_ptr, log.nullp, rq.code, rq.sev, rq.taskp, rq.seqno,
1043                rq.dir, rq.seg, rq.rb, rq.ap, rq.an, rq.np, rq.nn, rq.options, rq.temp, rq.maxlen,
1044                log.sw.full_recovery, log.d.log_directory, log.fcn(3).date, log.fcn(4).date);
1045           log.sw.special_segs = log.sw.special_segs | substr (sws, 3, 1); /* if we're installing a special segment */
1046           log.sw.logging_sw = log.sw.logging_sw | substr (sws, 4, 1);    /* if there's documenting... */
1047           log.fcn(1).date = fs_date();                      /* record date that log was changed. */
1048           log.fcn(1).group_id = log.lock.group_id;          /* record who changed the log last */
1049           go to cleanerr;                                   /* do some cleanup work, then quit */
1050 command_ignored:
1051           call com_err_ (error_table_$fatal_error, (proc),
1052                "^/As a result, the  ""^a ^a""  command has been ignored.",
1053                (proc), (function_table(f)));
1054           log.sw.error = "0"b;                              /* ignore this error in any listing. */
1055           go to cleanerr;                                   /* see, we had an error. Detach error stream. */
1056 
1057 
1058 start(9): call init_log ("1"b);                             /* "install" function; make sure log exists       */
1059           if log.listp = null then do;                      /* no listp -> no tasks in list                   */
1060 nolistp:       call com_err_(error_table_$out_of_sequence, (proc), "^/Installation log is empty.  ^a>^a.",
1061                     logdir, logseg );                       /* let user figure this one out !                 */
1062                goto return;                                 /* and exit stage do_nothing                      */
1063                end;
1064           if log.processp = log.listp then                  /* if log was installed before, but completely    */
1065                if log.sw.error then do;                     /* de_installed, and if errors occurred during    */
1066                     endlabel = start9a;                     /* installation, then clear these errors by       */
1067                     ctlw = "00000000010"b;                  /* calling "update_seg clear -error" function as  */
1068                     go to start11a;                         /* internal subroutine.                           */
1069                     end;
1070 start9a:  endlabel = full_recovery_off;                     /* if installation completes successfully, then   */
1071                                                             /* installation can never be fully-de_installed   */
1072           ctlw = "00101"b;                                  /* set up a "compile" and "task_run" control word */
1073           xxx = "Installation";                             /* set up directional variable for com_err_ msg   */
1074           log.fcn(3).date = fs_date();                      /* set date and time of installation.             */
1075           log.fcn(3).group_id = log.lock.group_id;          /* record who installed the log.                  */
1076           log.fcn(4).date = 0;                              /* clear date for possible future de_installation.*/
1077           go to start9b;                                    /* skip initialization for "de_install" function  */
1078 
1079 start(10):call init_log ("1"b);                             /* "de_install" function; make sure log exists    */
1080           if log.listp = null                               /* and make sure listp -> a list of tasks         */
1081                then goto nolistp;                           /* no listp -> no task list                       */
1082           if log.fcn(3).date = 0 then do;                   /* zero install date means we can't "de_install"  */
1083                call com_err_(error_table_$out_of_sequence, (proc),
1084                     "^/Installation Object segment ^a>^a has NOT been ""installed"".",
1085                     logdir, logseg );                       /* tell user the good news                        */
1086                goto return;                                 /* and exit                                       */
1087                end;
1088           endlabel = clean_up;                              /* cleanup when done.                             */
1089           ctlw = "10101"b;                                  /* set "reverse", "compile", & "task_run" control */
1090           xxx = "De-installation";                          /* set reverse direction in var for com_err_ msg  */
1091           log.fcn(4).date = fs_date();                      /* set date and time of de_installation.          */
1092           log.fcn(4).group_id = log.lock.group_id;          /* record who de_installed the log.               */
1093 
1094 start9b:  if stopsw then                                    /* user doesn't want error recovery */
1095                errlabel = abort;                            /* customer always knows best */
1096           else                                              /* he didn't say, */
1097                errlabel = recover;                          /* so do it for him */
1098           call ios_$attach ("installation_list_", "syn", "user_output", "w", status);
1099           call ios_$attach ("installation_error_", "syn", "error_output", "w", status);
1100                                                             /* Here We GO!  Attach installation streams first */
1101           call condition_("task_error_", task_error);       /* set up condition handlers */
1102           call condition_("task_linkage_err_", linkage_err);/* for all kinds of errors */
1103           call condition_("thread_task_", thread_task);     /* set up handler for task threading */
1104           call condition_ ("area", msa_manager_$area_handler);
1105                                                             /* handler for "area" condition.        */
1106           call condition_ ( "any_other", default_handler ); /* handle all conditions and treat them as */
1107                                                             /* fatal errors unless they're very special. */
1108           call upd_add_task_$init (Pmsa_ptr, log.linkp);    /* initialize task allocator */
1109           if log.processp = null then do;                   /* is this the very first time we've "process"ed log? */
1110                allocate in in (area);                       /* get some space to put things in for initialize call */
1111                in.io_name = logseg;                         /* copy name of current io seg */
1112                call upd_install_task_$init ("01"b, Pmsa_ptr, log.nullp, in.code, in.sev, in.taskp, in.seqno,
1113                     log.sw.special_segs, log.sw.full_recovery, in.temp, in.io_name);
1114                                                             /* add installer message routine to task list. */
1115                log.processp = log.listp;                    /* copy task list root pointer */
1116                if log.description ^= null then              /* at least we're writing a description */
1117                     log.sw.logging_sw = "1"b;               /* make sure the switch is set */
1118                if log.sw.logging_sw then do;                /* add description task, (if logging anything) */
1119                     allocate desc in (area);                /* grab space for description call */
1120                     call upd_describe_task_ ("01"b, Pmsa_ptr, log.nullp, desc.code, desc.sev,
1121                          desc.taskp, desc.seqno, desc.temp, log.d.log_directory, log.description, log.fcn(3).date);
1122                     end;
1123                end;
1124 rerun:    call upd_subtask_(ctlw, Pmsa_ptr, log.nullp, log.t.code, log.t.sev, log.t.taskp, log.t.seqno,
1125                log.processp, log.t.temp);                   /* process task list */
1126           go to endlabel;                                   /* "full_recovery_off" or "clean_up" */
1127 
1128 recover:  call reversion_ ("any_other");                                        /* stop handling conditions */
1129           substr (ctlw, 1, 1) = ^(substr (ctlw, 1, 1));     /* here for error recovery, do it backward now */
1130           call com_err_(error_table_$fatal_error, (proc), "^/^a aborted. The installation will be de-installed.", xxx);
1131           errlabel = abort;                                 /* avoid infinite error recovery loop */
1132           endlabel = clean_up;                              /* after recovery; don't unset full_recovery sw */
1133           xxx = "Error recovery";                           /* for com_err_ call */
1134           log.fcn(4).date = fs_date();                      /* set date of restoration and                    */
1135           log.fcn(4).group_id = log.lock.group_id;          /* record who is restoring the installation       */
1136           go to rerun;                                      /* and call task dispatcher again */
1137 
1138 abort:    call reversion_ ("any_other");                                        /* stop handling conditions */
1139           call com_err_(error_table_$fatal_error, (proc), "^a aborted.", xxx);
1140           go to clean_up;                                   /* cleanup, then return to user */
1141 
1142 full_recovery_off:
1143           log.sw.full_recovery = "0"b;                      /* once installation is complete, we cannot       */
1144           go to clean_up;                                   /* cleanup io streams and return. */
1145                                                             /* fully recover (by deleting new segs) during a  */
1146                                                             /* de_installation operation. */
1147 
1148 
1149 start(11):call init_log("1"b);                              /* "clear" function; make sure log exists         */
1150           if cerrorsw then                                  /* are we clearing errors? */
1151                if log.listp ^= null then                    /* if log has been installed before, */
1152                     if log.processp ^= log.listp then do;   /* but hasn't been completely de-installed... */
1153                          call com_err_ (error_table_$out_of_sequence, (proc),
1154                               "^/Performing the ""^a ^a -error"" function at this time^/will render ^a>^a unusable.",
1155                               (proc), (function_table(f)), logdir, logseg);
1156                          goto return;
1157                          end;
1158           ctlw = substr("000000000"b || sws,1,length(ctlw));/* do nothing but clearing task indicated by user */
1159 start11a: call condition_("task_linkage_err_", linkage_err);/* resolve our special linkage errors             */
1160           call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
1161                                                             /* process all upd_install_task_'s in task list   */
1162           log.fcn(2).date = fs_date();                      /* record date clear operation was performed. */
1163           log.fcn(2).group_id = log.lock.group_id;          /* record who cleared the log.                    */
1164           if ctlw & "00000000010"b then                     /* if errors have been cleared, then              */
1165                log.sw.error = "0"b;                         /* reset global error switch.                     */
1166           go to endlabel;
1167 
1168 
1169 start(12):call init_log("1"b);                              /* "list" function, log must exist */
1170           call suffixed_name_$new_suffix (logseg, "io", "il", listseg, code);
1171                                                             /* store name of listing segment */
1172           listdir = get_wdir_();                            /* put listing segment in working directory */
1173           Llistdir = mod (index (listdir, " ")+168, 169);   /* calculate length of non-blank part of dir */
1174           call msf_manager_$open (listdir, listseg, fcbp, code);
1175           if code = 0 then do;                              /* if it already exists, truncate it */
1176                call msf_manager_$adjust (fcbp, 0, 0, "111"b, code);
1177                if code ^= 0 then
1178                     go to listerr;
1179                end;
1180           else if code = error_table_$noentry then;         /* if it doesn't exist yet, all is well */
1181           else do;
1182 listerr:       call com_err_ (code, (proc),                 /* report other errors to user */
1183                     "^/Installation list (il) segment  ^a>^a  cannot be created.", listdir, listseg);
1184                go to return;                                /* unlock the log and return to installer.        */
1185                end;
1186           call msf_manager_$close (fcbp);                   /* close msf to conserve space in system_free_ */
1187 
1188           call ios_$attach ("installation_list_", "file_", substr (listdir, 1, Llistdir) || ">" || listseg,
1189                "w", status);                                /* attach I/O streams to installation list segment */
1190           if stat.code ^= 0 then do;
1191                code = stat.code;
1192                go to listerr;
1193                end;
1194           call ios_$attach ("installation_error_", "syn", "installation_list_", "w", status);
1195                                                             /* write error messages into the segment, too */
1196           call condition_ ("task_linkage_err_", linkage_err);         /* resolve task linkage errors */
1197 
1198           call date_time_ (clock(), date);                  /* write header of listing segment */
1199           call ioa_$ioa_stream ("installation_list_", "^|^/^a^2x^a>^a^2/^20a^a",
1200                "INSTALLATION OBJECT SEGMENT", logdir, logseg,
1201                "Listed on:", date);
1202 
1203           call date_time_$fstime (log.fcn(1).date, date);
1204           call ioa_$ioa_stream ("installation_list_", "^20a^a^/^20a^a (^a ^a)^/^20a^a",
1205                "Created by:", log.fcn(1).group_id,
1206                "Created with:", (proc), "MIS Version", log.version,
1207                "Created on:", date);
1208 
1209           if log.fcn(2).date ^= 0 then do;                  /* if log has been cleared, tell about that. */
1210                call date_time_$fstime (log.fcn(2).date, date);
1211                call ioa_$ioa_stream ("installation_list_", "^20a^a^/^20a^a",
1212                     "Cleared by:", log.fcn(2).group_id,
1213                     "Cleared on:", date);
1214                end;
1215 
1216           if log.fcn(3).date ^= 0 then do;                  /* if log has been installed, tell about that.    */
1217                call date_time_$fstime (log.fcn(3).date, date);
1218                call ioa_$ioa_stream ("installation_list_", "^20a^a^/^20a^a",
1219                     "Installed by:", log.fcn(3).group_id,
1220                     "Installed on:", date);
1221                end;
1222 
1223           if log.fcn(4).date ^= 0 then do;                  /* if log has been de_installed, tell about that  */
1224                call date_time_$fstime (log.fcn(4).date, date);
1225                                                             /* emphasize the fact of de-installation */
1226                call ioa_$ioa_stream ("installation_list_", "^/INSTALLATION HAS BEEN DE-INSTALLED");
1227                call ioa_$ioa_stream ("installation_list_", "^20a^a^/^20a^a",
1228                     "De-installed by:", log.fcn(4).group_id,
1229                     "De-installed on:", date);
1230                end;
1231 
1232 
1233           if log.description ^= null then do;               /* documentation description follows: */
1234                call ioa_$ioa_stream ("installation_list_", "^/DOCUMENTATION DESCRIPTION FOLLOWS:");
1235                                                             /* pass only minimum args. */
1236                call upd_describe_task_ ( "00000100100"b, log.nullp, log.nullp, 0, 0, log.nullp, 0,
1237                     log.nullp, "", log.description, log.fcn(3).date);
1238                end;
1239 
1240           call ioa_$ioa_stream ("installation_list_", "^3/SUMMARY OF THE INSTALLATION:");
1241           ctlw = "00000101000"b;                            /* output in brief mode */
1242           call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
1243                                                             /* let installation primitives generate output */
1244 
1245           if log.sw.error then do;                          /* if errors occurred, list them next */
1246                call ioa_$ioa_stream ("installation_list_", "^3/SUMMARY OF ERRORS WHICH OCCURRED DURING INSTALLATION:");
1247                ctlw = "00000110000"b;                       /* output errors only */
1248                call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
1249                end;
1250           else if log.fcn(3).date ^= 0 then                 /* if no errors occurred during installation, tell user */
1251                call ioa_$ioa_stream ("installation_list_", "^3/NO ERRORS OCCURRED DURING INSTALLATION.");
1252           else                                              /* otherwise, tell user log hasn't been installed */
1253                call ioa_$ioa_stream ("installation_list_",
1254                     "^3/INSTALLATION OBJECT SEGMENT HAS N^H_O^H_T^H_ BEEN INSTALLED.");
1255 
1256           if ^briefsw then do;                              /* if ^"-brief" mode, then print normal output */
1257                call ioa_$ioa_stream ("installation_list_",
1258                     "^5/A DESCRIPTION OF THE INSTALLATION FOLLOWS.^|^/INSTALLATION DESCRIPTION:");
1259                ctlw = "00000100000"b;                       /* output in normal mode */
1260                call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
1261                end;
1262 
1263           if longsw then do;                                /* if "-long" mode, then print details */
1264                call ioa_$ioa_stream ("installation_list_", "^5/INSTALLATION DETAILS FOLLOW:");
1265                ctlw = "00000100100"b;                       /* output in detailed mode */
1266                call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
1267                end;
1268 
1269 
1270 clean_up: call ios_$detach ("installation_list_", "", "", status);
1271 cleanerr: call ios_$detach ("installation_error_", "", "", status);
1272                                                             /* detach streams as a cleanup measure. */
1273           go to return;                                     /* unlock the log and return to installer.        */
1274 
1275 /*^L*/
1276 
1277 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1278 
1279 
1280 init_log:           procedure (sw);                         /* initialize installation log segment            */
1281 
1282 
1283      dcl  sw                            bit(1) aligned;     /* non-zero if reinitiating old segment           */
1284 
1285      dcl  process_id                    bit(36) aligned;    /* process id.                                    */
1286 
1287      dcl  seg_fault_error               condition;          /* condition                                      */
1288 
1289 
1290           if npath = 0 then do;                             /* no log specified as argument                   */
1291                on seg_fault_error begin;                    /* trap condition where io seg deleted without    */
1292                     logp = null;                            /* telling update_seg.                            */
1293                     go to faultlabel;
1294                     end;
1295                if logp ^= null then                         /* validate our log pointer as best we can.       */
1296                     if logp = log.selfp then do;
1297                          revert seg_fault_error;            /* stop handling this condition                    */
1298                          call validate_user;
1299                          return;
1300                          end;
1301                logp = null;                                 /* already null, or inconsistent                  */
1302                go to faultlabel;                            /* go bitch at user                               */
1303                end;
1304           logp = null;                                      /* make sure pointer, name not inconsistent       */
1305           msa_ptr = null;                                   /* ditto                                          */
1306           logdir = dir(1);                                  /* copy dirname of segment specified              */
1307           call suffixed_name_$find (logdir, seg(1), "io", logseg, type, mode, code);
1308                                                             /* find the io seg if it exists, or create        */
1309                                                             /* properly-suffixed path name from the one given */
1310                                                             /* to us by the user.                             */
1311           if sw then do;                                    /* perform re-initiation processing.              */
1312                if code ^= 0 then do;                        /* if we're re-init-ing a seg which doesn't exist,*/
1313 re_init_fail:       call com_err_ (code, (proc),
1314                          "^/Installation object (io) segment ^a>^a cannot be re-initiated.", logdir, seg(1));
1315                     go to return_without_unlocking;         /* then tell installer about it, and return.      */
1316                     end;
1317                if type = 2 then do;                         /* if a directory was found, then                 */
1318                     call com_err_ (error_table_$dirseg, (proc), "^/^a>^a ^a.^/^a.", logdir, logseg,
1319                          "is a directory",
1320                          "It cannot be re-initiated as an installation object (io) segment");
1321                     go to return_without_unlocking;
1322                     end;
1323                if mod (mode, 4) = 0 then do;                /* if user can't useio seg, then complain.        */
1324                     code = error_table_$moderr;
1325                     go to re_init_fail;
1326                     end;
1327                call msa_manager_$initiate (logdir, logseg, msa_ptr, (size(log)), logp, code);
1328                if code ^= 0 then do;                        /* Oh, Boy!  An error during initialization.      */
1329                     if code = error_table_$segno_in_use then
1330                                                             /* Component of io seg couldn't be initiated      */
1331                                                             /* with segno which was used before.  Tell the    */
1332                                                             /* user he must free this segno.                  */
1333                          call com_err_ (code, (proc), "^/^a ^a>^a^/^a ^o (octal).^/^a^/^a ^a again.",
1334                               "A component of the installation object (io) segment", logdir, logseg,
1335                               "must be initiated with the segment number", fixed (baseno(msa_ptr), 35),
1336                               "Please terminate the segment which is now known",
1337                               "by this number, and re-initiate", logseg);
1338                     else
1339                          if code = error_table_$noentry then do;
1340                                                             /* The first SSA of the MSA was not found.        */
1341                               call com_err_ (code, (proc), "^/^a ^a>^a^/^a.^/^a.",
1342                                    "The first component of the installation object (io) segment", logdir, logseg,
1343                                    "was discovered to be missing",
1344                                    "The installation object (io) segment cannot be re-initiated");
1345                               go to return_without_unlocking;
1346                               end;
1347                     else
1348                          if code = error_table_$seg_not_found then
1349                                                             /* An SSA, other than the first SSA of MSA, was   */
1350                                                             /* discovered to be missing.  A new SSA is        */
1351                                                             /* created to replace the old SSA.                */
1352                               call com_err_ ( code, (proc), "^/^a ^a>^a^/^a.^/^a.",
1353                                    "A component of the installation object (io) segment", logdir, logseg,
1354                                    "was discovered to be missing.  A new component was created to replace it",
1355                                    "Some data may be missing" );
1356                     else
1357                          if code = error_table_$improper_data_format then
1358                                                             /* an attempt was made to initiate an MSA which   */
1359                                                             /* was found to not be an MSA.                    */
1360                          call com_err_ (code, (proc), "^/^a>^a ^a.^/^a.",
1361                               logdir, logseg, "does not have the format of an installation object (io) segment",
1362                               "Please check its consistency" );
1363                     else                                    /* otherwise, it was another error.               */
1364                          call com_err_ ( code, (proc), "^a>^a", logdir, logseg);
1365                     go to return;
1366                     end;
1367                if msa_ptr = null then                       /* initiation failed.                             */
1368                     go to re_init_fail;
1369                if log.init_id = "0"b then do;               /* if this segment was never initiated before,    */
1370                     call msa_manager_$terminate (msa_ptr, code);
1371                                                             /* terminate it, and go initiate it with a high number. */
1372                     logp, msa_ptr = null;                   /* null ptr's, because terminate_seg doesn't.     */
1373                     go to init_high;
1374                     end;
1375                call validate_user;                          /* make sure this user knows what he's doing.     */
1376                process_id = get_process_id_();
1377                if log.init_id ^= process_id then            /* has log been initialized by this process?      */
1378                     call upd_add_task_$reset (log.linkp);   /* no, reset procedure entry pointers.            */
1379                log.init_id = process_id;                    /* leave out mark.                                */
1380                end;
1381 
1382           else do;                                          /* otherwise, we're creating the io seg.          */
1383                if code = 0 then do;                         /* zero code means log already exists. Tell user. */
1384                     call com_err_ (error_table_$namedup, (proc),
1385                          "^/Installation object (io) segment ^a>^a already exists.", logdir, logseg);
1386                     go to return_without_unlocking;         /* quit.                                          */
1387                     end;
1388                if code ^= error_table_$noentry then do;     /* any other errors are somewhat serious.         */
1389 randomerr:          call com_err_ (code, (proc),
1390                          "^/^a  ^a>^a  ^a", "Installation object segment", logdir, seg(1),
1391                          "cannot be initiated.");
1392                     go to return_without_unlocking;         /* quit.                                          */
1393                     end;
1394 init_high:     call msa_manager_$make_special (256, logdir, logseg, msa_ptr, (size(log)), logp, code);
1395                if code ^= 0 then do;
1396                     msa_ptr = null;                         /* make sure it's null */
1397                     if sw then go to randomerr;             /* re-initting old one */
1398                     if code = error_table_$segno_in_use then do;/* msa_man_ has this gross bug */
1399                                                             /* which leaves new seg hanging around */
1400                          call hcs_$delentry_file ( logdir, logseg, (0) );
1401                          call com_err_ (code, (proc), "^/^a.  ^a>^a ^a.^/^a.",
1402                               "No high segment numbers are available", logdir, logseg,
1403                               "cannot be initiated",
1404                               "Type:  ""new_proc""  and try again");
1405 
1406                          go to return_without_unlocking;
1407                          end;
1408                     go to randomerr;                        /* something else */
1409                     end;
1410 
1411                log.lock.word = "0"b;                        /* lock the new installation object segment.      */
1412                log.lock.group_id = get_group_id_$tag_star();
1413                log.version = Version_No;                    /* initialize the io seg header.                  */
1414                call validate_user;
1415                log.areap = msa_ptr;
1416                log.d.log_directory = "";
1417                log.init_id = "0"b;                          /* make sure it's 0                               */
1418                log.selfp = logp;                            /* save copy of log pointer in log segment        */
1419                log.linkp,                                   /* initialize linkage list ptr.                   */
1420                log.listp,                                   /* no task list...                                */
1421                log.processp,                                /* no task-last-processed.                        */
1422                log.nullp,
1423                log.description,
1424                log.t.taskp,
1425                log.t.temp = null;
1426                log.fcn.group_id = log.lock.group_id;        /* record creator of io seg.  Only he can build,  */
1427                                                             /* install, de_install, or clear seg w/o questions*/
1428 
1429                log.fcn.date,
1430                log.d.rb(1),
1431                log.d.rb(2),
1432                log.d.rb(3),
1433                log.d.acl.n,
1434                log.t.code,
1435                log.t.sev = 0;
1436 
1437                log.t.seqno = 32767;                         /* highest seqno means append upd_subtask_ to the */
1438                                                             /* very end of the primary task list.             */
1439                log.sw.full_recovery = "1"b;                 /* to start with, full recoveries are allowed.    */
1440                log.sw.special_segs,                         /* to start with, there are no special segs       */
1441                log.sw.error,                                /* there are no errors,                           */
1442                log.sw.logging_sw = "0"b;                    /* and, to start, there's no documentation        */
1443 
1444                log.init_id = get_process_id_();             /* leave our mark.                                */
1445                end;
1446 
1447           end init_log;
1448 
1449 
1450 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1451 
1452 
1453 /*^L*/
1454 
1455 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1456 
1457 
1458 validate_user:      procedure;                              /* This procedure validates the current user      */
1459 
1460           if log.version ^= Version_No then do;             /* first, check version numbers                   */
1461                                                             /* if not same, tell user the bad news            */
1462                     call com_err_ (error_table_$fatal_error, (proc),
1463                          "^a>^a was created with MIS Version ^a.^/^a ^a.^/^a ^a ^a ^a.", logdir, logseg,
1464                          log.version, "The version you are now using is MIS Version ", Version_No,
1465                          "As a result, the", (proc), (function_table(f)), "command has been ignored");
1466                     logp = null;
1467                     go to return;                           /* can't use this log */
1468                     end;
1469 
1470           call set_lock_$lock (log.lock.word, 0, code);     /* lock the installation object segment.          */
1471           if code ^= 0 then
1472                if code = error_table_$invalid_lock_reset then;
1473                                                             /* somebody bombed out while processing io seg?   */
1474                                                             /* ignore him.                                    */
1475                else if code = error_table_$locked_by_this_process then
1476                     call com_err_ (code, (proc), "^/^a  ^a>^a.^/^a ^a ^a function.",
1477                          "Non-fatal error encountered while locking", logdir, logseg,
1478                          (proc), "will continue performing the", (function_table(f)));
1479                else if code = error_table_$lock_wait_time_exceeded then do;
1480 lockerr:            call com_err_ (error_table_$seglock, (proc), "^/^a  ^a>^a^/^a ^a.^/The  ""^a ^a""  ^a.",
1481                          "Installation object (io) segment", logdir, logseg,
1482                          "is already being manipulated by", log.lock.group_id,
1483                          (proc), (function_table(f)), "command cannot be performed");
1484                     go to return_without_unlocking;         /* don't unlock seg; just return.                 */
1485                     end;
1486                else                                         /* report any other errors.                       */
1487                     go to lockerr;
1488           if log.lock.group_id ^= get_group_id_$tag_star() then do;
1489                                                             /* if another installer last referenced this log  */
1490                                                             /* then ask this installer if he knows what he's  */
1491                                                             /* doing.                                         */
1492                call command_query_ (addr (query_info), answer, (proc),
1493                     "^a>^a ^a ^a.^/^a  ""^a ^a""  command?",
1494                     logdir, logseg, "was created by", log.lock.group_id,
1495                     "Do you still wish to issue the", (proc), (function_table(f)));
1496                                                             /* make sure this user wants to do his thing.     */
1497                if answer = "yes" then
1498                     log.lock.group_id = get_group_id_$tag_star();
1499                                                             /* now this guy owns the io seg.                  */
1500                else do;
1501                     logp = null;                            /* forget the initialization done so far.         */
1502                     go to return;
1503                     end;
1504                end;
1505           end validate_user;                                /* return to init_log, if user is OK.             */
1506 
1507 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1508 /* ^L */
1509 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1510 
1511 
1512 
1513 unlock_log:         procedure;                              /* unlock io segment, if it is locked.            */
1514 
1515           if logp ^= null then if log.lock.word then do;    /* if we have an io seg which is locked, then     */
1516                call set_lock_$unlock (log.lock.word, code); /* unlock it.                                     */
1517                if code ^= 0 then
1518                     call com_err_ (code, (proc), "^/While unlocking  ^a>^a.", logdir, logseg);
1519                end;
1520           end unlock_log;                                   /* return to caller.                              */
1521 
1522 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1523 
1524 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1525 
1526 
1527 fs_date:            procedure returns (fixed bin(35));      /* return current fs_time value.                  */
1528 
1529      dcl  date                          fixed bin(35),      /* the fs_date value.                             */
1530           date_str                      bit(36) aligned based (addr (date)),
1531           time                          fixed bin(71),      /* the current time.                              */
1532           time_str                      bit(72) aligned based (addr (time));
1533 
1534           time = clock();                                   /* The time is now ...                            */
1535           date_str = substr (time_str, 21, 36);             /* The fs_time is now...                          */
1536           return (date);
1537 
1538           end fs_date;
1539 
1540 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1541 
1542 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1543 
1544 
1545 thread_task:        procedure (mcp, name, wcp, taskp, csw); /* handler for "thread_task_" condition */
1546 
1547 
1548      dcl  mcp                           ptr,                /* machine conditions pointer */
1549           name                          char(*),            /* condition name */
1550           wcp                           ptr,                /* crawl-out data pointer */
1551           taskp                         ptr,                /* pointer to allocated task */
1552           csw                           bit(1) aligned;     /* continue switch */
1553 
1554           call upd_thread_task_(log.listp, taskp);          /* add task to current task list */
1555           end thread_task;                                  /* and return to signaller. */
1556 
1557 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1558 /*^L*/
1559 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1560 
1561 
1562 task_error:         procedure (mcp, name, wcp, sp, csw);    /* "task_error_" handler */
1563 
1564      dcl  mcp                           ptr,                /* machine conditions pointer */
1565           name                          char(*),            /* condition name signalled */
1566           wcp                           ptr,                /* crawl-out data pointer */
1567           sp                            ptr,                /* status block pointer */
1568           csw                           bit(1) aligned;     /* continue switch */
1569 
1570      dcl  1 s                           aligned based (sp), /* status block for task error */
1571             2 proc                      char(32) unal,      /* name of procedure causing error */
1572             2 entry                     char(32) unal,      /* entry point name */
1573             2 code                      fixed bin(35),      /* status code */
1574             2 sev                       fixed bin,          /* severity code */
1575             2 string                    char(200);          /* optional message */
1576 
1577 
1578           log.sw.error = "1"b;                              /* record the fact that some error occurred       */
1579           if s.sev >= fail then do;                         /* if the error is fatal, then attempt to recover */
1580                call upd_print_err_(s.code, s.sev, "^NError^O", "", s.proc, s.entry, s.string);
1581                go to errlabel;                              /* unwind stack and begin error recovery */
1582                end;
1583           else                                              /* report non-fatal errors to user & continue.    */
1584                call upd_print_err_ (s.code, s.sev, "Warning", "", s.proc, s.entry, s.string);
1585           end task_error;                                   /* continue installing/de_installing              */
1586 
1587 
1588 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1589 
1590 
1591 linkage_err:        procedure (mcp, name, wcp, sp, csw);    /* handler for "task_linkage_err_" condition */
1592 
1593 
1594      dcl  mcp                           ptr,                /* machine conditions pointer */
1595           name                          char(*),            /* condition name */
1596           wcp                           ptr,                /* crawl-out data pointer */
1597           sp                            ptr,                /* pointer to status block */
1598           csw                           bit(1) aligned;     /* continue switch */
1599 
1600      dcl  1 s                           aligned based (sp), /* n.b. not same as for "error", above */
1601             2 proc                      char(32),           /* name of procedure signalling error */
1602             2 entry                     char(32),           /* entry point name */
1603             2 code                      fixed bin(35),      /* status code */
1604             2 sev                       fixed bin,          /* severity code */
1605             2 rname                     char(32),           /* refname of referenced procedure */
1606             2 ename                     char(32);           /* entryname of referenced procedure */
1607 
1608 
1609           call upd_print_err_(s.code, s.sev, "Task linkage error", "", s.proc, s.entry,
1610                "Entry point referenced was ^a$^a", s.rname, s.ename);
1611           call cu_$cl;                                      /* reenter command level, let user fix it */
1612           end linkage_err;                                  /* return to try again */
1613 
1614 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1615 /*^L*/
1616 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1617 
1618 
1619 
1620 
1621 default_handler:    procedure;                              /* handler for "unknown" conditions               */
1622 
1623 
1624      dcl  1  cond_info aligned,                             /* condition info */
1625              2 mcptr          ptr,
1626              2 version        fixed bin,
1627              2 condition_name char(32) var,
1628              2 infop          ptr,
1629              2 wcptr          ptr,
1630              2 loc_ptr        ptr,
1631              2 flags          aligned,
1632                3 crawlout     bit(1) unal,
1633                3 pad1         bit(35) unal,
1634              2 pad_word       bit(36) aligned,
1635              2 user_loc       ptr,
1636              2 pad(4)         bit(36) aligned;
1637 
1638           call find_condition_info_ ( null, addr(cond_info), code);
1639           if code ^= 0 then do;
1640                call ioa_$ioa_stream ("error_output", "Error:  Unknown signal has been received." );
1641                go to errlabel;                                        /* if call fails then try to back up */
1642                end;
1643 
1644           if cond_info.condition_name = "alrm" then do;
1645 continue:      call continue_to_signal_ (code);                       /* pass this error on to another handler. */
1646                return;
1647                end;
1648           if cond_info.condition_name = "signal_io_" then
1649                go to continue;
1650 
1651           if cond_info.condition_name = "cput" then                   /* ditto                                          */
1652                go to continue;
1653           if cond_info.condition_name = "linkage_error" then          /* let system's default handler handle these      */
1654                go to continue;
1655           if cond_info.condition_name = "mme2" then                   /* let debug intercept breakpoints.               */
1656                go to continue;
1657           if cond_info.condition_name = "quit" then                   /* let system quit handler handle them.           */
1658                go to continue;
1659           if cond_info.condition_name = "command_error" then          /* if our own error handler passed,     */
1660                go to continue;                                        /* pass it on.  */
1661           if cond_info.condition_name = "finish" then                 /* means it's all over anyway           */
1662                go to continue;
1663           if cond_info.condition_name = "stack" then                  /* we're coming close to the end        */
1664                go to continue;
1665           if cond_info.condition_name = "program_interrupt" then      /* ignore program interrupts.                     */
1666                return;
1667           if cond_info.condition_name = "stringsize" then do;         /* handle stringsize by reporting it. */
1668                call ioa_$ioa_stream ("error_output", "Error: stringsize condition occurred.");
1669                go to STOP;                                            /* condition_interpreter_ ignores these */
1670                end;                                                   /*  conditions.                         */
1671 
1672           call condition_interpreter_ (null(), null(), 0, 3, cond_info.mcptr, (cond_info.condition_name),
1673                 cond_info.wcptr, cond_info.infop);
1674           if stopsw then do;
1675 STOP:          call ioa_$ioa_stream ("error_output",
1676                     "Returning to command level.  Type: ""start"" to begin recovery operations.");
1677                call cu_$cl();
1678                go to recover;
1679                end;
1680 
1681           go to errlabel;                                             /* treat them as fatal errors.                    */
1682 
1683           end default_handler;
1684 
1685 
1686 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1687 /*^L*/
1688 get_reason:         proc (areap, nofillsw, rcp);            /* this proc accepts typed line input for */
1689                                                             /* documentation later */
1690           /* As of March, 1980, the "reason" may be contained in a segment
1691              rather than always asking the user to type it in.  The variable
1692              init_log_segment is the pathname of that segment.              */
1693 
1694 dcl
1695      areap          ptr,                                    /* area ptr for allocation */
1696      nofillsw       bit(1) aligned,                         /* on if reason is NOT to be filled.              */
1697      rcp            ptr;                                    /* ptr to description within area */
1698 
1699 dcl                                                         /* misc. error codes */
1700     (error_table_$end_of_info,
1701      error_table_$short_record,
1702      error_table_$not_detached)         ext static fixed bin(35);
1703 dcl
1704      code           fixed bin(35),
1705      i              fixed bin,
1706      total          fixed bin,                              /* total no. of chars in area */
1707      null           builtin,
1708      substr         builtin,
1709      break_sw       bit (1),
1710      tab_sw         bit(1),
1711      nelemt         fixed bin(21),                          /* no. of elements read */
1712      blockp         ptr,                                    /* ptr to allocated block */
1713      buffp          ptr;                                    /* ptr to input buffer */
1714 
1715 dcl  buffer         char (512) aligned;                     /* input buffer */
1716 
1717 dcl  out_buffer     char (16384) aligned;                   /* output buffer */
1718 
1719 dcl  Area           area based (areap);                     /* allocation area */
1720 
1721 dcl  1 block        based (blockp),                         /* block to be allocated */
1722        2 editsw     bit(1),                                 /* edit sw, "on" if already editted */
1723        2 no_chars   fixed bin(35),                          /* # of chars in this block */
1724        2 string     char (total refer (block.no_chars));    /* the character string */
1725 
1726 dcl  term_line (4)  char (1) init (
1727           ".",
1728           "?",
1729           ":",
1730           ";");
1731 
1732 dcl  HT             char (1) int static options(constant) init("      ");
1733 dcl  NL             char (1) int static options(constant) init ("
1734 ");                                                         /* new_line char */
1735 
1736 dcl
1737      ioa_                     entry options (variable),
1738      iox_$attach_name         entry (char(*), ptr, char(*), ptr, fixed bin(35)),
1739      iox_$find_iocb           entry ( char(*), ptr, fixed bin(35)),
1740      iox_$open                entry ( ptr, fixed bin, bit(1) aligned, fixed bin(35)),
1741      iox_$get_line            entry ( ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)),
1742      iox_$detach_iocb         entry ( ptr, fixed bin(35)),
1743      iox_$close               entry ( ptr, fixed bin(35));
1744 dcl
1745      iocb_ptr                 ptr,                          /* ptr to the I/O control block */
1746      atd                      char(256),                    /* attach description */
1747      switch_name              char(32),
1748      Path                     bit(1),                       /* ON = look for segment */
1749      ref_ptr                  ptr;
1750 
1751           total = 0;
1752           out_buffer = "";
1753           ref_ptr = null;
1754           buffp = addr(buffer);
1755 
1756           if init_log_segment ^= ""                         /* means look for a segment */
1757                then Path = "1"b;
1758                else Path = "0"b;                            /* otherwise, ask from the terminal */
1759 
1760           if Path then do;
1761                switch_name = "upd_init_log_sw_";
1762                atd = "vfile_ " || init_log_segment;         /* build attach description */
1763                call iox_$attach_name ( switch_name, iocb_ptr, atd, ref_ptr, code);
1764                if ( code ^= 0 ) & (code ^= error_table_$not_detached) then do;
1765                     call com_err_ (code, (proc), "Attaching ^a.^/^a",
1766                          init_log_segment,
1767                          "The ""log"" information remains unchanged.");
1768                     return;
1769                end;
1770 
1771                call iox_$open ( iocb_ptr, 1, "0"b, code);
1772                if code ^= 0 then do;
1773                     call com_err_ (code, (proc), "Opening ^a^/^a",
1774                          init_log_segment,
1775                          "The ""log"" information remains unchanged.");
1776                     go to DETACH_ILS;
1777                end;
1778           end;
1779           else do;
1780                call iox_$find_iocb ( "user_input", iocb_ptr, code );
1781                if code ^=0 then do;
1782                     call com_err_ ( code, (proc),
1783                          "Attaching ""user_input"".^/^a",
1784                          "the ""log"" information remains unchanged.");
1785                end;
1786                call ioa_ ("Input");                         /* tell user to type */
1787           end;
1788           tab_sw = "0"b;
1789 
1790 read:     call iox_$get_line (iocb_ptr, buffp, length(buffer), nelemt, code);
1791           if code = error_table_$end_of_info
1792                then go to process;
1793           if (code ^= 0) & (code ^= error_table_$short_record) then do;
1794                call com_err_ (code, (proc), "Reading ""log"" information.^/^a",
1795                     "The ""log"" information remains unchanged.");
1796                go to RETURN;
1797           end;
1798           if nelemt = 2
1799                then if substr(buffer,1,1) = "."
1800                     then goto process;                      /* end of input reached */
1801           if (total + (nelemt-1)) >= length(out_buffer)
1802                then goto warn;                              /* too many chars read */
1803 
1804           if nofillsw then do;
1805                                                             /* copy buffer into temp storage */
1806                if total + nelemt >= length(out_buffer)      /* check total again */
1807                     then goto warn;
1808                substr(out_buffer,(total+1),nelemt) = substr(buffer,1,nelemt);
1809                total = total + nelemt;                      /* reset total */
1810                end;
1811           else do;
1812 tab:           i = index(substr (buffer, 1, nelemt), HT);
1813                                                             /* look for tabs */
1814                if i ^= 0 then do;                           /* found one */
1815                     substr( buffer,i,1) = " ";              /* convert to single char */
1816                     tab_sw = "1"b;                          /* tell the user later. */
1817                     go to tab;
1818                     end;
1819                break_sw = "0"b;
1820                do i = 1 to 4;                               /* search for end of sentence chars */
1821                     if substr(buffer,(nelemt-1),1) = term_line(i)
1822                          then break_sw = "1"b;
1823                     end;
1824                if break_sw then do;
1825                     substr(buffer,nelemt,2) = "  ";         /* add 2 blanks */
1826                     nelemt = nelemt + 2;
1827                     end;
1828 
1829                if substr(buffer, 1, 1) = " " then           /* start on new line */
1830                     if total ^= 0 then do;
1831                     total = total + 1;
1832                     substr(out_buffer,total,1) = NL;        /* append new_line to out buffer */
1833                     end;
1834                if total ^= 0
1835                     then if substr(out_buffer,total,1) ^= NL
1836                          then if substr(out_buffer,total,1) ^= " " then do; /* add a blank between words */
1837                               total = total + 1;
1838                               substr(out_buffer,total,1) = " ";
1839                               end;
1840                                                             /* copy buffer into temp storage */
1841                if total + (nelemt-1) >= length(out_buffer)  /* check total again */
1842                     then goto warn;
1843                substr(out_buffer,(total+1),(nelemt-1)) = substr(buffer,1,(nelemt-1));
1844                total = total + (nelemt -1);                           /* reset total */
1845                end;
1846 
1847           goto read;
1848 
1849 process:                                                    /* allocate in area for keeping */
1850           if total = 0 then do;                             /* someone wanted to zap previous desc. */
1851                rcp = null;                                  /* null the pointer */
1852                go to RETURN;;                               /* and xfer out */
1853                end;
1854           allocate block in (Area) set (blockp);            /* grab the storage */
1855           blockp->block.editsw = nofillsw;                  /* not editted yet */
1856           blockp->block.no_chars = total;                   /* copy the number of characters */
1857           blockp->block.string = substr(out_buffer,1,total); /* and copy the characters */
1858           rcp = blockp;                                     /* finally, the return ptr */
1859           if tab_sw then                                    /* tell the user about any conversion */
1860                call ioa_ ( "Warning:  tabs have been converted to single blanks.^/");
1861 RETURN:   code = 0;
1862           if Path
1863                then call iox_$close ( iocb_ptr, code);
1864           if code ^= 0
1865                then call com_err_ (code, (proc), "Closing ""log"" info.");
1866 DETACH_ILS:
1867           if Path
1868                then call iox_$detach_iocb ( iocb_ptr, code);
1869           if code ^= 0
1870                then call com_err_ (code, (proc), "Detaching ""log"" info.");
1871           return;                                           /* finished */
1872 
1873 warn:                                                       /* too many characters entered */
1874           call ioa_("Maximum number of characters have been entered.^/""Input"" mode is terminated");
1875           goto process;
1876           end;
1877 
1878           end update_seg;