lib_access_mode_.pl1 02/15/84 0911.2rew 02/15/84 0749.8 186084 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Name: lib_access_mode_ */ /* */ /* This subroutine is part of the library maintenance tools. It gets and sets the */ /* current user's (person.project.a) access to a given library entry. */ /* */ /* Entry: lib_access_mode_$get */ /* */ /* This entry gets user's access to a given entry. */ /* */ /* Usage */ /* */ /* dcl lib_access_mode_$get entry (ptr, fixed bin(35)); */ /* */ /* call lib_access_mode_$get (Pnode, code); */ /* */ /* where: */ /* 1. Pnode is a pointer to the library node representing the library entry. (In) */ /* 2. code is an error code. (Out) */ /* */ /* Entry: lib_access_mode_$set */ /* */ /* This entry sets the user's access to a given library entry. If necessary, */ /* the user will be given access to the archive, directory, or MSF which contains the */ /* library entry. Links are chased. */ /* */ /* If the user already has sufficient access to meet the requirements of the */ /* requested access mode, then no changes are made. */ /* */ /* Access is granted in such a way that it can be unset, leaving the ACL in its */ /* original state, by call lib_access_mode_$unset. */ /* */ /* Usage */ /* */ /* dcl lib_access_mode_$set (ptr, bit(36) aligned, fixed bin, fixed bin(35)); */ /* */ /* call lib_access_mode_$set (Pnode, new_mode, unset_depth, code); */ /* */ /* where: */ /* 1. Pnode is as above. (In) */ /* 2. new_mode is a bit string describing the required user access. (In) */ /* For directories, the bits represent "sma..."b. */ /* For other entries, the bits represent "rew..."b. */ /* 3. unset_depth defines the depth up or down the library node tree to which access */ /* changes had to be made in order to set the user's access. This */ /* value must be given to lib_access_mode_$unset to properly unset */ /* the access mode. (Out) */ /* 4. code is as above. (Out) */ /* */ /* Entry: lib_access_mode_$unset */ /* */ /* This entry undoes what the $set entry does, so that all ACLs are in their original*/ /* state. */ /* */ /* Usage */ /* */ /* dcl lib_access_mode_$unset (ptr, fixed bin, fixed bin(35)); */ /* */ /* call lib_access_mode_$unset (Pnode, unset_depth, code); */ /* */ /* where: */ /* 1. - 3. are as described above. */ /* */ /* Status: */ /* */ /* 0) Created in June, 1976 by Gary C. Dixon */ /* 1) Modified on October 11, 1983 by Jim Lippard to change all occurrences of */ /* error_table_$invalid_data_format to error_table_$improper_data_format. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ lib_access_mode_: procedure; dcl /* Parameters */ new_mode bit(36) aligned, /* access to node which is required. */ unset_depth fixed bin, /* depth up/down tree to which setting was done. */ code fixed bin(35); /* return code. */ dcl /* Automatic Variables */ Bmode bit(5), /* bit access mode (xrewx, or xsmxa). */ Nmode fixed bin(5), /* binary access mode. */ Pmsf_fcb ptr, /* ptr to msf_manager_ control block. */ Sunset_required bit(1) aligned, /* on if ACL changed during $set call. */ 1 acle aligned, /* segment ACL entry addition structure. */ 2 user char(32), 2 mode bit(36), 2 pad bit(36), 2 code fixed bin(35), 1 del_acle aligned, /* segment ACL entry deletion structure. */ 2 user char(32), 2 code fixed bin(35), dir char(168) varying, /* dir part of node pathname. */ 1 dir_acle aligned, /* directory ACL entry addition structure. */ 2 user char(32), 2 mode bit(36), 2 code fixed bin(35), ent char(32) varying; /* ent part of node pathname. */ dcl /* Built-in Functions and Conditions */ (addr, bit, null, substr) builtin, cleanup condition; dcl /* Entries Called */ get_group_id_ entry returns (char(32)), get_ring_ entry returns (fixed bin(3)), (hcs_$add_acl_entries, hcs_$add_dir_acl_entries, hcs_$delete_acl_entries, hcs_$delete_dir_acl_entries, installation_tools_$add_acl_entries, installation_tools_$delete_acl_entries) entry (char(*), char(*), ptr, fixed bin, fixed bin(35)), hcs_$get_user_effmode entry (char(*), char(*), char(*), fixed bin, fixed bin(5), fixed bin(35)), (hcs_$list_acl, hcs_$list_dir_acl) entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)), lib_node_path_ entry (ptr, char(168) varying, char(32) varying), (msf_manager_$acl_add, msf_manager_$acl_delete) entry (ptr, ptr, fixed bin, fixed bin(35)), msf_manager_$acl_list entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin(35)), msf_manager_$close entry (ptr), msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35)); dcl /* Static Variables */ False bit(1) aligned int static options(constant) init ("0"b), True bit(1) aligned int static options(constant) init ("1"b), (error_table_$improper_data_format, error_table_$link, error_table_$out_of_sequence, error_table_$user_not_found) fixed bin(35) ext static, ring fixed bin int static init (8), user char(32) int static init (""); /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ get: entry (Pnode, code); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* lib_access_mode_$get sets the node.Smode field of input mode current user's access */ /* to the library entry associated with the node. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if user = "" then user = get_group_id_(); /* initialize internal static values. */ if ring = 8 then ring = get_ring_(); code = 0; /* initialize return code. */ if Svalid.mode then; /* if mode already known, return. */ else if node.T = Tlink then do; /* chase links to get associated access mode. */ if Svalid.kids then do; do PDnodes = node.PD repeat Dnodes.Pnext while (Dnodes.header.T ^= Tnodes); end; if Dnodes.N ^= 1 then code = error_table_$link; else do; call get (addr(Dnodes.nodes(1)), code); if code = 0 then do; node.Smode = addr(Dnodes.nodes(1))->node.Smode; Svalid.mode = True; end; end; end; else code = error_table_$link; end; else if node.T = Tarchive_comp then do; /* assoc access to containing archive with comp. */ ARCH_COMP: call get (node.Pparent, code); if code ^= 0 then do; node.Smode = node.Pparent->node.Smode; Svalid.mode = True; end; end; else if node.T = Tarchive & node.offset ^= 0 then /* do same for archived archive. */ go to ARCH_COMP; else do; /* get user's access to the library entry. */ call lib_node_path_ (Pnode, dir, ent); call hcs_$get_user_effmode ((dir), (ent), user, ring, Nmode, code); if code = 0 then do; Bmode = bit(Nmode,5); if node.T = Tdirectory then do; /* for directories: */ substr (node.Smode, 1, 1) = substr (Bmode, 2, 1); substr (node.Smode, 2, 2) = substr (Bmode, 4, 2); end; /* map 'xsxma' into 'sma'. */ else if node.T = Tmsf then do; /* for msfs: */ substr (node.Smode, 1, 1) = substr (Bmode, 2, 1); substr (node.Smode, 2, 1) = "0"b; substr (node.Smode, 3, 1) = substr (Bmode, 4, 1); end; /* map 'xsxma' into 'rxw'. */ else /* for segments: */ substr (node.Smode, 1, 3) = substr (Bmode, 2, 3); /* map 'xrewx' into 'rew'. */ Svalid.mode = True; /* mark access mode as being valid. */ end; end; return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ set: entry (Pnode, new_mode, unset_depth, code); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* lib_access_mode_$set sets the user's access (person.proj.a) to a given library entry */ /* to a specified mode. Information is returned to reverse the setting to the original */ /* ACL contents. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if user = "" then user = get_group_id_(); /* initialize internal static values. */ if ring = 8 then ring = get_ring_(); code = 0; /* initialize return code. */ unset_depth = 0; /* to start with, no unsetting is required. */ set_recurse: entry (Pnode, new_mode, unset_depth, code); if Svalid.mode then; /* get current mode, if not already known. */ else do; call get (Pnode, code); if code ^= 0 then return; end; if (node.Smode & new_mode) = new_mode then /* do nothing if current mode sufficient to meet */ Sunset_required = False; /* user's needs. */ else Sunset_required = True; if Sunset_required then /* cannot set ACL if previously set without unset */ if Svalid.prev_mode then do; code = error_table_$out_of_sequence; Sunset_required = False; end; if Sunset_required then do; /* must take positive action to set the ACL. */ unset_depth = unset_depth + 1; /* indicate taking another step up/down tree. */ if node.T = Tlink then do; /* chase links to set mode. */ if Svalid.kids then do; do PDnodes = node.PD repeat Dnodes.Pnext while (Dnodes.header.T ^= Tnodes); end; if Dnodes.N ^= 1 then code = error_table_$link; else do; call set_recurse (addr(Dnodes.nodes(1)), new_mode, unset_depth, code); if code = 0 then do; node.Smode = addr(Dnodes.nodes(1))->node.Smode; node.Sprev_mode = addr(Dnodes.nodes(1))->node.Sprev_mode; Svalid.mode = addr (addr(Dnodes.nodes(1))->node.Svalid)->Svalid.mode; Svalid.prev_mode = addr (addr(Dnodes.nodes(1))->node.Svalid)->Svalid.prev_mode; end; end; end; else code = error_table_$link; end; else if node.T = Tarchive_comp then do; /* set ACL on containing archive. */ ARCH_COMP_ACL: call set_recurse ((node.Pparent), new_mode, unset_depth, code); if code = 0 then do; node.Smode = node.Pparent->node.Smode; node.Sprev_mode = node.Pparent->node.Sprev_mode; Svalid.mode = addr(node.Pparent->node.Svalid)->Svalid.mode; Svalid.prev_mode = addr(node.Pparent->node.Svalid)->Svalid.prev_mode; end; end; else if node.T = Tarchive & node.offset ^= 0 then go to ARCH_COMP_ACL; /* do same for archived archive. */ else if node.T = Tmsf_comp then /* do same for MSF component (must keep MSF ACL */ go to ARCH_COMP_ACL; /* consistent). */ else do; if node.Pparent ^= null then do; /* make sure we have access to set access. */ call set_recurse ((node.Pparent), "110"b, unset_depth, code); if code ^= 0 then return; end; call lib_node_path_ (Pnode, dir, ent); /* get pathname of entry being considered. */ if node.T = Tsegment then do; /* set segment ACL. */ SEG_ACL: acle.user = user; acle.mode = ""b; acle.pad = ""b; acle.code = 0; call hcs_$list_acl ((dir), (ent), null, null, addr(acle), 1, code); if code ^= 0 then return; if acle.code = error_table_$user_not_found then node.Sprev_mode = node.Smode; /* save user's prev mode, but do NOT mark */ /* prev mode as valid; this is reserved */ /* for prev modes appearing in separate */ /* ACL entry for user. */ else do; node.Sprev_mode = acle.mode; Svalid.prev_mode = True; end; acle.mode = new_mode; acle.code = 0; if node.rb(1) < ring then call installation_tools_$add_acl_entries ((dir), (ent), addr(acle), 1, code); else call hcs_$add_acl_entries ((dir), (ent), addr(acle), 1, code); end; else if node.T = Tdirectory then do; /* set directory ACL. */ dir_acle.user = user; /* get current ACLe applying to person.proj.a */ dir_acle.mode = ""b; dir_acle.code = 0; call hcs_$list_dir_acl ((dir), (ent), null, null, addr(dir_acle), 1, code); if code ^= 0 then return; if dir_acle.code = error_table_$user_not_found then node.Sprev_mode = node.Smode; /* save user's prev mode, but do NOT mark */ /* prev mode as valid; this is reserved */ /* for prev modes appearing in separate */ /* ACL entry for user. */ else do; node.Sprev_mode = dir_acle.mode; Svalid.prev_mode = True; end; dir_acle.mode = new_mode; /* set the new mode. */ dir_acle.code = 0; call hcs_$add_dir_acl_entries ((dir), (ent), addr(dir_acle), 1, code); end; else if node.T = Tarchive then /* most archives can be handled like segments. */ go to SEG_ACL; else if node.T = Tmsf then do; /* set MSF ACL. */ acle.user = user; acle.mode = ""b; acle.pad = ""b; acle.code = 0; Pmsf_fcb = null; on cleanup begin; if Pmsf_fcb ^= null then call msf_manager_$close (Pmsf_fcb); end; call msf_manager_$open ((dir), (ent), Pmsf_fcb, code); if code ^= 0 then return; call msf_manager_$acl_list (Pmsf_fcb, null, null, addr(acle), 1, code); if code ^= 0 then do; call msf_manager_$close (Pmsf_fcb); return; end; if acle.code = error_table_$user_not_found then node.Sprev_mode = node.Smode; /* save user's prev mode, but do NOT mark */ /* prev mode as valid; this is reserved */ /* for prev modes appearing in separate */ /* ACL entry for user. */ else do; node.Sprev_mode = acle.mode; Svalid.prev_mode = True; end; acle.mode = new_mode; acle.code = 0; call msf_manager_$acl_add (Pmsf_fcb, addr(acle), 1, code); call msf_manager_$close (Pmsf_fcb); revert cleanup; end; end; end; return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ unset: entry (Pnode, unset_depth, code); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* lib_access_mode_$unset reverts any access change made by the $set entry point. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if user = "" then user = get_group_id_(); /* initialize internal static values. */ if ring = 8 then ring = get_ring_(); code = 0; /* initialize return values. */ if unset_depth = 0 then return; /* no unsetting required. */ unset_depth = unset_depth - 1; /* for what we are about to do, count it. */ if node.T = Tlink then do; /* link unsetting must be done to link kids. */ if ^Svalid.mode then; /* must have gotten error setting; ignore */ else if ^Svalid.kids then code = error_table_$improper_data_format; else do; do PDnodes = node.PD repeat Dnodes.Pnext while (Dnodes.header.T ^= Tnodes); end; if Dnodes.N = 1 then code = error_table_$improper_data_format; else do; call unset (addr(Dnodes.nodes(1)), unset_depth, code); node.Smode = addr(Dnodes.nodes(1))->node.Smode; node.Sprev_mode = addr(Dnodes.nodes(1))->node.Sprev_mode; Svalid.mode = addr (addr(Dnodes.nodes(1))->node.Svalid)->Svalid.mode; Svalid.prev_mode = addr (addr(Dnodes.nodes(1))->node.Svalid)->Svalid.prev_mode; end; end; end; else do; /* all other unsetting done to node and its parent*/ call lib_node_path_ (Pnode, dir, ent); if node.T = Tsegment then do; /* restore segment ACL */ SEG_ACL_UNSET: if Svalid.prev_mode then do; /* restore previous ACL entry mode. */ acle.user = user; acle.mode = node.Sprev_mode; acle.pad = ""b; acle.code = 0; if node.rb(1) < ring then call installation_tools_$add_acl_entries ((dir), (ent), addr(acle), 1, code); else call hcs_$add_acl_entries ((dir), (ent), addr(acle), 1, code); if code ^= 0 then; else do; Svalid.prev_mode = False; node.Smode = node.Sprev_mode; end; end; else do; /* delete ACL entry for user. */ del_acle.user = user; del_acle.code = 0; if node.rb(1) < ring then call installation_tools_$delete_acl_entries ((dir), (ent), addr(del_acle), 1, code); else call hcs_$delete_acl_entries ((dir), (ent), addr(del_acle), 1, code); if code ^= 0 then; else node.Smode = node.Sprev_mode; end; end; else if node.T = Tdirectory then do; /* restore directory ACL. */ if Svalid.prev_mode then do; /* restore previous ACL entry mode. */ dir_acle.user = user; dir_acle.mode = node.Sprev_mode; dir_acle.code = 0; call hcs_$add_dir_acl_entries ((dir), (ent), addr(dir_acle), 1, code); if code ^= 0 then; else do; Svalid.prev_mode = False; node.Smode = node.Sprev_mode; end; end; else do; /* delete ACL entry for user. */ del_acle.user = user; del_acle.code = 0; call hcs_$delete_dir_acl_entries ((dir), (ent), addr(del_acle), 1, code); if code ^= 0 then; else node.Smode = node.Sprev_mode; end; end; else if node.T = Tarchive then if node.offset > 0 then go to ARCH_ACL_UNSET; else go to SEG_ACL_UNSET; else if node.T = Tarchive_comp then do; /* restore archive component ACL. */ ARCH_ACL_UNSET: call unset ((node.Pparent), unset_depth, code); node.Smode = node.Pparent->node.Smode; node.Sprev_mode = node.Pparent->node.Sprev_mode; Svalid.mode = addr(node.Pparent->node.Svalid)->Svalid.mode; Svalid.prev_mode = addr(node.Pparent->node.Svalid)->Svalid.prev_mode; end; else if node.T = Tmsf then do; /* restore MSF ACL. */ Pmsf_fcb = null; on cleanup begin; if Pmsf_fcb ^= null then call msf_manager_$close (Pmsf_fcb); end; call msf_manager_$open ((dir), (ent), Pmsf_fcb, code); if code ^= 0 then return; if Svalid.prev_mode then do; /* restore previous ACL entry mode. */ acle.user = user; acle.mode = node.Sprev_mode; acle.pad = ""b; acle.code = 0; call msf_manager_$acl_add (Pmsf_fcb, addr(acle), 1, code); if code ^= 0 then; else do; Svalid.prev_mode = False; node.Smode = node.Sprev_mode; end; end; else do; /* delete ACL entry for user. */ del_acle.user = user; del_acle.code = 0; call msf_manager_$acl_delete (Pmsf_fcb, addr(del_acle), 1, code); if code ^= 0 then; else node.Smode = node.Sprev_mode; end; call msf_manager_$close (Pmsf_fcb); revert cleanup; end; else if node.T = Tmsf_comp then go to ARCH_ACL_UNSET; /* unset MSF acl for MSF components. */ if code = 0 then if unset_depth > 0 then call unset ((node.Pparent), unset_depth, code); end; return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ %include lib_node_; end lib_access_mode_;  lib_args_.pl1 02/11/86 1611.4rew 02/11/86 1609.7 265788 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(83-10-24,Lippard), approve(), audit(), install(): add -page_length, -all_matches, and -first_match options 2) change(86-01-15,GDixon), approve(86-02-06,MCR7338), audit(86-02-06,Lippard), install(86-02-11,MR12.0-1016): A) Fix bugs in handling of -pn control arg. B) Add standard short names to many control args. END HISTORY COMMENTS */ lib_args_: procedure (LIBRARY, STARNAME, EXCLUDE, Srequirements, Scontrol, Parg_struc, Acode); dcl /* Parameters */ Acode fixed bin(35); /* a status code. (Out) */ dcl /* Automatic variables */ Larg fixed bin, /* length of control argument. */ Loperand fixed bin, /* length of control argument operand. */ PSname ptr, /* ptr to switch for name table which overflowed. */ PSreq ptr, /* ptr to a set of requirements switches. */ Parg ptr, /* ptr to control argument. */ Poperand ptr, /* ptr to control argument operand. */ Sallowed bit(1) aligned, /* on if ctl arg requiring operand is allowed. */ Slib bit(1) aligned, /* on if TOO_MANY_LIBS msg already printed once. */ Scontrol_disallowed bit(36) aligned, /* control bits which may NOT be set. */ Srequirements_disallowed bit(72) aligned, /* rqeuirements bits which may NOT be set. */ 1 bad_library like LIBRARY, /* storage for bad library names. */ code fixed bin(35), /* an error table code. */ i fixed bin, /* number of input argument being processed. */ j fixed bin, /* index of found control arg in keyword table. */ Sstar bit(1) aligned, /* on if TOO_MANY_STAR msg already printed once. */ name_type char(7) aligned, /* type of name table which has overflowed. */ names_allowed fixed bin; /* number of names allowed in overflowing table. */ dcl /* Based Variables */ Sname bit(1) aligned based(PSname), /* on if corresponding name table ovfl msg printed*/ 1 Sreq aligned like Svalid_req based(PSreq), /* requirements switches. */ arg char(Larg) based(Parg), /* a control argument. */ operand char(Loperand) based(Poperand); /* a control argument operand. */ dcl /* Built-in Functions and Conditions */ (addr, convert, dimension, max, string, substr) builtin, conversion condition; dcl /* Entries Called */ check_star_name_$entry entry (char(*), fixed bin(35)), cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin(35), ptr), lib_descriptor_$validate_library entry (char(168) varying, ptr, ptr, fixed bin(35)), lib_error_list_ entry (char(32) varying, ptr, char(32) varying); dcl /* Static Variables */ 1 Sc_req int static aligned, /* relationship between requirements and control */ 2 acl bit(72) init(""b), /* switches. */ 2 iacl bit(72), 2 object_info bit(72), 2 check_ascii bit(72), 2 check_archive bit(72), 2 all_status bit(72), 2 quota bit(72), False bit(1) aligned int static options(constant) init ("0"b), True bit(1) aligned int static options(constant) init ("1"b), (error_table_$bad_arg, error_table_$badstar, error_table_$too_many_names, error_table_$unimplemented_version, error_table_$wrong_no_of_args) fixed bin(35) ext static; dcl keyword (66) char (30) varying int static options(constant) init ( "-access ", /* 1 */ "-access_class ", /* 2 */ "-acl ", /* 3 */ "-all ", /* 4 */ "-all_matches ", /* 5 */ "-author ", /* 6 */ "-bit_count ", /* 7 */ "-brief ", /* 8 */ "-chase ", /* 9 */ "-compiler_name ", /* 10 */ "-compiler_options ", /* 11 */ "-compiler_version ", /* 12 */ "-components ", /* 13 */ "-container ", /* 14 */ "-contents ", /* 15 */ "-copy ", /* 16 */ "-cross_reference ", /* 17 */ "-current_length ", /* 18 */ "-date ", /* 19 */ "-date_time_compiled ", /* 20 */ "-date_time_dumped ", /* 21 */ "-date_time_entry_modified ", /* 22 */ "-date_time_contents_modified ", /* 23 */ "-date_time_used ", /* 24 */ "-default ", /* 25 */ "-delete ", /* 26 */ "-descriptor ", /* 27 */ "-device ", /* 28 */ "-entry ", /* 29 */ "-error ", /* 30 */ "-first_match ", /* 31 */ "-footer ", /* 32 */ "-header ", /* 33 */ "-initial_acl ", /* 34 */ "-into ", /* 35 */ "-length ", /* 36 */ "-level ", /* 37 */ "-library ", /* 38 */ "-link_target ", /* 39 */ "-list ", /* 40 */ "-long ", /* 41 */ "-match ", /* 42 */ "-max_length ", /* 43 */ "-mode ", /* 44 */ "-name ", /* 45 */ "-new_line ", /* 46 */ "-no_chase ", /* 47 */ "-no_cross_reference ", /* 48 */ "-non_ascii ", /* 49 */ "-object_info ", /* 50 */ "-offset ", /* 51 */ "-omit ", /* 52 */ "-output_file ", /* 53 */ "-page_length ", /* 54 */ "-pathname ", /* 55 */ "-primary ", /* 56 */ "-quota ", /* 57 */ "-records ", /* 58 */ "-retain ", /* 59 */ "-ring_brackets ", /* 60 */ "-safety ", /* 61 */ "-search_name ", /* 62 */ "-status ", /* 63 */ "-time ", /* 64 */ "-type ", /* 65 */ "-unique_id "); /* 66 */ dcl key_ab (47) char(6) int static options(constant) init ( "-acc ", /* 2 */ "-a ", /* 4 */ "-amch ", /* 5 */ "-at ", /* 6 */ "-bc ", /* 7 */ "-bf ", /* 8 */ "-comp ", /* 13 */ "-cont ", /* 14 */ "-cp ", /* 16 */ "-cref ", /* 17 */ "-dt ", /* 19 */ "-dtc ", /* 20 */ "-dtd ", /* 21 */ "-dtem ", /* 22 */ "-dtcm ", /* 23 */ "-dtu ", /* 24 */ "-dft ", /* 25 */ "-dl ", /* 26 */ "-desc ", /* 27 */ "-dv ", /* 28 */ "-et ", /* 29 */ "-fmch ", /* 31 */ "-fo ", /* 32 */ "-he ", /* 33 */ "-iacl ", /* 34 */ "-ln ", /* 36 */ "-lev ", /* 37 */ "-lb ", /* 38 */ "-ls ", /* 40 */ "-lg ", /* 41 */ "-ml ", /* 43 */ "-md ", /* 44 */ "-nm ", /* 45 */ "-nl ", /* 46 */ "-ncref", /* 48 */ "-ofs ", /* 51 */ "-of ", /* 53 */ "-pl ", /* 54 */ "-pn ", /* 55 */ "-pri ", /* 56 */ "-rec ", /* 58 */ "-ret ", /* 59 */ "-rb ", /* 60 */ "-st ", /* 63 */ "-tm ", /* 64 */ "-tp ", /* 65 */ "-uid "); /* 66 */ dcl key_ab_for_key_no (47) fixed bin int static options(constant) init ( /* -acc */ 2, /* -a */ 4, /* -amch */ 5, /* -at */ 6, /* -bc */ 7, /* -bf */ 8, /* -comp */ 13, /* -cont */ 14, /* -cp */ 16, /* -cref */ 17, /* -dt */ 19, /* -dtc */ 20, /* -dtd */ 21, /* -dtem */ 22, /* -dtcm */ 23, /* -dtu */ 24, /* -dft */ 25, /* -dl */ 26, /* -desc */ 27, /* -dv */ 28, /* -et */ 29, /* -fmch */ 31, /* -fo */ 32, /* -he */ 33, /* -iacl */ 34, /* -ln */ 36, /* -lev */ 37, /* -lb */ 38, /* -ls */ 40, /* -lg */ 41, /* -ml */ 43, /* -md */ 44, /* -nm */ 45, /* -nl */ 46, /* -ncref */ 48, /* -ofs */ 51, /* -of */ 53, /* -pl */ 54, /* -pn */ 55, /* -pri */ 56, /* -rec */ 58, /* -ret */ 59, /* -rb */ 60, /* -st */ 63, /* -tm */ 64, /* -tp */ 65, /* -uid */ 66); /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ if Sc_req.acl = ""b then do; /* initialize requirements which force given */ PSreq = addr(Sc_req.acl); /* Scontrol bits on. */ Sreq.acl = True; PSreq = addr(Sc_req.iacl); string(Sreq) = ""b; Sreq.iacl = True; PSreq = addr(Sc_req.object_info); string(Sreq) = ""b; Sreq.compiler_name = True; Sreq.compiler_options = True; Sreq.compiler_version = True; Sreq.dtc = True; Sreq.object_info = True; PSreq = addr(Sc_req.check_ascii); string(Sreq) = ""b; Sreq.not_ascii = True; PSreq = addr(Sc_req.check_archive); /* all of these bits must be on in Srequirements */ string(Sreq) = ""b; Sreq.compiler_name = True; /* to cause Sc.check_archive to be turned on. */ Sreq.compiler_options = True; Sreq.compiler_version = True; Sreq.dtc = True; Sreq.entry_bound = True; Sreq.not_ascii = True; Sreq.object_info = True; PSreq = addr(Sc_req.all_status); string(Sreq) = ""b; Sreq.aim = True; Sreq.access_class = True; Sreq.author = True; Sreq.bit_count_author = True; Sreq.entry_bound = True; PSreq = addr(Sc_req.quota); string(Sreq) = ""b; Sreq.quota = True; end; Acode = 0; if arg_struc.version ^= Varg_struc_1 then go to BAD_ARG_STRUC; if ^Sc_init.descriptor then arg_struc.descriptor = ""; /* initialize argument-holding variables. */ if ^Sc_init.footing then arg_struc.footing = ""; if ^Sc_init.heading then arg_struc.heading = ""; if ^Sc_init.output_file then arg_struc.output_file = ""; if ^Sc_init.page_length then arg_struc.page_length = 0; if ^Sc_init.into_path then arg_struc.into_path = ""; if ^Sc_init.time then arg_struc.time = 0; if ^Sc_init.search_names then STARNAME.N = 0; if ^Sc_init.library then LIBRARY.N = 0; EXCLUDE.N = 0; Srequirements = arg_struc.Srequirements_initial; Scontrol = arg_struc.Scontrol_initial; Sc.descriptor = False; Sc.footing = False; Sc.heading = False; Sc.output_file = False; Sc.page_length = False; Sc.into_path = False; Sc.search_names = False; Sc.library = False; Sc.time = False; Poperand = addr(Poperand); /* initialize operand to a null string for use */ Loperand = 0; /* in error messages. */ Slib = False; Sstar = False; Srequirements_disallowed = ^arg_struc.Srequirements_allowed; Scontrol_disallowed = ^arg_struc.Scontrol_allowed; do i = arg_struc.Iarg_list to arg_struc.Larg_list; call cu_$arg_ptr_rel (i, Parg, Larg, code, arg_struc.Parg_list); /* get the argument. */ if substr (arg, 1, 1) = "-" then; /* if argument is not a control argument, it must */ else do; /* be a star name. */ Poperand = Parg; Loperand = Larg; Larg = 0; if Sc_allowed.search_names then go to SET_STARNAME; else go to SET_LIBNAME; end; do j = 1 to dimension (key_ab, 1) while (arg ^= key_ab(j)); end; if j > dimension (key_ab, 1) then do; do j = 1 to dimension (keyword, 1) while (arg ^= keyword(j)); end; if j > dimension (keyword, 1) then go to BAD_OPT; end; else j = key_ab_for_key_no (j); go to KEY(j); /* if arg is a valid keyword, process it. */ KEY(27): Sallowed = Sc_allowed.descriptor; /* if this is a keyword which requires an operand,*/ go to GET_OPERAND; KEY(32): Sallowed = Sc_allowed.footing; /* then get the next argument. */ go to GET_OPERAND; KEY(33): Sallowed = Sc_allowed.heading; go to GET_OPERAND; KEY(35): Sallowed = Sc_allowed.into_path; go to GET_OPERAND; KEY(38): Sallowed = Sc_allowed.library; go to GET_OPERAND; KEY(53): Sallowed = Sc_allowed.output_file; go to GET_OPERAND; KEY(54): Sallowed = Sc_allowed.page_length; go to GET_OPERAND; KEY(62): Sallowed = Sc_allowed.search_names; go to GET_OPERAND; KEY(64): Sallowed = Sc_allowed.time; go to GET_OPERAND; GET_OPERAND: if i = arg_struc.Larg_list then /* See if there's another arg. It's expected. */ if Sallowed then go to MISSING_ARG; else go to BAD_OPT; i = i + 1; call cu_$arg_ptr_rel (i, Poperand, Loperand, code, arg_struc.Parg_list); /* get the next arg. */ if ^Sallowed then go to BAD_OPT; go to KEY_OPERAND(j); /* process it. */ KEY(1): S.mode = True; /* -access (all access attributes required) */ S.rb = True; S.acl = True; Sc.acl = True; S.iacl = True; Sc.iacl = True; S.access_class = True; S.aim = True; S.entry_bound = True; S.safety = True; Sc.all_status = True; go to NEXT_ARG; KEY(2): S.access_class = True; /* -access_class */ S.aim = True; Sc.all_status = True; go to NEXT_ARG; KEY(3): S.acl = True; /* -acl */ Sc.acl = True; go to NEXT_ARG; KEY(4): Srequirements = arg_struc.Srequirements_allowed; if (Srequirements & Sc_req.acl) then /* -all or -a (set all requirements on). */ Sc.acl = True; if (Srequirements & Sc_req.iacl) then Sc.iacl = True; if (Srequirements & Sc_req.object_info) then Sc.object_info = True; if (Srequirements & Sc_req.check_ascii) then Sc.check_ascii = True; if ((Srequirements & Sc_req.check_archive) = Sc_req.check_archive) then Sc.check_archive = True; if (Srequirements & Sc_req.all_status) then Sc.all_status = True; if (Srequirements & Sc_req.quota) then Sc.quota = True; go to NEXT_ARG; KEY(5): Sc.first_match = False; /* -all_matches or -amch */ go to NEXT_ARG; KEY(6): S.author = True; /* -author or -at */ S.bit_count_author = True; Sc.all_status = True; go to NEXT_ARG; KEY(7): S.bit_count = True; /* -bit_count or -bc */ S.msf_indicator = True; go to NEXT_ARG; KEY(8): Sc.long = False; /* -brief or -bf */ go to NEXT_ARG; KEY(9): Sc.chase = True; /* -chase (links should be chased). */ go to NEXT_ARG; KEY(10): S.compiler_name = True; /* -compiler_name */ Sc.object_info = True; go to NEXT_ARG; KEY(11): S.compiler_options = True; /* -compiler_options */ Sc.object_info = True; go to NEXT_ARG; KEY(12): S.compiler_version = True; /* -compiler_version */ Sc.object_info = True; go to NEXT_ARG; KEY(13): Sc.components = True; /* -components or -comp (print all nodes below a */ go to NEXT_ARG; /* parent node) */ KEY(14): Sc.container = True; /* -container or -cont (print parent nodes) */ go to NEXT_ARG; KEY(15): S.dtc = True; /* -contents (description of entry contents */ S.compiler_version = True; /* is required). */ S.compiler_name = True; S.compiler_options = True; S.object_info = True; Sc.object_info = True; S.not_ascii = True; Sc.check_ascii = True; S.entry_bound = True; Sc.all_status = True; Sc.check_archive = True; go to NEXT_ARG; KEY(16): S.copy = True; /* -copy or -cp (copy switch setting reqd). */ go to NEXT_ARG; KEY(17): S.cross_ref = True; /* -cross_reference or -cref. */ go to NEXT_ARG; KEY(18): S.current_length = True; /* -current_length */ go to NEXT_ARG; KEY(19): S.dtm = True; /* -date or -dt (all storage system dates reqd). */ S.dtu = True; S.dtem = True; S.dtd = True; S.dtc = True; Sc.object_info = True; go to NEXT_ARG; KEY(20): S.dtc = True; /* -date_time_compiled or -dtc */ Sc.object_info = True; go to NEXT_ARG; KEY(21): S.dtd = True; /* -date_time_dumped or -dtd */ go to NEXT_ARG; KEY(22): S.dtem = True; /* -date_time_entry_modified or -dtem */ go to NEXT_ARG; KEY(23): S.dtm = True; /* -date_time_contents_modified or -dtcm */ go to NEXT_ARG; KEY(24): S.dtu = True; /* -date_time_used or -dtu */ go to NEXT_ARG; KEY(25): Sc.default = True; /* -default or -dft (default info required for */ go to NEXT_ARG; /* each entry, according to library search pgm,*/ /* in addition to info reqd by control args). */ KEY(26): Sc.delete = True; /* -delete of -dl (Library entries to be deleted)*/ go to NEXT_ARG; KEY_OPERAND(27): arg_struc.descriptor = operand; /* -descriptor or -desc (use other than */ Sc.descriptor = True; /* default library descriptor.) */ go to NEXT_ARG; KEY(28): S.lvid = True; /* -device or -dv */ go to NEXT_ARG; KEY(29): Sc.components = False; /* -entry or -et (info about parent or component */ Sc.container = False; /* of matching library entry is not required). */ go to NEXT_ARG; KEY(30): S.kids_error = True; /* -error (errors obtaining descendant */ go to NEXT_ARG; /* nodes required). */ KEY(31): Sc.first_match = True; /* -first_match or -fmch */ go to NEXT_ARG; KEY_OPERAND(32): arg_struc.footing = operand; /* -footer or -fo (set value of footing). */ Sc.footing = True; go to NEXT_ARG; KEY_OPERAND(33): arg_struc.heading = operand; /* -header or -he (set value of heading line.) */ Sc.heading = True; go to NEXT_ARG; KEY(34): S.iacl = True; /* -initial_acl or -iacl */ Sc.iacl = True; go to NEXT_ARG; KEY_OPERAND(35): arg_struc.into_path = operand; /* -into (path into which entries are fetched). */ Sc.into_path = True; go to NEXT_ARG; KEY(36): S.records_used = True; /* -length or -ln (all lengths required). */ S.current_length = True; S.bit_count = True; S.msf_indicator = True; S.offset = True; S.max_length = True; S.quota = True; Sc.quota = True; go to NEXT_ARG; KEY(37): S.level = True; /* -level or -lev (level number to precede each */ go to NEXT_ARG; /* entry). */ KEY_OPERAND(38): /* -library or -lb; store library name. */ SET_LIBNAME: if ^Sc.library then do; LIBRARY.N = 0; /* user wants to override initial value. */ Sc.library = True; end; if LIBRARY.N = dimension(LIBRARY.group,1) then go to TOO_MANY_LIBS; LIBRARY.N = LIBRARY.N + 1; LIBRARY.V(LIBRARY.N) = operand; call check_star_name_$entry (operand, code); if code = error_table_$badstar then do; LIBRARY.N = LIBRARY.N - 1; go to BAD_LIB; /* make sure library name has proper format. */ end; else LIBRARY.C(LIBRARY.N) = code; if LIBRARY.C(LIBRARY.N) = 2 then do; /* if star name is **, make it first name. */ if LIBRARY.C(1) = 2 then LIBRARY.N = max(LIBRARY.N - 1, 1); else do; /* 1st name not already **; swap with Nth name. */ LIBRARY.V(LIBRARY.N) = LIBRARY.V(1); LIBRARY.C(LIBRARY.N) = LIBRARY.C(1); LIBRARY.V(1) = operand; LIBRARY.C(1) = 2; end; end; go to NEXT_ARG; KEY(39): S.link_target = True; /* -link_target */ go to NEXT_ARG; KEY(40): Sc.list = True; /* -list or -ls (Library entries subject to */ go to NEXT_ARG; /* cleanup are to be listed.) */ KEY(41): Sc.long = True; /* -long or -lg */ go to NEXT_ARG; KEY(42): S.matching_names = True; /* -match (all matching names required). */ go to NEXT_ARG; KEY(43): S.max_length = True; /* -max_length or -ml */ go to NEXT_ARG; KEY(44): S.mode = True; /* -mode or -md */ go to NEXT_ARG; KEY(45): S.names = True; /* -name or -nm */ go to NEXT_ARG; KEY(46): S.new_line = True; /* -new_line or -nl (new-line char to separate */ go to NEXT_ARG; /* major entries. */ KEY(47): Sc.chase = False; /* -no_chase */ go to NEXT_ARG; KEY(48): S.cross_ref = False; /* -no_cross_reference or -ncref */ go to NEXT_ARG; KEY(49): S.not_ascii = True; /* -non_ascii (check for non-ascii segment */ Sc.check_ascii = True; /* required). */ go to NEXT_ARG; KEY(50): S.object_info = True; /* -object_info (other compiler attributes */ Sc.object_info = True; /* required). */ go to NEXT_ARG; KEY(51): S.offset = True; /* -offset or -ofs (offset of archive comps reqd).*/ go to NEXT_ARG; KEY(52): Sc.retain = False; /* -omit (don't retain entries awaiting deletion).*/ go to NEXT_ARG; KEY_OPERAND(53): arg_struc.output_file = operand; /* -output_file or -of */ Sc.output_file = True; go to NEXT_ARG; KEY_OPERAND(54): /* -page_length or -pl */ on conversion go to BAD_TIME; arg_struc.page_length = convert(arg_struc.page_length, operand); revert conversion; if arg_struc.page_length < 10 | arg_struc.page_length > 120 then go to BAD_TIME; go to NEXT_ARG; KEY(55): S.pathname = True; /* -pathname or -pn */ go to NEXT_ARG; KEY(56): S.primary_name = True; /* -primary or -pri */ go to NEXT_ARG; KEY(57): S.quota = True; /* -quota */ Sc.quota = True; go to NEXT_ARG; KEY(58): S.records_used = True; /* -records or -rec */ go to NEXT_ARG; KEY(59): Sc.retain = True; /* -retain or -ret (keep nodes awaiting deletion).*/ go to NEXT_ARG; KEY(60): S.rb = True; /* -ring_brackets or -rb */ S.entry_bound = True; Sc.all_status = True; go to NEXT_ARG; KEY(61): S.safety = True; /* -safety */ go to NEXT_ARG; KEY_OPERAND(62): /* -search_name (arg which follows looks */ SET_STARNAME: /* like a keyword, but is really a star name. */ if ^Sc.search_names then do; STARNAME.N = 0; Sc.search_names = True; end; else if STARNAME.N = 1 then /* if a star name of ** has been encountered */ if STARNAME.C(1) = 2 then /* previously, ignore all other star names. */ go to NEXT_ARG; if STARNAME.N = dimension (STARNAME.group,1) then go to TOO_MANY_STAR; STARNAME.N = STARNAME.N + 1; STARNAME.V(STARNAME.N) = operand; call check_star_name_$entry (operand, code); if code = error_table_$badstar then do; STARNAME.N = STARNAME.N - 1; go to BAD_STAR; /* make sure starname name has proper format. */ end; else STARNAME.C(STARNAME.N) = code; if STARNAME.C(STARNAME.N) = 2 then do; /* if this starname is **, then ignore all other */ STARNAME.N = 1; /* star names, and use only this one. */ STARNAME.V(1) = operand; STARNAME.C(1) = 2; end; go to NEXT_ARG; KEY(63): S.primary_name = True; /* -status (all info given by status -all). */ S.matching_names = True; S.kids = True; S.kids_error = True; S.type = True; S.copy = True; S.unique_id = True; S.dtem = True; S.dtd = True; S.dtm = True; S.dtu = True; S.link_target = True; S.records_used = True; S.current_length = True; S.msf_indicator = True; S.bit_count = True; S.offset = True; S.lvid = True; S.max_length = True; S.author = True; S.bit_count_author = True; Sc.all_status = True; go to NEXT_ARG; KEY_OPERAND(64): Sc.time = True; on conversion go to BAD_TIME; /* -time NN or -tm NN */ arg_struc.time = convert(arg_struc.time, operand); revert conversion; if arg_struc.time < 0 then go to BAD_TIME; go to NEXT_ARG; KEY(65): S.type = True; /* -type or -tp */ go to NEXT_ARG; KEY(66): S.unique_id = True; /* -unique_id or -uid */ go to NEXT_ARG; BAD_TIME: revert conversion; go to BAD_OPT; NEXT_ARG: if Srequirements & Srequirements_disallowed then do; Srequirements = Srequirements & arg_struc.Srequirements_allowed; BAD_OPT: code = error_table_$bad_arg; BAD_LIB: BAD_STAR: call arg_struc.put_error (code, arg_struc.program, " ^a ^a", arg, operand); if Acode = 0 then Acode = code; end; else if Scontrol & Scontrol_disallowed then do; Scontrol = Scontrol & arg_struc.Scontrol_allowed; go to BAD_OPT; end; Loperand = 0; go to END_LOOP; MISSING_ARG: call arg_struc.put_error (error_table_$wrong_no_of_args, arg_struc.program, " The ^a control argument requires an operand.", arg); if Acode = 0 then Acode = error_table_$wrong_no_of_args; go to END_LOOP; TOO_MANY_LIBS: name_type = "Library"; names_allowed = dimension(LIBRARY.group, 1); PSname = addr(Slib); go to TOO_MANY; TOO_MANY_STAR: name_type = "Search"; names_allowed = dimension(STARNAME.group, 1); PSname = addr(Sstar); TOO_MANY: if Sname then call arg_struc.put_error (error_table_$too_many_names, arg_struc.program, " ^a name ^a ^a ignored.", name_type, arg, operand); else do; Sname = True; call arg_struc.put_error (error_table_$too_many_names, arg_struc.program, " ^a name storage exceeded; only ^d names can be given. ^a ^a ignored.", name_type, names_allowed, arg, operand); if Acode = 0 then Acode = error_table_$too_many_names; end; go to END_LOOP; END_LOOP: end; /* mark args requiring operand as present if */ /* arg given, or if default value given. */ Sc.descriptor = Sc.descriptor | Sc_init.descriptor; Sc.footing = Sc.footing | Sc_init.footing; Sc.heading = Sc.heading | Sc_init.heading; Sc.output_file = Sc.output_file | Sc_init.output_file; Sc.page_length = Sc.page_length | Sc_init.page_length; Sc.into_path = Sc.into_path | Sc_init.into_path; Sc.search_names = Sc.search_names | Sc_init.search_names; Sc.library = Sc.library | Sc_init.library; Sc.time = Sc.time | Sc_init.time; if LIBRARY.N > 0 then do; /* validate the library names. */ call lib_descriptor_$validate_library (arg_struc.descriptor, addr(LIBRARY), addr(bad_library), code); if bad_library.N > 0 then do; call arg_struc.put_error (error_table_$bad_arg, arg_struc.program, " Library descriptor '^a' does not define the", arg_struc.descriptor); call lib_error_list_ ("library name", addr(bad_library), arg_struc.program); if Acode = 0 then Acode = error_table_$bad_arg; end; else if code ^= 0 then do; call arg_struc.put_error (code, arg_struc.program, " While accessing library descriptor: ^a ", arg_struc.descriptor); if Acode = 0 then Acode = code; end; else if LIBRARY.C(1) = 2 then LIBRARY.N = 1; /* If ** given as library name, ignore all others.*/ end; return; BAD_ARG_STRUC: call arg_struc.put_error (error_table_$unimplemented_version, "lib_args_", " Version ^d of the library argument structure is not supported.", arg_struc.version); code = error_table_$unimplemented_version; %include lib_arg_struc_; %include lib_Svalid_req_; %include lib_Scontrol_; end lib_args_;  lib_descriptor_.pl1 02/15/84 0911.2rew 02/15/84 0750.0 236574 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* NAME: lib_descriptor_ */ /* */ /* THis procedure interfaces between the various library maintenance tools and the */ /* library status gathering subroutines by mapping user-supplied (or default) library */ /* names into the pathnames of library directories or archives to be searched. It */ /* also provides a pre-defined, per-library search procedure to find library entries. */ /* */ /* ENTRIES: $info, $map, $print, $fetch, $cleanup */ /* */ /* These entries are provided to support the five basic library maintenance tools, */ /* library_info, library_map, library_print, library_fetch, and library_cleanup. All */ /* perform the same basic function of gathering library status; however, this status */ /* gathering operation often differs in depth of search, cross-referencing, default info */ /* returned, etc between the different library tools. */ /* */ /* ENTRIES: $name, $set_name */ /* */ /* These entries return and set the name of the library descriptor which is used */ /* by default to do the name mapping, etc. The initial default value is the */ /* multics_libraries_ library descriptor. */ /* */ /* ENTRY: $default_values */ /* */ /* This entry returns information about the default library names and search names */ /* which are used by the various library tools. */ /* */ /* ENTRIES: $libraries, $validate_library */ /* */ /* These entries return information about the libraries defined in a given library */ /* descriptor, and validate the correctness of library names with respect to a given */ /* library descriptor. */ /* */ /* STATUS */ /* */ /* 0) Created on: March 1, 1975 by G. C. Dixon */ /* 1) Modified on: May 25, 1976 by G. C. Dixon */ /* a) Use new library descriptor format provided by library_descriptor_compiler, */ /* Version 3.0. */ /* 2) Modified on: January 18, 1984 by Jim Lippard to add n_found */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ lib_descriptor_: procedure; dcl /* parameters */ Adescriptor char(168) varying; /* name of a library descriptor. (In/Out) */ %include lib_based_args_; dcl 1 bad_library based (Pbad_library), 2 N fixed bin, 2 group (0 refer (bad_library.N)) like library.group, Pbad_library ptr, ASrequirements bit(72) aligned, /* requirement switches. (In) */ AScontrol bit(36) aligned, /* control switches. (In) */ Parea ptr, /* ptr to area in which status tree is to be */ /* allocated. (In) */ Acommand fixed bin, /* index of a command using the descriptor. (In) */ Acommand_name char(32), /* name of command using the descriptor. (Out) */ ASunsupported bit(1) unal, /* on if command is not supported by the */ /* specified descriptor. (Out) */ Ptree ptr, /* ptr to status tree. (Out) */ progress fixed bin, /* integer identifying progress of search. (Out) */ Acode fixed bin(35); /* a status code. (Out) */ dcl /* automatic variables */ Nnodes fixed bin, /* = dimension (root node array of status tree) */ Pnodes ptr, /* = addr (root node array of status tree) */ Prt ptr, /* = addr (rt). */ Sfound bit(1) aligned, /* switch: on if library found. */ code fixed bin(35), /* a status code. */ (i, j, k) fixed bin; /* do group indices. */ dcl 1 command_info aligned, /* info passed to search routine */ 2 command fixed bin, /* index of command referencing descriptor. */ 2 n_found fixed bin; /* number of entries found */ dcl /* based variables */ area area based (Parea), /* an allocation area. */ 1 rt like root based (Prt); /* overlay for a root. */ dcl /* builtin functions */ (addr, addrel, dimension, length, min, null, substr) builtin; dcl /* entries */ cu_$decode_entry_value entry (entry, ptr, ptr), cv_entry_ entry (char(*), ptr, fixed bin(35)) returns (entry), lib_free_node_$array entry (ptr), lib_get_tree_$root_array entry (fixed bin, ptr, ptr, fixed bin(35)), lib_get_tree_$root_array_info entry (ptr, fixed bin, fixed bin(35)), lib_get_tree_$lib_root_node entry (ptr, fixed bin, char(168) varying, char(65) varying, ptr, ptr, bit(72) aligned, bit(36) aligned, ptr, entry, ptr, ptr, fixed bin, fixed bin(35)), match_star_name_ entry (char(*), char(*), fixed bin(35)); dcl /* static variables */ 1 defaultP aligned like P int static, /* pointers to the aggregates of the default */ /* library descriptor. */ (error_table_$name_not_found, error_table_$noarg, error_table_$nomatch, error_table_$out_of_bounds, error_table_$process_stopped, error_table_$request_not_recognized, error_table_$unimplemented_version) fixed bin(35) ext static, first_call bit(1) aligned int static init ("1"b), /* switch: on if lib_descriptor_ has not been */ /* referenced in this process before. */ multics_libraries_$descriptor fixed bin ext static, /* first word of the initial default library */ /* descriptor. */ 1 zero_names int static options(constant), /* an empty name structure. */ 2 N fixed bin init(0); /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ info: entry (Adescriptor, Plibrary, Pstarname, Pexclude, ASrequirements, AScontrol, Parea, Ptree, progress, Acode); command_info.command = library_info; go to common; map: entry (Adescriptor, Plibrary, Pstarname, Pexclude, ASrequirements, AScontrol, Parea, Ptree, progress, Acode); command_info.command = library_map; go to common; print: entry (Adescriptor, Plibrary, Pstarname, Pexclude, ASrequirements, AScontrol, Parea, Ptree, progress, Acode); command_info.command = library_print; go to common; fetch: entry (Adescriptor, Plibrary, Pstarname, Pexclude, ASrequirements, AScontrol, Parea, Ptree, progress, Acode); command_info.command = library_fetch; go to common; cleanup: entry (Adescriptor, Plibrary, Pstarname, Pexclude, ASrequirements, AScontrol, Parea, Ptree, progress, Acode); command_info.command = library_cleanup; go to common; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* _p_r_o_g_r_e_s_s */ /* */ /* 1) If the user has specified a descriptor, then get a pointer to it and its aggregates.*/ /* Otherwise, get pointers to the default descriptor's aggregates, and return the */ /* name of the default descriptor. */ /* 2) See if the command is supported by this descriptor. If not, return an error code. */ /* 3) See if the user supplied any library names. If not, address the default library */ /* names specified by the descriptor for this command. If none in descriptor either, */ /* return an error code. */ /* 4) Repeat step 3 for star names used to search for library entries. */ /* 5) Allocate an array of root nodes for the status tree which is big enough to hold _a_l_l */ /* of the roots defined by this descriptor. This will handle the maximum possible */ /* case. */ /* 6) Compare the library names with the names of defined roots. When a match is found, */ /* fill in a status tree root node for that root, and look for library entries in the */ /* root which match the search name(s). If no matching library entries are found, */ /* remove the root from the root node array. */ /* 7) If the root node array of the status tree is empty after all roots identified */ /* by the library names have been searched, then free the root node array and return */ /* an error code. Otherwise, return a pointer to the status tree. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ common: Ptree = null; /* initialize return arguments. */ command_info.n_found = 0; progress = 1; /* find descriptor. */ call find_descriptor (Adescriptor, P, Acode); /* note that Acode is initialized here. */ if Acode ^= 0 then return; progress = 2; /* see if command supported. */ if command_default_values.N < command then go to unsupported; if command_default_values(command).S.unsupported then do; unsupported: Acode = error_table_$request_not_recognized; return; end; progress = 3; /* address library names. */ if library.N < 1 then do; Plibrary_names = addrel (P.descriptor, command_default_values(command).library_names.O); Plibrary = addr(library_names.N); end; if library.N < 1 then do; Acode = error_table_$noarg; return; end; progress = 4; /* address the search names. */ if starname.N < 1 then do; Psearch_names = addrel (P.descriptor, command_default_values(command).search_names.O); Pstarname = addr(search_names.N); end; if starname.N < 1 then do; Acode = error_table_$noarg; return; end; progress = 5; /* allocate the root nodes of the status tree. */ call lib_get_tree_$root_array (roots.N, Parea, Pnodes, Acode); if Acode ^= 0 then return; progress = 6; /* find library entries in roots matching library */ Sfound = "0"b; /* names. */ do k = 1 to roots.N; Proot_names = addrel (P.descriptor, roots.root(k).name.O); do i = 1 to root_names.N; do j = 1 to library.N; go to match (library(j).C); match(0): if root_names.root_name(i) = library(j).V then go to match_found; go to no_match; match(1): call match_star_name_ (root_names.root_name(i), library(j).V, code); if code = 0 then go to match_found; no_match: end; end; go to next_name; match(2): match_found: Sfound = "1"b; Prt = addr(roots.root(k)); call lib_get_tree_$lib_root_node (Proot_names, rt.type, rt.path, rt.search_proc_name, Pstarname, Pexclude, ASrequirements, AScontrol, Parea, rt.search_proc, addr(command_info), Pnodes, roots.N, code); if code = error_table_$process_stopped then do; code = 0; go to stop_searching; end; else if code ^= 0 then Acode = code; /* return last bad error to caller. */ next_name: end; stop_searching: call lib_get_tree_$root_array_info (Pnodes, Nnodes, code); if (Nnodes > 0) | Sfound then do; /* find out about resultant status tree. */ if Acode = 0 then /* return any code from tree except nomatch. */ if code ^= error_table_$nomatch then Acode = code; Ptree = Pnodes; /* if non-empty, return tree, with any code rec'd */ return; /* while getting tree, to caller. */ end; progress = 7; /* tree empty. Tell user why and return. */ if Acode = 0 then if code ^= 0 then Acode = code; /* return lib_get_tree_'s reason for empty tree. */ else Acode = error_table_$nomatch; call lib_free_node_$array (Pnodes); /* free up Dnodes. */ return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ name: entry (Adescriptor); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry point returns the name of the current default library descriptor. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if first_call then call find_descriptor ("", P, code); else P.descriptor = defaultP.descriptor; Adescriptor = descriptor.name; return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ set_name: entry (Adescriptor, Acode); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry point sets the name of the default library descriptor. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if Adescriptor = "" then first_call = "1"b; /* if returning to the initial default descriptor,*/ /* re-initialize default descriptor values. */ call find_descriptor (Adescriptor, P, Acode); if Acode = 0 then defaultP = P; return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ default_values: entry (Adescriptor, Acommand, Acommand_name, ASunsupported, Plibrary, Pstarname, Pexclude, progress, Acode); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry point expects as input either: 1) the index of a library command; or */ /* 2) the name of a library command. If a name is given, it converts the name to an */ /* index. If the index is valid, the entry point returns the following information about */ /* the command: the name of the command; a switch indicating whether or not the */ /* command is supported by the specified (or default) library descriptor; and the */ /* default library names and search names associated with the command (if any). If the */ /* index is invalid, or if the specified library descriptor cannot be located, it returns */ /* a non-zero error code. */ /* */ /* _p_r_o_g_r_e_s_s */ /* */ /* 0) Validate the command index (if given), or convert the command name to a command */ /* index. */ /* 1) If the user specified a library descriptor, then get a pointer to it and its */ /* aggregates. Otherwise, get pointers to the default descriptor's aggregates. */ /* 2) Report whether or not the command is supported. */ /* 3) If supported, return any default values for library names and search names. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ ASunsupported = "1"b; /* initialize output values. */ Plibrary = addr(zero_names); Pstarname = addr(zero_names); Acode = 0; progress = 0; /* progress command index. */ if Acommand < 1 then do; /* a command name was given. Convert it to an */ /* index. */ do i = 1 to dimension (command_name,1) while (command_name(i) ^= Acommand_name); end; if i > dimension (command_name,1) then do; do i = 1 to dimension (command_abbrev,1) while (command_abbrev(i) ^= Acommand_name); end; if i > dimension (command_abbrev,1) then go to bad_command_name; Acommand_name = command_name(i); /* return full command name in place of abbrev. */ end; command_info.command = i; Acommand = i; end; else do; /* validate the command index. */ if Acommand > dimension (command_name,1) then go to bad_command_index; command_info.command = Acommand; Acommand_name = command_name(command_info.command); /* return the command name. */ end; progress = 1; /* find the descriptor. */ call find_descriptor (Adescriptor, P, Acode); if Acode ^= 0 then return; progress = 2; /* report whether or not command supported. */ if command_default_values.N < command_info.command then do; ASunsupported = "1"b; /* an old library descriptor doesn't include this */ return; /* command. Command is unsupported. */ end; ASunsupported = command_default_values(command_info.command).S.unsupported; if ASunsupported then return; /* no more to do for an unsupported command. */ progress = 3; /* report on any default values. */ Plibrary_names = addrel (P.descriptor, command_default_values(command_info.command).library_names.O); Plibrary = addr (library_names.N); Psearch_names = addrel (P.descriptor, command_default_values(command_info.command).search_names.O); Pstarname = addr (search_names.N); return; bad_command_index: Acode = error_table_$out_of_bounds; /* no such command index as being asked for. */ return; bad_command_name: Acode = error_table_$name_not_found; return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ libraries: entry (Adescriptor, Plibrary, ASrequirements, Parea, Ptree, progress, Acode); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry point expects as input an array of library names. It returns as output an */ /* array of library root nodes (suitable for printing by the lib_output_node_ subroutine) */ /* for the libraries in the library descriptor which match the specified library names. */ /* If no library names are given, an error is returned. */ /* */ /* _p_r_o_g_r_e_s_s */ /* */ /* 1) If the user specified a library descriptor, then get a pointer to it and its */ /* aggregates. Otherwise, get pointers to the default descriptor's aggregates. */ /* 3) Make sure caller specified some library names, and overlay these names. */ /* 5) Allocate an array of root nodes big enough to hold all of the roots defined in the */ /* descriptor being referenced. This is a guaranteed fit. */ /* 6) Compare the library names with the names of the defined roots. When a match is */ /* found, fill in a root node for that root. */ /* 7) If no matching roots are found, free the array of root nodes and return an error. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ Ptree = null; /* initialize output argument. */ progress = 1; /* find the descriptor. */ call find_descriptor (Adescriptor, P, Acode); if Acode ^= 0 then return; progress = 3; /* check for and overlay library names. */ if library.N <= 0 then do; Acode = error_table_$noarg; return; end; progress = 5; /* allocate array of root nodes big enough for */ /* all roots defined by this descriptor. */ call lib_get_tree_$root_array (roots.N, Parea, Pnodes, Acode); if Acode ^= 0 then return; progress = 6; /* find/output root nodes for matching roots. */ do k = 1 to roots.N; Proot_names = addrel (P.descriptor, roots.root(k).name.O); do i = 1 to root_names.N; do j = 1 to library.N; go to match_lib (library(j).C); match_lib (0): if root_names.root_name(i) = library(j).V then go to match_found_lib; go to no_match_lib; match_lib (1): call match_star_name_ (root_names.root_name(i), library(j).V, code); if code = 0 then go to match_found_lib; no_match_lib: end; end; go to next_name_lib; match_lib (2): match_found_lib: Prt = addr(roots.root(k)); call lib_get_tree_$lib_root_node (Proot_names, rt.type, rt.path, rt.search_proc_name, addr(zero_names), addr(zero_names), ASrequirements, "0"b, Parea, null_search_proc, addr(command_info.command), Pnodes, roots.N, code); if code = error_table_$process_stopped then do; code = 0; go to stop_searching_lib; end; else if code ^= 0 then Acode = code; /* return last bad error to caller. */ next_name_lib: end; stop_searching_lib: call lib_get_tree_$root_array_info (Pnodes, Nnodes, code); progress = 7; if Nnodes = 0 then do; /* no matching root definitions found. ERROR */ Acode = error_table_$nomatch; call lib_free_node_$array (Pnodes); end; else Ptree = Pnodes; return; null_search_proc: procedure; /* Null search procedure which does nothing. */ end null_search_proc; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ validate_library: entry (Adescriptor, Plibrary, Pbad_library, Acode); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry point expects as input an array of library names and an empty library */ /* name array of the same size. It returns as output in the empty array the names from */ /* the input array that do not match any library name defined in the given library */ /* descriptor. If no library names are input, an error is returned. */ /* */ /* _p_r_o_g_r_e_s_s */ /* */ /* 1) If the user specified a library descirptor, then get a pointer to it and its */ /* aggregates. Otherwise, get pointers to the default descriptor's aggregates. */ /* 3) Make sure the caller specified some library names. */ /* 6) Copy all of the caller's names to the bad_library array. Compare the names in */ /* this array with the valid library names from the descriptor, and REMOVE input */ /* library names from bad_library when they match a valid library name. */ /* */ /* NOTES */ /* */ /* A non-zero error code is returned ONLY IF the specified descriptor cannot be located, */ /* or if no library names were given as input. */ /* */ /* A zero code is returned otherwise. If there are bad library names, bad_library.N will */ /* be greater than 0 on output. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ bad_library.N = 0; /* initialize output argument. */ call find_descriptor (Adescriptor, P, Acode); /* find the descriptor. */ if Acode ^= 0 then return; if library.N <= 0 then do; /* check for library names given as input. */ Acode = error_table_$noarg; return; end; Pbad_library -> library = library; /* copy all input library names to bad_library. */ do k = 1 to roots.N while (bad_library.N > 0); /* compare input names with valid library names. */ Proot_names = addrel (P.descriptor, roots.root(k).name.O); do j = bad_library.N to 1 by -1; Sfound = "0"b; do i = 1 to root_names.N while (^Sfound); go to match_valid (bad_library(j).C); match_valid (0): if root_names.root_name(i) = bad_library(j).V then Sfound = "1"b; go to end_match_valid; match_valid (1): call match_star_name_ (root_names.root_name(i), bad_library(j).V, code); if code = 0 then Sfound = "1"b; go to end_match_valid; match_valid (2): Sfound = "1"b; end_match_valid: end; if Sfound then do; do i = j+1 to bad_library.N; bad_library(i-1).V = bad_library(i).V; bad_library(i-1).C = bad_library(i).C; end; bad_library.N = bad_library.N - 1; end; end; end; return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ find_descriptor: procedure (Adescriptor, P1, code); dcl /* parameters */ Adescriptor char(168) varying, /* descriptor to be found. (In) */ /* If Adescriptor = "", then name of */ /* default descriptor. (Out) */ 1 P1 aligned like P, /* descriptor pointer structure to be filled in. */ /* (Out) */ code fixed bin(35); /* a status code. (Out) */ dcl E entry variable, /* an entry variable temp. */ P_me ptr, /* a pointer temp. */ i fixed bin; dcl /* based variable */ 1 descriptor1 aligned like descriptor based (P1.descriptor); if first_call then do; /* first call. Initialize default descriptor ptr.*/ P1.descriptor = addr (multics_libraries_$descriptor); defaultP.descriptor = P1.descriptor; defaultP.command_default_values = addrel(P1.descriptor, descriptor1.command_default_values.O); defaultP.roots = addrel(P1.descriptor, descriptor1.roots.O); first_call = "0"b; end; if Adescriptor = "" then do; /* use default descriptor, and return its name. */ P1 = defaultP; Adescriptor = descriptor1.name; code = 0; end; else do; /* use user-specified descriptor. */ call cu_$decode_entry_value (lib_descriptor_, P_me, null); i = verify (reverse (Adescriptor), " "); i = length(Adescriptor) - (i-1); if search (Adescriptor, "<>") > 0 then E = cv_entry_ (substr(Adescriptor,1,i) || "|descriptor", P_me, code); else E = cv_entry_ (substr(Adescriptor,1,i) || "$descriptor", P_me, code); call cu_$decode_entry_value (E, P1.descriptor, null); if code ^= 0 then P1.descriptor = null; else if descriptor1.version ^= Vdescriptor_2 then do; code = error_table_$unimplemented_version; P1.descriptor = null; end; else do; P1.command_default_values = addrel(P1.descriptor, descriptor1.command_default_values.O); P1.roots = addrel(P1.descriptor, descriptor1.roots.O); code = 0; /* ignore superfluous errors. */ end; end; end find_descriptor; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ %include lib_descriptor_; end lib_descriptor_;  lib_error_list_.pl1 02/15/84 0911.2rew 02/15/84 0819.0 52371 /* *************************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1975 by Massachusetts Institute of Technology * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *************************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Name: lib_error_list_ */ /* */ /* This procedure prints information for error messages and other output from the */ /* arrays used by the library descriptor tools interfaces. */ /* */ /* Status */ /* 0) Created: Aug, 1971 by G. C. Dixon */ /* 1) Modified: Dec, 1980 by G. C. Dixon - add $return_string entry point. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ lib_error_list_: procedure (label, Pstarname, proc); /* Procedure to output an array of names in an */ /* error message. */ dcl /* parameters */ label char(32) varying; /* label for name array. */ %include lib_based_args_; dcl proc char(32) varying, /* Name of caller to be used in error message. */ APiocb ptr; /* ptr to iocb of switch array to be output on. */ dcl /* automatic variables */ (Lfield (3), Lprefix) fixed bin, /* length of output fields. */ Piocb ptr, /* ptr: to output switch. */ Sreturn_string bit(1), /* switch: on if entered at $return_string */ field (3) char(32), /* output fields. */ (i, j, k) fixed bin, /* do group indices. */ return_string char(10000) var; /* temp string to hold results during calc. */ dcl (length, min, reverse, verify) builtin; dcl ioa_$rsnpnnl entry options(variable), ioa_$ioa_switch entry options (variable); dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant), iox_$error_output ptr ext static; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ Sreturn_string = FALSE; /* Entry to output results to error_output */ Piocb = iox_$error_output; go to COMMON; lib_array_list_: entry (label, Pstarname, APiocb); /* Entry to output results on user_output. */ Sreturn_string = FALSE; Piocb = APiocb; go to COMMON; return_string: /* Entry to return formatted results as a string. */ entry (label, Pstarname) returns (char(*) varying); Sreturn_string = TRUE; return_string = ""; COMMON: Lprefix = 2; /* indent heading line by 2 chars. */ if starname.N > 1 then field(1) = label || "s:"; else field(1) = label || ":"; /* 1st field is label (singular or plural). */ Lfield(1) = 23; i = 1; /* indicate first field has been used. */ j = 1; /* begin outputing with 1st name. */ do while (j <= starname.N); if i = 3 then do; /* if all fields full, output the line. */ if Sreturn_string then call ioa_$rsnpnnl ("^a^[^/^]^vx^va^va^va", return_string, 0, return_string, length(return_string)>0, Lprefix, Lfield(1), field(1), Lfield(2), field(2), Lfield(3), field(3)); else call ioa_$ioa_switch (Piocb, "^vx^va^va^va", Lprefix, Lfield(1), field(1), Lfield(2), field(2), Lfield(3), field(3)); i = 0; /* no fields used. */ Lprefix = 5; /* indent all succeeding lines by 5 chars. */ end; i = i + 1; /* process next field. */ Lfield(i) = min (32, 33 - verify (reverse (starname.V(j)), " ")); if Lfield(i) <= 18 then do; /* if name <= 18 chars; it will fit in 1 field. */ Lfield(i) = 20; field(i) = starname.V(j); end; else if i < 3 then do; /* name > 18 chars; it will fit in 2 fields. */ if i = 1 then do; /* put name in 2nd field of line, if next */ /* name won't fit in first field. */ if j < starname.N then do; k = min (32, 33 - verify (reverse (starname.V(j+1)), " ")); if k <= 18 then do; Lfield(i) = 20; field (i) = starname.V(j+1); i = i + 1; Lfield(i) = 40; field (i) = starname.V(j); i = i + 1; Lfield(i) = 0; field (i) = ""; j = j + 1; go to NEXT_NAME; end; end; Lfield(i) = 20; field (i) = ""; i = i + 1; end; Lfield(i) = 40; field(i) = starname.V(j); i = i + 1; /* 2d of the 2 fields needs no further processing.*/ Lfield(i) = 0; field(i) = ""; end; else do; /* name > 18 chars and only 1 field left. */ Lfield(i) = 0; /* make it a blank field. */ field(i) = ""; j = j - 1; /* process this name again on the next line. */ end; NEXT_NAME: j = j + 1; /* process the next name. */ end; do i = i+1 to 3; /* null out any unused fields on last line. */ Lfield(i) = 0; field(i) = ""; end; if Sreturn_string then do; call ioa_$rsnpnnl ("^a^[^/^]^vx^va^va^va", return_string, 0, return_string, length(return_string)>0, Lprefix, Lfield(1), field(1), Lfield(2), field(2), Lfield(3), field(3)); return (return_string); end; else call ioa_$ioa_switch (Piocb, "^vx^va^va^va", Lprefix, Lfield(1), field(1), Lfield(2), field(2), Lfield(3), field(3)); /* output the last line. */ end lib_error_list_;  lib_fetch_.pl1 09/25/84 1155.7rew 09/25/84 1154.5 221823 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Modified October 26, 1983 by Jim Lippard to fix bug in the call to get_equal_name_ and to properly handle */ /* name duplication */ /* Modified June 13, 1984 by Jim Lippard to not sort found names */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ lib_fetch_: procedure (Plibrary, Pstarname, Pexclude, Srequirements, Scontrol, Parg_struc, Acode) options (rename ((alloc_, smart_alloc_))); dcl /* Parameter */ Acode fixed bin(35); /* an error table code. */ dcl /* automatic variables */ Iname fixed bin, /* count of names processed so far. */ Lcopy fixed bin(21), /* length of target segment (in chars). */ Nentries_fetched fixed bin, /* number of library entries successfully fetched.*/ Parea ptr, /* ptr to an MSA. */ Pcopy ptr, /* ptr to target segment (ie, copy fetched into). */ Pent ptr, /* ptr to library entry being fetched. */ Pmsf_fcb ptr, /* ptr to msf_manager_'s control block. */ Ptarget_node ptr, /* ptr to node for actual library entry being */ /* fetched. */ Ptree ptr, /* ptr to a tree of status nodes. */ 1 S_ structure, /* switches: */ (2 link_error_output, /* on if link error message already output. */ 2 error, /* on if error occurred making target seg. */ 2 fetch_not_done, /* on if fetch not yet complete. */ 2 acl_init, /* on if ACL structure already initialized. */ 2 msf, /* on if entry being fetched is an MSF. */ 2 no_action, /* on if user said "no" to nd_handler_ */ 2 delete_msf) bit(1) unal, /* on if target MSF needs to be deleted after */ /* an error occurred. */ 1 acl structure, /* an ACL addition structure. */ 2 access_name char(32), 2 modes bit(36), 2 zero_pad bit(36), 2 code fixed bin(35), bc fixed bin(24), /* bit count of library entry. */ clock fixed bin(71), /* a clock value. */ code fixed bin(35), /* a status code. */ date char(16) aligned, /* a date/time string. */ dir char(168) varying, /* dir part of library entry pathname. */ ent char(32) varying, /* ent part of library entry pathnamer. */ 1 fcb_temp like fcb, /* storage for file control block. */ i fixed bin, /* a do-group index. */ into_dir char(168), /* dir part of into_path. */ into_ent char(32), /* ent part of into_path. */ msf_comp fixed bin(24), /* number of next msf_comp to be initiated. */ nd_result fixed bin(35), /* return code from nd_handler_. */ node_name char(32), /* a name on the library entry being fetched. */ progress fixed bin init (0), /* integer indicating progress of our search. */ /* 0 = search beginning. */ /* 1 = finding library descriptor. */ /* 2 = seeing if library_fetch command supported*/ /* by this descriptor. */ /* 3 = getting default library names if user */ /* specified none. */ /* 4 = getting default search names if user */ /* specified none. */ /* 5 = allocating the root nodes of the tree. */ /* 6 = searching each library root for entries */ /* identified by the search names. */ /* 7 = no entries matching search names found. */ state char(16), /* an error temporary char string. */ target_name char(32), /* name to be put on target segment. */ unique_name char(32); /* unique name by which target segment created. */ dcl /* based variables */ area area based (Parea), /* an MSA (multi-segment area). */ copy char(Lcopy) based (Pcopy); /* (all or part of) library entry being fetched. */ dcl (addr, divide, length, min, null, string, substr) builtin; dcl cleanup condition; dcl /* Entries Called */ clock_ entry returns (fixed bin(71)), condition_ entry (char(*), entry), date_time_ entry (fixed bin(71), char(*) aligned), delete_$path entry (char(*), char(*), bit(6), char(*), fixed bin(35)), expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin(35)), get_equal_name_ entry (char(*), char(*), char(32), fixed bin(35)), (get_group_id_, get_group_id_$tag_star) entry returns (char(32) aligned), get_system_msa_ entry (ptr, fixed bin, ptr), hcs_$add_acl_entries entry (char(*), char(*), ptr, fixed bin, fixed bin(35)), hcs_$chname_file entry (char(*), char(*), char(*), char(*), fixed bin(35)), hcs_$make_seg entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35)), hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35)), hcs_$terminate_noname entry (ptr, fixed bin(35)), (ioa_, ioa_$ioa_switch) entry options (variable), iox_$attach_ioname entry (char(*), ptr, char(*), fixed bin(35)), iox_$close entry (ptr, fixed bin(35)), iox_$detach_iocb entry (ptr, fixed bin(35)), iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)), lib_array_list_ entry (char(32) varying, ptr, ptr), lib_descriptor_$fetch entry (char(168) varying, ptr, ptr, ptr, bit(72) aligned, bit(36) aligned, ptr, ptr, fixed bin, fixed bin(35)), lib_error_list_ entry (char(32) varying, ptr, char(32) varying), lib_next_name_ entry (bit(72) aligned, ptr, fixed bin, ptr) returns (char(32)), lib_node_path_ entry (ptr, char(168) varying, char(32) varying), lib_output_node_list_$info entry (ptr, ptr, ptr, ptr, char(45) varying, bit(72) aligned, ptr), lib_ptr_and_bc_ entry (ptr, fixed bin(24), ptr, ptr, fixed bin(24), fixed bin(35)), lib_sort_tree_$make_name_list entry (ptr, ptr, ptr, ptr, fixed bin(35)), msa_manager_$area_handler entry, msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35)), msf_manager_$get_ptr entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35)), msf_manager_$close entry (ptr), nd_handler_ entry (char(*), char(*), char(*), fixed bin(35)), release_system_msa_ entry (ptr, fixed bin(35)), unique_chars_ entry (bit(*) aligned) returns (char(15)); dcl /* static variables */ False bit(1) int static options(constant) init ("0"b), True bit(1) int static options(constant) init ("1"b), (error_table_$action_not_performed, error_table_$entlong, error_table_$longeql, error_table_$namedup, error_table_$noentry, error_table_$not_detached, error_table_$not_done, error_table_$not_open) fixed bin(35) ext static, finish bit(1) aligned int static options(constant) init ("1"b), group_id char(32) int static init (""), on_unit bit(1) aligned int static options(constant) init ("0"b), stream_output fixed bin int static init (2); /* iox_ opening mode for stream-output I/O. */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* 1) initialize library pgm's file control block. */ /* 2) establish cleanup on unit. */ /* 3) attach/open output file. */ /* 4) get ptr to system multi-segment area, and establish area on unit. */ /* 5) search and build status tree for library entries being sought. */ /* 6) make a list of found entries */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ Acode = 0; /* initialize output argument. */ Pfcb = addr(fcb_temp); fcb.version = Vfcb_1; fcb.ioname = "lib_fetch_"; /* do all of our output on the lib_fetch_ ioname. */ fcb.Piocb = null; /* indicate no attachment so far. */ fcb.Eend_page = no_end_page; fcb.page_length = 131071; fcb.page_text_length = 131071; fcb.page_no = 1; fcb.line_length = 79; fcb.line_no = 2; Parea = null; /* initialize values used by cleanup on unit. */ Pent = null; Pmsf_fcb = null; Pcopy = null; string(S_) = ""b; /* initialize all switches. */ on cleanup call janitor(on_unit); if Sc.output_file then do; /* attach/open output file if required. */ if substr(arg_struc.output_file, length(arg_struc.output_file)-5) ^= ".fetch" then if length(arg_struc.output_file) > 162 then do; code = error_table_$entlong; go to BAD_ATTACH; end; else arg_struc.output_file = arg_struc.output_file || ".fetch"; call iox_$attach_ioname (fcb.ioname, fcb.Piocb, "vfile_ " || arg_struc.output_file || " -extend", code); if code ^= 0 then go to BAD_ATTACH; call iox_$open (fcb.Piocb, stream_output, "0"b, code); if code ^= 0 then go to BAD_OPEN; end; call expand_path_ (addr(substr(arg_struc.into_path,1)), length(arg_struc.into_path), addr(into_dir), addr(into_ent), code); if code ^= 0 then go to BAD_INTO; /* validate -into path specification. */ call get_equal_name_ ((32) ".", into_ent, target_name, code); if code = error_table_$longeql then; else if code ^= 0 then go to BAD_INTO; call condition_ ("area", msa_manager_$area_handler); /* let msa_manager_ handle area conditions. */ call get_system_msa_ (addr(Parea), 0, (null)); /* get MSA ptr. */ call lib_descriptor_$fetch (arg_struc.descriptor, Plibrary, Pstarname, Pexclude, Srequirements, Scontrol, Parea, Ptree, progress, code); /* get a tree of status nodes reflecting the */ if code ^= 0 then go to BAD_SEARCH; /* library entries which match the star name. */ allocate index_list in (area), /* allocate space for sorting the status nodes. */ name_list in (area), node_list in (area); index_list.I = 0; /* initialize count of entries in each list. */ name_list.I = 0; node_list.I = 0; call lib_sort_tree_$make_name_list (Ptree, Pname_list, Pindex_list, Pnode_list, code); if code ^= 0 then go to NO_MATCH; /* put the outputable nodes into a name list. */ do i = 1 to index_list.I; /* initialize the index list */ index_list.e (i) = i; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* For EACH library entry which was found: */ /* 1) Get a pointer to the node describing the found entry. */ /* 2) Complain if the entry is a link, and links are not being chased. */ /* 3) Get pointer to, and bit count of, the library entry to be fetched. */ /* 4) For segments, archives, archive components, and MSF components: */ /* a) create a uniquely-named target segment in the user-specified directory. */ /* b) copy the library entry into the target segment. */ /* c) if the library entry is an object segment, set the user's access to the target */ /* segment to 're'. */ /* d) terminate the library entry. */ /* */ /* For MSFs: */ /* a) create a uniquely-name target MSF in the user-specified directory, via */ /* msf_manager_. */ /* b) copy the library MSF into the target MSF, component by component. */ /* c) terminate each library MSF component as it is copied. */ /* 5) Add ALL, the PRIMARY, or the MATCHING names to the uniquely-named target, as */ /* the user specified. */ /* 6) Remove the unique name. */ /* 7) Output message to the user if -long was specified. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ Nentries_fetched = 0; do i = 1 to index_list.I; /* loop through nodes to be fetched. */ unique_name = unique_chars_ (""b); /* get unique name to place on target segment.*/ Pnode = node_list.e (index_list.e(i)); /* get ptr to node. */ call lib_node_path_ (Pnode, dir, ent); /* get pathname of library entry. */ if node.T = Tlink then if ^Sc.chase then do; /* warn user that links aren't chased. */ if S_.link_error_output then call arg_struc.put_error (error_table_$not_done, arg_struc.program, " Link ^a>^a", dir, ent); else do; call arg_struc.put_error (error_table_$not_done, arg_struc.program, " Use the -chase option to fetch the target of the link ^a>^a.", dir, ent); S_.link_error_output = True; end; node_list.e (index_list.e(i)) = null; Acode = code; go to NEXT_NODE; end; msf_comp = 0; call lib_ptr_and_bc_ (Pnode, msf_comp, Ptarget_node, Pent, bc, code); if code ^= 0 then do; if node.T = Tlink then call arg_struc.put_error (code, arg_struc.program, " Unable to fetch through null link ^a>^a.", dir, ent); else call arg_struc.put_error (code, arg_struc.program, " Unable to fetch ^a ^a>^a.", node_type(node.T), dir, ent); node_list.e (index_list.e(i)) = null; Acode = code; go to NEXT_NODE; end; if node.T = Tlink then go to COPY (Ptarget_node->node.T); /* copy according to type of library entry. */ else go to COPY (node.T); COPY(1): /* segment entries. */ COPY(4): /* MSF component entries. */ COPY(5): /* archive entries. */ COPY(6): /* archive component entries. */ call hcs_$make_seg (into_dir, unique_name, "", 01010b, Pcopy, code); if Pcopy = null then do; /* create new segment in which ent is copied. */ call arg_struc.put_error (code, arg_struc.program, " Unable to create segment ^a (^a>^a) into which the library entry will be copied.", ent, into_dir, unique_name); S_.error = True; Acode = code; go to TERM_ENT; end; S_.fetch_not_done = True; Lcopy = divide (bc+8, 9, 21, 0); /* compute number of characters to be copied. */ copy = Pent -> copy; /* copy library entry into target segment. */ call hcs_$set_bc_seg (Pcopy, bc, code); /* set the bit count on the target segment. */ if Svalid.object_info then do; /* set ACL of object segs to 're' */ if ^S_.acl_init then do; if group_id = "" then group_id = get_group_id_$tag_star(); acl.access_name = group_id; acl.modes = "110"b; acl.zero_pad = ""b; end; call hcs_$add_acl_entries (into_dir, unique_name, addr(acl), 1, code); if code ^= 0 then call arg_struc.put_error (code, arg_struc.program, " Unable to give user 're' access to fetched entry ^a, (^a>^a).", ent, into_dir, unique_name); end; TERM_ENT: call hcs_$terminate_noname (Pent, code); Pent = null; if S_.error then do; S_.error = False; node_list.e(index_list.e(i)) = null; go to NEXT_NODE; end; go to JOIN; COPY(3): /* MSF entries. */ S_.msf = True; /* Indicate we're dealing with an MSF. */ call msf_manager_$open (into_dir, unique_name, Pmsf_fcb, code); if code ^= 0 then if code ^= error_table_$noentry then do; /* create new MSF into which ent is copied. */ call arg_struc.put_error (code, arg_struc.program, " Unable to create MSF ^a (^a>^a) into which the library MSF will be copied.", ent, into_dir, unique_name); S_.error = True; Acode = code; go to TERM_MSF; end; do while (Pent ^= null); /* copy MSF, component by component. */ call msf_manager_$get_ptr (Pmsf_fcb, msf_comp-1, True, Pcopy, 0, code); if Pcopy = null then do; call arg_struc.put_error (code, arg_struc.program, " Unable to create MSF component ^d in MSF ^a (^a>^a).", msf_comp-1, ent, into_dir, unique_name); S_.error = True; S_.delete_msf = (msf_comp >= 2); Acode = code; go to TERM_MSF; end; S_.fetch_not_done = True; Lcopy = divide (bc+8, 9, 21, 0); copy = Pent -> copy; call hcs_$set_bc_seg (Pcopy, bc, code); call hcs_$terminate_noname (Pent, 0); call lib_ptr_and_bc_ (Pnode, msf_comp, Ptarget_node, Pent, bc, code); end; TERM_MSF: call msf_manager_$close (Pmsf_fcb); Pmsf_fcb = null; if S_.delete_msf then do; call delete_$path (into_dir, unique_name, "000100"b, (arg_struc.program), code); S_.delete_msf = False; end; if S_.error then do; S_.error = False; node_list.e(index_list.e(i)) = null; go to NEXT_NODE; end; go to JOIN; JOIN: do PDnames = node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames); end; /* get list of names on library entry. */ Iname = 0; /* indicate no names in list processed yet. */ node_name = lib_next_name_ (node.Sreq, PDnames, Iname, Pstarname); S_.no_action = False; do while (node_name ^= ""); /* add names to target, 1 by 1. */ call get_equal_name_ (node_name, into_ent, target_name, code); if code ^= 0 then do; call arg_struc.put_error (code, arg_struc.program, " Unable to apply equal name ^a to library entry name ^a.", into_ent, node_name); go to NEXT_NAME; end; call hcs_$chname_file (into_dir, unique_name, "", target_name, code); if code = error_table_$namedup then do; call nd_handler_ ((arg_struc.program), into_dir, target_name, nd_result); if nd_result = 0 then call hcs_$chname_file (into_dir, unique_name, "", target_name, code); else if nd_result = error_table_$action_not_performed then S_.no_action = True; end; else if code ^= 0 then do; call arg_struc.put_error (code, arg_struc.program, " Unable to add name ^a to copied library entry ^a (^a>^a).", target_name, Dnames.names(1), into_dir, unique_name); Acode = code; end; NEXT_NAME: node_name = lib_next_name_ (node.Sreq, PDnames, Iname, Pstarname); end; S_.fetch_not_done = False; call hcs_$chname_file (into_dir, unique_name, unique_name, "", code); if code ^= 0 then do; /* If unique name is only name on copy, complain! */ if ^S_.no_action then call arg_struc.put_error (code, arg_struc.program, " Unable to add any names to copied library entry ^a The entry could not be fetched.", Dnames.names(1)); call delete_$path (into_dir, unique_name, "000100"b, (arg_struc.program), code); node_list.e(index_list.e(i)) = null; go to NEXT_NODE; end; Nentries_fetched = Nentries_fetched + 1; /* Increment count of entries actually fetched. */ if Sc.long then do; /* output the fetched message. */ call ioa_ ("Library ^a ^a ^/ fetched from ^a", node_type(node.T), ent, dir); if arg_struc.into_path ^= "==" then call ioa_ (" into ^a>^a.", into_dir, target_name); end; NEXT_NODE: end; /* That completes the processing for this node. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Output list of fetched nodes into output file. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if Nentries_fetched = 0 then return; else if Sc.output_file then; else return; clock = clock_(); call date_time_ (clock, date); if Nentries_fetched = 1 then call ioa_$ioa_switch (fcb.Piocb, "^/Entry Fetched:^-^5x1"); else call ioa_$ioa_switch (fcb.Piocb, "^/Entries Fetched:^-^5x^d", Nentries_fetched); call ioa_$ioa_switch (fcb.Piocb, " Fetched on:^-^5x^a", date); call ioa_$ioa_switch (fcb.Piocb, " Fetched by:^-^5x^a", get_group_id_()); call ioa_$ioa_switch (fcb.Piocb, " Descriptor:^-^5x^a", arg_struc.descriptor); if library.N = 1 then call lib_array_list_ (" Library Name", Plibrary, fcb.Piocb); else call lib_array_list_ ("Library Name", Plibrary, fcb.Piocb); if starname.N = 1 then call lib_array_list_ (" Search Name", Pstarname, fcb.Piocb); else call lib_array_list_ (" Search Name", Pstarname, fcb.Piocb); call lib_output_node_list_$info (Pfcb, Pnode_list, Pname_list, Pindex_list, "", (72)"1"b, addr(starname)); /* print the nodes, including names which */ /* match the user's search names. */ DETACH: if Acode = 0 then Acode = code; call janitor(finish); /* clean up. */ return; janitor: procedure (invocation_mode); /* cleanup procedure. */ dcl invocation_mode bit(1) aligned; /* off if invoked by cleanup on unit. */ if Parea ^= null then /* cleanup by releasing any system MSA. */ call release_system_msa_ (addr(Parea), code); if fcb.Piocb ^= null then do; /* close/detach our output file, if open. */ call iox_$close (fcb.Piocb, code); if invocation_mode = finish then if code ^= 0 then if code ^= error_table_$not_open then go to BAD_CLOSE; call iox_$detach_iocb (fcb.Piocb, code); fcb.Piocb = null; /* we've done all we can. Stop trying. */ if invocation_mode = finish then if code ^= 0 then go to BAD_DETACH; end; if Pent ^= null then call hcs_$terminate_noname (Pent, code); if S_.msf then if Pmsf_fcb ^= null then call msf_manager_$close (Pmsf_fcb); else; else if Pcopy ^= null then call hcs_$terminate_noname (Pent, code); if S_.fetch_not_done then call delete_$path (into_dir, unique_name, "000100"b, (arg_struc.program), code); end janitor; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ BAD_ATTACH: if code = error_table_$not_detached then go to MULTIPLE_ATTACH; state = "attaching"; fcb.Piocb = null; go to BAD_IO; BAD_CLOSE: state = "closing"; go to BAD_IO; BAD_DETACH: state = "detaching"; go to BAD_IO; BAD_OPEN: state = "opening"; BAD_IO: call arg_struc.put_error (code,arg_struc.program, " While ^a the fetch record ^R^a^B using the I/O switch ^R^a^B.", state, arg_struc.output_file, fcb.ioname); go to DETACH; MULTIPLE_ATTACH: call arg_struc.put_error (code, arg_struc.program, " While attaching the map file ^R^a^B to the I/O switch ^R^a^B. Release any other activations of ^a and try again.", arg_struc.output_file, fcb.ioname, arg_struc.program); Acode = code; return; BAD_INTO: call arg_struc.put_error (code, arg_struc.program, " -into ^a", arg_struc.into_path); Acode = code; return; BAD_SEARCH: progress = min (progress, 7); go to BAD_S (progress); BAD_S(0): call arg_struc.put_error (code, arg_struc.program, " While calling lib_descriptor_$map."); go to DETACH; BAD_S(1): call arg_struc.put_error (code, arg_struc.program, " While finding the '^R^a^B' library descriptor.", arg_struc.descriptor); go to DETACH; BAD_S(2): call arg_struc.put_error (code, arg_struc.program, " Library descriptor '^R^a^B' does not implement the ^a command.", arg_struc.descriptor, arg_struc.program); go to DETACH; BAD_S(3): state = "library"; go to NO_DEFAULT_NAMES; BAD_S(4): state = "search"; NO_DEFAULT_NAMES: call arg_struc.put_error (code, arg_struc.program, " No ^a names were specified, and the '^R^a^B' library descriptor does not define any default ^a names.", state, arg_struc.descriptor, state); go to DETACH; BAD_S(5): call arg_struc.put_error (code, arg_struc.program, " While allocating the root nodes of the library tree."); go to DETACH; BAD_S(6): NO_MATCH: call arg_struc.put_error (code, arg_struc.program, " While searching for entries in the library. Descriptor:^-^5x^a", arg_struc.descriptor); call lib_error_list_ ("library name", Plibrary, arg_struc.program); call lib_error_list_ ("search name", Pstarname, arg_struc.program); go to DETACH; BAD_S(7): call arg_struc.put_error (code, arg_struc.program, " No libraries matching the library name(s) could be found. Descriptor:^-^5x^a", arg_struc.descriptor); call lib_error_list_ ("library name", Plibrary, arg_struc.program); go to DETACH; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ no_end_page: procedure; /* This is a null end-of-page handling proc. */ fcb.page_no = fcb.page_no + 1; fcb.line_no = 1; end no_end_page; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ %include lib_arg_struc_; %include lib_based_args_; %include lib_fcb_; %include lib_list_; %include lib_node_; end lib_fetch_;  lib_free_node_.pl1 02/15/84 0911.2rew 02/15/84 0819.1 44361 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* N__a_m_e: lib_free_node_ */ /* */ /* This procedure frees the storage used by library nodes. */ /* */ /* E__n_t_r_y: lib_free_node_$array */ /* */ /* This entry point frees all structures attached to each node of a library node */ /* array, and then frees the node array, itself. */ /* */ /* U__s_a_g_e */ /* */ /* dcl lib_free_node_$array entry (ptr); */ /* */ /* call lib_free_node_$array (PDnodes); */ /* */ /* 1) PDnodes points to the library node array to be freed. (In) */ /* is a null pointer. (Out) */ /* */ /* E__n_t_r_y: lib_free_node_$descriptors */ /* */ /* This entry point frees all structures attached to a single library node. */ /* */ /* U__s_a_g_e */ /* */ /* dcl lib_free_node_$descriptors entry (ptr); */ /* */ /* call lib_free_node_$descriptors (Pnode); */ /* */ /* 1) Pnode points to the library node whose descriptors are to be freed. (In) */ /* */ /* S__t_a_t_u_s */ /* */ /* 0) Created: Aug, 1973 by G. C. Dixon */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ lib_free_node_: procedure; dcl APnode ptr, /* ptr to node whose descriptors are to be freed. */ /* (In) */ APDnodes ptr; /* ptr to node array to be freed. (In) */ /* null ptr. (Output) */ dcl Parea ptr, /* ptr to an area. */ i fixed bin; /* do group index. */ dcl area area based (Parea); /* create a dummy area to make PL/I happy when */ /* it executes the free statements. */ dcl 1 Dfree based (PD), /* structure used to free all descriptors. */ 2 header like D, 2 body (Dfree.length-size(D)) fixed bin(35); dcl (addr, null, size) builtin; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ array: entry (APDnodes); /* entry to free a node descriptor, and its */ /* descriptors. */ PDnodes = APDnodes; /* address the node array descriptor. */ Parea = PDnodes; /* for PL/I's benefit, fake ptr to area for free. */ if PDnodes = null then /* if descriptor has already been freed, done. */ return; if Dnodes.version ^= Vnodes_1 then /* if structure of descriptor unknown, exit. */ return; do i = 1 to Dnodes.N; /* for each node in the node array: */ Pnode = addr (Dnodes.nodes(i)); /* (1) address the node. */ call free_node_descriptors; /* (2) free its descriptors. */ end; /* then: */ free Dnodes in (area); /* (3) free the node array descriptor. */ APDnodes = null; /* (4) null out the ptr to the freed descriptor */ /* to prevent mistaken attempts to refree. */ return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ descriptors: entry (APnode); /* entry to free a node's descriptors. */ Pnode = APnode; /* address the node. */ Parea = Pnode; /* for PL/I's benefit, fake ptr to area for free. */ call free_node_descriptors; /* free its descriptors. */ return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ free_node_descriptors: procedure; /* This internal procedure frees descriptors */ /* attached to the node pointed to by Pnode. */ do PD = node.PD repeat node.PD while (PD ^= null);/* free descriptors, one at a time. */ node.PD = D.Pnext; /* save ptr to next descriptor. */ if D.T = Tnodes then /* if this is a node array descriptor, then */ call array (PD); /* call array freer to do the work. */ else /* otherwise, do the freeing ourself. */ free Dfree in (area); end; end free_node_descriptors; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ %include lib_node_; end lib_free_node_;  lib_get_tree_.pl1 07/18/86 1518.6rew 07/18/86 1235.1 540747 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(75-08-01,GDixon), approve(), audit(), install(86-07-18,MR12.0-1098): Written initially. 2) change(84-01-20,Lippard), approve(), audit(), install(86-07-18,MR12.0-1098): Use archive_$list_components. 3) change(84-03-05,Lippard), approve(), audit(), install(86-07-18,MR12.0-1098): Free the correct archive component array structure and treat error_table_$logical_volume_not_connected as a fatal error (so it will complain instead of being quiet about it. 4) change(86-02-15,GDixon), approve(86-03-24,MCR7365), audit(86-04-22,Dickson), install(86-04-22,MR12.0-1042): Fix bug which prevents listing segments when a .1 version of the segment also exists in the libraries. 5) change(86-05-17,GDixon), approve(86-05-17,MCR7357), audit(86-07-10,Farley), install(86-07-18,MR12.0-1098): Changed call to tct_ to reference find_char_$first_in_table; this subroutine was renamed. END HISTORY COMMENTS */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ lib_get_tree_: procedure (APparent, path, Pstarname, Pexclude, Srequirements, Scontrol, tree_level, link_level, Parea, director, Pdirector_args, Pnodes, Acode) options (rename ((alloc_, smart_alloc_))); dcl APparent ptr, /* ptr to parent node of the node array we are */ /* to create. It must not be null. (In) */ path char(168) varying; /* path name of the parent node, or a link path */ /* if the parent node was a link. (In) */ %include lib_based_args_; dcl tree_level fixed bin, /* number of generations which are parent to the */ /* node array we are to create. (In) */ link_level fixed bin, /* number of consecutive links we have processed */ /* when in no-chase-links mode. (In) */ Parea ptr, /* ptr to MSA we are to create the node in. (In) */ director entry (ptr, char(168) varying, ptr, ptr, bit(72) aligned, bit(36) aligned, fixed bin, fixed bin, ptr, entry, ptr, ptr, fixed bin(35)), /* entry we are to call to validate (and further */ /* process) each node in the array. (In) */ /* Note that the director's calling sequence is */ /* the same as ours. */ Pdirector_args ptr, /* ptr to director-defined structure containing */ /* information used by the director. (In) */ Pnodes ptr, /* ptr to the node array which we created. (Out) */ Acode fixed bin(35), /* (Ignored) */ 1 root_names based (Proot_names),/* list of names on a root. */ 2 N fixed bin, /* count of names. */ 2 root_name (0 refer (root_names.N)) /* array of names. */ char (32), Proot_names ptr, /* ptr to root_names structure. (In) */ root_type fixed bin, /* type of a root. 2 = directory, 4 = archive. */ root_search_proc char(65) varying, /* procedure used to search root. (In) */ MNnodes fixed bin; /* maximum size of the root node array. (In) */ dcl /* automatic variables */ Inode fixed bin, /* index of the node array element (node) we're */ /* working on now. */ Lstring_ fixed bin(35), /* length of string_. */ Nentries fixed bin, /* number of arch comp entries. */ Nterminal_account fixed bin(1), /* terminal account switch from hcs_$quota_read */ PBDarch ptr unal, /* ptr to base of archive descriptor chain. */ PDarch ptr, /* ptr to an archive descriptor chain entry. */ Pacl ptr, /* ptr to a segment ACL. */ Parch ptr, /* ptr to the archive component we're working on. */ Pdir_acl ptr, /* ptr to a directory ACL. */ Piacl ptr, /* ptr to a group of IACLs from list_inacl_all. */ Pparent ptr, /* ptr to our node's parent node. */ Pstring_ ptr, /* ptr to string_. */ Ptemp ptr, /* a temporary ptr. */ Schase_links fixed bin(1), /* chase switch. */ author char(33), /* author of a link (33 chars so guaranteed to */ /* end with a space). */ bit_count fixed bin(24), /* a segment or archive component bit count. */ call_id bit(70) aligned, /* unique identifier of each logical call to */ /* hcs_$star_ or hcs_$status_long. */ char32 char(32), /* character temporary. */ clock fixed bin(71), /* a binary clock value. */ code fixed bin(35), /* a status code. */ count fixed bin, /* number of matching entries in a dir. */ e fixed bin, /* entry switch: 1-$lib_root_node, 2-$root_node */ ent char(32), /* entry part of a path name. */ error label local, /* address of current error handler. */ 1 flags aligned, 2 archive bit(1), /* segment is an archive. */ 2 object_seg bit(1), /* segment is an object segment. */ 2 ascii bit(1), /* segment contains only ascii characters. */ i fixed bin, /* a do-group index and integer temporary. */ 1 iacl_info, /* information structure req'd by list_inacl_all. */ 2 seg, /* information about segment IACLs. */ 3 offsets (0:7) bit(18) aligned, /* per ring offset of first ACLe in array. */ 3 counts (0:7) fixed bin, /* per ring count of ACL entries. */ 2 dir, /* information about directory IACLs. */ 3 offsets (0:7) bit(18) aligned, /* per ring offset of first ACLe in array. */ 3 counts (0:7) fixed bin, /* per ring count of ACL entries. */ j fixed bin, /* a do-group index. */ k fixed bin, /* a do-group index. */ msf_dir char(168), /* pathname of MSF directory. */ n_components fixed bin, /* number of archive components */ type fixed bin; /* a temporary containing node type of parent to */ /* the node array we're creating. */ %include status_for_backup; declare 1 sfb automatic aligned like status_for_backup; dcl /* based variables */ 1 Darch aligned based (PDarch), /* an archive component descriptor. */ 2 Pnext ptr unal, /* ptr to the next descriptor in the chain. */ 2 Parch ptr unal, /* ptr to the archive component. */ 2 Smode bit(3) unal, /* mode from archive component. */ 2 pad bit(8) unal, 2 bit_count fixed bin(24) unal, /* bit count from archive component. */ 2 dtm bit(36) aligned, /* date-time modified for archive component. */ 2 dtupdated bit(36) aligned, /* date-time component last updated. */ 2 name char(32) aligned, /* component name. */ 1 acl (Nacls) based (Pacl) like Dacl.acls, /* a segment ACL structure. */ 1 arch based (Parch), /* an archive component header. */ 2 header_begin char(8), /* start-of-archive-header identification field. */ 2 pad1 char(4), 2 name char(32), /* name of the archive component. */ 2 dtem char(16), /* date-time component updated. */ 2 mode char(4), /* user's access mode to segment when archived. */ 2 dtm char(16), /* date-time segment last modified before it was */ 2 pad2 char(4), /* archived. */ 2 bit_count char(8), /* length of archive component (minus header), in */ /* bits). */ 2 header_end char(8), /* end-of-archive-header identification field. */ area_var area based (Parea), /* area where tree is to be allocated. */ clock_string bit(72) aligned based (addr (clock)), /* bit string overlay for a binary clock value. */ 1 dir_acl (Ndir_acls) based (Pdir_acl) like Ddir_acl.acls, /* a directory ACL structure. */ node_string bit(Lnode_string) aligned based (Pnode), /* overlay for the storage occupied by a node. */ stop_search label local, /* where to go if search is being stopped */ string_ char(Lstring_) based (Pstring_); dcl /* builtin functions */ (addr, addrel, binary, divide, length, min, mod, null, pointer, rel, reverse, rtrim, size, string, substr, sum, verify) builtin; dcl /* entries */ area condition, /* a condition name. */ cleanup condition, /* a condition name. */ archive_$list_components entry (ptr, fixed bin(24), fixed bin, ptr, ptr, fixed bin, fixed bin(35)), find_char_$first_in_table entry (char(*), char(512) aligned) returns (fixed bin(21)) reducible, get_ring_ entry returns (fixed bin(5)), hcs_$get_author entry (char(*), char(*), fixed bin(1), char(*), fixed bin(35)), hcs_$get_max_length entry (char(*), char(*), fixed bin(35), fixed bin(35)), hcs_$get_safety_sw entry (char(*), char(*), bit(1), fixed bin(35)), hcs_$initiate entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35)), hcs_$list_acl entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)), hcs_$list_dir_acl entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)), hcs_$list_inacl_all entry (char(*), ptr, ptr, ptr, fixed bin(35)), (hcs_$dir_quota_read, hcs_$quota_read) entry (char(*), fixed bin(35), fixed bin(71), bit(36), fixed bin(35), fixed bin(1), fixed bin(35), fixed bin(35)), hcs_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35)), hcs_$status_for_backup entry (char(*), char(*), ptr, fixed bin(35)), hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)), hcs_$terminate_noname entry (ptr, fixed bin(35)), lib_free_node_$array entry (ptr), lib_free_node_$descriptors entry (ptr), lib_ptr_and_bc_ entry (ptr, fixed bin, ptr, ptr, fixed bin(24), fixed bin(35)), match_star_name_ entry (char(*), char(*)) returns (fixed bin(35)), msf_manager_$acl_list entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin (35)), msf_manager_$close entry (ptr), msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35)), object_info_$display entry (ptr, fixed bin(24), ptr, fixed bin(35)), smart_alloc_$area_full entry (fixed bin, ptr, bit(70) aligned); dcl /* static variables */ /* length of an archive component header (in bits)*/ Lnode_string fixed bin int static init (0), /* length of a node (in bits). */ Lrecord fixed bin(35) int static init (0), /* length of a record (in bits). */ NO_MATCH fixed bin(2) unsigned int static options(constant) init(3), (Svalid_added_status, Svalid_archive, Svalid_archive_comp, Svalid_directory, Svalid_link, Svalid_msf, Svalid_msf_comp, Svalid_object_info, Svalid_root init(""b), Svalid_segment) bit(72) aligned int static, (archive_data_$header_begin, archive_data_$header_end, archive_data_$ident) char(8) aligned ext static, (error_table_$archive_fmt_err, error_table_$logical_volume_not_connected, error_table_$noalloc, error_table_$nomatch, error_table_$notalloc, error_table_$out_of_bounds, error_table_$process_stopped, error_table_$toomanylinks, error_table_$typename_not_found) fixed bin(35) ext static, find_char_$not_ascii_table char(512) aligned external static, ring fixed bin(5) int static init(8), /* current validation level. */ sys_info$maxlinks fixed bin(35) ext static, sys_info$page_size fixed bin(35) ext static; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ Acode = 0; if Svalid_root = ""b then call init_Svalid(); if ring > 7 then ring = get_ring_(); if Lnode_string = 0 then do; Lnode_string = size(node) * 36; Lrecord = sys_info$page_size * 36; end; Schase_links = 0; Pparent = APparent; /* copy input argument for use by internal subr. */ Pnodes = null; /* initialize output arguments. */ PDnodes = null; /* initialize node structure ptr. */ Parch = null; /* initialize temporary pointer so that cleanup */ /* can see if segment must be terminated. */ on cleanup call terminate_archive; /* cleanup by terminating any archive. */ type = Pparent -> node.T; /* get parent's node type. */ go to proc_node(type); /* process each node, according to its type. */ proc_node(1): /* don't process nodes whose parents are */ proc_node(4): /* segments, archive components, or msf */ proc_node(6): /* components any further. */ return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ proc_node(0): error = fatal; /* processing used when parent is a link. Any */ /* error is fatal. */ if link_level > sys_info$maxlinks then do; /* too many consecutive links can get us into a */ code = error_table_$toomanylinks; /* loop. Use the system-defined limit for */ go to error; /* consecutive links to prevent this. */ end; ent = ""; /* use path as entire path name of link. */ call get_node_array (1); /* get a node array containing only a single node.*/ call init_node; /* initialize this node. */ Schase_links = binary (Sc.chase, 1); /* interpret link chase switch here. */ call status_long ((path), ent); /* get status info about the item linked to. */ /* store this information in the node. */ stop_search = end_search; call director_caller; /* let director have a chance to validate node. */ end_search: Pnodes = PDnodes; /* return ptr to the node array descriptor. */ return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ proc_node(2): /* processing used when parent is a directory. */ if starname.N > 1 then /* process multiple starnames in outer ring. */ ent = "**"; else /* let ring 0 process single starname. */ ent = starname(1).V; go to call_star; proc_node(3): /* processing used when parent is an msf. */ ent = "**"; /* return information about all msf components. */ call_star: call_id = "0"b; /* initialize call id, so that it will be set the */ /* first time smart_alloc_$area_full is called. */ call_again: call hcs_$star_ ((path), ent, star_ALL_ENTRIES, Parea, star_entry_count, star_entry_ptr, star_names_ptr, code); /* get the name and type of each matching entry */ /* in the directory. */ if code = error_table_$notalloc then do; /* if the current SSA of the MSA is full, */ call smart_alloc_$area_full (0, Parea, call_id); go to call_again; /* get another SSA in the MSA, and try again. */ end; else if code ^= 0 then /* treat any other status code as a fatal error. */ go to fatal; count = star_entry_count; /* find out how many entries match any starname. */ go to star_test(type); /* no checking needed for msfs. */ star_test(2): if starname.N > 1 then do; /* compare entry names with starnames. Flag */ do i = 1 to star_entry_count; /* entry type with "11"b for non-matches. */ do j = star_entries(i).nindex to star_entries(i).nindex + star_entries(i).nnames - 1; do k = 1 to starname.N; go to dir_test(starname(k).C); dir_test(0): if star_names(j) = starname(k).V then go to dir_match; go to dir_nomatch; dir_test(1): if match_star_name_(star_names(j), starname(k).V) = 0 then go to dir_match; dir_nomatch: end; end; star_entries(i).type = NO_MATCH; /* Flag entry as non-matching. */ count = count - 1; /* Exclude it from entry count. */ dir_test(2): dir_match: end; if count = 0 then do; code = error_table_$nomatch; go to fatal; end; end; star_test(3): call get_node_array (count); /* get a node array with 1 node for each matching */ /* entry in the directory. */ error = record_and_skip; /* record any errors returned by status. */ stop_search = star_test_stop; do i = star_entry_count to 1 by -1; /* fill in nodes, one by one, most recently */ /* created first. */ if star_entries(i).type = NO_MATCH then go to next_entry; /* Ignore this entry. It didn't match. */ /* then discard the erring entry, and continue. */ call init_node; /* initialize this node. */ call status_long ((path), star_names (star_entries(i).nindex)); /* fill status of this entry into the node. */ call director_caller; /* the director has his chance at the node now. */ go to next_entry; /* if director OKed node, then fill in next one. */ record_and_skip: if Dnodes.C ^= error_table_$logical_volume_not_connected then Dnodes.C = code; /* remember what the last code was from status. */ call lib_free_node_$descriptors (Pnode); /* free any node descriptors. */ Inode = Inode - 1; /* reuse this node for the next entry. */ next_entry: end; star_test_stop: free star_names in (area_var), /* free name list returned by star_. */ star_entries in (area_var); /* free entry array returned by star_. */ Dnodes.N = Inode; /* store count of nodes we've filled into descr. */ if Inode = 0 then do; /* if no nodes were filled (because of bad status */ if Dnodes.C ^= 0 then code = Dnodes.C; else code = error_table_$nomatch; /* or director rejection), then tell parent node. */ go to fatal; end; else Dnodes.C = 0; Pnodes = PDnodes; /* return ptr to the node array descriptor. */ return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ proc_node(5): /* processing used when parent node is an archive */ error = terminate_arch; /* terminate the archive if an error occurs. */ call lib_ptr_and_bc_ (Pparent, 0, null, Parch, bit_count, code); if code ^= 0 then go to error; /* get ptr to, and bit count of, parent archive. */ PDarch = addr (PBDarch); /* make PBDarch point to the first archive */ /* descriptor (Darch) we create. */ PBDarch = null; /* to start with, there are no descriptors. */ Nentries = 0; call_id = "0"b; get_components: on area go to arch_expand_area; call archive_$list_components (Parch, bit_count, ARCHIVE_COMPONENT_INFO_VERSION_1, Parea, archive_component_info_ptr, n_components, code); revert area; if code ^= 0 then do; call terminate_archive; go to fatal; end; do j = 1 to n_components; do k = 1 to starname.N; go to arch_test(starname(k).C); arch_test(0): if starname (k).V = archive_component_info_array (j).name then go to arch_match; go to arch_nomatch; arch_test(1): if match_star_name_ (archive_component_info_array (j).name, starname (k).V) = 0 then go to arch_match; go to arch_nomatch; arch_test(2): arch_match: Nnames = 1; /* create a name descriptor; use temporarily as */ allocate Dnames in (area_var) set (Ptemp); /* archive component descriptor until we find out */ Darch.Pnext = Ptemp; PDarch = Ptemp; /* how many matching archive components exist. */ Darch.Pnext = null (); Darch.Parch = archive_component_info_array (j).comp_ptr; Darch.name = archive_component_info_array (j).name; Darch.bit_count = archive_component_info_array (j).comp_bc; clock = archive_component_info_array (j).time_modified; Darch.dtm = substr (clock_string, 21, 36); clock = archive_component_info_array (j).time_updated; Darch.dtupdated = substr (clock_string, 21, 36); Darch.Smode = substr (archive_component_info_array (j).access, 1, 3); Nentries = Nentries + 1; if starname.N = 1 then if starname (1).C = 0 then go to arch_test_done; arch_nomatch: end; end; free archive_component_info_array in (area_var); arch_test_done: /* if a format error occurred, or if we scanned */ if Nentries = 0 then do; /* thru entire archive, or if no *'s in star name,*/ if code = error_table_$archive_fmt_err then; /* then if no matching components were found, */ else /* store an error code in patent node, terminate */ code = error_table_$nomatch; /* the archive, and return. */ terminate_arch: call terminate_archive; go to fatal; end; stop_search = arch_test_stop; error = director_reject; /* errors in this section are caused by the */ /* director's rejection of a node. */ call get_node_array (Nentries); /* get node array with 1 node for each matching */ /* component. */ if Dnodes.C ^= error_table_$logical_volume_not_connected then Dnodes.C = code; /* save any archive format error. */ PDarch = PBDarch; /* starting at head of descriptor chain, */ do i = 1 to Nentries; /* scan thru component descriptors, filling */ /* in a node for each matching component. */ call init_node; /* initialize the node. */ node.bit_count = Darch.bit_count; /* store bit count from descriptor. */ node.Smode = Darch.Smode; /* store mode. */ node.dtm = Darch.dtm; /* store dtm. */ node.dtem = Darch.dtupdated; /* store dtem. */ PDnames = PDarch; /* use archive descriptor as name descriptor. */ Parch = Darch.Parch; /* but first, save ptr to archive component. */ PDarch = Darch.Pnext; /* Also, save ptr to next descriptor. */ Dnames.N = 1; /* set number of names in descriptor to 1. */ Dnames.length = size (Dnames); /* store length of descriptor. */ Dnames.version = Vnames_1; /* and version number. */ Dnames.Pnext = node.PD; /* chain descriptor to node. */ node.PD = PDnames; Dnames.T = Tnames; /* specify this is a name descriptor. */ node.current_length = divide (node.bit_count + Lrecord - 1, Lrecord, 35, 0); /* compute current length (in records) from */ /* component's bit count. */ node.offset = binary (rel (Parch), 18); /* fill in component's offset from base of segment*/ /* containing the archive. This works */ /* for archived archives, too. */ node.Svalid = Svalid_archive_comp; /* indicate which basic node fields are valid. */ if Sc.check_ascii then do; /* see if component contents is printable. */ call test_ascii (Parch, node.bit_count, flags.ascii); Svalid.not_ascii = ^flags.ascii; end; else do; flags.ascii = "0"b; end; flags.archive = "0"b; /* assume component is not an archived archive. */ if Sc.check_archive then flags.archive = test_archive (node.bit_count); if flags.archive then node.T = Tarchive; else do; node.T = Tarchive_comp; if flags.ascii & Sc.check_ascii then; else if Sc.object_info then do; /* see if component is an object component. */ flags.object_seg = object_seg_ (Parch, node.bit_count); if flags.object_seg then node.Svalid = node.Svalid | Svalid_object_info; end; end; node.Sreq = node.Svalid & Srequirements; /* say which fields are required for output. */ call director_caller; /* let the director validate this node. */ go to end_component; /* all done for this component. */ director_reject: /* if director rejected this node, then */ call lib_free_node_$descriptors (Pnode); /* free node's descriptors. */ Inode = Inode - 1; /* reuse this node for next component. */ end_component: end; arch_test_stop: Dnodes.N = Inode; /* record number of filled nodes in node array. */ call terminate_archive; /* terminate the archive. */ if Inode = 0 then do; /* if no acceptable components were found, */ if code = error_table_$archive_fmt_err then; /* set error code in a null node array descriptor.*/ else code = error_table_$nomatch; go to fatal; end; Pnodes = PDnodes; /* return ptr to the node array descriptor. */ return; arch_expand_area: /* let msa_manager_ expand the area */ revert area; call smart_alloc_$area_full (0, Parea, call_id); go to get_components; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ fatal: /* this is the global exit for errors which are */ /* fatal to the process of getting a node array. */ if PDnodes ^= null then do; /* if a node array was allocated, free it. */ Dnodes.N = Inode; /* store count of number of filled node in descr. */ call lib_free_node_$array (PDnodes); end; call get_node_array (0); /* get a node descriptor with zero nodes. */ if Dnodes.C ^= error_table_$logical_volume_not_connected then Dnodes.C = code; /* fill in its error code. */ Pnodes = PDnodes; /* return this error code descriptor. */ return; /* You lose, buddy. Too bad. */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* A D D I T I O N A L E N T R Y P O I N T S */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ root_array: entry (MNnodes, Parea, Pnodes, Acode); call get_node_array(MNnodes); /* get a node array of specified length. */ Dnodes.N = 0; /* record current length of node array. */ Pnodes = PDnodes; /* return pointer to node array. */ Acode = 0; return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ root_array_info: entry (Pnodes, MNnodes, Acode); PDnodes = Pnodes; /* address the specified node array. */ MNnodes = Dnodes.N; /* return current dimension of array, and any */ Acode = Dnodes.C; /* error code returned while getting array. */ return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ lib_root_node: entry (Proot_names, root_type, path, root_search_proc, Pstarname, Pexclude, Srequirements, Scontrol, Parea, director, Pdirector_args, Pnodes, MNnodes, Acode); e = 1; go to COMMON; root_node: entry (Proot_names, root_type, path, Pstarname, Pexclude, Srequirements, Scontrol, Parea, director, Pdirector_args, Pnodes, MNnodes, Acode); e = 2; COMMON: if Svalid_root = ""b then call init_Svalid(); /* initialize internal static variables. */ Pparent = null; /* a root node has no parent node. */ PDnodes = Pnodes; /* address the root node array. */ if Dnodes.N = MNnodes then do; /* make sure array isn't full. */ Acode = error_table_$out_of_bounds; return; end; if root_type ^= Tdirectory then if root_type ^= Tarchive then do; Acode = error_table_$typename_not_found; return; end; Inode = Dnodes.N; /* address the last filled node of array. */ Dnodes.N = Dnodes.N + 1; /* extend current length of array. */ call init_node; /* initialize new node. */ link_node.T = root_type; /* fill in root type. */ link_node.Svalid = Svalid_root; /* valid fields. */ Nnames = root_names.N; /* names. */ if Nnames > 0 then do; allocate Dnames in (area_var); Dnames.length = size (Dnames); Dnames.version = Vnames_1; Dnames.Pnext = link_node.PD; link_node.PD = PDnames; Dnames.T = Tnames; Dnames.names(*) = root_names.root_name(*); end; else do; Svalid.primary_name = "0"b; Svalid.matching_names = "0"b; Svalid.names = "0"b; end; link_node.link_target = path; /* path. */ if e = 1 then if length(root_search_proc) > 0 then do; allocate Dsearch_proc in (area_var); Dsearch_proc.length = size(Dsearch_proc); Dsearch_proc.version = Vsearch_proc_1; Dsearch_proc.Pnext = link_node.PD; link_node.PD = PDsearch_proc; Dsearch_proc.T = Tsearch_proc; Dsearch_proc.search_proc = root_search_proc; Svalid.root_search_proc = "1"b; end; node.Sreq = node.Svalid & Srequirements; /* required fields. */ Acode = 0; /* no more errors from here on can affect code. */ error = root_error; stop_search = root_stop; call director_caller; /* search this root for entries matching starname.*/ root_stop: return; root_error: if Dnodes.C ^= error_table_$logical_volume_not_connected then Dnodes.C = code; /* remember last root error code. */ call lib_free_node_$descriptors (Pnode); Dnodes.N = Dnodes.N - 1; /* remove node from array. */ return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* I N T E R N A L P R O C E D U R E S */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ cv_num: proc (n) returns (char(32)); /* procedure to convert integer to char string. */ dcl n fixed bin, /* number to be converted. (In) */ char32 char(32), /* the result. */ i fixed bin, pic pic "zzzzzzzzzzzz9"; pic = n; i = verify (pic, " "); char32 = substr(pic,i); return (char32); end cv_num; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ director_caller: procedure; /* This internal procedure is called in order to */ /* have the director validate each node after it */ /* has been filled, but before the next node */ /* in the array is filled. If the director */ /* rejects the node, then this procedure */ /* branches to the caller's error handler. */ code = 0; /* initialize search director's return code */ PD = null; /* and output node ptr. */ if node.Pparent = null then /* for a root node, pass the root path, tree level*/ /* 1, link level 0. */ call director (Pnode, link_node.link_target, Pstarname, Pexclude, Srequirements, Scontrol, 1, 0, Parea, director, Pdirector_args, PD, code); else if node.T = Tlink then /* for the first link in a chain, pass the link */ if link_level = 0 then /* path and increment both tree and link level. */ call director (Pnode, link_node.link_target, Pstarname, Pexclude, Srequirements, Scontrol, tree_level+1, link_level+1, Parea, director, Pdirector_args, PD, code); else /* for succeeding links in a chain, pass the link */ /* path and increment just the link level. */ call director (Pnode, link_node.link_target, Pstarname, Pexclude, Srequirements, Scontrol, tree_level, link_level+1, Parea, director, Pdirector_args, PD, code); else if link_level > 0 then /* for the target of a link, pass on the target */ /* path, zero the link level, and pass on the */ /* current tree level. */ call director (Pnode, path, Pstarname, Pexclude, Srequirements, Scontrol, tree_level, 0, Parea, director, Pdirector_args, PD, code); else do; /* otherwise, compute path by adding node's 1st */ /* name to path we rec'd as input, increment */ /* the tree level, and zero the link level. */ j = min(32, 33-verify(reverse(Dnames.names(1)), " ")); if path = ">" then call director (Pnode, path || substr (Dnames.names(1), 1, j), Pstarname, Pexclude, Srequirements, Scontrol, tree_level+1, 0, Parea, director, Pdirector_args, PD, code); else call director (Pnode, path || ">" || substr (Dnames.names(1), 1, j), Pstarname, Pexclude, Srequirements, Scontrol, tree_level+1, 0, Parea, director, Pdirector_args, PD, code); end; if PD ^= null then do; /* if the director created a node descriptor, */ D.Pnext = node.PD; /* attach it to the node. */ node.PD = PD; Svalid.kids = "1"b; if PD -> Dnodes.C ^= 0 then do; /* validate the error code, if there was one. */ Svalid.kids_error = "1"b; Sreq.kids_error = S.kids_error; Sreq.primary_name = Sreq.primary_name | S.kids_error; end; end; if code = error_table_$process_stopped then go to stop_search; else if code ^= 0 then /* if the director rejected the node for any */ go to error; /* reason, then go to the caller's error handler. */ end director_caller; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ get_acl: procedure (dir, ent); /* Internal procedure called to get ACL for a */ /* segment, and store it in a segment ACL */ /* descriptor. */ dcl dir char(*), /* dir part of segment's path name. (In) */ ent char(*); /* ent part of segment's path name. (In) */ call_id = "0"b; /* initialize id used for smart_alloc_. */ acl_again: call hcs_$list_acl (dir, ent, Parea, Pacl, null, Nacls, code); if code = error_table_$noalloc then do; /* if our SSA of MSA was full, get another one. */ call smart_alloc_$area_full (0, Parea, call_id); go to acl_again; end; else if code ^= 0 then Nacls = 0; /* fake it if there is no ACL. */ /* if no trouble getting ACL, get access class. */ allocate Dacl in (area_var); Dacl.length = size(Dacl); Dacl.version = Vacl_1; Dacl.Pnext = node.PD; /* chain ACL descriptor to the node. */ node.PD = PDacl; Dacl.T = Tacl; Dacl.C = code; Dacl.N = Nacls; if Dacl.N > 0 then Dacl.acls = acl; /* copy ACL into descriptor. */ end get_acl; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ get_dir_acl: procedure (dir, ent); /* Internal procedure to get ACL for a directory */ /* and store it in a directory ACL descriptor. */ dcl dir char(*), /* dir part of directory's path name. (In) */ ent char(*); /* ent part of directory's path name. (In) */ call_id = "0"b; /* initialize id used for smart_alloc_. */ dir_acl_again: call hcs_$list_dir_acl (dir, ent, Parea, Pdir_acl, null, Ndir_acls, code); if code = error_table_$noalloc then do; /* if our SSA of MSA was full, get another one. */ call smart_alloc_$area_full (0, Parea, call_id); go to dir_acl_again; end; else if code ^= 0 then Ndir_acls = 0; /* fake it if there is no ACL. */ /* if no trouble getting ACL, get access class. */ allocate Ddir_acl in (area_var); Ddir_acl.length = size(Ddir_acl); Ddir_acl.version = Vdir_acl_1; Ddir_acl.Pnext = node.PD; /* chain descriptor onto node. */ node.PD = PDdir_acl; Ddir_acl.T = Tdir_acl; Ddir_acl.C = code; Ddir_acl.N = Ndir_acls; if Ddir_acl.N > 0 then Ddir_acl.acls = dir_acl; /* copy ACL into descriptor. */ end get_dir_acl; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ get_iacls: procedure (dir, ent); /* Internal procedure to get all IACLs for a */ /* directory and store them in an IACL descriptor.*/ dcl dir char(*), /* dir part of directory's path name. (In) */ ent char(*), /* ent part of directory's path name. (In) */ i fixed bin, /* a do-group index. */ path char(168); /* directory's path name. */ path = dir || ">" || ent; call_id = "0"b; /* initialize id used for smart_alloc_. */ iacl_again: call hcs_$list_inacl_all (path, Parea, Piacl, addr(iacl_info), code); if code = error_table_$noalloc then do; /* if our SSA of MSA was full, get another one. */ call smart_alloc_$area_full (0, Parea, call_id); go to iacl_again; end; else if code ^= 0 then /* fake it if a fatal error occurred. */ do i = 0 to 7; iacl_info.seg.counts(i) = 0; iacl_info.dir.counts(i) = 0; end; Niacls, Ndir_iacls = 0; do i = 0 to 7; /* add up counts of IACL entries. */ Niacls = Niacls + iacl_info.seg.counts(i); Ndir_iacls = Ndir_iacls + iacl_info.dir.counts(i); end; allocate Diacl in (area_var); /* fill in the segment IACL descriptor. */ Diacl.length = size(Diacl); Diacl.version = Viacl_1; Diacl.Pnext = node.PD; /* chain descriptor onto node. */ node.PD = PDiacl; Diacl.T = Tiacl; Diacl.C = code; Diacl.N = Niacls; Diacl.N = 1; /* copy IACLs into descriptor. */ do i = 0 to 7; Diacl.Iring(i) = Diacl.N; Diacl.Nring(i) = iacl_info.seg.counts(i); if iacl_info.seg.counts(i) > 0 then do; Pacl = addrel(Piacl, iacl_info.seg.offsets(i)); Nacls = iacl_info.seg.counts(i); addr(Diacl.acls(Diacl.N)) -> acl = acl; Diacl.N = Diacl.N + Nacls; end; end; Diacl.N = Diacl.N - 1; allocate Ddir_iacl in (area_var); /* fill in the directory IACL descriptor. */ Ddir_iacl.length = size(Ddir_iacl); Ddir_iacl.version = Vdir_iacl_1; Ddir_iacl.Pnext = node.PD; /* chain descriptor onto node. */ node.PD = PDdir_iacl; Ddir_iacl.T = Tdir_iacl; Ddir_iacl.C = code; Ddir_iacl.N = Ndir_iacls; Ddir_iacl.N = 1; /* copy IACLs into descriptor. */ do i = 0 to 7; Ddir_iacl.Iring(i) = Ddir_iacl.N; Ddir_iacl.Nring(i) = iacl_info.dir.counts(i); if iacl_info.dir.counts(i) > 0 then do; Pdir_acl = addrel(Piacl, iacl_info.dir.offsets(i)); Ndir_acls = iacl_info.dir.counts(i); addr(Ddir_iacl.acls(Ddir_iacl.N)) -> dir_acl = dir_acl; Ddir_iacl.N = Ddir_iacl.N + Ndir_acls; end; end; Ddir_iacl.N = Ddir_iacl.N - 1; end get_iacls; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ get_msf_acl: procedure (dir, ent); /* Internal procedure to get ACL for an MSF, */ /* and store it in a segment ACL descriptor. */ dcl dir char(*), /* dir part of MSF's path name. (In) */ ent char(*); /* ent part of MSF's path name. (In) */ call msf_manager_$open (dir, ent, Ptemp, code); /* open the MSF. */ if code = 0 then do; call_id = "0"b; /* initialize id used for smart_alloc_. */ msf_acl_again: call msf_manager_$acl_list (Ptemp, Parea, Pacl, null, Nacls, code); if code = error_table_$noalloc then do; /* if our SSA of MSA is full, get another one. */ call smart_alloc_$area_full (0, Parea, call_id); go to msf_acl_again; end; end; if code ^= 0 then Nacls = 0; /* fake it if there is no ACL. */ /* if no trouble getting ACL, get access class. */ allocate Dacl in (area_var); Dacl.length = size(Dacl); Dacl.version = Vacl_1; Dacl.Pnext = node.PD; /* chain descriptor onto the node. */ node.PD = PDacl; Dacl.T = Tacl; Dacl.C = code; Dacl.N = Nacls; if Dacl.N > 0 then Dacl.acls = acl; /* copy ACL into descriptor. */ call msf_manager_$close (Ptemp); /* close the MSF. */ end get_msf_acl; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ get_node_array: procedure (N); /* This internal procedure allocates a node array */ /* and initializes its header. */ dcl N fixed bin; /* Number of nodes to be allocated in the array. */ Nnodes = N; /* set variable which controls number of nodes */ /* which get allocated in our adjustable based */ /* array. */ allocate Dnodes in (area_var); /* allocate the node array descriptor. */ Dnodes.length = size (Dnodes); /* fill in its size, */ Dnodes.version = Vnodes_1; /* version, */ Dnodes.Pnext = null; /* next descriptor ptr, and */ Dnodes.header.T = Tnodes; /* type. */ Dnodes.C = 0; /* clear its error code. */ Inode = 0; /* initialize number of filled nodes to zero. */ end get_node_array; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ init_Svalid: procedure; /* Internal procedure which initializes the */ /* internal static constants defining which of */ /* the basic node fields are valid for each type */ dcl Srequirements bit(72) aligned, /* of node. */ 1 S like Svalid_req based (addr(Srequirements)); string(S) = ""b; S.primary_name = "1"b; S.matching_names = "1"b; S.names = "1"b; S.type = "1"b; S.pathname = "1"b; S.dtem = "1"b; S.dtd = "1"b; S.link_target = "1"b; S.new_line = "1"b; S.level = "1"b; S.cross_ref = "1"b; Svalid_link = Srequirements; string(S) = ""b; S.primary_name = "1"b; S.matching_names = "1"b; S.names = "1"b; S.type = "1"b; S.pathname = "1"b; S.dtm = "1"b; S.dtu = "1"b; S.dtem = "1"b; S.dtd = "1"b; S.current_length = "1"b; S.records_used = "1"b; S.bit_count = "1"b; S.max_length = "1"b; S.lvid = "1"b; S.mode = "1"b; S.rb = "1"b; S.copy = "1"b; S.safety = "1"b; S.unique_id = "1"b; S.new_line = "1"b; S.level = "1"b; S.cross_ref = "1"b; Svalid_segment = Srequirements; Svalid_msf_comp = Srequirements; Svalid_archive = Srequirements; S.max_length = "0"b; S.copy = "0"b; S.msf_indicator = "1"b; Svalid_msf = Srequirements; S.bit_count = "0"b; S.msf_indicator = "0"b; Svalid_directory = Srequirements; string(S) = ""b; S.dtc = "1"b; S.compiler_name = "1"b; S.compiler_version = "1"b; S.compiler_options = "1"b; S.object_info = "1"b; Svalid_object_info = Srequirements; string(S) = ""b; S.primary_name = "1"b; S.matching_names = "1"b; S.names = "1"b; S.type = "1"b; S.pathname = "1"b; S.dtm = "1"b; S.dtem = "1"b; S.current_length = "1"b; S.bit_count = "1"b; S.offset = "1"b; S.mode = "1"b; S.new_line = "1"b; S.level = "1"b; S.cross_ref = "1"b; Svalid_archive_comp = Srequirements; string(S) = ""b; S.primary_name = "1"b; S.matching_names = "1"b; S.names = "1"b; S.type = "1"b; S.pathname = "1"b; S.new_line = "1"b; S.level = "1"b; S.cross_ref = "1"b; Svalid_root = Srequirements; string(S) = ""b; S.access_class = "1"b; S.aim = "1"b; S.author = "1"b; S.bit_count_author = "1"b; S.entry_bound = "1"b; S.pvid = "1"b; Svalid_added_status = Srequirements; end init_Svalid; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ init_node: procedure; /* This internal procedure initializes a node. */ Inode = Inode + 1; /* increment the filled node count to get the next*/ /* available node. */ Pnode = addr (Dnodes.nodes (Inode)); /* access the node. */ node_string = ""b; /* zero out storage occupied by node. */ node.Pparent = Pparent; node.PD = null; /* initialize the node's pointers. */ end init_node; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ object_seg_: procedure (Pseg, bit_count) /* This internal procedure checks to see if a */ returns (bit(1) aligned); /* segment is an object segment and, if so, it */ /* appends an object_info_ descriptor to the node */ /* which represents the segment. */ dcl Pseg ptr, /* ptr to the segment. */ bit_count fixed bin(35); /* bit count of the segment. */ /* overlay for object segment strings. */ oi.version_number = object_info_version_2; /* initialize the object_info_ structure. */ call object_info_$display (Pseg, binary(bit_count, 24), addr(oi), code); if code ^= 0 then /* let object_info_ decide if this is an obj seg. */ return ("0"b); allocate Dobj in (area_var); /* create an object_info_ descriptor. */ Dobj.version = Vobj_1; /* initialize its header. */ Dobj.length = size (Dobj); Dobj.T = Tobj; Dobj.Pnext = node.PD; node.PD = PDobj; Dobj.info.Otext = binary (rel (oi.textp), 18); /* fill in the structure, converting pointers */ Dobj.info.Odefinitions = binary (rel (oi.defp),18);/* to offsets. */ Dobj.info.Olink = binary (rel (oi.linkp), 18); Dobj.info.Ostatic = binary (rel (oi.statp), 18); Dobj.info.Osymbols = binary (rel (oi.symbp), 18); Dobj.info.Obreaks = binary (rel (oi.bmapp), 18); Dobj.info.Ltext = oi.tlng; Dobj.info.Ldefinitions = oi.dlng; Dobj.info.Llink = oi.llng; Dobj.info.Lstatic = oi.ilng; Dobj.info.Lsymbols = oi.slng; Dobj.info.Lbreaks = oi.blng; string (Dobj.info.format) = string (oi.format); Dobj.info.entry_bound = oi.entry_bound; Dobj.info.Otext_links = binary (rel (oi.textlinkp), 18); Dobj.info.compiler = oi.compiler; Dobj.info.compile_time = oi.compile_time; Dobj.info.userid = oi.userid; Dobj.info.cversion.O = Dobj.info.Osymbols + binary (oi.cvers.offset, 18); Dobj.info.cversion.L = binary (oi.cvers.length, 18); Dobj.info.comment.O = Dobj.info.Osymbols + binary (oi.comment.offset, 18); Dobj.info.comment.L = binary (oi.comment.length, 18); Dobj.info.Osource = Dobj.info.Osymbols + oi.source_map; Pstring_ = pointer (Pseg, Dobj.info.cversion.O); Lstring_ = Dobj.info.cversion.L; Dobj.cversion = string_; Pstring_ = pointer (Pseg, Dobj.info.comment.O); Lstring_ = Dobj.info.comment.L; Dobj.comment = string_; return ("1"b); end object_seg_; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ status_long: procedure (dir, ent); /* This procedure calls hcs_$status_long to get */ /* status information for dir>ent, and fills this */ /* information in the node. */ dcl dir char(*), /* dir part of path of entry to get status of.(In)*/ ent char(*); /* ent path of path of entry to get status of.(In)*/ dcl i fixed bin; /* do-group index. */ call_id = "0"b; /* initialize call id so that it will be set on */ /* our first call to smart_alloc_$area_full. */ status_ptr = addr (auto_status_branch); call_again: status_area_ptr = Parea; call hcs_$status_long (dir, ent, Schase_links, addr (status_branch), Parea, code); if code = error_table_$noalloc then do; /* if our SSA of MSA was full, get another SSA by */ /* calling smart_alloc_$area_full. */ call smart_alloc_$area_full (0, Parea, call_id); go to call_again; /* try getting status info again. */ end; else if code ^= 0 then /* return to caller's error handler for any other */ go to error; /* error. */ Nnames = status_branch.nnames; /* compute number of names. */ allocate Dnames in (area_var); /* store them in a name descriptor, attached to */ Dnames.length = size (Dnames); /* the node. */ Dnames.version = Vnames_1; Dnames.T = Tnames; addr(Dnames.names)->status_entry_names = status_entry_names; free status_entry_names in (area_var); /* copy names into the descriptor. */ go to type (status_branch.type); /* do rest of processing according to type of */ /* entry we got the status of. */ type(0): link_node.T = Tlink; /* this is a link! */ link_node.link_target = status_pathname; free status_pathname in (area_var); /* free the link path name status returned. */ link_node.dtem = status_link.dtem; /* fill in the dates. */ link_node.dtd = status_link.dtd; link_node.Svalid = Svalid_link; /* record which attributes of link_node are valid.*/ if Sc.all_status then do; call hcs_$get_author (dir, ent, 0, author, 0); link_node.author = rtrim(author); Svalid.author = "1"b; end; link_node.Sreq = link_node.Svalid & Srequirements;/* record which are required for output. */ Dnames.Pnext = node.PD; /* make name descriptor first in the chain of */ node.PD = PDnames; /* descriptors off node. It's referenced most. */ return; /* not much processing for a link node. */ type(1): /* this is a segment! */ node.Smode = substr (status_branch.mode, 2, 3); /* map "xrewx" into "rew". */ node.rb = status_branch.ring_brackets; /* copy ring brackets into node. */ node.records_used = status_branch.records_used; node.current_length = status_branch.current_length; /* copy the current length. */ node.bit_count = status_branch.bit_count; /* copy the bit count. */ call hcs_$get_max_length (dir, ent, node.max_length, code); call test_segment (dir, ent, flags); /* find out about segment. */ if Pparent -> node.T = Tmsf then do; /* is it an msf component? */ node.T = Tmsf_comp; /* yes. */ node.Svalid = Svalid_msf_comp; if flags.archive then /* MSF component is also an archive. Hum! */ go to process_archive; else /* process flags further, and set requirements */ go to process_segment; /* switches in node. */ end; else if flags.archive then do; /* is it an archive? */ node.Svalid = Svalid_archive; process_archive: node.T = Tarchive; Svalid.not_ascii = ^flags.ascii; end; else do; /* otherwise, it's just a plain segment. */ node.T = Tsegment; node.Svalid = Svalid_segment; process_segment: if flags.object_seg then /* if an object segment, say so. */ node.Svalid = node.Svalid | Svalid_object_info; Svalid.not_ascii = ^flags.ascii; /* say whether segment is printable or not. */ end; if Sc.acl & (node.T ^= Tmsf_comp) then do; /* get ACL for segment or archive. */ call get_acl (dir, ent); /* This call automatically chains ACL to node. */ Svalid.acl = "1"b; end; go to fill_node; /* fill remainder of node from status block. */ type(2): /* this is a directory! */ node.records_used = status_branch.records_used; node.current_length = status_branch.current_length; if status_branch.bit_count = 0 then do; /* is it a directory? */ node.T = Tdirectory; /* yes, it is. */ node.Svalid = Svalid_directory; substr (node.Smode, 1, 1) = substr (status_branch.mode, 2, 1); substr (node.Smode, 2, 2) = substr (status_branch.mode, 4, 2); /* map "xsxma" into "sma". */ node.rb = status_branch.ring_brackets; if Sc.acl then do; /* get acl of directory. */ call get_dir_acl (dir, ent); /* This call automatically chains ACL to node. */ Svalid.acl = "1"b; end; if Sc.iacl then do; /* get initial ACLs associated with directory. */ call get_iacls (dir, ent); /* This call automatically chains IACLs to node.*/ Svalid.iacl = "1"b; end; end; else do; /* is it an MSF? */ node.T = Tmsf; /* yes, it is. */ node.Svalid = Svalid_msf; substr (node.Smode, 1, 1) = substr (status_branch.mode, 2, 1); substr (node.Smode, 2, 1) = "0"b; /* map "xsxmx" dir mode into "rxw" seg mode. */ substr (node.Smode, 3, 1) = substr (status_branch.mode, 4, 1); node.rb(1) = status_branch.ring_brackets(1); node.rb(2) = status_branch.ring_brackets(2); node.rb(3) = status_branch.ring_brackets(2); /* map dir rb's into seg rb's. */ node.msf_indicator = status_branch.bit_count; if dir = ">" then msf_dir = dir || ent; else msf_dir = dir || ">" || ent; do i = 0 to node.msf_indicator - 1; /* get aggregate records_used, current_length, */ char32 = cv_num(i); /* and bit_count for MSF dir and components. */ call hcs_$status_long (msf_dir, char32, 1, addr(msf_comp), null, code); if code = 0 then do; node.records_used = node.records_used + msf_comp.records_used; node.current_length = node.current_length + msf_comp.current_length; node.bit_count = node.bit_count + msf_comp.bit_count; end; end; if Sc.acl then do; /* get acl of MSF. */ call get_msf_acl (dir, ent); /* This call automatically chains ACL to node. */ Svalid.acl = "1"b; end; end; if Sc.quota then do; /* get quota information for MSFs and directories.*/ call hcs_$quota_read (dir||">"||ent, node.segment.quota, node.segment.trp, node.segment.dttrp, node.segment.Ninf_quota, Nterminal_account, node.segment.quota_used, code); if code ^= 0 then go to error; if Nterminal_account > 0 then node.Sterminal_account = "1"b; call hcs_$dir_quota_read (dir||">"||ent, node.directory.quota, node.directory.trp, node.directory.dttrp, node.directory.Ninf_quota, Nterminal_account, node.directory.quota_used, code); if code ^= 0 then go to error; if Nterminal_account > 0 then node.Sterminal_account_dir = "1"b; Svalid.quota = "1"b; end; fill_node: /* fill in node values from entry status. */ node.Scopy = status_branch.copy_switch; node.Stpd = status_branch.tpd_switch; /* NEED TO ADD SUPPORT FOR OTHER SWITCHES. */ call hcs_$get_safety_sw (dir, ent, node.Ssafety, code); node.unique_id = status_branch.uid; node.lvid = status_branch.lvid; node.dtem = status_branch.dtem; node.dtd = status_branch.dtd; node.dtm = status_branch.dtcm; node.dtu = status_branch.dtu; if Sc.all_status then do; /* get additional information about branches. */ sfb.version = status_for_backup_version_2; call hcs_$status_for_backup (dir, ent, addr(sfb), code); if code ^= 0 then go to error; node.Smaster_dir = sfb.master_dir; node.Saim_security_oos = sfb.security_oosw; node.Saim_audit = sfb.audit_flag; node.Saim_multiple_class = sfb.multiple_class; i = min (32, 33-verify(reverse(sfb.author)," ")); node.author = substr(sfb.author,1,i); node.access_class = sfb.access_class; i = min (32, 33-verify(reverse(sfb.bc_author), " ")); node.bit_count_author = substr(sfb.bc_author,1,i); node.entry_bound = binary (sfb.entrypt_bound,14); node.pvid = sfb.pvid; node.Svalid = node.Svalid | Svalid_added_status; if ^sfb.entrypt then do; node.entry_bound = 0; Svalid.entry_bound = "0"b; end; end; Dnames.Pnext = node.PD; /* make name descriptor first in the chain of */ node.PD = PDnames; /* descriptors off node. It's referenced most. */ node.Sreq = node.Svalid & Srequirements; end status_long; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ terminate_archive: procedure; /* This internal procedure terminates an archive */ /* if one has been initiated. */ dcl code fixed bin(35); /* a dummy status code. */ if Parch ^= null then do; call hcs_$terminate_noname (Parch, code); Parch = null; end; end terminate_archive; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ test_archive: procedure (bit_count) /* This internal procedure determines if a segment*/ returns (bit(1) aligned); /* is an archive. */ dcl bit_count fixed bin(35); if bit_count >= 900 then if arch.header_begin = archive_data_$header_begin then if arch.header_end = archive_data_$header_end then return ("1"b); else; else if arch.header_begin = archive_data_$ident then return ("1"b); return ("0"b); end test_archive; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ test_ascii: procedure (Pseg, bit_count, Sascii); /* This internal procedure checks the contents of */ /* a segment to see if it is completely ascii */ dcl Pseg ptr, /* ptr to base of segment.(In) */ bit_count fixed bin(35), /* segment's bit count.(In) */ Sascii bit(1) aligned; /* on, if ascii segment. (Out) */ dcl Inon_ascii fixed bin(21); /* index of first non-ascii character of segment. */ if bit_count = 0 then go to not_ascii; if mod (bit_count, 9) ^= 0 then do; /* segment can't contain chars if bit count bad. */ not_ascii: Sascii = "0"b; return; end; Pstring_ = Pseg; /* overlay segment with character string. */ Lstring_ = divide (bit_count, 9, 24, 0); /* compute character length of segment. */ Inon_ascii = find_char_$first_in_table (string_, find_char_$not_ascii_table); /* search for a non-ascii character in the string.*/ if Inon_ascii = 0 then /* if none found, its an ascii segment. */ Sascii = "1"b; else Sascii = "0"b; end test_ascii; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ test_segment: procedure (dir, ent, flags); /* This internal procedure examines a segment to */ /* determine if it is an archive or an object */ /* segment. */ dcl (dir, ent) char(*), /* dir/ent of segment to be tested. */ 1 flags aligned, 2 archive bit(1), /* segment is an archive. */ 2 object_seg bit(1), /* segment is an object segment. */ 2 ascii bit(1); /* segment is composed only of ascii characters. */ flags.archive = "0"b; /* initialize output flags. */ flags.object_seg = "0"b; flags.ascii = "1"b; /* assume segment is ascii until check made. */ if node.rb(2) < ring then; /* if segment is readable from our ring, */ else if ^substr(node.Smode,1,1) then; else if node.bit_count <= 0 then; /* and it has a non-zero bit count, */ else if divide(node.bit_count + Lrecord - 1, Lrecord, 35, 0) > node.current_length then; else if (Sc.check_archive & node.bit_count >= 900) | Sc.check_ascii | Sc.object_info then do; /* if caller requests archive/ascii/object info, */ call hcs_$initiate (dir, ent, "", 0, 0, Parch, code); if Parch = null then return; /* initiate the segment. */ if Sc.check_ascii then /* check for ascii segments. */ call test_ascii (Parch, node.bit_count, flags.ascii); if Sc.check_archive then /* check for archives. */ flags.archive = test_archive (node.bit_count); if flags.archive then; else if flags.ascii & Sc.check_ascii then; else if Sc.object_info then /* check for object segment. */ flags.object_seg = object_seg_ (Parch, node.bit_count); call terminate_archive; /* terminate the segment. */ end; end test_segment; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ %include lib_node_; %include archive_component_info; dcl 1 archive_component_info_array (n_components) aligned like archive_component_info based (archive_component_info_ptr); %include object_info; dcl 1 oi aligned like object_info; %include star_structures; %include status_structures; dcl 1 auto_status_branch aligned like status_branch, 1 msf_comp aligned like status_branch; end lib_get_tree_;  lib_next_name_.pl1 02/15/84 0911.2rew 02/15/84 0819.0 35640 /* *************************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1975 by Massachusetts Institute of Technology * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *************************************************************** */ lib_next_name_: procedure (Srequirements, PDnames, Iname, Pstarname) returns (char(32)); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This procedure is part of the library maintenance subsystem of tools. Documentation of*/ /* the complete subsystem is available in AN-80, Library Maintenance. */ /* This procedure, when given node requirements bits, a pointer to the names descriptor, */ /* a name index, and an array of starnames, returns the next name in the descriptor which */ /* meets the name requirements. Three cases are considered: */ /* */ /* 1) the first name is required. */ /* 2) names which match one of the starnames are required. */ /* 3) all names are required. */ /* */ /* Any combination of cases is allowed. If there are no remaining names which meet one */ /* of the requirements, then a null character string is returned. */ /* */ /* S__t_a_t_u_s */ /* */ /* 0) Created by: G. C. Dixon, May 16, 1975 */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl /* Parameters */ /* PDnames ptr, /* ptr to a names descriptor. (In) */ Iname fixed bin; /* index into name array of next name to be */ /* checked. For the first call to process a */ /* given name descriptor, this should be set to */ /* 0. (In) */ /* index of last name checked. For subsequent */ /* calls to process a given name descriptor, */ /* this output value should be used as input. */ /* (Out) */ dcl blank_name char(32) aligned int static init ((32)" "), /* a blank name or null string. */ code fixed bin(35), /* a status code. */ i fixed bin; /* a do-group index. */ dcl addr builtin; dcl match_star_name_ entry (char(*), char(*), fixed bin(35)); /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ Iname = Iname + 1; /* get index of next name. */ if Iname > Dnames.N then /* name array exhausted? Return blank name. */ return (blank_name); if S.names then /* return all names. */ return (Dnames.names(Iname)); if S.primary_name then /* return first name. */ if Iname = 1 then return (Dnames.names(Iname)); if S.matching_names then do; /* return next name matching a starname. */ do Iname = Iname to Dnames.N; /* scan thru remaining names. */ do i = 1 to starname.N; /* for each name, compare with each starname. */ go to check (starname.C(i)); check(0): if Dnames.names(Iname) = starname.V(i) then return (Dnames.names(Iname)); go to nomatch; check(1): call match_star_name_ (Dnames.names(Iname), starname.V(i), code); if code = 0 then return (Dnames.names(Iname)); go to nomatch; check(2): return (Dnames.names(Iname)); nomatch: end; end; end; return (blank_name); /* if none of remaining names meet requirements, */ /* return a blank name (null string). */ %include lib_node_; %include lib_based_args_; end lib_next_name_;  lib_node_path_.pl1 02/15/84 0911.2rew 02/15/84 0819.1 45675 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* N__a_m_e: lib_node_path_ */ /* */ /* This procedure returns the path name of the entry represented by a library node. */ /* */ /* U__s_a_g_e */ /* */ /* dcl lib_node_path_ entry (ptr, char(168) varying, char(32) varying); */ /* */ /* call lib_node_path_ (Pnode, directory, entry); */ /* */ /* 1) Pnode is a pointer to the library node representing the entry whose path */ /* name is to be returned. (In) */ /* 2) directory is the directory portion of the path name. (Out) */ /* 3) entry is the entry portion of the path name. (Out) */ /* */ /* */ /* E__n_t_r_y: lib_node_path_$absolute */ /* */ /* This entry points returns an absolute pathname, include archive component names. */ /* */ /* U__s_a_g_e: */ /* */ /* dcl lib_node_path_$absolute (ptr, char(200) varying); */ /* call lib_node_path_$absolute (Pnode, pathname); */ /* */ /* where: */ /* 1) Pnode is as above. (In) */ /* 2) pathname is the absolute pathname. (Out) */ /* */ /* S__t_a_t_u_s */ /* */ /* 0) Created: Aug, 1973 by G. C. Dixon */ /* 1) Modified: Dec, 1980 by G. C. Dixon - add $absolute entry point. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ lib_node_path_: procedure (APnode, dir, ent); dcl APnode ptr, /* ptr to node whose path is to be obtained. (In) */ dir char(168) varying, /* directory part of path. (Out) */ ent char(32) varying; /* entry part of path. (Out) */ dcl i fixed bin, /* a do-group index. */ path char(200) varying; /* path name of the node. */ dcl (addr, index, length, null, reverse, rtrim, substr) builtin; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ path = recurse (APnode); /* get path name of the node. */ i = index (path, "::"); /* Look for archive component name in path. */ if i > 0 then do; /* If one found, treat it as the entryname. */ dir = substr(path, 1, i-1); ent = substr (path, i+2); end; else do; i = length(path) + 1 - index (reverse (path), ">"); if i = 1 then /* special case the root. */ dir = ">"; else dir = substr (path, 1, i-1); ent = substr (path, i+1); end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ absolute: entry (APnode) returns (char(200) varying); return (recurse (APnode)); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ recurse: procedure (APnode) /* This internal procedure constructs the path */ returns (char(200) varying); /* name of the node. */ dcl APnode ptr; /* ptr to the node whose path name is desired. */ Pnode = APnode; /* address the node in question. */ if node.Pparent = null then /* is this a root node of the tree? */ go to root_node; /* if so, then return path name assoc with it. */ else if addr (node.Pparent -> node.Svalid) -> Svalid.link_target then do; /* else, does node's parent have a path name */ Pnode = node.Pparent; /* assoc with it? Return that path name. */ root_node: return (link_node.link_target); end; else do; /* otherwise, concatenate parent node's path */ /* with primary name of this node. */ do PDnames = node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames); end; /* address the node's name descriptor. */ if node.T = Tarchive_comp then return (recurse (node.Pparent) || "::" || rtrim (Dnames.names(1))); else return (recurse (node.Pparent) || ">" || rtrim (Dnames.names(1))); end; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ %include lib_node_; end recurse; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ end lib_node_path_;  lib_output_node_.pl1 02/15/84 0911.2rew 02/15/84 0819.1 511011 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ lib_output_node_: procedure; dcl /* parameters */ ASrequirements bit(72) aligned, /* requirements bits determine output fields. */ level fixed bin(35), /* indentation level at which node is to be */ /* printed in the listing. (In) */ Inode fixed bin, /* number of this node in the node list. (In) */ Pprev_parent ptr, /* ptr to parent node of previous node which */ /* was output. (In) */ name char(32), /* name to be used in the cross reference */ /* entry. (In) */ path char(168) varying; /* path name to be used in the cross reference */ /* entry. (In) */ dcl Iaccess_string (8) fixed bin, /* starting indices of 50-char chunks of access */ Iacl fixed bin, /* number of ACL entries which have been output. */ /* string. */ Idir_iacl fixed bin, /* number of directory IACLe output. */ Iiacl fixed bin, /* number of segment IACLe output. */ Iname fixed bin, /* number of names which have been output. */ Laccess_string fixed bin, /* length of non-blank portion of access string. */ Lacl fixed bin, /* length of ACL we are outputting. */ Lname fixed bin, /* length of the name field in the output, */ Llevel fixed bin, /* length of level field (in characters). */ /* adjusted for indentation level. */ Nindent fixed bin, /* number of spaces that names at this level are */ /* to be indented. */ Sfield_blank bit(1) aligned init ("0"b), /* on if all node fields which can be put in */ /* right-hand column have been output. */ Scleanup bit(1) aligned init ("0"b), /* on if entered at the $cleanup entry point. */ Sinfo bit(1) aligned init ("0"b), /* on if output to go to user's terminal. */ Snames_first bit(1) aligned init ("0"b), /* on if all names to be output first. */ 1 Squota aligned, /* switches dealing with output of quota info. */ 2 master_dir bit(1) unal, /* on if master directory to be output. */ (2 quota, /* on if quota to be output. */ 2 quota_used, /* on if quota used to be output. */ 2 terminal_account, /* on if terminal account switch to be output. */ 2 Ninf, /* on if number of inf directories with quota...*/ 2 trp, /* on if time/record product to be output. */ 2 dttrp) bit(1) unal, /* on if date-time time/record product to be out*/ Stpd bit(1) aligned, /* on if transparent paging dev switch output */ access_string char(300), /* character representation of an access class. */ aim char(100) varying, /* character representation of AIM access switches*/ attributes char(100) varying, /* object segment attributes string. */ code fixed bin(35), /* a status code. */ dir char(168) varying, /* dir part of a node's path name. */ e fixed bin, /* entry point indicator for out_ch proc. */ ent char(32) varying, /* entry part of a node's path name. */ field char(108), /* character string output in right-hand column. */ flag char(1) aligned, /* library_cleanup entry deletion flag. */ i fixed bin, /* a string index. */ iacc fixed bin, /* do-group index used in processing access string*/ iacle char(104), /* character string containing IACL entries. */ level_suppressed bit(1) aligned, /* on if no level field to be put into output line*/ long char(100), /* an error message character string. */ lvname char(32), /* a logical volume name. */ lv_name char(32) varying, /* lvname without trailing blanks. */ mode char(4), /* a mode character string. */ pvname char(32), /* a physical volume name. */ pv_name char(32) varying, /* pvname without trailing blanks. */ rbs char(12) varying, /* a ring bracket character string. */ saved_Iname fixed bin, /* save value of Iname across a test. */ short char(8), /* an abbreviated error message char string. */ type char(20); /* a character node type. */ dcl (addr, binary, dimension, index, length, max, min, null, search, string, substr, reverse, verify) builtin; dcl /* entries */ convert_authorization_$to_string_short entry (bit(72) aligned, char(*), fixed bin(35)), convert_binary_integer_$long_octal_string entry (fixed bin(71)) returns (char(25) varying), convert_binary_integer_$octal_string entry (fixed bin(35)) returns (char(13) varying), convert_status_code_ entry (fixed bin(35), char(8), char(100)), (cv_acl variable, cv_acl_, cv_dir_acl_) entry (ptr, fixed bin, char(*), fixed bin, bit(*)), date_time_ entry (fixed bin(71) aligned, char(*) aligned), date_time_$fstime entry (bit(36), char(*) aligned), ioa_$ioa_switch entry options (variable), lib_next_name_ entry (bit(72) aligned, ptr, fixed bin, ptr) returns (char(32)), lib_node_path_ entry (ptr, char(168) varying, char(32) varying), mdc_$find_lvname entry (bit(36), char(*), fixed bin(35)), mdc_$find_volname entry (bit(36), char(*), char(*), fixed bin(35)); dcl /* static variables */ FT (0:1) char(5) int static init ("false", "true"), 1 null_name_descriptor aligned int static options(constant), /* a fake name descriptor which has no names. */ 2 length fixed bin(17) unal init (5), 2 version fixed bin(17) unal init (1), 2 T fixed bin init (1), 2 Pnext ptr init (null), 2 N fixed bin init (0), /* no names in name array. */ 1 null_user_descriptor aligned int static options(constant), /* a fake user descriptor which has no info. */ 2 length fixed bin(17) unal init (5), 2 version fixed bin(17) unal init (1), 2 T fixed bin init (6), 2 Pnext ptr init (null), 2 L fixed bin init (0), /* no user information. */ status_data_$dir_mode (0:7) char(4) varying aligned ext static, /* array which maps directory mode into a */ /* printable string. */ status_data_$mode (0:7) char(4) varying aligned ext static, /* array which maps segment/msf/archive mode into */ /* a printable string. */ sys_info$max_seg_size fixed bin(35) ext static; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ cleanup: entry (Pfcb, Pnode, ASrequirements, level, Pstarname, Inode, Pprev_parent); Scleanup = "1"b; info: entry (Pfcb, Pnode, ASrequirements, level, Pstarname); Sinfo = "1"b; /* output directed to user's terminal. */ map: entry (Pfcb, Pnode, ASrequirements, level, Pstarname); print: entry (Pfcb, Pnode, ASrequirements, level, Pstarname); /* format for printing on the online printer. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* SET UP REQUIREMENTS BITS WHICH WILL DRIVE OUTPUT OF THE VARIOUS FIELDS: */ /* 1) And requirements bits from node with those in our argument list; put result in our */ /* bit string we can overlay and modify as we like without harm. */ /* 2) Turn off selected output bits to suppress "standard" data (zero bit count, bit */ /* count author = author, etc). */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ Srequirements = node.Sreq & ASrequirements; /* copy req bits to overlay with structure. */ if S.dtc | S.compiler_name | S.compiler_version | S.compiler_options | S.object_info then /* Don't tell user an object segment isn't */ S.not_ascii = "0"b; /* printable. */ if S.copy then /* if user wants to know about the copy switch, */ S.copy = node.Scopy; /* but it is not on, then don't mention it. */ if S.safety then /* do same for safety switch setting. */ S.safety = node.Ssafety; if S.records_used then /* if user wants to know about records used and */ if S.current_length then /* about current length, and if these two values */ if node.records_used = node.current_length then S.records_used = "0"b; /* are equal, then don't mention records used. */ if S.max_length then /* output max length only if different from */ if node.max_length = sys_info$max_seg_size then S.max_length = "0"b; /* the maximum segment size. */ if S.quota then do; /* Set output switches for quota elements. */ string(Squota) = ""b; Squota.master_dir = node.Smaster_dir; if node.segment.quota_used ^= 0 | node.directory.quota_used ^= 0 then Squota.quota_used = "1"b; if node.segment.quota ^= 0 | node.directory.quota ^= 0 then do; Squota.quota = "1"b; Squota.terminal_account = node.Sterminal_account | node.Sterminal_account_dir; if node.segment.Ninf_quota ^= 0 | node.directory.Ninf_quota ^= 0 then Squota.Ninf = "1"b; Squota.trp = "1"b; Squota.dttrp = "1"b; end; end; else string(Squota) = "0"b; if S.bit_count_author then /* suppress bit count author if same as author. */ if S.author then if node.bit_count_author = node.author then S.bit_count_author = "0"b; if S.aim then /* suppress AIM switch settings if not on. */ S.aim = node.Saim_security_oos | node.Saim_audit | node.Saim_multiple_class; if S.lvid then /* suppress TPD switch if not on. */ Stpd = node.Stpd; else Stpd = "0"b; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ADDRESS DESCRIPTORS FOR VARIABLE-LENGTH or OPTIONAL INFORMATION CHAINED OFF THE NODE. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if Svalid.names then /* access the name descriptor, if it exists. */ do PDnames = node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames); end; else PDnames = addr (null_name_descriptor); /* otherwise, fake a null name descriptor. */ if S.dtc | S.compiler_name | S.compiler_version | S.compiler_options | S.object_info then /* address object info descriptor, if need be. */ do PDobj = node.PD repeat Dobj.Pnext while (Dobj.T ^= Tobj); end; if S.root_search_proc then /* address the search_proc info descriptor. */ do PDsearch_proc = node.PD repeat Dsearch_proc.Pnext while (Dsearch_proc.T ^= Tsearch_proc); end; if S.user then /* address user info descriptor, if need be. */ do PDuser = node.PD repeat Duser.Pnext while (Duser.T ^= Tuser); end; if S.kids_error then /* address node array descriptor, if needed. */ do PDnodes = node.PD repeat Dnodes.Pnext while (Dnodes.header.T ^= Tnodes); end; if S.acl then do; /* address ACL descriptor. */ if node.T = Tdirectory then do; do PDdir_acl = node.PD repeat Ddir_acl.Pnext while (Ddir_acl.T ^= Tdir_acl); end; PDacl = PDdir_acl; /* cheat by treating directory ACL descriptor */ cv_acl = cv_dir_acl_; /* as segment ACL descriptor, and letting the */ end; /* conversion routine worry about differences. */ else do; do PDacl = node.PD repeat Dacl.Pnext while (Dacl.T ^= Tacl); end; cv_acl = cv_acl_; end; end; if S.iacl then do; /* address segment/directory IACL descriptors. */ do PDiacl = node.PD repeat Diacl.Pnext while (Diacl.T ^= Tiacl); end; do PDdir_iacl = node.PD repeat Ddir_iacl.Pnext while (Ddir_iacl.T ^= Tdir_iacl); end; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* DO COMPLICATED FIELD CONVERSIONS BEFORE STARTING THE OUTPUT. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if S.mode then if node.T = Tdirectory then mode = status_data_$dir_mode (binary (node.Smode, 3)); else mode = status_data_$mode (binary (node.Smode, 3)); if S.rb then do; rbs = cv_dec(binary(node.rb(1), 35)) || ", "; rbs = rbs || cv_dec(binary(node.rb(2), 35)); if node.T ^= Tdirectory then do; rbs = rbs || ", "; rbs = rbs || cv_dec(binary(node.rb(3), 35)); end; end; if S.access_class then do; call convert_authorization_$to_string_short (node.access_class, access_string, code); if code ^= 0 then do; bad_access_class: call convert_status_code_ (code, short, long); access_string = "Error - " || long; Laccess_string = length(access_string) - verify (reverse (access_string), " ") + 1; end; if access_string = "" then S.access_class = "0"b; else do; Laccess_string = index(access_string," "); split_access_class: Iaccess_string(1) = 1; do iacc = 1 to dimension(Iaccess_string,1)-1; if Iaccess_string(iacc) > Laccess_string then Iaccess_string(iacc+1) = Laccess_string+1; else if Laccess_string - Iaccess_string(iacc) + 1 <= 50 then Iaccess_string(iacc+1) = Laccess_string+1; else Iaccess_string(iacc+1) = Iaccess_string(iacc) + 52 - search (reverse (substr (access_string, Iaccess_string(iacc), 51)), " ,"); end; end; end; if S.aim then do; aim = ""; if node.Saim_audit then aim = "audit"; if node.Saim_multiple_class then do; if length(aim) ^= 0 then aim = aim || ", "; aim = aim || "multiple-class"; end; if node.Saim_security_oos then do; if length(aim) ^= 0 then aim = aim || ", "; aim = aim || "out-of-service"; end; end; if S.object_info then do; attributes = ""; if Dobj.info.format.bound then attributes = attributes || "bound object"; if Dobj.info.format.old_format then do; if length (attributes) > 0 then attributes = attributes || ", "; attributes = attributes || "old format"; end; if Dobj.info.format.standard then; else do; if length (attributes) > 0 then attributes = attributes || ", "; attributes = attributes || "non-standard format"; end; if Dobj.info.format.procedure then; else do; if length (attributes) > 0 then attributes = attributes || ", "; attributes = attributes || "data"; end; if Dobj.info.format.relocatable then; else do; if length (attributes) > 0 then attributes = attributes || ", "; attributes = attributes || "non-relocatable"; end; if Dobj.info.format.gate then do; if length (attributes) > 0 then attributes = attributes || ", "; attributes = attributes || "gate (" || convert_binary_integer_$octal_string (Dobj.info.entry_bound) || ")"; end; if Dobj.info.format.separate_static then do; if length (attributes) > 0 then attributes = attributes || ", "; attributes = attributes || "separate static"; end; if Dobj.info.format.links_in_text then do; if length (attributes) > 0 then attributes = attributes || ", "; attributes = attributes || "links in text"; end; if length (attributes) = 0 then attributes = "standard object"; end; if S.pvid then do; S.pvid = "0"b; /* NEVER OUTPUT THE PVNAME! */ call mdc_$find_volname (node.pvid, pvname, lvname, 0); pv_name = substr(pvname,1, length(pvname) + 1 - verify(reverse(pvname)," ")); lv_name = substr(lvname,1, length(lvname) + 1 - verify(reverse(lvname)," ")); end; else if S.lvid then do; call mdc_$find_lvname (node.lvid, lvname, 0); lv_name = substr(lvname,1, length(lvname) + 1 - verify(reverse(lvname)," ")); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* OUTPUT THE LINES DESCRIBING THIS NODE WHICH ARE REQUIRED AND HAVE NOT BEEN SUPPRESSED. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call set_field_widths; /* set length of level, indentation, name fields */ if S.new_line then /* required at start of entry? */ call out_nl; /* put one into output. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* For library_cleanup, output directory pathname, followed by a list of nodes, with list */ /* entries numbered consecutively. Flag entries to be deleted with *. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if Scleanup then do; if S.pathname then do; S.pathname = "0"b; if Pprev_parent ^= null then if node.Pparent = Pprev_parent then; else do; CLEANUP_PATH: call lib_node_path_ (Pnode, dir, ent); if node.Pparent = null then if dir = ">" then dir = dir || ent; else dir = dir || ">" || ent; call out_pn (dir); if S.new_line then call out_nl; end; else go to CLEANUP_PATH; end; if Svalid.delete then flag = "*"; else flag = " "; if S.type then do; S.type = "0"b; type = brief_node_type (node.T); end; else type = ""; call out_cln (flag, Inode, type); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* If short terminal length requires that all names be output first, followed by other */ /* fields, output the names, then make the field zero length in lines which follow.*/ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if Snames_first then do; ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname); do while (ent ^= ""); call out_name (ent, "", ""); ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname); end; Lname = 0; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* LINE: in: */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if Sinfo then do; /* Special case short terminals. */ if S.type then do; type = brief_node_type(node.T); call out_ch2 (" type:", type); end; if S.pathname & (level <= 1) then do; call lib_node_path_ (Pnode, dir, ent); if node.Pparent = null then do; type = " path:"; if dir = ">" then dir = dir || ent; else dir = dir || ">" || ent; end; else type = " path:"; saved_Iname = Iname; ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname); Iname = saved_Iname; if ent = "" then do; if length (dir) <= 16 then do; dir = dir || (19)" "; dir = substr(dir,1,19); dir = dir || get_field(); i = length(dir) + 1 - verify(reverse(dir), " "); dir = substr(dir,1,i); end; else do; Lname = Lname - 40; Sinfo = "0"b; end; call out_vc2 (type, dir); S.pathname = "0"b; end; else if Nindent+Llevel+Lname+21+length(dir) <= fcb.line_length then do; call out_vc2 (type, dir); S.pathname = "0"b; end; end; end; else if S.type | S.pathname then do; if S.type then type = brief_node_type(node.T); else type = ""; if level > 1 then do; dir = (19)" " || get_field(); i = length(dir) + 1 - verify(reverse(dir), " "); dir = substr(dir,1,i); end; else if S.pathname then do; call lib_node_path_ (Pnode, dir, ent); if node.Pparent = null then do; /* special case a library root node. */ substr (type, 15, 5) = "path:"; if dir = ">" then dir = dir || ent; else dir = dir || ">" || ent; end; else substr (type, 17, 3) = "in:"; if length (dir) <= 16 then do; dir = dir || (19)" "; dir = substr(dir,1,19); dir = dir || get_field(); i = length(dir) + 1 - verify(reverse(dir), " "); dir = substr(dir,1,i); end; end; else dir = ""; call out_vc2 (type, dir); S.pathname = "0"b; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* LINE: contents modified: */ /* LINE: entry modified: */ /* LINE: date used: */ /* LINE: date dumped: */ /* LINE: date compiled: */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if node.T = Tarchive_comp then if S.dtem then do; S.dtem = "0"b; call out_ch3 (" component updated:", cv_date(node.dtem), get_field()); end; if S.dtm then do; S.dtm = "0"b; call out_ch3 (" contents modified:", cv_date(node.dtm), get_field()); end; if S.dtem then do; S.dtem = "0"b; call out_ch3 (" entry modified:", cv_date(node.dtem), get_field()); end; if S.dtu then do; S.dtu = "0"b; call out_ch3 (" date used:", cv_date(node.dtu), get_field()); end; if S.dtd then do; S.dtd = "0"b; call out_ch3 (" date dumped:", cv_date(node.dtd), get_field()); end; if S.dtc then do; S.dtc = "0"b; if Dobj.info.format.bound then call out_ch3 (" date bound:", cv_long_date(Dobj.info.compile_time), get_field()); else call out_ch3 (" date compiled:", cv_long_date(Dobj.info.compile_time), get_field()); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* LINE: msf indicator: */ /* LINE: bit count: */ /* LINE: length: */ /* LINE: records used: */ /* LINE: max length: */ /* LINE: offset: */ /* LINE: entry bound: */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if S.msf_indicator then do; S.msf_indicator = "0"b; call out_ch3 (" msf indicator:", cv_dec(node.msf_indicator), get_field()); end; if S.bit_count then do; S.bit_count = "0"b; call out_ch3 (" bit count:", cv_dec(node.bit_count), get_field()); end; if S.current_length then do; S.current_length = "0"b; call out_ch3 (" length:", cv_dec(node.current_length), get_field()); end; if S.records_used then do; S.records_used = "0"b; call out_ch3 (" records used:", cv_dec(node.records_used), get_field()); end; if S.max_length then do; S.max_length = "0"b; call out_ch3 (" max length:", cv_dec(node.max_length), get_field()); end; if S.offset then do; S.offset = "0"b; call out_ch3 (" offset:", convert_binary_integer_$octal_string(node.offset), get_field()); end; if S.entry_bound then do; S.entry_bound = "0"b; call out_ch3 (" entry bound:", convert_binary_integer_$octal_string(node.entry_bound), get_field()); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* LINE: author: */ /* LINE: bit count author: */ /* LINE: logical volume: */ /* LINE: physical volume: */ /* LINE: never on paging dv: true */ /* LINE: master directory: true */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if S.author then if length(node.author) <= 16 then do; S.author = "0"b; call out_vc3 (" author:", node.author, get_field()); end; if S.bit_count_author then if length(node.bit_count_author) <= 16 then do; S.bit_count_author = "0"b; call out_vc3 (" bit count author:", node.bit_count_author, get_field()); end; if S.lvid then if length(lv_name) <= 16 then do; S.lvid = "0"b; if node.T = Tdirectory | node.T = Tmsf then call out_vc3 (" sons log. volume:", lv_name, get_field()); else call out_vc3 (" logical volume:", lv_name, get_field()); end; if S.pvid then if length (pv_name) <= 16 then do; S.pvid = "0"b; call out_vc3 (" physical volume:", pv_name, get_field()); end; if Stpd then do; Stpd = "0"b; call out_ch3 ("never on paging dv:", "true", get_field()); end; if Squota.master_dir then do; Squota.master_dir = "0"b; call out_ch3 (" master directory:", "true", get_field()); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* LINE: access class: */ /* LINE: AIM attributes: */ /* LINE: mode: */ /* LINE: ring brackets: */ /* LINE: safety switch: on */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if S.access_class then if Laccess_string <= 16 then do; S.access_class = "0"b; call out_ch3 (" access class:", substr(access_string,1,Laccess_string), get_field()); end; if S.aim then if length(aim) <= 16 then do; S.aim = "0"b; call out_vc3 (" AIM attributes:", aim, get_field()); end; if S.mode then do; S.mode = "0"b; call out_ch3 (" mode:", mode, get_field()); end; if S.rb then do; S.rb = "0"b; call out_vc3 (" ring brackets:", rbs, get_field()); end; if S.safety then do; S.safety = "0"b; call out_ch3 (" safety switch:", "on", get_field()); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* LINE: copy switch: on */ /* LINE: unique id: */ /* LINE: : */ /* LINE: object attributes: */ /* LINE: printable: */ /* LINE: compiler: */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if S.copy then do; S.copy = "0"b; call out_ch3 (" copy switch:", "on", get_field()); end; if S.unique_id then do; S.unique_id = "0"b; call out_ch3 (" unique id:", convert_binary_integer_$octal_string(binary (node.unique_id, 36)), get_field()); end; if S.user then if Duser.L <= 16 then do; S.user = "0"b; call out_ch3 (Duser.label || ":", Duser.info, get_field()); end; if S.object_info then if length (attributes) <= 16 then do; S.object_info = "0"b; call out_vc3 (" object attributes:", attributes, get_field()); end; if S.not_ascii then do; S.not_ascii = "0"b; call out_ch3 (" printable:", "no", get_field()); end; if S.compiler_name then do; S.compiler_name = "0"b; call out_ch3 (" compiler:", Dobj.info.compiler, get_field()); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* FINISH OUTPUTTING SHORT DATA BEFORE BEGINNING LONG DATA. */ /* 1) Output remaining ACL entries, unless on short terminal or in 1-datum per line mode. */ /* 2) Output remaining names, unless on short terminal. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if S.acl then if Snames_first | Sinfo then; else do; field = get_acl(); do while (field ^= ""); call out_ch3 ("", "", field); field = get_acl(); end; end; if ^Snames_first then if Sinfo then do; /* For short terminals, print rest of names now. */ ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname); do while (ent ^= ""); call out_name (ent, "", ""); ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname); end; Lname = Lname - 40; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* OUTPUT ITEMS LONGER THAN A SINGLE COLUMN */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* LINE: quota: */ /* LINE: quota used: */ /* LINE: time * records(TR):