archive.pl1 01/12/88 1309.7rew 01/12/88 1245.0 402732 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-10-15,TLNguyen), approve(87-10-15,MCR7774), audit(87-12-16,GWMay), install(88-01-12,MR12.2-1012): - The archive replace operation will display an appropriate error message for invalid components specified in the command line. - Replace the expand_pathname_ with the expand_pathname_$add_suffix to always append the "archive" suffix to an archive segment if an user does not supply the "archive" suffix. 2) change(87-10-15,TLNguyen), approve(87-10-15,MCR7776), audit(87-12-16,GWMay), install(88-01-12,MR12.2-1012): - Make the archive xd operation produce correct error message when it extracts a single existing archive component into a nonexistent directory and delete this component in the archive if it extracts successfully. - Error also raised when more than one existing components to be extracted and place one of extracted components into a nonexistent directory (e.g. ac xd archive_seg >nonexistent_dir>seg_a seg_b). Currently, it deletes the component in the archive when it found the directory where the extracted component to be placed does not exist. This error found while testing the archive. 3) change(87-10-15,TLNguyen), approve(87-10-15,MCR7780), audit(87-12-16,GWMay), install(88-01-12,MR12.2-1012): - Make the archive append operation to avoid an out_of_bound fault. This error raised when an user sets the max length of the original archive less than its default max length and attempts to run the archive append operation. - So do the archive delete, replace, and update operations. These errors found while testing the archive. END HISTORY COMMENTS */ archive: ac: proc; /* archive command : operates as described in the MPM coded 8/1/69 J.W. Gintell conv to pl1 2/1/70 */ /* the following names have been shortened: gbct global_bit_count wdct word_count rcmp replace_component ccmp copy_component amsw arc_mod_sw hbgn header_begin hend header_end bcnt bit_count optr orig_ptr cptr copy_ptr tptr tempptr */ /* last modified on 12-4-73 by Kobziar not to check for append mode */ /* changed to use external flag archive_data_$active 08/29/79 S. Herbst */ /* Error messages fixed for "ac cud" 09/24/79 S. Herbst */ /* A few bugs fixed 04/09/80 S. Herbst */ /* Improve error messages 01/12/81 S. Herbst */ /* Added "xd" key to extract and delete archive component 07/01/82 S. Herbst */ /* Changed archive move to restore original on rqo 07/02/82 S. Herbst */ /* Fixed to truncate after it shortens the archive 10/29/82 S. Herbst */ /* Changed some error messages to give full component pathname 11/24/82 S. Herbst */ /* Changed to prefix "appended to" and "updated in" msgs with command name 1st time only 11/21/83 S. Herbst */ /* Changed update to print message if no components matched segs or none updated 12/12/83 S. Herbst */ /* Fixed bug: overflow of global array if deleting many components and no comp args specified 12/12/83 S. Herbst */ /* Fixed to ignore error_table_$no_s_permission from hcs_$status_long 04/18/85 Steve Herbst */ /* Fixed to report error_table_$entlong with .archive appended 04/18/85 Steve Herbst */ dcl moi char (8) aligned init ("archive"); dcl archive_data_$active bit (1) aligned external; /* ON if archive or archive_table af is active */ dcl (archive_data_$ident, archive_data_$fence) ext char (8) aligned; dcl error_table_$incorrect_access external fixed bin (35); dcl error_table_$namedup external fixed bin (35); dcl error_table_$no_append external fixed bin (35); dcl error_table_$no_s_permission external fixed bin (35); dcl error_table_$noentry external fixed bin (35); dcl error_table_$moderr external fixed bin (35); dcl error_table_$rqover external fixed bin (35); dcl error_table_$segknown external fixed bin (35); dcl archive_key_$last_index external fixed bin (17); declare 1 archive_key_$begin_table (100 /* archive_key_$last_index */) aligned ext, 2 key char (4), /* key to be matched */ 2 bits unaligned, /* required for Version II */ 3 action bit (2), /* = 0 table = 1 replace = 2 extract = 3 delete */ 3 update bit (1), /* = 1 if update feature */ 3 append bit (1), /* = 1 if append feature */ 3 copy bit (1), /* = 1 if copy feature */ 3 delete bit (1), /* = 1 if should delete */ 3 force bit (1), /* = 1 for delete force */ 3 long bit (1), /* = 1 for long output */ 3 zero_arg_ok bit (1), /* = 1 if OK to have zero arguments */ 3 star_ok bit (1), /* = 1 if star convention may be used */ 3 empty_ok bit (1), /* = 1 if OK to start with an empty archive */ 3 no_orig_ok bit (1), /* = 1 if OK to not find original */ 3 brief_bit bit (1); /* Suppress header printing in "t" keys */ declare 1 key_template aligned based (keyp), 2 key char (4), /* key to be matched */ 2 bits unaligned, /* required for Version II */ 3 action bit (2), /* = 0 table = 1 replace = 2 extract = 3 delete */ 3 update bit (1), /* = 1 if update feature */ 3 append bit (1), /* = 1 if append feature */ 3 copy bit (1), /* = 1 if copy feature */ 3 delete bit (1), /* = 1 if should delete */ 3 force bit (1), /* = 1 for delete force */ 3 long bit (1), /* = 1 for long output */ 3 zero_arg_ok bit (1), /* = 1 if OK to have zero arguments */ 3 star_ok bit (1), /* = 1 if star convention may be used */ 3 empty_ok bit (1), /* = 1 if OK to start with an empty archive */ 3 no_orig_ok bit (1), /* = 1 if OK to not find original */ 3 brief_bit bit (1); /* Suppress header printing in "t" keys */ dcl key_index fixed bin (17), /* hold index to table of keys here */ keyp ptr; /* Pointer to current entry in key list */ dcl (mcode, code, savecode, max_length) fixed bin (35); dcl (i, j, k) fixed bin (17); dcl wdct fixed bin (19); dcl lastarg fixed bin (17); dcl curlen fixed bin (17); dcl bcnt fixed bin (24), gbct fixed bin (24) initial (0); dcl noroomsw bit (1) initial ("1"b); /* set to ""b when message printed */ dcl header_printed bit (1) initial (""b); /* set to "1"b when table header printed */ dcl first_line_sw bit (1) init ("1"b); /* to prefix "appended to" and "updated in" msgs */ /* with "archive:" first time only */ /* one record may be enough to hold component names. If not, we open a seg */ dcl stack_space (1024) fixed bin (35) init ((1024) 0); dcl (sp, new_sp) pointer aligned; dcl (dcount, lcount) fixed bin (17) aligned; dcl (NONGLOBAL_ELEMENT_SIZE init (53), GLOBAL_ELEMENT_SIZE init (10)) fixed bin int static options (constant); dcl 1 nonglobal (2500) aligned based (sp), 2 component_name char (32) aligned, /* if this structure changes, change NONGLOBAL_ELEMENT_SIZE */ 2 component_path char (168) aligned, 2 component_code fixed bin (35) aligned, 2 flags fixed bin (3) aligned, 2 ngtype bit (2) unaligned; dcl 1 global (2500) aligned based (sp), 2 gcomponent_name char (32) aligned, /* if this structure changes, change GLOBAL_ELEMENT_SIZE */ 2 gflags fixed bin (3) aligned, 2 gtype bit (2) unaligned; /* flags = 0: not found in archive 1: action completed 2: not found in archive or filesys 3: found in archive but not in filesys 4: appended to archive 5: found in archive during append request 6: archive overflow during processing 7: no message, but no delete either */ dcl (dn, initpath, archive_dir, new_archive_dir) char (168) aligned, time char (16) aligned, timenow char (16) aligned, /* store current time here */ patharg char (pathlen) based (pathptr), pathlen fixed bin (17), pathptr ptr, keyb char (key_l) based (key_p), key_l fixed bin (17), key_p ptr; dcl arglist_ptr ptr; dcl archive_name char (32) aligned initial (""), temp_name char (32) aligned static init ("archive_temp_.archive"), act_com char (8) aligned, /* update, replace, or append */ key char (4) aligned; dcl buffer char (150) varying; dcl (optr, cptr, p1_orig) ptr init (null); dcl tptr ptr static init (null); dcl (p1, p2) ptr init (null); dcl iflag fixed bin (3); /* temporary copy */ dcl amsw fixed bin (17) init (0); /* = 1 if a modified copy is to replace the archive */ dcl cleanup_temp bit (1) internal static init (""b); /* =1 if must truncate temp */ declare 1 aux_wstructure aligned, /* structure for archive_aux_ */ 2 mustfree bit (1) init (""b), /* set to "1"b by archive_aux_$listwdir */ 2 ecount fixed bin, /* # of entries in dir */ 2 my_wdir char (168), /* Needed for link chasing in $inwdir call */ 2 eptr ptr init (null), /* for archive_aux_ */ 2 nptr ptr init (null); /* " */ dcl auxw_ptr ptr; dcl 1 query_info aligned, /* structure for command query */ 2 version fixed bin init (1), 2 yes_or_no_sw bit (1) unal init ("1"b), /* require yes or no answer */ 2 supress_name_sw bit (1) unal init ("0"b), /* print name with question */ 2 extra bit (34) unal, 2 status_code fixed bin (35), /* set to code of prompting question */ 2 query_code fixed bin (35); dcl 1 seg_acl aligned, /* structure for adding one acl */ 2 userid char (32), 2 access bit (36), 2 ex_access bit (36), 2 status fixed bin (35); dcl 1 delete_acl aligned, /* structure for deleting one acl */ 2 userid char (32), 2 status fixed bin (35); dcl mustreprotect bit (1) init (""b); /* set to true if archive is protected */ dcl entry_type bit (2); /* set to entry_type of entry */ dcl typef fixed bin (2); dcl stars_found bit (1) init (""b); /* set to "1" on star_entry */ dcl found_something_sw bit (1) init (""b); /* for update: ON when matching seg found in dir */ dcl updated_something_sw bit (1) init (""b); /* for update: ON when a component is actually replaced */ dcl 1 mask based aligned, 2 keep bit (36 - maskl) unaligned, 2 kill bit (maskl) unaligned; dcl maskl fixed bin; dcl array (wdct) fixed bin (35) based, fix17 fixed bin (35), fix35 fixed bin (35) based, 1 stat, /* structure for status_ call */ 2 type bit (2) unaligned, 2 pad bit (34) unaligned, 2 dtm bit (36), 2 pad1 (5) bit (36), 2 len, 3 cur bit (12) unaligned, 3 bitcnt bit (24) unaligned, 2 pad2 (2) bit (36), dtm bit (36) aligned, (copy, delete, force, long) bit (1) init (""b), update bit (1) init (""b), /* = "1"b if update feature requested */ append bit (1) init (""b), /* = "1"b if append feature requested */ dlast fixed bin (17) init (0), last fixed bin (17) init (0), dontcopy fixed bin (17) init (0), char8 picture "zzzzzzz9", char32 char (32) aligned; dcl (header_length init (25), /* # of words in header */ header_length_bits init (900)) fixed bin static; /* .. bits */ dcl 1 archive based (p1) aligned, 2 hbgn char (8), 2 pad1 char (4), 2 name char (32), 2 timeup char (16), 2 mode char (4), 2 time char (16), 2 pad char (4), 2 bcnt char (8), 2 hend char (8), 2 begin fixed bin; dcl 1 modeb aligned based (addr (mode)), 2 pad bit (32) unaligned, 2 r bit (1) unaligned, 2 e bit (1) unaligned, 2 w bit (1) unaligned, 2 obsolete bit (1) unaligned, mode fixed bin (5); dcl amode fixed bin (5); /* keep mode of archive segment here */ dcl 1 contents_overlay aligned based, 2 offset_space (offset_words) fixed bin, 2 contents (new_words - offset_words) fixed bin; dcl orig_bc fixed bin (24); dcl (new_words, offset_words, orig_words) fixed bin (21); dcl iox_$error_output ptr external; dcl check_star_name_$entry entry (char (*)aligned, fixed bin (35)), clock_ returns (fixed bin (71)), cu_$arg_ptr entry (fixed bin (17), ptr, fixed bin (17), fixed bin (35)), cu_$arg_list_ptr returns (ptr), cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr), cu_$arg_count returns (fixed bin (17)), expand_pathname_$add_suffix entry (char (*), char (*), char (*) aligned, char (*) aligned, fixed bin (35)), expand_pathname_ entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)), get_group_id_ entry returns (char (32) aligned), get_group_id_$tag_star entry returns (char (32) aligned), get_pdir_ returns (char (168) aligned), get_wdir_ returns (char (168) aligned), (com_err_, command_query_, ioa_, ioa_$ioa_switch) entry options (variable), fs_util_$get_max_length entry (char (*) aligned, char (*) aligned, fixed bin (35), fixed bin (35)), hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin, fixed bin, ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$terminate_seg entry (ptr, fixed bin (1), fixed bin (35)), hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35)), hcs_$set_bc entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (35)), hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)), hcs_$add_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)), hcs_$delete_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)), hcs_$chname_seg entry (ptr, char (*) aligned, char (*) aligned, fixed bin (35)), hcs_$truncate_seg entry (ptr, fixed bin (21), fixed bin (35)), hcs_$star_list_ entry (char (*)aligned, char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)), hcs_$status_long entry (char (*) aligned, char (*) aligned, fixed bin, ptr, ptr, fixed bin (35)), hcs_$status_minf entry (char (*) aligned, char (*) aligned, fixed bin, fixed bin (2), fixed bin, fixed bin (35)), hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)), hcs_$delentry_file entry (char (*) aligned, char (*) aligned, fixed bin (35)), hcs_$delentry_seg entry (ptr, fixed bin (35)), initiate_file_ entry (char (*) aligned, char (*) aligned, bit (*), pointer, fixed bin (24), fixed bin (35)), pathname_ entry (char (*) aligned, char (*) aligned) returns (char (168)), term_ entry (char (*) aligned, char (*) aligned, fixed bin (35)), dl_handler_ entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)), dl_handler_$noquestion entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)), nd_handler_ entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)), archive_util_$first_element entry (ptr, fixed bin (35)), archive_util_$next_element entry (ptr, fixed bin (35)), archive_aux_$listwdir entry (ptr, fixed bin (35)), archive_aux_$inwdir entry (ptr, char (32) aligned, bit (36) aligned, bit (2)) returns (bit (1)), archive_aux_$free entry (ptr), archive_aux_$active entry (bit (1) aligned), archive_star_ entry (char (*) aligned, char (*) aligned, char (*) aligned, ptr, fixed bin), convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)), date_time_$fstime entry (fixed bin (35), char (*) aligned), date_time_ entry (fixed bin (71), char (*) aligned), cv_dec_ entry (char (*) aligned) returns (fixed bin (24)); dcl (addr, addrel, bin, bit, divide, fixed, max, null, ptr, rel, size, substr) builtin; dcl (cleanup, record_quota_overflow) condition; dcl action fixed bin (2); %page; /* This block of code gets the arguments and initializes various data items. */ if archive_data_$active then call archive_aux_$active (archive_data_$active); /* query about recursive use */ if archive_data_$active then return; /* active reset if wish to proceed */ lastarg = cu_$arg_count (); arglist_ptr = cu_$arg_list_ptr (); /* save argument list pointer */ go to SKIPENTRY; /* This entry point is called by archive_star_ to implement star convention */ star_entry: entry (dummy_key, dummy_name, dummy_arglist_ptr, dummy_lastarg); dcl dummy_arglist_ptr ptr; dcl dummy_lastarg fixed bin; dcl (dummy_key, dummy_name) char (*); arglist_ptr = dummy_arglist_ptr; lastarg = dummy_lastarg; stars_found = "1"b; /* mark that through this entry */ SKIPENTRY: sp = addr (stack_space); auxw_ptr = addr (aux_wstructure); call cu_$arg_ptr (1, key_p, key_l, code); /* get key */ if code ^= 0 then go to NARG; if key_l <= 4 then key = keyb; else do; KEYERR: call com_err_ ((0), moi, "Unrecognized key - ^a", keyb); goto RETURN; end; do key_index = archive_key_$last_index to 1 by -1 while (key ^= archive_key_$begin_table (key_index).key);end; if key_index = 0 then go to KEYERR; /* couldn't find key */ keyp = addr (archive_key_$begin_table (key_index)); copy = key_template.copy; update = key_template.update; append = key_template.append; delete = key_template.delete; force = key_template.force; long = key_template.long; header_printed = key_template.brief_bit; /* That wasn't hard at all! */ action = bin (key_template.action, 17); if action = 1 /* If some form of replacement */ then if update then act_com = "update "; else if append then act_com = "append "; else act_com = "replace "; call cu_$arg_ptr (2, pathptr, pathlen, code); /* archive name */ if code ^= 0 then do; NARG: if append | delete then call com_err_ (0, moi, "Usage: ^a key archive_path component_names", moi); else call com_err_ (0, moi, "Usage: ^a key archive_path {component_names}", moi); goto RETURN; end; call expand_pathname_$add_suffix (patharg, "archive", archive_dir, archive_name, code); if code ^= 0 then do; call com_err_ (code, moi, patharg); goto RETURN; end; call check_star_name_$entry (archive_name, code); if code ^= 0 then do; if code = 1 | code = 2 then if ^key_template.star_ok then call com_err_ ((0), moi, "Star convention cannot be used with this key. ^a", key); else call archive_star_ (archive_dir, archive_name, key, arglist_ptr, lastarg); else call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name)); go to RETURN; end; %page; my_wdir = get_wdir_ (); on condition (cleanup) call clean_up; call initiate_file_ (archive_dir, archive_name, R_ACCESS, p1, orig_bc, code); p1_orig = p1; /* save pointer to archive */ if p1 ^= null then do; call hcs_$fs_get_mode (p1, amode, code); if code = 0 then if ^addr (amode) -> modeb.r then code = error_table_$moderr; if code ^= 0 then do; /* print message and return */ ERROR_RETURN: call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name)); goto RETURN; end; call fs_util_$get_max_length (archive_dir, archive_name, max_length, code); if code ^= 0 then go to ERROR_RETURN; call archive_util_$first_element (p1, savecode); if savecode = 2 then do; FERROR: call com_err_ (0, moi, "Format error in ^a", pathname_ (archive_dir, archive_name)); if p2 ^= null then if copy then call hcs_$delentry_seg (p2, code); go to COMRETN; end; end; if ^key_template.no_orig_ok then if p1 = null then do; NOARCHIVE: call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name)); goto COMRETN; end; if ^key_template.empty_ok then if savecode = 1 then do; call com_err_ (0, moi, "^a is empty.", pathname_ (archive_dir, archive_name)); go to COMRETN; /* cleanup and return */ end; if copy then do; /* special checking for copy */ if p1 = null then do; call com_err_ (0, moi, "Attempt to use copy feature when original not found. ^a", pathname_ (archive_dir, archive_name)); go to COMRETN; end; if archive_dir = my_wdir then do; call com_err_ (0, moi, "Attempt to copy onto original. ^a", pathname_ (archive_dir, archive_name)); goto COMRETN; end; new_archive_dir = my_wdir; /* force new archive to wdir */ end; else new_archive_dir = archive_dir; /* force new archive to replace old */ %page; if lastarg < 3 then if action = 1 then do; call hcs_$star_list_ (my_wdir, "**", 2, null, dcount, lcount, null, null, code); if dcount+lcount > 113 then do; call hcs_$make_seg ("", "", "", 01010b, sp, code); if code ^= 0 then do; call com_err_ (code, moi); go to COMRETN; end; end; end; if lastarg * NONGLOBAL_ELEMENT_SIZE > size (stack_space) then do; call hcs_$make_seg ("", "", "", 01010b, sp, code); if sp = null then do; call com_err_ (code, moi); go to COMRETN; end; do i = 1 to lastarg-2; component_code (i) = 0; flags (i) = 0; ngtype (i) = ""b; end; end; %page; do i = 3 to lastarg; /* get all component names */ call cu_$arg_ptr_rel (i, pathptr, pathlen, code, arglist_ptr); if code ^= 0 then go to BADARG; if pathlen = 0 then go to NEXTARG; /* this might be wrong */ if action = 0 | action = 3 then do; /* table or delete */ component_name (last+1) = patharg; /* not a pathname */ goto CHECKARG; end; call expand_pathname_ (patharg, component_path (last + 1), component_name (last + 1), code); if code ^= 0 then do; BADARG: call com_err_ (code, moi, patharg); goto NEXTARG; end; CHECKARG: do j = last to 1 by -1 while (component_name (j) ^= component_name (last+1));end; if j ^= 0 then do; call com_err_ ((0), moi, "Duplicated request for this component. ^a", component_name (last+1)); goto NEXTARG; end; last = last + 1; NEXTARG: end; if ^key_template.zero_arg_ok then if last = 0 then do; call com_err_ ((0), moi, "Some component names must be specified with this key - ^a", key); go to COMRETN; end; if lastarg >= 3 /* From cu_$arg_count */ then if last = 0 /* Null args, or expand_path_ errors */ then go to COMRETN; /* Don't perform global operations */ if action ^= 0 then archive_data_$active = "1"b; /* protect against recursion */ go to FANOUT (action); %page; FANOUT (0): TABLE_HANDLER: do while (p1 ^= null); /* loop through entire archive */ if last ^= 0 then do; /* check for match with input argument */ do i = last to 1 by -1 while (component_name (i) ^= p1 -> archive.name);end; if i = 0 then go to TNXT; flags (i) = 1; end; if ^header_printed then do; call ioa_ ("^/^-^a^/", pathname_ (archive_dir, archive_name)); if long then call ioa_ (" name^3- updated mode^-modified^- length^/"); else call ioa_ (" updated^2- name^/"); header_printed = "1"b; end; if long then call ioa_ ("^32a^17a^5a^16a^a", p1 -> archive.name, p1 -> archive.timeup, p1 -> archive.mode, p1 -> archive.time, p1 -> archive.bcnt); else call ioa_ ("^20a^a", p1 -> archive.timeup, p1 -> archive.name); TNXT: call archive_util_$next_element (p1, code); if code = 2 then go to FERROR; end; call ioa_ (""); go to NOT_FOUND_CHECKER; /* issue diagnostics and return */ %page; FANOUT (1): REPLACE_HANDLER: if p1 = null then if last = 0 then do; code = error_table_$noentry; go to NOARCHIVE; /* no archive found */ end; call date_time_ ((clock_ ()), timenow); /* get time */ if last = 0 then do; call archive_aux_$listwdir (auxw_ptr, code); if code ^= 0 then do; call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name)); go to COMRETN; end; end; if savecode = 1 then p1 = null; /* archive was empty */ do while (p1 ^= null); if last = 0 then do; /* full replace */ call rcmp; end; else do; do i = last to 1 by -1 while (component_name (i) ^= p1 -> archive.name);end; if i = 0 then do; call ccmp; end; else do; if append then do; flags (i) = 5; call ccmp; end; else do; flags (i) = 1; call rcmp; end; end; end; call archive_util_$next_element (p1, code); if code = 2 then go to FERROR; end; if update then goto MOVE_ARCHIVE; /* do no appending */ do i = 1 to last; if flags (i) = 0 then do; call rcmp; if flags (i) = 0 then flags (i) = 4; /* change to was appended code */ end; end; %page; /* Move archive and perform deletions if necessary */ MOVE_ARCHIVE: if dontcopy ^= 0 then do; call hcs_$set_bc (new_archive_dir, archive_name, gbct, code); if code ^= 0 then do; call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name)); go to COMRETN; end; call hcs_$terminate_noname (p2, fix17); if code = 0 then if delete then go to DELT; else go to NOT_FOUND_CHECKER; end; if amsw = 0 then go to NOT_FOUND_CHECKER; /* did not modify original */ if ^addr (amode) -> modeb.w then do; /* if archive is protected by no w access */ query_info.status_code = error_table_$moderr; call ask_question; /* find out if it's ok to change it */ seg_acl.userid = get_group_id_ (); /* wants to update */ seg_acl.access = "101"b; /* give user rw */ seg_acl.ex_access = "0"b; call hcs_$add_acl_entries (new_archive_dir, archive_name, addr (seg_acl), 1, mcode); if mcode ^= 0 then go to MOVE_ERROR; else mustreprotect = "1"b; end; orig_words = bc_to_rec (orig_bc) * 1024; new_words = bc_to_rec (gbct) * 1024; if new_words > orig_words then do; /* remember they're rounded to a page */ on record_quota_overflow begin; mcode = error_table_$rqover; call hcs_$truncate_seg (p1_orig, orig_words, 0); /* back to original length */ go to MOVE_ERROR; end; offset_words = orig_words; /* copy just the part beyond orig, as a test of quota */ p1_orig -> contents = ptr (p2, 0) -> contents; revert record_quota_overflow; end; offset_words = 0; /* now copy whole thing */ p1_orig -> contents = ptr (p2, 0) -> contents; if "0"b then do; /* only hit this via goto's */ MOVE_ERROR: call com_err_ (mcode, moi, "Archive ^a not updated.", pathname_ (archive_dir, archive_name)); call hcs_$set_bc_seg (tptr, gbct, code); call hcs_$chname_seg (tptr, temp_name, archive_name, code); if code = 0 then tptr = null; /* force temp.archive to be remade */ archive_dir = get_pdir_ (); if code ^= 0 then archive_name = "temp.archive"; call ioa_ ("A copy of the updated archive can be found in [pd]>^a", archive_name); go to NOT_FOUND_CHECKER; end; call hcs_$set_bc (new_archive_dir, archive_name, gbct, savecode); if savecode ^= 0 then call com_err_ (savecode, moi, "^a", pathname_ (archive_dir, archive_name)); else if p2 ^= null then call hcs_$truncate_seg (p2, 0, code); /* truncate copy */ if new_words < orig_words then call hcs_$truncate_seg (p1_orig, new_words, 0); if mustreprotect then do; /* restore ACL to original state */ delete_acl.userid = seg_acl.userid; /* delete ACL */ call hcs_$delete_acl_entries (new_archive_dir, archive_name, addr (delete_acl), 1, code); if code ^= 0 then do; call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name)); goto COMRETN; end; end; cleanup_temp = ""b; /* temporary segment is clean */ if ^delete | savecode ^= 0 then go to NOT_FOUND_CHECKER; DELT: ; do i = 1 to max (last, dlast); /* either last or dlast will be zero, we want the other */ if last ^= 0 then do; if flags (i) = 1 | flags (i) = 4 then call delete_seg (component_path (i), component_name (i), ngtype (i), code); end; else do; if gflags (i) = 1 | gflags (i) = 4 then call delete_seg (my_wdir, gcomponent_name (i), gtype (i), code); end; end; if last = 0 then go to COMRETN; NOT_FOUND_CHECKER: do i = 1 to last; iflag = flags (i); if iflag = 0 then call com_err_ (0, moi, "^a not found in ^a", component_name (i), pathname_ (archive_dir, archive_name)); else if iflag = 2 then call com_err_ (component_code (i), moi, "Could not append ^a to ^a", pathname_ (component_path (i), component_name (i)), pathname_ (archive_dir, archive_name)); else if iflag = 3 then if update & component_code (i) = 0 then do; if updated_something_sw then call com_err_ (0, moi, "Did not update ^a because latest copy already in ^a", component_name (i), pathname_ (archive_dir, archive_name)); end; else do; if found_something_sw | nonglobal (i).component_code ^= 0 then call com_err_ (nonglobal (i).component_code, moi, "Could not replace ^a in ^a", pathname_ (nonglobal (i).component_path, nonglobal (i).component_name), pathname_ (archive_dir, archive_name)); end; else if iflag = 4 & p1_orig ^= null & ^append then do; call ioa_ ("^[archive: ^;^9x^]^a appended to ^a", first_line_sw, pathname_ (component_path (i), component_name (i)), pathname_ (archive_dir, archive_name)); first_line_sw = "0"b; end; else if iflag = 5 then call com_err_ (0, moi, "Did not append ^a because copy found in ^a", component_name (i), pathname_ (archive_dir, archive_name)); else if iflag = 6 /* Temp, could use 2 if error code were available */ then call com_err_ (0, moi, "Archive segment overflow. Could not ^a ^a in ^a", act_com, pathname_ (component_path (i), component_name (i)), pathname_ (archive_dir, archive_name)); /* else if iflag = 7 then; /* No message, but no delete either */ end; if update then if ^found_something_sw then call com_err_ (0, moi, "No matching segments^[ in ^a^;^s^]; no components were updated in archive ^a", last = 0, archive_dir, pathname_ (archive_dir, archive_name)); else if ^updated_something_sw then call com_err_ (0, moi, "Archive ^a contains the latest versions; no components were updated^[ from ^a^].", pathname_ (archive_dir, archive_name), last = 0, archive_dir); COMRETN: ; /* return from command */ call clean_up; RETURN: return; /* cleanup handler used at command termination as well */ clean_up: proc; if sp ^= addr (stack_space) then do; call hcs_$delentry_seg (sp, code); call hcs_$terminate_noname (sp, code); end; if aux_wstructure.mustfree then call archive_aux_$free (auxw_ptr); if p1_orig ^= null then call hcs_$terminate_noname (p1_orig, code); archive_data_$active = ""b; end clean_up; %page; FANOUT (2): XTRACT_HANDLER: XTRACT_LOOP: do i = last to 1 by -1 while (component_name (i) ^= p1 -> archive.name);end; if i ^= 0 then nonglobal (i).flags = 1; else if last ^= 0 then do; /* this is not one of the specified components */ if delete then call ccmp; go to XTRACT_NXT; end; if last = 0 then initpath = my_wdir; else initpath = component_path (i); bcnt = cv_dec_ (p1 -> archive.bcnt); wdct = divide (bcnt+35, 36, 17, 0); if wdct > max_length then go to FERROR; if p1 -> archive.mode = "" then mode = 01010b; /* compatibility */ else do; /* convert ascii rewa to mode */ mode = 0; /* initialize */ if substr (p1 -> archive.mode, 1, 1) = "r" then mode = 01000b; if substr (p1 -> archive.mode, 2, 1) = "e" then mode = mode + 00100b; if substr (p1 -> archive.mode, 3, 1) = "w" then mode = mode + 00010b; end; MAKEIT: ; call hcs_$make_seg (initpath, p1 -> archive.name, "", 01011b, cptr, code); if cptr = null then do; if code = error_table_$incorrect_access then call com_err_ (error_table_$no_append, moi, "^a", initpath); else call com_err_ (code, moi, "^a", pathname_ (initpath, p1 -> archive.name)); if nonglobal (i).flags = 1 then do; /* found an existing archive component */ if delete then do; nonglobal (i).flags = 7; /* indicate that no delete */ call ccmp; /* copy this existing component in temp archive */ end; end; nonglobal (i).component_code = code; /* save error code for printing an error message */ goto XTRACT_NXT; end; if delete then do; amsw = 1; /* we're modifying the archive */ if i ^= 0 then nonglobal (i).flags = 1; end; if code ^= 0 then do; if ^force then call nd_handler_ (moi, initpath, p1 -> archive.name, code); else do; call hcs_$status_minf (initpath, p1 -> archive.name, 0, typef, j, code); call delete_seg (initpath, p1 -> archive.name, bit (typef, 2), code); end; if code = 0 then do; call hcs_$make_seg (initpath, p1 -> archive.name, "", 01011b, cptr, code); if code ^= 0 then do; if code = error_table_$incorrect_access then code = error_table_$no_append; call com_err_ (code, moi, "^a", initpath); if cptr ^= null then call hcs_$terminate_noname (cptr, code); SKIP_COMPONENT: if delete then call ccmp; /* don't delete the component */ go to XTRACT_NXT; end; end; else go to SKIP_COMPONENT; end; cptr -> array = addr (p1 -> archive.begin) -> array; call hcs_$set_bc (initpath, p1 -> archive.name, bcnt, code); if mode ^= 01010b then do; seg_acl.userid = get_group_id_$tag_star (); seg_acl.access = bit (bin (mode, 4), 4); /* convert old style access modes to new style */ seg_acl.ex_access = "0"b; call hcs_$add_acl_entries (initpath, p1 -> archive.name, addr (seg_acl), 1, code); end; call hcs_$terminate_seg (cptr, 0, code); XTRACT_NXT: call archive_util_$next_element (p1, code); if code = 2 then go to FERROR; if p1 ^= null then go to XTRACT_LOOP; if delete then do; delete = "0"b; /* don't want MOVE_ARCHIVE to delete the segs we made */ go to CHECK_DELETED; end; else go to NOT_FOUND_CHECKER; %page; FANOUT (3): DELETE_HANDLER: do while (p1 ^= null); do i = last to 1 by -1 while (component_name (i) ^= p1 -> archive.name);end; if i = 0 then do; call ccmp; end; else do;amsw = 1; flags (i) = 1;end; call archive_util_$next_element (p1, code); if code = 2 then go to FERROR; end; CHECK_DELETED: if p2 = null then do; /* get segment made */ call makenew; do i = 1 to last while (nonglobal (i).component_code = 0); end; if i > last then call ioa_ ("archive: All components of ^a have been deleted.", pathname_ (archive_dir, archive_name)); end; go to MOVE_ARCHIVE; %page; /* Internal procedure to replace an archive component */ rcmp: proc; if last ^= 0 then do; nonglobal (i).component_code = 0; char32 = nonglobal (i).component_name; initpath = nonglobal (i).component_path; end; else do; /* global case */ char32 = p1 -> archive.name; initpath = my_wdir; if ^archive_aux_$inwdir (auxw_ptr, p1 -> archive.name, dtm, entry_type) then goto MUSTCOPY; end; call initiate_file_ (initpath, char32, R_ACCESS, optr, bcnt, code); if code ^= 0 then do; if last = 0 then call com_err_ (code, moi, "^a", pathname_ (initpath, char32)); else nonglobal (i).component_code = code; end; if optr = p1_orig then do; /* can't replace the archive in itself */ flags (i) = 3; go to MUSTCOPY; end; if optr = null then do; MUSTCOPY: if last ^= 0 then if append then flags (i) = 2; else flags (i) = 3; MUSTCOPY2: if p1 ^= null then do; /* copy the original component */ call ccmp; end; return; end; found_something_sw = "1"b; call hcs_$fs_get_mode (optr, mode, code); /* get current mode */ if code = 0 then if ^modeb.r then code = error_table_$moderr; if code ^= 0 then do; REPLERR: if last = 0 then call com_err_ (code, moi, "^a", pathname_ (initpath, char32)); else component_code (i) = code; call hcs_$terminate_noname (optr, code); go to MUSTCOPY; end; call hcs_$status_long (initpath, char32, 0, addr (stat), null, code); if code ^= 0 & code ^= error_table_$no_s_permission then go to REPLERR; /* print error code (or store it) */ if last ^= 0 then ngtype (i) = stat.type; /* save the entry type */ if stat.type = "00"b then do; /* chase link */ call hcs_$status_long (initpath, char32, 1, addr (stat), null, code); if code ^= 0 & code ^= error_table_$no_s_permission then go to REPLERR; end; if last ^= 0 then dtm = stat.dtm; curlen = fixed (stat.cur, 12); if bc_to_rec (bcnt) < curlen then do; call com_err_ (0, moi, "Bit count is inconsistent with current length for ^a^[>^]^a", initpath, initpath ^= ">", char32); if last = 0 then call ioa_$ioa_switch (iox_$error_output, "Component was not updated in ^a", pathname_ (archive_dir, archive_name)); go to MUSTCOPY; end; call date_time_$fstime (addr (dtm) -> fix35, time); if update then do; if p1 ^= null then if convert_time (time) <= convert_time (p1 -> archive.time) then do; /* check dtm's */ call hcs_$terminate_noname (optr, code); go to MUSTCOPY; end; updated_something_sw = "1"b; end; if delete then /* save names for deletion */ if last = 0 then do; dlast = dlast + 1; if dlast * GLOBAL_ELEMENT_SIZE > size (stack_space) then do; /* need more room */ call hcs_$make_seg ("", "", "", 01010b, new_sp, code); if new_sp = null then do; call com_err_ (code, moi); go to COMRETN; end; do k = 1 to dlast - 1; /* copy from stack_space to allocated seg */ new_sp -> global (k) = sp -> global (k); end; sp = new_sp; end; gflags (dlast) = 1; gtype (dlast) = entry_type; /* save the entry type */ gcomponent_name (dlast) = char32; end; if p2 = null then call makenew; /* get segment made */ wdct = divide (bcnt+35, 36, 17, 0); if (bin (rel (p2), 18, 0) + wdct + header_length) > max_length then do; if last = 0 /* Global update/replace? */ then do; if copy then dn = new_archive_dir; else dn = archive_dir; call com_err_ (0, moi, "Archive segment overflow. Could not ^a ^a in ^a", act_com, char32, pathname_ (dn, archive_name)); if dlast = 0 then dlast = 1; gflags (dlast) = 7; /* No message, but no delete */ go to MUSTCOPY2; end; iflag = flags (i); flags (i) = 6; /* Temp until "seglarge" error code? */ if iflag = 0 /* Appending? */ then go to RCMPRTN; go to MUSTCOPY2; /* Don't update "flags" */ end; amsw = 1; /* mark for updating */ p2 -> archive.pad, p2 -> archive.pad1 = " "; p2 -> archive.hbgn = archive_data_$ident; p2 -> archive.hend = archive_data_$fence; p2 -> archive.name = char32; char8 = bcnt; p2 -> archive.bcnt = char8; p2 -> archive.timeup = timenow; p2 -> archive.time = time; p2 -> archive.mode = ""; if modeb.r then substr (p2 -> archive.mode, 1, 1) = "r"; if modeb.e then substr (p2 -> archive.mode, 2, 1) = "e"; if modeb.w then substr (p2 -> archive.mode, 3, 1) = "w"; p2 = addrel (p2, header_length); gbct = gbct + header_length_bits; p2 -> array = optr -> array; maskl = wdct*36 - bcnt; if maskl ^= 0 then addrel (p2, wdct-1) -> mask.kill = ""b; p2 = addrel (p2, wdct); gbct = gbct + wdct*36; if update & last = 0 then do; if copy then dn = new_archive_dir; else dn = archive_dir; call ioa_ ("^[archive: ^;^9x^]^a updated in ^a", first_line_sw, char32, pathname_ (dn, archive_name)); first_line_sw = "0"b; end; RCMPRTN: call hcs_$terminate_noname (optr, code); end rcmp; %page; /* Internal procedure to copy the current archive component to the new archive */ ccmp: proc; if p2 = null then call makenew; /* get temp seg */ bcnt = cv_dec_ (p1 -> archive.bcnt) + header_length_bits; /* get bit count of current component */ wdct = divide (bcnt+35, 36, 17, 0); /* convert to word count */ if wdct > max_length then go to FERROR; /* max length of the current component is greater the actual */ if (bin (rel (p2), 18, 0) + wdct) > max_length then do; call com_err_ (0, moi, "Archive segment overflow while copying ^a in ^a Archive not updated.", p1 -> archive.name, pathname_ (archive_dir, archive_name)); go to COMRETN; /* Abort */ end; p2 -> array = p1 -> array; /* copy header + data */ gbct = gbct + wdct*36; /* update global bit count */ p2 = addrel (p2, wdct); /* step current component pointer */ end ccmp; %page; /* Internal procedure to create a new output archive segment */ makenew: proc; dcl error fixed bin (35); if copy | p1_orig = null then do; dontcopy = 1; CREATE: call hcs_$make_seg (new_archive_dir, archive_name, "", 01011b, p2, error); if error ^= 0 then do; if error = error_table_$namedup | error = error_table_$segknown then do; call nd_handler_ (moi, new_archive_dir, archive_name, error); if error = 0 then go to CREATE; call hcs_$terminate_noname (p2, code); p2 = null; go to COMRETN; end; call com_err_ (error, moi, "^a", pathname_ (new_archive_dir, archive_name)); go to COMRETN; /* non local go to */ end; call fs_util_$get_max_length (new_archive_dir, archive_name, max_length, error); if code ^= 0 then do; call com_err_ (error, moi, "^a", pathname_ (new_archive_dir, archive_name)); go to COMRETN; /* non local go to */ end; if orig_bc = 0 then orig_bc = max_length * 36; if ^copy then do; call ioa_ ("archive: Creating ^a", pathname_ (archive_dir, archive_name)); p1_orig = p2; /* let p1_orig points to the newly created output archive segment */ end; else call ioa_ ("archive: Copying ^a", pathname_ (archive_dir, archive_name)); return; end; if tptr = null then do; /* make the temp */ call hcs_$make_seg ("", temp_name, "", 01011b, tptr, error); if tptr = null then do; /* cant make it */ call com_err_ (error, moi, "[pd]>^a", temp_name); go to COMRETN; /* non local go to */ end; end; else if cleanup_temp then call hcs_$truncate_seg (tptr, 0, error); p2 = tptr; cleanup_temp = "1"b; /* mark temp dirty */ end makenew; %page; bc_to_rec: proc (P_bc) returns (fixed bin); dcl P_bc fixed bin (24); if P_bc = 0 then return (0); else return (divide (P_bc - 1, 36 * 1024, 17, 0) + 1); end bc_to_rec; delete_seg: proc (path, entry, dtype, dcode); dcl (path, entry) char (*) aligned, dtype bit (2), dcode fixed bin (35); dcl ccode fixed bin (35); call term_ (path, entry, dcode); if dtype = "00"b then do; call hcs_$initiate (path, entry, "", 0, 1, cptr, dcode); if cptr = null then return; call hcs_$delentry_seg (cptr, dcode); end; else call hcs_$delentry_file (path, entry, dcode); if dcode = 0 then return; if ^force then call dl_handler_ (moi, path, entry, dcode); else call dl_handler_$noquestion (moi, path, entry, dcode); if dtype = "00"b then call hcs_$delentry_seg (cptr, ccode); else call hcs_$delentry_file (path, entry, ccode); if dcode = 0 then dcode = ccode; if dcode ^= 0 then call com_err_ (0, moi, "Could not delete ^a", pathname_ (path, entry)); end delete_seg; convert_time: proc (P_str) returns (fixed bin (71)); dcl P_str char (*) aligned; dcl fixed_time fixed bin (71); call convert_date_to_binary_ ((P_str), fixed_time, code); if code ^= 0 then return (0); else return (fixed_time); end convert_time; ask_question: proc; /* Procedure to ask the user whether to update a protected segment */ call command_query_ (addr (query_info), buffer, moi, "Do you want to update the protected segment ^a ?", pathname_ (new_archive_dir, archive_name)); if substr (buffer, 1, 2) = "no" then goto COMRETN; end ask_question; %page; %include access_mode_values; end archive;  archive_.pl1 04/19/85 0827.8rew 04/18/85 1658.2 153576 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ archive_: proc (); /* * ARCHIVE_ -- subroutine entriers for manipulating archives * * archive_$get_component * Returns a pointer to a named archive component, given a pointer to the archive * archive_$get_component_info * Finds a component and returns complete info about it. * archive_$next_component * Returns a pointer to the next component in an archive. * archive_$next_component_info * Returns complete info about the next component. * archive_$list_components * Returns a list of archive components and info. * * 01/13/81, W. Olin Sibert */ /* Fixed bug detecting format error if only one, null, component (archive is just a header) 04/18/85 Steve Herbst */ /* * Note: this procedure assumes that all archives do, in fact, contain only the strings * archive_data_$ident and archive_data_$header_end to identify their headers. The use * of archive_data_$header_begin and archive_data_$header_end was evidently an improvement * which was never implemented, and can therefore be ignored here. No existing code in * the system generates archives containing either of those strings. The archive command, * in fact, cannot deal with such archives. */ dcl P_archive_ptr pointer parameter; /* Input: pointer to archive */ dcl P_archive_bc fixed bin (24) parameter; /* Input: archive bitcount */ /* All entries take the same first two arguments */ dcl P_component_name char (*) parameter; /* Input: component to search for or update */ /* Output for archive_$next_component */ dcl P_component_ptr pointer parameter; /* Output: pointer to base of component */ /* Input/Output for archive_$next_component("" _info) */ dcl P_component_bc fixed bin (24) parameter; /* Output: bitcount of component */ dcl P_archive_component_info_ptr pointer parameter; /* Input: pointer to archive_component_info to fill in */ dcl P_info_version fixed bin parameter; /* Input: version number of listing structure caller wants */ dcl P_area_ptr pointer parameter; /* Input: pointer to area for list */ dcl P_n_components fixed bin; /* Output: number of components in archive */ dcl P_component_list_ptr pointer parameter; /* Output: pointer to array of component infos */ dcl P_code fixed bin (35) parameter; dcl archive_ptr pointer; /* Pointer and size of the archive being worked on */ dcl archive_bc fixed bin (24); dcl archive_size fixed bin (19); dcl component_name char (32); dcl component_ptr pointer; dcl header_ptr pointer; /* All information about the current component */ dcl 1 comp_info like archive_component_info aligned automatic; dcl comp_list_ptr pointer; dcl n_components fixed bin; dcl comp_idx fixed bin; dcl 1 comp_list (n_components) like archive_component_info aligned based (comp_list_ptr); dcl output_area_ptr pointer; dcl output_area area based (output_area_ptr); dcl info_sw bit (1) aligned; dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl error_table_$archive_fmt_err fixed bin (35) external static; dcl error_table_$bad_arg fixed bin (35) external static; dcl error_table_$no_component fixed bin (35) external static; dcl error_table_$not_archive fixed bin (35) external static; dcl error_table_$unimplemented_version fixed bin (35) external static; dcl archive_data_$ident char (8) aligned external static; dcl archive_data_$header_end char (8) aligned external static; dcl (addrel, baseno, binary, divide, ltrim, null, pointer, rel, rtrim, size, string, substr, unspec, verify) builtin; dcl cleanup condition; /* */ archive_$get_component: entry (P_archive_ptr, P_archive_bc, P_component_name, P_component_ptr, P_component_bc, P_code); P_component_ptr = null (); P_component_bc = 0; info_sw = "0"b; goto GET_COMPONENT_COMMON; archive_$get_component_info: entry (P_archive_ptr, P_archive_bc, P_component_name, P_archive_component_info_ptr, P_code); archive_component_info_ptr = P_archive_component_info_ptr; if archive_component_info.version ^= ARCHIVE_COMPONENT_INFO_VERSION_1 then call FINISH (error_table_$unimplemented_version); info_sw = "1"b; goto GET_COMPONENT_COMMON; GET_COMPONENT_COMMON: call CHECK_ARCHIVE; component_name = P_component_name; do header_ptr = (NEXT_HEADER_PTR ()) repeat (NEXT_HEADER_PTR ()) while (header_ptr ^= null ()); if comp_info.name = component_name then goto FOUND_COMPONENT; end; call FINISH (error_table_$no_component); /* never returns */ FOUND_COMPONENT: if info_sw then /* only call convert_date_to_binary_ if needful, to */ call GET_ALL_COMPONENT_INFO; /* avoid unnecessary expense. */ if ^info_sw then do; /* Return pointer and length */ P_component_ptr = comp_info.comp_ptr; P_component_bc = comp_info.comp_bc; end; else archive_component_info = comp_info; /* Just fill in the structure from our copy */ call FINISH (0); /* All done, return successfully */ /* */ archive_$next_component: entry (P_archive_ptr, P_archive_bc, P_component_ptr, P_component_bc, P_component_name, P_code); component_ptr = P_component_ptr; /* Input/Output parameter */ P_component_ptr = null (); /* Initialize output arguments */ P_component_bc = 0; P_component_name = ""; info_sw = "0"b; goto NEXT_COMPONENT_COMMON; archive_$next_component_info: entry (P_archive_ptr, P_archive_bc, P_component_ptr, P_archive_component_info_ptr, P_code); component_ptr = P_component_ptr; /* Input/Output parameter */ P_component_ptr = null (); /* Initialize output argument */ archive_component_info_ptr = P_archive_component_info_ptr; if archive_component_info.version ^= ARCHIVE_COMPONENT_INFO_VERSION_1 then call FINISH (error_table_$unimplemented_version); info_sw = "1"b; goto NEXT_COMPONENT_COMMON; NEXT_COMPONENT_COMMON: call CHECK_ARCHIVE; /* Get set up */ if baseno (archive_ptr) ^= baseno (component_ptr) then /* Ought to do something about this */ if component_ptr ^= null () then /* But don't reject the "first" flag */ call FINISH (error_table_$bad_arg); if component_ptr = null () then /* Set up for NEXT_HEADER_PTR protocol */ header_ptr = null (); else if binary (rel (component_ptr), 18) < size (archive_header) then /* Must be a sensible pointer */ call FINISH (error_table_$bad_arg); else if binary (rel (component_ptr), 18) > archive_size then /* Must not be past the end */ call FINISH (error_table_$bad_arg); else if pointer (component_ptr, rel (component_ptr)) ^= component_ptr then /* Make sure it's a word boundary */ call FINISH (error_table_$bad_arg); else do; header_ptr = addrel (component_ptr, 0 - size (archive_header)); /* Back up the header itself */ call GET_COMPONENT_INFO; end; header_ptr = NEXT_HEADER_PTR (); /* get the next one */ if header_ptr = null () then do; /* We have run out of components */ if info_sw then do; /* Clear out the comp_info as well */ unspec (archive_component_info) = ""b; archive_component_info.version = ARCHIVE_COMPONENT_INFO_VERSION_1; archive_component_info.comp_ptr = null (); end; else P_component_bc = 0; call FINISH (0); /* All done with this archive */ end; P_component_ptr = comp_info.comp_ptr; /* Return the Input/Output parameter */ if info_sw then do; /* only call convert_date_to_binary_ if needful, to */ call GET_ALL_COMPONENT_INFO; /* avoid unnecessary expense. */ archive_component_info = comp_info; end; else do; /* Otherwise, just return pointer and length */ P_component_bc = comp_info.comp_bc; P_component_name = comp_info.name; end; call FINISH (0); /* All done, return successfully */ /* */ archive_$list_components: entry (P_archive_ptr, P_archive_bc, P_info_version, P_area_ptr, P_component_list_ptr, P_n_components, P_code); output_area_ptr = P_area_ptr; /* Locate the area we shall allocate the list in */ P_n_components = 0; /* Initialize output arguments */ P_component_list_ptr = null (); if P_info_version ^= ARCHIVE_COMPONENT_INFO_VERSION_1 then /* Make sure we agree with the caller */ call FINISH (error_table_$unimplemented_version); /* about the info structure version */ call CHECK_ARCHIVE; /* See if it's in the least OK */ n_components = 0; /* First, count the components -- this will also validate */ header_ptr = null (); /* the entire archive */ do header_ptr = (NEXT_HEADER_PTR ()) repeat (NEXT_HEADER_PTR ()) while (header_ptr ^= null ()); n_components = n_components + 1; end; if (n_components = 0) | (output_area_ptr = null ()) then do; /* Nothing there, or no list wanted */ P_n_components = n_components; call FINISH (0); /* Return successfully */ end; on cleanup begin; if comp_list_ptr ^= null () then free comp_list in (output_area); P_component_list_ptr = null (); /* Don't let user think we didn't free this */ end; allocate comp_list in (output_area) set (comp_list_ptr); comp_idx = 1; do header_ptr = (NEXT_HEADER_PTR ()) /* Now, go through and list the components */ repeat (NEXT_HEADER_PTR ()) while (header_ptr ^= null ()); call GET_ALL_COMPONENT_INFO; /* Fill in the whole thing */ comp_list (comp_idx) = comp_info; /* and put it in the array */ comp_idx = comp_idx + 1; /* Advance to next component */ end; P_component_list_ptr = comp_list_ptr; P_n_components = n_components; call FINISH (0); /* All done for listing */ /* */ MAIN_RETURN: /* This label is the only way out of the program */ return; FORMAT_ERROR: /* General-purpose format error exit */ if comp_list_ptr ^= null () then /* Clean up anything we might have allocated */ free comp_list; comp_list_ptr = null (); call FINISH (error_table_$archive_fmt_err); FINISH: proc (P_return_code); dcl P_return_code fixed bin (35) parameter; /* This is just a convenient way of exiting and returning a specific error code */ P_code = P_return_code; /* Set the main procedure return code */ goto MAIN_RETURN; end FINISH; CHECK_ARCHIVE: proc (); /* This procedure copies the standard parameters, and verifies that the segment does, indeed, seem to be an archive. */ comp_list_ptr = null (); /* For cleanup handler */ archive_ptr = pointer (P_archive_ptr, 0); /* Adjust to base of archive segment */ archive_bc = P_archive_bc; archive_size = divide (archive_bc, 36, 19, 0); if archive_bc ^= (36 * archive_size) then /* Can't be if bitcount is not word aligned */ call FINISH (error_table_$not_archive); header_ptr = null (); /* Make NEXT_HEADER_PTR look for the first */ if archive_size = 0 then /* No components is OK, though perhaps undesired */ return; if archive_size < size (archive_header) then /* Must have enough to be an archive */ call FINISH (error_table_$not_archive); if (archive_ptr -> archive_header.header_begin ^= archive_data_$ident) then call FINISH (error_table_$not_archive); /* Probably not, and this is a better message than */ /* format error if it truly isn't an archive */ if (archive_ptr -> archive_header.header_end ^= archive_data_$header_end) then call FINISH (error_table_$not_archive); P_code = 0; /* Set standard output parameter for success, and */ return; /* assume it's valid, and let someone else */ end CHECK_ARCHIVE; /* find out that it is not if need be. */ /* */ NEXT_HEADER_PTR: proc () returns (pointer); /* This procedure advances header_ptr to point to the header for the next component, validates the header, and returns the pointer to it. It assumes that header_ptr already points to a validated header, unless it is null, in which case it sets header_ptr to point to the first header in the archive. */ if header_ptr = null () then /* First component */ if archive_size = 0 then /* But, archive is empty */ return (null ()); else header_ptr = archive_ptr; /* really first */ else do; if binary (rel (header_ptr), 18) + size (archive_header) + comp_info.comp_lth >= archive_size then return (null ()); /* We have reached the last component */ header_ptr = addrel (header_ptr, (size (archive_header) + comp_info.comp_lth)); end; call GET_COMPONENT_INFO; /* make sure this header seems OK, */ /* and extract all the information from it */ return (header_ptr); end NEXT_HEADER_PTR; /* */ GET_COMPONENT_INFO: proc (); /* This procedure ascertains that header_ptr points to something looking reasonably like an archive component header. It verifies as well as it can that the times and the access are valid, although it does not actually calculate them. To fill in those values, GET_ALL_COMPONENT_INFO should be called. */ dcl TIME_CHARACTERS char (13) internal static options (constant) init ("0123456789 ./"); dcl MODE_CHARACTERS char (5) internal static options (constant) init ("rewa "); dcl BITCOUNT_CHARS char (10) internal static options (constant) init ("0123456789"); if (header_ptr -> archive_header.header_begin ^= archive_data_$ident) then goto FORMAT_ERROR; if (header_ptr -> archive_header.header_end ^= archive_data_$header_end) then goto FORMAT_ERROR; /* These machinations with the bitcount are necessary because some archives in the system contain the bitcount left justified in the eight character field, rather than right justified. How they got that way is anybodys guess, but if archive can handle them, this should, too. */ if header_ptr -> archive_header.bit_count = "" then goto FORMAT_ERROR; if verify (rtrim (ltrim (header_ptr -> archive_header.bit_count)), BITCOUNT_CHARS) ^= 0 then goto FORMAT_ERROR; if verify (header_ptr -> archive_header.timeup, TIME_CHARACTERS) ^= 0 then goto FORMAT_ERROR; if verify (header_ptr -> archive_header.time, TIME_CHARACTERS) ^= 0 then goto FORMAT_ERROR; unspec (comp_info) = ""b; comp_info.version = ARCHIVE_COMPONENT_INFO_VERSION_1; /* So it's safer to just return this structure */ comp_info.comp_ptr = addrel (header_ptr, size (archive_header)); /* First data after header structure */ comp_info.comp_bc = binary (ltrim (rtrim (header_ptr -> archive_header.bit_count)), 28); /* Avoid size condition here by using precision 28 */ comp_info.name = header_ptr -> archive_header.name; comp_info.comp_lth = divide (comp_info.comp_bc + 35, 36, 18, 0); if archive_size < (binary (rel (comp_info.comp_ptr), 18) + comp_info.comp_lth) then goto FORMAT_ERROR; /* component extends past the end, sad to say */ /* This will also catch generally oversize bitcounts */ if verify (header_ptr -> archive_header.mode, MODE_CHARACTERS) ^= 0 then goto FORMAT_ERROR; return; end GET_COMPONENT_INFO; /* */ GET_ALL_COMPONENT_INFO: proc (); /* This procedure fills in all the rest of the comp_info structure, which is is only needed by some entrypoints. */ dcl 1 mode_str unaligned, /* For mode testing */ 2 read char (1) unaligned, 2 execute char (1) unaligned, 2 write char (1) unaligned, 2 pad char (1) unaligned; dcl code fixed bin (35); string (mode_str) = header_ptr -> archive_header.mode; comp_info.access = ""b; /* Prepare to figure out the access modes */ if mode_str.read = "r" then substr (comp_info.access, 1, 1) = "1"b; /* Read */ else if mode_str.read ^= " " then goto FORMAT_ERROR; if mode_str.execute = "e" then substr (comp_info.access, 2, 1) = "1"b; /* Execute */ else if mode_str.execute ^= " " then goto FORMAT_ERROR; if mode_str.write = "w" then substr (comp_info.access, 3, 1) = "1"b; /* Write */ else if mode_str.write ^= " " then goto FORMAT_ERROR; if (mode_str.pad ^= " ") & (mode_str.pad ^= "a") then /* Obsolete -- used to mean append */ goto FORMAT_ERROR; /* Complain if it's wrong, anyway */ call convert_date_to_binary_ (string (header_ptr -> archive_header.time), comp_info.time_modified, code); if code ^= 0 then /* Just complain about archive badness, rather than */ goto FORMAT_ERROR; /* whatever specific error it is */ call convert_date_to_binary_ (string (header_ptr -> archive_header.timeup), comp_info.time_updated, code); if code ^= 0 then goto FORMAT_ERROR; return; end GET_ALL_COMPONENT_INFO; %page; %include archive_header; %page; %include archive_component_info; end archive_;  archive_aux_.pl1 11/04/82 1938.1rew 11/04/82 1619.7 40653 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* auxilliary subroutines used by the archive command for special case handling. listwdir used to list the working directory inwdir used to find whether entry is in wdir free used to free storage allocated by listwdir active used to note to user attempt to use recursively */ /* 12/03/70 coded J.W. Gintell 07/07/71 modified Bug fixed 04/18/79 S. Herbst */ archive_aux_: proc; dcl (addr, bin, null, substr) builtin; /* */ listwdir: entry(auxw_ptr,code); dcl auxw_ptr ptr; /* pointer to structure */ dcl code fixed bin(35); dcl (get_system_free_area_, freen_) entry(ptr); dcl hcs_$star_list_ external entry(char(*),char(*),fixed bin(3),ptr,fixed bin, fixed bin,ptr,ptr,fixed bin(35)); dcl hcs_$status_long entry(char(*), char(*), fixed bin, ptr, ptr, fixed bin(35)); declare 1 stat aligned, /* Structure for status_long call */ 2 (type bit(2), pad bit(34)) unaligned, 2 dtm bit(36), 2 pad1(5) fixed bin, 2 (curlen bit(12), bitcnt bit(24)) unaligned, 2 pad2(2) fixed bin; declare 1 wstructure aligned based(auxw_ptr), 2 mustfree bit(1), /* set to one after allocation complete */ 2 ecount fixed bin, /* Number of entries in directory */ 2 wdir char(168) unaligned, /* Working directory unaligned, filled by caller */ 2 eptr ptr, /* pointer to entry structure */ 2 nptr ptr; /* pointer to name structure */ dcl area area based (areap); /* for freeing */ dcl areap ptr; /* pointer to area */ dcl lcount fixed bin(17); /* number of links */ dcl (j,k) fixed bin(17); dcl 1 branches(ecount) based(eptr) aligned, /* returned by star_ in area */ (2 type bit(2), /* ask for segs only */ 2 nname bit(16), /* number of names */ 2 nindex bit(18), /* index to names array */ 2 dtm bit(36), /* date-time mod */ 2 dtu bit(36), 2 mode bit(5), 2 pad bit(13), 2 records bit(18)) unaligned; dcl names (5000) char(32) aligned based (nptr); /* Illegal PL/I but easier than computing # of names */ call get_system_free_area_(areap); /* get area for star handler */ call hcs_$star_list_(wdir,"**",3,areap,ecount,lcount,eptr,nptr,code); ecount = ecount + lcount; /* Update by number of links, to get total entries */ if ecount > 0 then mustfree = "1"b; return; inwdir: entry(auxw_ptr,component_name,dtm,type,found) ; dcl component_name char(32); dcl type bit(2) aligned; dcl dtm bit(36) aligned; dcl found bit(1) aligned; dcl xcode fixed bin(35); do k = 1 to ecount; /* look at all branches */ do j = 1 to bin(eptr->branches.nname(k), 17); /* look at all names */ if component_name = nptr->names(j+bin(eptr->branches.nindex(k), 17)-1) then do; type = eptr->branches.type(k); if type then dtm = eptr->branches.dtm(k); /* Is branch (really should check non-dir) */ else do; /* Link, chase it */ call hcs_$status_long(wdir, component_name, 1, addr(stat), null, xcode); if xcode ^= 0 then go to nfnd; /* Link target empty */ dtm = stat.dtm; /* Set date-time-seg updated */ end; found = "1"b; return; end; end; end; nfnd: found = ""b; return; free: entry(auxw_ptr); if eptr ^= null then free eptr -> branches in (area); if nptr ^= null then free nptr -> names in (area); return; /* */ active: entry(activeind); dcl buffer char(120) varying; dcl command_query_ entry options(variable); declare 1 query_info aligned, /* structure for command_query_ */ 2 version fixed bin init(1), 2 yes_or_no_sw bit(1) unal init("1"b), /* require yes or no */ 2 suppress_name_sw bit(1) unal init("0"b), /* print name with question */ 2 status_code fixed bin(35), /* set to code of prompting question */ 2 query_code fixed bin(35) init(0); dcl activeind bit(1) aligned; query_info.status_code = 0; call command_query_(addr(query_info),buffer,"archive", "Pending work in previous invocation will be lost if you proceed;^/do you wish to proceed?",""); if substr(buffer,1,3) = "yes" then activeind = ""b; else activeind = "1"b; end archive_aux_;  archive_data_.alm 11/04/82 1938.1rew 11/04/82 1632.8 15057 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " ARCHIVE_DATA_ -- Constants used in archive manipulation " " Modified 2/22/81, W. Olin Sibert, to add comments about obsolescence. name archive_data_ " " segment containing active flag and constants used in archive segments " segdef active segdef header_begin segdef header_end segdef ident segdef fence " use var " " flag preventing recursive use of archive command/act active function " active: " oct 000000000000 " " Note: the appropriate constants to use when manipulating archives " are archive_data_$fence and archive_data_$ident. The header_begin " and header_end versions are relics of an obsolete "improved archive " format" which was never actually implemented. No existing code " creates archives containing them, and the archive command cannot " deal with them, either. " use const " " constant used to mark beginning of archive header " ident: " oct 014012012012 oct 017012011011 " constant used to mark end of archive header " header_end: fence: " oct 017017017017 oct 012012012012 " contant used to mark beginning of archive header (OBSOLETE) " header_begin: " oct 013012012012 oct 017012011011 " join /text/const join /static/var " end  archive_key_.alm 11/04/82 1938.1rew 11/04/82 1606.7 26703 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name archive_key_ segdef begin_table segdef last_index " array of archive keys and resulting codes " used to determine actions to be taken by the archive command " " New keys 'xd' (extract-delete component) and 'xdf' added 07/14/82 S. Herbst " "declare 1 archive_key_$begin_table(archive_key_$last_index), " 2 key char(4), /* key acceptable to archive command */ " 2 type bit(2), /* = 0 for table " = 1 for replace " = 2 for extract " = 3 for delete */ " 2 update bit(1), " 2 append bit(1), " 2 copy bit(1), " 2 delete bit(1), " 2 force bit(1), " 2 long bit(1), " 2 zero_arg_ok bit(1), " 2 star_ok bit(1), " 2 empty_ok bit(1), " 2 no_orig_ok bit(1); equ table,0 equ replace,1 equ extract,2 equ delete,3 bool update,100000 bit 2 of second word bool append,40000 bool copy,20000 bool del,10000 bool force,4000 bool long,2000 bool zarg,1000 bool star,400 bool empty,200 bool norig,100 bool brief,40 " begin_table: aci "r " vfd 2/replace,16/empty+norig+zarg aci "rd " vfd 2/replace,16/del+empty+norig+zarg aci "rdf " vfd 2/replace,16/del+force+empty+norig+zarg aci "cr " vfd 2/replace,16/copy+empty+norig+zarg aci "crd " vfd 2/replace,16/copy+del+empty+norig+zarg aci "crdf" vfd 2/replace,16/copy+del+force+empty+norig+zarg aci "u " vfd 2/replace,16/update+zarg aci "ud " vfd 2/replace,16/update+zarg+del aci "udf " vfd 2/replace,16/update+zarg+del+force aci "cu " vfd 2/replace,16/copy+update+zarg aci "cud " vfd 2/replace,16/copy+update+zarg+del aci "cudf" vfd 2/replace,16/copy+update+zarg+del+force aci "a " vfd 2/replace,16/append+empty+norig aci "ad " vfd 2/replace,16/append+empty+norig+del aci "adf " vfd 2/replace,16/append+empty+norig+del+force aci "ca " vfd 2/replace,16/copy+append+empty+norig aci "cad " vfd 2/replace,16/copy+append+empty+norig+del aci "cadf" vfd 2/replace,16/copy+append+empty+norig+del+force aci "d " vfd 2/delete,16/0 aci "cd " vfd 2/delete,16/copy aci "x " vfd 2/extract,16/zarg+star aci "xd " vfd 2/extract,16/zarg+star+del aci "xdf " vfd 2/extract,16/zarg+star+del+force aci "xf " vfd 2/extract,16/zarg+star+force aci "t " vfd 2/table,16/star+zarg aci "tl " vfd 2/table,16/long+star+zarg aci "tb " vfd 2/table,16/star+zarg+brief aci "tlb " vfd 2/table,16/long+star+zarg+brief end_table: last_index: vfd 36/(end_table-begin_table)/2 end archive_key_  archive_sort.pl1 07/26/84 1221.7rew 07/26/84 1140.9 116253 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ARCHIVE_SORT - Archive Segment Sorting Program. 9/21/69 - Noel I. Morris Recoded in PL/1 - 1/23/70 Checking for format errors, more rational treatment of other errors, list-insertion code re-arranged, C Garman, 6 Mar 1972. modified by E Stone Jan 1974 to call new version of update_handler_ Modified to call newer update_handler_ 03/29/79 by Steve Herbst Modified to check for error_table_$no_move from hcs_$fs_move_seg 05/16/84 S. Herbst */ archive_sort: as: proc; dcl whoami char(16) aligned static init("archive_sort"); dcl argptr ptr, /* pointer to argument */ arglen fixed bin (17), /* character length of argument */ argument char (arglen) based (argptr), /* template for argument */ argno fixed bin (17), /* number of argument */ (code, udh_code) fixed bin(35), /* error code */ dir char (168) aligned, /* directory path name */ arc_name char(40) aligned, /* Used to build "xx.archive" */ arc_temp_name char(32) aligned init("as_temp_.archive"), comment char(40) aligned, /* Variable for errors during move */ err_str char(8) aligned, /* For specifying type of format error */ c0 char(0) aligned, /* Null string */ bitcnt fixed bin (24), /* archive segment bit count */ stop fixed bin (19), /* length (in words) of archive segment */ inptr ptr, /* pointer to archive segment */ outptr ptr static init(null), /* pointer to temporary segment */ clean fixed bin static init(0), /* flag indicating state of temp seg */ max_entries fixed bin static init(1000), /* Size of arrays below */ (p_array ptr, /* array of archive sub-file pointers */ n_array fixed bin(18)) (0:999), /* array of archive sub-file lengths */ nwords fixed bin(18), /* word count of archive sub-file */ (dirp, entryp) ptr, /* Pointers to character strings */ (p1, p2) ptr, /* temporary sorting pointers */ in_sort fixed bin, /* Abandon sort if unnecessary */ retry fixed bin, /* Counter for re-try of move */ (i, j) fixed bin; /* sorting indices */ dcl move_array(nwords) fixed bin(35) based; /* for PL/I based-array move */ dcl expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin(35)), cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin(35)), cv_dec_check_ entry(char(*) aligned, fixed bin(35), fixed bin(18)), hcs_$initiate_count entry(char(*) aligned, char(*) aligned, char(*) aligned, fixed bin(24), fixed bin, ptr, fixed bin(35)), hcs_$make_seg entry(char(*) aligned, char(*) aligned, char(*) aligned, fixed bin, ptr, fixed bin(35)), hcs_$set_bc_seg entry(ptr, fixed bin(24), fixed bin(35)), hcs_$chname_seg entry(ptr, char(*) aligned, char(*) aligned, fixed bin(35)), hcs_$fs_move_seg entry(ptr, ptr, fixed bin, fixed bin(35)), hcs_$truncate_seg ext entry (ptr, fixed bin, fixed bin(35)), hcs_$terminate_noname ext entry (ptr, fixed bin(35)), update_handler_ entry (char(*) aligned, char(*) aligned, char(*) aligned, bit(36),bit(36),fixed bin(35)), update_handler_$reprotect entry (char(*) aligned, char(*) aligned, bit(36),bit(36),fixed bin(35)), (com_err_, ioa_$rsnnl) entry options(variable); dcl cleanup condition; dcl (addr, addrel, bin, divide, fixed, index, null, rel, substr) builtin; dcl access_switches bit (36), /* returned by update_handler_: BIT saying whether access was forced BIT saying there already was such an ACL term */ old_mode bit (36); /* previous mode if any */ dcl (error_table_$entlong, error_table_$moderr, error_table_$no_move, error_table_$noarg, error_table_$segknown) fixed bin (35) ext; dcl (archive_data_$ident, /* Magic numbers to verify "archive-ness" */ archive_data_$fence) char(8) ext aligned; /* .. */ declare 1 arc_head based aligned, /* archive header declaration */ 2 ident1 char (8), 2 historical char(4), 2 name char (32), 2 dtm char(16), 2 mode char(4), 2 dtu char (20), 2 bitcnt char (8), 2 ident2 char (8); /* Create the temporary segment. */ if outptr = null then do; call hcs_$make_seg (c0, arc_temp_name, c0, 1011b, outptr, code); if outptr = null then do; error_3: call com_err_ (code, whoami, "^R^a^B (in process directory)", arc_temp_name); return; end; if code = error_table_$segknown /* Did segment exist before? */ then go to unclean; /* Left dirty, truncate it */ end; else if clean ^= 0 then do; unclean: call hcs_$truncate_seg(outptr, 0, code); if code ^= 0 then go to error_3; end; clean = 0; /* Clear flag always */ on cleanup call trunc_temp; dirp = addr(dir); entryp = addr(arc_name); /* Pick up arguments to program. */ argno = 1; /* Initialize argument number. */ argument_loop: call cu_$arg_ptr (argno, argptr, arglen, code); /* Grab pointer to argument. */ if code ^= 0 then do; if code = error_table_$noarg then if argno ^= 1 then go to finish; call com_err_(code, whoami); go to finish; end; if arglen = 0 then go to exit; /* .. */ /* Expand the path name. */ call expand_path_(argptr, arglen, dirp, entryp, code); if code ^= 0 then do; /* Expand the name. */ error: call com_err_ (code, whoami, argument); go to exit; end; substr(arc_name, 33, 8) = (8)" "; /* Set blanks after expanded name */ if index(arc_name, ".archive ") = 0 /* Check for ".archive" provided */ then do; /* Not provided, add it, check length */ call ioa_$rsnnl("^a.archive", arc_name, nwords, arc_name); if nwords >= 33 then do; code = error_table_$entlong; go to error; end; end; /* Initiate and get the length of the archive file. */ call hcs_$initiate_count (dir, arc_name, c0, bitcnt, 1, inptr, code); if inptr = null /* Attempt to initiate the segment. */ then do; call com_err_(code, whoami, "^R^a>^a^B", dir, arc_name); go to exit; end; stop = divide (bitcnt + 35, 36, 19, 0); /* Compute word count of segment. */ if stop = 0 then do; call com_err_(0, whoami, "^R^a>^a^B is empty.", dir, arc_name); go to exit_1; end; /* Examine the archive file and perform sort. */ p1 = inptr; /* Set archive pointer to beginning of segment. */ in_sort = 0; /* Initialize flag for file-already-sorted */ do i = 0 by 1 while(fixed(rel(p1), 18) < stop); /* Set loop */ if i = max_entries /* Check for end of loop */ then do; call com_err_(0, whoami, "More than ^d components in ^R^a>^a^B, ^a", (max_entries), dir, arc_name, "Archive not sorted."); go to exit_1; /* Terminate the input seg */ end; if p1 -> arc_head.ident1 ^= archive_data_$ident /* Verify "archive-ness" of header */ then do; err_str = "head "; fmt_err: call com_err_(0, whoami, "Archive format error (^aer) in component ^d: ^R^a>^a^B", err_str, i + 1, dir, arc_name); go to exit_1; /* Terminate the segment */ end; if p1 -> arc_head.ident2 ^= archive_data_$fence /* Check trailer */ then do; err_str = "trail "; go to fmt_err; end; call cv_dec_check_(p1 -> arc_head.bitcnt, code, nwords); /* Convert bit-count in header to binary value. */ if code ^= 0 then do; call com_err_(0, whoami, "Non-numeric characters in bit-count for component ^R^a^B^/ ^R^a>^a^B, ^a", p1 -> arc_head.name, dir, arc_name, "Archive not sorted."); go to exit_1; end; /* Following inner loop compares name of this component with names of previously encountered components in order to find the proper slot for the component. Items are entered into the list in order, higher-sequence items being pushed up on the fly until the appropriate spot is found. Note that first time the loop code will not be executed, since the first item is simultaneously at the beginning and end of the list. */ do j = i to 1 by -1; /* Search list, from high to low. */ p2 = p_array (j-1); /* Get sub-file pointer. */ /* Compare names. Note that ">=" is used, not ">", so that identical entries (which really shouldn't ever be encountered) will not be interchanged; they will always remain in the same relative order. */ if p1 -> arc_head.name >= p2 -> arc_head.name then go to end_loop; /* Insert new info into array */ p_array (j) = p2; /* Current name less than current entry in list, */ n_array (j) = n_array (j-1); /* move this entry up one position */ end; /* If we fall out of loop, current info goes in position 0 of arrays */ end_loop: /* Come here to enter info into proper slot */ if j = i /* If new entry at end of list, ie already in sequence */ then in_sort = in_sort + 1; /* Increment flag */ p_array (j) = p1; /* Place sub-file pointer into correct slot. */ nwords = divide(nwords + 35, 36, 18, 0) + 25; /* Compute number of words in sub-file. */ n_array (j) = nwords; /* Set sub-file length array. */ p1 = addrel (p1, nwords); /* Step to next sub-file. */ end; /* End of per-archive loop, list now in order for creation of sorted temporary */ if in_sort = i /* If all array entries made at top */ then go to exit_1; /* A sordid case, terminate, no message */ stop = bin(rel(p1), 18); /* Re-calculate word-count */ bitcnt = stop * 36; /* and bit-count */ /* Copy each of the archive sub-files in correct order into the temporary segment. */ clean = clean + 1; /* Dirty, dirty, dirty! */ p1 = outptr; /* Now set pointer into output segment. */ do j = 0 by 1 while(j ^= i); /* Process all sub-files. */ nwords = n_array (j); /* Extract the word count. */ p1 -> move_array = p_array(j) -> move_array; /* Copy the sub-file into temporary. */ p1 = addrel (p1, nwords); /* Step the output pointer. */ end; /* Move the temporary back into the archive file. */ retry = 0; /* Clear counter */ try_move: call hcs_$fs_move_seg (outptr, inptr, 1b, code); /* Move the temporary after truncating the original */ if code ^= 0 then do; if code = error_table_$moderr | code = error_table_$no_move /* no write on target? */ then if retry = 0 /* Have we been here before? */ then do; /* OK, try to change mode */ call update_handler_(dir, arc_name, whoami, access_switches, old_mode, udh_code); if udh_code = 0 /* Successful? */ then do; retry = retry + 1; /* Update counter */ go to try_move; /* See if it works this time */ end; else if udh_code = 1 /* He answered "no" */ then code = 0; /* Suppress part of diagnostic */ else code = udh_code; /* Something else, tell him */ go to set_com; /* Print error message */ end; else /* ! */ set_com: comment = ""; else comment = " Original may have been truncated. "; call hcs_$set_bc_seg(outptr, bitcnt, udh_code); /* Make temporary copiable */ call hcs_$chname_seg(outptr, arc_temp_name, arc_name, udh_code); if udh_code = 0 then arc_temp_name = arc_name; /* Successful rename */ outptr = null; /* Re-call makeseg next time. */ call com_err_(code, whoami, "^R^a>^a^B not updated. ^/ ^a ^a^a", dir, arc_name, comment, "Sorted version temporarily preserved in [pd]>", arc_temp_name); go to finish; end; clean = 0; /* Successful fs_move call yields truncated seg */ /* Reset the bit-count on the branch (really shouldn't have changed) */ call hcs_$set_bc_seg(inptr, bitcnt, code); if code ^= 0 then call com_err_(code, whoami, "^R^a>^a^B", dir, arc_name); if retry ^= 0 then call update_handler_$reprotect(dir, arc_name, access_switches, old_mode, code); exit_1: call hcs_$terminate_noname (inptr, code); /* Terminate null reference name. */ if code ^= 0 then call com_err_ (code, whoami, "^R^a>^a^B", dir, arc_name); /* Go back for more. */ exit: argno = argno + 1; /* Increment the argument number. */ go to argument_loop; /* Back for more. */ trunc_temp: proc; /* Cleanup procedure */ if clean ^= 0 then call hcs_$truncate_seg(outptr, 0, (0)); /* Ignore error code */ clean = 0; /* Clear flag, indicates truncated seg */ end trunc_temp; finish: end archive_sort;  archive_star_.pl1 11/04/82 1938.1rew 11/04/82 1619.7 29619 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ archive_star_: proc(dirname,starname,key,argptr,lastarg); /* Procedure used by the archive command to implement the star convention. This procedure is called with the directory name and entryname which is known to contain stars. It uses the star handler to find all the correct names and then calls the archive command to perform the work. The archive segments will be treated in alphabetical order. */ /* 12/6/69 JW Gintell Originally coded as archive_t_star command. 1/27/70,7/15/70 modified 11/18/70 Transformed into archive_star_. 3/9/72 Modified to extend star convention */ dcl dirname char(*); /* directory in which * conventions is to be applied */ dcl starname char(*); dcl key char(*); /* key to be passed back */ dcl argptr ptr; /* pointer to argument list */ dcl lastarg fixed bin; /* count of number of arguments */ dcl (areap,eptr,nptr) ptr init(null), /* used for star handling */ (code,ecount) fixed bin(17), 1 entries(ecount) based(eptr) aligned, /* structure for status call */ 2 type bit(2) unaligned, 2 nname bit(16) unaligned, 2 nindex bit(18) unaligned, word(ecount) based(eptr) bit(36) aligned, /* used for sort */ saveword bit(36), names(n) char(32) aligned based(nptr), archive_name char(168), dirnamel fixed bin(17), n fixed bin(17), (i,j) fixed bin(17); dcl /* external entries */ hcs_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin(17), ptr, ptr, fixed bin(17)), com_err_ entry options(variable), archive$star_entry entry (char(*),char(*),ptr,fixed bin), (get_system_free_area_, freen_) entry(ptr); dcl system_area area(1024) based(areap); dcl cleanup condition; dcl (bin, index, null, substr) builtin; /* */ call get_system_free_area_(areap); /* get area for call to star_ */ on condition(cleanup) call free; call hcs_$star_(dirname, starname, 3 /* branches and links */, areap, ecount, eptr, nptr, code); if code ^= 0 then do; call com_err_(code,"archive","^a>^a",dirname,starname); return; end; do i = 1 to ecount-1; /* sort the names of the segments */ do j = i+1 to 2 by -1 while(names(bin(entries(j-1).nindex, 17)) > names(bin(entries(j).nindex, 17))); saveword = word(j); word(j) = word(j-1); word(j-1) = saveword; end; end; dirnamel = index(dirname," ") - 1; do i = 1 to ecount; /* call archive for each segment */ n = bin(eptr->entries(i).nindex, 17); /* pick out index to name */ archive_name = substr(dirname,1,dirnamel)||">"||names(n); /* build archive name: dir>name */ call archive$star_entry(key,archive_name,argptr,lastarg); end; call free; free: procedure; if eptr^=null then free eptr->entries in(system_area); if nptr^=null then free nptr->names in(system_area); end free; end archive_star_;  archive_table.pl1 04/09/85 1431.5r w 04/08/85 1128.9 109143 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: style4 */ archive_table: act: proc; /* Returns names of archive components matching starnames, or all. Usage: act archive_path {starnames} {-control_args} Usage: [act archive_path {starnames} {-control_args}] where archive_path cannot contain stars, and starnames can. control_arg can be -absolute_pathname (-absp). Coded 08/29/79 S. Herbst */ /* TR7460 Add -absolute_pathname 10/30/80 S. Herbst */ /* TR11457 Have act use archive_ to prevent misbehavior with static storage 01/10/82 L. Baldwin */ /* Added many control arguments 11/30/82 E. N. Kittlitz */ /* Fixed no_star error message 06/17/83 E. N. Kittlitz */ /* Change to use date_time_$format 06/19/84 J A Falksen Fix undocumented bug with -mode output */ /* Fix 2 bugs introduced above. AF output needs rtrim before requote. -absp strings must include "::". 84-11-14 jaf */ dcl area area based (area_ptr); dcl arg char (arg_len) based (arg_ptr); dcl return_arg char (return_len) varying based (return_ptr); dcl starname (starname_count) char (32) based (starname_ptr); dcl archive_string char (168) varying; dcl dn char (168); dcl en char (32); dcl item char (512) varying; dcl date_format char (15) int static options (constant) init ("^_^