1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Bull Inc., 1988                *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   6         *                                                         *
   7         * Copyright (c) 1972 by Massachusetts Institute of        *
   8         * Technology and Honeywell Information Systems, Inc.      *
   9         *                                                         *
  10         *********************************************************** */
  11 
  12 
  13 /****^  HISTORY COMMENTS:
  14   1) change(87-10-15,TLNguyen), approve(87-10-15,MCR7774),
  15      audit(87-12-16,GWMay), install(88-01-12,MR12.2-1012):
  16      - The archive replace operation will display an appropriate error message
  17        for invalid components specified in the command line.
  18 
  19      - Replace the expand_pathname_ with the expand_pathname_$add_suffix to
  20        always append the "archive" suffix to an archive segment if an user
  21        does not supply the "archive" suffix.
  22   2) change(87-10-15,TLNguyen), approve(87-10-15,MCR7776),
  23      audit(87-12-16,GWMay), install(88-01-12,MR12.2-1012):
  24      - Make the archive xd operation produce correct error message when it
  25        extracts a single existing archive component into a nonexistent
  26        directory and delete this component in the archive if it extracts
  27        successfully.
  28 
  29      - Error also raised when more than one existing components to be
  30        extracted and place one of extracted components into a nonexistent
  31        directory (e.g. ac xd archive_seg >nonexistent_dir>seg_a seg_b).
  32        Currently, it deletes the component in the archive when it found
  33        the directory where the extracted component to be placed
  34        does not exist.  This error found while testing the archive.
  35   3) change(87-10-15,TLNguyen), approve(87-10-15,MCR7780),
  36      audit(87-12-16,GWMay), install(88-01-12,MR12.2-1012):
  37      - Make the archive append operation to avoid an out_of_bound fault.
  38        This error raised when an user sets the max length of the original
  39        archive less than its default max length and attempts to run the
  40        archive append operation.
  41 
  42      - So do the archive delete, replace, and update operations.
  43        These errors found while testing the archive.
  44                                                    END HISTORY COMMENTS */
  45 
  46 
  47 
  48 archive: ac: proc;
  49 
  50 /* archive command : operates as described in the MPM
  51 
  52    coded 8/1/69     J.W. Gintell
  53    conv to pl1       2/1/70
  54 */
  55 
  56 
  57 /* the following names have been shortened:
  58 
  59    gbct   global_bit_count
  60    wdct   word_count
  61    rcmp   replace_component
  62    ccmp   copy_component
  63    amsw   arc_mod_sw
  64    hbgn   header_begin
  65    hend   header_end
  66    bcnt   bit_count
  67    optr   orig_ptr
  68    cptr   copy_ptr
  69    tptr   tempptr
  70 */
  71 /* last modified on 12-4-73 by Kobziar not to check for append mode */
  72 /* changed to use external flag archive_data_$active 08/29/79 S. Herbst */
  73 /* Error messages fixed for "ac cud" 09/24/79 S. Herbst */
  74 /* A few bugs fixed 04/09/80 S. Herbst */
  75 /* Improve error messages 01/12/81 S. Herbst */
  76 /* Added "xd" key to extract and delete archive component 07/01/82 S. Herbst */
  77 /* Changed archive move to restore original on rqo 07/02/82 S. Herbst */
  78 /* Fixed to truncate after it shortens the archive 10/29/82 S. Herbst */
  79 /* Changed some error messages to give full component pathname 11/24/82 S. Herbst */
  80 /* Changed to prefix "appended to" and "updated in" msgs with command name 1st time only 11/21/83 S. Herbst */
  81 /* Changed update to print message if no components matched segs or none updated 12/12/83 S. Herbst */
  82 /* Fixed bug: overflow of global array if deleting many components and no comp args specified 12/12/83 S. Herbst */
  83 /* Fixed to ignore error_table_$no_s_permission from hcs_$status_long 04/18/85 Steve Herbst */
  84 /* Fixed to report error_table_$entlong with .archive appended 04/18/85 Steve Herbst */
  85 
  86 
  87 dcl moi char (8) aligned init ("archive");
  88 
  89 
  90 dcl archive_data_$active bit (1) aligned external;          /* ON if archive or archive_table af is active */
  91 
  92 dcl (archive_data_$ident,
  93      archive_data_$fence) ext char (8) aligned;
  94 
  95 dcl  error_table_$incorrect_access external fixed bin (35);
  96 dcl  error_table_$namedup external fixed bin (35);
  97 dcl  error_table_$no_append external fixed bin (35);
  98 dcl  error_table_$no_s_permission external fixed bin (35);
  99 dcl  error_table_$noentry external fixed bin (35);
 100 dcl  error_table_$moderr external fixed bin (35);
 101 dcl  error_table_$rqover external fixed bin (35);
 102 dcl  error_table_$segknown external fixed bin (35);
 103 
 104 dcl  archive_key_$last_index external fixed bin (17);
 105 
 106 declare 1 archive_key_$begin_table (100 /* archive_key_$last_index */) aligned ext,
 107         2 key char (4),                                     /* key to be matched */
 108         2 bits unaligned,                                   /* required for Version II */
 109           3 action bit (2),                                 /* = 0 table
 110                                                                = 1 replace
 111                                                                = 2 extract
 112                                                                = 3 delete */
 113           3 update bit (1),                                 /* = 1 if update feature */
 114           3 append bit (1),                                 /* = 1 if append feature */
 115           3 copy bit (1),                                   /* = 1 if copy feature */
 116           3 delete bit (1),                                 /* = 1 if should delete */
 117           3 force bit (1),                                  /* = 1 for delete force */
 118           3 long bit (1),                                   /* = 1 for long output */
 119           3 zero_arg_ok bit (1),                            /* = 1 if OK to have zero arguments */
 120           3 star_ok bit (1),                                /* = 1 if star convention may be used */
 121           3 empty_ok bit (1),                               /* = 1 if OK to start with an empty archive */
 122           3 no_orig_ok bit (1),                             /* = 1 if OK to not find original */
 123           3 brief_bit bit (1);                              /* Suppress header printing in "t" keys */
 124 
 125 declare 1 key_template aligned based (keyp),
 126         2 key char (4),                                     /* key to be matched */
 127         2 bits unaligned,                                   /* required for Version II */
 128           3 action bit (2),                                 /* = 0 table
 129                                                                = 1 replace
 130                                                                = 2 extract
 131                                                                = 3 delete */
 132           3 update bit (1),                                 /* = 1 if update feature */
 133           3 append bit (1),                                 /* = 1 if append feature */
 134           3 copy bit (1),                                   /* = 1 if copy feature */
 135           3 delete bit (1),                                 /* = 1 if should delete */
 136           3 force bit (1),                                  /* = 1 for delete force */
 137           3 long bit (1),                                   /* = 1 for long output */
 138           3 zero_arg_ok bit (1),                            /* = 1 if OK to have zero arguments */
 139           3 star_ok bit (1),                                /* = 1 if star convention may be used */
 140           3 empty_ok bit (1),                               /* = 1 if OK to start with an empty archive */
 141           3 no_orig_ok bit (1),                             /* = 1 if OK to not find original */
 142           3 brief_bit bit (1);                              /* Suppress header printing in "t" keys */
 143 
 144 dcl  key_index fixed bin (17),                              /* hold index to table of keys here */
 145      keyp ptr;                                              /* Pointer to current entry in key list */
 146 
 147 dcl (mcode, code, savecode, max_length) fixed bin (35);
 148 dcl (i, j, k) fixed bin (17);
 149 dcl  wdct fixed bin (19);
 150 dcl  lastarg fixed bin (17);
 151 dcl  curlen fixed bin (17);
 152 dcl  bcnt fixed bin (24),
 153      gbct fixed bin (24) initial (0);
 154 dcl  noroomsw bit (1) initial ("1"b);                       /* set to ""b when message printed */
 155 dcl  header_printed bit (1) initial (""b);                  /* set to "1"b when table header printed */
 156 dcl  first_line_sw bit (1) init ("1"b);                     /* to prefix "appended to" and "updated in" msgs */
 157                                                             /* with "archive:" first time only */
 158 
 159 /* one record may be enough to hold component names. If not, we open a seg */
 160 
 161 dcl stack_space (1024) fixed bin (35) init ((1024) 0);
 162 
 163 dcl (sp, new_sp) pointer aligned;
 164 dcl (dcount, lcount) fixed bin (17) aligned;
 165 
 166 dcl (NONGLOBAL_ELEMENT_SIZE init (53), GLOBAL_ELEMENT_SIZE init (10))
 167           fixed bin int static options (constant);
 168 
 169 dcl 1 nonglobal (2500) aligned based (sp),
 170    2 component_name char (32) aligned,            /* if this structure changes, change NONGLOBAL_ELEMENT_SIZE */
 171    2 component_path char (168) aligned,
 172    2 component_code fixed bin (35) aligned,
 173    2 flags fixed bin (3) aligned,
 174    2 ngtype bit (2) unaligned;
 175 
 176 dcl 1 global (2500) aligned based (sp),
 177    2 gcomponent_name char (32) aligned,           /* if this structure changes, change GLOBAL_ELEMENT_SIZE */
 178    2 gflags fixed bin (3) aligned,
 179    2 gtype bit (2) unaligned;
 180 
 181 /* flags = 0: not found in archive
 182    1: action completed
 183    2: not found in archive or filesys
 184    3: found in archive but not in filesys
 185    4: appended to archive
 186    5: found in archive during append request
 187    6: archive overflow during processing
 188    7: no message, but no delete either */
 189 
 190 dcl (dn, initpath, archive_dir, new_archive_dir) char (168) aligned,
 191      time char (16) aligned,
 192      timenow char (16) aligned,                             /* store current time here */
 193      patharg char (pathlen) based (pathptr),
 194      pathlen fixed bin (17),
 195      pathptr ptr,
 196      keyb char (key_l) based (key_p),
 197      key_l fixed bin (17),
 198      key_p ptr;
 199 dcl  arglist_ptr ptr;
 200 
 201 dcl  archive_name char (32) aligned initial (""),
 202      temp_name char (32) aligned static init ("archive_temp_.archive"),
 203      act_com char (8) aligned,                              /* update, replace, or append */
 204      key char (4) aligned;
 205 
 206 dcl  buffer char (150) varying;
 207 dcl (optr, cptr, p1_orig) ptr init (null);
 208 dcl  tptr ptr static init (null);
 209 dcl (p1, p2) ptr init (null);
 210 
 211 dcl  iflag fixed bin (3);                                   /* temporary copy */
 212 
 213 dcl  amsw fixed bin (17) init (0);                          /* = 1 if a modified copy is to replace the archive */
 214 
 215 dcl  cleanup_temp bit (1) internal static init (""b);       /* =1 if must truncate temp */
 216 
 217 declare 1 aux_wstructure aligned,                           /* structure for archive_aux_ */
 218         2 mustfree bit (1) init (""b),                      /* set to "1"b by archive_aux_$listwdir */
 219         2 ecount fixed bin,                                 /* # of entries in dir */
 220         2 my_wdir char (168),                               /* Needed for link chasing in $inwdir call */
 221         2 eptr ptr init (null),                             /* for archive_aux_ */
 222         2 nptr ptr init (null);                             /* " */
 223 
 224 dcl  auxw_ptr ptr;
 225 
 226 dcl 1 query_info aligned,                                   /* structure for command query */
 227     2 version fixed bin init (1),
 228     2 yes_or_no_sw bit (1) unal init ("1"b),                /* require yes or no answer */
 229     2 supress_name_sw bit (1) unal init ("0"b),             /* print name with question */
 230     2 extra bit (34) unal,
 231     2 status_code fixed bin (35),                           /* set to code of prompting question */
 232     2 query_code fixed bin (35);
 233 
 234 dcl 1 seg_acl aligned,                                      /* structure for adding one acl */
 235     2 userid char (32),
 236     2 access bit (36),
 237     2 ex_access bit (36),
 238     2 status fixed bin (35);
 239 
 240 dcl 1 delete_acl aligned,                                   /* structure for deleting one acl */
 241     2 userid char (32),
 242     2 status fixed bin (35);
 243 
 244 dcl  mustreprotect bit (1) init (""b);                      /* set to true if archive is protected */
 245 dcl  entry_type bit (2);                                    /* set to entry_type of entry */
 246 dcl  typef fixed bin (2);
 247 dcl  stars_found bit (1) init (""b);                        /* set to "1" on star_entry */
 248 dcl  found_something_sw bit (1) init (""b);                 /* for update: ON when matching seg found in dir */
 249 dcl  updated_something_sw bit (1) init (""b);               /* for update: ON when a component is actually replaced */
 250 
 251 dcl 1 mask based aligned,
 252     2 keep bit (36 - maskl) unaligned,
 253     2 kill bit (maskl) unaligned;
 254 dcl  maskl fixed bin;
 255 dcl  array (wdct) fixed bin (35) based,
 256      fix17 fixed bin (35),
 257      fix35 fixed bin (35) based,
 258 
 259      1 stat,                                                /* structure for status_ call */
 260      2 type bit (2) unaligned,
 261      2 pad bit (34) unaligned,
 262      2 dtm bit (36),
 263      2 pad1 (5) bit (36),
 264      2 len,
 265      3 cur bit (12) unaligned,
 266      3 bitcnt bit (24) unaligned,
 267      2 pad2 (2) bit (36),
 268 
 269      dtm bit (36) aligned,
 270 
 271     (copy, delete, force, long) bit (1) init (""b),
 272      update bit (1) init (""b),                             /* = "1"b if update feature requested */
 273      append bit (1) init (""b),                             /* = "1"b if append feature requested */
 274      dlast fixed bin (17) init (0),
 275      last fixed bin (17) init (0),
 276      dontcopy fixed bin (17) init (0),
 277 
 278      char8 picture "zzzzzzz9",
 279      char32 char (32) aligned;
 280 
 281 dcl (header_length init (25),                               /* # of words in header */
 282      header_length_bits init (900)) fixed bin static;       /* .. bits */
 283 
 284 dcl 1 archive based (p1) aligned,
 285     2 hbgn char (8),
 286     2 pad1 char (4),
 287     2 name char (32),
 288     2 timeup char (16),
 289     2 mode char (4),
 290     2 time char (16),
 291     2 pad char (4),
 292     2 bcnt char (8),
 293     2 hend char (8),
 294     2 begin fixed bin;
 295 
 296 dcl 1 modeb aligned based (addr (mode)),
 297     2 pad bit (32) unaligned,
 298     2 r bit (1) unaligned,
 299     2 e bit (1) unaligned,
 300     2 w bit (1) unaligned,
 301     2 obsolete bit (1) unaligned,
 302      mode fixed bin (5);
 303 dcl  amode fixed bin (5);                                   /* keep mode of archive segment here */
 304 
 305 dcl 1 contents_overlay aligned based,
 306    2 offset_space (offset_words) fixed bin,
 307    2 contents (new_words - offset_words) fixed bin;
 308 
 309 dcl orig_bc fixed bin (24);
 310 dcl (new_words, offset_words, orig_words) fixed bin (21);
 311 
 312 dcl  iox_$error_output ptr external;
 313 
 314 dcl  check_star_name_$entry entry (char (*)aligned, fixed bin (35)),
 315      clock_ returns (fixed bin (71)),
 316      cu_$arg_ptr entry (fixed bin (17), ptr, fixed bin (17), fixed bin (35)),
 317      cu_$arg_list_ptr returns (ptr),
 318      cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr),
 319      cu_$arg_count returns (fixed bin (17)),
 320      expand_pathname_$add_suffix entry (char (*), char (*), char (*) aligned, char (*) aligned, fixed bin (35)),
 321      expand_pathname_ entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)),
 322      get_group_id_ entry returns (char (32) aligned),
 323      get_group_id_$tag_star entry returns (char (32) aligned),
 324      get_pdir_ returns (char (168) aligned),
 325      get_wdir_ returns (char (168) aligned),
 326 
 327     (com_err_, command_query_, ioa_, ioa_$ioa_switch) entry options (variable),
 328 
 329      fs_util_$get_max_length entry (char (*) aligned, char (*) aligned, fixed bin (35), fixed bin (35)),
 330      hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin, fixed bin, ptr, fixed bin (35)),
 331      hcs_$terminate_noname entry (ptr, fixed bin (35)),
 332      hcs_$terminate_seg entry (ptr, fixed bin (1), fixed bin (35)),
 333      hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35)),
 334      hcs_$set_bc entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (35)),
 335      hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)),
 336      hcs_$add_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)),
 337      hcs_$delete_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)),
 338      hcs_$chname_seg entry (ptr, char (*) aligned, char (*) aligned, fixed bin (35)),
 339      hcs_$truncate_seg entry (ptr, fixed bin (21), fixed bin (35)),
 340      hcs_$star_list_ entry (char (*)aligned, char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)),
 341      hcs_$status_long entry (char (*) aligned, char (*) aligned, fixed bin, ptr, ptr, fixed bin (35)),
 342      hcs_$status_minf entry (char (*) aligned, char (*) aligned, fixed bin, fixed bin (2), fixed bin, fixed bin (35)),
 343      hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)),
 344      hcs_$delentry_file entry (char (*) aligned, char (*) aligned, fixed bin (35)),
 345      hcs_$delentry_seg entry (ptr, fixed bin (35)),
 346      initiate_file_ entry (char (*) aligned, char (*) aligned, bit (*), pointer, fixed bin (24), fixed bin (35)),
 347      pathname_ entry (char (*) aligned, char (*) aligned) returns (char (168)),
 348      term_ entry (char (*) aligned, char (*) aligned, fixed bin (35)),
 349 
 350      dl_handler_ entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)),
 351      dl_handler_$noquestion entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)),
 352      nd_handler_ entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)),
 353 
 354      archive_util_$first_element entry (ptr, fixed bin (35)),
 355      archive_util_$next_element entry (ptr, fixed bin (35)),
 356      archive_aux_$listwdir entry (ptr, fixed bin (35)),
 357      archive_aux_$inwdir entry (ptr, char (32) aligned, bit (36) aligned, bit (2)) returns (bit (1)),
 358      archive_aux_$free entry (ptr),
 359      archive_aux_$active entry (bit (1) aligned),
 360      archive_star_ entry (char (*) aligned, char (*) aligned, char (*) aligned, ptr, fixed bin),
 361 
 362      convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)),
 363      date_time_$fstime entry (fixed bin (35), char (*) aligned),
 364      date_time_ entry (fixed bin (71), char (*) aligned),
 365      cv_dec_ entry (char (*) aligned) returns (fixed bin (24));
 366 
 367 dcl (addr, addrel, bin, bit, divide, fixed, max, null, ptr, rel, size, substr) builtin;
 368 
 369 dcl (cleanup, record_quota_overflow) condition;
 370 
 371 dcl  action fixed bin (2);
 372 %page;
 373 /* This block of code gets the arguments and initializes various data items. */
 374 
 375 
 376           if archive_data_$active then call archive_aux_$active (archive_data_$active);
 377                                                             /* query about recursive use */
 378           if archive_data_$active then return;              /* active reset if wish to proceed */
 379 
 380           lastarg = cu_$arg_count ();
 381 
 382           arglist_ptr = cu_$arg_list_ptr ();                /* save argument list pointer */
 383           go to SKIPENTRY;
 384 
 385 /* This entry point is called by archive_star_ to implement star convention */
 386 
 387 star_entry: entry (dummy_key, dummy_name, dummy_arglist_ptr, dummy_lastarg);
 388 
 389 dcl  dummy_arglist_ptr ptr;
 390 dcl  dummy_lastarg fixed bin;
 391 dcl (dummy_key, dummy_name) char (*);
 392 
 393           arglist_ptr = dummy_arglist_ptr;
 394           lastarg = dummy_lastarg;
 395           stars_found = "1"b;                               /* mark that through this entry */
 396 
 397 SKIPENTRY:
 398 
 399           sp = addr (stack_space);
 400           auxw_ptr = addr (aux_wstructure);
 401           call cu_$arg_ptr (1, key_p, key_l, code);         /* get key */
 402           if code ^= 0 then go to NARG;
 403           if key_l <= 4 then key = keyb;
 404           else do;
 405 KEYERR:        call com_err_ ((0), moi, "Unrecognized key - ^a", keyb);
 406                goto RETURN;
 407           end;
 408           do key_index = archive_key_$last_index to 1 by -1 while (key ^= archive_key_$begin_table (key_index).key);end;
 409           if key_index = 0 then go to KEYERR;               /* couldn't find key */
 410 
 411           keyp = addr (archive_key_$begin_table (key_index));
 412 
 413           copy = key_template.copy;
 414           update = key_template.update;
 415           append = key_template.append;
 416           delete = key_template.delete;
 417           force = key_template.force;
 418           long = key_template.long;
 419           header_printed = key_template.brief_bit;          /* That wasn't hard at all! */
 420 
 421           action = bin (key_template.action, 17);
 422 
 423           if action = 1                                     /* If some form of replacement */
 424           then if update
 425                then act_com = "update  ";
 426                else if append
 427                then act_com = "append  ";
 428                else act_com = "replace ";
 429 
 430           call cu_$arg_ptr (2, pathptr, pathlen, code);     /* archive name */
 431           if code ^= 0 then do;
 432 NARG:          if append | delete then call com_err_ (0, moi, "Usage:  ^a key archive_path component_names", moi);
 433                else call com_err_ (0, moi, "Usage:  ^a key archive_path {component_names}", moi);
 434                goto RETURN;
 435           end;
 436 
 437           call expand_pathname_$add_suffix (patharg, "archive", archive_dir, archive_name, code);
 438           if code ^= 0 then do;
 439                call com_err_ (code, moi, patharg);
 440                goto RETURN;
 441           end;
 442 
 443           call check_star_name_$entry (archive_name, code);
 444           if code ^= 0 then do;
 445                if code = 1 | code = 2 then
 446                     if ^key_template.star_ok then
 447                          call com_err_ ((0), moi, "Star convention cannot be used with this key.  ^a", key);
 448 
 449                     else call archive_star_ (archive_dir, archive_name, key, arglist_ptr, lastarg);
 450 
 451                else call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name));
 452 
 453                go to RETURN;
 454           end;
 455 %page;
 456           my_wdir = get_wdir_ ();
 457           on condition (cleanup) call clean_up;
 458 
 459           call initiate_file_ (archive_dir, archive_name, R_ACCESS, p1, orig_bc, code);
 460           p1_orig = p1;                                     /* save pointer to archive */
 461           if p1 ^= null then do;
 462                call hcs_$fs_get_mode (p1, amode, code);
 463                if code = 0 then if ^addr (amode) -> modeb.r then code = error_table_$moderr;
 464                if code ^= 0 then do;                        /* print message and return */
 465 ERROR_RETURN:
 466                     call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name));
 467                     goto RETURN;
 468                end;
 469 
 470                call fs_util_$get_max_length (archive_dir, archive_name, max_length, code);
 471                if code ^= 0 then go to ERROR_RETURN;
 472 
 473                call archive_util_$first_element (p1, savecode);
 474                if savecode = 2 then do;
 475 FERROR:             call com_err_ (0, moi, "Format error in ^a", pathname_ (archive_dir, archive_name));
 476                     if p2 ^= null then if copy then call hcs_$delentry_seg (p2, code);
 477                     go to COMRETN;
 478                end;
 479           end;
 480 
 481           if ^key_template.no_orig_ok then if p1 = null then do;
 482 NOARCHIVE:          call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name));
 483                     goto COMRETN;
 484                end;
 485 
 486           if ^key_template.empty_ok then if savecode = 1 then do;
 487                     call com_err_ (0, moi, "^a is empty.", pathname_ (archive_dir, archive_name));
 488                     go to COMRETN;                          /* cleanup and return */
 489                end;
 490 
 491           if copy then do;                                  /* special checking for copy */
 492                if p1 = null then do;
 493                     call com_err_ (0, moi, "Attempt to use copy feature when original not found.  ^a",
 494                          pathname_ (archive_dir, archive_name));
 495                     go to COMRETN;
 496                end;
 497                if archive_dir = my_wdir then do;
 498                     call com_err_ (0, moi, "Attempt to copy onto original.  ^a",
 499                          pathname_ (archive_dir, archive_name));
 500                     goto COMRETN;
 501                end;
 502                new_archive_dir = my_wdir;                   /* force new archive to wdir */
 503           end;
 504 
 505           else new_archive_dir = archive_dir;               /* force new archive to replace old */
 506 
 507 %page;
 508           if lastarg < 3 then if action = 1 then do;
 509                     call hcs_$star_list_ (my_wdir, "**", 2, null, dcount, lcount, null, null, code);
 510                     if dcount+lcount > 113 then do;
 511                          call hcs_$make_seg ("", "", "", 01010b, sp, code);
 512                          if code ^= 0 then do;
 513                               call com_err_ (code, moi);
 514                          go to COMRETN; end;
 515                     end;
 516                end;
 517 
 518           if lastarg * NONGLOBAL_ELEMENT_SIZE > size (stack_space) then do;
 519                call hcs_$make_seg ("", "", "", 01010b, sp, code);
 520                if sp = null then do;
 521                     call com_err_ (code, moi);
 522                go to COMRETN; end;
 523                do i = 1 to lastarg-2;
 524                     component_code (i) = 0;
 525                     flags (i) = 0;
 526                     ngtype (i) = ""b;
 527                end;
 528           end;
 529 %page;
 530           do i = 3 to lastarg;                              /* get all component names */
 531                call cu_$arg_ptr_rel (i, pathptr, pathlen, code, arglist_ptr);
 532                if code ^= 0 then go to BADARG;
 533                if pathlen = 0 then go to NEXTARG;           /* this might be wrong */
 534 
 535                if action = 0 | action = 3 then do;          /* table or delete */
 536                     component_name (last+1) = patharg;      /* not a pathname */
 537                     goto CHECKARG;
 538                end;
 539 
 540                call expand_pathname_ (patharg, component_path (last + 1), component_name (last + 1), code);
 541                if code ^= 0 then do;
 542 BADARG:             call com_err_ (code, moi, patharg);
 543                     goto NEXTARG;
 544                end;
 545 CHECKARG:      do j = last to 1 by -1 while (component_name (j) ^= component_name (last+1));end;
 546                if j ^= 0 then do;
 547                     call com_err_ ((0), moi, "Duplicated request for this component. ^a", component_name (last+1));
 548                     goto NEXTARG;
 549                end;
 550                last = last + 1;
 551 NEXTARG:
 552           end;
 553 
 554           if ^key_template.zero_arg_ok then if last = 0 then do;
 555                     call com_err_ ((0), moi, "Some component names must be specified with this key - ^a", key);
 556                     go to COMRETN;
 557                end;
 558 
 559           if lastarg >= 3                                   /* From cu_$arg_count */
 560           then if last = 0                                  /* Null args, or expand_path_ errors */
 561                then go to COMRETN;                          /* Don't perform global operations */
 562           if action ^= 0 then archive_data_$active = "1"b;            /* protect against recursion */
 563 
 564           go to FANOUT (action);
 565 
 566 
 567 
 568 %page;
 569 FANOUT (0):
 570 TABLE_HANDLER:
 571 
 572           do while (p1 ^= null);                            /* loop through entire archive */
 573 
 574                if last ^= 0 then do;                        /* check for match with input argument */
 575                     do i = last to 1 by -1 while (component_name (i) ^= p1 -> archive.name);end;
 576                     if i = 0 then go to TNXT;
 577                     flags (i) = 1;
 578                end;
 579 
 580                if ^header_printed then do;
 581                     call ioa_ ("^/^-^a^/", pathname_ (archive_dir, archive_name));
 582                     if long then call ioa_ (" name^3-      updated      mode^-modified^-   length^/");
 583                     else call ioa_ ("  updated^2-   name^/");
 584                     header_printed = "1"b;
 585                end;
 586 
 587                if long then call ioa_ ("^32a^17a^5a^16a^a",
 588                     p1 -> archive.name,
 589                     p1 -> archive.timeup,
 590                     p1 -> archive.mode,
 591                     p1 -> archive.time,
 592                     p1 -> archive.bcnt);
 593                else call ioa_ ("^20a^a", p1 -> archive.timeup, p1 -> archive.name);
 594 
 595 TNXT:
 596                call archive_util_$next_element (p1, code);
 597                if code = 2 then go to FERROR;
 598           end;
 599           call ioa_ ("");
 600 
 601           go to NOT_FOUND_CHECKER;                          /* issue diagnostics and return */
 602 %page;
 603 FANOUT (1):
 604 REPLACE_HANDLER:
 605 
 606 
 607           if p1 = null then if last = 0 then do;
 608                     code = error_table_$noentry;
 609                     go to NOARCHIVE;                        /* no archive found */
 610                end;
 611 
 612           call date_time_ ((clock_ ()), timenow);           /* get time */
 613 
 614           if last = 0 then do;
 615                call archive_aux_$listwdir (auxw_ptr, code);
 616                if code ^= 0 then do;
 617                     call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name));
 618                     go to COMRETN;
 619                end;
 620           end;
 621 
 622           if savecode = 1 then p1 = null;                   /* archive was empty */
 623 
 624           do while (p1 ^= null);
 625                if last = 0 then do;                         /* full replace */
 626                     call rcmp;
 627                end;
 628                else do;
 629                     do i = last to 1 by -1 while (component_name (i) ^= p1 -> archive.name);end;
 630                     if i = 0 then do;
 631                          call ccmp;
 632                     end;
 633                     else do;
 634                          if append then do;
 635                               flags (i) = 5;
 636                               call ccmp;
 637                          end;
 638                          else do;
 639                               flags (i) = 1;
 640                               call rcmp;
 641                          end;
 642                     end;
 643                end;
 644                call archive_util_$next_element (p1, code);
 645                if code = 2 then go to FERROR;
 646           end;
 647 
 648           if update then goto MOVE_ARCHIVE;                 /* do no appending */
 649           do i = 1 to last;
 650                if flags (i) = 0 then do;
 651                     call rcmp;
 652                     if flags (i) = 0 then flags (i) = 4;    /* change to was appended code */
 653                end;
 654           end;
 655 %page;
 656 /* Move archive and perform deletions if necessary */
 657 
 658 MOVE_ARCHIVE:
 659           if dontcopy ^= 0 then do;
 660                call hcs_$set_bc (new_archive_dir, archive_name, gbct, code);
 661                if code ^= 0 then do;
 662                     call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name));
 663                     go to COMRETN;
 664                end;
 665                call hcs_$terminate_noname (p2, fix17);
 666                if code = 0 then if delete then go to DELT;
 667                     else go to NOT_FOUND_CHECKER;
 668           end;
 669 
 670           if amsw = 0 then go to NOT_FOUND_CHECKER;         /* did not modify original */
 671 
 672           if ^addr (amode) -> modeb.w then do;              /* if archive is protected by no w access */
 673                query_info.status_code = error_table_$moderr;
 674                call ask_question;                           /* find out if it's ok to change it */
 675                seg_acl.userid = get_group_id_ ();           /* wants to update */
 676                seg_acl.access = "101"b;                     /* give user rw */
 677                seg_acl.ex_access = "0"b;
 678                call hcs_$add_acl_entries (new_archive_dir, archive_name, addr (seg_acl), 1, mcode);
 679                if mcode ^= 0 then go to MOVE_ERROR;
 680                else mustreprotect = "1"b;
 681           end;
 682 
 683           orig_words = bc_to_rec (orig_bc) * 1024;
 684           new_words = bc_to_rec (gbct) * 1024;
 685 
 686           if new_words > orig_words then do;                /* remember they're rounded to a page */
 687                on record_quota_overflow begin;
 688                     mcode = error_table_$rqover;
 689                     call hcs_$truncate_seg (p1_orig, orig_words, 0);  /* back to original length */
 690                     go to MOVE_ERROR;
 691                end;
 692 
 693                offset_words = orig_words;                   /* copy just the part beyond orig, as a test of quota */
 694                p1_orig -> contents = ptr (p2, 0) -> contents;
 695                revert record_quota_overflow;
 696           end;
 697 
 698           offset_words = 0;                                 /* now copy whole thing */
 699           p1_orig -> contents = ptr (p2, 0) -> contents;
 700 
 701           if "0"b then do;                                  /* only hit this via goto's */
 702 MOVE_ERROR:    call com_err_ (mcode, moi, "Archive ^a not updated.", pathname_ (archive_dir, archive_name));
 703                call hcs_$set_bc_seg (tptr, gbct, code);
 704                call hcs_$chname_seg (tptr, temp_name, archive_name, code);
 705                if code = 0 then tptr = null;                /* force temp.archive to be remade */
 706                archive_dir = get_pdir_ ();
 707                if code ^= 0 then archive_name = "temp.archive";
 708                call ioa_ ("A copy of the updated archive can be found in [pd]>^a", archive_name);
 709                go to NOT_FOUND_CHECKER;
 710           end;
 711           call hcs_$set_bc (new_archive_dir, archive_name, gbct, savecode);
 712           if savecode ^= 0 then call com_err_ (savecode, moi, "^a", pathname_ (archive_dir, archive_name));
 713           else if p2 ^= null then call hcs_$truncate_seg (p2, 0, code); /* truncate copy */
 714 
 715           if new_words < orig_words then call hcs_$truncate_seg (p1_orig, new_words, 0);
 716           if mustreprotect then do;                         /* restore ACL to original state */
 717                delete_acl.userid = seg_acl.userid;          /* delete ACL */
 718                call hcs_$delete_acl_entries (new_archive_dir, archive_name, addr (delete_acl), 1, code);
 719                if code ^= 0 then do;
 720                     call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name));
 721                     goto COMRETN;
 722                end;
 723           end;
 724           cleanup_temp = ""b;                               /* temporary segment is clean */
 725           if ^delete | savecode ^= 0 then go to NOT_FOUND_CHECKER;
 726 
 727 DELT:     ;
 728           do i = 1 to max (last, dlast);                    /* either last or dlast will be zero, we want the other */
 729                if last ^= 0 then do;
 730                     if flags (i) = 1 | flags (i) = 4 then
 731                          call delete_seg (component_path (i), component_name (i), ngtype (i), code);
 732                end;
 733                else do;
 734                     if gflags (i) = 1 | gflags (i) = 4 then
 735                          call delete_seg (my_wdir, gcomponent_name (i), gtype (i), code);
 736                end;
 737           end;
 738           if last = 0 then go to COMRETN;
 739 
 740 NOT_FOUND_CHECKER:
 741           do i = 1 to last;
 742                iflag = flags (i);
 743                if iflag = 0 then
 744                     call com_err_ (0, moi, "^a not found in ^a",
 745                          component_name (i), pathname_ (archive_dir, archive_name));
 746                else if iflag = 2 then
 747                     call com_err_ (component_code (i), moi, "Could not append ^a to ^a",
 748                          pathname_ (component_path (i), component_name (i)), pathname_ (archive_dir, archive_name));
 749                else if iflag = 3 then
 750                     if update & component_code (i) = 0 then do;
 751                          if updated_something_sw then call com_err_ (0, moi,
 752                               "Did not update ^a because latest copy already in ^a",
 753                               component_name (i), pathname_ (archive_dir, archive_name));
 754                     end;
 755                     else do;
 756                          if found_something_sw | nonglobal (i).component_code ^= 0 then
 757                               call com_err_ (nonglobal (i).component_code, moi, "Could not replace ^a in ^a",
 758                                    pathname_ (nonglobal (i).component_path, nonglobal (i).component_name), pathname_ (archive_dir, archive_name));
 759                     end;
 760                else if iflag = 4 & p1_orig ^= null & ^append then do;
 761                     call ioa_ ("^[archive: ^;^9x^]^a appended to ^a", first_line_sw,
 762                          pathname_ (component_path (i), component_name (i)),
 763                          pathname_ (archive_dir, archive_name));
 764                     first_line_sw = "0"b;
 765                end;
 766                else if iflag = 5 then
 767                     call com_err_ (0, moi, "Did not append ^a because copy found in ^a",
 768                     component_name (i), pathname_ (archive_dir, archive_name));
 769                else if iflag = 6                            /* Temp, could use 2 if error code were available */
 770                then call com_err_ (0, moi, "Archive segment overflow. Could not ^a ^a in ^a",
 771                     act_com, pathname_ (component_path (i), component_name (i)), pathname_ (archive_dir, archive_name));
 772 /*        else if iflag = 7 then;       /* No message, but no delete either */
 773           end;
 774 
 775           if update then
 776                if ^found_something_sw then call com_err_ (0, moi,
 777                     "No matching segments^[ in ^a^;^s^]; no components were updated in archive ^a",
 778                     last = 0, archive_dir, pathname_ (archive_dir, archive_name));
 779                else if ^updated_something_sw then call com_err_ (0, moi,
 780                     "Archive ^a contains the latest versions; no components were updated^[ from ^a^].",
 781                     pathname_ (archive_dir, archive_name), last = 0, archive_dir);
 782 
 783 COMRETN:  ;                                                 /* return from command */
 784 
 785           call clean_up;
 786 RETURN:   return;
 787 
 788 
 789 /* cleanup handler used at command termination as well */
 790 
 791 clean_up: proc;
 792 
 793                if sp ^= addr (stack_space) then do; call hcs_$delentry_seg (sp, code);
 794                call hcs_$terminate_noname (sp, code); end;
 795                if aux_wstructure.mustfree then call archive_aux_$free (auxw_ptr);
 796                if p1_orig ^= null then call hcs_$terminate_noname (p1_orig, code);
 797                archive_data_$active = ""b;
 798 
 799           end clean_up;
 800 
 801 %page;
 802 FANOUT (2):
 803 XTRACT_HANDLER:
 804 
 805 XTRACT_LOOP:
 806           do i = last to 1 by -1 while (component_name (i) ^= p1 -> archive.name);end;
 807           if i ^= 0 then nonglobal (i).flags = 1;
 808           else if last ^= 0 then do;                        /* this is not one of the specified components */
 809                if delete then call ccmp;
 810                go to XTRACT_NXT;
 811           end;
 812           if last = 0 then initpath = my_wdir;
 813           else initpath = component_path (i);
 814 
 815           bcnt = cv_dec_ (p1 -> archive.bcnt);
 816           wdct = divide (bcnt+35, 36, 17, 0);
 817 
 818           if wdct > max_length then go to FERROR;
 819 
 820           if p1 -> archive.mode = "" then mode = 01010b;    /* compatibility */
 821           else do;                                          /* convert ascii rewa to mode */
 822                mode = 0;                                    /* initialize */
 823                if substr (p1 -> archive.mode, 1, 1) = "r" then mode = 01000b;
 824                if substr (p1 -> archive.mode, 2, 1) = "e" then mode = mode + 00100b;
 825                if substr (p1 -> archive.mode, 3, 1) = "w" then mode = mode + 00010b;
 826           end;
 827 
 828 MAKEIT:   ;
 829           call hcs_$make_seg (initpath, p1 -> archive.name, "", 01011b, cptr, code);
 830           if cptr = null then do;
 831                if code = error_table_$incorrect_access then
 832                     call com_err_ (error_table_$no_append, moi, "^a", initpath);
 833                else call com_err_ (code, moi, "^a", pathname_ (initpath, p1 -> archive.name));
 834 
 835                if nonglobal (i).flags = 1 then do;          /* found an existing archive component */
 836                     if delete then do;
 837                          nonglobal (i).flags = 7;           /* indicate that no delete */
 838                          call ccmp;                         /* copy this existing component in temp archive */
 839                     end;
 840                end;
 841 
 842                nonglobal (i).component_code = code;         /* save error code for printing an error message */
 843                goto XTRACT_NXT;
 844           end;
 845 
 846           if delete then do;
 847                amsw = 1;                                    /* we're modifying the archive */
 848                if i ^= 0 then nonglobal (i).flags = 1;
 849           end;
 850 
 851           if code ^= 0 then do;
 852                if ^force then call nd_handler_ (moi, initpath, p1 -> archive.name, code);
 853                else do;
 854                     call hcs_$status_minf (initpath, p1 -> archive.name, 0, typef, j, code);
 855                     call delete_seg (initpath, p1 -> archive.name, bit (typef, 2), code);
 856                end;
 857                if code = 0 then do;
 858                     call hcs_$make_seg (initpath, p1 -> archive.name, "", 01011b, cptr, code);
 859                     if code ^= 0 then do;
 860                          if code = error_table_$incorrect_access then code = error_table_$no_append;
 861                          call com_err_ (code, moi, "^a", initpath);
 862                          if cptr ^= null then call hcs_$terminate_noname (cptr, code);
 863 SKIP_COMPONENT:          if delete then call ccmp;          /* don't delete the component */
 864                          go to XTRACT_NXT;
 865                     end;
 866                end;
 867                else go to SKIP_COMPONENT;
 868           end;
 869 
 870           cptr -> array = addr (p1 -> archive.begin) -> array;
 871           call hcs_$set_bc (initpath, p1 -> archive.name, bcnt, code);
 872           if mode ^= 01010b then do;
 873                seg_acl.userid = get_group_id_$tag_star ();
 874                seg_acl.access = bit (bin (mode, 4), 4);     /* convert old style access modes to new style */
 875                seg_acl.ex_access = "0"b;
 876                call hcs_$add_acl_entries (initpath, p1 -> archive.name, addr (seg_acl), 1, code);
 877           end;
 878           call hcs_$terminate_seg (cptr, 0, code);
 879 
 880 XTRACT_NXT:
 881           call archive_util_$next_element (p1, code);
 882           if code = 2 then go to FERROR;
 883           if p1 ^= null then go to XTRACT_LOOP;
 884 
 885           if delete then do;
 886                delete = "0"b;                               /* don't want MOVE_ARCHIVE to delete the segs we made */
 887                go to CHECK_DELETED;
 888           end;
 889           else go to NOT_FOUND_CHECKER;
 890 %page;
 891 FANOUT (3):
 892 DELETE_HANDLER:
 893 
 894           do while (p1 ^= null);
 895                do i = last to 1 by -1 while (component_name (i) ^= p1 -> archive.name);end;
 896                if i = 0 then do; call ccmp; end;
 897                else do;amsw = 1; flags (i) = 1;end;
 898 
 899                call archive_util_$next_element (p1, code);
 900                if code = 2 then go to FERROR;
 901           end;
 902 
 903 CHECK_DELETED:
 904           if p2 = null then do;                             /* get segment made */
 905                call makenew;
 906                do i = 1 to last while (nonglobal (i).component_code = 0); end;
 907                if i > last then
 908                call ioa_ ("archive: All components of ^a have been deleted.",
 909                     pathname_ (archive_dir, archive_name));
 910           end;
 911           go to MOVE_ARCHIVE;
 912 
 913 %page;
 914 /* Internal procedure to replace an archive component */
 915 
 916 rcmp:     proc;
 917                if last ^= 0 then do;
 918                     nonglobal (i).component_code = 0;
 919                     char32 = nonglobal (i).component_name;
 920                     initpath = nonglobal (i).component_path;
 921                end;
 922                else do;                                               /* global case */
 923                     char32 = p1 -> archive.name;
 924                     initpath = my_wdir;
 925                     if ^archive_aux_$inwdir (auxw_ptr, p1 -> archive.name, dtm, entry_type) then goto MUSTCOPY;
 926                end;
 927 
 928                call initiate_file_ (initpath, char32, R_ACCESS, optr, bcnt, code);
 929                if code ^= 0 then do;
 930                     if last = 0 then call com_err_ (code, moi, "^a", pathname_ (initpath, char32));
 931                     else nonglobal (i).component_code = code;
 932                end;
 933 
 934                if optr = p1_orig then do;                   /* can't replace the archive in itself */
 935                     flags (i) = 3;
 936                     go to MUSTCOPY;
 937                end;
 938                if optr = null then
 939                     do;
 940 MUSTCOPY:
 941                     if last ^= 0 then
 942                          if append then flags (i) = 2;
 943                          else flags (i) = 3;
 944 MUSTCOPY2:
 945                     if p1 ^= null then do;                  /* copy the original component */
 946                          call ccmp;
 947                     end;
 948                     return;
 949                end;
 950 
 951                found_something_sw = "1"b;
 952 
 953                call hcs_$fs_get_mode (optr, mode, code);    /* get current mode */
 954                if code = 0 then if ^modeb.r then code = error_table_$moderr;
 955                if code ^= 0 then do;
 956 REPLERR:            if last = 0 then call com_err_ (code, moi, "^a", pathname_ (initpath, char32));
 957                     else component_code (i) = code;
 958                     call hcs_$terminate_noname (optr, code);
 959                     go to MUSTCOPY;
 960                end;
 961 
 962                call hcs_$status_long (initpath, char32, 0, addr (stat), null, code);
 963                if code ^= 0 & code ^= error_table_$no_s_permission then go to REPLERR;              /* print error code (or store it) */
 964                if last ^= 0 then ngtype (i) = stat.type;    /* save the entry type */
 965                if stat.type = "00"b then do;                /* chase link */
 966                     call hcs_$status_long (initpath, char32, 1, addr (stat), null, code);
 967                     if code ^= 0 & code ^= error_table_$no_s_permission then go to REPLERR;
 968                end;
 969                if last ^= 0 then dtm = stat.dtm;
 970                curlen = fixed (stat.cur, 12);
 971                if bc_to_rec (bcnt) < curlen then do;
 972                     call com_err_ (0, moi, "Bit count is inconsistent with current length for ^a^[>^]^a",
 973                          initpath, initpath ^= ">", char32);
 974                     if last = 0 then call ioa_$ioa_switch (iox_$error_output, "Component was not updated in ^a",
 975                          pathname_ (archive_dir, archive_name));
 976                     go to MUSTCOPY;
 977                end;
 978                call date_time_$fstime (addr (dtm) -> fix35, time);
 979                if update then do;
 980                     if p1 ^= null then
 981                          if convert_time (time) <= convert_time (p1 -> archive.time) then do;   /* check dtm's */
 982                               call hcs_$terminate_noname (optr, code);
 983                               go to MUSTCOPY;
 984                          end;
 985                     updated_something_sw = "1"b;
 986                end;
 987                if delete then                               /* save names for deletion */
 988                     if last = 0 then do;
 989                          dlast = dlast + 1;
 990                          if dlast * GLOBAL_ELEMENT_SIZE > size (stack_space) then do;  /* need more room */
 991                               call hcs_$make_seg ("", "", "", 01010b, new_sp, code);
 992                               if new_sp = null then do;
 993                                    call com_err_ (code, moi);
 994                                    go to COMRETN;
 995                               end;
 996                               do k = 1 to dlast - 1;        /* copy from stack_space to allocated seg */
 997                                    new_sp -> global (k) = sp -> global (k);
 998                               end;
 999                               sp = new_sp;
1000                          end;
1001                          gflags (dlast) = 1;
1002                          gtype (dlast) = entry_type;        /* save the entry type */
1003                          gcomponent_name (dlast) = char32;
1004                     end;
1005 
1006                if p2 = null then call makenew;              /* get segment made */
1007 
1008                wdct = divide (bcnt+35, 36, 17, 0);
1009 
1010                if (bin (rel (p2), 18, 0) + wdct + header_length) > max_length
1011                then do;
1012 
1013                     if last = 0                             /* Global update/replace? */
1014                     then do;
1015 
1016                          if copy then dn = new_archive_dir;
1017                          else dn = archive_dir;
1018                          call com_err_ (0, moi, "Archive segment overflow. Could not ^a ^a in ^a",
1019                               act_com, char32, pathname_ (dn, archive_name));
1020                          if dlast = 0 then dlast = 1;
1021                          gflags (dlast) = 7;                /* No message, but no delete */
1022                          go to MUSTCOPY2;
1023 
1024                     end;
1025 
1026                     iflag = flags (i);
1027                     flags (i) = 6;                          /* Temp until "seglarge" error code? */
1028                     if iflag = 0                            /* Appending? */
1029                     then go to RCMPRTN;
1030 
1031                     go to MUSTCOPY2;                        /* Don't update "flags" */
1032 
1033 
1034                end;
1035 
1036                amsw = 1;                                    /* mark for updating */
1037 
1038                p2 -> archive.pad, p2 -> archive.pad1 = "    ";
1039                p2 -> archive.hbgn = archive_data_$ident;
1040                p2 -> archive.hend = archive_data_$fence;
1041                p2 -> archive.name = char32;
1042 
1043                char8 = bcnt;
1044                p2 -> archive.bcnt = char8;
1045                p2 -> archive.timeup = timenow;
1046                p2 -> archive.time = time;
1047 
1048                p2 -> archive.mode = "";
1049                if modeb.r then substr (p2 -> archive.mode, 1, 1) = "r";
1050                if modeb.e then substr (p2 -> archive.mode, 2, 1) = "e";
1051                if modeb.w then substr (p2 -> archive.mode, 3, 1) = "w";
1052 
1053                p2 = addrel (p2, header_length);
1054                gbct = gbct + header_length_bits;
1055                p2 -> array = optr -> array;
1056                maskl = wdct*36 - bcnt;
1057                if maskl ^= 0 then addrel (p2, wdct-1) -> mask.kill = ""b;
1058                p2 = addrel (p2, wdct);
1059                gbct = gbct + wdct*36;
1060 
1061                if update & last = 0 then do;
1062                     if copy then dn = new_archive_dir;
1063                     else dn = archive_dir;
1064                     call ioa_ ("^[archive: ^;^9x^]^a updated in ^a", first_line_sw, char32,
1065                          pathname_ (dn, archive_name));
1066                     first_line_sw = "0"b;
1067                end;
1068 
1069 RCMPRTN:       call hcs_$terminate_noname (optr, code);
1070           end rcmp;
1071 %page;
1072 /* Internal procedure to copy the current archive component to the new archive */
1073 ccmp:     proc;
1074 
1075                if p2 = null then call makenew;              /* get temp seg */
1076 
1077                bcnt = cv_dec_ (p1 -> archive.bcnt) + header_length_bits; /* get bit count of current component */
1078                wdct = divide (bcnt+35, 36, 17, 0);          /* convert to word count */
1079 
1080                if wdct > max_length then go to FERROR;      /* max length of the current component is greater the actual */
1081 
1082                if (bin (rel (p2), 18, 0) + wdct) > max_length
1083                then do;
1084 
1085                     call com_err_ (0, moi, "Archive segment overflow while copying ^a in ^a
1086 Archive not updated.", p1 -> archive.name, pathname_ (archive_dir, archive_name));
1087 
1088                     go to COMRETN;                          /* Abort */
1089 
1090                end;
1091 
1092                p2 -> array = p1 -> array;                   /* copy header + data */
1093                gbct = gbct + wdct*36;                       /* update global bit count */
1094                p2 = addrel (p2, wdct);                      /* step current component pointer */
1095 
1096           end ccmp;
1097 %page;
1098 /* Internal procedure to create a new output archive segment */
1099 
1100 makenew:  proc;
1101 
1102 dcl  error fixed bin (35);
1103 
1104                if copy | p1_orig = null then do;
1105                     dontcopy = 1;
1106 CREATE:             call hcs_$make_seg (new_archive_dir, archive_name, "", 01011b, p2, error);
1107                     if error ^= 0 then do;
1108                          if error = error_table_$namedup | error = error_table_$segknown then do;
1109                               call nd_handler_ (moi, new_archive_dir, archive_name, error);
1110                               if error = 0 then go to CREATE;
1111                               call hcs_$terminate_noname (p2, code);
1112                               p2 = null;
1113                               go to COMRETN;
1114                          end;
1115                          call com_err_ (error, moi, "^a", pathname_ (new_archive_dir, archive_name));
1116                          go to COMRETN;                     /* non local go to */
1117                     end;
1118 
1119                     call fs_util_$get_max_length (new_archive_dir, archive_name, max_length, error);
1120                     if code ^= 0 then do;
1121                          call com_err_ (error, moi, "^a", pathname_ (new_archive_dir, archive_name));
1122                          go to COMRETN;                     /* non local go to */
1123                     end;
1124                     if orig_bc = 0 then orig_bc = max_length * 36;
1125 
1126                     if ^copy then do;
1127                          call ioa_ ("archive: Creating ^a", pathname_ (archive_dir, archive_name));
1128                          p1_orig = p2;                      /* let p1_orig points to the newly created output archive segment */
1129                     end;
1130                     else call ioa_ ("archive: Copying ^a", pathname_ (archive_dir, archive_name));
1131 
1132                     return;
1133                end;
1134 
1135 
1136                if tptr = null then do;                      /* make the temp */
1137                     call hcs_$make_seg ("", temp_name, "", 01011b, tptr, error);
1138                     if tptr = null then do;                 /* cant make it */
1139                          call com_err_ (error, moi, "[pd]>^a", temp_name);
1140                          go to COMRETN;                     /* non local go to */
1141                     end;
1142                end;
1143                else if cleanup_temp then call hcs_$truncate_seg (tptr, 0, error);
1144 
1145                p2 = tptr;
1146                cleanup_temp = "1"b;                         /* mark temp dirty */
1147 
1148           end makenew;
1149 
1150 %page;
1151 bc_to_rec: proc (P_bc) returns (fixed bin);
1152 
1153 dcl P_bc fixed bin (24);
1154 
1155           if P_bc = 0 then return (0);
1156           else return (divide (P_bc - 1, 36 * 1024, 17, 0) + 1);
1157 
1158 end bc_to_rec;
1159 
1160 
1161 
1162 delete_seg:         proc (path, entry, dtype, dcode);
1163 
1164 dcl (path, entry) char (*) aligned,
1165      dtype bit (2),
1166      dcode fixed bin (35);
1167 dcl  ccode fixed bin (35);
1168 
1169                call term_ (path, entry, dcode);
1170                if dtype = "00"b then do;
1171                     call hcs_$initiate (path, entry, "", 0, 1, cptr, dcode);
1172                     if cptr = null then return;
1173                     call hcs_$delentry_seg (cptr, dcode);
1174                end;
1175                else call hcs_$delentry_file (path, entry, dcode);
1176                if dcode = 0 then return;
1177 
1178                if ^force then call dl_handler_ (moi, path, entry, dcode);
1179                else call dl_handler_$noquestion (moi, path, entry, dcode);
1180 
1181                if dtype = "00"b then call hcs_$delentry_seg (cptr, ccode);
1182                else call hcs_$delentry_file (path, entry, ccode);
1183                if dcode = 0 then dcode = ccode;
1184 
1185                if dcode ^= 0 then call com_err_ (0, moi, "Could not delete ^a", pathname_ (path, entry));
1186 
1187           end delete_seg;
1188 
1189 
1190 
1191 convert_time: proc (P_str) returns (fixed bin (71));
1192 
1193 dcl P_str char (*) aligned;
1194 dcl fixed_time fixed bin (71);
1195 
1196           call convert_date_to_binary_ ((P_str), fixed_time, code);
1197           if code ^= 0 then return (0);
1198           else return (fixed_time);
1199 
1200 end convert_time;
1201 
1202 
1203 
1204 ask_question: proc;
1205 
1206 /* Procedure to ask the user whether to update a protected segment */
1207 
1208                call command_query_ (addr (query_info), buffer, moi,
1209                     "Do you want to update the protected segment ^a ?", pathname_ (new_archive_dir, archive_name));
1210 
1211                if substr (buffer, 1, 2) = "no" then goto COMRETN;
1212 
1213           end ask_question;
1214 
1215 %page;
1216 %include access_mode_values;
1217      end archive;