adopt_seg.pl1 03/15/89 0839.5r w 03/15/89 0800.8 83565 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ adopt_seg: proc; /* adopt_seg Bernard Greenberg 7/19/77 */ /* Modified by Mike Grady to set ex_ringbrack on adopted dirs 9/79 */ /* Modified by Keith Loepere to set dir_quota 12/84 */ dcl (addr, bit, empty, fixed, null, unspec) builtin; dcl level fixed bin; dcl cu_$level_get entry returns (fixed bin); dcl mdc_$read_disk_table entry (ptr, fixed bin (35)); dcl (error_table_$pvid_not_found, error_table_$root) fixed bin (35) external; dcl (error_table_$action_not_performed, error_table_$not_seg_type) fixed bin (35) ext; dcl sub_entry bit (1); dcl (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35)); dcl hcs_$status_long entry (char (*), char (*), fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$get_access_class entry (char(*), char(*), bit(72) aligned, fixed bin(35)); dcl hc_backup_$retv_append entry (char (*), char (*), ptr, ptr, fixed bin (35)); dcl aim_check_$greater entry (bit(72) aligned, bit(72) aligned) returns(bit(1) aligned); dcl cleanup condition; dcl parent_acc bit (72) aligned; dcl q (1) ptr init (null ()); dcl pvname char (32); dcl i fixed bin; dcl code fixed bin (35); dcl myname char (20) init ("adopt_seg") static options (constant); dcl phcs_$get_vtoce entry (fixed bin, fixed bin, ptr, fixed bin (35)); dcl 1 local_vtoce like vtoce aligned; dcl 1 local_entry like entry aligned; dcl 1 aretv_args like retv_append_args aligned; dcl 1 cbi like create_branch_info aligned; dcl 1 brinfo like branch_status aligned; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl (ioa_, com_err_) entry options (variable); dcl (pvtx, vtocx) fixed bin; dcl xarea area (10000) based (q (1)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl arg char (argl) based (argp); dcl argl fixed bin, argp ptr; dcl pvid bit (36) aligned; dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl apdir char (168), apent char (32); dcl rtrname char (32); dcl aabsname char (168); /* Collect Arguments. */ sub_entry = "0"b; on condition (cleanup) call release_temp_segments_ (myname, q, (0));; call cu_$arg_ptr (1, argp, argl, code); if code ^= 0 then do; usage: call com_err_ (code, myname, "Usage: ^a pvname vtocx newpath", myname); return; end; pvname = arg; call get_pvtx; if code ^= 0 then do; call com_err_ (code, myname, arg); go to nlexit; end; i = 1; call cu_$arg_ptr (2, argp, argl, code); if code ^= 0 then go to usage; vtocx = cv_oct_check_ (arg, code); if code ^= 0 then do; call com_err_ (0, myname, "Bad octal # for VTOC index: ^a.", arg); go to nlexit; end; call cu_$arg_ptr (3, argp, argl, code); if code ^= 0 then go to usage; call expand_pathname_ (arg, aabsname, rtrname, code); if code = 0 then call expand_pathname_ (aabsname, apdir, apent, code); if code ^= 0 then do; call com_err_ (code, myname, arg); go to nlexit; end; /* Validate all paramters, the target directory, and the vtoce. */ process: vtocep = addr (local_vtoce); ep = addr (local_entry); call phcs_$get_vtoce (pvtx, vtocx, vtocep, code); if code ^= 0 then do; if sub_entry then go to rrcode; call com_err_ (code, myname, "Reading vtocx ^o on pvtx ^o.", vtocx, pvtx); go to nlexit; end; if vtoce.uid = "0"b then do; if sub_entry then do; notacted: code = error_table_$action_not_performed; go to rrcode; end; call com_err_ (0, myname, "Vtoce ^o on ^a is free.", vtocx, pvname); go to nlexit; end; xarea = empty (); call hcs_$status_long (apdir, apent, 0, addr (brinfo), q (1), code); if code ^= 0 & code = error_table_$root then brinfo.unique_id = (36)"1"b; /* avoid paging in imp. dependent way. */ else if code ^= 0 then do; if sub_entry then go to rrcode; call com_err_ (code, myname, "^a^[>^]^a", apdir, apdir ^= ">", apent); go to nlexit; end; else if brinfo.type ^= directory_type then do; code = error_table_$not_seg_type; if sub_entry then go to rrcode; call com_err_ (code, myname, "^a is not a directory.", aabsname); go to nlexit; end; do i = 0 to 15; if vtoce.uid_path (i) = "0"b then go to glev; end; glev: i = i - 1; if i = -1 then do; code = error_table_$root; if sub_entry then go to rrcode; call com_err_ (code, myname, "Cannot retrieve the root."); go to nlexit; end; if vtoce.uid_path (i) ^= brinfo.unique_id then do; if sub_entry then go to notacted; call com_err_ (0, myname, "This vtoce is not from ^a.", aabsname); go to nlexit; end; /* Prepare volume backup args, new create_branch info, and new branch image. */ aretv_args.version = RETV_APPEND_ARGS_VERSION_1; aretv_args.level = 1; /* to get multiclass segments */ level = cu_$level_get (); aretv_args.ep = ep; /**** hc_backup_ requires that cbi.user have sma, at the current authorization, and that the access class be <= the max in the retv_append_args */ call hcs_$get_access_class (apdir, apent, parent_acc, code); aretv_args.max_access_authorization = vtoce.access_class; /* has be be greater or equal to cbi.access_class */ aretv_args.access_authorization = parent_acc; /* has to be equal */ aretv_args.link = "0"b; unspec (cbi) = "0"b; cbi.version = create_branch_version_2; cbi.dir_sw = vtoce.dirsw; cbi.chase_sw = "0"b; if code = 0 & aim_check_$greater (vtoce.access_class, parent_acc) then do; cbi.priv_upgrade_sw = "1"b; cbi.parent_ac_sw = "0"b; end; else do; cbi.priv_upgrade_sw = "0"b; cbi.parent_ac_sw = "1"b; end; cbi.mode = "101"b; if cbi.priv_upgrade_sw & ^cbi.dir_sw then cbi.rings (*) = 1; /* Only way to create multi-class seg is ring 1 seg */ else cbi.rings (*) = level; cbi.userid = "Adopter.SysDaemon.z"; if vtoce.dirsw then do; cbi.quota = vtoce.quota (0); cbi.dir_quota = vtoce.quota (1); end; else cbi.bitcnt = 36*1024 * fixed (vtoce.csl, 9); cbi.access_class = vtoce.access_class; unspec (entry) = "0"b; entry.type = seg_type_getter (); entry.bs = "1"b; entry.pvid = pvid; entry.vtocx = vtocx; entry.ring_brackets = bit (fixed (cbi.rings, 3), 3); entry.size = 38; /* Susan says this is right magic # */ entry.nnames = 1; entry.owner = brinfo.unique_id; entry.dtd = "0"b; entry.bc = cbi.bitcnt; entry.dtem = "0"b; entry.uid = vtoce.uid; entry.dirsw = vtoce.dirsw; if entry.dirsw then entry.ex_ring_brackets = bit (fixed (level, 3), 3); call hc_backup_$retv_append (aabsname, rtrname, addr (cbi), addr (aretv_args), code); if sub_entry then do; rrcode: rcode = code; call release_temp_segments_ (myname, q, (0)); return; end; if code ^= 0 then do; call com_err_ (code, myname, "Appending branch for ^a^[>^]^a.", aabsname, aabsname ^= ">", rtrname); go to nlexit; end; call ioa_ ("Appended branch ""^a"" in ^a for uid ^w.", rtrname, aabsname, vtoce.uid); nlexit: call release_temp_segments_ (myname, q, (0)); return; /* */ adopt_seg_: entry (a_dirname, a_ename, a_pvid, a_pvtx, a_vtocx, rcode); dcl a_dirname char (*); dcl a_ename char (*); dcl a_pvid bit (36) aligned; dcl a_pvtx fixed bin; dcl a_vtocx fixed bin; dcl rcode fixed bin (35); sub_entry = "1"b; /* Set subroutine entry sw. */ on condition (cleanup) call release_temp_segments_ (myname, q, (0)); aabsname = a_dirname; rtrname = a_ename; pvid = a_pvid; pvtx = a_pvtx; vtocx = a_vtocx; call get_temp_segments_ (myname, q, code); if code ^= 0 then go to rrcode; call expand_pathname_ (aabsname, apdir, apent, code); if code ^= 0 then go to rrcode; /* Do first split here */ go to process; /* PVTX from DISK_TABLE getter */ get_pvtx: proc; /* Gets pvt index by scanning disk table for pv name. */ call get_temp_segments_ (myname, q, code); if code ^= 0 then do; call com_err_ (code, myname, "Getting temp segment for disk table"); go to nlexit; end; dtp = q (1); call mdc_$read_disk_table (dtp, code); if code ^= 0 then do; call com_err_ (code, myname, "Getting disk table"); go to nlexit; end; do pvtx = 1 to dt.n_entries; if dt.array (pvtx).pvname = pvname & dt.array (pvtx).used then do; pvid = dt.array (pvtx).pvid; return; end; end; code = error_table_$pvid_not_found ; end; /* */ %include create_branch_info; %include retv_append_args; %include vtoce; %include disk_table; %include branch_status; %include dir_entry; seg_type_getter: proc () returns (bit (18)); /* This is here to avoid include file name conflict on link_type */ return (SEG_TYPE); %include fs_types; end; end;  clear_partition.pl1 03/07/85 1000.3r 03/06/85 1213.0 55692 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ clear_partition: procedure () options (variable); /* * Command to clear a disk partition. * * clear_partition Pvname Partition_name * * 10/21/80, W. Olin Sibert * 1/31/85, Keith Loepere, for real error codes. */ dcl ap pointer; dcl al fixed bin (21); dcl arg char (al) based (ap); dcl code fixed bin (35); dcl (nargs, argno) fixed bin; dcl af_sw bit (1) aligned; dcl brief_sw bit (1) aligned; dcl answer char (4) varying; dcl pvname char (32); dcl part_name char (4); dcl pvid bit (36) aligned; dcl pattern_value fixed bin (35); dcl pattern_word bit (36) aligned; dcl pattern_page (1024) bit (36) aligned; dcl idx fixed bin fixed bin; dcl com_err_ entry options (variable); dcl command_query_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl dump_segment_ entry (pointer, pointer, fixed bin, fixed bin (35), fixed bin (18), bit (*)); dcl hphcs_$read_partition entry (bit (36) aligned, char (*), fixed bin (35), pointer, fixed bin (18), fixed bin (35)); dcl hphcs_$write_partition entry (bit (36) aligned, char (*), fixed bin (35), pointer, fixed bin (18), fixed bin (35)); dcl ioa_ entry options (variable); dcl mdc_$pvname_info entry (char (*), bit (36) aligned, char (*), bit (36) aligned, fixed bin, fixed bin (35)); dcl (error_table_$badopt, error_table_$noarg, error_table_$too_many_args, error_table_$bigarg, error_table_$out_of_bounds, error_table_$bad_conversion) fixed bin (35) external static; dcl WHOAMI char (32) internal static options (constant) init ("clear_partition"); dcl linkage_error condition; dcl (addr, char, hbound, length, maxlength, null, size, string, substr) builtin; /* */ pvname = ""; part_name = ""; brief_sw = "0"b; pattern_word = ""b; call cu_$arg_count (nargs, code); if code ^= 0 then do; call com_err_ (code, WHOAMI); RETURN: return; end; do argno = 1 to nargs; call cu_$arg_ptr (argno, ap, al, (0)); if (arg = "-pattern") then do; if argno = nargs then do; call com_err_ (error_table_$noarg, WHOAMI, "After ^a", arg); goto RETURN; end; argno = argno + 1; call cu_$arg_ptr (argno, ap, al, (0)); pattern_value = cv_oct_check_ (arg, code); if code ^= 0 then do; call com_err_ (error_table_$bad_conversion, WHOAMI, "Pattern must be an octal number, not ^a", arg); goto RETURN; end; pattern_word = unspec (pattern_value); end; else if (arg = "-long") | (arg = "-lg") then brief_sw = "0"b; else if (arg = "-brief") | (arg = "-bf") then brief_sw = "1"b; else if char (arg, 1) = "-" then do; call com_err_ (error_table_$badopt, WHOAMI, "^a", arg); goto RETURN; end; else if pvname = "" then /* first arg is volume name */ pvname = arg; else if part_name = "" then do; /* second arg is partition name */ if length (rtrim (arg)) > maxlength (part_name) then do; call com_err_ (error_table_$bigarg, WHOAMI, "Partition name must be ^d characters or less. ^a", maxlength (part_name), arg); goto RETURN; end; part_name = rtrim (arg); end; else do; code = error_table_$too_many_args; goto USAGE; end; end; /* of argument loop */ if part_name = "" then do; code = error_table_$noarg; USAGE: call com_err_ (code, WHOAMI, "^/Usage:^-^a pvname part_name {-control_args}", WHOAMI); goto RETURN; end; /* */ call mdc_$pvname_info (pvname, pvid, (""), (""b), (0), code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "^a", pvname); goto RETURN; end; on condition (linkage_error) begin; /* exit gracefully */ call com_err_ (0, WHOAMI, "This opertaion requires privileged access (hphcs_) not given to this process."); goto RETURN; /* and punt */ end; call hphcs_$read_partition (pvid, part_name, 0, addr (pattern_page), size (pattern_page), code); revert condition (linkage_error); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot read partition ^a on ^a.", part_name, pvname); goto RETURN; end; query_info.yes_or_no_sw = "1"b; if brief_sw then call command_query_ (addr (query_info), answer, WHOAMI, "Do you wish to overwrite partition ^a on ^a?", part_name, pvname); else call command_query_ (addr (query_info), answer, WHOAMI, "Partition ^a on ^a begins with:^/^3x^4(^w^x^)^/^3x^4(^w^x^)^/Do you wish to overwrite it?", part_name, pvname, pattern_page (1), pattern_page (2), pattern_page (3), pattern_page (4), pattern_page (5), pattern_page (6), pattern_page (7), pattern_page (8)); if (answer ^= "yes") then /* He chickened out */ goto RETURN; pattern_page (*) = pattern_word; /* fill it in */ do idx = 0 by 1; /* and go to it */ call hphcs_$write_partition (pvid, part_name, (idx * 1024), addr (pattern_page), size (pattern_page), code); if code = error_table_$out_of_bounds then /* All done */ goto FINISHED; else if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot write record ^d to partition ^a on ^a. Aborting", (idx - 1), part_name, pvname); goto RETURN; end; end; /* of loop writing records */ FINISHED: if ^brief_sw then call ioa_ ("^a: Cleared partition ^a on ^a (^d. records)^[, with pattern ^w^].", WHOAMI, part_name, pvname, idx, (pattern_word ^= ""b), pattern_word); goto RETURN; /* all done */ %page; %include query_info; end clear_partition;  delete_old_pdds.pl1 03/20/87 1347.3rew 03/20/87 1346.7 88938 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-01-02,TLNguyen), approve(87-01-02,MCR7594), audit(87-01-08,Blair), install(87-03-20,MR12.1-1007): Fixed bug which occurs when delete_old_pdds creates two temporary segments but it does not release them when it finishes. END HISTORY COMMENTS */ /* format: style2,indcomtxt,idind25 */ delete_old_pdds: procedure options (variable); /* DPDD cleans out old copies of process_dir_dir */ /* Made more robust by C. Hornig, December 1980 */ /* Made useable from non-Initializer processes, M.Pierret July 1981 */ /* Made to delete old >sl1's too by C. Hornig, March 1982 */ /* 84-01-16 BIM. Explicit salvage to shut up the online salvager. soos privilege. */ dcl code fixed bin (35); dcl a_time fixed bin (71); dcl saved_quota uns fixed bin (18); dcl areap ptr; dcl (ap, ap1) pointer; dcl (al, al1) fixed bin; dcl arg char (al) based (ap); dcl arg1 char (al1) based (ap1); dcl (argno, nargs) fixed bin; dcl (first_count, last_count) fixed bin; dcl soos_priv_code fixed bin (35); /* zero implies turn it off */ dcl tsps (2) pointer; dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl get_privileges_ entry () returns (bit (36) aligned); dcl get_temp_segments_ entry (character (*), (*) pointer, fixed binary (35)); dcl release_temp_segments_ entry (character (*), (*) pointer, fixed binary (35)); dcl hphcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl system_privilege_$soos_priv_on entry (fixed bin (35)); dcl system_privilege_$soos_priv_off entry (fixed bin (35)); dcl system_privilege_$check_mode_reset entry (char (*), char (*), fixed bin (35)); dcl hphcs_$delentry_file entry (char (*), char (*), fixed bin (35)); dcl hphcs_$quota_read entry (char (*), uns fixed bin (18), fixed bin (71), bit (36), fixed bin, fixed bin (1), fixed bin, fixed bin (35)); dcl hphcs_$quota_set entry (char (*), uns fixed bin (18), fixed bin (35)); dcl hphcs_$salv_directory entry (ptr, char (*) var, ptr, fixed bin, fixed bin (35)); dcl com_err_ entry options (variable); dcl ( error_table_$nomatch, error_table_$bad_conversion, error_table_$noarg, error_table_$badopt, error_table_$inconsistent ) fixed bin (35) ext; dcl whoami char (32) internal static options (constant) init ("delete_old_pdds"); dcl (cleanup, seg_fault_error) condition; dcl (length, null, reverse, substr, sum, verify) builtin; tsps = null (); soos_priv_code = -1; on cleanup call clean_up (); if (get_privileges_ () & SOOS_PRIVILEGE) = ""b then do; call system_privilege_$soos_priv_on (soos_priv_code); if soos_priv_code ^= 0 then call com_err_ (soos_priv_code, whoami, "Warning: could not enable SOOS privilege."); end; first_count, last_count = -1; /* default initial values */ call cu_$arg_count (nargs, code); if code ^= 0 then do; call com_err_ (code, whoami, "Usage: delete_old_pdds {-exclude_first Ndirs -exclude_last Ndirs}"); return; end; do argno = 1 to nargs; call cu_$arg_ptr (argno, ap, al, code); if /* case */ arg = "-exclude_first" then do; if first_count >= 0 then do; ONLY_ONCE: call com_err_ (error_table_$inconsistent, whoami, "The ^a control argument may only be specified once.", arg); return; end; if argno = nargs then do; NEED_NUMBER: call com_err_ (error_table_$noarg, whoami, "The ^a control argument must be followed by a number.", arg); return; end; argno = argno + 1; call cu_$arg_ptr (argno, ap1, al1, code); first_count = cv_dec_check_ (arg1, code); if code ^= 0 | first_count < 0 then do; /* negative numbers not allowed, either */ NEED_GOOD_NUMBER: call com_err_ (error_table_$bad_conversion, whoami, "The ^a control argument must be followed by a non-negative number, not ""^a"".", arg, arg1); return; end; end; /* of processing for -first */ else if arg = "-exclude_last" then do; if last_count >= 0 then goto ONLY_ONCE; if argno = nargs then goto NEED_NUMBER; argno = argno + 1; call cu_$arg_ptr (argno, ap1, al1, code); last_count = cv_dec_check_ (arg1, code); if code ^= 0 | last_count < 0 then goto NEED_GOOD_NUMBER; end; else do; call com_err_ (error_table_$badopt, whoami, "^a", arg); return; end; end; /* of argument processing */ if first_count < 0 then first_count = 0; /* apply defaults */ if last_count < 0 then last_count = 0; areap = get_system_free_area_ (); saved_quota = 0; /* set up for recovery */ call hphcs_$quota_read (">", saved_quota, (0), ("0"b), (0), (0), (0), code); if code ^= 0 then do; call com_err_ (code, whoami, "getting root quota"); return; end; a_time = clock (); call get_temp_segments_ (whoami, tsps, (0)); SA.temp1_ptr = tsps (1); SA.temp2_ptr = tsps (2); SA.salv_time = substr (unspec (a_time), 21, 36); SA.options = "0"b; SA.options.delete_connection_failure = "1"b; SA.options.force_rebuild = "1"b; SA.options.check_vtoce = "1"b; SA.branch_ptr = null (); SA.current_length = 0; SA.master_dir_uid = ""b; call do_it ("pdd"); call do_it ("sl1"); if saved_quota > 0 then call hphcs_$quota_set (">", saved_quota, code); call clean_up (); %page; clean_up: procedure (); if soos_priv_code = 0 then do; call system_privilege_$soos_priv_off (code); if code = 0 then soos_priv_code = -1; if code ^= 0 then call com_err_ (code, whoami, "Failed to reset soos priv."); end; if tsps (1) ^= null () then call release_temp_segments_ (whoami, tsps, (0)); return; end clean_up; %page; do_it: procedure (Dir); dcl Dir char (*) parameter; dcl i fixed bin; dcl ename char (32); star_entry_ptr, star_names_ptr = null (); call hphcs_$star_ (">", rtrim (Dir) || ".!??????????????", star_ALL_ENTRIES, areap, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then do; if code ^= error_table_$nomatch then call com_err_ (code, whoami, "listing root"); return; end; do i = first_count + 1 to star_entry_count - last_count; /* delete only those not excluded */ ename = star_names (star_entries (i).nindex); call deldir (">", ename, code); if code ^= 0 then call com_err_ (code, whoami, "Unable to delete >^a", ename); end; done_it: if star_names_ptr ^= null () then free star_names; if star_entry_ptr ^= null () then free star_entries; return; %include star_structures; end do_it; deldir: procedure (a_dn, a_en, code); dcl (a_dn, a_en) char (*) parameter; dcl code fixed bin (35) parameter; dcl dn char (168); dcl en char (32); dcl dnen char (168); dcl ename char (32); dcl j fixed bin; dn = a_dn; en = a_en; if dn = ">" then dnen = ">" || en; else dnen = rtrim (dn) || ">" || en; SA.pathname = dnen; call hphcs_$salv_directory (addr (SA), "", null (), (0), code); if code ^= 0 then do; call com_err_ (code, whoami, "Unable to salvage ^a. Will attempt to delete it.", SA.pathname); go to DELETE_TOP; /* skip starnaming */ end; on seg_fault_error goto connection_failure; call system_privilege_$check_mode_reset (dn, en, code); star_entry_ptr, star_names_ptr = null (); call hphcs_$star_ (dnen, "**", star_ALL_ENTRIES, areap, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= error_table_$nomatch then do; if code ^= 0 then call com_err_ (code, whoami, "^a", dnen); else do j = 1 to star_entry_count; ename = star_names (star_entries (j).nindex); if /* case */ star_entries (j).type = star_SEGMENT then do; call system_privilege_$check_mode_reset (dnen, ename, code); call hphcs_$delentry_file (dnen, ename, code); end; else if star_entries (j).type = star_DIRECTORY then do; call system_privilege_$check_mode_reset (dnen, ename, code); call deldir (dnen, ename, code); end; else do; /* link */ call hphcs_$delentry_file (dnen, ename, code); end; if code ^= 0 then call com_err_ (code, whoami, "^a>^a", dnen, ename); end; if star_names_ptr ^= null () then free star_names; if star_entry_ptr ^= null () then free star_entries; end; connection_failure: DELETE_TOP: call hphcs_$quota_set (dnen, 1, code); call hphcs_$delentry_file (dn, en, code); return; %include star_structures; end deldir; %page; %include aim_privileges; %include salv_args; declare 1 SA aligned like salv_args; end delete_old_pdds;  do_subtree.pl1 11/15/82 1853.9rew 11/15/82 1519.5 251532 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ dos: do_subtree: proc; /* (walk_subtree) Initially coded in September 1969 by V. Voydock */ /* Converted to pl1 in May 1970 by V. Voydock */ /* Modified on May 4, 1970 at 12:25 midnight by V. Voydock */ /* Modified on January 4, 1971 (to add pi handler) by V. Voydock */ /* Modified on July 8, 1971 by J. Stern Command name changed from "global" to "execute_in_subdirectories". Command format and options changed ("-bottom_up" option added). */ /* Modified Dec 13 1973 by S. Herbst Converted to Version II Names changed to walk_subtree and ws_recursive. Var. length temporary command line. */ /* Bugs fixed 12/9/75 by Steve Herbst: walking through MSF's and cwd in command line changing walk */ /* do_subtree built off this umble base, multiprocess circus Just about all of previous "improvements" thrown away, and just about every line changed or recoded somehow, BSG, magister multicis 2/20/77 */ dcl (cleanup, da_err_1_, undispatch_err_1_) condition; dcl starting_dir char (168); dcl temp_dname char (168); dcl working_dir char (168); dcl command_line char (clng) based (cp), bu_command_line char (buclng) based (buclp), starting_node char (slng) based (sp), /* starting node of subtree of subdirectories */ arg char (lng) based (ap), b36 bit (36) based aligned, myname char (15) static options (constant) init ("do_subtree"), procpicvar pic "99" init (0); /* Varying for &2 */ dcl (lng, clng, buclng, slng) fixed bin init (0); /* various lengths for indirect strings */ dcl (level init (0), first_level init (1), last_level init (999)) fixed bin; dcl i fixed bin; dcl (nnn, code) fixed bin (35); /* This set of flags is initialized from the command line in master process, or only process if that is the case. They are picked up from com seg for slave procs. */ dcl (bottom_up_flag init ("0"b), /* 1 => exists bottomup comline */ f_option_flag init ("0"b), /* 1 => -first was used */ top_down_flag init ("0"b), /* 1 => exists topdown comline */ trace_flag init ("0"b), /* 1 => print pathnames (default) */ privf init ("0"b), /* 1 => call hphcs_ instead of hcs_ star */ msff init ("0"b) /* 1 => treat msfs not as dirs */ ) bit (1) aligned; dcl abort_entry bit (1) aligned init ("0"b); dcl (ap, arp, cp, sp, buclp) ptr init (null ()); dcl tem_ area based (arp); dcl error_table_$badopt ext fixed bin (35); dcl error_table_$noarg ext fixed bin (35); dcl (addr, fixed, null, substr, stacq) builtin, cv_dec_check_ external entry (char (*), fixed bin (35)) returns (fixed bin (35)), cu_$arg_ptr ext entry (fixed bin (17), ptr, fixed bin (17), fixed bin (35)), cu_$arg_count ext entry (fixed bin (17)), get_system_free_area_ ext entry returns (ptr), get_wdir_ external entry returns (char (168)), ioa_ ext entry options (variable), com_err_ ext entry options (variable); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); /* */ /* Stuff for multiprocess feature */ dcl 1 mpdata based (mpdatap) aligned, /* Element block for one process in circus */ 2 pid bit (36) aligned, /* process id */ 2 wait_list, /* IPC event channel data */ 3 nchan fixed bin, /* 1 */ 3 evchn fixed bin (71), /* Event channel on which to wake this px */ 2 px fixed bin, /* process index (in array ) */ 2 gostac bit (36) aligned, /* Set NZ to "grab" px for dispatch */ 2 data_avl bit (36) aligned, /* set when data available */ 2 uid (-1:15) fixed bin, /* "cnt" for directories */ 2 slevel fixed bin, /* starting "-ft" level */ 2 shlev fixed bin, /* starting hierarchy lev of dispatch */ 2 dname char (168) varying, /* dirname at dispatch */ 2 flags unal, 3 ready bit (1), /* px exists */ 3 died bit (1); /* known to have failed wakeup */ dcl mpdatap ptr; /* process element ptr */ dcl 1 global_mpdata based (gmpdata_p) aligned, /* global com seg for 1 circus */ 2 startctl bit (36) aligned, /* pid of FIRST guy to join circus */ 2 cnt fixed bin (35) aligned, /* tag generator for diirectories */ 2 first_hdepth fixed bin, /* starting hierarchy depth */ 2 last_hdepth fixed bin, /* finishing hierarchy depph */ 2 sfirst fixed bin, /* "-first" stuff */ 2 slast fixed bin, /* -last */ 2 global_flags unal, 3 trace_flag bit (1), /* 1 => print pathnames */ 3 top_down_flag bit (1), /* 1 => Exists topdown line */ 3 bottom_up_flag bit (1), /* 1 => exists bottomup line */ 3 msf_flag bit (1), /* 1 => dont walk msfs */ 3 priv_flag bit (1), /* 1 => call hphcs_ */ 2 comlinel fixed bin, /* length of topdown line */ 2 command_line char (300), /* value of topdown line */ 2 bu_comlinel fixed bin, /* length of bottomup line */ 2 bu_comline char (300), /* value of bottomup line */ 2 stopflags unal, 3 eoj bit (1), /* All dirs have been exited => job done */ 3 abort bit (1), /* GET OUT OF WATER FAST! */ 2 nprocs fixed bin (35) aligned, /* current number of px's */ 2 meters, 3 executions fixed bin, 3 dxeqs fixed bin, 3 recursions fixed bin, 3 pickups fixed bin, 3 dispatches fixed bin, 3 decursions fixed bin, 3 getworks fixed bin, 3 wakeups fixed bin, 3 blocks fixed bin, 2 perprocess (36) like mpdata aligned, /* Array of process elements */ 2 dir_table (1 : global_mpdata.cnt), /* indexed by cnt-generated index */ 3 procbits (36) bit (1) unaligned; /* "1"b => process 2sub in dir # 1sub */ dcl b_comline char (global_mpdata.comlinel) based (addr (global_mpdata.command_line)); dcl b_bu_comline char (global_mpdata.bu_comlinel) based (addr (global_mpdata.bu_comline)); dcl gmpdata_p ptr; dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin, ptr, fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)); dcl get_process_id_ entry returns (bit (36) aligned); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl hlev fixed bin; dcl px fixed bin; dcl my_pid bit (36) aligned; dcl event_msg (4) fixed bin (71); dcl my_px fixed bin; dcl my_evchn fixed bin (71); dcl mpf bit (1) init ("0"b); dcl command_process bit (1) init ("1"b); dcl do entry options (variable); /* */ /* Get starting node name */ call cu_$arg_ptr (1, sp, slng, code); if code ^= 0 then do; call com_err_ (code, myname); return; end; /* "-wd" => current working directory */ if starting_node = "-wd" then do; working_dir = get_wdir_ (); sp = addr (working_dir); slng = length (rtrim (working_dir)); end; /* Check for options */ do i = 2 by 1; call cu_$arg_ptr (i, ap, lng, code); if code ^= 0 then go to endopt; /* Identify options */ if arg = "-ft" | arg = "-first" | arg = "-last" | arg = "-lt" then do; f_option_flag = substr (arg, 2, 1) = "f"; i = i + 1; call cu_$arg_ptr (i, ap, lng, code); if code ^= 0 then do; call com_err_ (error_table_$noarg, myname, "Level number missing."); return; end; nnn = cv_dec_check_ (arg, code); if code ^= 0 | nnn <= 0 then do; call com_err_ (0, myname, "Bad level number: ^a.", arg); return; end; if f_option_flag then first_level = nnn; else last_level = nnn; end; else if arg = "-td" | arg = "-top_down" then do; i = i + 1; call cu_$arg_ptr (i, cp, clng, code); if code ^= 0 then do; call com_err_ (error_table_$noarg, myname, "Top-down command line missing."); return; end; top_down_flag = "1"b; end; else if arg = "-bu" | arg = "-bottom_up" then do; i = i + 1; call cu_$arg_ptr (i, buclp, buclng, code); if code ^= 0 then do; call com_err_ (error_table_$noarg, myname, "Bottom-up command line missing."); return; end; bottom_up_flag = "1"b; end; else if arg = "-lg" | arg = "-long" then trace_flag = "1"b; else if arg = "-mp" | arg = "-multiprocess" then mpf = "1"b; else if arg = "-priv" then privf = "1"b; else if arg = "-no_msf" then msff = "1"b; else do; call com_err_ (error_table_$badopt, myname, arg); return; end; end; endopt: /* Control comes here when all arguments have been processed. */ if last_level < first_level then do; code = 0; call com_err_ (0, myname, "Last level (^d) must be >= first level (^d)", last_level, first_level); return; end; /* Get area in which star handler can allocate information */ arp = get_system_free_area_ (); if starting_node = "-slave" then do; command_process = "0"b; starting_dir = starting_node; mpf = "1"b; end; else do; call absolute_pathname_ (starting_node, starting_dir, code); if code ^= 0 then do; call com_err_ (code, myname, starting_node); return; end; end; slng = length (rtrim (starting_dir)); sp = addr (starting_dir); /* bind starting-node to starting_dir */ if mpf then do; call establish_self_mp; if command_process then call recurse$dispatch (starting_node); call multiprocess_ws; end; else call recurse (starting_node); return; ABORT: call com_err_ (0, myname, "Multiprocess abort signalled."); NLX: return; /* */ recurse: proc (node); /* Internal procedure to execute the command line set up in the main body of the program at all specified points of the file system hierarchy */ /* In a single-process execution, this procedure recurses over the whole specified subtree. In multiprocess executions, each dispatched process calls it to recurse over the dispatch point. It always executes the topdown line: the bottom up line must be scheduled. */ dcl node char (*); dcl (np, ep) ptr init (null); dcl dispatch_buf char (168); dcl dispatch_name char (dispatch_namel) based (addr (dispatch_buf)); dcl (k, ecount) fixed bin; dcl cnt fixed bin; dcl ename char (enamel) based (enamep); dcl enamep ptr; dcl (dispatch_namel, enamel) fixed bin; dcl code fixed bin (35); dcl (hcs_$star_, hphcs_$star_) ext entry (char (*), char (*), fixed bin (2), ptr, fixed bin (17), 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 bitcount fixed bin (24), type fixed bin (2); dcl error_table_$no_s_permission ext fixed bin (35); dcl error_table_$nomatch ext fixed bin (35); dcl names (100) char (32) based (np) aligned; dcl 1 ent (ecount) based (ep) aligned, 2 type bit (2) unaligned, 2 nname bit (16) unaligned, 2 nindex fixed bin (17) unaligned; /* */ /* Establish cleanup handler */ on condition (cleanup) begin; if ep ^= null then free ent; if np ^= null then free names; end; /* Push level of recursion */ if mpf then do; global_mpdata.recursions = global_mpdata.recursions + 1; if global_mpdata.abort then go to ABORT; cnt = stacq_countgen (global_mpdata.cnt); /* get dir id */ /* We are provably the first process to encounter this dir. Generate unique index for it */ addr (global_mpdata.dir_table (cnt)) -> b36 = "0"b; /* err 338, 'string a (2, *) not implemented yet' */ dir_table (cnt).procbits (my_px) = "1"b; /* dir goes busy */ mpdata.uid (hlev) = cnt; hlev = hlev + 1; end; level = level+1; /* See if top-down trace is wanted */ if top_down_flag then call executor (command_line); /* If this is last level then skip looking for subdirectories */ if level >= last_level then ecount, code = 0; /* Get list of all subdirectories */ else do; if privf then call hphcs_$star_ (node, "**", 2, arp, ecount, ep, np, code); else call hcs_$star_ (node, "**", 2, arp, ecount, ep, np, code); if code ^= 0 then do; ecount = 0; if code ^= error_table_$nomatch then call com_err_ (code, myname, node); end; end; /* Execute command in all subdirectories which are in range */ do k = 1 to ecount; enamep = addr (names (ent (k).nindex)); enamel = length (rtrim (names (ent (k).nindex))); if is_it_a_dir ((ent (k).type)) then do; dispatch_buf = node; if node = ">" then do; substr (dispatch_buf, 2) = ename; dispatch_namel = 1 + length (ename); end; else do; substr (dispatch_buf, length (node) + 1, 1) = ">"; substr (dispatch_buf, length (node) + 2) = ename; dispatch_namel = length (node) + 1 + length (ename); end; /* Essence of do_subtree work scheduler: If I can't find someone else (now idle) to do it, do it myself. */ if ^dispatch (dispatch_name) then call recurse (dispatch_name); end; end; /* Clear out level flag and do bottom-up xeq */ if mpf then do; if ^dir_busyp (cnt, my_px, "0"b) /* Unmark self from dir, test. */ then if bottom_up_flag then call executor (bu_command_line); /* xec the b_u line iff I am last guy out! */ hlev = hlev - 1; /* Count down hierarchy depth. */ end; else if bottom_up_flag then call executor (bu_command_line); level = level - 1; /* note that executor looks at this */ if ep ^= null then free ent; if np ^= null then free names; return; executor: procedure (com_line); /* exec command right here */ dcl com_line char (*); if level < first_level then return; if trace_flag then call ioa_ ("^-^a", node); call do (com_line, node, procpicvar); if mpf then global_mpdata.executions = global_mpdata.executions + 1; end executor; is_it_a_dir: proc (btype) returns (bit (1)); dcl btype bit (2); if btype ^= "10"b then return ("0"b); if ^msff then return ("1"b); /* This is a silly thing */ call hcs_$status_minf (node, ename, 0, type, bitcount, code); if code ^= 0 then if code ^= error_table_$no_s_permission then do; call com_err_ (code, myname, "^a^[>^]^a", node, node ^= ">", ename); return ("0"b); end; return ((type = 2) & (bitcount = 0)); end is_it_a_dir; /* */ dispatch: proc (s) returns (bit (1) aligned); /* This s/r is called with the name of a directory. It looks for some currently idle process to do it, and returns "1"b if it found someone. Otherwise, returns "0"b. The target process' process element is "loaded" from current process & "cnt". He is marked in dir_table as busy in all the dirs from his dispatch point up. */ dcl s char (*); dcl 1 ampdata like mpdata aligned based (ampdatap); dcl ampdatap ptr; dcl dpx fixed bin; dcl dx fixed bin; if ^mpf then return ("0"b); do dpx = 1 to global_mpdata.nprocs; ampdatap = addr (global_mpdata.perprocess (dpx)); if ampdata.ready then if stac (addr (ampdata.gostac), my_pid) then do; ampdata.dname = s; ampdata.uid = mpdata.uid; ampdata.uid (hlev - 1) = cnt; ampdata.slevel = level; ampdata.shlev = hlev; do dx = global_mpdata.first_hdepth - 1 to hlev - 1; if dir_busyp (ampdata.uid (dx), dpx, "1"b) then; end; if ^stac (addr (ampdata.data_avl), my_pid) then signal da_err_1_; global_mpdata.dispatches = global_mpdata.dispatches + 1; if waker (ampdatap) then return ("1"b); else do dx = global_mpdata.first_hdepth - 1 to hlev - 1; if ^dir_busyp (mpdata.uid (dx), dpx, "0"b) then signal undispatch_err_1_; end; end; end; return ("0"b); end dispatch; recurse$dispatch: entry (node); /* entry to roll the ball */ /* Dispatch the root node. */ hlev = global_mpdata.first_hdepth; cnt = stacq_countgen (global_mpdata.cnt); /* Corresp. to Root node's FATHER */ if ^dispatch (node) then do; call com_err_ (code, myname, "Cannot dispatch root job."); go to NLX; end; return; end recurse; /* This page intentionally left blank */ multiprocess_ws: proc; /* Clear my gostac-word. Wait for work, which will be indicated by data_avl NZ. Load auto vars from process element and global data. Recurse over dispatch point, and decurse up. */ dcl 1 dmpdata like mpdata aligned based (dmpdatap); dcl dmpdatap ptr; dcl upnamel fixed bin, upward_name char (upnamel) based (addr (temp_dname)); getwork: global_mpdata.getworks = global_mpdata.getworks + 1; do while (mpdata.gostac = "0"b & mpdata.data_avl = "0"b); global_mpdata.blocks = global_mpdata.blocks + 1; call ipc_$block (addr (mpdata.wait_list), addr (event_msg), code); if code ^= 0 then do; call com_err_ (code, myname, "From ipc_$block"); mpdata.died = "1"b; return; end; if global_mpdata.abort then go to ABORT; if global_mpdata.eoj then return; end; global_mpdata.pickups = global_mpdata.pickups + 1; trace_flag = global_mpdata.trace_flag; msff = global_mpdata.msf_flag; privf = global_mpdata.priv_flag; bottom_up_flag = global_mpdata.bottom_up_flag; top_down_flag = global_mpdata.top_down_flag; starting_dir = mpdata.dname; level = mpdata.slevel; first_level = global_mpdata.sfirst; last_level = global_mpdata.slast; hlev = mpdata.shlev; sp = addr (starting_dir); slng = length (mpdata.dname); cp = addr (global_mpdata.command_line); clng = global_mpdata.comlinel; buclp = addr (global_mpdata.bu_comline); buclng = global_mpdata.bu_comlinel; call recurse (starting_node); if global_mpdata.abort then go to ABORT; temp_dname = mpdata.dname; upnamel = length (mpdata.dname); /* Go back down looking for directories left upon us to undo. */ do hlev = hlev - 1 by -1 to global_mpdata.first_hdepth; upnamel = max (upnamel - index (reverse (upward_name), ">"), 1); if ^dir_busyp (mpdata.uid (hlev), my_px, "0"b) then do; if bottom_up_flag then do; /* Tollite jugum meum, dixit ad eos */ global_mpdata.dxeqs = global_mpdata.dxeqs + 1; if trace_flag then call ioa_ ("^9x*^a", upward_name); call do (bu_command_line, upward_name, procpicvar); end; global_mpdata.decursions = global_mpdata.decursions + 1; end; end; if ^dir_busyp (mpdata.uid (hlev), my_px, "0"b) then call sig_eoj; /* PL/I leaves behind last val of 'hlev'-1 */ mpdata.data_avl = "0"b; /* need no stacq */ if stacq (mpdata.gostac, "0"b, (mpdata.gostac)) then; /* Leave self open for work */ go to getwork; end multiprocess_ws; waker: proc (xmpdp) returns (bit (1) aligned); /* Send wakeup to px of which xmpdp -> */ dcl 1 xmpd like mpdata based (xmpdp) aligned; dcl xmpdp ptr; call hcs_$wakeup (xmpd.pid, xmpd.evchn, 0, code); global_mpdata.wakeups = global_mpdata.wakeups + 1; if code = 0 then return ("1"b); xmpd.died = "1"b; call com_err_ (code, myname, "Process ^d died while in ^a.", xmpd.px, xmpd.dname); if global_mpdata.abort &^abort_entry then goto ABORT; /* Good place to pick up his burden */ return ("0"b); end waker; establish_self_mp: proc; /* Find the circus' seg. Establish who's first. If this is the command px, fill in automatic parameters into global ones. Initialize my process element. */ dcl save_first_possible bit (36) aligned; call get_com_seg; call get_process_parameters; /* This is for the first guy, whether master or not */ save_first_possible = global_mpdata.startctl; if stac (addr (global_mpdata.startctl), my_pid) then do; /* Are we the FIRST (not nec. Master)? */ global_mpdata.nprocs = 0; global_mpdata.cnt = 0; string (global_mpdata.stopflags) = "0"b; unspec (global_mpdata.meters) = "0"b; end; if command_process then do; /* real starting stuff */ global_mpdata.trace_flag = trace_flag; global_mpdata.msf_flag = msff; global_mpdata.priv_flag = privf; global_mpdata.bottom_up_flag = bottom_up_flag; global_mpdata.top_down_flag = top_down_flag; global_mpdata.comlinel = length (command_line); global_mpdata.command_line = command_line; global_mpdata.bu_comlinel = buclng; global_mpdata.bu_comline = bu_command_line; global_mpdata.first_hdepth = count_greater_thans (starting_node); global_mpdata.last_hdepth = global_mpdata.first_hdepth + last_level - first_level; global_mpdata.sfirst = first_level; global_mpdata.slast = last_level; end; if global_mpdata.nprocs ^< hbound (global_mpdata.dir_table.procbits, 2) then do; if command_process then call com_err_ (0, myname, "Too many slave processes to add master."); else call com_err_ (0, myname, "too many processes to add another."); go to NLX; end; my_px = stacq_countgen (global_mpdata.nprocs); procpicvar = my_px; /* Set for &2 hack */ call ioa_ ("Process ^d in ^a.", my_px, get_wdir_ ()); mpdatap = addr (global_mpdata.perprocess (my_px)); unspec (mpdata) = "0"b; mpdata.pid = my_pid; mpdata.px = my_px; mpdata.nchan = 1; mpdata.evchn = my_evchn; mpdata.ready = "1"b; end establish_self_mp; get_process_parameters: procedure; /* Get ev chan & pid */ call ipc_$create_ev_chn (my_evchn, code); if code ^= 0 then do; call com_err_ (code, myname, "Cannot create event channel."); go to NLX; end; my_pid = get_process_id_ (); return; end get_process_parameters; /* Now comes all the dirt and language apologies. */ dir_busyp: proc (acnt, apx, abit) returns (bit (1) aligned); /* This procedure is the heart of the bottom_up and completion scheduling technique. As "abit" is "0"b or "1"b, respectively, it marks the process whos index is "apx" as out of, or in, respectively, the dir whose index is "acnt". The bit diddling is done unitarily (with stacq), such that it is known, in the case of taking a process _o_u_t of a dir, if this was th last process out. This is the condition for b_u comline execution. The last process out of the root node's father declares tthe entire circus over. */ dcl acnt fixed bin; dcl apx fixed bin; dcl abit bit (1) aligned; dcl p ptr; dcl (b, c) bit (36) aligned; dcl dummy bit (1) aligned; p = addr (global_mpdata.dir_table (acnt)); r: b = string (global_mpdata.dir_table (acnt)); c = b; substr (c, apx, 1) = abit; dummy = "1"b; /* This is to get around PL1 bug 1664, _i_n _q_u_o state_man doesn't flush substr references. This clears the a-register. HELP! */ if stacq (p -> b36, c, b) then do; substr (b, apx, 1) = "0"b; return (b ^= "0"b); end; else go to r; end dir_busyp; count_greater_thans: proc (s) returns (fixed bin); /* Determines "hierarchy depth" from # of greater thans */ dcl s char (*); dcl (i, j) fixed bin; dcl c fixed bin; if s = ">" then return (0); i = 1; c = 0; do while ("1"b); j = index (substr (s, i), ">"); if j = 0 then return (c); c = c + 1; i = i + j; end; end count_greater_thans; stacq_countgen: proc (reference) returns (fixed bin (35)); /* Take a unique tag from loc "reference", incrementing it by 1 in so doing. Exactly like the ticket machine in the bakery. */ dcl reference fixed bin (35); dcl bit_reference bit (36) aligned based (addr (reference)); /* This is ILLEGAL, but necessary. */ /* We hope we don't get optimized away. */ dcl v fixed bin (35); r: v = reference; if stacq (bit_reference, bit (fixed (v + 1, 36), 36), bit (fixed (v, 36), 36)) then return (v + 1); else go to r; end stacq_countgen; sig_eoj: proc; /* Broadcast the fact of completion */ dcl 1 empdata like mpdata based (empdatap); dcl empdatap ptr; dcl epx fixed bin; global_mpdata.eoj = "1"b; j: do epx = 1 to global_mpdata.nprocs; empdatap = addr (global_mpdata.perprocess (epx)); if waker (empdatap) then; end; return; sig_abort: entry; global_mpdata.abort = "1"b; abort_entry = "1"b; go to j; end sig_eoj; abort: entry; call get_com_seg; abort_entry = "1"b; call sig_abort; return; /* */ recover: entry; call cu_$arg_ptr (1, ap, lng, code); if code ^= 0 then do; call com_err_ (code, myname); return; end; my_px = cv_dec_check_ (arg, code); if code ^= 0 then do; call com_err_ (0, myname, "Bad process number: ^a.", arg); return; end; procpicvar = my_px; call get_com_seg; if my_px < 0 | my_px > global_mpdata.nprocs then do; call com_err_ (0, myname, "Invalid process number: ^d.", my_px); return; end; mpdatap = addr (global_mpdata.perprocess (my_px)); call get_process_parameters; mpdata.pid = my_pid; mpdata.evchn = my_evchn; mpdata.nchan = 1; call ioa_ ("Recovering process ^d in ^a.", my_px, get_wdir_ ()); mpf = "1"b; command_process = "0"b; if mpdata.died then do; mpdata.data_avl = "0"b; if stacq (mpdata.gostac, "0"b, (mpdata.gostac)) then; mpdata.died = "0"b; end; arp = get_system_free_area_ (); call multiprocess_ws; return; /* */ status: entry; call get_com_seg; call ioa_ ("Seg at ^p", gmpdata_p); call ioa_ ("Starter was ^w, count at ^d, ^d processes.", global_mpdata.startctl, global_mpdata.cnt, global_mpdata.nprocs); call ioa_ ("Flags: ^[^^^]tracing, ^[^^^]top-down, ^[^^^]bot-up, ^[^^^]eoj, ^[^^^]abort ^[^^^]no_msf ^[^^^]priv", ^global_mpdata.trace_flag, ^global_mpdata.top_down_flag, ^global_mpdata.bottom_up_flag, ^global_mpdata.eoj, ^global_mpdata.abort, ^global_mpdata.msf_flag, ^global_mpdata.priv_flag); call ioa_ ("^d dispatches, ^d pickups, ^d getworks, ^d wakeups.", global_mpdata.dispatches, global_mpdata.pickups, global_mpdata.getworks, global_mpdata.wakeups); call ioa_ ("^d blocks, ^d recursions, ^d decursions.", global_mpdata.blocks, global_mpdata.recursions, global_mpdata.decursions); call ioa_ ("^d recurse executions, ^d decurse executions.", global_mpdata.executions, global_mpdata.dxeqs); call ioa_ ("first ^d last ^d first hd ^d last hd ^d", global_mpdata.sfirst, global_mpdata.slast, global_mpdata.first_hdepth, global_mpdata.last_hdepth); if global_mpdata.top_down_flag then call ioa_ ("Top command: ^a", b_comline); if global_mpdata.bottom_up_flag then call ioa_ ("Bottom command: ^a", b_bu_comline); do px = 1 to global_mpdata.nprocs; mpdatap = addr (global_mpdata.perprocess (px)); call ioa_ ("^/Px ^d PID ^w at ^p, evchn = ^o.", mpdata.px, mpdata.pid, mpdatap, mpdata.evchn); call ioa_ ("gostac ^w data_avl ^w.", mpdata.gostac, mpdata.data_avl); call ioa_ ("Uid array ^(^d ^).", mpdata.uid); call ioa_ ("Last seen at ^a, s-lev ^d, s-hlev ^d.", mpdata.dname, mpdata.slevel, mpdata.shlev); call ioa_ ("Flags: ^[^^^]ready, ^[^^^]died.", ^mpdata.ready, ^mpdata.died); end; return; get_com_seg: proc; call hcs_$make_seg (get_wdir_ (), "dos_mp_seg", "", 1011b, gmpdata_p, code); if gmpdata_p = null then do; call com_err_ (code, myname, "Cannot get pointer to communications segment."); go to NLX; end; end get_com_seg; end dos;  dump_partition.pl1 11/15/82 1853.9rew 11/15/82 1519.5 64269 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ dump_partition: procedure () options (variable); /* * Command to use privileged partition I/O gate to display contents of disk partitions. * * dump_partition Pvname Partition_name Offset {Length} {-control_args} * -header, -no_header, -short, -long, -character * * 10/18/80, W. Olin Sibert */ dcl ap pointer; dcl al fixed bin (21); dcl arg char (al) based (ap); dcl rsp pointer; dcl rsl fixed bin (21); dcl rs char (rsl) varying based (rsp); dcl code fixed bin (35); dcl complain entry variable options (variable); dcl (nargs, argno) fixed bin; dcl af_sw bit (1) aligned; dcl header_sw bit (1) aligned; dcl pvname char (32); dcl part_name char (4); dcl pvid bit (36) aligned; dcl offset fixed bin (35); dcl lth fixed bin (18); dcl part_lth fixed bin (35); dcl 1 ds_arg unaligned, /* flags argument to dump_segment_ */ (2 address, 2 offset, 2 short, 2 bcd, 2 ascii, 2 long, 2 ebcdic9, 2 ebcdic8, 2 fourbit, 2 hex8, 2 hex9) bit (1) unaligned; dcl active_fnc_err_ entry options (variable); dcl com_err_ 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, pointer, fixed bin (21), fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl dump_segment_ entry (pointer, pointer, fixed bin, fixed bin (35), fixed bin (18), bit (*)); dcl find_partition_ entry (char (*), char (*), bit (36) aligned, fixed bin (35), fixed bin (35), fixed bin (35)); dcl hphcs_$read_partition entry (bit (36) aligned, char (*), fixed bin (35), pointer, fixed bin (18), fixed bin (35)); dcl hphcs_$write_partition entry (bit (36) aligned, char (*), fixed bin (35), pointer, fixed bin (18), fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$rsnpnnl entry options (variable); dcl (error_table_$badopt, error_table_$too_many_args, error_table_$noarg, error_table_$not_act_fnc, error_table_$bad_conversion) fixed bin (35) external static; dcl iox_$user_output pointer external static; dcl WHOAMI char (32) internal static options (constant) init ("dump_partition"); dcl linkage_error condition; dcl (addr, char, length, maxlength, rtrim, string) builtin; /* */ pvname = ""; part_name = ""; offset = -1; lth = -1; string (ds_arg) = ""b; header_sw = "1"b; call cu_$af_return_arg (nargs, rsp, rsl, code); if code = 0 then do; rs = ""; complain = active_fnc_err_; af_sw = "1"b; end; else if code = error_table_$not_act_fnc then do; complain = com_err_; af_sw = "0"b; end; else do; call com_err_ (code, WHOAMI); RETURN: return; end; do argno = 1 to nargs; call cu_$arg_ptr (argno, ap, al, (0)); if (arg = "-long") | (arg = "-lg") then ds_arg.long = "1"b; else if (arg = "-short") | (arg = "-sh") then ds_arg.short = "1"b; else if (arg = "-characters") | (arg = "-character") | (arg = "-char") | (arg = "-ch") then ds_arg.ascii = "1"b; else if (arg = "-bcd") then ds_arg.bcd = "1"b; else if (arg = "-header") | (arg = "-he") then header_sw = "1"b; else if (arg = "-no_header") | (arg = "-nhe") then header_sw = "1"b; else if char (arg, 1) = "-" then do; call complain (error_table_$badopt, WHOAMI, "^a", arg); goto RETURN; end; else if pvname = "" then /* first arg is volume name */ pvname = arg; else if part_name = "" then do; /* second arg is partition name */ if length (rtrim (arg)) > maxlength (part_name) then do; call complain (0, WHOAMI, "Partition name must be ^d characters or less. ^a", maxlength (part_name), arg); goto RETURN; end; part_name = rtrim (arg); end; else if offset < 0 then do; /* third arg is offset */ offset = cv_oct_check_ (arg, code); if code ^= 0 then code = error_table_$bad_conversion; if (code ^= 0) | (offset < 0) then do; call complain (code, WHOAMI, "Offset must be a nonnegative octal number, not ^a", arg); goto RETURN; end; end; else if lth < 0 then do; /* fourth arg is length to dump */ lth = cv_oct_check_ (arg, code); if code ^= 0 then code = error_table_$bad_conversion; if (code ^= 0) | (lth < 0) then do; call complain (code, WHOAMI, "Length must be a nonnegative octal number, not ^a", arg); goto RETURN; end; end; else do; code = error_table_$too_many_args; goto USAGE; end; end; /* of argument loop */ if offset < 0 then do; /* length is optional */ code = error_table_$noarg; USAGE: call complain (code, WHOAMI, "^/Usage:^-^a pvname part_name offset {length} {-control_args}", WHOAMI); goto RETURN; end; /* */ call find_partition_ (pvname, part_name, pvid, (0), part_lth, code); if code ^= 0 then do; call complain (code, WHOAMI, "Partition ^a on ^a", part_name, pvname); goto RETURN; end; if lth <= 0 then /* apply defaults */ lth = 1; if (offset + lth) > part_lth then do; call com_err_ (0, WHOAMI, "Partition ^a on ^a is only ^oo words long. Cannot dump ^oo words at ^oo.", part_name, pvname, part_lth, lth, offset); goto RETURN; end; ds_arg.offset = "1"b; /* print offset if we got a non-zero offset */ /* Never print address column, because it's useless */ begin; /* get a place to put the copied data */ dcl copy_data (lth) bit (36) aligned; on condition (linkage_error) begin; /* exit gracefully */ call complain (0, WHOAMI, "This opertaion requires privileged access (hphcs_) not given to this process."); goto RETURN; /* and punt */ end; call hphcs_$read_partition (pvid, part_name, offset, addr (copy_data), lth, code); revert condition (linkage_error); if code ^= 0 then do; call complain (code, WHOAMI, "Cannot read ^o word^[s^] from PV ^a, partition ^a|^o", lth, (lth ^= 1), pvname, part_name, offset); goto RETURN; end; if af_sw then /* return the result */ call ioa_$rsnpnnl ("^(^w^x^)", rs, (0), copy_data); else do; if header_sw then call ioa_ ("^/^3xVolume ^a, partition ^a: ^o word^[s^] at offset ^o:^/", pvname, part_name, lth, (lth ^= 1), offset); call dump_segment_ (iox_$user_output, addr (copy_data), 0, offset, lth, string (ds_arg)); call ioa_ (""); /* blank line at the end */ end; /* of command case */ end; /* begin block */ goto RETURN; /* all done */ end dump_partition;  find_partition_.pl1 07/20/88 1304.2r w 07/19/88 1534.8 33147 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2,indcomtxt */ find_partition_: proc (P_pvname, P_part_name, P_pvid, P_part_start, P_part_lth, P_code); /* * FIND_PARTITION_ * * This procedure is used to locate a disk partition if it exists, and returns the * size, location, and volume pvid for the partition. It is designed to make partition * processing programs easier to write. * * Written 12/06/80, W. Olin Sibert * Modified 1/31/85, Keith Loepere, for real error codes. */ /* Modified by BIM, 830601, to default to using phcs_$find_partition to find the config_deck specified partition if P_pvname = "" */ dcl ( P_pvname char (*), /* Input: name of volume to look on */ P_part_name char (*), /* Input: name of partition to look for */ P_pvid bit (36) aligned, /* Output: PVID of volume */ P_part_start fixed bin (35), /* Output: first record of partition */ P_part_lth fixed bin (35), /* Output: number of words in partition */ P_code fixed bin (35) ) parameter; /* Output: error code */ dcl fb18_record fixed bin (18); dcl fb18_length fixed bin (18); dcl pvid bit (36) aligned; dcl code fixed bin (35); dcl idx fixed bin; dcl label_buffer (1024) bit (36) aligned; dcl mdc_$pvname_info entry (char (*), bit (36) aligned, char (*), bit (36) aligned, fixed bin, fixed bin (35)); dcl phcs_$read_disk_label entry (bit (36) aligned, pointer, fixed bin (35)); dcl phcs_$find_partition entry (char (*), fixed bin, bit (36) aligned, fixed bin (18), fixed bin (18), fixed bin (35)); dcl ( error_table_$device_parity, error_table_$device_not_usable, error_table_$invalid_device, error_table_$moderr, error_table_$noentry ) fixed bin (35) external static; dcl sys_info$page_size fixed bin external static; dcl linkage_error condition; dcl addr builtin; on condition (linkage_error) begin; /* Lose gracefully if no access to phcs_ */ code = error_table_$moderr; goto MAIN_RETURN; end; if P_pvname = "" then do; P_pvid = ""b; fb18_record = 0; fb18_length = 0; call phcs_$find_partition (P_part_name, (0), P_pvid, fb18_record, fb18_length, P_code); P_part_start = fb18_record; P_part_lth = fb18_length; return; end; call mdc_$pvname_info (P_pvname, pvid, (""), (""b), (0), code); if code ^= 0 then /* Wrong name, probably */ goto MAIN_RETURN; labelp = addr (label_buffer); call phcs_$read_disk_label (pvid, labelp, code); revert condition (linkage_error); if code ^= 0 then goto MAIN_RETURN; do idx = 1 to label.nparts while (label.parts (idx).part ^= P_part_name); end; if idx > label.nparts then do; code = error_table_$noentry; goto MAIN_RETURN; end; P_pvid = pvid; /* Found it. Copy output parameters */ P_part_start = label.parts (idx).frec; P_part_lth = sys_info$page_size * label.parts (idx).nrec; code = 0; MAIN_RETURN: P_code = code; return; %page; %include fs_vol_label; end find_partition_;  fix_quota_used.pl1 02/19/85 1027.5rew 02/14/85 0748.9 36450 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ fix_quota_used: proc; /* fix_quota_used: B. Greenberg 2/19/77 */ /* Modified 12/13/84 by Keith Loepere for (seg/dir) variants. */ /* Based */ dcl arg char (argl) based (argp); /* Misc */ dcl bad_dir_ condition; /* Variables */ dcl acted bit (1) aligned; dcl argl fixed bin; dcl argnum fixed bin; dcl argp ptr; dcl brief bit (1) aligned; dcl code fixed bin (35); dcl fix_dir bit (1) aligned; dcl fix_seg bit (1) aligned; dcl myname char (24); dcl ndu fixed bin (34); dcl nsu fixed bin (34); dcl odu fixed bin (34); dcl osu fixed bin (34); dcl pathname char (168); dcl salvct fixed bin; /* Entries */ dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl hphcs_$correct_dir_qused entry (char (*), fixed bin (34), fixed bin (34), bit (1) aligned, fixed bin (35)); dcl hphcs_$correct_qused entry (char (*), fixed bin (34), fixed bin (34), fixed bin (34), fixed bin (34), bit (1) aligned, fixed bin (35)); dcl hphcs_$correct_seg_qused entry (char (*), fixed bin (34), fixed bin (34), bit (1) aligned, fixed bin (35)); dcl ioa_ entry options (variable); /* External */ dcl error_table_$bad_arg fixed bin (35) ext static; /* Builtin */ dcl index builtin; %page; myname = "fix_quota_used"; fix_dir, fix_seg = "1"b; go to join; fix_dir_quota_used: entry; myname = "fix_dir_quota_used"; fix_dir = "1"b; fix_seg = "0"b; go to join; fix_seg_quota_used: entry; myname = "fix_seg_quota_used"; fix_dir = "0"b; fix_seg = "1"b; join: brief = "0"b; pathname = ""; call cu_$arg_ptr (1, argp, argl, code); if code ^= 0 then do; USAGE: call com_err_ (code, myname, "Usage is: ^a {-bf}", myname); return; end; argnum = 1; do while (code = 0); if index (arg, "-") = 1 then do; if arg = "-brief" | arg = "-bf" then brief = "1"b; else if arg = "-long" | arg = "-lg" then brief = "0"b; else do; call com_err_ (error_table_$bad_arg, myname, "^a", arg); return; end; end; else do; /* must be path */ call absolute_pathname_ (arg, pathname, code); if code ^= 0 then do; call com_err_ (code, myname, arg); return; end; end; argnum = argnum + 1; call cu_$arg_ptr (argnum, argp, argl, code); end; if pathname = "" then go to USAGE; salvct = 0; on bad_dir_ begin; call com_err_ (0, myname, "Salvage performed on ^a.", pathname); salvct = salvct + 1; if salvct > 3 then go to ret; else go to retry; end; retry: if myname = "fix_quota_used" then call hphcs_$correct_qused (pathname, osu, odu, nsu, ndu, acted, code); else if fix_seg then do; call hphcs_$correct_seg_qused (pathname, osu, nsu, acted, code); odu, ndu = 0; end; else do; call hphcs_$correct_dir_qused (pathname, odu, ndu, acted, code); osu, nsu = 0; end; revert bad_dir_; if acted then if ^brief then do; if code ^= 0 then call com_err_ (code, myname, "While processing ^a.", pathname); if osu ^= nsu then call ioa_ ("^a: Segment quota used changed from ^d to ^d.", pathname, osu, nsu); if odu ^= ndu then call ioa_ ("^a: Directory quota used changed from ^d to ^d.", pathname, odu, ndu); end; else ; else call com_err_ (code, myname, "Could not validate/correct quota on ^a.", pathname); ret: return; end;  hp_delete_vtoce.pl1 11/15/82 1853.9rew 11/15/82 1520.0 77211 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ hp_delete_vtoce: proc (); /* * This procedure is simply an interface used to delete a specified * VTOCE, either causing a forward connection failure or curing a * reverse connection failure. It checks before causing a forward * failure, unless asked not to. * * Written sometime in 1979, W. Olin Sibert * Cleaned up and installed, 06/21/81, WOS */ dcl arg char (al) based (ap); dcl al fixed bin (21); dcl ap pointer; dcl code fixed bin (35); dcl (argno, nargs) fixed bin; dcl vtoce_argno fixed bin; dcl pvname char (32); dcl pvid bit (36) aligned; dcl pvtx fixed bin; dcl vtocx fixed bin (18); dcl force_sw bit (1) aligned; dcl check_sw bit (1) aligned; dcl query_sw bit (1) aligned; dcl brief_sw bit (1) aligned; dcl clear_sw bit (1) aligned; dcl com_err_ entry options (variable); dcl command_query_$yes_no 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 cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl hphcs_$clear_vtoce entry (bit (36) aligned, fixed bin (18), fixed bin (35)); dcl hphcs_$delete_vtoce entry (bit (36) aligned, bit (36) aligned, fixed bin (18), fixed bin (35)); dcl ioa_ entry options (variable); dcl phcs_$get_vtoce entry (fixed bin, fixed bin (18), ptr, fixed bin (35)); dcl pvname_to_pvtx_ entry (char (*), fixed bin, bit (36) aligned, fixed bin (35)); dcl vpn_cv_uid_path_$ent entry (ptr, char (*), bit (36) aligned, fixed bin (35)); dcl error_table_$bad_conversion fixed bin (35) external static; dcl error_table_$badopt fixed bin (35) external static; dcl error_table_$inconsistent fixed bin (35) external static; dcl error_table_$moderr fixed bin (35) external static; dcl error_table_$no_dir fixed bin (35) external static; dcl error_table_$noarg fixed bin (35) external static; dcl error_table_$noentry fixed bin (35) external static; dcl WHOAMI char (32) internal static options (constant) init ("hp_delete_vtoce"); dcl linkage_error condition; dcl (addr, char) builtin; /* */ vtocx = -1; /* some initializations */ pvtx = -1; vtoce_argno = -1; force_sw = "0"b; /* If on, forces lack of questions */ brief_sw = "0"b; /* If on, suppresses informative message */ query_sw = "0"b; /* If on, forces a query (opposite of -force, sort of) */ check_sw = "1"b; /* Causes checking for connectedness */ clear_sw = "0"b; /* Just delete by default */ call cu_$arg_count (nargs, code); if code ^= 0 then do; call com_err_ (code, WHOAMI); MAIN_RETURN: return; end; do argno = 1 to nargs; call cu_$arg_ptr (argno, ap, al, (0)); if (arg = "-force") | (arg = "-fc") then force_sw = "1"b; else if (arg = "-brief") | (arg = "-bf") then brief_sw = "1"b; else if (arg = "-no_check") | (arg = "-nck") then check_sw = "0"b; else if (arg = "-check") | (arg = "-ck") then check_sw = "1"b; else if (arg = "-query") | (arg = "-qy") then query_sw = "1"b; else if (arg = "-clear") then clear_sw = "1"b; else if (arg = "-delete") then clear_sw = "0"b; else if char (arg, 1) = "-" then do; code = error_table_$badopt; BAD_ARGUMENT: call com_err_ (code, WHOAMI, "^a", arg); goto MAIN_RETURN; end; else if pvtx < 0 then do; /* first non control arg is PV name */ pvname = arg; /* otherwise, remember its name */ call pvname_to_pvtx_ (pvname, pvtx, pvid, code); /* Get pvtx and pvid */ if code ^= 0 then goto BAD_ARGUMENT; end; else do; /* second through last are VTOCE indices */ vtocx = cv_oct_check_ (arg, code); if code ^= 0 then do; code = error_table_$bad_conversion; BAD_VTOCE_INDEX: call com_err_ (code, WHOAMI, "VTOCE index must be a positive octal number, not ""^a"".", arg); goto MAIN_RETURN; end; if vtocx < 0 then goto BAD_VTOCE_INDEX; if vtoce_argno < 0 then vtoce_argno = argno; /* Remember where to start */ end; end; /* of argument processing */ /* */ if force_sw & query_sw then do; call com_err_ (error_table_$inconsistent, WHOAMI, "-force and -query"); goto MAIN_RETURN; end; if vtoce_argno < 0 then do; /* not enough args */ call com_err_ (error_table_$noarg, WHOAMI, "^/Usage:^-^a pvname vtocx(octal) {-query} {-force} {-brief} {-no_check}", WHOAMI); goto MAIN_RETURN; end; on linkage_error begin; /* not enough access, sorry. */ call com_err_ (error_table_$moderr, WHOAMI, "This operation requires access to phcs_ and hphcs_"); goto MAIN_RETURN; end; do argno = vtoce_argno to nargs; /* Loop through VTOCE indices */ call cu_$arg_ptr (argno, ap, al, (0)); if char (arg, 1) ^= "-" then do; /* Not a leftover control argument */ vtocx = cv_oct_check_ (arg, (0)); /* Conversion is guaranteed to work */ call expunge (); /* Do it */ end; end; /* of loop through vtoces */ return; /* */ expunge: proc (); /* This procedure does the actual deletion. It inherits the flag switches, as well as pvname, pvid, pvtx and vtocx. */ dcl pathname char (168); dcl answer bit (1) aligned; dcl vtoce_uid bit (36) aligned; dcl connected bit (1) aligned; dcl asked bit (1) aligned; dcl 1 local_vtoce aligned like vtoce; vtocep = addr (local_vtoce); call phcs_$get_vtoce (pvtx, vtocx, vtocep, code); /* take a look at it first */ if code ^= 0 then do; call com_err_ (code, WHOAMI, "Reading VTOCE ^o from ^a.", vtocx, pvname); return; end; vtoce_uid = vtoce.uid; /* find out who we are */ if vtoce_uid = ""b then do; /* sorry, wrong number */ call com_err_ (0, WHOAMI, "VTOCE ^o on ^a is free.", vtocx, pvname); return; /* nothing to do this time */ end; /* * Note that this ought to get replaced by a more useful call to hardcore which resolves * the UID path deterministically and correctly; unfortunately, hc_backup_$decode_uidpath * just can't hack it, since it's only in the business of finding directories. */ if check_sw then do; /* find out if we're connected */ call vpn_cv_uid_path_$ent (addr (vtoce.uid_path), pathname, vtoce_uid, code); if code = error_table_$noentry then connected = "0"b; else if code = error_table_$no_dir then connected = "0"b; else connected = "1"b; /* either is, or might be */ end; else connected = "0"b; /* Can't check */ asked = "0"b; /* Used to suppress informative message */ if check_sw & ^query_sw & ^connected then; /* If of no interest, just delete it */ else if (check_sw | query_sw) & connected then do; /* Ask the question about a connected VTOCE */ call command_query_$yes_no (answer, 0, WHOAMI, "", "VTOCE ^o on ^a is ^a.^/Do you wish to ^[clear^;delete^] it anyway?", vtocx, pvname, pathname, clear_sw); if answer = "0"b then return; /* Don't bother */ asked = "1"b; end; /* of case to check for connection */ else if ^force_sw then do; /* if it is (or might be) connected, ask user */ call command_query_$yes_no (answer, 0, WHOAMI, "", "Do you really want to ^[clear^;delete^] VTOCE ^o (""^a"") on ^a ??", clear_sw, vtocx, vtoce.primary_name, pvname); if answer = "0"b then return; /* chickened out! */ asked = "1"b; end; if ^clear_sw then call hphcs_$delete_vtoce (vtoce_uid, pvid, vtocx, code); else call hphcs_$clear_vtoce (pvid, vtocx, code); if (code = 0) & (^brief_sw) & (^asked) then do; /* successful. Tell user? */ call ioa_ ("^a: ^[Cleared^;Deleted^] ^[unconnected ^]VTOCE ^o (""^a"") on ^a.", WHOAMI, clear_sw, (check_sw & ^connected), vtocx, vtoce.primary_name, pvname); end; else if code ^= 0 then call com_err_ (code, WHOAMI, /* otherwise, complain since some unknown lossage occurred */ "Unable to ^[clear^;delete^] VTOCE ^o (""^a"") on ^a.", clear_sw, vtocx, vtoce.primary_name, pvname); return; /* all done */ end expunge; %page; %include vtoce; end hp_delete_vtoce;  list_partitions.pl1 07/20/88 1304.2r w 07/19/88 1534.8 32850 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ list_partitions: procedure () options (variable); /* * Command to use phcs_$read_disk_label and to list the partitions on a volume. * * list_partitions Pvname * * 10/18/80, W. Olin Sibert */ dcl ap pointer; dcl al fixed bin (21); dcl arg char (al) based (ap); dcl code fixed bin (35); dcl (nargs, argno) fixed bin; dcl pvname char (32); dcl pvid bit (36) aligned; dcl part_idx fixed bin; dcl 1 local_label aligned like label automatic; dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); dcl phcs_$read_disk_label entry (bit (36) aligned, pointer, fixed bin (35)); dcl ioa_ entry options (variable); dcl mdc_$pvname_info entry (char (*), bit (36) aligned, char (*), bit (36) aligned, fixed bin, fixed bin (35)); dcl (error_table_$badopt, error_table_$too_many_args, error_table_$noarg) fixed bin (35) external static; dcl WHOAMI char (32) internal static options (constant) init ("list_partitions"); dcl linkage_error condition; dcl (addr, char) builtin; /* */ pvname = ""; call cu_$arg_count (nargs, code); if code ^= 0 then do; call com_err_ (code, WHOAMI); RETURN: return; end; do argno = 1 to nargs; call cu_$arg_ptr (argno, ap, al, (0)); if char (arg, 1) = "-" then do; call com_err_ (error_table_$badopt, WHOAMI, "^a", arg); goto RETURN; end; else if pvname = "" then /* first arg is volume name */ pvname = arg; else do; code = error_table_$too_many_args; goto USAGE; end; end; /* of argument loop */ if pvname = "" then do; code = error_table_$noarg; USAGE: call com_err_ (code, WHOAMI, "^/Usage:^-^a pvname", WHOAMI); goto RETURN; end; /* */ call mdc_$pvname_info (pvname, pvid, (""), (""b), (0), code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "^a", pvname); goto RETURN; end; labelp = addr (local_label); on condition (linkage_error) begin; /* exit gracefully */ call com_err_ (0, WHOAMI, "This opertaion requires privileged access (phcs_) not given to this process."); goto RETURN; /* and punt */ end; call phcs_$read_disk_label (pvid, labelp, code); revert condition (linkage_error); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot read label of ^a", pvname); goto RETURN; end; call ioa_ ("Volume ^a:", pvname); call ioa_ ("^8d records, ^5d VTOC records.", label.vol_size, label.vtoc_size); call ioa_ ("^[No^s^;^d^] partition^[s^]^[:^/^2xName^5xStart^5xSize^;.^]", (label.nparts = 0), label.nparts, (label.nparts ^= 1), (label.nparts ^= 0)); do part_idx = 1 to label.nparts; call ioa_ ("^2x^4a^2x^8o^2x^6o^x(^d.)", label.parts.part (part_idx), label.parts.frec (part_idx), label.parts.nrec (part_idx), label.parts.nrec (part_idx)); end; call ioa_ (""); /* end with a blank line */ goto RETURN; /* all done */ %page; %include fs_vol_label; end list_partitions;  record_to_vtocx.pl1 07/20/88 1304.2r w 07/19/88 1533.3 76113 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-16,Fawcett), approve(86-04-10,MCR7383), audit(86-05-15,Martinson), install(86-07-18,MR12.0-1098): Add support for 512_WORD_IO devices, 3380 and 3390. END HISTORY COMMENTS */ record_to_vtocx: procedure () options (variable); /* adapted from adopt_seg Bernard Greenberg 09/05/77 */ /* modified for -pathname, to print the path of segment owning the address, E. A. Ranzenbach 06/05/80 */ /* Modified to fix loop bug, increase max number of records, 04/17/81, W. Olin Sibert */ /* Modified to use a temp segment for the disk table, 07/11/81, Art Beattie */ /* Modified for -all, 9 August 1981, WOS */ /* Modified for new PVTE and to check address against paging region, March 1982, J. Bongiovanni */ dcl nargs fixed bin; dcl argno fixed bin; dcl arg char (argl) based (argp); dcl argl fixed bin (21); dcl argp ptr; dcl recnoa (MAX_RECORDS) fixed bin; dcl found_address (MAX_RECORDS) bit (1) unaligned; dcl recno fixed bin; dcl naddrs fixed bin; dcl highest_vtocx fixed bin; dcl addrno fixed bin; dcl pageno fixed bin; dcl last_page fixed bin; dcl addrs_left fixed bin; dcl (r, s) fixed bin; dcl dev_type fixed bin; dcl pvname char (32); dcl pvt_size fixed bin (19); dcl code fixed bin (35); dcl pathname char (168); dcl (pvtx, vtocx) fixed bin; dcl pvid bit (36) aligned; dcl all_sw bit (1) aligned; dcl path_sw bit (1) aligned; dcl sector_sw bit (1) aligned; dcl 1 local_vtoce aligned like vtoce; dcl error_table_$badopt fixed bin (35) external static; dcl error_table_$noarg fixed bin (35) external static; dcl error_table_$too_many_args fixed bin (35) external static; dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl phcs_$get_vtoce entry (fixed bin, fixed bin, ptr, fixed bin (35)); dcl pvname_to_pvtx_ entry (char (*), fixed bin, bit (36) aligned, fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl ring_zero_peek_$get_max_length entry (char(*), fixed bin(19), fixed bin(35)); dcl ring_zero_peek_$by_name entry (char(*), fixed bin(18), ptr, fixed bin(19), fixed bin(35)); dcl vpn_cv_uid_path_$ent entry (ptr, char (*), bit (36), fixed bin (35)); dcl MAX_RECORDS fixed bin internal static options (constant) init (500); dcl myname char (32) init ("record_to_vtocx") internal static options (constant); dcl cleanup condition; dcl (addr, binary, char, divide, hbound, null) builtin; /* */ path_sw = "0"b; all_sw = "0"b; pvtp = null; on condition (cleanup) begin; if pvtp ^= null () then call release_temp_segment_ (myname, pvtp, (0)); end; call cu_$arg_count (nargs, code); if code ^= 0 then go to USAGE; if nargs < 1 then do; USAGE_NOARG: code = error_table_$noarg; USAGE: call com_err_ (code, myname, "^/Usage:^-^a pvname rec_no1 {... rec_no^d} {-sector NNN} {-pathname}", myname, hbound (recnoa, 1)); return; end; call cu_$arg_ptr (1, argp, argl, code); pvname = arg; call pvname_to_pvtx_ (pvname, pvtx, pvid, code); if code ^= 0 then do; call com_err_ (code, myname, pvname); go to MAIN_RETURN; end; call get_temp_segment_ (myname, pvtp, code); if code ^= 0 then do; CANNOT_GET_PVT: call com_err_ (code, myname, "Cannot get ring zero PVT"); goto MAIN_RETURN; end; call ring_zero_peek_$get_max_length ("pvt", pvt_size, code); if code ^= 0 then goto CANNOT_GET_PVT; call ring_zero_peek_$by_name ("pvt", 0, pvtp, pvt_size, code); if code ^= 0 then goto CANNOT_GET_PVT; pvt_arrayp = addr (pvt.array); /* */ naddrs = 0; /* Number of record arguments */ sector_sw = "0"b; dev_type = pvt_array (pvtx).device_type; do argno = 2 to nargs; call cu_$arg_ptr (argno, argp, argl, (0)); if (arg = "-pathname") | (arg = "-pn") then path_sw = "1"b; else if (arg = "-all") | (arg = "-a") then all_sw = "1"b; else if (arg = "-sector") then sector_sw = "1"b; /* Next number is a sector number */ else if char (arg, 1) = "-" then do; call com_err_ (error_table_$badopt, myname, "^a", arg); goto MAIN_RETURN; end; else do; recno = cv_oct_check_ (arg, code); if code ^= 0 then do; call com_err_ (0, myname, "Invalid octal address ^a", arg); go to MAIN_RETURN; end; if sector_sw then do; /* Preceded by -sector, so must convert */ s = sect_per_cyl (dev_type); r = divide (recno, s, 17, 0) * (s - divide (s, sect_per_rec (dev_type), 17, 0) * sect_per_rec (dev_type)); recno = divide (recno - r, sect_per_rec (dev_type), 17, 0); end; if (recno < pvt_array (pvtx).baseadd) | (recno >= pvt_array (pvtx).baseadd + pvt_array (pvtx).totrec) then do; call com_err_ (0, myname, "^[Sector^;Record^] address ^a is outside of Paging Region", sector_sw, arg); goto MAIN_RETURN; end; naddrs = naddrs + 1; if naddrs > hbound (recnoa, 1) then do; call com_err_ (error_table_$too_many_args, myname, "Too many record numbers. Max is ^d", hbound (recnoa, 1)); goto MAIN_RETURN; end; sector_sw = "0"b; /* Turn it off after collecting the argument */ recnoa (naddrs) = recno; end; end; if sector_sw then do; /* If still set, something was missing */ call com_err_ (error_table_$noarg, myname, "Octal sector number after -sector"); goto MAIN_RETURN; end; if naddrs = 0 then goto USAGE_NOARG; /* */ addrs_left = naddrs; found_address (*) = "0"b; highest_vtocx = pvt_array (pvtx).n_vtoce - 1; /* Zero origin */ vtocep = addr (local_vtoce); do vtocx = 0 to highest_vtocx; call phcs_$get_vtoce (pvtx, vtocx, vtocep, code); if code ^= 0 then do; call com_err_ (code, myname, "Error reading vtocx ^o", vtocx); goto NEXT_VTOCE; end; if (vtoce.uid = ""b) then goto NEXT_VTOCE; if all_sw then last_page = 255; else last_page = binary (vtoce.csl, 9) - 1; do pageno = 0 to last_page; do addrno = 1 to naddrs; if ^all_sw then if found_address (addrno) then goto NEXT_ADDRESS; if recnoa (addrno) = binary (vtoce.fm (pageno), 18) then do; call ioa_ ("Address ^o = page ^d of VTOC index ^o", recnoa (addrno), pageno, vtocx); if path_sw then do; call vpn_cv_uid_path_$ent (addr (vtoce.uid_path), pathname, vtoce.uid, code); if code ^= 0 then call com_err_ (code, myname, "Cannot get path of vtocx ^o on ^a", vtocx, pvname); else call ioa_ ("^5xvtocx ^o is ^a", vtocx, pathname); end; else call ioa_ ("^5xUID ^w, ^a", vtoce.uid, vtoce.primary_name); found_address (addrno) = "1"b; /* Remember that we have found it */ if ^all_sw then do; /* Make sure it doesn't get used again */ recnoa (addrno) = -1; /* This will cause further comparisons to fail */ addrs_left = addrs_left - 1; if addrs_left = 0 then go to MAIN_RETURN; end; goto NEXT_PAGE; end; /* of case for matching address */ NEXT_ADDRESS: end; /* Of loop through addresses in the list */ NEXT_PAGE: end; /* Of loop through pages in a vtoce */ NEXT_VTOCE: end; /* Of loop through VTOCEs */ do addrno = 1 to naddrs; if ^found_address (addrno) then call com_err_ (0, myname, "Address ^o not found.", recnoa (addrno)); end; MAIN_RETURN: if pvtp ^= null () then call release_temp_segment_ (myname, pvtp, (0)); return; %page; %include vtoce; %page; %include pvt; %page; %include pvte; %page; %include fs_dev_types; end record_to_vtocx;  salvage_dir.pl1 07/11/86 0925.9rew 07/11/86 0915.5 77598 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-05-23,Lippard), approve(86-06-17,MCR7433), audit(86-06-24,Hartogs), install(86-07-11,MR12.0-1092): Modified by Jim Lippard to mention -delete_connection_failure in syntax line and display output on terminal when no output file pathname is given. END HISTORY COMMENTS */ salvage_dir: proc; /* This command rebuilds the directory specified. Usage: salvage_dir path {output_path} -debug -dump dump_path -compact -rebuild -check_vtoce -delete_connection_failure */ /* AUTOMATIC */ dcl arg char (arg_len) based (arg_ptr); /* argument specified with the call */ dcl arg_len fixed bin; dcl arg_ptr ptr; dcl close_io bit (1) aligned; /* ON, if salv was open. */ dcl detach_io bit (1) aligned; /* ON, if salv was attached. */ dcl code fixed bin (35); dcl path char (168); /* name of directory */ dcl ename char (32); /* entry name */ dcl nargs fixed bin; /* number of arguments. Must be 1 */ dcl output char (output_len) var based (output_p); dcl output_len fixed bin (21); dcl output_p ptr; dcl output_path char (168); /* Name of the output segment specified with the call */ dcl dump_p ptr; /* ptr to copy of directory before salvage. */ dcl temp_p (4) ptr; dcl time char (24) aligned; dcl dump_len fixed bin; dcl p ptr; dcl dump_dir char (168); dcl dump_ename char (32); dcl i fixed bin; dcl 1 info aligned like salv_args; dcl iocbp ptr; dcl cleanup condition; dcl copy (dump_len) bit (36) aligned based; /* director y */ dcl (null, ptr, substr, string) builtin; /* EXTERNAL */ dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl clock_ entry returns (fixed bin (52)); 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 date_time_ entry (fixed bin (52), char (*) aligned); dcl error_table_$bad_arg fixed bin (35) ext; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hphcs_$salv_directory entry (ptr, char (*) var, ptr, fixed bin, fixed bin (35)); dcl ioa_$ioa_switch entry options (variable); dcl ioa_ entry options (variable); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* CONSTANT */ dcl NAME char (11) int static options (constant) init ("salvage_dir"); %page; temp_p (*) = null; output_path, path = ""; close_io, detach_io = "0"b; /* Argument parse */ call cu_$arg_count (nargs); if nargs = 0 then do; call com_err_ (0, "salvage_dir", "Usage: salvage_dir dir_path {output_path} -compact -check_vtoce -delete_connection_failure -rebuild"); return; end; string (info.options) = "0"b; info.salv_time = bit (clock_ (), 36); info.correct_oosw = "1"b; do i = 1 to nargs; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, "salvage_dir", arg); return; end; if substr (arg, 1, 1) = "-" then do; if arg = "-rebuild" then info.force_rebuild = "1"b; else if arg = "-check_vtoce" then info.check_vtoce = "1"b; else if arg = "-compact" then info.compact = "1"b; else if arg = "-delete_connection_failure" | arg = "-dcf" then info.delete_connection_failure = "1"b; /* -dump */ else if arg = "-debug" | arg = "-db" then info.print_trace = "1"b; else if arg = "-dump" then do; info.dump = "1"b; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (0, NAME, "-dump must be followed by the path of the dump directory"); return; end; call absolute_pathname_ (arg, dump_dir, code); if code ^= 0 | (substr (arg, 1, 1) = "-") then do; call com_err_ (code, NAME, "-dump must be followed by the path of the dump directory ^a", arg); return; end; end; else do; call com_err_ (error_table_$bad_arg, NAME, arg); return; end; end; else if path = "" then do; call expand_pathname_ (arg, path, ename, code); if code ^= 0 then do; call com_err_ (code, NAME, arg); return; end; if path = ">" then path = rtrim (path) || ename; else path = rtrim (path) || ">" || ename; end; else if output_path = "" then do; call absolute_pathname_ (arg, output_path, code); if code ^= 0 then do; call com_err_ (code, NAME, ""); return; end; end; else do; call com_err_ (error_table_$bad_arg, NAME, arg); return; end; end; if path = "" then do; call com_err_ (0, NAME, "Pathname missing. salvage_dir path {output_path}"); return; end; info.check_vtoce = info.check_vtoce | info.delete_connection_failure; /* Get temp segments */ on cleanup call release; call get_temp_segments_ (NAME, temp_p, code); if code ^= 0 then do; call com_err_ (code, NAME); return; end; output_p = temp_p (1); info.temp1_ptr = temp_p (2); info.temp2_ptr = temp_p (3); if info.dump then dump_p = temp_p (4); else dump_p = null; /* Salvage and print output. */ output_len = 64 * 1024 * 4; output = ""; info.pathname = path; call hphcs_$salv_directory (addr (info), output, dump_p, dump_len, code); /* Attach output segment. */ if output ^= "" then do; if output_path ^= "" then do; call iox_$attach_ioname ("salv", iocbp, "vfile_ " || rtrim (output_path) || " -append ", code); if code ^= 0 then call com_err_ (code, NAME, output_path); else do; detach_io = "1"b; call iox_$open (iocbp, Stream_output, "0"b, code); if code ^= 0 then call com_err_ (code, NAME, output_path); else do; close_io = "1"b; call ioa_$ioa_switch (iocbp, "^/^a:", path); call iox_$put_chars (iocbp, ptr (output_p, 1), length (output), code); end; end; end; else do; call ioa_ ("^/^a:", path); call ioa_ ("^a", output); end; end; /* If a copy of the directory, before salvage, is returned, then create a segment in the dump_dir with the name: .