adjust_bit_count.pl1 10/25/83 1546.8r w 10/25/83 1444.5 52713 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ adjust_bit_count: abc: proc; /* This command sets the bit counts of segments to the last bit of the last non-zero word or character */ /* Written 3/4/76 by Steve Herbst */ /* Fixed to complain about directories 05/15/79 S. Herbst */ dcl 1 paths (arg_count) based(paths_ptr), /* ptrs and lengths of pathname args */ 2 path_ptr ptr, 2 path_len fixed bin; dcl 1 entries (ecount) aligned based(entries_ptr), /* entry info from hcs_$star_ */ 2 etype fixed bin(1) unaligned, 2 nnames fixed bin(15) unaligned, 2 nindex fixed bin unaligned; dcl LINK_TYPE fixed bin int static options(constant) init(0); dcl names (99) char(32) aligned based(names_ptr); /* entry names from hcs_$star_ */ dcl area area based(area_ptr); dcl arg char(arg_len) based(arg_ptr); dcl dn char(168); dcl (en, star_name) char(32); dcl (character, chase_sw, long, match, stars) bit(1) aligned; dcl (area_ptr, arg_ptr, entries_ptr, names_ptr, paths_ptr) ptr; dcl (arg_count, arg_len, ecount, i, j, path_count) fixed bin; dcl (bit_count, old_bit_count) fixed bin(24); dcl code fixed bin(35); dcl error_table_$badopt fixed bin(35) ext; dcl error_table_$badstar fixed bin(35) ext; dcl error_table_$dirseg fixed bin(35) ext; dcl error_table_$nomatch fixed bin(35) ext; dcl adjust_bit_count_ entry(char(*),char(*),bit(1)aligned,fixed bin(24),fixed bin(35)); dcl check_star_name_$entry entry(char(*),fixed bin(35)); dcl com_err_ entry options(variable); dcl cu_$arg_count entry(fixed bin); dcl cu_$arg_ptr entry(fixed bin,ptr,fixed bin,fixed bin(35)); dcl expand_path_ entry(ptr,fixed bin,ptr,ptr,fixed bin(35)); dcl get_system_free_area_ entry returns(ptr); dcl hcs_$get_link_target entry(char(*),char(*),char(*),char(*),fixed bin(35)); dcl hcs_$star_ entry(char(*),char(*),fixed bin(2),ptr,fixed bin,ptr,ptr,fixed bin(35)); dcl hcs_$status_minf entry(char(*),char(*),fixed bin(1),fixed bin(2),fixed bin(24),fixed bin(35)); dcl ioa_ entry options(variable); dcl (addr, null, substr) builtin; dcl cleanup condition; /* */ call cu_$arg_count(arg_count); if arg_count=0 then do; NO_PATH: call com_err_(0,"","Usage is: adjust_bit_count paths -control_args-"); return; end; entries_ptr, names_ptr, paths_ptr = null; on condition(cleanup) call clean_up; area_ptr = get_system_free_area_(); allocate paths in(area) set(paths_ptr); path_count = 0; character, chase_sw, long = "0"b; do i = 1 to arg_count; call cu_$arg_ptr(i,arg_ptr,arg_len,code); if substr(arg,1,1)="-" then if arg="-character" | arg="-ch" then character = "1"b; else if arg="-long" | arg="-lg" then long = "1"b; else if arg="-chase" then chase_sw = "1"b; else if arg="-no_chase" then chase_sw = "0"b; else do; call com_err_(error_table_$badopt,"adjust_bit_count","^a",arg); free paths in(area); return; end; else do; /* pathname argument */ path_count = path_count+1; path_ptr(path_count) = arg_ptr; path_len(path_count) = arg_len; end; end; if path_count=0 then do; free paths in(area); go to NO_PATH; end; /* */ do i = 1 to path_count; call expand_path_(path_ptr(i),path_len(i),addr(dn),addr(en),code); if code^=0 then do; arg_ptr = path_ptr(i); arg_len = path_len(i); call com_err_(code,"adjust_bit_count","^a",arg); go to NEXT_PATH; end; call check_star_name_$entry(en,code); if code=0 then do; stars = "0"b; ecount = 1; end; else if code=error_table_$badstar then do; call com_err_(code,"adjust_bit_count","^a",en); go to NEXT_PATH; end; else do; stars = "1"b; star_name = en; call hcs_$star_(dn,en,3,area_ptr,ecount,entries_ptr,names_ptr,code); if code^=0 then do; call com_err_(code,"adjust_bit_count","^a>^a",dn,en); go to NEXT_PATH; end; end; match = "0"b; do j = 1 to ecount; /* for each starname match */ if stars then do; en = names(nindex(j)); if etype(j)=LINK_TYPE then if chase_sw then do; call hcs_$get_link_target(dn,en,dn,en,code); if code^=0 then go to NEXT_MATCH; end; else go to NEXT_MATCH; end; if long then do; call hcs_$status_minf(dn,en,1,(0),old_bit_count,code); bit_count = old_bit_count; end; call adjust_bit_count_(dn,en,character,bit_count,code); if code = error_table_$dirseg then do; if ^stars then call com_err_ (code, "adjust_bit_count", "^a^[>^]^a", dn, dn ^= ">", en); end; else do; match = "1"b; if code ^= 0 then if bit_count=-1 then call com_err_(code,"adjust_bit_count","^a>^a",dn,en); else call com_err_(code,"adjust_bit_count", "^a>^a^/^-Computed bit count = ^d",dn,en,bit_count); else if long & bit_count^=old_bit_count then call ioa_("Bit count of ^a>^a changed from ^d to ^d", dn,en,old_bit_count,bit_count); end; NEXT_MATCH: end; if stars then do; if ^match then call com_err_ (error_table_$nomatch, "adjust_bit_count", "^a^[>^]^a", dn, dn ^= ">", star_name); free entries in(area); free names in(area); end; NEXT_PATH: end; call clean_up; return; clean_up: proc; if paths_ptr^=null then free paths in(area); if entries_ptr^=null then free entries in(area); if names_ptr^=null then free names in(area); end clean_up; end adjust_bit_count;  adjust_bit_count_.pl1 07/26/84 1221.5rew 07/26/84 1137.3 55746 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ adjust_bit_count_: proc (dn, en, ascii, a_bit_count, a_code); /* Subroutine that does adjusting on individual files. Prepared for installation by C Garman, July 1971 */ /* re-modified to work on MSF's by Steve Herbst 12/15/74 */ /* fixed by M. Asherman 9/2/76 to return a bit_count for msf's */ /* Modified 06/08/82 by Jim Lippard to not require aligned dname and ename, and to compile without error */ /* Modified 08/02/83 by Jim Lippard to properly handle MSFs */ /* Modified 04/09/84 by Jim Lippard to return proper error code on MSF to which caller has no access */ /* DECLARATIONS */ dcl sum_prev_bcs fixed(35); /* sum of bit counts of MSF components */ /* fixed bin */ dcl (current_block, i, j, k init (0), components, ldn ) fixed bin (17); dcl block_offset fixed bin (18); dcl a_bit_count fixed(35); dcl (bc,bit_count) fixed(24); dcl (a_code, code, error_table_$dirseg ext, error_table_$noentry ext, error_table_$segknown ext) fixed bin (35); /* bit */ dcl ascii bit (1) aligned; dcl msf bit (1) aligned; /* character */ dcl (en, enc) char (32); /* entry name */ dcl (dn, dnc) char (168); /* directory name */ /* pointer */ dcl (blockp, compp init (null), eptr, fcbp init (null), segp, wordp) ptr; /* builtin */ dcl (addr, addrel, fixed, max, null) builtin; /* structures and based declarations */ declare 1 br aligned, /* status branch */ (2 (type bit (2), nnames bit (16), nrp bit (18)), 2 dtm bit (36), 2 dtu bit (36), 2 (mode bit (5), pad1 bit (13), records bit (18)), 2 dtd bit (36), 2 dtem bit (36), 2 acct bit (36), 2 (curlen bit (12), bitcnt bit (24)), 2 (did bit (4), imdid bit (4), copysw bit (1), pad3 bit (9), rbs (0:2) bit (6)), 2 uid bit (36)) unaligned; dcl word_mask (0:1023) fixed bin based (blockp); declare 1 char_mask aligned based (wordp), 2 char (1:4) bit (9) unaligned; /* external entries */ dcl hcs_$fs_get_path_name entry (ptr, char(*), fixed bin, char(*), fixed bin(35)); dcl hcs_$initiate entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35)); dcl hcs_$set_bc entry (char(*), char(*), fixed bin(24), fixed bin(35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35)); dcl hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)); dcl hcs_$terminate_noname entry (ptr, fixed bin(35)); dcl msf_manager_$adjust entry (ptr, fixed bin, fixed bin(24), bit(3), fixed bin(35)); dcl msf_manager_$close entry (ptr); dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35)); dcl msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35)); /* adjust_bit_count_: proc (dn, en, ascii, a_bit_count, a_code); */ bit_count = -1; msf = "0"b; sum_prev_bcs=0; eptr = addr (br); call hcs_$status_long (dn, en, 1, eptr, null, code); /* Get length and type of segment */ if code ^= 0 then go to FIN; if br.type = "10"b then if br.bitcnt = "0"b then do; code = error_table_$dirseg; go to FIN; end; else do; msf = "1"b; call msf_manager_$open (dn, en, fcbp, code); if code ^= 0 then go to FIN; components = -1; bc=0; msf_loop: components = components + 1; sum_prev_bcs=sum_prev_bcs+bc; segp = compp; call msf_manager_$get_ptr (fcbp, components, "0"b, compp, bc, code); if code = 0 | code = error_table_$segknown then go to msf_loop; else if code ^= error_table_$noentry then do; sum_prev_bcs = 0; go to FIN; end; call hcs_$fs_get_path_name (segp, dnc, ldn, enc, code); if code ^= 0 then go to FIN; call hcs_$status_long (dnc, enc, 1, eptr, null, code); if code ^= 0 then go to FIN; end; else call hcs_$initiate (dn, en, "", 0, 1, segp, code); /* Get pointer to segment */ if segp = null then go to FIN; /* this is the only non-zero code that worries us */ last: code = 0; current_block = fixed (br.curlen, 12) -1; /* get current block number */ if current_block >= 0 /* If non-zero current length */ then do i = current_block to 0 by -1 while (bit_count < 0); block_offset = i * 1024; /* Compute start of current block */ blockp = addrel (segp, block_offset); do j = 1023 by -1 to 0 while (blockp -> word_mask (j) = 0); /* Search current block for non-zero word */ end; if j >= 0 /* (Should always be, but ...) */ then do; if ascii /* If character adjustment wanted, test last word */ then do; wordp = addr (blockp -> word_mask (j)); /* Get pointer to last word */ do k = 4 by -1 to 1 while (wordp -> char_mask.char (k) = (9)"0"b); /* Now test characters */ end; end; else /* no character adjustment wanted */ j = j + 1; /* include full last non-zero word */ end; if j >= 0 /* a non-zero length block was found */ then bit_count = (((block_offset + j) * 4) + k) * 9; /* inner expression is multiplied by 36 */ end; bit_count = max (bit_count, 0); if msf then do; call msf_manager_$adjust (fcbp, components-1, bit_count, "110"b, code); if code ^= 0 then go to FIN; if components>1 then call hcs_$set_bc (dn, en, (components), code); if code ^= 0 then go to FIN; end; call hcs_$set_bc_seg(segp,bit_count,code); if code ^= 0 then go to FIN; if msf then call msf_manager_$close (fcbp); else call hcs_$terminate_noname (segp, (0)); FIN: a_bit_count = bit_count+sum_prev_bcs; a_code = code; /* Return the last error code */ end adjust_bit_count_;  check_file_system_damage.pl1 09/15/88 1344.6rew 09/15/88 1341.0 183537 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-05,Spitzer), approve(85-09-05,MCR7269), audit(85-09-18,Blair), install(85-12-16,MR12.0-1001): 1) Fix CA detection code. 2) Add -pn CA. 2) change(88-08-25,TLNguyen), approve(88-08-25,MCR7962), audit(88-09-14,Parisek), install(88-09-15,MR12.2-1110): Remove the check_superior_dirs internal procedure because users don't generally have a status access mode on their superior directories and this procedure goes beyond what this program is documented or supposed to do. END HISTORY COMMENTS */ check_file_system_damage: cfsd: proc; /* *********************************************************************** * Command for finding damaged segments and connection failures. * * This program is useful after a system crash to check the state * * of the libraries and system control directories * * * * Coded July 1980 by Jim Homan, with thanks to Warren Johnson for * * his check_dsw command. * * Bug fixes installed August 1980 by Warren Johnson. * *********************************************************************** */ /* Modified 3/8/84 by C Spitzer. modify for installation per MCRB amendments */ /* Modified 1/6/85 by Keith Loepere to understand "new" error code from hcs_$star_. */ /* **************************************************************************** * * * Usage: * * * * check_file_system_damage path {-control_args} * * * * path is a pathname specifying what is to be checked. It * * may be a starname, and -wd is accepted. * * * * control_args may be any of the following: * * * * -pathname, specifies that the next argument is to be used as a * * -pn pathname rather than as a control argument. * * * * -subtree, if this control argument is specified, then path must * * -subt be a directory. All segments in the specified directory * * and all directories below the specified directory are * * checked. * * * * -multisegment_file, * * -msf if this control argument is specified, then the components * * of MSFs are checked. This is the default. * * * * -no_multisegment_file, * * -no_msf, turns off checking of MSF. * * * * -brief, bf if this control argument is specified, then error * * messages about incorrect access to directories and no star * * name matches are suppressed. * * * * -call STR STR is a command to be executed for each segment which * * is damaged. For each damaged segment, the command * * executed is "STR path damaged". For each connection * * failure, the executed is "STR path connection_failure". * * The default action, when -call is not specified, is to * * print out an error message for each damaged segment and * * each connection failure. * **************************************************************************** */ %page; /* external entries */ dcl active_fnc_err_ entry options (variable); dcl check_star_name_$entry entry (char (*), fixed (35)); dcl com_err_ entry options (variable); dcl cu_$af_return_arg entry (fixed, ptr, fixed (21), fixed (35)); dcl cu_$arg_count entry returns (fixed); dcl cu_$arg_ptr entry (fixed, ptr, fixed, fixed (35)); dcl cu_$cp entry (ptr, fixed, fixed (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed (35)); dcl get_system_free_area_ entry returns (ptr); dcl get_wdir_ entry () returns (char (168)); dcl hcs_$star_ entry (char (*), char (*), fixed (2), ptr, fixed, ptr, ptr, fixed (35)); dcl hcs_$status_long entry (char (*), char (*), fixed (1), ptr, ptr, fixed (35)); dcl ioa_ entry options (variable); dcl pathname_ entry (char (*), char (*)) returns (char (168)); /* external static */ dcl error_table_$bad_arg fixed (35) bin external static; dcl error_table_$badopt fixed (35) bin external static; dcl error_table_$inconsistent fixed (35) bin external static; dcl error_table_$logical_volume_not_defined fixed (35) bin external static; dcl error_table_$moderr fixed (35) bin external static; dcl error_table_$noarg fixed (35) bin external static; dcl error_table_$nomatch fixed (35) bin external static; dcl error_table_$too_many_args fixed (35) bin external static; dcl error_table_$vtoce_connection_fail fixed (35) bin external static; /* internal static */ dcl ME char (32) int static options (constant) init ("check_file_system_damage"); /* automatic */ dcl area_ptr ptr; /* pointer to area used for hcs_$star allocations */ dcl argN fixed; /* number of argument being processed */ dcl arglen fixed; /* length of any command argument */ dcl argptr ptr; /* pointer to any command argument */ dcl brief_switch bit (1) aligned; /* on if -brief specified */ dcl call_switch bit (1) aligned; /* on if -call specified */ dcl code fixed (35); /* error code returned by Multics subroutines */ dcl command_line_length fixed init (0); /* length of command line argument */ dcl command_line_ptr ptr; /* pointer to command line argument */ dcl dname char (168); /* directory portion of pathname given as argument */ dcl ename char (32); /* entryname portion of pathname given as argument */ dcl max_depth fixed bin; /* number of dirs allowed to go down. default is 99999 */ dcl msf_switch bit (1) aligned; /* on if -msf specified */ dcl nargs fixed; /* number of arguments given to the command */ dcl star_switch bit (1) aligned; /* on if pathname arg is a starname */ dcl subroutine bit (1) aligned; /* on if entry thru subroutine interface */ dcl subtree_switch bit (1) aligned; /* on if -subtree specified */ /* based */ dcl arg char (arglen) based (argptr); /* any command argument */ dcl command_line char (command_line_length) based (command_line_ptr); /* argument after -call */ /* conditions */ dcl cleanup condition; /* builtins */ dcl (addr, index, length, null, rtrim, substr, sum) builtin; %page; %include branch_status; %page; star_switch, subtree_switch, brief_switch, call_switch, subroutine = "0"b; msf_switch = "1"b; max_depth = 99999; call cant_be_active_function (); call check_number_of_args (1, 0, "check_file_system_damage path {-ctl_args}", nargs); dname = ""; argN = 1; do while (argN <= nargs); call cu_$arg_ptr (argN, argptr, arglen, code); if /* case */ code ^= 0 then do; call com_err_ (code, ME, "^/Error getting argument ^d.", argN); return; end; else if index (arg, "-") ^= 1 then if dname = "" then call get_starname_arg (arg, dname, ename, star_switch); else do; MULTIPLE_PATHS: call com_err_ (0, ME, "Multiple pathnames given. ^a", arg); goto EXIT; end; else if arg = "-pn" | arg = "-pathname" then if dname = "" then do; argN = argN + 1; call get_required_arg (argN, "After -pathname.", argptr, arglen); call expand_pathname_ (arg, dname, ename, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", arg); return; end; end; else goto MULTIPLE_PATHS; else if arg = "-wd" | arg = "-working_dir" then if dname = "" then call expand_pathname_ (get_wdir_ (), dname, ename, (0)); else goto MULTIPLE_PATHS; else if arg = "-subtree" | arg = "-subt" then subtree_switch = "1"b; else if arg = "-brief" | arg = "-bf" then brief_switch = "1"b; else if arg = "-msf" | arg = "-multisegment_file" then msf_switch = "1"b; else if arg = "-no_msf" | arg = "-no_multisegment_file" then msf_switch = "0"b; else if arg = "-dh" | arg = "-depth" then do; argN = argN + 1; call get_required_arg (argN, "After -depth.", argptr, arglen); max_depth = cv_dec_check_ (arg, code); if code ^= 0 then do; call com_err_ (0, ME, "Non-numeric after -depth. ^a", arg); return; end; subtree_switch = "1"b; end; else if arg = "-call" then do; call_switch = "1"b; argN = argN + 1; call get_required_arg (argN, "After -call.", command_line_ptr, command_line_length); end; else do; /* Error, unrecognized argument */ if arglen > 0 then if substr (arg, 1, 1) = "-" then call com_err_ (error_table_$badopt, ME, arg); else call com_err_ (error_table_$bad_arg, ME, arg); else ; return; end; argN = argN + 1; end; if dname = "" then do; call com_err_ (error_table_$noarg, ME, "^/Usage: ^a path {-control_args}", ME); goto EXIT; end; if subtree_switch & star_switch then do; call com_err_ (error_table_$inconsistent, ME, "Pathname may not be a starname if -^[subtree^;depth^] option is used. ^a", (max_depth = 99999), pathname_ (dname, ename)); go to EXIT; end; else ; area_ptr = get_system_free_area_ (); if subtree_switch then call survey_the_damage (pathname_ (dname, ename), "**", 1); else if star_switch then call survey_the_damage (dname, ename, 1); else call check_entry (dname, ename, 1); EXIT: /* all internal procs may go to here to after reporting errors */ return; %page; check_file_system_damage_: entry (Pdir, Pname, Pcode) returns (bit (36) aligned); dcl Pdir char (*) parameter; /* directory name (input) */ dcl Pname char (*) parameter; /* entry name (input)*/ dcl Pcode fixed bin (35) parameter; /* error code (output) */ dcl return_bits bit (36) aligned; dcl 1 return_bits_based aligned based (addr (return_bits)), 2 damage bit (1) unaligned, /* ON = any damage */ 2 damaged_switch bit (1) unaligned, /* ON = damaged entry */ 2 connection_failure bit (1) unaligned, /* ON = connectin failure on entry */ 2 unused bit (33) unaligned; /* future expansion */ return_bits = "0"b; Pcode, code = 0; subroutine = "1"b; call_switch, msf_switch = "0"b; max_depth = 0; command_line_length = 0; call check_entry (Pdir, Pname, 0); if code ^= 0 then do; Pcode = code; return_bits = "0"b; end; else if return_bits ^= "0"b then return_bits_based.damage = "1"b; return (return_bits); %page; /* ********************************************************************** * Internal procedure to check all entries in a directory that match * * a starname. * ********************************************************************** */ survey_the_damage: proc (dir, et, depth) recursive; dcl dir char (*) parameter; /* Input-directory name */ dcl et char (*) parameter; /* Input-starname */ dcl depth fixed bin parameter; /* Input-number of dirs downwards we are */ dcl ec fixed (35); /* error code */ dcl i fixed; /* loop index */ %page; %include star_structures; %page; if depth > max_depth then return; star_entry_ptr, star_names_ptr = null (); on cleanup /* CLEANUP HANDLER */ begin; if star_names_ptr ^= null () then free star_names; else ; if star_entry_ptr ^= null () then free star_entries; else ; end; call hcs_$star_ (dir, et, star_BRANCHES_ONLY, area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, ec); if ec ^= 0 then if (ec = error_table_$moderr | ec = error_table_$nomatch | ec = error_table_$logical_volume_not_defined) & brief_switch then ; else call com_err_ (ec, ME, "^a", pathname_ (dir, et)); else do i = 1 to star_entry_count by 1; call check_entry (dir, star_names (star_entries (i).nindex), depth); end; CLEANUP: if star_names_ptr ^= null () then free star_names; else ; if star_entry_ptr ^= null () then free star_entries; else ; return; end survey_the_damage; %page; /* ********************************************************************** * Internal procedure to check an individual branch for damage. * * This procedure recalls survey_damage as needed to handle * * subtrees and MSFs. * ********************************************************************** */ check_entry: proc (d, e, depth); dcl d char (*) parameter; /* Input-directory portion of pathname */ dcl e char (*) parameter; /* Input-entryname */ dcl depth fixed bin parameter; /* Input-number of dirs downward we are */ dcl ec fixed (35); /* error code */ dcl command char (command_line_length + 188); /* long enough for command line plus pathname plus */ /* "connection_failure" plus spaces */ call hcs_$status_long (d, e, 0, addr (branch_status), null (), ec); if ec = error_table_$vtoce_connection_fail then if call_switch then do; command = command_line || " " || rtrim (pathname_ (d, e)) || " connection_failure"; call cu_$cp (addr (command), length (command), (0)); end; else if subroutine then return_bits_based.connection_failure = "1"b; else call ioa_ ("Connection failure: ^a", pathname_ (d, e)); else if ec ^= 0 then if subroutine then do; code = ec; return; end; else call com_err_ (ec, ME, "^a", pathname_ (d, e)); else if branch_status.damaged_switch then if call_switch then do; command = command_line || " " || rtrim (pathname_ (d, e)) || " damaged"; call cu_$cp (addr (command), length (command), (0)); end; else if subroutine then return_bits_based.damaged_switch = "1"b; else call ioa_ ("Damage switch on: ^a", pathname_ (d, e)); else if branch_status.type = directory_type then if (msf_switch & branch_status.bit_count ^= "0"b) | (branch_status.bit_count = "0"b & subtree_switch) then if depth < max_depth then call survey_the_damage (pathname_ (d, e), "**", depth + 1); else ; /* would make it too far down */ else ; else ; /* not a directory */ return; end check_entry; %page; /* *********************************************************************** * Internal procedure to check to see if command was called as active * * function, and to report an error if it was. * *********************************************************************** */ cant_be_active_function: proc; dcl ec fixed (35); /* error code */ call cu_$af_return_arg ((0), null (), (0), ec); /* call with dummy args, we just want the error code */ if ec = 0 then do; call active_fnc_err_ (0, ME, "This command cannot be called as an active function."); go to EXIT; end; else return; end cant_be_active_function; %page; /* ********************************************************************** * Internal procedure to determine the number of arguments passed to * * the command and ensure that the minimum and maximum number of * * arguments for the command are not abused. * ********************************************************************** */ check_number_of_args: proc (min_args, max_args, usage, nargs); /* parameters */ dcl min_args fixed parameter; /* Input-Minimum number of arguments needed by this command */ dcl max_args fixed parameter; /* Input-Maximum number of arguments acceptable to this command. (0 means no maximum) */ dcl usage char (*) parameter; /* Input-Usage description for this command */ dcl nargs fixed parameter; /* Output-Actual number of arguments given to command */ nargs = cu_$arg_count (); if nargs < min_args /* not enough arguments, tell user what to do */ then call com_err_ (error_table_$noarg, ME, "^/^-Usage: ^a", usage); else if nargs > max_args & max_args ^= 0 /* too many arguments, tell user what to do */ then call com_err_ (error_table_$too_many_args, ME, "^/^-Usage: ^a", usage); else return; go to EXIT; end check_number_of_args; %page; /* ********************************************************************** * This internal procedure is used to get pointer and length for a * * required argument. * ********************************************************************** */ get_required_arg: proc (n, error_comment, ap, al); dcl n fixed parameter; /* Input-number of the argument we want to get */ dcl error_comment char (*) parameter; /* Input-comment to print with any error messages */ dcl ap ptr parameter; /* Output-pointer to argument */ dcl al fixed parameter; /* Output-length of argument */ dcl arg char (al) based (ap); /* the argument itself */ dcl ec fixed (35); /* error code */ call cu_$arg_ptr (n, ap, al, ec); if ec = 0 then if al > 0 /* check to make sure it's not another control arg */ then if substr (arg, 1, 1) = "-" then do; ec = error_table_$noarg; call com_err_ (ec, ME, error_comment); go to EXIT; end; else ; else ; else do; call com_err_ (ec, ME, error_comment); go to EXIT; end; return; end get_required_arg; %page; /* ********************************************************************** * Internal procedure to get a pathname, which may be a starname. * * -wd or -working_dir is accepted as meaning the working directory. * ********************************************************************** */ get_starname_arg: proc (arg, dir, et, is_star); dcl arg char (*) parameter; /* Input-path of the directory to usage (may be a starname) */ dcl dir char (*) parameter; /* Output-directory portion of pathname */ dcl et char (*) parameter; /* Output-entryname portion (starname) of pathname */ dcl is_star bit (1) aligned parameter; /* Output-"1"b if entryname is a starname */ dcl ec fixed (35); /* error code */ call expand_pathname_ (arg, dir, et, ec); if ec ^= 0 then do; call com_err_ (ec, ME, "^a", arg); go to EXIT; end; if dir = ">" & et = "" /* special case the ROOT */ then is_star = "0"b; else do; call check_star_name_$entry (et, ec); if ec > 2 then do; /* 1 and 2 have special meanings and do not indicate errors */ call com_err_ (ec, ME, "^a", arg); go to EXIT; end; else ; if ec = 0 then is_star = "0"b; else is_star = "1"b; end; return; end get_starname_arg; end check_file_system_damage;  copy.pl1 01/24/89 0858.0rew 01/24/89 0847.4 209439 /****^ ************************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1989 * * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * ************************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-02-13,TLNguyen), approve(87-02-13,MCR7619), audit(87-03-20,Gilcrease), install(87-03-24,MR12.1-1011): - Change "copy" to always display a correct error message when copying a specified extended entry types into unsuffixed targets. - Change "move" to always display a correct error message when moving a specified MSF that has unsufficient ACL requirements in order to move. - Change "copy" to always display a correct error message when copying a specified segment or star convention is applied and unsufficient ACL requirements for directory containing a specified segment. 2) change(88-10-03,Flegel), approve(89-01-09,MCR8020), audit(89-01-16,Lee), install(89-01-24,MR12.3-1012): Change sub_err_handler display of an error so that the causing pathname is properly displayed with the error according to the copy_error_info.target_err_switch value. This sort of backs out phx20384 as the solution addressed the wrong source its problem. END HISTORY COMMENTS */ /* format: style2,idind30,indcomtxt */ copy: cp: procedure () options (variable); /**** This is the standard service system command to copy a segment or multi-segment file. This procedure also includes the move command, which consists of a copy (with names and ACLs) followed by a delete. Both commands take multiple arguments and the star convention. Under control of optional arguments it will also copy extra names and/or the ACL of the segment. */ /* Coded 3 Aug 1969 David Clark */ /* Revised 25 Sept 1969 0935 DDC */ /* Modified by M Weaver 11 April 1970 */ /* Broken into four routines by John Strayhorn. July 1, 1970 */ /* Check for same directory, when copying names, added by T.Casey, Jan 1973 */ /* Modified June 4 1974 by Steve Herbst */ /* Rewritten: June 1979 by G. Palter, adding -chase in the process */ /* Bugs fixed, check for "copy foo" added 07/14/81 S. Herbst */ /* Changed move to move switches, max length, and ring brackets 11/17/82 S. Herbst */ /* Fixed to move MSF ring brackets correctly 12/15/82 S. Herbst */ /* Modified: 6/2/83 Jay Pattin moved it all to copy_ */ /* 831001 BIM infintessimally cleaned up for installation */ /* 841102 C Spitzer. fixed bug in sub_error_handler, getting null pointer fault if info_ptr not set */ /* 850206 MSharpe. changed -force_no_type to -inase/-inaee; modified to advise user that no non-dirs matched the starname */ dcl argument character (argument_lth) based (argument_ptr); dcl argument_lth fixed binary (21); dcl argument_ptr pointer; dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl (argument_count, arg_idx) fixed binary; dcl arg_list_ptr pointer; dcl NAME character (32); /* who I am */ dcl code fixed binary (35); dcl chase_sw bit (2) aligned; /* either default or one of two given values */ dcl (brief, copy_command_sw, entry_only_sw, have_paths) bit (1) aligned; dcl (successful_copy, inhibit_nomatch_error) bit (1) aligned; dcl (source_dir, target_dir) character (168); dcl (source_ename, target_eqname, ename) character (32); dcl source_stars fixed binary (35); dcl source_type fixed binary (2); dcl select_sw fixed binary (2); dcl idx fixed binary; dcl DEFAULT_2ND_NAME character (2) static options (constant) initial ("=="); dcl ( error_table_$argerr, error_table_$badopt, error_table_$badstar, error_table_$dirseg, error_table_$incorrect_access, error_table_$moderr, error_table_$namedup, error_table_$noarg, error_table_$noentry, error_table_$no_info, error_table_$not_seg_type, error_table_$sameseg, error_table_$inconsistent, error_table_$root, error_table_$unsupported_operation ) fixed binary (35) external; dcl (cleanup, sub_error_) condition; dcl ( com_err_, com_err_$suppress_name ) entry () options (variable); dcl check_star_name_$entry entry (character (*), fixed binary (35)); dcl continue_to_signal_ entry (fixed bin (35)); dcl copy_ entry (ptr); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl cu_$arg_ptr_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer); dcl expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35)); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl get_equal_name_ entry (character (*), character (*), character (*), fixed binary (35)); dcl get_system_free_area_ entry () returns (pointer); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl (addr, length, index, null, rtrim, search, string, substr, sum) builtin; %page; %include star_structures; %page; %include copy_options; %page; %include copy_flags; dcl 1 cpo aligned like copy_options; dcl 1 explicit aligned like copy_flags; %page; %include sub_error_info; %include condition_info_header; %page; %include condition_info; %include copy_error_info; %page; /* copy: cp: entry () options (variable); */ NAME = "copy"; copy_command_sw = "1"b; string (cpo.copy_items) = ""b; /* default options */ go to COMMON; /* This is the move command */ move: mv: entry () options (variable); NAME = "move"; copy_command_sw = "0"b; string (cpo.copy_items) = ""b; cpo.copy_items.acl, cpo.copy_items.names, cpo.copy_items.ring_brackets, cpo.copy_items.max_length, cpo.copy_items.copy_switch, cpo.copy_items.safety_switch, cpo.copy_items.dumper_switches = "1"b; /* Actual work starts here */ COMMON: chase_sw = "00"b; /* none supplied */ cpo.version = COPY_OPTIONS_VERSION_1; cpo.caller_name = NAME; cpo.copy_items.entry_bound = "1"b; /* always copy */ string (cpo.flags) = ""b; cpo.flags.delete = ^copy_command_sw; string (explicit) = ""b; call cu_$arg_count (argument_count, code); if code ^= 0 then do; call com_err_ (code, NAME); return; end; if argument_count = 0 then do; USAGE: call com_err_ (error_table_$noarg, NAME, "^/^6xUsage: ^a path1 {equal_name1 ...} {-control_args}", NAME); return; end; /* Scan for control arguments */ have_paths = "0"b; /* haven't found any yet */ do arg_idx = 1 to argument_count; call cu_$arg_ptr (arg_idx, argument_ptr, argument_lth, code); if code ^= 0 then do; call com_err_ (code, NAME, "Fetching argument #^d.", arg_idx); return; end; if substr (argument, 1, 1) ^= "-" then have_paths = "1"b; /* found some pathnames */ else if (argument = "-brief") | (argument = "-bf") then brief = "1"b; else if (argument = "-long") | (argument = "-lg") then brief = "0"b; else if (argument = "-all") | (argument = "-a") then cpo.copy_items.acl, cpo.copy_items.names, cpo.copy_items.ring_brackets, cpo.copy_items.max_length, cpo.copy_items.copy_switch, cpo.copy_items.safety_switch, cpo.copy_items.dumper_switches = "1"b; else if (argument = "-acl") then cpo.copy_items.acl, explicit.acl = "1"b; else if (argument = "-no_acl") then cpo.copy_items.acl, explicit.acl = "0"b; else if (argument = "-name") | (argument = "-nm") then cpo.copy_items.names, explicit.names = "1"b; else if (argument = "-no_name") | (argument = "-nnm") then cpo.copy_items.names, explicit.names = "0"b; else if (argument = "-chase") then chase_sw = "11"b; /* explicit request to do chasing */ else if (argument = "-no_chase") then chase_sw = "10"b; else if argument = "-force" | argument = "-fc" then cpo.flags.force = "1"b; else if argument = "-no_force" | argument = "-nfc" then cpo.flags.force = "0"b; else if argument = "-max_length" | argument = "-ml" then cpo.copy_items.max_length, explicit.max_length = "1"b; else if argument = "-no_max_length" | argument = "-nml" then cpo.copy_items.max_length, explicit.max_length = "0"b; else if argument = "-ring_brackets" | argument = "-rb" then cpo.copy_items.ring_brackets, explicit.ring_brackets = "1"b; else if argument = "-no_ring_brackets" | argument = "-nrb" then cpo.copy_items.ring_brackets, explicit.ring_brackets = "0"b; else if argument = "-copy_switch" | argument = "-csw" then cpo.copy_items.copy_switch, explicit.copy_switch = "1"b; else if argument = "-no_copy_switch" | argument = "-ncsw" then cpo.copy_items.copy_switch, explicit.copy_switch = "0"b; else if argument = "-safety_switch" | argument = "-ssw" then cpo.copy_items.safety_switch, explicit.safety_switch = "1"b; else if argument = "-no_safety_switch" | argument = "-nssw" then cpo.copy_items.safety_switch, explicit.safety_switch = "0"b; else if argument = "-volume_dumper_switches" | argument = "-vdsw" then cpo.copy_items.dumper_switches, explicit.dumper_switches = "1"b; else if argument = "-no_volume_dumper_switches" | argument = "-nvdsw" then cpo.copy_items.dumper_switches, explicit.dumper_switches = "0"b; else if argument = "-entry_bound" | argument = "-eb" then cpo.copy_items.entry_bound, explicit.entry_bound = "1"b; else if argument = "-no_entry_bound" | argument = "-neb" then cpo.copy_items.entry_bound, explicit.entry_bound = "0"b; else if argument = "-extend" then do; cpo.copy_items.extend = "1"b; cpo.copy_items.update = "0"b; end; else if ^copy_command_sw then goto BADOPT; else if argument = "-replace" | argument = "-rp" then cpo.copy_items.extend, cpo.copy_items.update = "0"b; else if argument = "-update" | argument = "-ud" then do; cpo.copy_items.update = "1"b; cpo.copy_items.extend = "0"b; end; else if argument = "-interpret_as_standard_entry" | argument = "-inase" then cpo.flags.raw = "1"b; else if argument = "-interpret_as_extended_entry" | argument = "-inaee" then cpo.flags.raw = "0"b; else do; BADOPT: call com_err_ (error_table_$badopt, NAME, """^a""", argument); return; end; end; if ^have_paths then /* nothing to work on */ go to USAGE; if (cpo.copy_items.extend | cpo.copy_items.update) & (cpo.copy_items.acl | cpo.copy_items.names | cpo.copy_items.ring_brackets | cpo.copy_items.max_length | cpo.copy_items.copy_switch | cpo.copy_items.safety_switch | cpo.copy_items.dumper_switches) then do; call com_err_ (error_table_$inconsistent, NAME, "Attributes may not be copied when -^[extend^;update^] is used.", cpo.copy_items.extend); return; end; /* */ system_area_ptr = get_system_free_area_ (); star_entry_ptr, /* so cleanup will work */ star_names_ptr = null (); on condition (cleanup) call clean_up (); /* Process the pairs of pathnames supplied */ arg_list_ptr = cu_$arg_list_ptr (); do arg_idx = 1 to argument_count; call cu_$arg_ptr (arg_idx, argument_ptr, argument_lth, (0)); /* known to work from above */ if substr (argument, 1, 1) ^= "-" then do; /* ignore control args */ entry_only_sw = (search (argument, "<>") = 0); call expand_pathname_ (argument, source_dir, source_ename, code); if code ^= 0 then do; call com_err_ (code, NAME, "^a", argument); call find_second_arg (); go to NEXT_PAIR; end; call check_star_name_$entry (source_ename, source_stars); if (source_stars ^= 0) & (source_stars ^= 1) & (source_stars ^= 2) then do; call com_err_ (source_stars, NAME, "^a", pathname_ (source_dir, source_ename)); call find_second_arg (); go to NEXT_PAIR; end; call find_second_arg (); /* move on to second pair (if any) */ if arg_idx > argument_count then do; /* none, use === */ if entry_only_sw then do; call com_err_ (0, NAME, "No target pathname specified."); return; end; argument_ptr = addr (DEFAULT_2ND_NAME); argument_lth = length (DEFAULT_2ND_NAME); end; call expand_pathname_ (argument, target_dir, target_eqname, code); if code ^= 0 then do; call com_err_ (code, NAME, "^a", argument); go to NEXT_PAIR; end; call check_star_name_$entry (target_eqname, code); if code ^= 0 then do; if code > 2 then /* code = error_table_$badstar */ /* fix an incorrect error message, for example ! copy foo > */ if argument = ">" then do; call com_err_ (error_table_$root, NAME, "^a. Your request has been aborted.", argument); go to NEXT_PAIR; end; /* end of bug fix */ else call com_err_ (code, NAME, "^a", pathname_ (target_dir, target_eqname)); else call com_err_ (0, NAME, "Star convention not allowed in second argument. ^a", pathname_ (target_dir, target_eqname)); go to NEXT_PAIR; end; /* Preliminary checks OK for this pair; now do the work */ if source_stars = 0 then do; /* source name is a single entry */ if chase_sw = "10"b then do; /* user doesn't want links chased */ call hcs_$status_minf (source_dir, source_ename, 0b, source_type, (0), code); if code ^= 0 then do; call com_err_ (code, NAME, "^a", pathname_ (source_dir, source_ename)); go to NEXT_PAIR; end; if source_type = star_LINK then do; call com_err_ (0, NAME, "^a is a link and ""-no_chase"" was specified.", pathname_ (source_dir, source_ename)); go to NEXT_PAIR; end; end; call process_entry (source_ename, "1"b, ("0"b)); /* ignore the successful_copy bit */ end; /* do the work */ else do; /* source name is a star name */ if chase_sw = "11"b then select_sw = star_ALL_ENTRIES; /* request -chase */ else select_sw = star_BRANCHES_ONLY; call hcs_$star_ (source_dir, source_ename, select_sw, system_area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then /* fix bug for TR number 19526 */ if code = error_table_$moderr then do; call com_err_ (error_table_$incorrect_access, NAME, "^a", pathname_ (source_dir, source_ename)); go to NEXT_PAIR; end; /* end of bug fix */ else do; call com_err_ (code, NAME, "^a", pathname_ (source_dir, source_ename)); go to NEXT_PAIR; end; inhibit_nomatch_error, successful_copy = "0"b; /* If still OFF after the loop, there were no non-dirs that matched the starname */ do idx = 1 to star_entry_count; ename = star_names (star_entries (idx).nindex); call process_entry (ename, "0"b, successful_copy); end; /* ignore directories */ if ^successful_copy & ^inhibit_nomatch_error then call com_err_ (0, NAME, "No entries of appropriate type matched the starname ^a", pathname_ (source_dir, source_ename)); end; NEXT_PAIR: call clean_up (); /* free up anything still around */ end; /* of non-control argument */ end; /* */ /* This internal procedure cleans up after an argument pair */ clean_up: procedure (); if star_names_ptr ^= null () then do; free star_names in (system_area); star_names_ptr = null (); end; if star_entry_ptr ^= null () then do; free star_entries in (system_area); star_entry_ptr = null (); end; return; end clean_up; /* */ find_second_arg: procedure (); /* This internal procedure scans the argument list looking for the second pathname of the current pair (if any) */ do arg_idx = (arg_idx + 1) to argument_count; call cu_$arg_ptr_rel (arg_idx, argument_ptr, argument_lth, (0), arg_list_ptr); if substr (argument, 1, 1) ^= "-" then /* found it */ return; end; arg_idx = argument_count + 1; /* none found */ return; end find_second_arg; %page; process_entry: /* copy one segment */ procedure (P_ename, P_report_dirseg, P_successful_copy); dcl P_ename character (32) parameter; /* source entry name */ dcl P_report_dirseg bit (1) aligned parameter; /* ON => e_t_$dirseg on source */ dcl P_successful_copy bit (1) aligned parameter; /* OUTPUT: ON => entry successfully copied */ dcl bit_count fixed binary (24); /* bit count returned by hcs_$status_minf. */ dcl (source_ename, target_ename) character (32); dcl code fixed binary (35); dcl target_type fixed binary (2); /* type of a target entryname returned by hcs_$status_minf. */ source_ename = P_ename; bit_count = -0; /* initialized */ target_type = -0; /* initialized */ call get_equal_name_ (source_ename, target_eqname, target_ename, code); if code ^= 0 then do; call com_err_ (code, NAME, "^a for ^a", pathname_ (target_dir, target_eqname), source_ename); return; end; cpo.source_dir = source_dir; cpo.source_name = source_ename; cpo.target_dir = target_dir; cpo.target_name = target_ename; on sub_error_ call sub_err_handler (); /* copy_ reports erors with sub_err_ */ call copy_ (addr (cpo)); /* go to it */ P_successful_copy = "1"b; COPY_LOST: return; %page; sub_err_handler: proc (); declare 1 ci aligned like condition_info; declare reverse builtin; declare suffix_name char (8) varying init (""); declare temp_source_ename char (32) varying init (""); ci.version = condition_info_version_1; call find_condition_info_ (null (), addr (ci), (0)); sub_error_info_ptr = ci.info_ptr; if sub_error_info.name ^= "copy_" then do; CONTINUE_TO_SIGNAL: call continue_to_signal_ ((0)); goto END_HANDLER; end; else if sub_error_info.info_ptr = null then goto CONTINUE_TO_SIGNAL; else if copy_error_info.copy_options_ptr ^= addr (cpo) then goto CONTINUE_TO_SIGNAL; code = sub_error_info.status_code; if sub_error_info.cant_restart then do; /* copy failed */ if ^copy_error_info.target_err_switch then if code = error_table_$dirseg then /* source is a directory */ if ^P_report_dirseg then /* but that's OK for starnames */ goto COPY_LOST; inhibit_nomatch_error = "1"b; /* found an appropriate entry that matched the starname, but still didn't get it copied -- Don't report a nomatch for this starname */ if code ^= error_table_$namedup then /* already reported */ /* fix bug for TR number phx20617 */ if (code = error_table_$badstar) | (code = error_table_$argerr) then do; temp_source_ename = reverse (rtrim (source_ename)); suffix_name = substr (temp_source_ename, 1, (index (temp_source_ename, ".") - 1)); suffix_name = reverse (suffix_name); call com_err_ (error_table_$not_seg_type, NAME, "The .^a suffix was missing from ^a", suffix_name, pathname_ (target_dir, target_ename)); end; /* fix bug for TR number phx19526 */ else if code = error_table_$no_info then call com_err_ (error_table_$incorrect_access, NAME, sub_error_info.info_string); /* end of bug fixes */ else call com_err_ (code, NAME, sub_error_info.info_string); else; if ^copy_command_sw then if (code ^= error_table_$noentry) & (code ^= error_table_$dirseg) & (code ^= error_table_$moderr) & (code ^= error_table_$sameseg) & (code ^= error_table_$namedup) then call com_err_$suppress_name (0, NAME, "Segment ^a not deleted.", pathname_ (source_dir, source_ename)); goto COPY_LOST; end; /* fatal error */ else if sub_error_info.default_restart then if ^brief then call com_err_ (code, NAME, sub_error_info.info_string); else ; else do; if code = error_table_$unsupported_operation then if badop () then call com_err_ (0, NAME, sub_error_info.info_string); else ; /* fix an incorrect error message for TR number phx20384, this is backed out * with phx20481 as the original repair was incorrect */ else do; call com_err_ (code, NAME, sub_error_info.info_string); goto COPY_LOST; end; /* end of fixing */ end; END_HANDLER: return; end sub_err_handler; %page; badop: /* returns true iff operation specifically requested */ proc returns (bit (1) aligned); declare op char (32); op = copy_error_info.operation; if op = "names" then return (explicit.names | ^copy_command_sw); if op = "ACL" then return (explicit.acl | ^copy_command_sw); if op = "ring brackets" then return (explicit.ring_brackets); if op = "max length" then return (explicit.max_length); if op = "copy switch" then return (explicit.copy_switch); if op = "safety switch" then return (explicit.safety_switch); if op = "dumper switches" then return (explicit.dumper_switches); if op = "entry bound" then return (explicit.entry_bound); return ("1"b); /* if we don't recognize it, print it. */ end badop; end process_entry; end copy;  copy_.pl1 10/14/90 0932.7rew 10/14/90 0915.0 220482 /****^ ************************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * ************************************************************** */ /****^ HISTORY COMMENTS: 1) change(88-10-03,Flegel), approve(88-11-16,MCR8020), audit(89-01-16,Lee), install(89-01-24,MR12.3-1012): phx19616 - created procedure change_source_dir, see function header for info. phx20481 - repaired ioa_ control strings for calls to error and warning so that all 3 arguments are properly accounted for. phx21214 - reorder the copying of characteristics so that the ACL is copied last and the ring_brackets are second last. 2) change(88-11-10,Flegel), approve(88-12-22,MCR8028), audit(89-01-16,Lee), install(89-01-24,MR12.3-1012): phx21056 / phx21147 - ignore error_table_$action_not_performed when setting max_length and allow suffix_XXX_ to set the max_length appropriately when the copy is first perfomed. 3) change(89-01-31,Flegel), approve(89-03-08,PBF8020), audit(89-03-09,Lee), install(89-03-13,MR12.3-1023): Post Bug Fix - The call to sub_error_ had control string backwards in respect to the pathnames that were to be used based on the value of switch. 4) change(89-11-15,Flegel), approve(89-11-16,MECR0014), audit(89-11-15,LZimmerman), install(89-11-16,MR12.3-1118): Repair "change_source_dir" subroutine to verify that the target is a real directory (which excludes MSFs). 5) change(89-12-14,Flegel), approve(89-12-14,MCR8151), audit(89-12-14,LZimmerman), install(90-04-19,MR12.4-1007): Install MECR0014 through regular installation procedures. 6) change(90-09-04,Huen), approve(90-09-04,MCR8195), audit(90-09-26,Vu), install(90-10-14,MR12.4-1039): phx21348 (cmds_837) - Fix the error handling of the copy/move commands by intercepting the "sub_error" condition. END HISTORY COMMENTS */ /* format: style2,indcomtxt,idind30 */ copy_: proc (P_copy_options_ptr); /* This is the primitive used to copy (and move) segments. Jay Pattin 6/2/83 */ /**** BIM 830923 rework of object_type_ to fs_util_ */ /**** BIM 831022 split into fs_copy_ and copy_. */ /**** BIM 831031 fixed raw mode to use source type instead of target. */ /**** BIM 1984-07-27 fix copying with the raw switch. */ /**** C Spitzer 841102 fix bug in sub_err_ call */ /**** MSharpe 850206 to check the hcs type of the source before calling nd_handler_ */ /**** * copy_ is the advertised interface for copying objects. copy_ uses fs_util_$copy to copy the contents, and then various copy_XXX_ utilities to copy other atrributes. In raw mode, it forcibly uses segment or msf copying in fs_standard_object_, and does attributes appropriately. */ declare P_copy_options_ptr ptr parameter; declare errsw bit (1) aligned; declare forced_access bit (1) aligned; declare max_length fixed bin (19); declare raw bit (1) aligned; declare same_dir_sw bit (1) aligned; declare ring_brackets (64) fixed bin (3); declare source_dir char (168); declare source_name char (32); declare source_type char (32); declare target_dir char (168); declare target_name char (32); declare (source_uid, target_uid) bit (36) aligned; declare fs_type char (32); declare (source_hcs_type, target_hcs_type) fixed bin (2); declare old_source_dir char (168); declare 1 bks aligned like status_for_backup; declare 1 si aligned like suffix_info; declare 1 cei aligned like copy_error_info; declare ( error_table_$nonamerr, error_table_$dirseg, error_table_$namedup, error_table_$noentry, error_table_$no_info, error_table_$sameseg, error_table_$segnamedup, error_table_$unimplemented_version, error_table_$unsupported_operation, error_table_$action_not_performed ) fixed bin (35) external; declare copy_acl_ entry (char (*), char (*), char (*), char (*), bit (1) aligned, fixed bin (35)); declare copy_names_ entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned, fixed bin (35)); declare delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35)); declare expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); declare ( hcs_$chname_file, fs_util_$chname_file ) entry (char (*), char (*), char (*), char (*), fixed bin (35)); declare hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35)); declare hcs_$get_uid_file entry (char (*), char (*), bit (36) aligned, fixed bin (35)); declare hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); declare hcs_$set_entry_bound entry (char (*), char (*), fixed bin (14), fixed bin (35)); declare hcs_$status_for_backup entry (char (*), char (*), ptr, fixed bin (35)); declare move_names_ entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned, fixed bin (35)); declare nd_handler_$switches entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35)); declare get_shortest_path_ entry (char (*)) returns (char (168)); declare get_system_free_area_ entry () returns (ptr); declare hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); declare 1 entries aligned, 2 ( copy_entry entry (ptr, fixed bin (35)), (get_ml_entry, set_ml_entry) entry (char (*), char (*), fixed bin (19), fixed bin (35)), (get_rb_entry, set_rb_entry) entry (char (*), char (*), (*) fixed bin (3), fixed bin (35)), (get_switch_entry, set_switch_entry) entry (char (*), char (*), char (*), bit (1) aligned, fixed bin (35)) ) variable; declare fs_util_$suffix_info_for_type entry (char (*), ptr, fixed bin (35)); declare fs_util_$get_type entry (char (*), char (*), char (*), fixed bin (35)); declare fs_util_$make_entry_for_type entry (char (*), char (*), entry, fixed bin (35)); /* declare fs_util_$copy entry (pointer, fixed bin (35)); */ declare sub_err_ entry options (variable); declare pathname_ entry (char (*), char (*)) returns (char (168)); declare code fixed bin (35); declare (addr, fixed, rtrim, string, index, length, pointer, substr) builtin; /* format: off */ %page; %include status_structures; %page; %include status_for_backup; %page; %include suffix_info; %page; %include copy_options; %page; %include copy_flags; %page; %include access_mode_values; %page; %include delete_options; %page; %include nd_handler_options; %page; %include sub_error_info; %page; %include sub_err_flags; %page; %include condition_info_header; %page; %include condition_info; %page; %include copy_error_info; %page; %include file_system_operations; /* format: on */ entries = Dummy_Procedure; /* aggregately */ old_source_dir = ""; /* No source dir change */ copy_options_ptr = P_copy_options_ptr; if copy_options.version ^= COPY_OPTIONS_VERSION_1 then call copy_error (error_table_$unimplemented_version, "0"b); if copy_options.extend & copy_options.update then call fatal (0, "contents", "0"b, "The extend and update switches may not both be specified."); source_dir = copy_options.source_dir; source_name = copy_options.source_name; target_dir = copy_options.target_dir; target_name = copy_options.target_name; raw = copy_options.raw; forced_access = "0"b; call hcs_$status_minf (source_dir, source_name, 1 /* chase */, source_hcs_type, (0), code); if code ^= 0 then if code ^= error_table_$no_info /* may not be true for inner-ring entries; fs_util_$get_type will catch this anyway */ then call copy_error (code, "0"b); call fs_util_$get_type (source_dir, source_name, source_type, code); if code = 0 & source_type = FS_OBJECT_TYPE_DIRECTORY then code = error_table_$dirseg; if code ^= 0 then call copy_error (code, "0"b); call hcs_$status_minf (target_dir, target_name, 0, target_hcs_type, (0), code); /* does target already exist? */ if code = error_table_$noentry then /* Has to if updating or extending */ if copy_options.extend | copy_options.update then call copy_error (code, "1"b); else ; else do; /* check if source = target */ if code ^= 0 then call copy_error (code, "1"b); call hcs_$get_uid_file (source_dir, source_name, source_uid, (0)); call hcs_$get_uid_file (target_dir, target_name, target_uid, (0)); if source_uid = target_uid then if target_hcs_type ^= Link then call copy_error (error_table_$sameseg, "1"b); else do; /* in case we delete the link, get real source path */ call hcs_$get_link_target (copy_options.source_dir, copy_options.source_name, source_dir, source_name, code); if code ^= 0 then call copy_error (code, "0"b); copy_options.source_dir = source_dir; copy_options.source_name = source_name; end; if ^copy_options.no_name_dup & ^copy_options.extend & ^copy_options.update then do; /* MF - phx19616 - make sure pathname in source will not change */ call change_source_dir (); string (nd_handler_options) = ""b; nd_handler_options.delete_force = copy_options.force; nd_handler_options.raw = raw; call nd_handler_$switches (copy_options.caller_name, target_dir, target_name, string (nd_handler_options), code); if code ^= 0 then do; if code = error_table_$action_not_performed then code = error_table_$namedup; call copy_error (code, "1"b); end; end; end; /* name duplication */ if raw then /* we could use a GET_REAL_TYPE, ... */ if source_hcs_type = Segment then fs_type = FS_OBJECT_TYPE_SEGMENT; else fs_type = FS_OBJECT_TYPE_MSF; else fs_type = source_type; call fs_util_$make_entry_for_type (fs_type, FS_COPY, copy_entry, (0)); call fs_util_$make_entry_for_type (fs_type, FS_GET_RING_BRACKETS, get_rb_entry, (0)); call fs_util_$make_entry_for_type (fs_type, FS_SET_RING_BRACKETS, set_rb_entry, (0)); call fs_util_$make_entry_for_type (fs_type, FS_GET_MAX_LENGTH, get_ml_entry, (0)); call fs_util_$make_entry_for_type (fs_type, FS_SET_MAX_LENGTH, set_ml_entry, (0)); call fs_util_$make_entry_for_type (fs_type, FS_GET_SWITCH, get_switch_entry, (0)); call fs_util_$make_entry_for_type (fs_type, FS_SET_SWITCH, set_switch_entry, (0)); si.version = SUFFIX_INFO_VERSION_1; call fs_util_$suffix_info_for_type (fs_type, addr (si), code); if code ^= 0 then call copy_error (code, "0"b); if (copy_options.extend & ^si.copy_flags.extend) | (copy_options.update & ^si.copy_flags.update) then call copy_error (error_table_$unsupported_operation, "0"b); /* phx21348 - use original if no source dir change */ if (old_source_dir = "") /* No source_dir change */ then call copy_entry (copy_options_ptr, code); /* Grab the contents */ else begin; /* pass modified copy of struc that contains a valid source_dir */ /* MF - phx19616 - need to use a local version of copy_options so we don't * change the original passed into us when there is a source_dir change */ declare 1 co aligned like copy_options; declare sub_error_ condition; co = copy_options; co.source_dir = source_dir; /* source_dir change */ /* phx21348 - If the sub_error_ condition occurs and the error was caused * using the modifed copy of the copy_options struc (co) then we patch * copy_error_info.copy_options_ptr to point back to the original version. * This is necessary because the handler in the 'copy' command uses this * value to determine whether to handle the condition. */ on sub_error_ begin; declare 1 ci aligned like condition_info; declare continue_to_signal_ entry (fixed bin(35)); declare find_condition_info_ entry (ptr, ptr, fixed bin(35)); declare null builtin; ci.version = condition_info_version_1; call find_condition_info_ (null (), addr (ci), (0)); sub_error_info_ptr = ci.info_ptr; if sub_error_info.name = "copy_" & copy_error_info.copy_options_ptr = addr(co) then copy_error_info.copy_options_ptr = P_copy_options_ptr; call continue_to_signal_ ((0)); end; /* of sub_error_ patch handler */ call copy_entry (addr (co), code); /* Grab the contents */ end; if code ^= 0 then call copy_error (code, (copy_options.target_err_switch)); /* MF - phx21214 - reorganized the characteristic copying section so that * the ACL is last (except for source deletion) and the ring_brackets are * second last. */ if copy_options.max_length then if ^si.copy_flags.max_length then call unsup ("max length"); else do; call get_ml_entry (source_dir, source_name, max_length, code); if code ^= 0 then call error (code, "max length", "0"b, "Getting max length on ^[^s^a^;^a^s^]."); else do; call set_ml_entry (target_dir, target_name, max_length, code); /* MF - phx21056 - ignore action_not_performed error code */ if code ^= 0 & code ^= error_table_$action_not_performed then call error (code, "max length", "1"b, "Setting max length on ^[^s^a^;^a^s^]."); end; end; if copy_options.copy_switch then if ^si.copy_flags.copy_switch then call unsup ("copy switch"); else call copy_switch ("copy"); if copy_options.safety_switch then if ^si.copy_flags.safety_switch then call unsup ("safety switch"); else call copy_switch ("safety"); if copy_options.dumper_switches then if ^si.copy_flags.dumper_switches then call unsup ("dumper switches"); else do; call copy_switch ("complete_volume_dump"); call copy_switch ("incremental_volume_dump"); end; if copy_options.entry_bound then do; if fs_type ^= FS_OBJECT_TYPE_SEGMENT then goto NOT_GATE; bks.version = status_for_backup_version_2; call hcs_$status_for_backup (source_dir, source_name, addr (bks), code); if code ^= 0 then call error (code, "entry bound", "0"b, "Getting entry bound on ^[^s^a^;^a^s^]."); else if ^bks.entrypt then NOT_GATE: call error (error_table_$unsupported_operation, "entry bound", "0"b, "Entry has no entry bound to copy. ^[^s^a^;^a^s^]"); else do; call hcs_$set_entry_bound (target_dir, target_name, fixed (bks.entrypt_bound), code); if code ^= 0 then call error (code, "entry bound", "1"b, "Setting entry bound on ^[^s^a^;^a^s^]."); end; end; if copy_options.ring_brackets then if ^si.copy_flags.ring_brackets then call unsup ("ring brackets"); else do; call get_rb_entry (source_dir, source_name, ring_brackets, code); if code ^= 0 then call error (code, "ring brackets", "0"b, "Getting ring brackets on ^[^s^a^;^a^s^]."); else do; call set_rb_entry (target_dir, target_name, ring_brackets, code); if code ^= 0 then call error (code, "ring brackets", "1"b, "Setting ring brackets on ^[^s^a^;^a^s^]."); end; end; /**** NOTE -- since we don't have copy_XXX_$raw yet, we have to skip these! */ if ^raw then do; if copy_options.acl then if ^si.copy_flags.acl then call unsup ("ACL"); else do; call copy_acl_ (source_dir, source_name, target_dir, target_name, errsw, code); if code ^= 0 then call error (code, "ACL", errsw, "Copying ACL ^[from ^a^s^;to ^s^a^]."); end; if copy_options.names then if ^si.copy_flags.names then call unsup ("names"); else do; same_dir_sw = same_dirp (); if same_dir_sw then do; /* If in same dir, have to move names */ if ^copy_options.delete then call warning (0, "names", "1"b, "Source and target are in the same directory. Names will be moved instead of copied." ); call move_names_ (source_dir, source_name, target_dir, target_name, copy_options.caller_name, errsw, code); end; else call copy_names_ (source_dir, source_name, target_dir, target_name, copy_options.caller_name, errsw, code); if code ^= 0 & code ^= error_table_$namedup & code ^= error_table_$segnamedup then call error (code, "names", errsw, "Copying names ^[from ^a^s^;to ^s^a^]."); end; end; if copy_options.delete then do; string (delete_options) = ""b; delete_options.segment, delete_options.link, delete_options.chase, delete_options.question = "1"b; delete_options.force = copy_options.force; delete_options.raw = raw; call delete_$path (source_dir, source_name, string (delete_options), copy_options.caller_name, code); if code ^= 0 then if code ^= error_table_$action_not_performed then call error (code, "delete", "0"b, "Deleting ^[^s^a^;^a^s^]."); if copy_options.names & same_dir_sw then do; if raw then call hcs_$chname_file (target_dir, target_name, "", source_name, code); else call fs_util_$chname_file (target_dir, target_name, "", source_name, code); if code ^= 0 then call error (code, "names", "1"b, "Copying names to ^[^s^a^;^a^s^]."); end; end; MAIN_RETURN: return; %page; same_dirp: proc returns (bit (1) aligned); declare dir_dir char (168), dir_ent char (32); if source_dir = target_dir then return ("1"b); call expand_pathname_ (source_dir, dir_dir, dir_ent, (0)); call hcs_$get_uid_file (dir_dir, dir_ent, source_uid, (0)); call expand_pathname_ (target_dir, dir_dir, dir_ent, (0)); call hcs_$get_uid_file (dir_dir, dir_ent, target_uid, (0)); return (source_uid = target_uid); end same_dirp; copy_switch: proc (switch_name); declare switch_name char (*), value bit (1) aligned; call get_switch_entry (source_dir, source_name, switch_name, value, code); if code ^= 0 then call error (code, rtrim (switch_name) || "switch", "0"b, "Getting switch from ^[^s^a^;^a^s^]."); else do; call set_switch_entry (target_dir, target_name, switch_name, value, code); if code ^= 0 then call error (code, rtrim (switch_name) || "switch", "1"b, "Setting switch on ^[^s^a^;^a^s^]."); end; return; end copy_switch; change_source_dir: proc (); /* FUNCTION phx19616 - Determine whether or not there will be a conflict in names between a target pathname and some component of the source directory. If there is, then the source dir will be changed so that a new name is inserted where the conflict occurs. If there are no other names to use, then it will merely return to let nd_handler and the user resolve what to do. */ /* MISC VARIABLES */ declare short_target_path char (168) var; declare short_target_dir char (168) var; declare short_source_dir char (168) var; declare target_type char (32); declare done bit (1); declare i fixed bin; declare 1 sb aligned like status_branch; /* INIT */ short_target_dir = rtrim (get_shortest_path_ (target_dir)); short_source_dir = rtrim (get_shortest_path_ (source_dir)); short_target_path = rtrim (pathname_ (rtrim (short_target_dir), target_name)); /* MAIN */ /* Find out what type of file we are targetting to */ call fs_util_$get_type (target_dir, target_name, target_type, code); if (code ^= 0) then do; call error (code, "copy_", "1"b, "Getting file system type of ^[^s^a^;^a^s^]"); return; end; /* A target DIRECTORY contained in the source DIRECTORY is potential */ if (target_type = FS_OBJECT_TYPE_DIRECTORY) & (index (short_source_dir, short_target_path) > 0) then do; status_ptr = addr (sb); status_area_ptr = get_system_free_area_ (); call hcs_$status_ (target_dir, target_name, 0, status_ptr, status_area_ptr, code); if (code ^= 0) then call error (code, "status", "0"b, "Getting status on ^[^s^a^;^a^s^]"); done = "0"b; /* Is there really a contention? */ do i = 1 to status_branch.short.nnames; if status_entry_names (i) = target_name then do; /* Found, so get out of the loop */ done = "1"b; i = status_branch.short.nnames; end; end; if ^done then do; /* No, then get out */ free status_entry_names; return; end; i = 1; /* Look for another name to use */ done = "0"b; do while (^done); if (i > status_branch.short.nnames) then /* None at all */ done = "1"b; else if (status_entry_names (i) ^= target_name) then /* Found */ done = "1"b; else /* Keep trying */ i = i + 1; end; if (i > status_branch.short.nnames) then do; /* Oh-oh, can't continue */ free status_entry_names; call fatal (error_table_$nonamerr, "copy_", "1"b, "^s^s^a. Source will be deleted before copy completed."); return; end; /* Rearrange the names so that there will be no contention */ old_source_dir = source_dir; source_dir = short_target_dir || ">" || rtrim (status_entry_names (i)); if length (short_target_path) < length (short_source_dir) then source_dir = rtrim (source_dir) || substr (short_source_dir, length (short_target_path) + 1); free status_entry_names; end; end change_source_dir; copy_error: proc (status, switch); declare status fixed bin (35), switch bit (1) aligned; cei.copy_options_ptr = copy_options_ptr; cei.operation = "contents"; cei.target_err_switch = switch; do while ("1"b); call sub_err_ (status, "copy_", ACTION_CANT_RESTART, addr (cei), (0), "^[^a^s^;^s^a^]", switch, pathname_ (target_dir, target_name), pathname_ (source_dir, source_name)); end; end copy_error; unsup: proc (op); declare op char (32); cei.copy_options_ptr = copy_options_ptr; cei.operation = op; cei.target_err_switch = "0"b; call sub_err_ (error_table_$unsupported_operation, "copy_", ACTION_CAN_RESTART, addr (cei), (0), "The ^a object type does not support the copying of ^a. ^a", si.type_name, op, pathname_ (source_dir, source_name)); return; end unsup; error: proc (status, op, switch, message); declare flags bit (36) aligned, status fixed bin (35), op char (*), switch bit (1) aligned, message char (*); flags = ACTION_CAN_RESTART; goto COMMON; fatal: entry (status, op, switch, message); flags = ACTION_CANT_RESTART; goto COMMON; warning: entry (status, op, switch, message); flags = ACTION_DEFAULT_RESTART; COMMON: cei.copy_options_ptr = copy_options_ptr; cei.operation = op; cei.target_err_switch = switch; call sub_err_ (status, "copy_", flags, addr (cei), (0), message, switch, pathname_ (source_dir, source_name), pathname_ (target_dir, target_name)); return; end error; Dummy_Procedure: procedure options (non_quick); declare cu_$arg_count entry (fixed bin, fixed bin (35)); declare cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); declare last_arg_x fixed bin; declare code_ptr pointer; declare code fixed bin (35) based (code_ptr); declare error_table_$no_operation fixed bin (35) ext static; call cu_$arg_count (last_arg_x, (0)); call cu_$arg_ptr (last_arg_x, code_ptr, (0), (0)); code = error_table_$no_operation; return; end Dummy_Procedure; end copy_;  copy_acl.pl1 09/12/84 1456.6rew 09/12/84 1451.6 78471 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * ************************************************************** */ /* format: style2,idind30,indcomtxt */ copy_acl: procedure options (variable); /* COPY_ACL, COPY_IACL_SEG, COPY_IACL_DIR */ /* initial coding 8/76 THVV */ /* Added -working_dir or -wd in place of pathnames 07/25/80 S. Herbst */ /* cleaned and neatened BIM and J. Pattin, 83-(8 9) */ /* Modified 11/01/83 by C. Spitzer. fix arg processing bug, allow equal convention in place of missing last argument */ dcl arg char (al) based (ap); dcl (dn1, dn2) char (168); dcl (en1, en2) char (32); dcl error_sw bit (1); dcl (ap, areap) ptr; dcl (eptr, nptr) ptr init (null); dcl whoami char (13); dcl (i, ecount) fixed bin; dcl al fixed bin (21); dcl an fixed bin init (1); dcl (starsw, areasw) bit (1) init ("0"b); dcl system_area area ((1024)) based (areap); dcl 1 entries (100) based (eptr) aligned, 2 type bit (2) unaligned, 2 nnames bit (16) unaligned, 2 nindex bit (18) unaligned; dcl names (100) char (32) based (nptr); dcl arg_count fixed bin; dcl code fixed bin (35); dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$noarg fixed bin (35) ext; dcl error_table_$odd_no_of_args fixed bin (35) ext; dcl error_table_$badequal fixed bin (35) ext; dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl com_err_$suppress_name entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl get_equal_name_ entry (char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin, ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl get_wdir_ entry returns (char (168)); dcl copy_acl_ entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35)); dcl copy_iacl_$dir entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35)); dcl copy_iacl_$seg entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl (addr, addrel, bin, null) builtin; dcl cleanup condition; whoami = "copy_acl"; go to start; copy_iacl_seg: entry; whoami = "copy_iacl_seg"; go to start; copy_iacl_dir: entry; whoami = "copy_iacl_dir"; start: call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, whoami); return; end; if arg_count = 0 then do; call com_err_$suppress_name (0, whoami, "Usage: ^a path11 {path21 ... pathN1 {pathN2}}", whoami); return; end; do an = 1 to arg_count by 2; call cu_$arg_ptr (an, ap, al, (0)); if index (arg, "-") = 1 then if arg = "-working_dir" | arg = "-wd" then call expand_pathname_ (get_wdir_ (), dn1, en1, code); else do; BADOPT: call com_err_ (error_table_$badopt, whoami, "^a", arg); return; end; else call expand_pathname_ (arg, dn1, en1, code); if code ^= 0 then do; call com_err_ (code, whoami, "^a", arg); return; end; call check_star_name_$entry (en1, code); if code = 0 then starsw = "0"b; /* No stars */ else if code <= 2 then do; /* Name1 has stars */ if ^areasw then do; areasw = "1"b; areap = get_system_free_area_ (); on condition (cleanup) call cleanup_handler; end; call hcs_$star_ (dn1, en1, 3, areap, ecount, eptr, nptr, code); if code ^= 0 then do; call com_err_ (code, whoami, "Could not star list ^a.", pathname_ (dn1, en1)); return; end; starsw = "1"b; end; else PATHNAME_ERROR: do; call com_err_ (code, whoami, "^a.", pathname_ (dn1, en1)); return; end; if an = arg_count then do; /* last argument missing */ dn2 = get_wdir_ (); en2 = "==="; /* same name in current [wd] */ end; else do; call cu_$arg_ptr (an+1, ap, al, (0)); /* Get Name2 */ if index (arg, "-") = 1 then if arg = "-working_dir" | arg = "-wd" then call expand_pathname_ (get_wdir_ (), dn2, en2, code); else go to BADOPT; else call expand_pathname_ (arg, dn2, en2, code); if code ^= 0 then go to PATHNAME_ERROR; end; if ^starsw then call PERFORM_COPY (en1); else do i = 1 to ecount; call PERFORM_COPY (names (bin (entries (i).nindex, 18))); end; again: if starsw then call cleanup_handler; end; PERFORM_COPY: proc (oldent); dcl oldent char (32); dcl newent char (32); call get_equal_name_ (oldent, en2, newent, code); if code ^= 0 then if code = error_table_$badequal then go to PATHNAME_ERROR; /* skip this pair of arguments */ else do; /* must be longeql */ call com_err_ (code, whoami, arg); /* print arg name in error message */ return; end; if whoami = "copy_acl" then call copy_acl_ (dn1, oldent, dn2, newent, error_sw, code); else if whoami = "copy_iacl_seg" then call copy_iacl_$seg (dn1, oldent, dn2, newent, error_sw, code); else if whoami = "copy_iacl_dir" then call copy_iacl_$dir (dn1, oldent, dn2, newent, error_sw, code); if code ^= 0 then do; if error_sw then call com_err_ (code, whoami, "^a", pathname_ (dn2, newent)); else call com_err_ (code, whoami, "^a", pathname_ (dn1, oldent)); end; end PERFORM_COPY; cleanup_handler: proc; if eptr ^= null then free entries in (system_area); if nptr ^= null then free names in (system_area); end cleanup_handler; end copy_acl;  copy_acl_.pl1 12/07/87 1554.0rew 12/07/87 1343.3 78534 /****^ ************************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * ************************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-08-27,TLNguyen), approve(87-08-27,MCR7755), audit(87-09-08,Lippard), install(87-12-07,MR12.2-1009): Change copy_acl_ to set the error switch just before it calls fs_util_$replace_acl. END HISTORY COMMENTS */ /* format: style2,idind30,indcomtxt */ copy_acl_: proc (Dir_name_1, Entryname_1, Dir_name_2, Entryname_2, Errsw, Code); /* Routine to copy the acl from one file to another. Called by the copy command. Coded by John Strayhorn, 7/1/70 */ /* Modified by M. Weaver 31 December 1970 */ /* Modified 7/1/74 by Steve Herbst to copy MSF acls */ /* Modified 12/19/79 by Gary Dixon to copy seg->MSF acls, or vice versa */ /* Modified 2/20/83 Jay Pattin for object_type_ */ /* Modified 830927 BIM for object_type_ --> fs_util_ */ dcl cleanup condition; dcl (Dir_name_1, Entryname_1, Dir_name_2, Entryname_2) char (*); /* arguments */ dcl Code fixed bin (35); dcl error_table_$not_seg_type fixed bin (35) ext static; dcl error_table_$unsupported_operation fixed bin (35) ext static; dcl Errsw bit (1) aligned; /* indicates which seg error was on */ declare fs_util_$suffix_info entry (character (*), character (*), pointer, fixed binary (35)); declare fs_util_$list_acl entry (character (*), character (*), character (*), pointer, pointer, fixed binary (35)); declare fs_util_$list_extended_acl entry (character (*), character (*), character (*), pointer, pointer, fixed binary (35)); declare fs_util_$replace_acl entry (character (*), character (*), pointer, bit (1), fixed binary (35)); declare fs_util_$replace_extended_acl entry (character (*), character (*), pointer, bit (1), fixed binary (35)); declare fs_util_$get_type entry (character (*), character (*), character (*), fixed binary (35)); declare get_system_free_area_ entry () returns (ptr); declare sub_err_ entry () options (variable); declare fs_util_type_2 char (32) unaligned; declare dir_name (2) char (168) unaligned; declare entryname (2) char (32) unaligned; %page; %include acl_structures; %include suffix_info; %include copy_flags; declare 1 si aligned like suffix_info; %include sub_err_flags; %page; dcl (addr, null) builtin; /* begin coding */ Code = 0; acl_ptr = null (); /* make cleanup handler happy */ /* establish cleanup condition */ on cleanup call clean_up; /* get input parameters */ dir_name (1) = Dir_name_1; dir_name (2) = Dir_name_2; entryname (1) = Entryname_1; entryname (2) = Entryname_2; /* determine the type (extended or standard) of specified source and target entries */ Errsw = "0"b; /* Error apply to source. */ si.version = SUFFIX_INFO_VERSION_1; /* get version name for "si" structure */ call fs_util_$suffix_info (dir_name (1), entryname (1), addr (si), Code); if Code ^= 0 then return; Errsw = "1"b; /* indicates error applied to target */ call fs_util_$get_type (dir_name (2), entryname (2), fs_util_type_2, Code); if Code ^= 0 then return; /**** * Errsw = 1 since mismatch is layed at door of output */ if si.type ^= fs_util_type_2 then do; if si.type = FS_OBJECT_TYPE_SEGMENT | si.type = FS_OBJECT_TYPE_MSF then call SPECIAL_CASE_SEG_MSF; /* perhaps seg -> msf or vica versa */ else Code = error_table_$not_seg_type; /* ycch, used to get dirseg right ... */ return; end; /**** * here is a pair of the same type ! */ Errsw = "0"b; /* indicates error applied to source */ if si.extended_acl then do; call fs_util_$list_extended_acl (dir_name (1), entryname (1), GENERAL_EXTENDED_ACL_VERSION_1, get_system_free_area_ (), acl_ptr, Code); if Code = error_table_$unsupported_operation then call sub_err_ ((0), "Invalid suffix_XXX_", ACTION_CANT_RESTART, null (), (0), "suffix_^a_ claims to support extended acl's, but does not supply a list_extended_acl operation." , fs_util_type_2); else if Code ^= 0 then go to EXIT; Errsw = "1"b; /* indicates error applied to target */ call fs_util_$replace_extended_acl (dir_name (2), entryname (2), acl_ptr, "1"b /* no sysdaemon! */, Code); if Code = error_table_$unsupported_operation then call sub_err_ ((0), "Invalid suffix_XXX_", ACTION_CANT_RESTART, null (), (0), "suffix_^a_ claims to support extended acl's, but does not supply a replace_extended_acl operation." , fs_util_type_2); go to EXIT; /* Leaving code set */ end; /**** * Land here for non-extended acls */ Errsw = "0"b; /* indicates error applied to source */ call fs_util_$list_acl (dir_name (1), entryname (1), GENERAL_ACL_VERSION_1, get_system_free_area_ (), acl_ptr, Code); if Code ^= 0 then go to EXIT; Errsw = "1"b; /* indicates error applied to target */ call fs_util_$replace_acl (dir_name (2), entryname (2), acl_ptr, "1"b /* no sysdaemon! */, Code); go to EXIT; /**** * This procedure handles the special case of copying acls back and forth between segments and msf's. Someday, we may permit this for dm files as well. */ SPECIAL_CASE_SEG_MSF: procedure; /**** * To get into this procedure, the input object had to be a seg or msf. now examine the output object to see if the types are compatable. */ if fs_util_type_2 ^= FS_OBJECT_TYPE_SEGMENT & fs_util_type_2 ^= FS_OBJECT_TYPE_MSF then do; Code = error_table_$not_seg_type; return; end; Errsw = "0"b; /* indicates error applied to source */ call fs_util_$list_extended_acl (dir_name (1), entryname (1), GENERAL_EXTENDED_ACL_VERSION_1, get_system_free_area_ (), acl_ptr, Code); if Code ^= 0 then return; Errsw = "1"b; /* indicates error applied to target */ call fs_util_$replace_extended_acl (dir_name (2), entryname (2), acl_ptr, "1"b /* no sysdaemon! */, Code); return; end SPECIAL_CASE_SEG_MSF; EXIT: call clean_up (); if Code = 0 then Errsw = "0"b; return; clean_up: proc; if acl_ptr ^= null () then do; free general_acl; /* or general_extended_acl, illegal but effective */ return; end; end clean_up; end copy_acl_;  copy_dir.pl1 03/10/85 1722.5r w 03/08/85 1003.3 137340 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * ************************************************************** */ /* format: style2,idind30,indcomtxt */ copy_dir: cpd: procedure options (variable); /* Move or copy a directory and its subtree. Last modified: 06/02/78 by LLS for initial implementation 07/06/78 by LLS to add -update, the entry_type_keys, and fix containment and argument consistency checking. 11/14/80 by GAT to use copy_dir_. 09/22/81 by Lindsey Spratt: removed call to status to validate pathnames. copy_dir_ does this validation and it need not be duplicated here. 6/29/83 by Jay Pattin to add -fcnt 831002 by BIM to cleanup a bit, audit above, etc. 25/09/84 by B. Braun to initialize copy_dir_options.parent_ac_sw to "0"b; 12/27/84 by Keith Loepere to remove create_branch_info. 830206 by MSharpe to replace -fcnt with -inase/inaee; to accept -fc as synonym for -force; to initialize cdo.primary to ""b. */ /* Entries */ dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl com_err_$suppress_name entry options (variable); dcl copy_dir_ entry (char (*), char (*), char (*), char (*), char (*), ptr, fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl get_wdir_ entry returns (char (168)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); /**** * Conditions */ dcl cleanup condition; /**** * Based */ dcl arg char (arg_len) based (arg_ptr); dcl area area based (area_ptr); /**** * Automatic */ dcl whoami char (8); /* name of entry into code ("copy_dir" or "move_dir"). */ dcl code fixed bin (35); /* the returned error code from a system call. */ dcl ( all_entries, /* all entries are copied */ all_names, /* all names on an entry are copied */ errors, have_source, /* pathname of source is known. */ have_target, /* pathname of target is known */ same_dir, /* se_name and te_name are in the same directory. */ multiple_sources, /* star name input */ move ) bit (1); /* delete source_dir after copying */ dcl ( argno, /* index to count through the argument list. */ entry_count, /* number star matches */ entry_index, nargs ) fixed bin; dcl arg_len fixed bin (21); /* length of argument pointed to by arg_ptr. */ dcl (sd_name, td_name, wd) char (168); dcl (entry_temp, se_name, te_name) char (32); dcl (arg1, arg2) char (32) varying; dcl ( area_ptr, /* ptr on which area is based. */ arg_ptr /* Ptr to arg, set by call to cu_$arg_ptr. */ ) ptr; /* External */ dcl ( error_table_$badopt, error_table_$inconsistent, error_table_$notadir, error_table_$no_s_permission ) fixed bin (35) external; /**** * Builtins */ dcl (addr, binary, null, substr, sum) builtin; whoami = "copy_dir"; move = "0"b; go to START; move_dir: mvd: entry options (variable); whoami = "move_dir"; move = "1"b; /* true beginning of program */ START: star_branch_count, star_link_count = 0; star_select_sw = star_BRANCHES_ONLY; area_ptr = get_system_free_area_ (); star_entry_ptr, star_names_ptr = null (); on condition (cleanup) begin; if star_names_ptr ^= null () then free star_names in (area); if star_entry_ptr ^= null () then free star_entries in (area); end; wd = get_wdir_ (); have_source = "0"b; have_target = "0"b; all_names = "1"b; all_entries = "1"b; errors = "0"b; same_dir = "0"b; cdo.version = copy_dir_options_version_0; cdo.replace = "0"b; cdo.link_translation = "1"b; cdo.primary = "0"b; cdo.acl = "0"b; cdo.force = "0"b; cdo.brief = "0"b; cdo.chase = "0"b; cdo.parent_ac_sw = "0"b; cdo.link = "0"b; cdo.seg = "0"b; cdo.msf = "0"b; cdo.nnlk = "0"b; cdo.update = "0"b; cdo.dir = "0"b; cdo.raw = "0"b; cdo.pad1, cdo.pad2 = "0"b; if move then cdo.delete = "1"b; else cdo.delete = "0"b; /* process arguments */ call cu_$arg_count (nargs, code); if code ^= 0 then do; call com_err_ (code, whoami); return; end; if nargs = 0 then do; usage: call com_err_$suppress_name (0, whoami, "Usage: ^a source_dir {target_dir} {-entry_type_keys} {-control_args} ", whoami); goto finish; end; /* get source_dir (sd_name and se_name). */ do argno = 1 to nargs; call cu_$arg_ptr (argno, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, whoami, "On argument number ^d", argno); goto finish; end; if substr (arg, 1, 1) ^= "-" then if ^have_source then do; call expand_pathname_ (arg, sd_name, se_name, code); if code ^= 0 then do; err: call com_err_ (code, whoami, "^a", arg); goto finish; end; call check_star_name_$entry (se_name, code); if code = 0 then do; entry_count = 1; multiple_sources = "0"b; end; else if (code = 1 | code = 2) then multiple_sources = "1"b; else do; call com_err_ (code, whoami, "Star name check failed on ^a.", se_name); goto finish; end; have_source = "1"b; end; /* process the rest of the arguments. */ else if ^have_target then do; call expand_pathname_ (arg, td_name, entry_temp, code); if code ^= 0 then do; call com_err_ (code, whoami, "^a", arg); goto finish; end; have_target = "1"b; end; else do; call com_err_ (error_table_$badopt, whoami, "Too many pathnames, a maximum of two is allowed."); goto finish; end; /* check for the control arguments */ else if arg = "-replace" | arg = "-rp" then cdo.replace = "1"b; else if arg = "-update" | arg = "-ud" then cdo.update = "1"b; else if (arg = "-no_link_translation" | arg = "-nlt") & ^move then cdo.link_translation = "0"b; else if arg = "-acl" then cdo.acl = "1"b; else if arg = "-force" | arg = "-fc" then cdo.force = "1"b; else if arg = "-brief" | arg = "-bf" then cdo.brief = "1"b; else if arg = "-chase" then cdo.chase = "1"b; else if arg = "-primary" | arg = "-pri" then cdo.primary = "1"b; else if arg = "-interpret_as_standard_entry" | arg = "-inase" then cdo.raw = "1"b; else if arg = "-interpret_as_extended_entry" | arg = "-inaee" then cdo.raw = "0"b; /* check for entry type keys. */ else if arg = "-link" | arg = "-lk" then do; all_entries = "0"b; cdo.link = "1"b; end; else if arg = "-sm" | arg = "-segment" then do; all_entries = "0"b; cdo.seg = "1"b; end; else if arg = "-dr" | arg = "-directory" then do; all_entries = "0"b; cdo.dir = "1"b; end; else if arg = "-branch" | arg = "-br" then do; all_entries = "0"b; cdo.seg = "1"b; cdo.msf = "1"b; cdo.dir = "1"b; end; else if arg = "-file" | arg = "-f" then do; all_entries = "0"b; cdo.seg = "1"b; cdo.msf = "1"b; end; else if arg = "-msf" | arg = "-multisegment_file" then do; all_entries = "0"b; cdo.msf = "1"b; end; else if arg = "-non_null_link" | arg = "-nnlk" then do; all_entries = "0"b; cdo.nnlk = "1"b; end; else do; call com_err_ (error_table_$badopt, whoami, "^a", arg); goto finish; end; end; /* check argument compatibility. */ if (cdo.nnlk & cdo.link) then do; arg1 = "-non_null_link"; arg2 = "-link"; incompatarg: call com_err_ (error_table_$inconsistent, whoami, "Incompatible arguments ^a and ^a", arg1, arg2); goto finish; end; if (cdo.replace & cdo.update) then do; arg1 = "-replace"; arg2 = "-update"; goto incompatarg; end; if (cdo.chase & ^(cdo.link | all_entries)) then do; arg1 = "-chase"; arg2 = "not -link"; goto incompatarg; end; if ^have_target then do; td_name = wd; entry_temp = "=="; end; if all_entries then cdo.link, cdo.seg, cdo.dir, cdo.msf = "1"b; /* if source_dir is a star name, decode it and set up for using multiple source entries. Otherwise, set up for using a single source entry. */ if multiple_sources then do; call hcs_$star_ (sd_name, se_name, star_BRANCHES_ONLY, area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then do; call com_err_ (code, whoami, "Could not get matching names for ^a^[>^]^a.", sd_name, sd_name ^= ">", se_name); goto finish; end; entry_count = star_entry_count; end; /* begin the loop through all of the source entries. */ do entry_index = 1 to entry_count; if multiple_sources then if star_entries (entry_index).type = star_DIRECTORY /* check that arg 1 is a directory. */ then se_name = star_names (star_entries (entry_index).nindex); else goto NEXT_ENTRY; call get_equal_name_ (se_name, entry_temp, te_name, code); call copy_dir_ (whoami, sd_name, se_name, td_name, te_name, addr (cdo), code); /* errors messages are taken care of by copy_dir_, if -brief was used, the "trivial" errors aren't reported anywhere. */ NEXT_ENTRY: end; finish: if star_names_ptr ^= null () then free star_names in (area); if star_entry_ptr ^= null () then free star_entries in (area); return; %page; /* Include */ %include star_structures; %page; %include query_info_; %page; %include copy_dir_options; declare 1 cdo aligned like copy_dir_options; end copy_dir;  copy_dir_.pl1 03/15/89 0848.2r w 03/15/89 0800.0 401661 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-02-17,TLNguyen), approve(87-02-17,MCR7624), audit(87-02-27,Lippard), install(87-03-20,MR12.1-1006): - Change "copy_dir_" to always set its returned code parameter before returning. - Change "copy_dir_" to properly delete the target dir when "-replace" is given. It currently calls "hcs_$del_dir_tree" rather than calling "delete_$path". Therefore it fails to delete Data Managment files. - Change "copy_dir_" to properly copy ACLs when -acl is specified. It currently copies only ACLs on 2nd-Nth segments of a directory. 2) change(88-08-30,TLNguyen), approve(88-08-30,MCR7949), audit(88-09-09,Parisek), install(88-11-1,MR12.2-1202): - Change the copy_dir_ to do the containment check before deleting the contents of the target which indicated by the replace flag. - Change copy_dir_ so that -replace will work as documented for the copy_dir command. END HISTORY COMMENTS */ /* format: style2,idind30,indcomtxt */ copy_dir_: procedure (whoami, source_dir, source_ename, target_dir, target_ename, pcopy_dir_options, acode); /**** * Most of this code is from the original copy_dir command. * Status: 0) Original by LLS in 1978 1) Modified: 11/80 by GAT to make the subroutines 2) Gutted: 6/30/83 by Jay Pattin for extended objects 3) 831002 BIM for extended object cleanup 4) Modified: 12/84 by Keith Loepere to set dir_quota at append. 5) Modified: 2/15/85 M. Sharpe to give up if can't create target */ /**** * Entries */ dcl command_query_ entry options (variable); dcl copy_ entry (ptr); dcl com_err_ entry options (variable); dcl copy_acl_ entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35)); dcl copy_iacl_ entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35)); dcl move_names_ entry (char (*), char (*), char (*), char (*), char (*), bit (1), fixed bin (35)); dcl copy_names_ entry (char (*), char (*), char (*), char (*), char (*), bit (1), fixed bin (35)); dcl continue_to_signal_ entry (fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl get_group_id_$tag_star entry returns (char (32)); dcl get_max_authorization_ entry () returns (bit (72) aligned); dcl get_ring_ entry () returns (fixed bin (3)); dcl get_system_free_area_ entry returns (ptr); dcl hcs_$get_dir_ring_brackets entry (char (*), char (*), (2) fixed bin (3), fixed bin (35)); dcl hcs_$get_access_class entry (char (*), char (*), bit (72) aligned, fixed bin (35)); dcl hcs_$append_link entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$create_branch_ entry (char (*), char (*), ptr, fixed bin (35)); dcl hcs_$get_safety_sw entry (char (*), char (*), bit (1), fixed bin (35)); dcl hcs_$get_uid_file entry (char (*), char (*), bit (36) aligned, fixed bin (35)); dcl hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$set_safety_sw entry (char (*), char (*), bit (1), fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl nd_handler_ entry (char (*), char (*), char (*), fixed bin (35)); dcl nd_handler_$switches entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35)); dcl delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35)); dcl fs_util_$get_type entry (character (*), character (*), character (*), fixed binary (35)); dcl fs_util_$suffix_info entry (char (*), char (*), ptr, fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl sub_err_ entry () options (variable); /* Constants */ dcl no_translation fixed bin (35) internal static options (constant) init (1); /* Conditions */ dcl (cleanup, sub_error_) condition; /* Based */ dcl 1 comp based (cptr), 2 name char (32) varying, 2 next ptr; dcl area area based (area_ptr); /* Automatic */ dcl acode fixed bin (35); dcl parent_access bit (1); dcl (source_dir, source_ename, target_dir, target_ename) char (*); /* from where to where */ dcl whoami char (*); /* name of entry into code ("copy_dir" or "move_dir"). */ dcl (tt, type) fixed bin (2); /* type of entry returned by hcs_$status_minf, 0 = link, 1 = seg, 2 = dir. */ dcl ln fixed bin (21); /* length of a char string returned by ioa_$rsnnl. */ dcl (code, code1) fixed bin (35); /* the returned error code from a system call. */ dcl bc fixed bin (24); /* bit count returned by hcs_$status_minf. */ dcl answer char (3) varying; /* answer from user via command_query_ */ dcl dir_rings (2) fixed bin (3); /* ring validation for a directory. */ dcl ( acl, /* acl on copy is same as original */ all_entries, /* all entries are copied */ all_names, /* all names on an entry are copied */ brief, /* comments are suppressed */ chase, /* copy targets of links */ force, /* user is not queried about existing target */ raw, /* don't use object_type_ */ replace, /* truncate target_dir before copying */ translate_links, /* translate links */ update, /* name duplications are deleted or unlinked without asking the user */ clink, /* copy links. */ cseg, /* copy segments. */ cmsf, /* copy multisegment files. */ cnnl, /* copy non-null links. */ cdir, /* copy directories. */ errors, /* one or more errors occurred while processing */ ersw, /* used in calls to copy_ utilities to indicate which entry an error occurred on. */ source_contains_target, /* if "1"b, the source directory contains the target directory. */ target_contains_source, /* If "1"b, the target_directory contains the source directory. */ safety_sw, /* used in setting the safety_switch of a branch. */ same_dir, /* se_name and te_name are in the same directory. */ move ) bit (1); /* delete source_dir after copying */ dcl fs_util_type char (32); dcl (entry_index, lcomp_count, scomp_count, tcomp_count, ii) fixed bin; dcl (dir1_uid, dir2_uid, uid) bit (36) aligned; dcl (sd_name, td_name, temp_target_dir) char (168); dcl (se_name, le, userid, te_name) char (32); dcl ( area_ptr, /* ptr on which area is based. */ cb_ptr, /* ptr on which create_branch_info is based. */ lcomp_root, /* Path info for link_target(lcomp). */ scomp_root, /* Path info for source_dir. */ tcomp_root, /* Path info for target_dir. */ cptr /* Ptr on which comp is based. */ ) ptr; /* External */ dcl ( error_table_$action_not_performed, error_table_$inconsistent, error_table_$bad_ring_brackets, error_table_$incorrect_access, error_table_$no_dir, error_table_$no_s_permission, error_table_$not_seg_type, error_table_$segnamedup, error_table_$namedup, error_table_$noentry, error_table_$nomatch, error_table_$notadir, error_table_$sameseg, error_table_$unimplemented_version ) fixed bin (35) external; /* Builtins */ dcl (addr, index, null, reverse, rtrim, ptr, string, substr, sum) builtin; /**** ** Copy all the parameters into local variables. In the case of * the structure, this is unneccessary, but is convienient since this * did not used to be a seperate routine from the command. */ cb_ptr = null (); acode = 0; /* must be initialized */ on condition (cleanup) begin; if cb_ptr ^= null () then free cb_ptr -> create_branch_info in (area); end; if copy_dir_options.version ^= copy_dir_options_version_0 then do; call sub_err_ (error_table_$unimplemented_version, ACTION_CANT_RESTART, null (), (0), "copy_dir_ has been invoked with the wrong version of the copy_dir_options structure. The version provided was ^d, the expected version is ^d.", copy_dir_options.version, copy_dir_options_version_0); return; end; userid = get_group_id_$tag_star (); area_ptr = get_system_free_area_ (); move = copy_dir_options.delete; if ^(copy_dir_options.link | copy_dir_options.dir | copy_dir_options.seg | copy_dir_options.msf | copy_dir_options.nnlk) then do; call complain (error_table_$action_not_performed, "^/No entries specified to be ^[copied^;moved^].", (^copy_dir_options.delete)); return; end; if (copy_dir_options.link & copy_dir_options.dir & copy_dir_options.seg & copy_dir_options.msf) then do; all_entries = "1"b; clink, cseg, cdir, cmsf, cnnl = "0"b; end; else do; all_entries = "0"b; clink = copy_dir_options.link; cseg = copy_dir_options.seg; cdir = copy_dir_options.dir; cmsf = copy_dir_options.msf; cnnl = copy_dir_options.nnlk; end; parent_access = copy_dir_options.parent_ac_sw; brief = copy_dir_options.brief; force = copy_dir_options.force; replace = copy_dir_options.replace; update = copy_dir_options.update; acl = copy_dir_options.acl; primary = copy_dir_options.primary; translate_links = copy_dir_options.link_translation; chase = copy_dir_options.chase; raw = copy_dir_options.raw; if (replace & update) then do; call complain (error_table_$inconsistent, "^/Options replace and update specified."); return; end; if primary then all_names = "0"b; else all_names = "1"b; allocate create_branch_info in (area) set (cb_ptr); cb_ptr -> create_branch_info.version = create_branch_version_2; cb_ptr -> create_branch_info.quota = 0; cb_ptr -> create_branch_info.dir_quota = 0; cb_ptr -> create_branch_info.mode = "111"b; cb_ptr -> create_branch_info.switches.dir_sw = "1"b; cb_ptr -> create_branch_info.switches.copy_sw = "0"b; cb_ptr -> create_branch_info.switches.chase_sw = "1"b; cb_ptr -> create_branch_info.switches.parent_ac_sw = parent_access; cb_ptr -> create_branch_info.priv_upgrade_sw = "0"b; cb_ptr -> create_branch_info.userid = userid; cb_ptr -> create_branch_info.bitcnt = 0; sd_name = source_dir; /* copy the name args to the "old" variables */ se_name = source_ename; /* and proceed with existing code */ td_name = target_dir; te_name = target_ename; if sd_name = td_name then same_dir = "1"b; else same_dir = (get_uid (sd_name) = get_uid (td_name)); /* check that arg 1 is a directory. */ call hcs_$status_minf (sd_name, se_name, 0, type, bc, code); if code ^= 0 & code ^= error_table_$no_s_permission then do; BAD_STAT: call complain (code, "^/Unable to get the status of ^a^[>^]^a.", sd_name, sd_name ^= ">", se_name); return; end; if type ^= Directory | bc ^= 0 then do; NOT_A_DIR: call complain (error_table_$notadir, "^/The source pathname must be a directory. ^a^[>^]^a is not a directory", sd_name, sd_name ^= ">", se_name); return; end; if ^raw then do; /* check if it is an extended object */ call fs_util_$get_type (sd_name, se_name, fs_util_type, code); if fs_util_type ^= FS_OBJECT_TYPE_DIRECTORY then goto NOT_A_DIR; end; call hcs_$get_uid_file (sd_name, se_name, uid, code); if code ^= 0 then goto BAD_STAT; dir1_uid = uid; /* if the target doesn't exist, create it. If it does exist, but is not a directory, complain and get next entry. */ call hcs_$status_minf (td_name, te_name, 0, type, bc, code); if code ^= 0 then if code = error_table_$noentry then do; if ^brief then call ioa_ ("^a: Creating target directory ^a.", whoami, pathname_ (td_name, te_name)); call create_directory; if code ^= 0 then goto finish; end; else do; BAD_TSTAT: call complain (code, "^/Unable to get the status of the target directory ^a^[>^]^a.", td_name, td_name ^= ">", te_name); return; end; else if type ^= Directory | bc ^= 0 then do; T_NOT_DIR: call nd_handler_ (whoami, td_name, te_name, code); if code ^= 0 then do; acode = code; return; end; call create_directory; if code ^= 0 then goto finish; end; else do; /* target_dir exists */ if ^raw then do; call fs_util_$get_type (td_name, te_name, fs_util_type, code); if fs_util_type ^= FS_OBJECT_TYPE_DIRECTORY then goto T_NOT_DIR; end; call hcs_$get_uid_file (td_name, te_name, dir2_uid, code); if code ^= 0 then go to BAD_TSTAT; if dir1_uid = dir2_uid then do; call complain (error_table_$action_not_performed, "Attempt to specify the same directory as both old and new"); return; end; if ^(force | replace) then do; query_info.version = 1; query_info.yes_or_no_sw = "1"b; query_info.suppress_name_sw = "0"b; query_info.status_code = 0; query_info.query_code = 0; call command_query_ (addr (query_info), answer, whoami, "^a^[>^]^a already exists. Do you wish to continue?", td_name, td_name ^= ">", te_name); if query_info.status_code ^= 0 then do; call complain (query_info.status_code, "^/Unable to use answer from query."); return; end; if answer = "no" then goto finish; end; /* perform the containment check */ call contains (source_contains_target, target_contains_source, code); if code ^= 0 then do; call complain (code, "^/Unable to check containment of source and target directories, ^a^[>^]^a and ^a^[>^]^a respectively.", sd_name, sd_name ^= ">", se_name, td_name, td_name ^= ">", te_name); return; end; if source_contains_target /* the source directory contains the target directory */ then do; call complain (error_table_$action_not_performed, "^/The source directory cannot contain the target directory;^/^a contains ^a.", pathname_ (sd_name, se_name), pathname_ (td_name, te_name)); return; end; if target_contains_source /* the target directory contains the source directory */ then do; call complain (error_table_$action_not_performed, "^/The target directory cannot contain the source directory;^/^a contains ^a.", pathname_ (td_name, te_name), pathname_ (sd_name, se_name)); return; end; if replace /* want to delete the contents of the specified existent target */ then do; string (delete_options) = ""b; delete_options.force = force; delete_options.question, delete_options.directory, delete_options.segment, delete_options.link = "1"b; delete_options.chase = chase; delete_options.library = "0"b; delete_options.raw = raw; temp_target_dir = pathname_ (td_name, te_name); star_entry_count = 0; /* initialize variable declared in star_structures.incl.pl1 */ star_entry_ptr = null; /* initialize variable declared in star_structures.incl.pl1 */ star_names_ptr = null; /* initialize variabel declared in start_structures.incl.pl1 */ /* get information on all entries in the specified existent target */ call hcs_$star_ (temp_target_dir, "**", star_ALL_ENTRIES, area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then do; /* if the existent target is empty (star_entry_count = 0), then keep going */ if code ^= error_table_$nomatch then do; call complain (code, "Unable to return information on all entries in target directory ^a.", temp_target_dir); return; end; end; /* delete all entries in the specified existent target */ do entry_index = 1 to star_entry_count; call delete_$path (temp_target_dir, star_names (entry_index), string (delete_options), whoami, code); if code ^= 0 & code ^= error_table_$bad_ring_brackets then do; call complain (code, "^/Unable to delete the entryname ^a in the directory ^a.", rtrim (star_names (entry_index)), rtrim (temp_target_dir)); return; end; end; /* make the specified existent target directory become empty */ end; /* want to delete the contents of a specified existent directory */ end; /* case the specified target directory exists */ errors = "0"b; /* start fresh */ call hcs_$get_safety_sw (sd_name, se_name, safety_sw, code); if code ^= 0 then call complain (code, "^/Unable to get the safety switch for the source directory ^a^[>^]^a.", sd_name, sd_name ^= ">", se_name); else do; call hcs_$set_safety_sw (td_name, te_name, safety_sw, code); if code ^= 0 then call complain (code, "^/Unable to set the safety switch on the target directory ^a^[>^]^a.", td_name, td_name ^= ">", te_name); end; call copy_iacl_ (sd_name, se_name, td_name, te_name, ersw, code); if code ^= 0 then call complain (code, "^/Unable to copy the initial ACL from the source directory ^a^[>^]^a to the target directory ^a^[>^]^a. Error occurred on the ^[source^;target^] directory.", sd_name, sd_name ^= ">", se_name, td_name, td_name ^= ">", te_name, ^ersw); cpo.version = COPY_OPTIONS_VERSION_1; cpo.caller_name = "copy_dir_"; /* Now call the recursive procedure which does the actual copying */ call work (sd_name, se_name, td_name, te_name, acl, move); if acl | move then do; call copy_acl_ (sd_name, se_name, td_name, te_name, ersw, code); if code ^= 0 then call complain (code, "^/Unable to copy the ACL from ^a^[>^]^a to ^a^[>^]^a. Error occurred on the ^[source^;target^].", sd_name, sd_name ^= ">", se_name, td_name, td_name ^= ">", te_name, ^ersw); end; if all_names then do; if same_dir then call move_names_ (sd_name, se_name, td_name, te_name, whoami, ersw, code); else call copy_names_ (sd_name, se_name, td_name, te_name, whoami, ersw, code); if code ^= 0 then if code ^= error_table_$segnamedup then if code ^= error_table_$namedup then call complain (code, "^/Unable to ^[move^;copy^] names of ^a^[>^]^a to ^a^[>^]^a. Error occurred on the ^[source^;target^].", same_dir, sd_name, (sd_name ^= ">"), se_name, td_name, td_name ^= ">", te_name, ^ersw); end; if move then if errors then do; if ^brief then call com_err_ (error_table_$action_not_performed, whoami, "Source directory not deleted due to error in copying."); if acode = 0 then acode = error_table_$action_not_performed; /* tell caller something! */ end; else do; string (delete_options) = ""b; delete_options.question, delete_options.directory = "1"b; delete_options.raw = raw; call delete_$path (sd_name, se_name, string (delete_options), whoami, code); if code ^= 0 then call complain (code, "^/Unable to delete ^a^[>^]^a.", sd_name, (sd_name ^= ">"), se_name); end; finish: if cb_ptr ^= null () then free cb_ptr -> create_branch_info in (area); return; %page; /* The directory tree is recursively followed, copying the links, files, and directories along the way. If a copy fails for any reason on a particular entry,processing continues with the next one and nothing is done with the failed entry. */ work: proc (d1, e1, d2, e2, acl, move) recursive; dcl i fixed bin; dcl (from_dir, to_dir) char (168); dcl name char (32); dcl names (500) char (32) aligned based (nptr); /* info from hcs_$star_ */ dcl nptr ptr; dcl 1 branches (entry_count) aligned based (sptr), /* info from hcs_$star_ */ ( 2 type bit (2), 2 nnames fixed bin (15), 2 nindex fixed bin (17) ) unaligned; dcl (d1, d2, e1, e2) char (*); dcl (acl, move) bit (1); /* save these flags for later reference in the "file" procedure. */ dcl sptr ptr; dcl entry_count fixed bin; /* construct directory pathnames */ call ioa_$rsnnl ("^a^[>^]^a", from_dir, ln, d1, (d1 ^= ">"), e1); call ioa_$rsnnl ("^a^[>^]^a", to_dir, ln, d2, (d2 ^= ">"), e2); /* set up cleanup handler */ on condition (cleanup) begin; if sptr ^= null then free branches in (area); if nptr ^= null then free nptr -> names in (area); end; /* get all of the entries in from_dir */ call hcs_$star_ (from_dir, "**", 3, area_ptr, entry_count, sptr, nptr, code); if code ^= 0 then if code = error_table_$nomatch then goto finish_work; else do; call complain (code, "^/Unable to get the entries in the directory ^a.", from_dir); return; end; /* call appropriate entry copier */ do i = 1 to entry_count; name = names (branches (i).nindex); if branches (i).type = "00"b then do; if (all_entries | clink | cnnl) then call link; end; else if branches (i).type = "01"b then do; FILE: if (all_entries | cseg) then call file (from_dir, name, to_dir, name, acl, move); end; else if branches (i).type = "10"b then do; if ^raw then do; call fs_util_$get_type (from_dir, name, fs_util_type, code); if code ^= error_table_$not_seg_type & substr (fs_util_type, 1, 1) ^= "-" then goto FILE; end; call hcs_$status_minf (from_dir, name, 1, tt, bc, code); if code ^= 0 then do; call complain (code, "^/Unable to get status on the file ^a^[>^]^a.", from_dir, from_dir ^= ">", name); return; end; if bc ^= 0 then do; if (all_entries | cmsf) then call file (from_dir, name, to_dir, name, acl, move); end; else do; if (all_entries | cdir) then call directory; end; end; else do; call complain (0, "Illegal branch type ""11""b ^a^[>^]^a", from_dir, from_dir ^= ">", name); return; /* tell caller something */ end; end; finish_work: if sptr ^= null then free sptr -> branches in (area); if nptr ^= null then free nptr -> names in (area); return; /* Effective end of work. */ link: proc; dcl pptr ptr; dcl 1 links aligned like status_link; dcl pathname char (links.pathname_length) aligned based (pptr); dcl (link_target, new_target, ld) char (168); call hcs_$status_ (from_dir, name, 0, addr (links), area_ptr, code); if code ^= 0 then do; call complain (code, "^/Unable to get detailed status on the link ^a^[>^]^a.", from_dir, from_dir ^= ">", name); return; end; pptr = ptr (area_ptr, links.names_relp); free pptr -> names in (area); pptr = ptr (area_ptr, links.pathname_relp); link_target = pathname; call expand_pathname_ (link_target, ld, le, code); if code ^= 0 then do; call complain (code, "^/Unable to expand the target pathname ^a for the link ^a^[>^]^a.", link_target, from_dir, from_dir ^= ">", name); return; end; if translate_links then do; call contains_target (ld, le, new_target, code); if code = 0 then link_target = new_target; else if code = no_translation then code = 0; else do; call complain (code, "^/Unable to analyze ^a^[>^]^a for containment in the target directory.", ld, ld ^= ">", le); return; end; end; free pptr -> pathname in (area); if chase then do; call hcs_$get_link_target (ld, le, ld, le, code); if code ^= 0 then if code = error_table_$noentry | code = error_table_$no_dir then do; if clink then goto append_link; return; end; else do; call complain (code, "^/Unable to get the link target of ^a^[>^]^a, with target pathname of ^a^[>^]^a.", from_dir, (from_dir ^= ">"), name, ld, ld ^= ">", le); return; end; call hcs_$status_minf (ld, le, 0, tt, bc, code); if code ^= 0 then if code = error_table_$noentry | code = error_table_$no_dir then do; if clink then goto append_link; return; end; else do; call complain (code, "^/Unable to get status on ^a^[>^]^a, the link target of ^a^[>^]^a.", ld, ld ^= ">", le, from_dir, from_dir ^= ">", name); return; end; if ^raw then do; call fs_util_$get_type (ld, le, fs_util_type, code); if code ^= error_table_$not_seg_type & substr (fs_util_type, 1, 1) ^= "-" /* if it is an extended object, or if it dont exist */ then tt = 1; end; if (tt = 1 & (cseg | all_entries)) | (tt = 2 & bc ^= 0 & (cmsf | all_entries)) then call file (ld, le, to_dir, name, acl, move); else if (tt = 2 & bc = 0 & (cdir | all_entries)) then goto append_link; else return; end; else do; if cnnl then do; call hcs_$status_minf (ld, le, 1, tt, bc, code); if code ^= 0 then if code = error_table_$noentry | code = error_table_$no_dir then return; else do; call complain (code, "^/Unable to get status on ^a^[>^]^a, the link target of ^a^[>^]^a.", ld, ld ^= ">", le, from_dir, from_dir ^= ">", name); return; end; end; append_link: call hcs_$append_link (to_dir, name, link_target, code); if code ^= 0 then if code = error_table_$namedup then do; string (nd_handler_options) = ""b; nd_handler_options.raw = raw; nd_handler_options.delete_force = update; call nd_handler_$switches (whoami, to_dir, name, string (nd_handler_options), code1); if code1 = 0 then goto append_link; else if code1 = error_table_$action_not_performed then return; else do; acode = code1; errors = "1"b; return; end; end; else do; call complain (code, "^/Unable to copy from ^a^[>^]^a to ^a^[>^]^a. Error occurred on the ^[source^;target^].", from_dir, (from_dir ^= ">"), name, to_dir, (to_dir ^= ">"), name, ^ersw); return; end; call copy_names_ (from_dir, name, to_dir, name, whoami, ersw, code); if code ^= 0 & code ^= error_table_$segnamedup & code ^= error_table_$namedup then do; call complain (code, "^/Unable to copy the names from ^a^[>^]^a to ^a^[>^]^a. Error occurred on the ^[source^;target^] entry.", from_dir, from_dir ^= ">", name, to_dir, to_dir ^= ">", name, ^ersw); return; end; end; end link; %page; file: proc (from_dir, from_en, to_dir, to_en, acl, move); dcl (from_dir, from_en, to_dir, to_en) char (*); dcl (acl, move) bit (1); /* They are originally received from the "copy_dir_" procedure. */ dcl 1 local_suffix_info aligned like suffix_info; cpo.source_dir = from_dir; cpo.source_name = from_en; cpo.target_dir = to_dir; cpo.target_name = to_en; string (cpo.flags) = ""b; cpo.raw = raw; cpo.no_name_dup = update; string (cpo.copy_items) = ""b; cpo.names = all_names; cpo.acl = acl | move; local_suffix_info.version = SUFFIX_INFO_VERSION_1; call fs_util_$suffix_info (from_dir, from_en, addr (local_suffix_info), code); if code ^= 0 then do; call complain (code, "^/Unable to get the suffix_info for ^a.", pathname_ (from_dir, from_en)); return; end; if tt = 1 then do; cpo.max_length = local_suffix_info.copy_flags.max_length; cpo.dumper_switches = local_suffix_info.copy_flags.dumper_switches; end; cpo.safety_switch = local_suffix_info.copy_flags.safety_switch; on sub_error_ call sub_err_handler (); call copy_ (addr (cpo)); PUNT_FILE: return; %page; sub_err_handler: proc (); ci.version = condition_info_version_1; call find_condition_info_ (null (), addr (ci), (0)); sub_error_info_ptr = ci.info_ptr; if sub_error_info.name ^= "copy_" | copy_error_info.copy_options_ptr ^= addr (cpo) then do; call continue_to_signal_ ((0)); return; end; code = sub_error_info.status_code; call complain (code, "^[^a^/^-^;^s^]^[Copying^;Unable to copy^] from ^a to ^a. Error occurred on the ^[target^;source^].", sub_error_info.info_string ^= "", sub_error_info.info_string, sub_error_info.default_restart, pathname_ (from_dir, from_en), pathname_ (to_dir, to_en), copy_error_info.target_err_switch); if sub_error_info.cant_restart then goto PUNT_FILE; return; end sub_err_handler; end file; %page; directory: proc; call hcs_$status_minf (to_dir, name, 1, tt, bc, code); if code ^= 0 then do; tt = 0; call hcs_$get_dir_ring_brackets (from_dir, name, dir_rings, code); if code ^= 0 then do; call complain (code, "^/Unable to get the directory ring brackets of ^a^[>^]^a.", from_dir, (from_dir ^= ">"), name); return; end; end; else if tt ^= 2 then do; call nd_handler_ (whoami, to_dir, name, code); if code ^= 0 then if code = error_table_$action_not_performed then return; else do; errors = "1"b; acode = code; return; end; call hcs_$get_dir_ring_brackets (from_dir, name, dir_rings, code); if code ^= 0 then do; call complain (code, "^/Unable to get the directory ring brackets of ^a^[>^]^a.", from_dir, (from_dir ^= ">"), name); return; end; end; if tt ^= 2 then do; cb_ptr -> create_branch_info.rings (1) = dir_rings (1); cb_ptr -> create_branch_info.rings (2) = dir_rings (2); cb_ptr -> create_branch_info.rings (3) = 7; call hcs_$get_access_class (from_dir, name, cb_ptr -> create_branch_info.access_class, code); if code ^= 0 then do; call complain (code, "^/Unable to get the access class of ^a^[>^]^a.", from_dir, (from_dir ^= ">"), name); return; end; cb_ptr -> create_branch_info.switches.dir_sw = "1"b; cb_ptr -> create_branch_info.switches.copy_sw = "0"b; cb_ptr -> create_branch_info.switches.chase_sw = "1"b; cb_ptr -> create_branch_info.mode = "111"b; call hcs_$create_branch_ (to_dir, name, cb_ptr, code); if code ^= 0 then do; call complain (code, "^/Unable to create the directory branch ^a^[>^]^a.", to_dir, (to_dir ^= ">"), name); return; end; end; if all_names then do; call copy_names_ (from_dir, name, to_dir, name, whoami, ersw, code); if code ^= 0 & code ^= error_table_$segnamedup & code ^= error_table_$namedup then call complain (code, "^/Unable to copy the names from ^a^[>^]^a to ^a^[>^]^a. Error occurred on the ^[source^;target^].", from_dir, (from_dir ^= ">"), name, to_dir, (to_dir ^= ">"), name, ^ersw); end; call hcs_$get_safety_sw (from_dir, name, safety_sw, code); if code ^= 0 then call complain (code, "^/Unable to get the safety_switch of ^a^[>^]^a.", from_dir, (from_dir ^= ">"), name); else do; call hcs_$set_safety_sw (to_dir, name, safety_sw, code); if code ^= 0 then call complain (code, "^/Unable to set the safety switch of ^a^[>^]^a.", to_dir, (to_dir ^= ">"), name); end; call copy_iacl_ (from_dir, name, to_dir, name, ersw, code); if code ^= 0 then call complain (code, "^/Unable to copy the initial ACL from ^a^[>^]^a to ^a^[>^]^a. Error occurred on the ^[source^;target^].", from_dir, from_dir ^= ">", name, to_dir, to_dir ^= ">", name, ^ersw); call work (from_dir, name, to_dir, name, acl, move); if acl | move then do; call copy_acl_ (from_dir, name, to_dir, name, ersw, code); if code ^= 0 then call complain (code, "^/Unable to copy ACL from ^a^[>^]^a to ^a^[>^]^a. Error occurred on the ^[source^;target^].", from_dir, from_dir ^= ">", name, to_dir, to_dir ^= ">", name, ^ersw); end; end directory; end work; create_directory: proc; code = 0; call hcs_$get_dir_ring_brackets (sd_name, se_name, dir_rings, code); if code ^= 0 then do; if code = error_table_$no_s_permission | code = error_table_$incorrect_access then do; cb_ptr -> create_branch_info.rings (1) = get_ring_ (); cb_ptr -> create_branch_info.rings (2) = cb_ptr -> create_branch_info.rings (1); cb_ptr -> create_branch_info.rings (3) = 7; end; else do; call complain (code, "^/Unable to get the directory ring brackets of ^a^[>^]^a.", sd_name, sd_name ^= ">", se_name); return; end; end; else do; cb_ptr -> create_branch_info.rings (1) = dir_rings (1); cb_ptr -> create_branch_info.rings (2) = dir_rings (2); cb_ptr -> create_branch_info.rings (3) = 7; end; call hcs_$get_access_class (sd_name, se_name, cb_ptr -> create_branch_info.access_class, code); if code ^= 0 then do; if code = error_table_$no_s_permission | code = error_table_$incorrect_access then cb_ptr -> create_branch_info.access_class = get_max_authorization_ (); else do; call complain (code, "^/Unable to get access class for ^a^[>^]^a.", sd_name, sd_name ^= ">", se_name); return; end; end; call hcs_$create_branch_ (td_name, te_name, cb_ptr, code); if code ^= 0 then do; call complain (code, "^/Unable to create the branch ^a^[>^]^a.", td_name, td_name ^= ">", te_name); return; end; call hcs_$get_uid_file (td_name, te_name, dir2_uid, code); if code ^= 0 then do; call complain (code, "^/Unable to get uid of the target directory ^a^[>^]^a.", td_name, td_name ^= ">", te_name); return; end; call contains (source_contains_target, target_contains_source, code); if code ^= 0 then do; call complain (code, "^/Unable to check containment of source and target directories, ^a^[>^]^a and ^a^[>^]^a respectively.", sd_name, sd_name ^= ">", se_name, td_name, td_name ^= ">", te_name); return; end; if source_contains_target /* the source directory contains the target directory */ then do; call complain (error_table_$action_not_performed, "^/The source directory cannot contain the target directory;^/^a contains ^a.", pathname_ (sd_name, se_name), pathname_ (td_name, te_name)); /* indicate that error has been found */ code = error_table_$action_not_performed; return; end; if target_contains_source /* the target directory contains the source directory */ then do; call complain (error_table_$action_not_performed, "^/The target directory cannot contain the source directory;^/^a contains ^a.", pathname_ (td_name, te_name), pathname_ (sd_name, se_name)); /* indicate that an error has been found */ code = error_table_$action_not_performed; return; end; return; end create_directory; contains: proc (p_source_contains_target, p_target_contains_source, code); /* check of target_dir in source_dir and vice-versa. */ dcl (dir1, dir2) char (168); dcl (en1, en2) char (32); dcl p_source_contains_target bit (1); dcl p_target_contains_source bit (1); dcl code fixed bin (35); code = 0; p_source_contains_target = "0"b; p_target_contains_source = "0"b; call hcs_$get_link_target (sd_name, se_name, dir1, en1, code); if code ^= 0 then return; call hcs_$get_link_target (td_name, te_name, dir2, en2, code); if code ^= 0 then return; call path_info (dir1, en1, scomp_count, scomp_root, code); if code ^= 0 then return; if dir1 = dir2 & en1 = en2 then do; code = error_table_$sameseg; p_target_contains_source = "1"b; p_source_contains_target = "1"b; end; else do; call path_info (dir2, en2, tcomp_count, tcomp_root, code); if code ^= 0 then return; if scomp_count = tcomp_count then return; else if scomp_count > tcomp_count then do; call csub (scomp_root, tcomp_count, uid, code); if code ^= 0 then return; if uid = dir2_uid then p_source_contains_target = "1"b; end; else do; /* for example: source and target pathnames are ">udd>m>x" and ">udd>m>x>y", respectively */ call csub (tcomp_root, scomp_count, uid, code); if code ^= 0 then return; if uid = dir1_uid then p_target_contains_source = "1"b; end; end; %page; csub: proc (p_root, p_count, p_uid, p_code); dcl (p, p_root) ptr; dcl (code, p_code) fixed bin (35); dcl dir char (128); dcl en char (32); dcl p_count fixed bin; dcl comp_index fixed bin; dcl p_uid bit (36) aligned; dir = ""; p = p_root; p_code = 0; if p_count = 1 then dir = ">"; else do comp_index = 1 to p_count - 1; dir = rtrim (dir) || ">" || p -> comp.name; p = p -> comp.next; end; en = p -> comp.name; call hcs_$get_uid_file (dir, en, p_uid, code); if code ^= 0 then p_code = code; end; end; path_info: proc (d, e, count, root, code); /* Turn pathname into threaded list of component names. */ dcl code fixed bin (35); dcl (d, e) char (*); dcl count fixed bin; dcl optr ptr; dcl dirstr char (168); dcl root ptr; count = 0; if d = ">" then dirstr = reverse (">" || rtrim (e)); else dirstr = reverse (rtrim (d) || ">" || rtrim (e)); ii = index (dirstr, ">"); cptr = null; optr = null; do while (ii > 1); alloc comp in (area); comp.name = reverse (substr (dirstr, 1, ii - 1)); comp.next = optr; optr = cptr; dirstr = substr (dirstr, ii + 1); count = count + 1; ii = index (dirstr, ">"); end; root = cptr; end; /* */ /* containment subroutine for the link copier. */ contains_target: proc (ld, le, new_target, code) recursive; /* Check whether source link's target pathname is contained in the source directory and if so, translate the link target pathname to a pathname in the target directory. Only the components of the target pathname which are target directory. Only the components of the target pathname which are be used in the check. If one of the components being checked is a link, contains_target is re-called with the new link target pathname and the unprocessed portion of the old one. */ dcl i fixed bin; dcl en char (32); dcl dir char (168); dcl new_target char (168); dcl p ptr; dcl (ld, le) char (*); dcl code fixed bin (35); dcl uid bit (36) aligned; call path_info (ld, le, lcomp_count, lcomp_root, code); if code ^= 0 then goto finish; if lcomp_count < scomp_count then do; code = no_translation; return; end; p = lcomp_root; dir = ""; /* Catenate the 2nd through lcomp_count'th components, checking at each one for links or matching with unique id's. */ do i = 1 to lcomp_count - 1; dir = rtrim (dir) || ">" || p -> comp.name; p = p -> comp.next; en = p -> comp.name; call hcs_$status_minf (dir, en, 0, type, (0), code); if code ^= 0 then if code = error_table_$noentry | code = error_table_$no_dir /* The part of the link target pathname which is non-null is not contained in source_dir. Therefore, don't translate the link. */ then do; code = no_translation; return; end; else do; code = no_translation; goto check_dir_level; end; if type = Link then do; code = no_translation; return; end; else if type ^= Directory then do; if i <= scomp_count - 1 then do; code = no_translation; return; end; end; else check_dir_level: call hcs_$get_uid_file (dir, en, uid, code); if code ^= 0 then do; code = no_translation; return; end; if i = scomp_count - 1 then if dir1_uid ^= uid then do; code = no_translation; return; end; else do; call ioa_$rsnnl ("^a^[>^]^a", new_target, ln, td_name, (td_name ^= ">"), te_name); p = p -> comp.next; do while (p ^= null); new_target = rtrim (new_target) || ">" || p -> comp.name; p = p -> comp.next; end; code = 0; return; end; next_comp: end; new_target = rtrim (new_target) || ">" || rtrim (le); return; end contains_target; get_uid: proc (p_path) returns (bit (36)); dcl p_path char (168); dcl dir char (168); dcl entry char (32); dcl code fixed bin (35); dcl uid bit (36) aligned; call expand_pathname_ (p_path, dir, entry, code); if code ^= 0 then return ("0"b); call hcs_$get_uid_file (dir, entry, uid, code); if code ^= 0 then return ("0"b); return (uid); end get_uid; %page; complain: proc () options (variable); dcl p_code fixed bin (35) based (argp); dcl argp ptr; dcl argl fixed bin (21); dcl nargs fixed bin; dcl arg_list_ptr ptr; dcl error_message char (512); dcl error_message_length fixed bin; call cu_$arg_ptr (1, argp, argl, 0); if ^brief then do; call cu_$arg_count (nargs, 0); if nargs > 1 then do; call cu_$arg_list_ptr (arg_list_ptr); call ioa_$general_rs (arg_list_ptr, 2, 3, error_message, error_message_length, "0"b, "0"b); call com_err_ (p_code, whoami, substr (error_message, 1, error_message_length)); end; else call com_err_ (p_code, whoami); end; errors = "1"b; acode = p_code; end complain; /* format: off */ %page; %include suffix_info; %include copy_flags; %page; %include create_branch_info; %page; %include query_info_; %page; %include status_structures; %page; %include copy_dir_options; %page; %include copy_options; declare 1 cpo aligned like copy_options; %page; %include delete_options; %include nd_handler_options; %page; %include copy_error_info; %include sub_error_info; %include condition_info_header; %include condition_info; declare 1 ci aligned like condition_info; %include sub_err_flags; %include star_structures; end copy_dir_;  copy_iacl_.pl1 10/25/83 1546.8r w 10/25/83 1444.6 42588 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Copy segment and/or directory IACL from one directory to another */ /* Rewritten: 23 January 1981 by G. Palter to not add *.SysDaemon.* term to the new IACL if not present in the original and to use the system free area rather than an automatic one */ copy_iacl_: procedure (source_dirname, source_ename, target_dirname, target_ename, error_on_target, code); /* Parameters */ dcl source_dirname character (*) parameter; /* dir/entry of directory whose IACL is copied */ dcl source_ename character (*) parameter; dcl target_dirname character (*) parameter; /* dir/entry of directory to receive the IACL */ dcl target_ename character (*) parameter; dcl error_on_target bit (1) aligned parameter; /* ON => error occurred adding IACL to target; OFF => error occured adding getting IACL from source */ dcl code fixed binary (35) parameter; /* Remaining declarations */ dcl 1 segment_acl (acl_count) aligned based (acl_ptr), 2 access_name character (32), 2 modes bit (36), 2 extended_modes bit (36), 2 status_code fixed binary (35); dcl 1 directory_acl (acl_count) based (acl_ptr), 2 access_name character (32), 2 dir_modes bit (36), 2 status_code fixed binary (35); dcl acl_ptr pointer; dcl acl_count fixed binary; dcl ring fixed binary (3); dcl directory_iacl bit (1) aligned; dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl get_ring_ entry () returns (fixed binary (3)); dcl get_system_free_area_ entry () returns (pointer); dcl (hcs_$list_inacl, hcs_$list_dir_inacl) entry (character (*), character (*), pointer, pointer, pointer, fixed binary, fixed binary (3), fixed binary (35)); dcl (hcs_$replace_dir_inacl, hcs_$replace_inacl) entry (character (*), character (*), pointer, fixed binary, bit(1) aligned, fixed binary (3), fixed binary (35)); dcl cleanup condition; dcl null builtin; %page; /* Copy both the segment and directory IACLs */ system_area_ptr = get_system_free_area_ (); ring = get_ring_ (); acl_ptr = null (); /* for cleanup handler */ on condition (cleanup) begin; if acl_ptr ^= null () then if directory_iacl then free directory_acl in (system_area); else free segment_acl in (system_area); end; directory_iacl = "0"b; call copy_seg_iacl (); if code ^= 0 then return; /* couldn't do it */ directory_iacl = "1"b; call copy_dir_iacl (); return; /* Copy the segment IACL only */ seg: entry (source_dirname, source_ename, target_dirname, target_ename, error_on_target, code); system_area_ptr = get_system_free_area_ (); ring = get_ring_ (); acl_ptr = null (); on condition (cleanup) begin; if acl_ptr ^= null () then free segment_acl in (system_area); end; call copy_seg_iacl (); return; /* Copy the directory IACL only */ dir: entry (source_dirname, source_ename, target_dirname, target_ename, error_on_target, code); system_area_ptr = get_system_free_area_ (); ring = get_ring_ (); acl_ptr = null (); on condition (cleanup) begin; if acl_ptr ^= null () then free directory_acl in (system_area); end; call copy_dir_iacl (); return; %page; /* Copy the segment IACL */ copy_seg_iacl: procedure (); error_on_target = "0"b; call hcs_$list_inacl (source_dirname, source_ename, system_area_ptr, acl_ptr, null (), acl_count, ring, code); if code ^= 0 then return; /* assume nothing was allocated */ error_on_target = "1"b; call hcs_$replace_inacl (target_dirname, target_ename, acl_ptr, acl_count, "1"b, ring, code); free segment_acl in (system_area); /* get rid of it */ return; end copy_seg_iacl; /* Copy the directory IACL */ copy_dir_iacl: procedure (); error_on_target = "0"b; call hcs_$list_dir_inacl (source_dirname, source_ename, system_area_ptr, acl_ptr, null (), acl_count, ring, code); if code ^= 0 then return; /* assume nothing allocated */ error_on_target = "1"b; call hcs_$replace_dir_inacl (target_dirname, target_ename, acl_ptr, acl_count, "1"b, ring, code); free directory_acl in (system_area); return; end copy_dir_iacl; end copy_iacl_;  copy_names.pl1 03/21/84 1044.0r 03/21/84 1043.0 60111 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * ************************************************************** */ /* format: style2,idind30,indcomtxt */ copy_names: procedure options (variable); /**** * The commands copy_names and move_names copy and move all the additional names from one designated segment to another. copy_names also copies the designated name. Name duplication within a directory is handled in the accepted manner. Any number of pairs of arguments is allowed and the = convention is followed in the second argument of a pair. */ /* Karolyn Martin 5/30/69 */ /* modified by M. Weaver 9 April 1970 6:35 PM -- recoded into PL/I */ /* last modified by M. Weaver 31 December 1970 */ /* modified 6/3/75 by S. Herbst: command names changed to copy_names and move_names */ /* TR7429 Changed to reject starnames 10/30/80 S. Herbst */ /* Housecleaned, but not entirely, J Pattin and BIM 83-(8, 9, 10) */ /* Allow star names in first argument. C Spitzer 12/20/83 */ dcl arg char (lng) based (ap); dcl (copy, errsw) bit (1) aligned; dcl (i, j, n) fixed bin (17); dcl lng fixed bin (21); dcl areap ptr; dcl myarea area based (areap); dcl bitcnt fixed bin (24); dcl code fixed bin (35); dcl (dir1, dir2) char (168); dcl (en1, en2, qent) char (32); dcl cleanup condition; dcl (null, sum) builtin; dcl stars bit (1) aligned; dcl ap ptr; dcl whoami char (32); dcl type fixed bin (2); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl check_star_name_$entry entry (character (*), fixed binary (35)); dcl expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35)); dcl ( com_err_, com_err_$suppress_name ) ext entry options (variable); dcl error_table_$namedup external fixed bin (35); dcl error_table_$segnamedup external fixed bin (35); dcl get_wdir_ ext entry returns (char (168)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl copy_names_ entry (character (*), character (*), character (*), character (*), character (*), bit (1) aligned, fixed binary (35)); dcl move_names_ entry (character (*), character (*), character (*), character (*), character (*), bit (1) aligned, fixed binary (35)); dcl get_equal_name_ entry (character (*), character (*), character (32), fixed binary (35)); dcl cu_$arg_count ext entry (fixed bin, fixed bin (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl get_system_free_area_ entry() returns(ptr); /* The additional names are to be left on the original segment. */ copy = "1"b; whoami = "copy_names"; go to work; move_names: entry options (variable); /* The additional names are to be removed from the original segment. */ copy = "0"b; whoami = "move_names"; work: call cu_$arg_count (n, code); if code ^= 0 then do; call com_err_ (code, whoami); return; end; if n = 0 then do; call com_err_$suppress_name (0, whoami, "Usage: ^a from1 to1 ... fromj toj", whoami); return; end; areap = get_system_free_area_ (); star_entry_ptr, star_names_ptr = null; on cleanup call cleaner; /* The following master loop processes each pair of arguments completely unless some error code is returned by the file system. */ do i = 1 to n by 2; /* get first arg */ call cu_$arg_ptr (i, ap, lng, code); call expand_pathname_ (arg, dir1, en1, code); if code ^= 0 then do; call com_err_ (code, whoami, "^a", arg); return; end; call check_star_name_$entry (en1, code); if code ^= 0 then do; if code = 1 | code = 2 then stars = "1"b; else do; call com_err_ (code, whoami, "^a", en1); return; end; end; /* get second arg */ if i = n then do; qent = en1; /* have odd no. of args */ dir2 = get_wdir_ (); call doit; end; else do; call cu_$arg_ptr (i + 1, ap, lng, code); call expand_pathname_ (arg, dir2, qent, code); if code ^= 0 then do; call com_err_ (code, whoami, "^a", arg); return; end; if stars then do; call hcs_$star_ (dir1, en1, 3, areap, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then do; errseg1: call com_err_ (code, whoami, "^a", pathname_ (dir1, en1)); goto next_arg; end; do j = 1 to star_entry_count; en1 = star_names (star_entries (j).nindex); call doit; end; call cleaner; /* get rid of current star structures */ end; else call doit; end; next_arg: end; doit: proc; call get_equal_name_ (en1, qent, en2, code); if code ^= 0 then do; call com_err_ (code, whoami, "^a for ^a", qent, en1); return; end; /* Does target segment exist?? */ call hcs_$status_minf (dir2, en2, 0, type, bitcnt, code); if code ^= 0 then go to errseg2; /* If so, then move the names. */ if copy then call copy_names_ (dir1, en1, dir2, en2, whoami, errsw, code); else call move_names_ (dir1, en1, dir2, en2, whoami, errsw, code); if code ^= 0 & code ^= error_table_$namedup & code ^= error_table_$segnamedup then if errsw then errseg2: call com_err_ (code, whoami, "^a", pathname_ (dir2, en2)); else call com_err_ (code, whoami, "^a", pathname_ (dir1, en1)); end doit; cleaner: proc; if star_names_ptr ^= null then do; free star_names in (myarea); star_names_ptr = null; end; if star_entry_ptr ^= null then do; free star_entries in (myarea); star_entry_ptr = null; end; return; end cleaner; %page; %include star_structures; end copy_names;  copy_names_.pl1 10/25/83 1546.8r w 10/25/83 1444.6 57285 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * ************************************************************** */ /* format: style2,idind30,indcomtxt */ copy_names_: proc (dir1, en1, dir2, en2, entry_name, errsw, code); /* Procedure to copy (copy_names_) or move (move_names_) the names from one segment to another. */ /* Copy_names_ copies all the names on a segment, move_names_ ignores the first name */ /* Coded by John Strayhorn 7/1/70 */ /* modified by E. Stone 12/71 - to allow nd_handler_ to be called from the user ring only */ /* last modified by J. Klensin 8/73 - to permit handling more than 60 names */ /* Bug fixed 1/22/76 by Steve Herbst */ /* changed to call object_type_ Jay Pattin 2/17/83 */ /* 830924 object_type_ -> fs_util_ BIM */ dcl (count, i) fixed bin (17); dcl code fixed bin (35); dcl (dir1, dir2) char (*); /* directories */ dcl (en1, en2, entry_name) char (*); /* entry names */ dcl name char (32); /* temporary name to save based references */ dcl (areap, eptr) ptr; dcl np ptr init (null); dcl 1 branch aligned, /* structure for status */ 2 type bit (2) unal, 2 nnames bit (16) unal, 2 nrp bit (18) unal, 2 pad bit (108) unal; dcl area area based (areap); dcl cleanup condition; dcl names (0:119) char (32) based (np); dcl hcs_$status_ entry (char (*), char (*), fixed bin, ptr, ptr, fixed bin (35)); dcl fs_util_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl nd_handler_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl (addr, bin, empty, null, ptr) builtin; dcl (get_ring_, get_initial_ring_) returns (fixed bin); dcl error_table_$namedup external fixed bin (35); dcl error_table_$segnamedup external fixed bin (35); dcl (mvsw, errsw, nd_flag, sd_flag, user_ring) bit (1) aligned; mvsw = "0"b; go to start; /* This entry deletes the names before adding them to the target segment. */ move_names_: entry (dir1, en1, dir2, en2, entry_name, errsw, code); mvsw = "1"b; /* Default assumption is that error occurred while referencing first segment. */ start: errsw, nd_flag, sd_flag = "0"b; /* set switch to indicate whether called from user ring (OK to query) */ user_ring = (get_ring_ () >= get_initial_ring_ ()); /* initialize pointers and area (for status) */ areap = get_system_free_area_ (); eptr = addr (branch); on condition (cleanup) call clean_up; /* call status to get names (get link names if a link). */ call hcs_$status_ (dir1, en1, 0, eptr, areap, code); if code ^= 0 then go to out; np = ptr (areap, branch.nrp); count = bin (branch.nnames, 17); /* move the names: same order, deleting first for move */ do i = 0 to count - 1; name = np -> names (i); if mvsw then do; if name = en1 then go to nex_nam; /* leave the name given as argument */ call fs_util_$chname_file (dir1, en1, name, "", code); if code ^= 0 then go to out; end; next_try: call fs_util_$chname_file (dir2, en2, "", name, code); if code ^= 0 then do; if code = error_table_$namedup then do; /* name already in directory */ if user_ring then do; /* query user to correct namedup */ call nd_handler_ (entry_name, dir2, name, code); if code = 0 then go to next_try; end; nd_flag, errsw = "1"b; go to nex_nam; end; else if code = error_table_$segnamedup then do; /* name already on segment */ sd_flag = "1"b; go to nex_nam; end; else do; if mvsw then call fs_util_$chname_file (dir1, en1, "", name, code); errsw = "1"b; call clean_up; return; end; end; nex_nam: end; out: if nd_flag then code = error_table_$namedup; else if sd_flag then code = error_table_$segnamedup; call clean_up; clean_up: proc (); /* procedure to free any space in system area */ if np ^= null then free names in (area); end clean_up; end copy_names_;  copy_seg_.pl1 10/25/83 1546.8r w 10/25/83 1444.6 37143 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * ************************************************************** */ copy_seg_: proc (P_source_dir, P_source_name, P_target_dir, P_target_name, P_caller, P_error_sw, P_code); /* This is a replacement for the old copy_seg_. It is just a write-around for copy_ Jay Pattin 6/29/83 */ declare (P_source_dir, P_source_name, P_target_dir, P_target_name, P_caller) char (*) parameter, P_error_sw bit (1) aligned parameter, P_code fixed bin (35) parameter; declare 1 cpo aligned like copy_options, 1 cei aligned like copy_error_info, 1 ci aligned like condition_info; declare brief bit (1) aligned, code fixed bin (35), message char (100) aligned, no_message bit (1) aligned; declare error_table_$fatal_error fixed bin (35) external, iox_$error_output ptr external, string builtin, sub_error_ condition; declare continue_to_signal_ entry (fixed bin (35)), convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned), copy_ entry (ptr), find_condition_info_ entry (ptr, ptr, fixed bin (35)), ioa_$ioa_switch entry options (variable); %page; %include copy_options; %page; %include copy_flags; %page; %include sub_error_info; %include copy_error_info; %include condition_info_header; %include condition_info; %page; brief, no_message = "0"b; goto COMMON; copy_seg_$brief: entry (P_source_dir, P_source_name, P_target_dir, P_target_name, P_caller, P_error_sw, P_code); brief = "1"b; no_message = "0"b; goto COMMON; copy_seg_$no_message: entry (P_source_dir, P_source_name, P_target_dir, P_target_name, P_caller, P_error_sw, P_code); brief = "0"b; no_message = "1"b; goto COMMON; COMMON: cpo.version = COPY_OPTIONS_VERSION_1; cpo.caller_name = P_caller; cpo.source_dir = P_source_dir; cpo.source_name = P_source_name; cpo.target_name = P_target_name; cpo.target_dir = P_target_dir; string (cpo.flags) = ""b; cpo.no_name_dup = no_message; string (cpo.copy_items) = ""b; on sub_error_ call sub_err_handler (); call copy_ (addr (cpo)); P_code = 0; return; MAIN_RETURN: P_error_sw = cpo.target_err_switch; if code = 0 then code = error_table_$fatal_error; P_code = code; return; %page; sub_err_handler: proc (); ci.version = condition_info_version_1; call find_condition_info_ (null (), addr (ci), (0)); sub_error_info_ptr = ci.info_ptr; if sub_error_info.name ^= "copy_" | copy_error_info.copy_options_ptr ^= addr (cpo) then do; call continue_to_signal_ ((0)); return; end; code = sub_error_info.status_code; if sub_error_info.cant_restart then goto MAIN_RETURN; if sub_error_info.default_restart & brief then return; call convert_status_code_ (code, "", message); call ioa_$ioa_switch (iox_$error_output, "^a: ^a ^a", cpo.caller_name, message, sub_error_info.info_string); return; end sub_err_handler; end copy_seg_;  create.pl1 03/15/89 0848.2r w 03/15/89 0800.5 139086 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1974 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ create: cr: proc; /* Command completely re-written on 10/04/74 to add create_dir options for compatibility with the Access Isolation Mechanism -- J. C. Whitmore */ /* Modified 750122 by LJS to use new hcs_$create_branch_ and clean up error handling */ /* Modified 751205 by LJS to use parent access class as default, make dir names starting with "-" invalid */ /* Modified April 1976 by Larry Johnson to create master directories */ /* Fix to reject "" and not print err after "no" to query 04/08/80 S. Herbst */ /* Fixed to reject -foo, create_dir to set 7,7 brackets and accept -rb 06/30/82 S. Herbst */ /* Changed to not create through links 07/28/82 S. Herbst */ /* Fixed -name 12/21/83 S. Herbst */ /* Rewrote again, added -msf and -max_length 01/11/84 S. Herbst */ /* Changed to provide dir_quota for dirs, December 1984, Keith Loepere. */ /* Modified 1985-01-02 by EJ Sharpe to add -account and -owner */ /* Fixed -name to disallow white space or null arg 02/21/85 Steve Herbst */ /* Constants */ dcl SMA bit (3) unaligned internal static options (constant) init ("111"b); dcl RW bit (3) unaligned internal static options (constant) init ("101"b); /* Based */ dcl arg char (arg_len) based (arg_ptr); /* Automatic */ dcl dn char (168); dcl (ctl_arg_name, en, lv_name, type_name, whoami) char (32); dcl (account, owner) char (32); dcl access_class bit (72) aligned; dcl (create_dir_sw, create_msf_sw) bit (1); dcl (ac_specified_sw, lv_specified_sw, quota_specified_sw, dir_quota_specified_sw) bit (1); dcl (acct_specified_sw, owner_specified_sw) bit (1); dcl (alp, arg_ptr, fcb_ptr) ptr; dcl rb (3) fixed bin; dcl (arg_count, i) fixed bin; dcl (quota, dir_quota) fixed bin (18); dcl (msf_max_length, specified_max_length) fixed bin (19); dcl arg_len fixed bin (21); dcl code fixed bin (35); /* External */ dcl error_table_$action_not_performed fixed bin (35) ext; dcl error_table_$bad_ring_brackets fixed bin (35) ext; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$invalid_ring_brackets fixed bin (35) ext; dcl error_table_$namedup fixed bin (35) ext; dcl error_table_$no_s_permission fixed bin (35) ext; dcl error_table_$noarg fixed bin (35) ext; dcl error_table_$noentry fixed bin (35) ext; dcl error_table_$nostars fixed bin (35) ext; dcl sys_info$max_seg_size fixed bin(35) ext static; /* Entries */ dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl mdc_$create_dirx_acct entry (char (*), char (*), char (*), ptr, char (*), char (*), fixed bin (35)); dcl cu_$level_get entry () returns (fixed bin); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_authorization_ entry returns (bit (72) aligned); dcl get_group_id_$tag_star entry () returns (char (32)); dcl get_wdir_ entry returns (char (168)); dcl hcs_$create_branch_ entry (char (*), char (*), pointer, fixed bin (35)); dcl hcs_$set_max_length entry (char(*), char(*), fixed bin(19), fixed bin(35)); dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35)); dcl ioa_ entry options (variable); dcl msf_manager_$close entry (ptr); dcl msf_manager_$msf_get_ptr entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35)); dcl msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35)); dcl nd_handler_ entry (char (*), char (*), char (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); /* Builtins */ dcl (addr, mod, null, string, substr, verify) builtin; /* Conditions */ dcl cleanup condition; %include create_branch_info; dcl 1 branch_template aligned like create_branch_info; dcl WHITE_SPACE char (4) aligned int static options (constant) init (/* NL HT SP FF */ " "); whoami = "create"; create_dir_sw = "0"b; go to CHECK_ARGS; create_dir: createdir: cd: entry; whoami = "create_dir"; create_dir_sw = "1"b; CHECK_ARGS: access_class = get_authorization_ (); call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, whoami); return; end; if arg_count = 0 then do; USAGE: call com_err_$suppress_name (0, whoami, "Usage: ^a paths {-control_args}", whoami); return; end; call cu_$arg_list_ptr (alp); create_msf_sw = "0"b; ac_specified_sw, lv_specified_sw, quota_specified_sw, dir_quota_specified_sw = "0"b; acct_specified_sw, owner_specified_sw = "0"b; msf_max_length = 0; /* can be changed by -max_length */ quota, dir_quota = 0; if create_dir_sw then rb (1), rb (2), rb (3) = 7; /* default for dirs */ else rb (1), rb (2), rb (3) = cu_$level_get (); /* for segments */ account = ""; /* defaults to user's proccess group id */ owner = ""; /* defaults to user's proccess group id */ begin; dcl name_sw (arg_count) bit (1) unaligned; dcl path_sw (arg_count) bit (1) unaligned; string (name_sw) = "0"b; string (path_sw) = "0"b; do i = 1 to arg_count; call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp); if code ^= 0 then do; call com_err_ (code, whoami); return; end; /* Control args only for create_dir */ if arg = "-access_class" | arg = "-acc" then do; if ^create_dir_sw then go to BAD_CTL_ARG; ctl_arg_name = "-access_class"; /* save arg name in case error printed */ i = i + 1; if i > arg_count then do; MISSING_VALUE: call com_err_ (0, whoami, "No value specified for ^a", ctl_arg_name); return; end; call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp); call convert_authorization_$from_string (access_class, arg, code); if code ^= 0 then do; /* all errors are fatal */ call com_err_ (code, whoami, arg); return; end; ac_specified_sw = "1"b; end; else if arg = "-logical_volume" | arg = "-lv" then do; if ^create_dir_sw then go to BAD_CTL_ARG; ctl_arg_name = "-logical_volume"; i = i + 1; if i > arg_count then go to MISSING_VALUE; call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp); lv_specified_sw = "1"b; lv_name = arg; end; else if arg = "-quota" then do; if ^create_dir_sw then go to BAD_CTL_ARG; ctl_arg_name = "-quota"; i = i + 1; if i > arg_count then go to MISSING_VALUE; call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp); quota = cv_dec_check_ (arg, code); if code ^= 0 then do; BAD_VALUE: call com_err_ (code, whoami, "Cannot convert ^a value ^a", ctl_arg_name, arg); return; end; quota_specified_sw = "1"b; end; else if arg = "-dir_quota" then do; if ^create_dir_sw then go to BAD_CTL_ARG; ctl_arg_name = "-dir_quota"; i = i + 1; if i > arg_count then go to MISSING_VALUE; call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp); dir_quota = cv_dec_check_ (arg, code); if code ^= 0 then go to BAD_VALUE; dir_quota_specified_sw = "1"b; end; else if arg = "-account" | arg = "-acct" then do; if ^create_dir_sw then go to BAD_CTL_ARG; ctl_arg_name = "-account"; i = i + 1; if i > arg_count then go to MISSING_VALUE; call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp); account = arg; acct_specified_sw = "1"b; end; else if arg = "-owner" | arg = "-ow" then do; if ^create_dir_sw then go to BAD_CTL_ARG; ctl_arg_name = "-owner"; i = i + 1; if i > arg_count then go to MISSING_VALUE; call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp); owner = arg; owner_specified_sw = "1"b; end; /* Control args only for create */ else if arg = "-max_length" | arg = "-ml" then do; if create_dir_sw then go to BAD_CTL_ARG; ctl_arg_name = "-max_length"; i = i + 1; if i > arg_count then go to MISSING_VALUE; call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp); msf_max_length = cv_dec_check_ (arg, code); if code ^= 0 then go to BAD_VALUE; if msf_max_length <= 0 then go to BAD_VALUE; end; else if arg = "-multisegment_file" | arg = "-msf" then do; if create_dir_sw then go to BAD_CTL_ARG; create_msf_sw = "1"b; end; else if arg = "-segment" | arg = "-sm" then do; if create_dir_sw then go to BAD_CTL_ARG; create_msf_sw = "0"b; end; /* Control args for both commands */ else if arg = "-name" | arg = "-nm" then do; ctl_arg_name = "-name"; i = i + 1; if i > arg_count then go to MISSING_VALUE; call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp); if verify (arg, WHITE_SPACE) = 0 then do; call com_err_ (0, whoami, "Invalid name ""^a""", arg); return; end; path_sw (i), name_sw (i) = "1"b; end; else if arg = "-ring_brackets" | arg = "-rb" then do; ctl_arg_name = "-ring_brackets"; i = i + 1; if i > arg_count then go to MISSING_VALUE; call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp); rb (1) = cv_dec_check_ (arg, code); if code ^= 0 then go to BAD_VALUE; if i < arg_count then do; call cu_$arg_ptr_rel (i + 1, arg_ptr, arg_len, code, alp); rb (2) = cv_dec_check_ (arg, code); if code = 0 then do; i = i + 1; if i < arg_count & ^create_dir_sw then do; call cu_$arg_ptr_rel (i + 1, arg_ptr, arg_len, code, alp); rb (3) = cv_dec_check_ (arg, code); if code = 0 then i = i + 1; else rb (3) = rb (2); end; else rb (3) = rb (2); end; else rb (2), rb (3) = rb (1); end; else rb (2), rb (3) = rb (1); end; else if substr (arg, 1, 1) = "-" then do; BAD_CTL_ARG: call com_err_ (error_table_$badopt, whoami, arg); return; end; else do; if verify (arg, WHITE_SPACE) = 0 then do; /* blank arg */ call com_err_ (0, whoami, "Invalid name ""^a""", arg); return; end; path_sw (i) = "1"b; end; end; if string (path_sw) = "0"b then go to USAGE; if msf_max_length ^= 0 & ^create_msf_sw then do; call com_err_ (0, whoami, "-max_length can only be specified with -msf."); return; end; if msf_max_length > sys_info$max_seg_size then do; call ioa_ ("^a: Max length ^d greater than limit of ^d; using ^d for max length.", whoami, msf_max_length, sys_info$max_seg_size, sys_info$max_seg_size); msf_max_length = sys_info$max_seg_size; end; if mod (msf_max_length, 1024) ^= 0 then do; specified_max_length = msf_max_length; msf_max_length = msf_max_length - mod (msf_max_length, 1024) + 1024; call ioa_ ("^a: ^d is not a multiple of 1024; ^d will be used for max length.", whoami, specified_max_length, msf_max_length); end; if ^quota_specified_sw & (lv_specified_sw | ac_specified_sw) then do; /* special directories need quota */ if lv_specified_sw & ac_specified_sw then type_name = "upgraded master"; else if lv_specified_sw then type_name = "master"; else type_name = "upgraded"; call com_err_ (error_table_$noarg, whoami, "-quota needed to create ^a directory.", type_name); return; end; if (acct_specified_sw | owner_specified_sw) & ^lv_specified_sw then do; call com_err_ (error_table_$noarg, whoami, "^[-account^]^[ and ^]^[-owner^] may only be specified when using -logical_volume to create a master directory.", acct_specified_sw, (acct_specified_sw & owner_specified_sw), owner_specified_sw); return; end; /* - - - - This is where the real work starts - - - - */ /* Fill in structure that gets passed to hcs_$create_branch_ */ branch_template.version = create_branch_version_2; /* Fill in version constant defined in include file */ branch_template.switches.dir_sw = create_dir_sw; branch_template.switches.copy_sw = "0"b; branch_template.switches.priv_upgrade_sw = "0"b; branch_template.switches.mbz1 = (31)"0"b; if create_dir_sw then branch_template.mode = SMA; else branch_template.mode = RW; branch_template.mbz2 = (33)"0"b; do i = 1 to 3; branch_template.rings (i) = rb (i); end; branch_template.userid = get_group_id_$tag_star (); branch_template.bitcnt = 0; branch_template.quota = quota; branch_template.dir_quota = dir_quota; branch_template.chase_sw = "0"b; do i = 1 to arg_count; if ^path_sw (i) then go to END_LOOP; /* skip over control args */ call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp); if code ^= 0 then do; call com_err_ (code, whoami, "Arg: ^d", i); return; end; if name_sw (i) then do; dn = get_wdir_ (); en = arg; end; else do; call expand_pathname_ (arg, dn, en, code); if code ^= 0 then do; call com_err_ (code, whoami, arg); go to END_LOOP; end; call check_star_name_$entry (en, code); if code ^= 0 then do; if code < 3 then code = error_table_$nostars; /* star convention not allowed */ go to COMPLAIN; end; end; branch_template.parent_ac_sw = ^ac_specified_sw; branch_template.access_class = access_class; TRY_AGAIN: if lv_specified_sw then call mdc_$create_dirx_acct (dn, en, lv_name, addr (branch_template), account, owner, code); else if create_msf_sw then code = create_msf (); else call hcs_$create_branch_ (dn, en, addr (branch_template), code); if code ^= 0 then if code = error_table_$namedup then do; call nd_handler_ (whoami, dn, en, code); if code = 0 then go to TRY_AGAIN; /* user deleted it */ if code > 1 & code ^= error_table_$action_not_performed then COMPLAIN: call com_err_ (code, whoami, "^a^[^/^-Specified ring brackets: ^d,^d,^d^]", pathname_ (dn, en), code = error_table_$bad_ring_brackets | code = error_table_$invalid_ring_brackets, rb (1), rb (2), rb (3)); go to END_LOOP; end; else go to COMPLAIN; END_LOOP: end; end; /* begin block */ return; %page; create_msf: proc returns (fixed bin (35)); /* Creates an MSF with pathname dn>en, returns the status code */ dcl code fixed bin (35); call hcs_$status_minf (dn, en, 0, 0, 0, code); if code = 0 | code = error_table_$no_s_permission then return (error_table_$namedup); else if code ^= error_table_$noentry then return (code); fcb_ptr = null; on cleanup begin; if fcb_ptr ^= null then call msf_manager_$close (fcb_ptr); end; call msf_manager_$open (dn, en, fcb_ptr, code); if fcb_ptr = null then return (code); call msf_manager_$msf_get_ptr (fcb_ptr, 0, "1"b, null, 0, code); /* creates the MSF */ call msf_manager_$close (fcb_ptr); if msf_max_length ^= 0 then do; call hcs_$set_max_length (pathname_ (dn, en), "0", msf_max_length, code); if code ^= 0 then call com_err_ (code, whoami, "Could not set max length of ^a>0", pathname_ (dn, en)); end; return (code); end create_msf; end create;  equal_.pl1 10/25/83 1546.8r w 10/25/83 1444.6 22410 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* N__a_m_e: equal_ */ /* */ /* This program provides an interface between the obsolete routine, equal_, and */ /* the routine which has replaced it, get_equal_name_. equal_ scans its character string */ /* arguments to compute their length, according to the algorithm: */ /* */ /* do Larg = 1 to 32 while (substr (arg, Larg, 1) ^= " "); */ /* end; */ /* Larg = Larg - 1; */ /* */ /* and then calls get_equal_name_ with these arguments, and returns its results. */ /* Eventually, this obsolete routine should be deleted. */ /* */ /* S__t_a_t_u_s */ /* */ /* 0) Created: July, 1973 by G. C. Dixon */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ equal_: procedure (Pentry, Pequal, Ptarget, code); dcl Pentry ptr, /* ptr to an entry name of 32 or fewer chars.(In) */ Pequal ptr, /* ptr to an equal name of 32 or fewer chars.(In) */ Ptarget ptr, /* ptr to a target name of 32 chars.(In) */ code fixed bin(35); /* a status code. */ dcl Lentry fixed bin, /* length of entry name. */ Lequal fixed bin, /* length of equal name. */ entry char(Lentry) based (Pentry), equal char(Lequal) based (Pequal), (error_table_$bad_equal_name, error_table_$badequal) fixed bin(35) ext static, get_equal_name_ entry (char(*), char(*), char(*), fixed bin(35)), substr builtin, target char(32) based (Ptarget); do Lentry = 1 to 32 while (substr (entry, Lentry, 1) ^= " "); end; Lentry = Lentry - 1; do Lequal = 1 to 32 while (substr (equal, Lequal, 1) ^= " "); end; Lequal = Lequal - 1; call get_equal_name_ (entry, equal, target, code); if code = error_table_$bad_equal_name then code = error_table_$badequal; end equal_;  link.pl1 02/06/84 1012.8re 02/06/84 1008.2 86094 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ link: lk: proc; /* The link command: link target1 path1 ... targetN {pathN} */ /* Written 12/05/80 S. Herbst */ /* Added -chase, -check, -copy_names, -name, reject -foo and blank names 06/30/82 S. Herbst */ /* Fixed to print usage message if no pathnames specified 04/04/83 S. Herbst */ /* Fixed not to try to -copy_names if link cannot be created 12/12/83 S. Herbst */ /* Constants */ dcl WHITE_SPACE char (5) int static options (constant) init (" "); /* SP HT VT NL FF */ dcl ALL_ENTRIES fixed bin (2) int static options (constant) init (3); dcl (CHASE init (1), NO_CHASE init (0)) fixed (1) int static options (constant); dcl LINK_TYPE fixed (2) int static options (constant) init (0); /* Based */ dcl arg char (arg_len) based (arg_ptr); /* Automatic */ dcl (dn, first_arg, target_dn) char (168); dcl (en, target_en) char (32); dcl (chase_sw, check_sw, copy_names_sw, errsw, got_path_sw, name_sw, second_arg_sw, star_sw) bit (1); dcl arg_ptr ptr; dcl (arg_count, arg_len, i) fixed; dcl type fixed bin (2); dcl code fixed bin (35); dcl error_table_$action_not_performed fixed (35) ext; dcl error_table_$badopt fixed (35) ext; dcl error_table_$namedup fixed (35) ext; dcl error_table_$no_s_permission fixed (35) ext; dcl error_table_$noentry fixed (35) ext; dcl error_table_$segnamedup fixed (35) ext; dcl check_star_name_$entry entry (char (*), fixed (35)); dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl copy_names_ entry (char (*), char (*), char (*), char (*), char (*), bit (1), fixed (35)); dcl cu_$arg_count entry (fixed, fixed (35)); dcl cu_$arg_ptr entry (fixed, ptr, fixed, fixed (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed (35)); dcl get_equal_name_ entry (char (*), char (*), char (*), fixed (35)); dcl get_system_free_area_ entry returns (ptr); dcl get_wdir_ entry returns (char (168)); dcl hcs_$append_link entry (char (*), char (*), char (*), fixed (35)); dcl hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed (35)); dcl hcs_$star_ entry (char (*), char (*), fixed (2), ptr, fixed, ptr, ptr, fixed (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed (1), fixed (2), fixed (24), fixed (35)); dcl nd_handler_ entry (char (*), char (*), char (*), fixed (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl (fixed, null, search, verify) builtin; dcl cleanup condition; %page; call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, "link"); return; end; chase_sw, check_sw, copy_names_sw, got_path_sw = "0"b; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if verify (arg, WHITE_SPACE) = 0 then do; /* blank arg */ call com_err_ (0, "link", "Invalid name ""^a""", arg); return; end; if substr (arg, 1, 1) = "-" then if arg = "-chase" then chase_sw = "1"b; else if arg = "-no_chase" then chase_sw = "0"b; else if arg = "-check" | arg = "-ck" then check_sw = "1"b; else if arg = "-no_check" | arg = "-nck" then check_sw = "0"b; else if arg = "-copy_names" | arg = "-cpnm" then copy_names_sw = "1"b; else if arg = "-no_copy_names" | arg = "-ncpnm" then copy_names_sw = "1"b; else if arg = "-name" | arg = "-nm" then i = i + 1; else do; call com_err_ (error_table_$badopt, "link", "^a", arg); return; end; else got_path_sw = "1"b; end; if ^got_path_sw then do; call com_err_$suppress_name (0, "link", "Usage: link target_path1 link_path1 ... target_pathN {link_pathN} {-control_args}"); return; end; second_arg_sw = "0"b; /* ON if already got first arg of pair */ name_sw = "0"b; /* ON if -name just encountered */ do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) = "-" then if arg = "-name" | arg = "-nm" then do; i = i + 1; if i > arg_count then do; call com_err_ (0, "link", "No value specified for -name"); return; end; name_sw = "1"b; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if second_arg_sw then go to SECOND_ARG; else do; call com_err_ (0, "link", "-name not allowed before target path."); return; end; end; else; else if ^second_arg_sw then do; FIRST_ARG: second_arg_sw = "1"b; /* for next time through */ first_arg = arg; call expand_pathname_ (arg, target_dn, target_en, code); if code ^= 0 then do; PATH_ERR: call com_err_ (code, "link", "^a", arg); return; end; call check_star_name_$entry (target_en, code); if code ^= 0 then if code = 1 | code = 2 then star_sw = "1"b; else do; call com_err_ (code, "link", "^a", target_en); return; end; else star_sw = "0"b; end; else do; name_sw = "0"b; SECOND_ARG: second_arg_sw = "0"b; /* for next time through */ if name_sw then do; name_sw = "0"b; dn = get_wdir_ (); en = arg; end; else do; call expand_pathname_ (arg, dn, en, code); if code ^= 0 then go to PATH_ERR; call check_star_name_$entry (en, code); if code ^= 0 then do; if code = 1 | code = 2 then call com_err_ (0, "link", "Stars not allowed in link pathname. ^a", arg); else call com_err_ (code, "link", "^a", en); return; end; end; if star_sw then call link_stars (dn, en, target_dn, target_en); else call link_one (dn, en, target_dn, target_en); end; end; if second_arg_sw then do; /* second arg in pair missing */ if search (first_arg, "<>") = 0 then do; /* first is in wdir */ call com_err_ (0, "link", "Link points to itself; not created. ^a", pathname_ (target_dn, target_en)); return; end; dn = get_wdir_ (); en = "==="; if star_sw then call link_stars (dn, en, target_dn, target_en); else call link_one (dn, en, target_dn, target_en); end; RETURN: return; %page; link_one: proc (P_dn, P_en, P_target_dn, P_target_en); dcl (P_dn, P_en, P_target_dn, P_target_en) char (*); dcl (target_dn, target_path, ultimate_dn) char (168); dcl (en, target_en, ultimate_en) char (32); target_dn = P_target_dn; target_en = P_target_en; target_path = pathname_ (target_dn, target_en); call get_equal_name_ (target_en, P_en, en, code); if code ^= 0 then do; call com_err_ (code, "link", "^a for ^a", en, target_en); return; end; if check_sw then do; call hcs_$status_minf (target_dn, target_en, CHASE, type, 0, code); if code ^= 0 & code ^= error_table_$no_s_permission then do; if code = error_table_$noentry then do; call hcs_$status_minf (target_dn, target_en, NO_CHASE, 0, 0, code); if code ^= error_table_$noentry then do; call com_err_ (0, "link", "No ultimate target for intended target ^a", pathname_ (target_dn, target_en)); go to RETURN; end; end; call com_err_ (code, "link", "Link target ^a", pathname_ (target_dn, target_en)); go to RETURN; end; end; if chase_sw then do; call hcs_$get_link_target (target_dn, target_en, ultimate_dn, ultimate_en, code); if ultimate_dn ^= "" then do; target_dn = ultimate_dn; target_en = ultimate_en; target_path = pathname_ (target_dn, target_en); end; end; LINK: call hcs_$append_link (P_dn, en, target_path, code); if code ^= 0 then if code = error_table_$namedup then do; /* ask whether to replace existing link */ call nd_handler_ ("link", P_dn, en, code); if code = 0 then go to LINK; else if code = error_table_$action_not_performed then return; else go to RETURN; /* an error occurred */ end; else call com_err_ (code, "link", "^a^[>^]^a", dn, dn ^= ">", en); else if copy_names_sw then do; call copy_names_ (target_dn, target_en, P_dn, en, "link -copy_names", errsw, code); if code ^= 0 & code ^= error_table_$namedup & code ^= error_table_$segnamedup then if errsw then call com_err_ (code, "link", "^a", pathname_ (P_dn, en)); else call com_err_ (code, "link", "^a", pathname_ (target_dn, target_en)); end; end link_one; %page; link_stars: proc (P_dn, P_en, P_target_dn, P_target_en); dcl (P_dn, P_en, P_target_dn, P_target_en) char (*); dcl 1 entries (entry_count) based (entries_ptr), 2 pad bit (18) unaligned, 2 nindex bit (18) unaligned; dcl names (999) char (32) aligned based (names_ptr); dcl target_en char (32); dcl area area based (area_ptr); dcl (area_ptr, entries_ptr, names_ptr) ptr; dcl (entry_count, j) fixed bin; area_ptr = get_system_free_area_ (); entries_ptr, names_ptr = null; on cleanup call star_cleanup; call hcs_$star_ (P_target_dn, P_target_en, ALL_ENTRIES, area_ptr, entry_count, entries_ptr, names_ptr, code); if code ^= 0 then do; call com_err_ (code, "link", "^a", pathname_ (P_target_dn, P_target_en)); return; end; do j = 1 to entry_count; target_en = names_ptr -> names (fixed (entries_ptr -> entries (j).nindex)); call link_one (P_dn, P_en, P_target_dn, target_en); end; call star_cleanup; return; star_cleanup: proc; if entries_ptr ^= null then free entries in (area); if names_ptr ^= null then free names in (area); end star_cleanup; end link_stars; end link;  move_quota.pl1 02/22/85 0836.4rew 02/21/85 0927.6 193833 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ move_quota: movequota: mq: proc; /* Implements the get_quota and move_quota commands and the get_quota active function. */ /* Coded November 1969 by M.R. Thompson */ /* Converted to pl1 1970 J.W. Gintell */ /* Star convention added September 1971 J. W. Gintell */ /* Converted to Version 2 December 1971 J.W. Gintell */ /* Removed set_quota entry point to tools May 1975 J. Whitmore */ /* Extra blank line removed from output 07/14/76 S. Herbst */ /* Rewrote, added gq af and -quota, -records_left, -records_used 09/29/82 S. Herbst */ /* Fixed to print table when multiple paths specified 10/29/82 S. Herbst */ /* Fixed error message for invalid numeric arg 01/03/83 S. Herbst */ /* Fixed bug in gq active function 03/17/83 S. Herbst */ /* Fixed -rec_left on link to use target's parent quota not link's parent quota 07/06/84 S. Herbst */ /* Added -nonzero, -total, -zero 07/06/84 S. Herbst */ /* Changed -all to print trp price at current rate structure 07/09/84 S. Herbst */ /* Added -sort 07/12/84 S. Herbst */ /* Fixed bug truncating record-days to an integer 11/15/84 Steve Herbst */ /* Fixed -long to align its output data in a column 11/26/84 Steve Herbst */ /* Fixed bug in error message when no directories match a starname 02/15/85 Steve Herbst */ /* Constants */ dcl NO_ACCESS fixed bin int static options (constant) init (-1); dcl (QUOTA init (1), RECORDS_LEFT init (2), RECORDS_USED init (3)) fixed bin int static options (constant); /* Based */ dcl area area based (area_ptr); dcl 1 node aligned based, 2 sort_value fixed bin (35), 2 next ptr, 2 info, 3 path char (168) unaligned, 3 lvname char (36), 3 trp fixed bin (71), 3 time_updated fixed bin (36), 3 (terminal_quota, quota_value, records_left, records_used) fixed bin; dcl arg char (arg_len) based (arg_ptr); dcl return_arg char (return_len) varying based (return_ptr); /* Automatic */ dcl (dn, path) char (168); dcl lvname_string char (36); dcl (default_lvname, en, lvname, me, time_string) char (32); dcl sons_lvid bit (36); dcl (af_sw, dir_quota_sw, long_sw, nonzero_sw, print_header_sw, quota_sw, records_left_sw, records_used_sw) bit (1); dcl (some_matches, some_nonzero, some_zero, sort_sw, star_sw, total_sw, type_specified_sw, wdir_sw, zero_sw) bit (1); dcl (area_ptr, arg_ptr, first_node_ptr, last_node_ptr, p, return_ptr) ptr; dcl rate_structure_number fixed bin (9); dcl (arg_count, i, j, node_count, path_count, quota_value, records_left, records_used) fixed bin; dcl (sort_by, terminal_quota, total_quota, total_records_used) fixed bin; dcl (arg_len, return_len) fixed bin (21); dcl (code, time_updated) fixed bin (35); dcl trp fixed bin (71); dcl record_days float bin; dcl dummy_rate (0:7) float bin; dcl (disk_rate, dummy_float) float bin; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$badstar fixed bin (35) ext; dcl error_table_$nomatch fixed bin (35) ext; dcl error_table_$nostars fixed bin (35) ext; dcl error_table_$not_act_fnc fixed bin (35) ext; dcl complain variable entry options (variable); dcl get_arg variable entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl active_fnc_err_ entry options (variable); dcl check_star_name_$path entry (char (*), fixed bin (35)); dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl (cu_$af_arg_ptr, cu_$arg_ptr) entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl date_time_$fstime entry (fixed bin (35), char (*)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl get_wdir_ entry returns (char (168)); dcl (hcs_$dir_quota_move, hcs_$quota_move) entry (char (*), char (*), fixed bin, fixed bin (35)); dcl (hcs_$dir_quota_read, hcs_$quota_read) entry (char (*), fixed bin, fixed bin (71), fixed bin (35), bit (36), fixed bin, fixed bin, fixed bin (35)); dcl hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$star_dir_list_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)); dcl (ioa_, ioa_$rsnnl) entry options (variable); dcl mdc_$find_lvname entry (bit (36), char (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl sort_items_$fixed_bin entry (ptr); dcl system_info_$prices_rs entry (fixed bin (9), (0:7)float bin, (0:7)float bin, (0:7)float bin, (0:7)float bin, float bin, float bin); dcl user_info_$rs_number entry (fixed bin (9)); dcl (addr, binary, divide, float, index, length, mod, null, reverse, substr, sum, unspec) builtin; dcl cleanup condition; %page; me = "move_quota"; dir_quota_sw = "0"b; go to MOVE_COMMON; move_dir_quota: entry; me = "move_dir_quota"; dir_quota_sw = "1"b; MOVE_COMMON: call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, me); return; end; if arg_count < 2 | mod (arg_count, 2) ^= 0 then do; call com_err_$suppress_name (0, me, "Usage: ^a path1 records1 ... pathN recordsN", me); return; end; do i = 1 by 2 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if index (arg, "-") = 1 then if arg = "-working_directory" | arg = "-working_dir" | arg = "-wd" then do; dn = get_wdir_ (); en = ""; end; else do; call com_err_ (error_table_$badopt, me, "^a", arg); return; end; else do; call expand_pathname_ (arg, dn, en, code); if code ^= 0 then do; call com_err_ (code, me, "^a", arg); return; end; end; call cu_$arg_ptr (i + 1, arg_ptr, arg_len, code); quota_value = cv_dec_check_ (arg, code); if code ^= 0 then do; call com_err_ (0, me, "Invalid numeric argument. ^a", arg); return; end; if dir_quota_sw then call hcs_$dir_quota_move (dn, en, quota_value, code); else call hcs_$quota_move (dn, en, quota_value, code); if code ^= 0 then do; call com_err_ (code, me, "^a", pathname_ (dn, en)); return; end; end; return; %page; get_quota: getquota: gq: entry; me = "get_quota"; dir_quota_sw = "0"b; go to GET_COMMON; get_dir_quota: entry; me = "get_dir_quota"; dir_quota_sw = "1"b; GET_COMMON: call cu_$af_return_arg (arg_count, return_ptr, return_len, code); if code = 0 then do; af_sw = "1"b; get_arg = cu_$af_arg_ptr; complain = active_fnc_err_; end; else if code = error_table_$not_act_fnc then do; af_sw = "0"b; get_arg = cu_$arg_ptr; complain = com_err_; end; else do; call com_err_ (code, me); return; end; long_sw, nonzero_sw, quota_sw, records_left_sw, records_used_sw = "0"b; sort_sw, total_sw, type_specified_sw, wdir_sw, zero_sw = "0"b; path_count = 0; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if index (arg, "-") = 1 then if arg = "-all" | arg = "-a" then do; LONG: if af_sw then do; BAD_OPT: call complain (error_table_$badopt, me, "^a", arg); return; end; long_sw, quota_sw, records_left_sw, records_used_sw = "1"b; end; else if arg = "-long" | arg = "-lg" then go to LONG; else if arg = "-nonzero" | arg = "-nz" then if af_sw then go to BAD_OPT; else nonzero_sw = "1"b; else if arg = "-quota" then quota_sw, type_specified_sw = "1"b; else if arg = "-records_left" | arg = "-rec_left" | arg = "-left" then records_left_sw, type_specified_sw = "1"b; else if arg = "-records_used" | arg = "-rec_used" | arg = "-ru" | arg = "-used" then records_used_sw, type_specified_sw = "1"b; else if arg = "-sort" then if af_sw then go to BAD_OPT; else sort_sw = "1"b; else if arg = "-total" | arg = "-tt" then total_sw = "1"b; else if arg = "-working_directory" | arg = "-working_dir" | arg = "-wd" then if af_sw & path_count > 0 then go to AF_TWO_PATHS; else do; wdir_sw = "1"b; path_count = path_count + 1; end; else if arg = "-zero" then if af_sw then go to BAD_OPT; else zero_sw = "1"b; else go to BAD_OPT; else do; if af_sw & path_count > 0 then do; AF_TWO_PATHS: call complain (0, me, "Only one directory allowed."); return; end; path_count = path_count + 1; end; end; if nonzero_sw & zero_sw then do; call complain (0, me, "Incompatible control arguments -zero and -nonzero"); return; end; if af_sw then if (quota_sw & records_left_sw) | (records_left_sw & records_used_sw) | (quota_sw & records_used_sw) then do; call complain (0, me, "Only one of -quota, -records_left, -records_used is allowed."); return; end; if ^type_specified_sw then if af_sw then quota_sw = "1"b; /* af default: just return quota */ else quota_sw, records_used_sw = "1"b; if sort_sw then do; /* decide which value to sort by */ if quota_sw & ^records_left_sw & ^records_used_sw then sort_by = QUOTA; else if records_left_sw & ^quota_sw & ^records_used_sw then sort_by = RECORDS_LEFT; else sort_by = RECORDS_USED; node_count = 0; end; default_lvname = ""; print_header_sw = "1"b; some_nonzero, some_zero, star_sw = "0"b; total_quota, total_records_used = 0; star_entry_ptr, star_names_ptr = null; first_node_ptr, last_node_ptr = null; area_ptr = get_system_free_area_ (); on cleanup call clean_up; if wdir_sw | path_count = 0 then do; call process_path (get_wdir_ ()); if path_count < 2 then go to TOTAL; /* no args or -wd by itself */ end; do i = 1 to arg_count; call get_arg (i, arg_ptr, arg_len, code); if index (arg, "-") ^= 1 then do; /* pathname */ call absolute_pathname_ (arg, path, code); if code ^= 0 then do; call complain (code, me, "^a", arg); return; end; star_sw = "0"b; if path ^= ">" then do; call check_star_name_$path (path, code); if code = error_table_$badstar then do; call complain (code, me, "^a", path); return; end; star_sw = (code ^= 0); end; if ^star_sw then call process_path (path); else do; /* starname */ if af_sw then do; call complain (error_table_$nostars, me, "^a", path); return; end; call expand_pathname_ (path, dn, en, code); if code ^= 0 then do; /* absolute_pathname_ probably caught this */ call complain (code, me, "^a", path); return; end; if dir_quota_sw then call hcs_$dir_quota_read (dn, quota_value, trp, time_updated, sons_lvid, terminal_quota, records_used, code); else call hcs_$quota_read (dn, quota_value, trp, time_updated, sons_lvid, terminal_quota, records_used, code); if code ^= 0 then do; call complain (code, me, "^a", dn); return; end; call mdc_$find_lvname (sons_lvid, default_lvname, code); if code ^= 0 then do; call complain (code, me, "^a ^w", dn, sons_lvid); return; end; call hcs_$star_ (dn, en, star_BRANCHES_ONLY, area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then do; call complain (code, me, "^a", pathname_ (dn, en)); return; end; some_matches = "0"b; do j = 1 to star_entry_count; if star_entries (j).type = star_DIRECTORY then do; some_matches = "1"b; call process_path (pathname_ (dn, star_names (star_entries (j).nindex))); end; end; if ^some_matches then call complain (0, me, "No directories match starname ^a", pathname_ (dn, en)); call clean_up_stars; end; end; end; TOTAL: if nonzero_sw & ^some_nonzero then call com_err_ (0, me, "No directories with nonzero quota-used."); else if zero_sw & ^some_zero then call com_err_ (0, me, "No directories with zero quota-used."); if sort_sw then begin; dcl 1 sort_array aligned, 2 n fixed bin (18), 2 eltp (node_count) ptr unaligned; sort_array.n = node_count; i = 0; do p = first_node_ptr repeat (p -> node.next) while (p ^= null); i = i + 1; sort_array.eltp (i) = addr (p -> node.sort_value); end; call sort_items_$fixed_bin (addr (sort_array)); do i = sort_array.n by -1 to 1; p = eltp (i); lvname = p -> node.lvname; trp = p -> node.trp; time_updated = p -> node.time_updated; terminal_quota = p -> node.terminal_quota; quota_value = p -> node.quota_value; records_left = p -> node.records_left; records_used = p -> node.records_used; call print_line (p -> node.path); end; end; if star_sw & ^af_sw & ^print_header_sw & ^long_sw then if (quota_sw | records_used_sw) then call ioa_ ("^/^[^6d^-^;^s^]^[^6d^-^;^s^]^[^-^]^-Total^/", quota_sw, total_quota, records_used_sw, total_records_used, records_left_sw); else call ioa_ (""); return; %page; add_node: proc () returns (ptr); dcl newp ptr; allocate node in (area) set (newp); unspec (newp -> node) = "0"b; newp -> node.next = null; if first_node_ptr = null then first_node_ptr, last_node_ptr = newp; else do; last_node_ptr -> node.next = newp; last_node_ptr = newp; end; node_count = node_count + 1; return (newp); end add_node; %page; clean_up: proc; dcl (nextp, p) ptr; call clean_up_stars; if first_node_ptr ^= null then do p = first_node_ptr repeat (nextp) while (p ^= null); nextp = p -> node.next; free p -> node in (area); end; end clean_up; %page; clean_up_stars: proc; if star_names_ptr ^= null then free star_names in (area); if star_entry_ptr ^= null then free star_entries in (area); star_entry_ptr, star_names_ptr = null; end clean_up_stars; %page; entryname: proc (P_path) returns (char (*)); dcl P_path char (*); dcl (i, j) fixed bin; if P_path = ">" then return (">"); i = index (reverse (P_path), ">"); if i = 0 then return (P_path); j = length (P_path) - i + 2; return (substr (P_path, j)); end entryname; %page; get_records_left: proc (P_path, P_quota_value, P_records_used, P_terminal_quota) returns (fixed bin); /* This procedure calls itself recursively */ dcl P_path char (*); dcl (P_quota_value, P_records_used, P_terminal_quota) fixed bin; dcl (dn, target_dn) char (168); dcl (en, target_en) char (32); dcl (quota_value, records_used, terminal_quota) fixed bin; dcl code fixed bin (35); if P_terminal_quota ^= 0 then return (P_quota_value - P_records_used); else do; call expand_pathname_ (P_path, dn, en, code); call hcs_$get_link_target (dn, en, target_dn, target_en, code); /* if nonlink, target_foo set same as foo */ if code ^= 0 then return (NO_ACCESS); if dir_quota_sw then call hcs_$dir_quota_read (target_dn, quota_value, 0, 0, "0"b, terminal_quota, records_used, code); else call hcs_$quota_read (target_dn, quota_value, 0, 0, "0"b, terminal_quota, records_used, code); if code ^= 0 then return (NO_ACCESS); else return (get_records_left (target_dn, quota_value, records_used, terminal_quota)); end; end get_records_left; %page; print_line: proc (P_path); dcl P_path char (*); if ^long_sw then if ^star_sw & path_count < 2 then call ioa_ ("^[quota = ^d^[; ^]^;^2s^]^[used = ^d^[; ^]^;^2s^]^[remaining = ^[(no access)^;^d^]^]", quota_sw, quota_value, records_left_sw | records_used_sw, records_used_sw, records_used, records_left_sw, records_left_sw, records_left = NO_ACCESS, records_left); else do; /* star case */ if print_header_sw then do; /* print heading first time */ call ioa_ ("^/^[^xquota^-^]^[^2xused^-^]^[^2xremaining^-^]^-directory name^/", quota_sw, records_used_sw, records_left_sw); print_header_sw = "0"b; end; if lvname = default_lvname then lvname_string = ""; else call ioa_$rsnnl ("(^a)", lvname_string, 0, lvname); call ioa_ ("^[^6d^-^;^s^]^[^6d^-^;^s^]^[^[no access^s^;^6d^]^-^;^2s^]^-^a ^a", quota_sw, quota_value, records_used_sw, records_used, records_left_sw, records_left = NO_ACCESS, records_left, entryname (P_path), lvname_string); end; else do; /* -long */ call ioa_ ("^/quota for: ^a^/", P_path); call date_time_$fstime (time_updated, time_string); record_days = (float (trp) + 43200.) / 86400.; call ioa_ ("quota:^28t^d pages ^[(space is charged to superior directory)^]", quota_value, terminal_quota = 0); call ioa_ ("used:^28t^d pages", records_used); call ioa_ ("remaining:^28t^[(no access)^;^d pages^]", records_left = NO_ACCESS, records_left); call ioa_ ("sons volume:^28t^a", lvname); if time_updated ^= 0 then do; call ioa_ ("time-record-product:^28t^.3f record-days", record_days); call ioa_ ("trp last updated:^28t^a", time_string); call user_info_$rs_number (rate_structure_number); disk_rate = 0; call system_info_$prices_rs (rate_structure_number, dummy_rate, dummy_rate, dummy_rate, dummy_rate, disk_rate, dummy_float); if disk_rate > 0 then call ioa_ ("trp price at current rate:^28t$^.2f", trp * disk_rate); call ioa_ (""); end; end; end print_line; %page; process_path: proc (P_path); dcl P_path char (*); if dir_quota_sw then call hcs_$dir_quota_read (P_path, quota_value, trp, time_updated, sons_lvid, terminal_quota, records_used, code); else call hcs_$quota_read (P_path, quota_value, trp, time_updated, sons_lvid, terminal_quota, records_used, code); if code ^= 0 then do; call complain (code, me, "^a", P_path); return; end; if total_sw & terminal_quota ^= 0 then records_used = records_used + subdir_records_used (P_path); if nonzero_sw then if records_used = 0 then return; else some_nonzero = "1"b; else if zero_sw then if records_used ^= 0 then return; else some_zero = "1"b; call mdc_$find_lvname (sons_lvid, lvname, code); if code ^= 0 then call complain (code, me, "^a ^w", P_path, sons_lvid); total_quota = total_quota + quota_value; total_records_used = total_records_used + records_used; if records_left_sw then records_left = get_records_left (P_path, quota_value, records_used, terminal_quota); if af_sw then do; call ioa_$rsnnl ("^[^d^;^s^]^[^d^;^s^]^[^d^]", return_arg, return_len, quota_sw, quota_value, records_left_sw, records_left, records_used_sw, records_used); return; end; if ^sort_sw then call print_line (P_path); else do; /* -sort: save data for sorting */ p = add_node (); p -> node.path = P_path; p -> node.lvname = lvname; p -> node.trp = trp; p -> node.time_updated = time_updated; p -> node.terminal_quota = terminal_quota; p -> node.quota_value = quota_value; p -> node.records_left = records_left; p -> node.records_used = records_used; if sort_by = QUOTA then p -> node.sort_value = quota_value; else if sort_by = RECORDS_LEFT then p -> node.sort_value = records_left; else p -> node.sort_value = records_used; end; end process_path; %page; subdir_records_used: proc (P_dn) returns (fixed bin); dcl P_dn char (*); dcl path char (168); dcl (eptr, nptr) ptr; dcl (ecount, j, lcount, records_used, terminal_quota, total_ru) fixed bin; dcl code fixed bin (35); eptr, nptr = null; on cleanup call local_cleanup; total_ru = 0; call hcs_$star_dir_list_ (P_dn, "**", star_BRANCHES_ONLY, area_ptr, ecount, lcount, eptr, nptr, code); if code = 0 & ecount > 0 then do; star_branch_count = ecount; /* to satisfy the structure declarations */ star_link_count = lcount; star_select_sw = star_BRANCHES_ONLY; do j = 1 to ecount; if eptr -> star_dir_list_branch (j).type = star_DIRECTORY then do; path = pathname_ (P_dn, (nptr -> star_list_names (eptr -> star_dir_list_branch (j).nindex))); if eptr -> star_dir_list_branch (j).master_dir then call complain (0, me, "^a is a master directory; its quota will not be included in the total.", path); else do; if dir_quota_sw then call hcs_$dir_quota_read (path, 0, 0, 0, "0"b, terminal_quota, records_used, code); else call hcs_$quota_read (path, 0, 0, 0, "0"b, terminal_quota, records_used, code); if code ^= 0 then call complain (code, me, "^a^/Directory's quota will not be included in the total.", path); else if terminal_quota ^= 0 then total_ru = total_ru + records_used + subdir_records_used (path); end; end; end; call local_cleanup; end; else if code ^= 0 & code ^= error_table_$nomatch then call complain (code, me, "^a", P_dn); return(total_ru); local_cleanup: proc; star_list_branch_ptr = eptr; /* to make the declaration happy */ if nptr ^= null then free nptr -> star_list_names in (area); if eptr ^= null then free eptr -> star_dir_list_branch in (area); end local_cleanup; end subdir_records_used; %page; %include star_structures; end move_quota;  nd_handler_.pl1 10/06/92 0059.9r w 10/06/92 0057.3 136305 /****^ ************************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1992 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * ************************************************************** */ /****^ HISTORY COMMENTS: 1) change(92-09-24,Vu), approve(92-09-24,MCR8266), audit(92-09-24,Zimmerman), install(92-10-06,MR12.5-1025): Fix bug for add_name when adding a name to a forum meeting which is the only remaining name of another forum. END HISTORY COMMENTS */ /* format: style2 */ nd_handler_: proc (caller, pname, ename, code); /* this is an updated version of the name_dup handler for SSS commands. It attempts to remove an existing entry name from a directory, asking questions of the console as necessary. */ /* initial coding 8 Aug 1969 David Clark */ /* revised 25 Aug 1969 DDC */ /* modified on October 30, 1969 at 11:50 A. M. by V Voydock */ /* modified by E Stone on Dec 3 1970 */ /* modified by Dan Bricklin 9 Dec 1970 */ /* Modified by Dennis Capps on 11/04/71 */ /* Modified by Steve Herbst 4/15/76 */ /* Modified by C. D. Tavares 06/22/77 for force and del_force entries */ /* Changed to print link targets 11/02/79 S. Herbst */ /* Made to work on mailboxes and queues 03/28/80 S. Herbst */ /* 09/29/81 by Lindsey Spratt:Changed to return actual error code when unexpected error occurs. Also, changed to ignore error_table_$vtoce_connection_fail from status_long. */ /* New message added "(Target PATH is a null link)" instead of "exists" 07/01/82 S. Herbst */ /* changed for object_type_, added switches entry 2/17/83 Jay Pattin */ /* removed check for connection failure, hardcore does not return entry information in this case. 6/10/83 Jay Pattin */ /* 830924 object_type_ --> fs_util_ BIM */ dcl (caller, pname, ename) char (*), options bit (36) aligned, code fixed bin (35); /* Link messages */ dcl TARGET_NULL_LINK char (64) int static options (constant) init ("^/^8x(Target ^a^[>^]^a is a null link.)"); dcl TARGET_EXISTS char (64) int static options (constant) init ("^/^8x(Target ^a^[>^]^a exists.)"); dcl TARGET_NOT_EXISTS char (64) int static options (constant) init ("^/^8x(Target ^a^[>^]^a does not exist.)"); dcl TARGET_NO_INFO char (64) int static options (constant) init ("^/^8x(Cannot get info for target ^a^[>^]^a)"); dcl TARGET_NO_PATH char (64) int static options (constant) init ("^/^8x(No target pathname.)"); dcl LINK_TYPE fixed bin (2) int static options (constant) init (0); dcl icode fixed bin (35), type fixed bin, minf_type fixed bin (2), bit fixed bin (24); dcl (link_msg, query_msg) char (256); dcl buff char (132) varying; dcl fs_util_type char (32); dcl target_path char (target_len) based (target_ptr); dcl target_ptr ptr init (null); dcl target_len fixed bin; dcl target_dn char (168); dcl target_en char (32); dcl noun char (18) aligned; dcl verb char (6) aligned; dcl ( LINK init (0), SEGMENT init (1) ) fixed bin int static options (constant); %page; %include nd_handler_options; %page; %include delete_options; %page; %include query_info; %page; %include branch_status; dcl 1 link_status aligned based (addr (branch_status)), ( 2 type bit (2), 2 nnames fixed bin (15), 2 nrp bit (18), 2 dtem bit (36), 2 dtd bit (36), 2 pnl fixed bin (17), 2 pnrp bit (18) ) unaligned; dcl names (2) char (32) aligned based (np), np pointer init (null), old_seg char (32) aligned; dcl area_ptr ptr int static init (null); dcl area area based (area_ptr); dcl error_table_$action_not_performed fixed bin (35) ext; dcl error_table_$improper_data_format fixed bin (35) ext; dcl error_table_$namedup fixed bin (35) ext; dcl error_table_$noentry fixed bin (35) ext; dcl error_table_$nonamerr fixed bin (35) ext; dcl (com_err_, command_query_) entry options (variable), delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35)), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), get_system_free_area_ entry returns (ptr), hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)), hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35)), hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)), hcs_$status_long entry (char (*), char (*), fixed bin, ptr, ptr, fixed bin (35)), installation_tools_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)), fs_util_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl fs_util_$get_type entry (character (*), character (*), character (*), fixed binary (35)); dcl (addr, fixed, null, ptr, rtrim, string, substr, unspec) builtin; dcl cleanup condition; %page; string (nd_handler_options) = ""b; goto COMMON; force: entry (caller, pname, ename, code); /* nd_handler_$force is used to forcibly delete conflicting seg if necessary */ string (nd_handler_options) = ""b; nd_handler_options.delete_force = "1"b; goto COMMON; switches: entry (caller, pname, ename, options, code); string (nd_handler_options) = options; if nd_handler_options.mbz ^= ""b then do; code = error_table_$improper_data_format; return; end; if nd_handler_options.delete | nd_handler_options.delete_force then goto COMMON2; nd_handler_options.delete_force = nd_handler_options.force; COMMON: code, icode = 0; if area_ptr = null then area_ptr = get_system_free_area_ (); on cleanup call clean_up; call hcs_$status_long (pname, ename, 0, addr (branch_status), area_ptr, code); if code ^= 0 then do; call com_err_ (code, caller, "^/Unable to get status information about ^a^[>^]^a.", pname, pname ^= ">", ename); return; end; code = 0; np = ptr (area_ptr, branch_status.names_rel_pointer); if names (1) = ename then if fixed (branch_status.number_names, 17) = 1 then go to DELETE; else old_seg = names (2); else old_seg = names (1); if nd_handler_options.library then call installation_tools_$chname_file (pname, ename, ename, "", icode); else if nd_handler_options.raw then call hcs_$chname_file (pname, ename, ename, "", icode); else call fs_util_$chname_file (pname, ename, ename, "", icode); /* works even for MSF's ! */ if icode = 0 then do; call com_err_ (0, caller, "Name duplication. Old name ^a removed from ^a>^a", ename, pname, old_seg); return; end; if icode ^= error_table_$nonamerr then do; code = icode; call com_err_ (code, caller, "^/Unable to remove the old name ^a from ^a^[>^]^a.", ename, pname, pname ^= ">", old_seg); return; end; else /* only one name left, delete it */ go to DELETE; del: entry (caller, pname, ename, code); /* This entry used if caller knows deletion is necessary */ string (nd_handler_options) = ""b; goto COMMON2; del_force: entry (caller, pname, ename, code); /* This entry used if caller wants deletion performed forcibly */ string (nd_handler_options) = ""b; nd_handler_options.delete_force = "1"b; COMMON2: code = 0; if area_ptr = null then area_ptr = get_system_free_area_ (); on cleanup call clean_up; call hcs_$status_long (pname, ename, 0, addr (branch_status), area_ptr, code); if code ^= 0 then do; call com_err_ (code, caller, "^/Unable to get status information about ^a^[>^]^a.", pname, pname ^= ">", ename); return; end; code = 0; DELETE: type = fixed (branch_status.type, 17); bit = fixed (branch_status.bit_count, 24); string (delete_options) = ""b; delete_options.force = "1"b; delete_options.raw = nd_handler_options.raw; if type = SEGMENT then do; verb = "delete"; noun = "segment"; delete_options.segment = "1"b; end; else if type = LINK then do; verb = "unlink"; delete_options.link = "1"b; noun = "link"; target_len = link_status.pnl; target_ptr = ptr (area_ptr, link_status.pnrp); if target_path = "" then link_msg = TARGET_NO_PATH; else do; call hcs_$get_link_target (pname, ename, target_dn, target_en, code); if target_dn = "" then call expand_pathname_ (target_path, target_dn, target_en, code); call hcs_$status_minf (target_dn, target_en, 0, minf_type, 0, icode); if icode = 0 then if minf_type = LINK_TYPE then link_msg = TARGET_NULL_LINK; else link_msg = TARGET_EXISTS; else if icode = error_table_$noentry then link_msg = TARGET_NOT_EXISTS; else link_msg = TARGET_NO_INFO; end; end; else do; if bit ^= 0 then do; /* a multi-segment file */ verb = "delete"; noun = "multisegment file"; delete_options.segment = "1"b; end; else do; /* it is a directory */ verb = "delete"; noun = "directory"; call fs_util_$get_type (pname,ename,fs_util_type,code); if code ^= 0 then return; if substr (fs_util_type, 1, 1) ^= "-" then delete_options.segment = "1"b; else delete_options.directory = "1"b; end; end; call clean_up; /* free hcs_$status storage */ if ^nd_handler_options.delete_force then do; unspec (query_info) = "0"b; query_info.version = query_info_version_4; query_info.yes_or_no_sw = "1"b; query_info.question_iocbp, query_info.answer_iocbp = null; query_info.status_code = error_table_$namedup; query_msg = "Name duplication. Do you want to ^a the old ^a ^a>^a?"; if type = LINK then query_msg = rtrim (query_msg) || link_msg; call command_query_ (addr (query_info), buff, caller, rtrim (query_msg) || "^3x", verb, noun, pname, ename, target_dn, target_dn ^= ">", target_en); if buff = "no" then do; code = error_table_$action_not_performed; return; end; end; else do; if type = LINK then call com_err_ (error_table_$namedup, caller, "Unlinking the old link ^a>^a" || link_msg, pname, ename, target_dn, target_dn ^= ">", target_en); else call com_err_ (error_table_$namedup, caller, "Deleting the old ^a ^a>^a", noun, pname, ename); end; /* You really must want to get rid of it ... */ call delete_$path (pname, ename, string (delete_options), caller, code); if code ^= 0 then call com_err_ (code, caller, "^/Unable to remove old entry ^a^[>^]^a.", pname, pname ^= ">", ename); return; clean_up: proc; if np ^= null then free names in (area); if target_ptr ^= null then free target_path in (area); end clean_up; end nd_handler_;  rename.pl1 09/30/88 1303.1rew 09/30/88 1301.8 165933 /****^ ************************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * ************************************************************** */ /****^ HISTORY COMMENTS: 1) change(88-09-20,TLNguyen), approve(88-09-20,MCR7976), audit(88-09-28,Parisek), install(88-09-30,MR12.2-1123): The rename command will print an appropriate error message when it finds that 1. The new name of a specified storage system entry is improperly constructed without specifying the -name control argument. 2. The returned code from XXX_$chname_file is non zero in value, where XXX can be either installation_tool_, hcs_, or fs_util_ END HISTORY COMMENTS */ /* format: style4,ifthenstmt,ifthen,^indcomtxt,^indproc,initcol1,declareind8,dclind4,struclvlind1 */ rename: rn: procedure () options (variable); /* This module implements the rename, add_name and delete_name commands. Usage: rename {-name} path1 {-name} name1 ... {-name} pathj {-name} namej where -name causes the following pathi or namei as a literal name (for pathi, in the working directory) without applying the star or equal conventions. add_name {-name} path {-name} name1 ... {-name} namej delete_name {-name} path1 ... {-name} pathj Written by Steve Herbst 12/09/76 */ /* Cleanup handling and control arg processing fixed 10/25/79 S. Herbst */ /* Made to work on mailboxes and queues 03/28/80 S. Herbst */ /* Bug fixes on 06/30/80 by G. Palter */ /* Fixed to not try to add the same name twice to the same seg 12/09/82 S. Herbst */ /* modified for object_type_ convention 1/26/83 Jay Pattin */ /* fixed -name, added l_rename and friends 2/27/83 Jay Pattin */ /* 830924 object_type_ --> fs_util_ BIM */ /* Modified 2/10/84 by C Spitzer. allow $, disallow ? in added or renamed names */ /* Changed to allow -name before all args of all commands 03/27/84 S. Herbst */ /* Modified 1984.08.27 by M. Pandolf to use pathname_ and report pathname when starname doesn't match */ /* 850206 MSharpe to replace -fcnt with -inase/inaee */ /* Fixed cleanup bug causing null ptr fault for "rn a b x.* y.=" 04/05/85 Steve Herbst */ dcl 1 entries (ecount) aligned based (eptr), /* entry info from hcs_$star_ */ 2 type bit (2) unaligned, 2 nnames fixed bin (15) unaligned, 2 nindex fixed bin (17) unaligned; dcl names (99) char (32) aligned based (nptr); /* names from hcs_$star_ */ dcl 1 added_names aligned based (added_names_ptr), 2 (count, bound) fixed bin, 2 array (added_names_bound refer (added_names.bound)), 3 dn char (168), 3 match fixed bin, /* the number of the starname match from hcs_$star_ */ 3 name char (32); dcl arg char (arg_len) based (arg_ptr); dcl dn char (168); dcl (command, en, name) char (32); dcl (brief_sw, force_no_type, library_sw, literal_source, literal_target, stars) bit (1); dcl area area based (area_ptr); dcl area_ptr ptr int static init (null); dcl (added_names_ptr, eptr, nptr) ptr init (null); dcl arg_ptr ptr; dcl (added_names_bound, arg_count, arg_len, ecount, i, k, match_index) fixed bin; dcl code fixed bin (35); dcl error_table_$bad_equal_name fixed bin (35) ext; dcl error_table_$bad_file_name fixed bin (35) ext; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$entlong fixed bin (35) ext; dcl error_table_$namedup fixed bin (35) ext; dcl error_table_$noarg fixed binary (35) ext; dcl error_table_$nomatch fixed binary (35) ext; dcl error_table_$noentry fixed bin (35) ext; dcl error_table_$nostars fixed bin (35) ext; dcl error_table_$segnamedup fixed bin (35) ext; dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl ( active_fnc_err_, com_err_, com_err_$suppress_name ) entry options (variable); dcl cu_$af_return_arg entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl installation_tools_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl nd_handler_$switches entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35)); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl fs_util_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl (index, length, null, string) builtin; dcl (cleanup, linkage_error) condition; %page; command = "rename"; library_sw = "0"b; goto RENAME_COMMON; l_rename: lrename: lren: entry; library_sw = "1"b; command = "l_rename"; RENAME_COMMON: call cu_$af_return_arg (arg_count, (null ()), (0), code); if code = 0 then do; NOT_ACT_FNC: call active_fnc_err_ (0, command, "This command cannot be invoked as an active function."); return; end; if arg_count < 2 then do; call com_err_$suppress_name (0, "rename", "Usage: ^a path1 name1 ... pathj namej {-control_args}", command); RETURN: return; end; force_no_type = "0"b; do i = 1 to arg_count; /* prescan for bad control arguments */ call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); if index (arg, "-") = 1 then if (arg = "-name") | (arg = "-nm") then do; i = i + 1; if i > arg_count then do; NO_NAME_VALUE: call com_err_ (error_table_$noarg, command, "Value for -name"); return; end; end; else if ^library_sw & (arg = "-interpret_as_standard_entry" | arg = "-inase") then force_no_type = "1"b; else if (arg = "-interpret_as_extended_entry" | arg = "-inaee") then force_no_type = "0"b; else do; call com_err_ (error_table_$badopt, command, """^a""", arg); return; end; end; on cleanup call clean_up; call allocate_added_names; do i = 1 by 2 to arg_count; NEXT_ARG: call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); if arg = "-interpret_as_standard_entry" | arg = "-inase" | arg = "-interpret_as_extended_entry" | arg = "-inaee" then do; i = i + 1; if i > arg_count then return; goto NEXT_ARG; end; if arg = "-name" | arg = "-nm" then do; literal_source = "1"b; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); end; else literal_source = "0"b; call get_path; if code ^= 0 then if code = error_table_$nomatch then call com_err_ (code, command, "For ^a.", pathname_ (dn, en)); else call com_err_ (code, command, "^a", arg); else do; if (i + 1) > arg_count then do; call com_err_ (error_table_$noarg, command, "New name for ^a.", pathname_ (dn, en)); return; end; call cu_$arg_ptr (i + 1, arg_ptr, arg_len, (0)); if arg = "-name" | arg = "-nm" then do; literal_target = "1"b; i = i + 1; call cu_$arg_ptr (i + 1, arg_ptr, arg_len, (0)); end; else literal_target = "0"b; call get_name; if code ^= 0 then call com_err_ (code, command, "^a", arg); else call change_names (en, name); end; call clean_up_stars (); end; return; %page; add_name: addname: an: entry () options (variable); command = "add_name"; library_sw = "0"b; goto ADDNAME_COMMON; l_add_name: laddname: lan: entry; command = "l_add_name"; library_sw = "1"b; ADDNAME_COMMON: call cu_$af_return_arg (arg_count, (null ()), (0), code); if code = 0 then go to NOT_ACT_FNC; if arg_count < 2 then do; ADD_NAME_USAGE: call com_err_$suppress_name (0, "", "Usage: ^a path names {-control_args}", command); return; end; brief_sw, force_no_type = "0"b; do i = 1 to arg_count; /* prescan for control arguments */ call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); if index (arg, "-") = 1 then do; if arg = "-brief" | arg = "-bf" then brief_sw = "1"b; else if arg = "-long" | arg = "-lg" then brief_sw = "0"b; else if arg = "-name" | arg = "-nm" then do; i = i + 1; if i > arg_count then go to NO_NAME_VALUE; end; else if ^library_sw & (arg = "-interpret_as_standard_entry" | arg = "-inase") then force_no_type = "1"b; else if arg = "-interpret_as_extended_entry" | arg = "-inaee" then force_no_type = "0"b; else do; call com_err_ (error_table_$badopt, command, "^a", arg); return; end; end; end; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); if index (arg, "-") ^= 1 then do; literal_source = "0"b; go to FOUND_NAME; end; else if arg = "-name" | arg = "-nm" then do; literal_source = "1"b; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); go to FOUND_NAME; end; end; go to ADD_NAME_USAGE; FOUND_NAME: on cleanup call clean_up; call get_path; if code ^= 0 then do; call com_err_ (code, command, "^a", arg); return; end; if i = arg_count then go to ADD_NAME_USAGE; /* no names to be added */ call allocate_added_names; do i = i + 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); if index (arg, "-") ^= 1 then do; literal_target = "0"b; ADD_THE_NAME: call get_name; if code ^= 0 then call com_err_ (code, command, "^a", arg); else call change_names ("", name); end; else if arg = "-name" | arg = "-nm" then do; literal_target = "1"b; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); go to ADD_THE_NAME; end; end; call clean_up; return; %page; delete_name: deletename: dn: entry () options (variable); command = "delete_name"; library_sw = "0"b; goto DELETE_NAME_COMMON; l_delete_name: ldeletename: ldn: entry; command = "l_delete_name"; library_sw = "1"b; DELETE_NAME_COMMON: call cu_$af_return_arg (arg_count, (null ()), (0), code); if code = 0 then go to NOT_ACT_FNC; if arg_count = 0 then do; call com_err_$suppress_name (0, "", "Usage: ^a paths {-control_args}", command); return; end; brief_sw, force_no_type = "0"b; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); if index (arg, "-") = 1 then do; if arg = "-name" | arg = "-nm" then do; i = i + 1; /* skip arg following -name */ if i > arg_count then go to NO_NAME_VALUE; end; else if arg = "-brief" | arg = "-bf" then brief_sw = "1"b; else if arg = "-long" | arg = "-lg" then brief_sw = "0"b; else if ^library_sw & (arg = "-interpret_as_standard_entry" | arg = "-inase") then force_no_type = "1"b; else if arg = "-interpret_as_extended_entry" | arg = "-inaee" then force_no_type = "0"b; else do; call com_err_ (error_table_$badopt, command, "^a", arg); return; end; end; end; on cleanup call clean_up; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); if index (arg, "-") ^= 1 then do; literal_source = "0"b; DELETE_THE_NAME: call get_path; if code ^= 0 then do; if ^brief_sw | code ^= error_table_$nomatch then call com_err_ (code, command, "^a", arg); end; else call change_names (en, ""); call clean_up_stars (); end; else if arg = "-name" | arg = "-nm" then do; literal_source = "1"b; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); go to DELETE_THE_NAME; end; end; return; %page; get_path: procedure (); /* This internal procedure expands a pathname argument and applies the star convention. */ code = 0; if index (arg, "-") = 1 & ^literal_source then do; call com_err_ (error_table_$badopt, command, "^a", arg); go to RETURN; end; call expand_pathname_ (arg, dn, en, code); if code ^= 0 then return; if literal_source then do; stars = "0"b; return; end; if en ^= "" then call check_star_name_$entry (en, code); if code = 0 then stars = "0"b; else if code < 3 then do; /* star convention */ stars = "1"b; if area_ptr = null then area_ptr = get_system_free_area_ (); call hcs_$star_ (dn, en, 3, area_ptr, ecount, eptr, nptr, code); end; end get_path; %page; get_name: procedure (); /* This internal procedure checks for a valid entryname and applies the equal convention. */ dcl type fixed bin (2); dcl check_star_name_ entry (char (*), bit (36) aligned, fixed bin (2), fixed bin (35)); code = 0; type = 0; if arg_len > length (name) then do; code = error_table_$entlong; return; end; name = arg; if literal_target then return; if index (arg, "-") = 1 then do; call com_err_ (error_table_$badopt, command, "^a", arg); go to RETURN; end; call check_star_name_ (arg, (CHECK_STAR_IGNORE_EQUAL), type, code); if code ^= 0 then do; call com_err_ (code, command, "^a", arg); goto RETURN; end; if type ^= 0 then do; call com_err_ (error_table_$nostars, command, "^a", arg); goto RETURN; end; call get_equal_name_ ("a.a.a.a.a.a.a.a.a.a.a.a.a.a.a.a", arg, "", code); /* see if valid equal name */ if code ^= error_table_$bad_equal_name then code = 0; /* might be valid */ /* This call tests for syntax errors in the equal name, for example "a.===.b". It is a preliminary test before we know which entry names match the starname en. Therefore, the equal name is applied to a dummy containing the maximum number of components (16) rather than the starname, which can have too few components even though some matching entry names have enough components. */ end get_name; %page; change_names: procedure (P_old_name, P_equal_name); /* This internal procedure calls its internal procedure change_name for each starname match. */ dcl (P_old_name, P_equal_name) char (*); dcl new_name char (32); if ^stars then call change_name; else do match_index = 1 to ecount; do k = entries (match_index).nindex to entries (match_index).nindex + entries (match_index).nnames - 1; en = names (k); call change_name; end; NEXT_STAR: end; %page; change_name: procedure (); /* This internal procedure performs the name change for all three commands. */ dcl i fixed bin; if command = "delete_name" | command = "l_delete_name" then new_name = ""; else do; if literal_target then new_name = P_equal_name; /* if -name given, don't apply equals convention */ else do; call get_equal_name_ (en, P_equal_name, new_name, code); if code ^= 0 then do; call com_err_ (code, command, "^a for ^a", P_equal_name, en); return; end; end; if stars then do; do i = added_names.count by -1 to 1 while (dn ^= added_names.dn (i) | match_index ^= added_names.match (i) | new_name ^= added_names.name (i)); end; if i > 0 then /* already added this name to this segment */ if command = "add_name" | command = "l_add_name" then return; else new_name = ""; /* rename: just delete the name to rename */ added_names.count = added_names.count + 1; if added_names.count > added_names.bound then call grow_added_names; added_names.dn (added_names.count) = dn; added_names.match (added_names.count) = match_index; added_names.name (added_names.count) = new_name; end; end; TRY: if library_sw then do; on linkage_error begin; call com_err_ (0, command, "The user lacks access to installation_tools_."); goto RETURN; end; call installation_tools_$chname_file (dn, en, P_old_name, new_name, code); revert linkage_error; end; else if force_no_type then call hcs_$chname_file (dn, en, P_old_name, new_name, code); else call fs_util_$chname_file (dn, en, P_old_name, new_name, code); if code ^= 0 then do; if code = error_table_$namedup then do; string (nd_handler_options) = ""b; nd_handler_options.raw = force_no_type; nd_handler_options.library = library_sw; call nd_handler_$switches (command, dn, new_name, string (nd_handler_options), code); if code = 0 then go to TRY; end; else if code = error_table_$segnamedup then if brief_sw & command = "add_name" then; /* "an -bf" suppresses this message */ else call com_err_ (code, command, "^a on ^a.", new_name, pathname_ (dn, en)); else if code = error_table_$noentry & (command = "delete_name" | command = "l_delete_name") & brief_sw then return; else if code = error_table_$bad_file_name then call com_err_ (code, command, "^a", new_name); else do; call com_err_ (code, command, "^a", pathname_ (dn, en)); if command = "add_name" | command = "l_add_name" then if stars then go to NEXT_STAR; else go to RETURN; end; end; end change_name; end change_names; %page; allocate_added_names: proc; area_ptr = get_system_free_area_ (); added_names_bound = 50; allocate added_names in (area) set (added_names_ptr); added_names.count = 0; end allocate_added_names; %page; grow_added_names: proc; dcl old_ptr ptr; dcl i fixed bin; old_ptr = added_names_ptr; added_names_bound = 2 * added_names_bound; allocate added_names in (area) set (added_names_ptr); added_names.count = old_ptr -> added_names.count; do i = 1 to added_names.count; added_names.array (i) = old_ptr -> added_names.array (i); end; free old_ptr -> added_names in (area); end grow_added_names; %page; clean_up: proc; if eptr ^= null then free entries in (area); if nptr ^= null then free names in (area); if added_names_ptr ^= null then free added_names in (area); end clean_up; %page; clean_up_stars: proc; if eptr ^= null then free entries in (area); if nptr ^= null then free names in (area); end clean_up_stars; %page; %include check_star_name; %page; %include nd_handler_options; end rename;  set_bit_count.pl1 10/25/83 1546.8r w 10/25/83 1444.6 44415 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * ************************************************************** */ /* format: style2,idind30,indcomtxt */ set_bit_count: sbc: procedure options (variable); /* procedure to set the bit count on segments */ /* coded by M. Weaver on 28 November 1969 11:00 A.M. */ /* modified by M. Weaver 22 January 1970 */ /* modified to reject too large bit count 9/15/76 S. Herbst */ /* Modified 2/20/83 Jay Pattin for object_type_ */ /* 830924 BIM for fs_util_ */ dcl dirname char (168); dcl arg char (argl) based (argp) unaligned; dcl ename char (32); dcl bitcnt fixed bin (24); dcl bc_35 fixed bin (35); dcl argl fixed bin (21); dcl i fixed bin; dcl argp ptr; dcl arg_count fixed bin; dcl ( code, error_table_$noarg ext ) fixed bin (35); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl err_name char (16) static init ("set_bit_count") options (constant); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl fs_util_$set_bit_count entry (char (*), char (*), fixed bin (24), fixed bin (35)); dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl error_table_$nostars fixed bin (35) ext static; dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl mod builtin; call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, err_name); return; end; if arg_count = 0 | mod (arg_count, 2) ^= 0 then do; call com_err_ (0, err_name, "Usage: set_bit_count path1 bit_count1 ... pathN bit_countN"); return; end; do i = 1 by 2 to arg_count; call cu_$arg_ptr (i, argp, argl, (0)); call expand_pathname_ (arg, dirname, ename, code); if code ^= 0 then do; call com_err_ (code, err_name, "^a", arg); return; end; call check_star_name_$entry (ename, code); if code = 1 | code = 2 then code = error_table_$nostars; if code ^= 0 then do; call com_err_ (code, err_name, "^a.", arg); return; end; call cu_$arg_ptr (i + 1, argp, argl, (0)); if argl = 0 then do; call com_err_ (0, err_name, "Null argument supplied as bit count for ^a.", pathname_ (dirname, ename)); return; end; bc_35 = cv_dec_check_ (arg, code); if code ^= 0 then do; call com_err_ (0, err_name, "Illegal decimal digits in bit count ^a for ^a", arg, pathname_ (dirname, ename)); return; end; if bc_35 > 2 ** 24 - 1 then do; call com_err_ (0, err_name, "Bit count ^d is larger than the maximum 2**24-1.", bc_35); return; end; else bitcnt = bc_35; call fs_util_$set_bit_count (dirname, ename, bitcnt, code); if code ^= 0 then do; call com_err_ (code, err_name, "^a", pathname_ (dirname, ename)); return; end; end; return; end set_bit_count;  status.pl1 05/10/89 0951.8rew 05/10/89 0947.5 791460 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-02-17,TLNguyen), approve(87-02-17,MCR7622), audit(87-02-25,Gilcrease), install(87-03-23,MR12.1-1008): - Make "status" active function returns the current length when the "-length" control argument is specified. - Add the "-nonstandard_names" (-nsn) control argument to the status command or active function. 2) change(87-02-24,TLNguyen), approve(87-02-24,MCR7620), audit(87-02-25,Gilcrease), install(87-03-23,MR12.1-1008): - Change "status" command to always display an appropriate error message if "-chase" control argument is specified and the entry is a null link. - Change "status" command to always skip printing an error message if the code received from "file_manager_$status" is "A transaction is currently in progress." - Change "status" to always display an error message if specified paths are directories, MSFs, DM files, and links and the "-synchronized_ switch" is specified. - Change "status" to always call "msf_manager_$close" when it finishes for an MSF and to always call "cleanup" internal procedure when it finishes. - Change "status" to always not display a specified MSF's contents which appeared at the end of the error message. 3) change(87-03-25,TLNguyen), approve(87-03-25,MCR7620), audit(87-03-25,Gilcrease), install(87-03-25,MR12.1-1015): PBF to last installation, status with no arguments ok now. 4) change(87-09-04,TLNguyen), approve(87-09-04,PBF7620), audit(87-09-04,Farley), install(87-09-09,MR12.1-1099): status with MSFs and -all control argument work ok now. 5) change(88-01-29,TLNguyen), approve(88-01-29,MCR7833), audit(88-02-02,Lippard), install(88-02-02,MR12.2-1020): Make status with -length work as documented when it is used as a command. 6) change(88-05-12,Lippard), approve(88-05-02,MCR7881), audit(88-06-09,Fawcett), install(88-08-02,MR12.2-1074): Add -audit_switch, -asw. 7) change(89-04-06,Vu), approve(89-04-06,MCR8096), audit(89-04-26,Lee), install(89-05-10,MR12.3-1040): status -switch SW_NAME yields bogus error for link and the date returned by status for the root does not use the user's default date/time format. Reformatted status.pl1 END HISTORY COMMENTS */ /* format: style4,ifthenstmt,^indproc */ status: st: procedure options (variable); /* WARNING: Some hcs_ entries are mis-declared with char (*) aligned */ /* This command and active function returns selected attributes of storage system entries. */ /* Written 5/20/76 by Steve Herbst */ /* Control args -dr, -lk, -sm added and [st -nm] names quoted 09/28/79 S. Herbst */ /* Changed to print damaged switch (if on) by default 03/19/80 S. Herbst */ /* Fix dates reported for MSF's (most recent date of all components) 01/06/81 S. Herbst */ /* Chasing fixed, -chase_if_possible added, -records_used -> -records 01/12/81 S. Herbst */ /* Fixed bug in MSF processing 10/01/81 S. Herbst */ /* fixed not to assume 168 char link pathname BIM 3/82 */ /* Added printing of synchronized switch, J. Bongiovanni, September 1982 */ /* Fixed to handle et_$vtoce_connection_fail like et_$logical_volume_not_connected 11/23/82 S. Herbst */ /* Changed back again to treat VTOCE errors as errors, since no info can be trusted. 12/07/82 S. Herbst */ /* Simple support for object_type_ 2/24/83 Jay Pattin */ /* Added entry_bound, -switch, changed behavior of -all w/switches 6/2/83 Jay Pattin */ /* 830924 object_type_ --> fs_util_, BIM */ /* Modified 11/21/83 by C Spitzer. fix lots of bugs */ /* Fixed to not free switch_list when switch_list_ptr is null, 1984.02.16, MAP */ /* Modified 07/18/84 by Jim Lippard to only allocate names when they're asked for and to free them properly */ /* Modified 84-09-17 by JAFalksen. Utilize date_time_$format("date_time",... */ /* Modified 01/11/84 by C Spitzer. work on root (changes adapted by Steve Herbst) */ /* Changed to work on DM files 10/23/84 Steve Herbst */ /* Added extended entry type control args -select_entry_type, changed -force_no_type to -inase 11/20/84 M. Pandolf */ /* Changed -no_(concurrency rollback)_sw to -(concurrency rollback)_sw 12/04/84 Steve Herbst */ /* Fixed mode value for DM files 01/11/85 Steve Herbst */ /* Modified 02/05/85 by M. Sharpe to implement -slet correctly and to complain about unsupported operation when type does not have ring brackets, extended mode, max length, etc. */ /* Fixed to print DM file switches without a transaction in effect 02/26/85 Steve Herbst */ /* DECLARATIONS */ /* Options structure. Various settings for it are at the back of the listing. */ dcl 1 opt, /* attributes to be requested */ (2 primary_name, /* -primary, -pri */ 2 names, /* -name, -names, -nm */ 2 type, /* -type, -tp */ 2 link_path, /* -link_path, -lp */ 2 unique_id, /* -unique_id, -uid */ 2 dtu, /* -date_time_used, -dtu */ 2 dtcm, /* -date_time_contents_modified, -dtcm */ 2 dtem, /* -date_time_entry_modified, -dtem */ 2 dtd, /* -date_time_dumped, -dtd */ 2 dtvd, /* -date_time_volume_dumped, -dtvd */ 2 author, /* -author, -at */ 2 bc_author, /* -bc_author, -bca */ 2 logical_volume, /* -logical_volume, -lv, -device, -dv */ 2 bit_count, /* -bit_count, -bc */ 2 records_used, /* -records, -rec */ 2 current_length, /* -current_length, -cl */ 2 max_length, /* -max_length, -ml */ 2 mode, /* -mode, -md */ 2 access_class, /* -access_class, -acc */ 2 ring_brackets, /* -ring_brackets, -rb */ 2 safety_switch, /* -safety_switch, -ssw */ 2 copy_switch, /* -copy_switch, -csw */ 2 audit_switch, /* -audit_switch, -asw */ 2 ivds, /* -incr_volume_dump_switch, -ivds */ 2 cvds, /* -comp_volume_dump_switch , -cvds */ 2 usage_count, /* -usage_count, -use */ 2 damaged_switch, /* -damaged_switch, -dsw */ 2 synchronized_switch, /* -synchronized_switch, -synch */ 2 entry_bound /* -entry_bound, -eb */ ) bit (1) unaligned, 2 dm_files_only, (3 highest_ci, /* -highest_control_interval, -hci */ 3 concurrency_switch, /* -concurrency_sw, -concsw */ 3 rollback_switch, /* -rollback_sw, -rlbsw */ 3 protected_switch /* -protected_sw, -psw */ ) bit (1) unaligned; dcl 1 explicit_opt like opt; /* attributes explicitly requested */ dcl 1 saved_options like opt; /* saved copy of opt */ dcl ALL_OPTIONS bit (33) aligned int static options (constant) init ((33)"1"b); /* for -all */ dcl LONG_OPTION (33) char (64) int static options (constant) init ("-primary", "-name", "-type", "-link_path", "-unique_id", "-date_time_used", "-date_time_contents_modified", "-date_time_entry_modified", "-date_time_dumped", "-date_time_volume_dumped", "-author", "-bc_author", "-logical_volume", "-bit_count", "-records", "-current_length", "-max_length", "-mode", "-access_class", "-ring_brackets", "-safety_switch", "-copy_switch", "-audit_switch", "-incr_volume_dump_switch", "-comp_volume_dump_switch", "-usage_count", "-damaged_switch", "-synchronized_switch", "-entry_bound", /* (DM file options:) */ "-highest_control_interval", "-concurrency_sw", "-rollback_sw", "-protected_sw"); dcl SHORT_OPTION (33) char (8) int static options (constant) init ("-pri", "-nm", "-tp", "-lp", "-uid", "-dtu", "-dtcm", "-dtem", "-dtd", "-dtvd", "-at", "-bca", "-lv", "-bc", "-rec", "-cl", "-ml", "-md", "-acc", "-rb", "-ssw", "-csw", "-asw", "-ivds", "-cvds", "-use", "-dsw", "-synch", "-eb", "-hci", "-concsw", "-rlbsw", "-psw"); dcl 1 bks aligned like status_for_backup; dcl 1 link_status aligned based (addr (branch_status)), /* status for link entries */ 2 type bit (2) unaligned, 2 nnames bit (16) unaligned, 2 nrp bit (18) unaligned, 2 dtlm bit (36) unaligned, 2 dtd bit (36) unaligned, 2 pnl fixed bin (18) uns unaligned, 2 pnrp bit (18) unaligned; dcl 1 msf_info aligned, /* status for MSF components */ 2 type bit (2) unaligned, 2 nnames bit (16) unaligned, 2 names_offset bit (18) unaligned, 2 dtcm bit (36) unaligned, 2 dtu bit (36) unaligned, 2 mode bit (5) unaligned, 2 pad bit (13) unaligned, 2 records fixed bin (17) unaligned, 2 dtd bit (36) unaligned, 2 dtem bit (36) unaligned, 2 pad3 bit (36) unaligned, 2 current_length fixed bin (11) unaligned, 2 bit_count bit (24) unaligned, 2 pad2 bit (18) unaligned, 2 rbs (0:2) fixed bin (5) unaligned, 2 pad4 bit (36) unaligned; dcl branch_names (0:99) char (32) based (branch_names_ptr);/* names from hcs_$status_long */ dcl ROOT_NAMES (1) char (32) int static options (constant) init (">"); dcl 1 si aligned like suffix_info; dcl 1 auto_dm_file_status aligned like dm_file_status; dcl 1 path_array (path_array_size) aligned based (path_array_ptr), 2 path_ptr ptr, 2 path_len fixed bin, 2 nonstandard_names_flag bit (1) aligned; dcl 1 slet_path_array (slet_path_array_size) aligned based (slet_path_array_ptr) like path_array; dcl 1 path_array_space (25) like path_array; dcl dates_array (5) bit (36); dcl 1 combined_options, (2 access, /* -access */ 2 all, /* -all */ 2 dates, /* -date */ 2 lengths /* -length */ ) bit (1) unaligned; dcl 1 fs_entry_type aligned based (fs_entry_type_ptr), 2 count fixed bin, 2 suffix char (32) unaligned dim (fs_entry_type_count refer (fs_entry_type.count)); dcl 1 fs_time_value aligned based, 2 pad1 bit (20) unal, 2 time bit (36) unal, 2 pad2 bit (16) unal; dcl temp_clock fixed bin (71); dcl stime bit (36); dcl switch_names (10) char (32); /* for -switch */ dcl mode_bits (5) bit (1) unaligned; dcl ring_brackets (8) fixed bin (3); /* Constants */ dcl ME char (32) int static options (constant) init ("status"); dcl INITIALIZER_ID char (32) int static options (constant) init ("Initializer.SysDaemon.z"); dcl EXTENDED_type fixed bin int static options (constant) init (5); dcl (CHASE init (1), NO_CHASE init (0)) fixed bin int static options (constant); /* Based */ dcl area area based (area_ptr); dcl arg char (arg_len) based (arg_ptr); dcl return_string char (return_len) varying based (return_ptr); dcl slet_path char (slet_path_len) based (slet_path_ptr); dcl target_path char (target_len) based (target_ptr); /* Automatic */ dcl slet_area area; dcl date_string char (64) varying; dcl mode_string char (36) varying; dcl (class, temp_string) char (336); /* ASCII access class */ dcl (dn, msf_path, saved_dn, target_dn) char (168); dcl (author_string, bc_author_string, comp_name, en, fs_type, fs_util_type) char (32); dcl (lv_string, saved_en, star_en, target_en) char (32); dcl type_string char (32); /* avoid string size condition while compiling. */ dcl access_class bit (72) aligned; dcl (exmodes, local_unique_id, modes) bit (36) aligned; dcl (bc36, msf_dtcm, msf_dtd, msf_dtem, msf_dtu) bit (36); dcl switch_mask bit (10) aligned; dcl (active_function, chase, chase_if_possible, chased, dir_sw, dm_file_sw, interpret_as_standard_entry) bit (1) aligned; dcl (link_sw, matched, msf, msf_error, one_item, printed_pathname, printed_something) bit (1) aligned; dcl (root_sw, safety_switch, seg_sw, selecting_by_entry_type, star_sw) bit (1) aligned; dcl (area_ptr, arg_ptr, branch_names_ptr, comp_ptr, fs_entry_type_ptr, msf_ptr) ptr; dcl (path_array_ptr, return_ptr, slet_path_array_ptr, slet_path_ptr, target_ptr) ptr; dcl status_chase fixed bin (1); dcl entry_type fixed bin (3); dcl (arg_count, arg_len, class_len, cvds, entry_type_index, extended_type_count, fs_entry_type_count, i, ivds) fixed bin; dcl (j, k, kk, path_array_size, path_count, return_len, slet_path_array_size, slet_path_len) fixed bin; dcl (switch_count, switch_length, target_len, total_length, total_records) fixed bin; dcl max_length fixed bin (19); dcl total_bit_count fixed bin (24); dcl (bc35, code, usage_count) fixed bin (35); /* External */ dcl dm_error_$transaction_in_progress fixed bin (35) ext; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$inconsistent fixed bin (35) ext; dcl error_table_$incorrect_access fixed bin (35) ext; dcl error_table_$logical_volume_not_connected fixed bin (35) ext; dcl error_table_$logical_volume_not_defined fixed bin (35) ext; dcl error_table_$moderr fixed bin (35) ext; dcl error_table_$no_s_permission fixed bin (35) ext; dcl error_table_$noarg fixed bin (35) ext; dcl error_table_$noentry fixed bin (35) ext; dcl error_table_$nomatch fixed bin (35) ext; dcl error_table_$not_act_fnc fixed bin (35) ext; dcl error_table_$root fixed bin (35) ext; dcl error_table_$segknown fixed bin (35) ext; dcl error_table_$unsupported_operation fixed bin (35) ext; /* Entries */ dcl complain entry variable options (variable); dcl active_fnc_err_ entry options (variable); dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_ entry () returns (char (32)); dcl get_system_free_area_ entry returns (ptr); dcl get_wdir_ entry returns (char (168)); dcl file_manager_$status entry (char (*), char (*), ptr, fixed bin (35)); dcl fs_util_$get_type entry (char (*), char (*), char (*), fixed bin (35)); dcl fs_util_$get_max_length entry (char (*), char (*), fixed bin (19), fixed bin (35)); dcl fs_util_$get_ring_brackets entry (char (*), char (*), (*) fixed bin (3), fixed bin (35)); dcl fs_util_$get_switch entry (char (*), char (*), char (*), bit (1) aligned, fixed bin (35)); dcl fs_util_$get_user_access_modes entry (char (*), char (*), char (*), fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl fs_util_$list_switches_for_type entry (char (*), char (*), ptr, ptr, fixed bin (35)); dcl fs_util_$suffix_info_for_type entry (char (*), ptr, fixed bin (35)); dcl hcs_$get_access_class entry (char (*), char (*), bit (72) aligned, fixed bin (35)); dcl hcs_$get_dates entry (char (*), char (*), (5) bit (36), fixed bin (35)); dcl hcs_$get_author entry (char (*), char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$get_bc_author entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$get_max_length entry (char (*), char (*), fixed bin (19), fixed bin (35)); dcl hcs_$get_safety_sw entry (char (*), char (*), bit (1) aligned, fixed bin (35)); dcl hcs_$get_volume_dump_switches entry (char (*), char (*), fixed bin, fixed bin, fixed bin (35)); dcl hcs_$star_dir_list_ entry (char (*), char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_for_backup entry (char (*), char (*), ptr, fixed bin (35)); dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$nnl entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl mdc_$find_lvname entry (bit (36), char (*), fixed bin (35)); dcl mhcs_$get_seg_usage entry (char (*), char (*), fixed bin (35), fixed bin (35)); dcl msf_manager_$close entry (ptr); dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)); dcl msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl requote_string_ entry (char (*)) returns (char (*)); /* Builtins */ dcl (addr, after, before, bin, binary, clock, convert, divide, fixed, hbound, index, null) builtin; dcl (length, max, ptr, reverse, rtrim, string, substr, unspec, verify, empty) builtin; /* Conditions */ dcl (cleanup, linkage_error) condition; /* END OF DECLARATIONS */ %page; call cu_$af_return_arg (arg_count, return_ptr, return_len, code); if code = error_table_$not_act_fnc then do; active_function = "0"b; complain = com_err_; end; else do; active_function = "1"b; complain = active_fnc_err_; end; code = 0; /* must reset code to 0 */ string (opt) = "0"b; string (combined_options) = "0"b; chase, chase_if_possible, dir_sw, dm_file_sw, interpret_as_standard_entry, link_sw, root_sw, seg_sw = "0"b; area_ptr = get_system_free_area_ (); path_array_ptr = addr (path_array_space); fs_entry_type_ptr, star_list_branch_ptr, star_list_names_ptr = null; selecting_by_entry_type = ""b; on cleanup call CLEAN_UP (); path_array_size = arg_count; if path_array_size > hbound (path_array_space, 1) then allocate path_array in (area) set (path_array_ptr); path_count, switch_count = 0; switch_length = 13; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) ^= "-" then do; path_count = path_count + 1; path_array.path_ptr (path_count) = arg_ptr; path_array.path_len (path_count) = arg_len; path_array.nonstandard_names_flag (path_count) = "0"b; end; else if arg = "-working_dir" | arg = "-wd" then do; path_count = path_count + 1; path_array.path_len (path_count) = 0; /* use expand_path_'s working dir feature */ path_array.nonstandard_names_flag (path_count) = "0"b; end; else if arg = "-chase" then chase = "1"b; else if arg = "-no_chase" then chase = "0"b; else if arg = "-chase_if_possible" | arg = "-cip" then chase_if_possible = "1"b; else if arg = "-no_chase_if_possible" | arg = "-ncip" then chase_if_possible = "0"b; else if arg = "-directory" | arg = "-dr" then dir_sw = "1"b; else if arg = "-link" | arg = "-lk" then link_sw = "1"b; else if arg = "-segment" | arg = "-sm" then seg_sw = "1"b; else if arg = "-switch" then do; i = i + 1; if i > arg_count then do; call complain (error_table_$noarg, ME, "Following -switch."); return; end; if switch_count = 10 then do; call complain (0, ME, "Only 10 switch names allowed."); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); switch_count = switch_count + 1; switch_names (switch_count) = arg; switch_length = max (switch_length, arg_len); end; else do; do j = hbound (LONG_OPTION, 1) by -1 to 1 while (arg ^= LONG_OPTION (j) & arg ^= SHORT_OPTION (j)); end; if j ^= 0 then substr (string (opt), j, 1) = "1"b; else if arg = "-device" | arg = "-dv" then opt.logical_volume = "1"b; else if arg = "-entry_type" | arg = "-ettp" then opt.type = "1"b; else if arg = "-interpret_as_extended_entry" | arg = "-inaee" then interpret_as_standard_entry = "0"b; else if arg = "-interpret_as_standard_entry" | arg = "-inase" then interpret_as_standard_entry = "1"b; else if arg = "-names" then opt.names = "1"b; /* synonym for -name and -nm */ else if arg = "-nonstandard_names" | arg = "-nsn" then do; i = i + 1; if i > arg_count then do; call complain (error_table_$noarg, ME, "Need an argument for ^a.", arg); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); path_count = path_count + 1; path_array.path_ptr (path_count) = arg_ptr; path_array.path_len (path_count) = arg_len; path_array.nonstandard_names_flag (path_count) = "1"b; end; else if arg = "-records_used" | arg = "-ru" then opt.records_used = "1"b; /* syn for -records */ else if arg = "-select_entry_type" | arg = "-slet" then do; i = i + 1; if i > arg_count then do; call complain (error_table_$noarg, ME, "Following ^a", arg); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); call BUILD_ENTRY_TYPE_LIST (arg, fs_entry_type_ptr, selecting_by_entry_type); end; else if arg = "-length" | arg = "-lengths" | arg = "-ln" then lengths = "1"b; else if active_function then do; /* not any control arg acceptable to status af */ call complain (0, ME, "Specified control argument is not implemented by this active function. ^a", arg); return; end; else if arg = "-access" | arg = "-ac" then access = "1"b; /* -all, -a are undocumented synonyms of -long to be retained for compatibility. */ else if arg = "-all" | arg = "-a" | arg = "-long" | arg = "-lg" then all = "1"b; else if arg = "-date" | arg = "-dt" then dates = "1"b; else do; call complain (error_table_$badopt, ME, "^a", arg); return; end; end; end; /* Adjust the environment for slet processing, if any requested */ if selecting_by_entry_type then do; if link_sw | seg_sw | dir_sw then do; call complain (error_table_$inconsistent, ME, "-select_entry_type is an alternative to -directory, -segment, or -link."); return; end; dir_sw, link_sw, seg_sw = "1"b; extended_type_count = 0; do entry_type_index = 1 to fs_entry_type.count; if substr (fs_entry_type.suffix (entry_type_index), 1, 1) ^= "-" then extended_type_count = extended_type_count + 1; end; if extended_type_count = fs_entry_type.count then slet_path_array_size = path_count * extended_type_count; else slet_path_array_size = path_count * (extended_type_count + 1); if slet_path_array_size > hbound (path_array_space, 1) then allocate slet_path_array in (area) set (slet_path_array_ptr); else slet_path_array_ptr = addr (path_array_space); i = slet_path_array_size; do j = path_count by -1 to 1; do entry_type_index = 1 to fs_entry_type.count; if substr (fs_entry_type.suffix (entry_type_index), 1, 1) ^= "-" then do; slet_path_len = path_array.path_len (j) + 1 + length (rtrim (fs_entry_type.suffix (entry_type_index))); allocate slet_path in (slet_area) set (slet_path_ptr); target_len = path_array.path_len (j); if ^path_array.nonstandard_names_flag (j) then call expand_pathname_$add_suffix (path_array.path_ptr (j) -> target_path, fs_entry_type.suffix (entry_type_index), target_dn, slet_path_ptr -> slet_path, code); else do; target_dn = get_wdir_ (); arg_len = path_array.path_len (j); arg_ptr = path_array.path_ptr (j); slet_path_ptr -> slet_path = arg; end; slet_path_array.path_ptr (i) = slet_path_ptr; slet_path_array.path_len (i) = slet_path_len; i = i - 1; end; end; if fs_entry_type.count > extended_type_count then do; slet_path_array.path_ptr (i) = path_array.path_ptr (j); slet_path_array.path_len (i) = path_array.path_len (j); i = i - 1; end; end; if path_array_ptr ^= addr (path_array_space) then do; free path_array in (area); path_array_ptr = slet_path_array_ptr; end; path_count = slet_path_array_size; end; /* Set star selection variables */ if ^dir_sw & ^link_sw & ^seg_sw then dir_sw, link_sw, seg_sw = "1"b; /* default */ if ^link_sw then star_select_sw = star_BRANCHES_ONLY; else if ^dir_sw & ^seg_sw then star_select_sw = star_LINKS_ONLY; else star_select_sw = star_ALL_ENTRIES; k = 0; switch_mask = ""b; do i = 1 to switch_count; /* check for standards */ if switch_names (i) = "damaged" then opt.damaged_switch = "1"b; else if switch_names (i) = "safety" then opt.safety_switch = "1"b; else if switch_names (i) = "copy" then opt.copy_switch = "1"b; else if switch_names (i) = "audit" then opt.audit_switch = "1"b; else if switch_names (i) = "synchronized" then opt.synchronized_switch = "1"b; else if switch_names (i) = "complete_volume_dump" then opt.cvds = "1"b; else if switch_names (i) = "incremental_volume_dump" then opt.ivds = "1"b; else substr (switch_mask, i, 1) = "1"b; if ^(substr (switch_mask, i, 1)) then k = k + 1; /* was a standard switch */ end; explicit_opt = opt; if all then string (opt) = ALL_OPTIONS; if access then string (opt) = string (opt) | string (access_options); if dates then string (opt) = string (opt) | string (date_options); if lengths then do; if active_function then string (opt) = string (opt) | string (active_function_length_options); else string (opt) = string (opt) | string (length_options); end; if switch_count = 0 & string (opt) = "0"b then if active_function then do; /* control arg must be supplied to active function */ AF_USAGE: call active_fnc_err_ (0, ME, "Usage: [status path control_arg {-chase}]"); return; end; else unspec (opt) = unspec (default_options); /* Shorter output format if only one item of information is requested. */ j = switch_count - k; do i = 1 to hbound (LONG_OPTION, 1); if substr (string (opt), i, 1) then j = j + 1; end; if j = 1 then one_item = "1"b; else if active_function & ^lengths then go to AF_USAGE; else one_item = "0"b; if path_count = 0 then do; /* assume working directory */ if active_function & arg_count = 2 then go to AF_USAGE; path_count = 1; path_array.path_len (1) = 0; /* use expand_path_'s working dir feature */ path_array.path_ptr (1) = null (); end; else if active_function & path_count > 1 then go to AF_USAGE; saved_options = opt; %page; printed_something = "0"b; /* haven't output anything yet */ do i = 1 to path_count; if path_array.nonstandard_names_flag (i) then do; dn = get_wdir_ (); arg_len = path_array.path_len (i); arg_ptr = path_array.path_ptr (i); en = arg; end; else do; call expand_path_ (path_array.path_ptr (i), path_array.path_len (i), addr (dn), addr (en), code); if code ^= 0 then do; arg_ptr = path_array.path_ptr (i); arg_len = path_array.path_len (i); call complain (code, ME, "^a", arg); go to NEXT_PATH; end; if en ^= "" then call check_star_name_$entry (en, code); /* star convention? */ end; if code = 0 then do; star_sw = "0"b; j, star_entry_count = 1; printed_pathname = "0"b; msf = "0"b; msf_ptr = null (); call ENTRY_STATUS (); /* do the work */ if msf then if msf_ptr ^= null then call msf_manager_$close (msf_ptr); if branch_names_ptr ^= null & ^root_sw then free branch_names in (area); end; else if code > 2 then do; /* invalid entry name */ arg_ptr = path_array.path_ptr (i); arg_len = path_array.path_len (i); call complain (code, ME, "^a", arg); go to NEXT_PATH; end; else if active_function then do; call active_fnc_err_ (0, ME, "Star convention is not allowed."); RETURN: return; end; else star_loop: begin; star_sw = "1"b; star_list_branch_ptr, star_list_names_ptr = null; on condition (cleanup) call CLEAN_UP (); call hcs_$star_dir_list_ (dn, en, star_select_sw, area_ptr, star_branch_count, star_link_count, star_list_branch_ptr, star_list_names_ptr, code); if code ^= 0 then do; call complain (code, ME, "^a", pathname_ (dn, en)); go to NEXT_PATH; end; star_en = en; matched = "0"b; star_entry_count = star_branch_count + star_link_count; do j = 1 to star_entry_count; entry_type = star_dir_list_branch (j).type; if entry_type = star_SEGMENT then do; if ^seg_sw then go to NEXT_MATCH; end; else if entry_type = star_LINK then do; if ^link_sw then go to NEXT_MATCH; end; else do; /* directory type: dir or MSF */ if star_dir_list_branch (j).bit_count = 0 then do; if ^dir_sw then go to NEXT_MATCH; end; else if ^seg_sw then go to NEXT_MATCH; end; matched = "1"b; en = star_list_names (star_dir_list_branch (j).nindex); printed_pathname = "0"b; msf = "0"b; msf_ptr = null (); call ENTRY_STATUS (); /* do the work */ if ^printed_something then /* if we haven't output anything yet, */ printed_something = printed_pathname; /* then if we printed the pathname, */ /* well that's something */ if chased | msf_error then dn = saved_dn; if msf then if msf_ptr ^= null then call msf_manager_$close (msf_ptr); if branch_names_ptr ^= null & ^root_sw then free branch_names in (area); NEXT_MATCH: end; if ^matched | (matched & ^printed_something) then call complain (error_table_$nomatch, ME, "^a", pathname_ (dn, star_en)); call CLEAN_UP (); end star_loop; NEXT_PATH: end; STATUS_EXIT: call CLEAN_UP (); return; %page; ENTRY_STATUS: proc; /* This internal procedure returns the requested attributes of dn>en */ /* It uses a number of global values declared in the external procedure. */ /* It allocates branch names and sets branch_names_ptr. */ /* For multisegment files, it turns on the flag msf. */ dcl max_switch_length fixed bin; dcl not_mounted fixed bin (35); dcl msf_mode bit (5) aligned; dcl msf_rbs (0:2) fixed bin (5) unaligned; max_switch_length = switch_length; branch_status.number_names = "0"b; opt = saved_options; chased, dm_file_sw, msf_error, root_sw = "0"b; not_mounted = 0; status_chase = NO_CHASE; /* get info on entry */ /* If it's a link, we'll be coming back here with status_chase = CHASE */ STATUS: branch_status.names_rel_pointer = "0"b; if opt.names | opt.primary_name | opt.link_path then call hcs_$status_long (dn, en, status_chase, addr (branch_status), area_ptr, code); else call hcs_$status_long (dn, en, status_chase, addr (branch_status), null, code); branch_names_ptr = null; if branch_status.names_rel_pointer ^= "0"b then branch_names_ptr = ptr (area_ptr, branch_status.names_rel_pointer); on condition (cleanup) begin; if branch_names_ptr ^= null & ^root_sw then free branch_names in (area); end; if code ^= 0 then if code = error_table_$no_s_permission then do; NO_S: string (opt) = string (opt) & string (no_s_options); if string (opt) = "0"b then call ENTRY_ERROR (code, dn, en); end; else if code = error_table_$logical_volume_not_connected | code = error_table_$logical_volume_not_defined then do; not_mounted = code; string (opt) = string (opt) & string (off_line_options); if branch_status.number_names = "0"b then string (opt) = string (opt) & string (no_s_options); if string (opt) = "0"b then call ENTRY_ERROR (code, dn, en); end; else if code = error_table_$root then do; /* now it works on the root */ root_sw = "1"b; string (opt) = string (opt) & string (root_options); if string (opt) = "0"b then call ENTRY_WRONG_TYPE ("the root"); dn = ">"; en = ""; branch_names_ptr = addr (ROOT_NAMES); /* fake hcs_$status info */ unspec (branch_status) = "0"b; branch_status.type = directory_type; branch_status.unique_id = (36)"1"b; branch_status.number_names = "0001"b4; if get_group_id_ () = INITIALIZER_ID then branch_status.mode = "01011"b; /* sma */ else branch_status.mode = "01"b; /* s for everybody else */ branch_status.ring_brackets (*) = "000111"b; /* 7,7,7 */ end; else call ENTRY_ERROR (code, dn, en); /* Check the fs type when we are -inase with -slet, and fake out status if wrong type */ if selecting_by_entry_type then do; call fs_util_$get_type (dn, en, fs_type, code); if code ^= 0 then do; call complain (code, ME, "Getting type of ^a", pathname_ (dn, en)); return; end; if ^ENTRY_TYPE_SELECTED (fs_type, fs_entry_type_ptr) then do; matched = "1"b; return; end; else if substr (fs_type, 1, 1) = "-" then ; /* standard type, no faking necessary */ else if star_sw then if before (reverse (rtrim (en)), ".") ^= before (reverse (rtrim (star_en)), ".") then do; matched = "1"b; return; end; end; /* See if the entry is a special type */ entry_type = fixed (branch_status.type); msf = (entry_type = star_DIRECTORY & branch_status.bit_count ^= "0"b); if ^interpret_as_standard_entry & entry_type ^= star_LINK & ^root_sw then if msf | switch_count > 0 | (string (opt) & string (typed_options)) then do; call fs_util_$get_type (dn, en, fs_util_type, code); dm_file_sw = (code = 0 & fs_util_type = FS_OBJECT_TYPE_DM_FILE); if code = 0 & substr (fs_util_type, 1, 1) ^= "-" then do; /* for now, handle segs, dirs, DM files, and MSF's by hand */ entry_type = EXTENDED_type; msf = "0"b; si.version = SUFFIX_INFO_VERSION_1; call fs_util_$suffix_info_for_type (fs_util_type, addr (si), (0)); end; end; if branch_status.type = link_type then do; /* process link for -chase or -chase_if_possible */ if chase & chased then do; /* null link */ call complain (0, ME, "Null link with -chase. ^a", pathname_ (dn, en)); return; end; else if (chase_if_possible | chase) then if ^chased then do; call hcs_$get_link_target (dn, en, target_dn, target_en, code); if code = 0 & dn ^= "" then do; chased = "1"b; saved_dn = dn; saved_en = en; dn = target_dn; en = target_en; status_chase = CHASE; /* chase the link this time */ go to STATUS; /* go back to get link info */ end; else if code = error_table_$noentry then if chase then do; /* null link */ call complain (code, ME, "Target: ^a. Link to a null link with -chase. Source: ^a", pathname_ (target_dn, target_en), pathname_ (dn, en)); return; end; end; /* if ^chase */ string (opt) = string (opt) & string (link_options); if string (opt) = "0"b & switch_count = 0 then /* no applicable control args */ call ENTRY_WRONG_TYPE ("a link"); end; /* if branch_status.type = link_type */ else do; /* non-link */ if ^star_sw then if branch_status.type = directory_type & ^dm_file_sw then do; if (seg_sw | link_sw) & ^dir_sw then call ENTRY_WRONG_TYPE ("a directory"); end; else if (link_sw | dir_sw) & ^seg_sw then if dm_file_sw then call ENTRY_WRONG_TYPE ("a Data Management file"); else call ENTRY_WRONG_TYPE ("a segment"); string (opt) = string (opt) & string (nonlink_options); if string (opt) = "0"b & switch_count = 0 then do; /* no applicable control args */ if ^star_sw then call ENTRY_WRONG_TYPE ("not a link"); return; end; end; if lengths & active_function then /* set up the return value for -length only when status acts as an active function */ if branch_status.type = directory_type & branch_status.bit_count = "0"b then opt.current_length = "0"b; /* for directory type -- status active function returns bit count for -length */ else opt.bit_count = "0"b; /* for other types -- status active function returns current length for -length */ else ; if dm_file_sw | root_sw then msf = "0"b; /* root's not, can't look inside a DM file */ if dm_file_sw then do; string (opt) = string (opt) & string (dm_file_options); if string (opt) = "0"b & switch_count = 0 then call ENTRY_WRONG_TYPE ("a Data Management file"); end; else do; /* not DM file; make sure some control args apply */ unspec (opt.dm_files_only) = "0"b; /**** vp: phx20203 ; case when string (opt) = "0"b and switch_count > 0 for a link ****/ if string (opt) = "0"b then do; if branch_status.type = link_type then call ENTRY_WRONG_TYPE ("a link"); else call ENTRY_WRONG_TYPE ("not a Data Management file"); end; end; %page; /* Now we know we can proceed to print or return some info */ if ^active_function & ^one_item then do; /* multiple entries; print pathname */ call PRINT_PATHNAME (); call ioa_ (""); end; if dm_file_sw then do; if (string (opt) & string (fm_status_options)) ^= "0"b then do; unspec (auto_dm_file_status) = "0"b; auto_dm_file_status.version = DM_FILE_STATUS_VERSION_1; call file_manager_$status (dn, en, addr (auto_dm_file_status), code); if code ^= 0 & code ^= dm_error_$transaction_in_progress then do; call complain (code, ME, "^a", pathname_ (dn, en)); return; end; end; end; %page; /* Format each item of status info */ if opt.names | opt.primary_name then do; /* -name or -primary */ if active_function then do; return_string = requote_string_ (rtrim (branch_names (0))); if opt.names then do k = 1 to bin (branch_status.number_names) - 1; return_string = return_string || " " || requote_string_ (rtrim (branch_names (k))); end; return; end; call PRINT_PATHNAME (); if opt.names then do; if one_item then call ioa_ ("^a", branch_names (0)); else call ioa_ ("names:^4x^a", branch_names (0)); do k = 1 to bin (branch_status.number_names) - 1; if one_item then call ioa_ ("^a", branch_names (k)); else call ioa_ ("^10x^a", branch_names (k)); end; end; else if one_item then call ioa_ ("^a", branch_names (0)); else call ioa_ ("primary name:^7x^a", branch_names (0)); end; if opt.type then do; /* -type */ if root_sw then type_string = "directory"; else if dm_file_sw then type_string = "Data Management file"; else if entry_type = EXTENDED_type then type_string = si.type_name; else if entry_type = star_LINK then type_string = "link"; else if entry_type = star_SEGMENT then type_string = "segment"; else if entry_type = star_DIRECTORY then if branch_status.bit_count ^= "0"b then type_string = "multisegment file"; else if branch_status.mdir then type_string = "master directory"; else type_string = "directory"; if active_function then do; return_string = """" || rtrim (type_string) || """"; return; end; call PRINT_PATHNAME (); if one_item then call ioa_ ("^a", type_string); else call ioa_ ("type:^15x^a", type_string); end; if opt.link_path then do; /* -link_path */ target_ptr = ptr (area_ptr, link_status.pnrp); target_len = link_status.pnl; if active_function then do; return_string = rtrim (target_path); return; end; call PRINT_PATHNAME (); if one_item then call ioa_ ("^a", target_ptr -> target_path); else call ioa_ ("links to:^11x^a", target_ptr -> target_path); end; if opt.unique_id then do; /* -unique_id */ if dm_file_sw then local_unique_id = auto_dm_file_status.fm_unique_id; else local_unique_id = branch_status.unique_id; if active_function then do; call ioa_$rsnnl ("^w", return_string, k, local_unique_id); return; end; else do; call PRINT_PATHNAME (); if one_item then call ioa_ ("^w", local_unique_id); else call ioa_ ("^[fm unique id:^7x^;unique id:^10x^]^w", dm_file_sw, local_unique_id); end; end; /* Get MSF information */ if opt.dtu | opt.dtcm | opt.dtem | opt.dtd | opt.bit_count | opt.records_used | opt.current_length | opt.mode | opt.ring_brackets then do; call PRINT_PATHNAME (); if msf then get_msf_info: begin; on cleanup begin; if msf_ptr ^= null then call msf_manager_$close (msf_ptr); end; call msf_manager_$open (dn, en, msf_ptr, code); if msf_ptr = null then do; call complain (code, ME, "Unable to open multisegment file ^a>^a", dn, en); msf = "0"b; return; end; msf_dtu, msf_dtcm, msf_dtem, msf_dtd = "0"b; total_records = bin (branch_status.records, 17); total_length = bin (branch_status.current_length, 11); total_bit_count = 0; msf_path = rtrim (dn) || ">" || en; /* initialize in case no components */ msf_mode = branch_status.mode & "01010"b; unspec (msf_rbs) = unspec (branch_status.ring_brackets); do k = 0 by 1 while (code = 0); /* look at all components */ call msf_manager_$get_ptr (msf_ptr, k, "0"b, comp_ptr, 0, code); if code = 0 | code = error_table_$segknown then do; comp_name = convert (comp_name, k); comp_name = substr (comp_name, verify (comp_name, " ")); call hcs_$status_long (msf_path, comp_name, 1, addr (msf_info), null, code); if code ^= 0 then if code = error_table_$no_s_permission then do; opt.ring_brackets = "0"b; if string (opt) = "0"b then do; saved_dn = dn; msf_error = "1"b; call ENTRY_ERROR (code, msf_path, comp_name); end; end; else do; call complain (code, ME, "^a>^a", msf_path, comp_name); return; end; code = 0; if fixed (msf_info.dtu) > fixed (msf_dtu) then msf_dtu = msf_info.dtu; if fixed (msf_info.dtcm) > fixed (msf_dtcm) then msf_dtcm = msf_info.dtcm; if fixed (msf_info.dtem) > fixed (msf_dtem) then msf_dtem = msf_info.dtem; if fixed (msf_info.dtd) > fixed (msf_dtd) then msf_dtd = msf_info.dtd; if k = 0 then do; /* first component */ msf_mode = msf_info.mode; unspec (msf_rbs) = unspec (msf_info.rbs); end; total_records = total_records + msf_info.records; total_bit_count = total_bit_count + bin (msf_info.bit_count); total_length = total_length + msf_info.current_length; end; else if code ^= error_table_$noentry then do; opt.bit_count, opt.records_used, opt.current_length, opt.dtu, opt.dtcm, opt.dtem, opt.dtd, opt.mode, opt.ring_brackets = "0"b; if string (opt) = "0"b then do; saved_dn = dn; msf_error = "1"b; comp_name = convert (comp_name, k); call ENTRY_ERROR (error_table_$moderr, dn, en); end; end; end; end get_msf_info; end; if opt.dtu then do; /* -date_time_used */ /**** vp: phx20897; convert the system clock to 36 bits then make use of the internal procedure CONVERT_DATE to convert a 36 bits clock time into an ASCII date string. This will effectively check for active function as well. ****/ if root_sw then do; temp_clock = clock (); /* This conversion method was taken from date_time_.pl1 routine */ stime = addr (temp_clock) -> fs_time_value.time; call CONVERT_DATE (stime); end; else if msf & msf_dtu ^= "0"b then call CONVERT_DATE (msf_dtu); else call CONVERT_DATE (branch_status.date_time_used); call PRINT_PATHNAME (); if one_item then call ioa_ ("^a", date_string); else if date_string ^= "ZERO" | explicit_opt.dtu then call ioa_ ("date used:^10x^a", date_string); end; if opt.dtcm then do; /* -date_time_contents_modified */ if msf & msf_dtcm ^= "0"b then call CONVERT_DATE (msf_dtcm); else call CONVERT_DATE (branch_status.date_time_modified); call PRINT_PATHNAME (); if one_item then call ioa_ ("^a", date_string); else if date_string ^= "ZERO" | explicit_opt.dtcm then call ioa_ ("date modified:^6x^a", date_string); end; if opt.dtem then do; /* -date_time_entry_modified */ call PRINT_PATHNAME (); if entry_type = star_LINK then do; call CONVERT_DATE (link_status.dtlm); if one_item then call ioa_ ("^a", date_string); else if date_string ^= "ZERO" | explicit_opt.dtem then call ioa_ ("date link modified: ^a", date_string); end; else do; if msf & msf_dtem ^= "0"b then call CONVERT_DATE (msf_dtem); else call CONVERT_DATE (branch_status.date_time_entry_modified); if one_item then call ioa_ ("^a", date_string); else if date_string ^= "ZERO" | explicit_opt.dtem then call ioa_ ("branch modified:^4x^a", date_string); end; end; if opt.dtvd then do; /* -date_time_volume_dumped */ call PRINT_PATHNAME (); if entry_type = star_LINK then do; call hcs_$get_dates (dn, "", dates_array, code); call CONVERT_DATE (dates_array (5)); if one_item then call ioa_ ("link dtvd: ^a", date_string); else if date_string ^= "ZERO" | explicit_opt.dtd then call ioa_ ("link volume dumped:^1x^a", date_string); end; else do; call hcs_$get_dates (dn, en, dates_array, code); call CONVERT_DATE (dates_array (5)); if one_item then call ioa_ ("dtvd: ^a", date_string); else if date_string ^= "ZERO" | explicit_opt.dtd then call ioa_ ("date volume dumped:^1x^a", date_string); end; end; if opt.dtd then do; /* -date_time_dumped */ call PRINT_PATHNAME (); if entry_type = star_LINK then do; call CONVERT_DATE (link_status.dtd); if one_item then call ioa_ ("dtd: ^a", date_string); else if date_string ^= "ZERO" | explicit_opt.dtd then call ioa_ ("link dumped:^8x^a", date_string); end; else do; if msf & msf_dtd ^= "0"b then call CONVERT_DATE (msf_dtd); else call CONVERT_DATE (branch_status.date_time_dumped); if one_item then call ioa_ ("br dtd: ^a", date_string); else if date_string ^= "ZERO" | explicit_opt.dtd then call ioa_ ("date branch dumped:^1x^a", date_string); end; end; if opt.author then do; /* -author */ call PRINT_PATHNAME (); if root_sw then do; author_string = INITIALIZER_ID; code = 0; end; else call hcs_$get_author (dn, en, 0, author_string, code); if active_function then do; if code = 0 then return_string = rtrim (author_string); else call active_fnc_err_ (code, ME); return; end; if code = 0 then do; if one_item then call ioa_ ("^a", author_string); else call ioa_ ("author:^13x^a", author_string); end; else if one_item then call complain (code, ME); else if explicit_opt.author then call complain (code, ME, "Unable to get author."); end; if opt.bc_author then do; /* -bc_author */ call PRINT_PATHNAME (); if root_sw then do; bc_author_string = INITIALIZER_ID; code = 0; end; else call hcs_$get_bc_author (dn, en, bc_author_string, code); if active_function then do; if code = 0 then return_string = rtrim (bc_author_string); else call active_fnc_err_ (code, ME); return; end; if code = 0 then do; if one_item then call ioa_ ("^a", bc_author_string); else if explicit_opt.bc_author | bc_author_string ^= author_string then call ioa_ ("bit count author:^3x^a", bc_author_string); end; else if one_item then call complain (code, ME); else if explicit_opt.bc_author then call complain (code, ME, "Unable to get bit count author."); end; if opt.logical_volume then do; /* -logical_volume */ call PRINT_PATHNAME (); if root_sw then do; lv_string = "root"; code = 0; end; else call mdc_$find_lvname (branch_status.lvid, lv_string, code); if active_function then do; if code = 0 then return_string = rtrim (lv_string); else call active_fnc_err_ (code, ME); return; end; else if code = 0 then do; if one_item then call ioa_ ("^a", lv_string); else if entry_type = star_SEGMENT then call ioa_ ("volume name:^8x^a", lv_string); else call ioa_ ("sons volume:^8x^a", lv_string); end; else if one_item then call complain (code, ME); else if explicit_opt.logical_volume then call complain (code, ME, "Unable to get logical volume."); end; if opt.bit_count then do; /* -bit_count */ call PRINT_PATHNAME (); if root_sw then bc35 = 0; else do; bc36 = "0000"b3 || branch_status.bit_count; unspec (bc35) = bc36; /* convert to fixed bin (35) */ end; if msf then if active_function then do; call ioa_$rsnnl ("^d", return_string, k, total_bit_count); return; end; else do; call ioa_ ("number of components:^9x^d", k - 1); if k - 1 ^= bin (branch_status.bit_count) then call ioa_ ("msf indicator:^6x^d (inconsistent with number of components)", bc35); call ioa_ ("total bit count:^4x^d", total_bit_count); end; else if active_function then do; call ioa_$rsnnl ("^d", return_string, k, bc35); return; end; else if one_item then call ioa_ ("^d", bc35); else call ioa_ ("bit count:^10x^d", bc35); end; if opt.records_used then do; /* -records_used */ call PRINT_PATHNAME (); if msf then if active_function then do; call ioa_$rsnnl ("^d", return_string, k, total_records); return; end; else do; if one_item then call ioa_ ("^d", total_records); else call ioa_ ("total records used:^x^d", total_records); end; else if active_function then do; call ioa_$rsnnl ("^d", return_string, k, fixed (branch_status.records, 18)); return; end; else do; if one_item then call ioa_ ("^d", fixed (branch_status.records, 18)); else call ioa_ ("records used:^7x^d", fixed (branch_status.records, 18)); end; end; if opt.current_length then do; /* -current_length */ call PRINT_PATHNAME (); if msf then if active_function then do; call ioa_$rsnnl ("^d", return_string, k, total_length); return; end; else do; if one_item then call ioa_ ("^d", total_length); else if explicit_opt.current_length | total_length ^= total_records then call ioa_ ("total length:^7x^d", total_length); end; else if active_function then do; call ioa_$rsnnl ("^d", return_string, k, fixed (branch_status.current_length, 12)); return; end; else do; if one_item then call ioa_ ("^d", fixed (branch_status.current_length, 12)); else if explicit_opt.current_length | branch_status.current_length ^= substr (branch_status.records, 7, 12) then call ioa_ ("current length:^5x^d", fixed (branch_status.current_length, 12)); end; end; if opt.max_length then do; /* -max_length */ call PRINT_PATHNAME (); if entry_type ^= star_DIRECTORY then do; if msf then call hcs_$get_max_length (msf_path, "0", max_length, code); else if entry_type = EXTENDED_type then call fs_util_$get_max_length (dn, en, max_length, code); else call hcs_$get_max_length (dn, en, max_length, code); if active_function then do; if code = 0 then call ioa_$rsnnl ("^d", return_string, k, max_length); else call active_fnc_err_ (code, ME); return; end; if code = 0 then if one_item then call ioa_ ("^d", max_length); else call ioa_ ("max length:^9x^d", max_length); else if code = error_table_$unsupported_operation & ^explicit_opt.max_length then ; /* ignore if this type has no max length */ else if one_item then call complain (code, ME); else if explicit_opt.max_length then call complain (code, ME, "Unable to get max length."); end; else if active_function then do; call active_fnc_err_ (0, ME, "Unable to get the max length of a directory. ^a>^a", dn, en); return; end; else if explicit_opt.max_length then call complain (0, ME, "Unable to get the max length of a directory. ^a>^a", dn, en); end; if opt.mode then do; /* -mode */ call PRINT_PATHNAME (); if dm_file_sw then string (mode_bits) = "0"b || substr (auto_dm_file_status.mode, 1, 4); /* prevent string size condition while compiling. */ else if msf then string (mode_bits) = msf_mode; else string (mode_bits) = branch_status.mode; mode_string = ""; if entry_type = EXTENDED_type then do; call fs_util_$get_user_access_modes (dn, en, "", -1, modes, exmodes, code); if code ^= 0 then if code = error_table_$unsupported_operation & ^explicit_opt.mode then ; /* ignore if this type has no extended mode */ else call complain (code, ME, "Unable to get extended mode."); else do; do k = 1 to length (rtrim (si.modes)); if substr (modes, k, 1) then mode_string = mode_string || substr (si.modes, k, 1); end; end; end; else if dm_file_sw | msf | entry_type = star_SEGMENT then do; if mode_bits (2) then mode_string = "r"; if mode_bits (3) then mode_string = mode_string || "e"; if mode_bits (4) then mode_string = mode_string || "w"; end; else do; /* directory */ if mode_bits (2) then mode_string = "s"; if mode_bits (4) then mode_string = mode_string || "m"; if mode_bits (5) then mode_string = mode_string || "a"; end; if code = 0 then do; if mode_string = "" then mode_string = "null"; if active_function then do; return_string = mode_string; return; end; if one_item then call ioa_ ("^a", mode_string); else call ioa_ ("mode:^15x^a", mode_string); end; end; if opt.access_class then do; /* -access_class */ call PRINT_PATHNAME (); call hcs_$get_access_class (dn, en, access_class, code); if code = 0 then do; call convert_authorization_$to_string_short (access_class, class, code); if code ^= 0 then call complain (code, ME, "Unable to convert access class."); else if active_function then do; if class = "" then class = "system_low"; return_string = rtrim (class); return; end; else if class ^= "" then do; /* format access class in lines of 50 chars */ class_len = index (class, " ") - 1; if class_len = -1 then class_len = 336; k = 1; if ^one_item then call ioa_$nnl ("access class:^7x"); do while ((class_len - k + 1) > 50); temp_string = substr (class, k, 50); kk = length (temp_string) + 1 - index (reverse (temp_string), ","); call ioa_$nnl ("^a", substr (class, k, kk)); if ^one_item then call ioa_$nnl ("^/^20x"); k = k + kk; end; call ioa_ ("^a", substr (class, k)); end; else if explicit_opt.access_class then if one_item then call ioa_ ("system_low"); else call ioa_ ("access class:^7xsystem_low"); end; else if active_function | explicit_opt.access_class then do; call complain (code, ME, "Unable to get access class."); return; end; end; if opt.ring_brackets then do; /* -ring_brackets */ call PRINT_PATHNAME (); if entry_type = EXTENDED_type then do; if si.num_ring_brackets = 0 then if explicit_opt.ring_brackets then call complain (0, ME, "The ^a object type does not support ring brackets.", si.type_name); else ; else do; call fs_util_$get_ring_brackets (dn, en, ring_brackets, code); if code ^= 0 then if code = error_table_$unsupported_operation & ^explicit_opt.ring_brackets then ; /* ignore if this type has no ring brackets */ else call complain (code, ME, "Unable to get ring brackets."); else if active_function then call ioa_$rsnnl ("^v(^d ^)", return_string, k, si.num_ring_brackets, ring_brackets); else call ioa_ ("^[ring brackets:^6x^]^v(^d, ^)^d", ^one_item, si.num_ring_brackets - 1, ring_brackets); end; end; else if active_function then do; if dm_file_sw then call ioa_$rsnnl ("^d ^d", return_string, k, auto_dm_file_status.ring_brackets); else if msf then call ioa_$rsnnl ("^d ^d ^d", return_string, k, msf_rbs); else if entry_type ^= star_DIRECTORY then call ioa_$rsnnl ("^d ^d ^d", return_string, k, fixed (branch_status.ring_brackets, 5)); else call ioa_$rsnnl ("^d ^d", return_string, k, fixed (branch_status.ring_brackets (0), 5), fixed (branch_status.ring_brackets (1), 5)); return; end; else if dm_file_sw then if one_item then call ioa_ ("^d, ^d", auto_dm_file_status.ring_brackets); else call ioa_ ("extended ring brackets:^2x^d, ^d", auto_dm_file_status.ring_brackets); else if msf then if one_item then call ioa_ ("^d, ^d, ^d", msf_rbs); else call ioa_ ("ring brackets:^6x^d, ^d, ^d", msf_rbs); else if entry_type ^= star_DIRECTORY then if one_item then call ioa_ ("^d, ^d, ^d", fixed (branch_status.ring_brackets, 5)); else call ioa_ ("ring brackets:^6x^d, ^d, ^d", fixed (branch_status.ring_brackets, 5)); else if one_item then call ioa_ ("^d, ^d", fixed (branch_status.ring_brackets (0), 5), fixed (branch_status.ring_brackets (1), 5)); else call ioa_ ("ring brackets:^6x^d, ^d", fixed (branch_status.ring_brackets (0), 5), fixed (branch_status.ring_brackets (1), 5)); end; if opt.usage_count then do; /* -usage_count */ call PRINT_PATHNAME (); if entry_type = star_DIRECTORY then if explicit_opt.usage_count & ^star_sw then call complain (0, ME, "Cannot determine the usage count of a directory."); else ; else do; usage_count = 0; on linkage_error begin; usage_count = -1; go to flurp; end; call mhcs_$get_seg_usage (dn, en, usage_count, code); flurp: revert linkage_error; if usage_count < 0 then code = error_table_$incorrect_access; if active_function then do; if code = 0 then call ioa_$rsnnl ("^d", return_string, k, usage_count); else call active_fnc_err_ (code, ME); return; end; if code = 0 then if one_item then call ioa_ ("^d", usage_count); else call ioa_ ("usage count:^8x^d", usage_count); else if explicit_opt.usage_count then call complain (code, ME, "Unable to get usage count."); end; end; if entry_type = EXTENDED_type | dm_file_sw then do; call PRINT_PATHNAME (); switch_list_ptr = null (); on cleanup begin; if switch_list_ptr ^= null () then free switch_list; end; call fs_util_$list_switches_for_type (fs_util_type, SWITCH_LIST_VERSION_1, area_ptr, switch_list_ptr, code); if code = error_table_$unsupported_operation & ^(explicit_opt.safety_switch | explicit_opt.ivds | explicit_opt.copy_switch | explicit_opt.audit_switch | explicit_opt.cvds | explicit_opt.synchronized_switch | explicit_opt.damaged_switch | explicit_opt.concurrency_switch | explicit_opt.rollback_switch | explicit_opt.protected_switch) then goto SKIP_SWITCHES; /* WARNING, this ain't too modular */ if code ^= 0 then do; call complain (code, ME, "Listing switches."); return; end; if all then do k = 1 to switch_list.switch_count; max_switch_length = max (max_switch_length, length (rtrim (switch_list.names (switch_list.name_index (k))))); end; end; max_switch_length = max_switch_length + 8; /* " switch: " */ if opt.safety_switch then do; /* -safety_switch */ call PRINT_PATHNAME (); if entry_type = EXTENDED_type | dm_file_sw then call STATUS_SWITCH ("safety", explicit_opt.safety_switch); else do; if root_sw then safety_switch = "0"b; else call hcs_$get_safety_sw (dn, en, safety_switch, code); call PRINT_SWITCH ("safety", explicit_opt.safety_switch, safety_switch, "0"b); end; end; if opt.ivds then do; /* -ivds */ call PRINT_PATHNAME (); if entry_type = star_DIRECTORY & ^root_sw then if explicit_opt.ivds then call ENTRY_WRONG_TYPE ("a directory"); else ; /* not valid for dirs */ else do; if entry_type = EXTENDED_type | dm_file_sw then call STATUS_SWITCH ("ivds", explicit_opt.ivds); else do; if root_sw then ivds = 1; else call hcs_$get_volume_dump_switches (dn, en, ivds, cvds, code); call PRINT_SWITCH ("ivds", explicit_opt.ivds, (ivds = -1), "1"b); end; end; end; if opt.cvds then do; /* -cvds */ call PRINT_PATHNAME (); if entry_type = star_DIRECTORY & ^root_sw then if explicit_opt.cvds then call ENTRY_WRONG_TYPE ("a directory"); else ; /* not valid for dirs */ else do; if entry_type = EXTENDED_type | dm_file_sw then call STATUS_SWITCH ("cvds", explicit_opt.cvds); else do; if root_sw then cvds = 1; else call hcs_$get_volume_dump_switches (dn, en, ivds, cvds, code); call PRINT_SWITCH ("cvds", explicit_opt.cvds, (cvds = -1), "1"b); end; end; end; if opt.audit_switch then do; /* -audit_switch */ call PRINT_PATHNAME (); if entry_type = EXTENDED_type | dm_file_sw then call STATUS_SWITCH ("audit", explicit_opt.audit_switch); else do; bks.version = status_for_backup_version_2; call hcs_$status_for_backup (dn, en, addr (bks), code); call PRINT_SWITCH ("audit", explicit_opt.audit_switch, (bks.audit_flag), "0"b); end; end; if opt.copy_switch then do; /* -copy_switch */ call PRINT_PATHNAME (); if entry_type = EXTENDED_type | dm_file_sw then call STATUS_SWITCH ("copy", explicit_opt.copy_switch); else do; code = 0; call PRINT_SWITCH ("copy", explicit_opt.copy_switch, (branch_status.copy_switch), "0"b); end; end; if opt.damaged_switch then do; /* -damaged_switch */ call PRINT_PATHNAME (); if entry_type = EXTENDED_type | dm_file_sw then call STATUS_SWITCH ("damaged", explicit_opt.damaged_switch); else do; code = 0; call PRINT_SWITCH ("damaged", explicit_opt.damaged_switch, (branch_status.damaged_switch), "0"b); end; end; if opt.synchronized_switch then do; /* -synchronized_switch */ call PRINT_PATHNAME (); if entry_type = EXTENDED_type | dm_file_sw then call STATUS_SWITCH ("synchronized", explicit_opt.synchronized_switch); else do; code = 0; if fixed (branch_status.bit_count) = 0 & branch_status.type = directory_type then do; if ^all then call complain (0, ME, "Directories do not support the synch switch. ^a.", pathname_ (dn, en)); end; else call PRINT_SWITCH ("synchronized", explicit_opt.synchronized_switch, (branch_status.synchronized_switch), "0"b); end; end; call PRINT_PATHNAME (); if entry_type = EXTENDED_type then do; if all then do; do k = 1 to switch_list.switch_count; if switch_list.name_index (k) > 0 then call STATUS_SWITCH_QUICK ((switch_list.names (switch_list.name_index (k))), "0"b); end; do k = 1 to switch_count; do kk = 1 to switch_list.switch_name_count; if switch_names (k) = switch_list.names (kk) then go to FOUND; end; call complain (0, ME, "The ^a switch is not supported by ^a.", switch_names (k), si.plural_name); FOUND: end; end; else if switch_mask ^= "0"b then do kk = 1 to switch_count; call STATUS_SWITCH (switch_names (kk), "1"b); end; end; else if switch_mask ^= "0"b then do k = 1 to switch_count; if substr (switch_mask, k, 1) then call complain (0, ME, "Standard objects do not support the ^a switch.", switch_names (k)); end; SKIP_SWITCHES: if opt.entry_bound then do; call PRINT_PATHNAME (); if entry_type ^= star_SEGMENT then if explicit_opt.entry_bound then call complain (0, ME, "The entry is not a gate. ^a", pathname_ (dn, en)); else ; else do; bks.version = status_for_backup_version_2; call hcs_$status_for_backup (dn, en, addr (bks), code); if code ^= 0 then call complain (code, ME, "Unable to obtain entrybound."); else if ^bks.entrypt then NOT_GATE: if explicit_opt.entry_bound then call complain (0, ME, "The entry is not a gate."); else ; else if active_function then call ioa_$rsnnl ("^d", return_string, k, fixed (bks.entrypt_bound)); else if one_item then call ioa_ ("^d", fixed (bks.entrypt_bound)); else call ioa_ ("entry bound:^8x^d", fixed (bks.entrypt_bound)); end; end; if opt.highest_ci then do; call PRINT_PATHNAME (); if active_function then call ioa_$rsnnl ("^d", return_string, k, auto_dm_file_status.highest_ci); else if one_item then call ioa_ ("^d", auto_dm_file_status.highest_ci); else call ioa_ ("highest control interval: ^d", auto_dm_file_status.highest_ci); end; if opt.concurrency_switch then do; call PRINT_PATHNAME (); call PRINT_SWITCH ("concurrency", explicit_opt.concurrency_switch, ^auto_dm_file_status.no_concurrency_sw, "1"b); end; if opt.rollback_switch then do; call PRINT_PATHNAME (); call PRINT_SWITCH ("rollback", explicit_opt.rollback_switch, ^auto_dm_file_status.no_rollback_sw, "1"b); end; if opt.protected_switch then do; call PRINT_PATHNAME (); call PRINT_SWITCH ("protected", explicit_opt.protected_switch, (auto_dm_file_status.protected_sw), "1"b); end; if not_mounted ^= 0 & all & ^active_function then call complain (not_mounted, ME, "Unable to determine: date used, date modified, date volume dumped, records used, max length or usage count."); if j = star_entry_count & ^active_function & ^one_item then call ioa_ (""); if (entry_type = EXTENDED_type) & (switch_list_ptr ^= null ()) then free switch_list; ENTRY_RETURN: return; %page; CONVERT_DATE: proc (date_time); /* This internal procedure converts a bit(36) clock time into an ASCII date string. If status was called as an active function, the string is returned. */ dcl date_time bit (36); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl cv_fstime_ entry (bit (36) aligned) returns (fixed bin (71)); if date_time = "0"b then date_string = "ZERO"; else date_string = date_time_$format ("date_time", cv_fstime_ ((date_time)), "", ""); if active_function then do; return_string = """" || rtrim (date_string) || """"; go to ENTRY_RETURN; /* "status" active function must call normal cleanup handler before it finishes. */ end; end CONVERT_DATE; %page; ENTRY_ERROR: proc (P_code, P_dn, P_en); dcl P_code fixed bin (35); dcl (P_dn, P_en) char (*); if active_function then do; if msf_ptr ^= null then call msf_manager_$close (msf_ptr); call CLEAN_UP; end; call complain (P_code, ME, "^a", pathname_ (P_dn, P_en)); go to ENTRY_RETURN; end ENTRY_ERROR; %page; ENTRY_WRONG_TYPE: proc (P_string); dcl P_string char (*); if ^star_sw then call complain (0, ME, "^a is ^[the root^;^a^]. Control arguments given do not apply.", pathname_ (dn, en), root_sw, P_string); go to ENTRY_RETURN; end ENTRY_WRONG_TYPE; %page; PRINT_PATHNAME: proc; /* This internal procedure merely prints out the pathname if it hasn't been printed yet. */ if printed_pathname | active_function then return; if star_sw | (path_count > 1) then if one_item then call ioa_ ("^5x^a", pathname_ (dn, en)); else call ioa_ ("^/^10x^a", pathname_ (dn, en)); else ; /* don't print header for only 1 path on command line */ printed_pathname = "1"b; return; end PRINT_PATHNAME; %page; STATUS_SWITCH: proc (switch, explicit); dcl switch char (*); dcl temp_switch char (32); dcl explicit bit (1) unaligned; dcl default bit (1) aligned; dcl value bit (1) aligned; dcl x fixed bin; if switch = "cvds" then temp_switch = "complete_volume_dump"; else if switch = "ivds" then temp_switch = "incremental_volume_dump"; else temp_switch = switch; do k = 1 to switch_list.switch_count; do x = 0 to switch_list.name_count (k) - 1; if switch_list.name_index (k) > 0 then if switch = switch_list.names (switch_list.name_index (k) + x) then go to JOIN; end; end; if explicit then call complain (0, ME, "The ^a switch is not supported by ^a.", switch, si.plural_name); return; STATUS_SWITCH_QUICK: entry (switch, explicit); temp_switch = switch; JOIN: if switch_list.name_index (k) = 0 then return; /* already printed */ switch_list.name_index (k) = 0; /* so we don't come back */ default = switch_list.default_value (k); call fs_util_$get_switch (dn, en, temp_switch, value, code); goto PRINT; PRINT_SWITCH: entry (switch, explicit, switch_value, default_value); dcl switch_value bit (1) aligned; dcl default_value bit (1) aligned; value = switch_value; default = default_value; code = 0; PRINT: if code ^= 0 then call complain (code, ME, "Unable to get ^a switch.", switch); if active_function then do; if value then return_string = "true"; else return_string = "false"; return; end; else if all | (value ^= default) then if one_item then call ioa_ ("^[on^;off^]", value); else call ioa_ ("^a switch:^vt^[on^;off^] (default^[ = ^[off^;on^]^])", switch, max_switch_length, value, value ^= default, value); else if explicit then if one_item then call ioa_ ("^[on^;off^]", value); else call ioa_ ("^a switch:^vt^[on^;off^]", switch, max_switch_length, value); return; end STATUS_SWITCH; end ENTRY_STATUS; %page; BUILD_ENTRY_TYPE_LIST: proc (P_entry_type_list, P_fs_entry_type_ptr, P_slet_enabled_sw); dcl P_entry_type_list char (*); dcl P_fs_entry_type_ptr ptr; dcl P_slet_enabled_sw bit (1) aligned; dcl 1 entry_type_info aligned like suffix_info; dcl types char (types_len) based (types_ptr); dcl types_len fixed bin (24); dcl types_ptr ptr; dcl this_type char (32); /* Copy the entry type list parameter into locally managed storage */ types_ptr = null; on cleanup begin; if types_ptr ^= null then free types in (area); end; types_len = length (P_entry_type_list); allocate types set (types_ptr) in (area); types = P_entry_type_list; /* Count the number of entry types and allocate the entry type array */ do fs_entry_type_count = 1 repeat (fs_entry_type_count + 1) while (index (types, ",") ^= 0); types = after (types, ","); end; allocate fs_entry_type in (area) set (P_fs_entry_type_ptr); entry_type_info.version = SUFFIX_INFO_VERSION_1; P_fs_entry_type_ptr -> fs_entry_type.suffix (*) = ""; /* For each potential entry type, validate it and add it to the structure */ types = P_entry_type_list; entry_type_index = 1; do while (types ^= ""); this_type = before (types, ","); if substr (this_type, 1, 1) ^= "-" then do; if this_type = "link" then this_type = FS_OBJECT_TYPE_LINK; else if this_type = "segment" then this_type = FS_OBJECT_TYPE_SEGMENT; else if this_type = "directory" then this_type = FS_OBJECT_TYPE_DIRECTORY; else if this_type = "multisegment_file" then this_type = FS_OBJECT_TYPE_MSF; else if this_type = "data_management_file" then this_type = FS_OBJECT_TYPE_DM_FILE; P_fs_entry_type_ptr -> fs_entry_type.suffix (entry_type_index) = this_type; if this_type = FS_OBJECT_TYPE_LINK then entry_type_index = entry_type_index + 1; /* fs_util_ does not handle links */ else do; call fs_util_$suffix_info_for_type (this_type, addr (entry_type_info), code); if code = 0 then entry_type_index = entry_type_index + 1; end; end; types = after (types, ","); end; /* Free the types variable and set P_slet_enabled_sw */ free types_ptr -> types in (area); P_fs_entry_type_ptr -> fs_entry_type.count = entry_type_index - 1; if P_fs_entry_type_ptr -> fs_entry_type.count > 0 then P_slet_enabled_sw = "1"b; else do; call complain (0, ME, "^[None of the specified entry types is valid^;The specified entry type is not valid^]: ^a", P_fs_entry_type_ptr -> fs_entry_type.count > 1, P_entry_type_list); go to STATUS_EXIT; end; return; end BUILD_ENTRY_TYPE_LIST; %page; ENTRY_TYPE_SELECTED: proc (P_fs_type, P_fs_entry_type_ptr) returns (bit (1) aligned); dcl P_fs_type char (*); dcl P_fs_entry_type_ptr ptr; dcl entry_type_index fixed bin; do entry_type_index = 1 to P_fs_entry_type_ptr -> fs_entry_type.count; if P_fs_type = P_fs_entry_type_ptr -> fs_entry_type.suffix (entry_type_index) then return ("1"b); end; return ("0"b); end ENTRY_TYPE_SELECTED; %page; CLEAN_UP: proc; if star_list_names_ptr ^= null then free star_list_names in (area); if star_list_branch_ptr ^= null then free star_dir_list_branch in (area); if fs_entry_type_ptr ^= null then free fs_entry_type in (area); if path_array_ptr ^= null & path_array_ptr ^= addr (path_array_space) then free path_array in (area); end CLEAN_UP; %page; dcl 1 access_options int static, /* for -access */ (2 primary_name init ("0"b), 2 names init ("0"b), 2 type init ("0"b), 2 link_path init ("0"b), 2 unique_id init ("0"b), 2 dtu init ("0"b), 2 dtcm init ("0"b), 2 dtem init ("0"b), 2 dtd init ("0"b), 2 dtvd init ("0"b), 2 author init ("0"b), 2 bc_author init ("0"b), 2 logical_volume init ("0"b), 2 bit_count init ("0"b), 2 records_used init ("0"b), 2 current_length init ("0"b), 2 max_length init ("0"b), 2 mode init ("1"b), 2 access_class init ("1"b), 2 ring_brackets init ("1"b), 2 safety_switch init ("1"b), 2 copy_switch init ("0"b), 2 audit_switch init ("0"b), 2 ivds init ("0"b), 2 cvds init ("0"b), 2 usage_count init ("0"b), 2 damaged_switch init ("0"b), 2 synchronized_switch init ("0"b), 2 entry_bound init ("0"b), 2 highest_ci init ("0"b), 2 concurrency_switch init ("0"b), 2 rollback_switch init ("0"b), 2 protected_switch init ("0"b) ) bit (1) unaligned; %page; dcl 1 date_options int static, /* for -date */ (2 primary_name init ("0"b), 2 names init ("0"b), 2 type init ("0"b), 2 link_path init ("0"b), 2 unique_id init ("0"b), 2 dtu init ("1"b), 2 dtcm init ("1"b), 2 dtem init ("1"b), 2 dtd init ("1"b), 2 dtvd init ("1"b), 2 author init ("0"b), 2 bc_author init ("0"b), 2 logical_volume init ("0"b), 2 bit_count init ("0"b), 2 records_used init ("0"b), 2 current_length init ("0"b), 2 max_length init ("0"b), 2 mode init ("0"b), 2 access_class init ("0"b), 2 ring_brackets init ("0"b), 2 safety_switch init ("0"b), 2 copy_switch init ("0"b), 2 audit_switch init ("0"b), 2 ivds init ("0"b), 2 cvds init ("0"b), 2 usage_count init ("0"b), 2 damaged_switch init ("0"b), 2 synchronized_switch init ("0"b), 2 entry_bound init ("0"b), 2 highest_ci init ("0"b), 2 concurrency_switch init ("0"b), 2 rollback_switch init ("0"b), 2 protected_switch init ("0"b) ) bit (1) unaligned; %page; dcl 1 length_options int static, /* for -length */ (2 primary_name init ("0"b), 2 names init ("0"b), 2 type init ("0"b), 2 link_path init ("0"b), 2 unique_id init ("0"b), 2 dtu init ("0"b), 2 dtcm init ("0"b), 2 dtem init ("0"b), 2 dtd init ("0"b), 2 dtvd init ("0"b), 2 author init ("0"b), 2 bc_author init ("0"b), 2 logical_volume init ("0"b), 2 bit_count init ("1"b), 2 records_used init ("1"b), 2 current_length init ("1"b), 2 max_length init ("1"b), 2 mode init ("0"b), 2 access_class init ("0"b), 2 ring_brackets init ("0"b), 2 safety_switch init ("0"b), 2 copy_switch init ("0"b), 2 audit_switch init ("0"b), 2 ivds init ("0"b), 2 cvds init ("0"b), 2 usage_count init ("0"b), 2 damaged_switch init ("0"b), 2 synchronized_switch init ("0"b), 2 entry_bound init ("0"b), 2 highest_ci init ("0"b), 2 concurrency_switch init ("0"b), 2 rollback_switch init ("0"b), 2 protected_sw init ("0"b) ) bit (1) unaligned; %page; dcl 1 active_function_length_options int static, /* for -length */ (2 primary_name init ("0"b), 2 names init ("0"b), 2 type init ("0"b), 2 link_path init ("0"b), 2 unique_id init ("0"b), 2 dtu init ("0"b), 2 dtcm init ("0"b), 2 dtem init ("0"b), 2 dtd init ("0"b), 2 dtvd init ("0"b), 2 author init ("0"b), 2 bc_author init ("0"b), 2 logical_volume init ("0"b), 2 bit_count init ("1"b), /* for directory type only */ 2 records_used init ("0"b), 2 current_length init ("1"b), /* for other types such as segment or MSF or DM file */ 2 max_length init ("0"b), 2 mode init ("0"b), 2 access_class init ("0"b), 2 ring_brackets init ("0"b), 2 safety_switch init ("0"b), 2 copy_switch init ("0"b), 2 audit_switch init ("0"b), 2 ivds init ("0"b), 2 cvds init ("0"b), 2 usage_count init ("0"b), 2 damaged_switch init ("0"b), 2 synchronized_switch init ("0"b), 2 entry_bound init ("0"b), 2 highest_ci init ("0"b), 2 concurrency_switch init ("0"b), 2 rollback_switch init ("0"b), 2 protected_sw init ("0"b) ) bit (1) unaligned; %page; dcl 1 default_options int static, /* no control arguments specified */ (2 primary_name init ("0"b), 2 names init ("1"b), 2 type init ("1"b), 2 link_path init ("1"b), 2 unique_id init ("0"b), 2 dtu init ("1"b), 2 dtcm init ("1"b), 2 dtem init ("1"b), 2 dtd init ("0"b), 2 dtvd init ("0"b), 2 author init ("0"b), 2 bc_author init ("0"b), 2 logical_volume init ("0"b), 2 bit_count init ("1"b), 2 records_used init ("1"b), 2 current_length init ("0"b), 2 max_length init ("0"b), 2 mode init ("1"b), 2 access_class init ("0"b), 2 ring_brackets init ("0"b), 2 safety_switch init ("0"b), 2 copy_switch init ("0"b), 2 audit_switch init ("0"b), 2 ivds init ("0"b), 2 cvds init ("0"b), 2 usage_count init ("0"b), 2 damaged_switch init ("1"b), 2 synchronized_switch init ("0"b), 2 entry_bound init ("0"b), 2 highest_ci init ("1"b), 2 concurrency_switch init ("1"b), 2 rollback_switch init ("1"b), 2 protected_switch init ("1"b) ) bit (1) unaligned; %page; dcl 1 no_s_options int static, /* attributes available without s access */ (2 primary_name init ("0"b), 2 names init ("0"b), 2 type init ("1"b), 2 link_path init ("1"b), 2 unique_id init ("1"b), 2 dtu init ("1"b), 2 dtcm init ("1"b), 2 dtem init ("1"b), 2 dtd init ("1"b), 2 dtvd init ("1"b), 2 author init ("1"b), 2 bc_author init ("1"b), 2 logical_volume init ("1"b), 2 bit_count init ("1"b), 2 records_used init ("1"b), 2 current_length init ("1"b), 2 max_length init ("1"b), 2 mode init ("1"b), 2 access_class init ("1"b), 2 ring_brackets init ("1"b), 2 safety_switch init ("1"b), 2 copy_switch init ("1"b), 2 audit_switch init ("1"b), 2 ivds init ("1"b), 2 cvds init ("1"b), 2 usage_count init ("1"b), 2 damaged_switch init ("1"b), 2 synchronized_switch init ("1"b), 2 entry_bound init ("1"b), 2 highest_ci init ("1"b), 2 concurrency_switch init ("1"b), 2 rollback_switch init ("1"b), 2 protected_switch init ("1"b) ) bit (1) unaligned; %page; dcl 1 off_line_options int static, /* attributes available without VTOC */ (2 primary_name init ("1"b), 2 names init ("1"b), 2 type init ("1"b), 2 link_path init ("1"b), 2 unique_id init ("1"b), 2 dtu init ("0"b), 2 dtcm init ("0"b), 2 dtem init ("1"b), 2 dtd init ("1"b), 2 dtvd init ("0"b), 2 author init ("1"b), 2 bc_author init ("1"b), 2 logical_volume init ("1"b), 2 bit_count init ("1"b), 2 records_used init ("0"b), 2 current_length init ("0"b), 2 max_length init ("1"b), 2 mode init ("1"b), 2 access_class init ("1"b), 2 ring_brackets init ("1"b), 2 safety_switch init ("1"b), 2 copy_switch init ("1"b), 2 audit_switch init ("1"b), 2 ivds init ("0"b), 2 cvds init ("0"b), 2 usage_count init ("0"b), 2 damaged_switch init ("0"b), 2 synchronized_switch init ("0"b), 2 entry_bound init ("1"b), 2 highest_ci init ("0"b), 2 concurrency_switch init ("0"b), 2 rollback_switch init ("0"b), 2 protected_switch init ("0"b) ) bit (1) unaligned; %page; dcl 1 link_options int static, /* attributes valid for links */ (2 primary_name init ("1"b), 2 names init ("1"b), 2 type init ("1"b), 2 link_path init ("1"b), 2 unique_id init ("0"b), 2 dtu init ("0"b), 2 dtcm init ("0"b), 2 dtem init ("1"b), 2 dtd init ("1"b), 2 dtvd init ("1"b), 2 author init ("1"b), 2 bc_author init ("0"b), 2 logical_volume init ("0"b), 2 bit_count init ("0"b), 2 records_used init ("0"b), 2 current_length init ("0"b), 2 max_length init ("0"b), 2 mode init ("0"b), 2 access_class init ("0"b), 2 ring_brackets init ("0"b), 2 safety_switch init ("0"b), 2 copy_switch init ("0"b), 2 audit_switch init ("0"b), 2 ivds init ("0"b), 2 cvds init ("0"b), 2 usage_count init ("0"b), 2 damaged_switch init ("0"b), 2 synchronized_switch init ("0"b), 2 entry_bound init ("0"b), 2 highest_ci init ("0"b), 2 concurrency_switch init ("0"b), 2 rollback_switch init ("0"b), 2 protected_switch init ("0"b) ) bit (1) unaligned; %page; dcl 1 nonlink_options int static, /* attributes valid for non-links */ (2 primary_name init ("1"b), 2 names init ("1"b), 2 type init ("1"b), 2 link_path init ("0"b), 2 unique_id init ("1"b), 2 dtu init ("1"b), 2 dtcm init ("1"b), 2 dtem init ("1"b), 2 dtd init ("1"b), 2 dtvd init ("1"b), 2 author init ("1"b), 2 bc_author init ("1"b), 2 logical_volume init ("1"b), 2 bit_count init ("1"b), 2 records_used init ("1"b), 2 current_length init ("1"b), 2 max_length init ("1"b), 2 mode init ("1"b), 2 access_class init ("1"b), 2 ring_brackets init ("1"b), 2 safety_switch init ("1"b), 2 copy_switch init ("1"b), 2 audit_switch init ("1"b), 2 ivds init ("1"b), 2 cvds init ("1"b), 2 usage_count init ("1"b), 2 damaged_switch init ("1"b), 2 synchronized_switch init ("1"b), 2 entry_bound init ("1"b), 2 highest_ci init ("1"b), 2 concurrency_switch init ("1"b), 2 rollback_switch init ("1"b), 2 protected_switch init ("1"b) ) bit (1) unaligned; %page; dcl 1 dm_file_options int static, /* attributes valid for DM files */ (2 primary_name init ("1"b), 2 names init ("1"b), 2 type init ("1"b), 2 link_path init ("0"b), 2 unique_id init ("1"b), 2 dtu init ("1"b), 2 dtcm init ("1"b), 2 dtem init ("1"b), 2 dtd init ("1"b), 2 dtvd init ("1"b), 2 author init ("1"b), 2 bc_author init ("0"b), 2 logical_volume init ("1"b), 2 bit_count init ("0"b), 2 records_used init ("1"b), 2 current_length init ("1"b), 2 max_length init ("1"b), 2 mode init ("1"b), 2 access_class init ("1"b), 2 ring_brackets init ("1"b), 2 safety_switch init ("0"b), 2 copy_switch init ("0"b), 2 audit_switch init ("0"b), 2 ivds init ("0"b), 2 cvds init ("0"b), 2 usage_count init ("0"b), 2 damaged_switch init ("0"b), 2 synchronized_switch init ("0"b), 2 entry_bound init ("0"b), 2 highest_ci init ("1"b), 2 concurrency_switch init ("1"b), 2 rollback_switch init ("1"b), 2 protected_switch init ("1"b) ) bit (1) unaligned; %page; dcl 1 fm_status_options int static, /* DM file attr's requiring file_manager_$status */ (2 primary_name init ("0"b), 2 names init ("0"b), 2 type init ("0"b), 2 link_path init ("0"b), 2 unique_id init ("1"b), 2 dtu init ("0"b), 2 dtcm init ("0"b), 2 dtem init ("0"b), 2 dtd init ("0"b), 2 dtvd init ("0"b), 2 author init ("0"b), 2 bc_author init ("0"b), 2 logical_volume init ("0"b), 2 bit_count init ("0"b), 2 records_used init ("0"b), 2 current_length init ("0"b), 2 max_length init ("0"b), 2 mode init ("1"b), 2 access_class init ("0"b), 2 ring_brackets init ("1"b), 2 safety_switch init ("0"b), 2 copy_switch init ("0"b), 2 audit_switch init ("0"b), 2 ivds init ("0"b), 2 cvds init ("0"b), 2 usage_count init ("0"b), 2 damaged_switch init ("0"b), 2 synchronized_switch init ("0"b), 2 entry_bound init ("0"b), 2 highest_ci init ("1"b), 2 concurrency_switch init ("1"b), 2 rollback_switch init ("1"b), 2 protected_switch init ("1"b) ) bit (1) unaligned; %page; dcl 1 root_options int static, /* attributes available for the root */ (2 primary_name init ("1"b), 2 names init ("1"b), 2 type init ("1"b), 2 link_path init ("0"b), 2 unique_id init ("1"b), 2 dtu init ("1"b), 2 dtcm init ("0"b), 2 dtem init ("0"b), 2 dtd init ("0"b), 2 dtvd init ("0"b), 2 author init ("1"b), 2 bc_author init ("1"b), 2 logical_volume init ("1"b), 2 bit_count init ("1"b), 2 records_used init ("0"b), 2 current_length init ("0"b), 2 max_length init ("0"b), 2 mode init ("1"b), 2 access_class init ("0"b), 2 ring_brackets init ("1"b), 2 safety_switch init ("1"b), 2 copy_switch init ("0"b), 2 audit_switch init ("0"b), 2 ivds init ("0"b), 2 cvds init ("0"b), 2 usage_count init ("0"b), 2 damaged_switch init ("1"b), 2 synchronized_switch init ("0"b), 2 entry_bound init ("0"b), 2 highest_ci init ("0"b), 2 concurrency_switch init ("0"b), 2 rollback_switch init ("0"b), 2 protected_switch init ("0"b) ) bit (1) unaligned; %page; dcl 1 typed_options int static, /* attributes that must come from fs_util_ */ (2 primary_name init ("0"b), 2 names init ("0"b), 2 type init ("1"b), 2 link_path init ("0"b), 2 unique_id init ("0"b), 2 dtu init ("0"b), 2 dtcm init ("0"b), 2 dtem init ("0"b), 2 dtd init ("0"b), 2 dtvd init ("0"b), 2 author init ("0"b), 2 bc_author init ("0"b), 2 logical_volume init ("0"b), 2 bit_count init ("0"b), 2 records_used init ("0"b), 2 current_length init ("0"b), 2 max_length init ("1"b), 2 mode init ("1"b), 2 access_class init ("0"b), 2 ring_brackets init ("1"b), 2 safety_switch init ("1"b), 2 copy_switch init ("1"b), 2 audit_switch init ("1"b), 2 ivds init ("1"b), 2 cvds init ("1"b), 2 usage_count init ("0"b), 2 damaged_switch init ("1"b), 2 synchronized_switch init ("1"b), 2 entry_bound init ("0"b), 2 highest_ci init ("1"b), 2 concurrency_switch init ("1"b), 2 no_rollback_sw init ("1"b), 2 protected_switch init ("1"b) ) bit (1) unaligned; %page; %include branch_status; %page; %include copy_flags; %page; %include dm_file_status; %page; %include star_structures; %page; %include status_for_backup; %page; %include suffix_info; end status;  truncate.pl1 03/07/85 1017.7r w 03/06/85 1230.1 77706 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ truncate: tc: proc; /* This command is used to truncate a specified segment to a specified word offset. the segment to be truncated is referred to either by a pathname or an octal segment number. The second argument is the length to which the segment is to be truncated. If no offset is supplied, zero will be assumed. Written by Robert S. Coren Sept 1972 Modified Nov 1983 by Charles Spitzer. make work on consistent MSFs. */ /* entry declarations */ dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)); dcl cv_oct_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35)); dcl com_err_ entry options(variable); dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl hcs_$get_safety_sw_seg entry (ptr, bit (1), fixed bin (35)); dcl hcs_$truncate_file entry (char(*), char(*), fixed bin(19), fixed bin(35)); dcl hcs_$truncate_seg entry (ptr, fixed bin(19), fixed bin(35)); dcl hcs_$set_bc entry (char(*), char(*), fixed bin(24), fixed bin(35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35)); /* external refs */ dcl (error_table_$noarg, error_table_$dirseg, error_table_$noentry, error_table_$inconsistent_msf) fixed bin(35) ext static; /* static */ dcl myname char (32) int static options (constant) init ("truncate"); /* fixed binary */ dcl alen fixed bin(21); /* length of currently examined argument */ dcl code fixed bin(35); /* status code */ dcl bitcnt fixed bin(24);/* new bit count */ dcl nwords fixed bin(19);/* new length in words */ dcl i fixed bin; /* argument counter */ dcl segno fixed bin; /* pointers */ dcl aptr ptr; /* pointer to latest argument */ dcl segptr ptr; /* pointer to segment if number coded */ dcl (baseptr,char,divide,ltrim,null) builtin; /* character strings */ dcl dir char(168); dcl ent char(32); dcl arg char(alen) based(aptr); dcl argsave char(168) init(" "); /* labels */ dcl callpt label local; /******************** code begins here ***********************/ i = 1; call cu_$arg_ptr(i,aptr,alen,code); if code = error_table_$noarg|alen = 0 then go to nogood; if arg = "-name" | arg = "-nm" then do; /* Name option */ i = i + 1; /* Next arg is name of segment */ call cu_$arg_ptr(i,aptr,alen,code); if code = error_table_$noarg | alen = 0 then go to nogood; end; else do; /* find out if it's a number */ segno = cv_oct_check_(arg,code); if code = 0 then do; /* it is */ segptr = baseptr(segno); callpt = seg; go to getoff; end; end; /* if it's a name, expand it */ call expand_pathname_(arg,dir,ent,code); if code ^= 0 then do; argsave = arg; go to nogood; end; callpt = file; getoff: argsave = arg; i = i + 1; /* Get offset argument (if any) */ call cu_$arg_ptr(i,aptr,alen,code); if code=0 & alen>0 then do; nwords = cv_oct_check_(arg,code); if code^=0 then go to badarg; bitcnt = nwords*36; end; else do; nwords,bitcnt = 0; /* default is 0 */ end; go to callpt; /********************** actual truncation now *******************/ file: /* pathname given */ call hcs_$truncate_file(dir,ent,nwords,code); if code = 0 then do; call hcs_$set_bc(dir,ent,bitcnt,code); if code ^= 0 then goto nogood; end; else if code = error_table_$dirseg then call truncate_msf; else goto nogood; return; seg: /* segment number given */ call hcs_$truncate_seg(segptr,nwords,code); if code = 0 then do; call hcs_$set_bc_seg(segptr,bitcnt,code); if code = 0 then return; end; /**** ERROR BRANCHES ****/ nogood: call com_err_(code,myname,"^a",argsave); return; badarg: /* Non-numeric offset */ call com_err_(0,myname,"Invalid offset: ^a",arg); return; %page; truncate_msf: proc; dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35)); dcl delete_$ptr entry (ptr, bit(36) aligned, char(*), fixed bin(35)); dcl hcs_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35)); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl cleanup condition; dcl ec fixed bin (35); /* error code */ dcl word_count fixed bin (19); dcl word_count_sum fixed bin (35); dcl path char (168); dcl component fixed bin; dcl (max_component, min_component) fixed bin (24); dcl component_count fixed bin; dcl deleting bit (1) aligned; dcl safety_sw bit (1); dcl error_component fixed bin; path = pathname_ (dir, ent); /* get the number of components. */ call hcs_$star_ (path, "**", 3, null, component_count, (null), (null), ec); if ec ^= 0 then return; begin; dcl segp ptr; dcl msf_bc fixed bin (24); dcl 1 segs (component_count), /* components of the msf */ 2 name char (32), /* component name */ 2 segp ptr, /* ptr to base of component */ 2 bc fixed bin (24); /* bit count of component */ segp, segs.segp (*) = null; on cleanup call msf_cleanup; ec, max_component = 0; do component = 1 by 1 while (ec = 0 & component <= component_count); segs.name (component) = ltrim (char (max_component)); call initiate_file_ (path, segs.name (component), "001"b, segs.segp (component), segs.bc (component), ec); if ec = 0 then max_component = max_component + 1; else error_component = max_component; end; if ec ^= 0 then if ec ^= error_table_$noentry then goto msf_close; if max_component ^= component_count then do; ec = error_table_$inconsistent_msf; /* not enough segments in MSF to match what star_ said */ error_component = 0; goto msf_close; end; word_count_sum, word_count = 0; do component = 1 to max_component; word_count = divide (segs.bc (component) + 35, 36, 24, 0); if word_count_sum + word_count >= nwords then do; /* end the MSF on this component */ msf_bc, min_component = component; /* MSF bit count is highest numbered component */ /* going backwards means we have a valid MSF if we get an abort for any reason */ deleting = "1"b; /* delete components */ do component = max_component to min_component+1 by -1; error_component = component; call hcs_$get_safety_sw_seg (segs.segp (component), safety_sw, ec); if ec ^= 0 then goto msf_close; if ^safety_sw & deleting then do; call delete_$ptr (segs.segp (component), "010101"b, "truncate", ec); segs.segp (component) = null; end; else do; if deleting then do; msf_bc = component;/* how many components to set the bit count of the dir */ deleting = "0"b; /* don't delete any more previous to this one */ end; call terminate_file_ (segs.segp (component), 0, TERM_FILE_TRUNC_BC_TERM, ec); end; if ec ^= 0 then goto msf_close; end; error_component = min_component; call terminate_file_ (segs.segp (min_component), (nwords-word_count_sum)*36, TERM_FILE_TRUNC_BC_TERM, ec); if ec ^= 0 then goto msf_close; error_component = 0; call hcs_$set_bc (dir, ent, msf_bc, ec); goto msf_close; end; else word_count_sum = word_count_sum + word_count; end; /* We reached the end of the MSF before nwords. This is not allowed. Issue an error message and return. */ call com_err_ (0, myname, "Truncation length specified is larger than current length of ^d for ^a.", word_count_sum, path); ec = 0; msf_close: if ec ^= 0 then call com_err_ (ec, myname, "^a^[>^d^]", path, (error_component ^= 0), error_component); call msf_cleanup; msf_cleanup: /* inside begin block */ proc; do component = 1 to component_count; if segs.segp (component) ^= null then call terminate_file_ (segs.segp (component), 0, "0010"b, (0)); end; if segp ^= null then call terminate_file_ (segp, 0, "0010"b, (0)); return; end msf_cleanup; end; /* begin block */ return; end truncate_msf; %include terminate_file; end truncate; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved