



		    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 <path> {-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 <dump_directory> */
		     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:
   <date>.<time><dir_name> */
	if info.dump & (dump_len > 0) then do;
		call date_time_ (clock_ (), time);
		dump_ename = substr (time, 1, 2) || substr (time, 4, 2) || substr (time, 7, 2) || "." || substr (time, 11, 5) || ename;
		call hcs_$make_seg (dump_dir, dump_ename, "", 01010b, p, code);
		if code ^= 0 then call com_err_ (code, NAME, "^a>^a", dump_dir, dump_ename);
		else do;
			p -> copy = dump_p -> copy;
			call hcs_$set_bc_seg (p, dump_len * 36, code);
			if code ^= 0 then call com_err_ (code, NAME, "^a>^a", dump_dir, dump_ename);
		     end;
	     end;

	call release;

	return;

%page;
release: proc;

	call release_temp_segments_ (NAME, temp_p, code);
	if code ^= 0 then call com_err_ (code, NAME);

	if output_path ^= "" then do;
		if close_io then call iox_$close (iocbp, code);
		if code ^= 0 then call com_err_ (code, NAME, output_path);
		else do;
			if detach_io then call iox_$detach_iocb (iocbp, code);
			if code ^= 0 then call com_err_ (code, NAME, output_path);
		     end;
	     end;

     end release;

%page;
%include salv_args;
%include iox_modes;
     end salvage_dir;




		    scavenge_vol.pl1                07/20/88  1304.2r w 07/19/88  1533.3      132201



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-10-22,Parisek), approve(87-10-29,MCR7790),
     audit(88-02-03,GDixon), install(88-05-04,MR12.2-1045):
     A. Change com_err_ call to an ioa_ call for reporting "No volumes found"
        message, so call_ec_ will not complain about it.
     B. Change non-existent error_table_$no_arg to error_table_$noarg.
                                                   END HISTORY COMMENTS */


/* format: style3 */
scavenge_vol:
     procedure options (variable);


/*  User-ring program to trigger a volume scavenge.

    scavenge_vol {pvname} {-control_args}

    Arguments accepted:

          -lv lvname      scavenges all volumes in logical volume lvname

	-all, -a	      scavenges all mounted volumes

	-auto	      used with -all or -lv, scavenges only those volumes
		      with volume inconsistencies

          -long, -lg      print metering data for the scavenge

          -debug, -db     enables various ring-0 debugging options,
		      mainly dumping more information into the
		      syserr log

          -trap	      traps to BOS at the end of the scavenge

	-meter	      dumps metering information into the syserr
		      log at the end of the scavenge

          -dump	      dumps VTOCEs damaged during the scavenge into
		      the syserr log

          -nopt	      inhibits the VTOCE read-ahead optimization and 
		      drops CPU priority periodically

          -check	      validates arguments and prints a list of PVs
		      which would be scavenged, but doesn't scavenge.

          -fault_under_AST_lock faults under AST lock for debugging.

          -fault_under_volmap_lock faults under volmap lock for debugging.

          -fault_under_PTL         faults under global PTL for debugging.

    If invoked as an active function, -check is assumed, and a list of
    PVs is returned.

    -fault control arguments not permitted in -check mode to avoid
    operator crazyness.

    Written July 1982 by J. Bongiovanni
    Modified October 1982 by J. Bongiovanni for fm_damaged and associated meters
    Modified 83-12-13 by BIM for faults control arguments.
*/

/*  Automatic  */

dcl	af_invocation	bit (1) aligned;
dcl	af_return_len	fixed bin (21);
dcl	af_return_ptr	ptr;
dcl	all_vols		bit (1) aligned;
dcl	auto_fl		bit (1) aligned;
dcl	arg_no		fixed bin;
dcl	1 arg_options	aligned like scavenger_options;
dcl	argl		fixed bin (21);
dcl	argp		ptr;
dcl	check_sw		bit (1) aligned;
dcl	clock_sec		float;
dcl       code                fixed bin (35);
dcl	1 copy_sc_meters	aligned like sc_meters;
dcl	dtx		fixed bin;
dcl	error_proc	entry options (variable) variable;
dcl	first_arg		fixed bin;
dcl	inconsistency_count fixed bin;
dcl	have_lvname	bit (1) aligned;
dcl	have_pvname	bit (1) aligned;
dcl	long_sw		bit (1) aligned;
dcl	lvname		char (32);
dcl	lvx		fixed bin;
dcl	n_args		fixed bin;
dcl	n_pvs		fixed bin;
dcl	pv_found		bit (1) aligned;
dcl	pvx		fixed bin;
dcl	pvname		char (32);
dcl	scavenge_in_progress
			bit (1) aligned;
dcl	temp_segs		(2) ptr;
dcl	vcpu_sec		float;

/*  Static  */

dcl	MYNAME		char (12) int static options (constant) init ("scavenge_vol");

/*  Based  */

dcl	af_return		char (af_return_len) varying based (af_return_ptr);
dcl	arg		char (argl) based (argp);
dcl	1 pv_struct	(n_pvs) aligned based (temp_segs (2)),
	  2 pvtx		fixed bin,
	  2 pvid		bit (36) aligned,
	  2 pvname	char (32),
	  2 lvname	char (32);


/*  External  */

dcl	error_table_$badopt fixed bin (35) external;
dcl	error_table_$duplicate_request
			fixed bin (35) external;
dcl	error_table_$inconsistent
			fixed bin (35) external;
dcl	error_table_$logical_volume_not_defined
			fixed bin (35) external;
dcl	error_table_$noarg  fixed bin (35) external;
dcl	error_table_$not_act_fnc
			fixed bin (35) external;
dcl	error_table_$not_privileged
			fixed bin (35) external;
dcl	error_table_$pvid_not_found
			fixed bin (35) external;
dcl	scavenge_vol_severity_
			fixed bin external static;

/*  Entry  */

dcl	active_fnc_err_	entry options (variable);
dcl	com_err_		entry options (variable);
dcl	cu_$af_return_arg	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	get_temp_segments_	entry (char (*), (*) ptr, fixed bin (35));
dcl	hphcs_$scavenge_volume
			entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin (35));
dcl	ioa_		entry options (variable);
dcl	mdc_$read_disk_table
			entry (ptr, fixed bin (35));
dcl	release_temp_segments_
			entry (char (*), (*) ptr, fixed bin (35));
dcl	ring_zero_peek_$by_definition
			entry (char (*), char (*), fixed bin (18), ptr, fixed bin (19), fixed bin (35));


/*  Builtin  */

dcl	addr		builtin;
dcl	char		builtin;
dcl	float		builtin;
dcl	null		builtin;
dcl	size		builtin;
dcl	unspec		builtin;

/*  Condition  */

dcl	cleanup		condition;
dcl	linkage_error	condition;
%page;
/*  Pick up arguments and validate them  */


	unspec (arg_options) = ""b;
	long_sw, have_pvname, have_lvname, all_vols, auto_fl, af_invocation, check_sw = "0"b;
	error_proc = com_err_;

	n_pvs = 0;
	scavenge_vol_severity_ = 1;

	call cu_$af_return_arg (n_args, af_return_ptr, af_return_len, code);
	if code = 0
	then do;
		af_invocation = "1"b;
		check_sw = "1"b;
		error_proc = active_fnc_err_;
	     end;
	else if code ^= error_table_$not_act_fnc
	then do;
		call error_proc (code, MYNAME);
		return;
	     end;

	if n_args = 0
	then do;
USAGE_IS:
		call error_proc (0, MYNAME, "Usage is:     ^a {pvname} {-lv LVNAME} {-all} {-auto} {-nopt} {-dump}",
		     MYNAME);
		call RETURN_AF ("0"b);
		return;
	     end;

	call cu_$arg_ptr (1, argp, argl, code);
	if char (arg, 1) = "-"
	then first_arg = 1;
	else do;
		pvname = arg;
		have_pvname = "1"b;
		first_arg = 2;
	     end;

	do arg_no = first_arg to n_args;
	     call cu_$arg_ptr (arg_no, argp, argl, code);
	     if arg = "-long" | arg = "-lg"
	     then long_sw = "1"b;
	     else if arg = "-debug" | arg = "-db"
	     then arg_options.debug = "1"b;
	     else if arg = "-trap"
	     then arg_options.trap = "1"b;
	     else if arg = "-meter"
	     then arg_options.print_meters = "1"b;
	     else if arg = "-dump"
	     then arg_options.dump = "1"b;
	     else if arg = "-no_optimize" | arg = "-nopt"
	     then arg_options.no_optimize = "1"b;
	     else if arg = "-check"
	     then check_sw = "1"b;
	     else if arg = "-all" | arg = "-a"
	     then all_vols = "1"b;
	     else if arg = "-auto"
	     then auto_fl = "1"b;
	     else if arg = "-lv"
	     then do;
		     if have_lvname
		     then do;
			     call error_proc (error_table_$duplicate_request, MYNAME, "-lv");
			     return;
			end;
		     arg_no = arg_no + 1;
		     call cu_$arg_ptr (arg_no, argp, argl, code);
		     if code ^= 0
		     then do;
LV_ERROR:
			     call error_proc (code, MYNAME, "Logical volume name");
			     call RETURN_AF ("0"b);
			     return;
			end;
		     if char (arg, 1) = "-"
		     then do;
			     code = error_table_$noarg;
			     goto LV_ERROR;
			end;
		     have_lvname = "1"b;
		     lvname = arg;
		end;
	     else if arg = "-fault_under_AST_lock"
	     then arg_options.fault_under_ast = "1"b;
	     else if arg = "-fault_under_volmap_lock"
	     then arg_options.fault_under_volmap = "1"b;
	     else if arg = "-fault_under_PTL"
	     then arg_options.fault_under_pt = "1"b;
	     else do;
		     call error_proc (error_table_$badopt, MYNAME, arg);
		     call RETURN_AF ("0"b);
		     return;
		end;
	end;

%page;
/*  Check arguments for consistency  */


	if check_sw
	     & (arg_options.fault_under_ast | arg_options.fault_under_volmap | arg_options.fault_under_pt
	     | arg_options.debug | arg_options.dump)
	then do;
	          scavenge_vol_severity_ = 1;
		call error_proc (error_table_$inconsistent, MYNAME,
		     "The debugging options (-debug, -dump, -fault_*) are not valid with -check.");
		call RETURN_AF ("0"b);
	     end;
	if (have_pvname & have_lvname) | (have_pvname & all_vols) | (have_lvname & all_vols)
	then do;
		call error_proc (error_table_$inconsistent, MYNAME, "^[pvname ^]^[-lv ^]^[-all^]", have_pvname,
		     have_lvname, all_vols);
		call RETURN_AF ("0"b);
		return;
	     end;
	if ^(have_lvname | all_vols) & auto_fl
	then do;
		call error_proc (error_table_$inconsistent, MYNAME, "-all or -lv must be used with -auto");
		call RETURN_AF ("0"b);
		return;
	     end;

%page;
/*  Build list of physical volumes to scavenge.  */


	on cleanup call CLEAN_OUT;

	call get_temp_segments_ (MYNAME, temp_segs, code);
	if code ^= 0
	then do;
		call error_proc (code, MYNAME, "Getting temp segments.");
		call RETURN_AF ("0"b);
		return;
	     end;

	dtp = temp_segs (1);
	call mdc_$read_disk_table (dtp, code);
	if code ^= 0
	then do;
		call error_proc (code, MYNAME, "Reading disk table.");
		call CLEAN_OUT;
		call RETURN_AF ("0"b);
		return;
	     end;


	if have_pvname
	then do;
		pv_found = "0"b;
		do dtx = 1 to dt.n_entries while (^pv_found);
		     dtep = addr (dt.array (dtx));
		     if dte.used & (dte.pvname = pvname)
		     then do;
			     pv_found = "1"b;
			     call ADD_PVTX (dtx);
			end;
		end;
		if ^pv_found
		then do;
			call error_proc (error_table_$pvid_not_found, MYNAME, pvname);
			call CLEAN_OUT;
			call RETURN_AF ("0"b);
			return;
		     end;
	     end;
	else if have_lvname
	then do;
		do lvx = 1 to dt.n_lv_entries;
		     lvep = addr (dt.lv_array (lvx));
		     if lve.used & (lve.lvname = lvname)
		     then goto LV_FOUND;
		end;
		call error_proc (error_table_$logical_volume_not_defined, MYNAME, lvname);
		call CLEAN_OUT;
		call RETURN_AF ("0"b);
		return;

LV_FOUND:
		do dtx = 1 to dt.n_entries;
		     dtep = addr (dt.array (dtx));
		     if dte.used & (dte.lvx = lvx)
		     then call ADD_PVTX (dtx);
		end;
	     end;
	else if all_vols
	then do;
		do dtx = 1 to dt.n_entries;
		     dtep = addr (dt.array (dtx));
		     if dte.used
		     then call ADD_PVTX (dtx);
		end;
	     end;

	if n_pvs = 0
	then do;
		if ^af_invocation
		then call ioa_ ("^a: No volumes found", MYNAME);
		call CLEAN_OUT;
		call RETURN_AF ("0"b);
		return;
	     end;

	scavenge_vol_severity_ = 0;

	if check_sw
	then do;					/* Don't really want scavenge */
		call RETURN_AF ("1"b);
		call CLEAN_OUT;
		return;
	     end;
%page;
/*  Scavenge each volume.  */


	do pvx = 1 to n_pvs;
	     inconsistency_count = INCONSISTENCY_COUNT (pv_struct (pvx).pvtx, scavenge_in_progress);

	     if auto_fl
	     then if inconsistency_count <= 0
		then goto NEXT_PV;

	     call ioa_ ("Scavenging volume ^a of logical volume ^a", pv_struct (pvx).pvname, pv_struct (pvx).lvname);

	     on linkage_error goto LINKAGE_ERROR;

	     call hphcs_$scavenge_volume (pv_struct (pvx).pvtx, pv_struct (pvx).pvid, addr (arg_options),
		addr (copy_sc_meters), code);

	     revert linkage_error;

	     if code ^= 0
	     then call error_proc (code, MYNAME, "Scavenging ^a.^[ Another scavenge is in progress for the volume.",
		     pv_struct (pvx).pvname, scavenge_in_progress);

	     if long_sw & (code = 0)
	     then do;				/* Wants print of meters */
		     clock_sec = float (copy_sc_meters.clock_time) / 1.0e6;
		     vcpu_sec = float (copy_sc_meters.vcpu) / 1.0e6;

		     call ioa_ ("^/Scavenge of ^a took ^7.1f seconds ^7.1f VCPU seconds ^4d page faults^/",
			pv_struct (pvx).pvname, clock_sec, vcpu_sec, copy_sc_meters.pf);
		     call ioa_ ("^5xVTOCES: ^d examined  ^d per-process  ^d per-bootload  ^d FMDamaged ^d freed^/",
			copy_sc_meters.n_vtoces, copy_sc_meters.n_vtoces_per_proc, copy_sc_meters.n_vtoces_per_boot,
			copy_sc_meters.n_vtoces_fmd, copy_sc_meters.n_vtoces_freed);
		     call ioa_ (
			"^5xRecords: ^d examined  ^d pot. conflicts ^d FMD conflicts  ^d conflicts  ^d lost^/",
			copy_sc_meters.n_records, copy_sc_meters.n_conflicts, copy_sc_meters.n_fmd_conflicts,
			copy_sc_meters.n_real_conflicts, copy_sc_meters.n_lost_records);
		end;

NEXT_PV:
	end;

GLOBAL_RETURN:
	call CLEAN_OUT;
	return;


LINKAGE_ERROR:
	call error_proc (error_table_$not_privileged, MYNAME, "hphcs_");
	call CLEAN_OUT;
	return;

%page;
/*  Internal Procedure to add a volume to the scavenge table  */

ADD_PVTX:
     proc (Pvtx);

dcl	Pvtx		fixed bin;

	if auto_fl
	then if INCONSISTENCY_COUNT (Pvtx, ("0"b)) <= 0
	     then return;

	n_pvs = n_pvs + 1;
	pv_struct (n_pvs).pvtx = Pvtx;
	pv_struct (n_pvs).pvid = dt.array (Pvtx).pvid;
	pv_struct (n_pvs).pvname = dt.array (Pvtx).pvname;
	pv_struct (n_pvs).lvname = dt.lv_array (dt.array (Pvtx).lvx).lvname;

     end ADD_PVTX;
%page;
/*  Internal Procedure to return the volume inconsistency count for a specified
    physical volume. Also checks whether a scavenge is likely in progress. */

INCONSISTENCY_COUNT:
     proc (Pvtx, Scavenge_In_Progress) returns (fixed bin);

dcl	Pvtx		fixed bin;
dcl	Scavenge_In_Progress
			bit (1) aligned;

dcl	1 local_pvte	aligned like pvte;

	call ring_zero_peek_$by_definition ("pvt", "array", ((Pvtx - 1) * size (pvte)), addr (local_pvte), size (pvte),
	     code);
	if code ^= 0
	then do;
		call error_proc (code, MYNAME, "^a", dt.array (Pvtx).pvname);
		goto GLOBAL_RETURN;
	     end;
	Scavenge_In_Progress = (local_pvte.scavenger_block_rel ^= ""b);
	return (local_pvte.vol_trouble_count);

     end INCONSISTENCY_COUNT;
%page;
/*  Internal Procedure to return string of PVs if invoked as an active function,
    or to print (non-empty) list of PVs if invoked with -check.  */

RETURN_AF:
     proc (Have_Pvs);

dcl	Have_Pvs		bit (1) aligned;

dcl	pvx		fixed bin;

	if af_invocation
	then do;
		af_return = "";
		if Have_Pvs
		then do pvx = 1 to n_pvs;
			af_return = af_return || pv_struct (pvx).pvname || " ";
		     end;
	     end;
	else if check_sw
	then do;
		if Have_Pvs & (n_pvs > 0)
		then do;
			call ioa_ ("^/Volumes to be Scavenged:^/");
			do pvx = 1 to n_pvs;
			     call ioa_ ("^3x^a^-(^a)", pv_struct (pvx).pvname, pv_struct (pvx).lvname);
			end;
			call ioa_ ("");
		     end;
	     end;

     end RETURN_AF;



%page;
/*  Internal Procedure to clean up  */

CLEAN_OUT:
     proc;

	if temp_segs (1) ^= null ()
	then call release_temp_segments_ (MYNAME, temp_segs, code);
	temp_segs (1) = null ();

     end CLEAN_OUT;


/* format: off  */
%page; %include disk_table;
%page; %include pvte;
%page; %include scavenger_data;

     end scavenge_vol;




		    sweep_pv.pl1                    03/08/88  1040.5rew 03/08/88  1039.4      253773



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */

/* format: off */

sweep_pv: proc;

	go to spv;


/* sweep_pv by Bernard Greenberg  6/12/76 
   adopter by BSG, 8/2/77 
   Modified March 1982, J. Bongiovanni, to remove optimizer (ring-0 does it now),
	  to fix some bugs, and generally clean up the code
*/


/****^  HISTORY COMMENTS:
  1) change(87-11-12,Farley), approve(88-03-01,MCR7816),
     audit(88-03-03,Fawcett), install(88-03-08,MR12.2-1033):
     Added use of hphcs_$clear_vtoce when the error code from cv_uid_path
     is error_table_$bad_uidpath or the filemap in the vtoce is thought to
     be bad, instead of hphcs_$delete_vtoce, when using the -delete option.
     This indicates that the VTOCE is in error and attempting to possibly
     free the vtoce.fm pages could cause much more damage. (phx20964)
     
     Corrected code so that "dir" privilege is not removed from the user's
     process after this program executes. (phx17077).
     
     Generally cleaned up the code.
                                                   END HISTORY COMMENTS */


/*  Automatic  */

dcl 1 acla (1) aligned,
    2 userid char (32),
    2 modes bit (36),
    2 aclaec fixed bin (35);
dcl  adopting bit (1);
dcl  areap ptr;
dcl  argl fixed bin;
dcl  argp ptr;
dcl  chainptrs (0:15) ptr;
dcl  checksum bit (36) aligned;
dcl  code fixed bin (35);
dcl  code1 fixed bin (35);
dcl  damaged_ct fixed bin;
dcl  dbsw bit (1);
dcl  del_this bit (1);
dcl  deleted bit (1);
dcl  dir char (168);
dcl  dl_mode bit (1);
dcl  dswitch ptr;
dcl  dts4 char (4) defined dtstart pos (11);
dcl  dtstart char (24);
dcl  ent char (32);
dcl  eswitch ptr;
dcl  excuse char (10);
dcl  force bit (1);
dcl  fromsw bit (1);
dcl  fv fixed bin;
dcl  gc_comment char (20);
dcl  gcsw bit (1);
dcl  i fixed bin;
dcl  inhibit_on bit (1);
dcl  lastv fixed bin;
dcl  listopt bit (1);
dcl  llines fixed bin;
dcl 1 local_vtoce like vtoce aligned;
dcl  lswitch ptr;
dcl  myname char (32);
dcl  namealloclen fixed bin;
dcl  n_args fixed bin;
dcl  onlysw bit (1);
dcl  pageno fixed bin;
dcl  pn char (168);
dcl  pvid bit (36) aligned;
dcl  pvname char (32);
dcl  pvtx fixed bin;
dcl  recsgotten fixed bin;
dcl  rstate fixed bin;
dcl  set_priv bit (1);
dcl  started bit (1);
dcl  tosw bit (1);
dcl  tptr ptr;
dcl  vacating bit (1);
dcl  vsgotten fixed bin;
dcl  vsrecovered fixed bin;
dcl  vtocx fixed bin;

/*  Based  */

dcl  arg char (argl) based (argp);
dcl  allocarea area based (areap);
dcl 1 restore_name based aligned,
    2 fp ptr unal,
    2 namelen fixed bin (8) unal,
    2 name char (namealloclen refer (restore_name.namelen)) unal;

/*  Constants  */

dcl  EF_open fixed bin internal static options (constant) init (6);
dcl  GC_open fixed bin internal static options (constant) init (4);
dcl  LS_open fixed bin internal static options (constant) init (2);

/*  External  */

dcl  error_table_$action_not_performed fixed bin (35) external;
dcl  error_table_$badopt fixed bin (35) external;
dcl  error_table_$bad_uidpath fixed bin (35) external;
dcl  error_table_$inconsistent fixed bin (35) external;
dcl  error_table_$incorrect_access fixed bin (35) external;
dcl  error_table_$invalid_vtocx fixed bin (35) external;
dcl  error_table_$no_dir fixed bin (35) external;
dcl  error_table_$noentry fixed bin (35) external;
dcl  error_table_$not_privileged fixed bin (35) external;
dcl  error_table_$root fixed bin (35) external;

/*  Entry  */

dcl  adopt_seg_ entry (char (*), char (*), bit (36) aligned, fixed bin, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
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_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  date_time_ entry (fixed bin (52), char (*));
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  date_time_$fstime entry (bit (36) aligned, char (*));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  filemap_checksum_ entry (ptr, fixed bin, bit (36) aligned);
dcl  get_group_id_ entry returns (char (32) aligned);
dcl  get_system_free_area_ entry returns (ptr);
dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$delete_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hphcs_$clear_vtoce entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  hphcs_$delete_vtoce entry (bit (36), bit (36) aligned, fixed bin, fixed bin (35));
dcl  hphcs_$pv_move_file entry (char (*), char (*), fixed bin (35));
dcl  hphcs_$stop_vacate_pv entry (fixed bin, bit (36) aligned, fixed bin (35));
dcl  hphcs_$vacate_pv entry (fixed bin, bit (36) aligned, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ioa_$ioa_switch entry options (variable);
dcl  ioa_$rsnnl 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_$user_output ptr external;
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  system_privilege_$dir_priv_off entry (fixed bin (35));
dcl  system_privilege_$dir_priv_on entry (fixed bin (35));
dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  vpn_cv_uid_path_$ent entry (ptr, char (*), bit (36), fixed bin (35));

/*  Builtin  */

dcl  addr builtin;
dcl  clock builtin;
dcl  dim builtin;
dcl  fixed builtin;
dcl  hbound builtin;
dcl  lbound builtin;
dcl  length builtin;
dcl  mod builtin;
dcl  null builtin;
dcl  reverse builtin;
dcl  rtrim builtin;
dcl  substr builtin;
dcl  verify builtin;

/*  Condition  */

dcl  cleanup condition;
dcl  linkage_error condition;


/*  */
inhibit_pv: entry;

          myname = "inhibit_pv";
	inhibit_on = "1"b;
	
	call cu_$arg_count (n_args, code);
	if code ^= 0 then do;
	     call com_err_ (code, myname);
	     return;
	end;
	
	if n_args = 0 | n_args > 2 then do;
	     call ioa_ ("^a: Usage is:     ^a pvname {-off}", myname, myname);
	     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);
	     return;
	end;
	
	if n_args >= 2 then do;
	     call cu_$arg_ptr (2, argp, argl, code);
	     if arg = "-off" then inhibit_on = "0"b;
	     else do;
		call com_err_ (error_table_$badopt, myname, arg);
		return;
	     end;
	end;
	
	on linkage_error goto NOT_PRIVILEGED;

	if inhibit_on
	     then call hphcs_$vacate_pv (pvtx, pvid, code);
	else call hphcs_$stop_vacate_pv (pvtx, pvid, code);
	
	revert linkage_error;

	if code ^= 0 then do;
	     call com_err_ (code, myname, "Attempting to ^[^;un-^]inhibit ^a",
		(inhibit_on), pvname);
	     return;
	end;

	return;


/*  */
spv:

	myname = "sweep_pv";
	adopting, dbsw, dl_mode, force, fromsw, gcsw, listopt, onlysw, set_priv,
	     started, tosw, vacating = "0"b;
	damaged_ct, fv, llines, recsgotten, rstate, vsgotten, vsrecovered = 0;
	lastv = MAX_VTOCE_PER_PACK;
	pageno = 1;
	dswitch, eswitch, lswitch = null ();

	call cu_$arg_count (n_args, code);
	if code ^= 0 then do;
	     call com_err_ (code, myname);
	     return;
	end;
	
	if n_args = 0 then do;
	     call ioa_ ("^a: Usage is:  ^a pvname {-collect|-gc} {-list|-ls} {-adopt}
		{-from vtocx} {-to vtocx} {-only vtocx} {-force|-fc}
		{-move|-mv} {-delete|-dl}", myname, myname);
	     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);
	     return;
	end;
	
%page;
/*  Collect Arguments and Validate Same  */

          do i = 2 to n_args;
	     call cu_$arg_ptr (i, argp, argl, code);
	     if arg = "-gc" | arg = "-collect" then gcsw = "1"b;
	     else if arg = "-ls" | arg = "-list" then listopt = "1"b;
	     else if arg = "-move" | arg = "-mv" then vacating = "1"b;
	     else if arg = "-adopt" then adopting = "1"b;
	     else if arg = "-delete" | arg = "-dl" then dl_mode = "1"b;
	     else if arg = "-debug" | arg = "-db" then dbsw = "1"b;
	     else if arg = "-from" then fv = numarg (fromsw);
	     else if arg = "-to" then lastv = numarg (tosw);
	     else if arg = "-only" then lastv, fv = numarg (onlysw);
	     else if arg = "-force" | arg = "-fc" then force = "1"b;
	     else do;
		call com_err_ (error_table_$badopt, myname, arg);
		return;
	     end;

	end;

	call checkincon (dl_mode & ^gcsw, "-delete requires -gc.");
	call checkincon (adopting & ^gcsw, "-adopt requires -gc.");
	call checkincon ((fromsw | tosw) & onlysw, "-only is inconsistent with -from/-to.");
	call checkincon (fromsw & tosw & lastv < fv, "Last vtoce # is less than first.");
	call checkincon (^dbsw & ^ vacating & ^ listopt & ^ gcsw, "No action specified.");

	if vacating then do;
	     on linkage_error goto NOT_PRIVILEGED;
	     call hphcs_$vacate_pv (pvtx, pvid, code);
	     revert linkage_error;
	     if code ^= 0 then do;
		call com_err_ (code, myname, "Attempting to inhibit ^a", pvname);
		return;
	     end;
	     call ioa_ ("^a: Volume ^a inhibited", myname, pvname);
	end;
	

	on cleanup call finish;

	if force then do;
	     areap = get_system_free_area_ ();
	     chainptrs (*) = null ();
	     acla (1).userid = get_group_id_ ();	/* Get acl info for forcing */
	     acla (1).modes = SMA_ACCESS;

	     on linkage_error begin;
		call com_err_ (0, myname, "Unable to set AIM privilege. Access may be incomplete.");
		go to revert_handler;
	     end;
	     call system_privilege_$dir_priv_on (code);	/* Try to give AIM authority */
	     set_priv = (code = 0);			/* If given, remember to take away later */
revert_handler:
	     revert linkage_error;

	end;



	call date_time_ (clock (), dtstart);

	if listopt then call attach (lswitch, "pvlist", "Listing");
	else rstate = LS_open;			/* update so finish will work properly */

	if gcsw then do;
	     call attach (dswitch, "pvgc", "Disconnection");
	     call ioa_$ioa_switch (dswitch, "PV COLLECTION  -- Vol ^a  ^o to ^o   ^a^3/", pvname, fv, lastv, dtstart);
	end;
	else rstate = GC_open;			/* update so finish will work properly */


	if adopting then gc_comment = "Recovering";
	else if dl_mode then gc_comment = "Deleting";
	else gc_comment = "Unconnected";


/*          SCAN THE VTOC

   This loop walks the selected region of the VTOC, performing the following operations for
   all non-free vtoces:
   1. Develop the pathname, forcing all access as necessary. (See s/r cv_uid_path).
   2. If reverse connection failure, and gc-mode, report and possibly delete it.
   3. If adopting, attempt to construct a branch for the segment or direcory.
   4. If moving segments, call hphcs to move the segment via the segment mover.
   5. If listing, produce a report line.
   6. Write all errors to the error file.


*/

	started = "1"b;
	vtocep = addr (local_vtoce);

	do vtocx = fv to lastv by 1;
	     call phcs_$get_vtoce (pvtx, vtocx, vtocep, code);
	     if code ^= 0 then do;
		vtoce.uid = "0"b;			/* for next thing */

		if code = error_table_$invalid_vtocx then go to fin;
		call ckef;
		call ioa_$ioa_switch (eswitch, "^8o^3x^6a^3x^a", vtocx, time (), einterp (code));
	     end;

	     if vtoce.uid ^= "0"b then do;
		deleted = "0"b;
		call cv_uid_path (addr (vtoce.uid_path), pn, vtoce.uid, code);
		if code ^= 0 then do;

/* The following code deals with the case of reverse connection failure. */

		     if code = error_table_$noentry | code = error_table_$no_dir then do;
			if code = error_table_$noentry then excuse = "No Entry."; else excuse = "No Dir.";
			if ^gcsw then go to a;
			call ioa_$ioa_switch (dswitch, "^8o^3x^6a^3x^10a^3x^a Vtoce: ^a",
			     vtocx, time (), excuse, gc_comment, pn);
			call ioa_$ioa_switch (dswitch, "^33x= ""^a"", modified ^a, used ^a",
			     vtoce.primary_name, dtc (vtoce.dtm), dtc (vtoce.dtu));
			if adopting then do;
			     if code = error_table_$no_dir then do;
				call ioa_$ioa_switch (dswitch,
				     "^33xWill not reconnect: superior directory missing.");
				if dl_mode then call ioa_$ioa_switch (dswitch,
				     "^33xWill attempt to delete ^a", pn);
				del_this = "1"b;
			     end;
			     else do;		/* Entry missing- try reconnect */
				call expand_pathname_ (pn, dir, (32)" ", (0));
				ent = gen_uname (vtoce.primary_name);
				call adopt_seg_ (dir, ent, pvid, pvtx, vtocx, code1);
				if dir = ">" then dir = "";
				pn = rtrim (dir) || ">" || ent;
				if code1 = 0 then do;
				     vsrecovered = vsrecovered + 1;
				     call ioa_$ioa_switch (dswitch,
					"^33xAdopted ^o as ^a.", vtocx, pn);
				end;
				else do;
				     call ckef;
				     do tptr = eswitch, dswitch;
					call ioa_$ioa_switch (tptr, "^8o^3x^6a^3xError Reconnecting vtoce: ^a ^a.",
					     vtocx, time (), einterp (code1), pn);
				     end;
				end;
				del_this = "0"b;
			     end;
			end;
			else del_this = "1"b;
			deleted = "1"b;
			if dl_mode & del_this then do;
			     if ^vtoce.fm_damaged & vtoce.fm_checksum_valid then do;
				call filemap_checksum_ (addr (vtoce.fm), fixed (vtoce.csl), checksum);
				if vtoce.fm_checksum ^= checksum then vtoce.fm_damaged = "1"b;
			     end;
			     if code = error_table_$bad_uidpath | vtoce.fm_damaged
			     then call hphcs_$clear_vtoce (pvid, vtocx, code1);
			     else call hphcs_$delete_vtoce (vtoce.uid, pvid, vtocx, code1);
			     if code1 ^= 0 then do;
				call ckef;
				do tptr = eswitch, dswitch;
				     call ioa_$ioa_switch (tptr,
					"^8o^3x^6a^3xError Deleting vtoce: ^a ^a",
					vtocx, time (), einterp (code1), pn);
				end;
			     end;
			end;
			else code1 = 0;
			if code1 = 0 then do;
			     vsgotten = vsgotten + 1;
			     recsgotten = recsgotten + fixed (vtoce.records, 9);
			end;
		     end;
		     else do;
a:			call ckef;
			call ioa_$ioa_switch (eswitch, "^8o^3x^6a^3x^a^x^a",
			     vtocx, time (), einterp (code), pn);
		     end;
		end;

/* Check the VTOCE for consistency */

		call validate_vtoce;

/* See if damaged, report it if so. */

		if vtoce.damaged then do;
		     if listopt then do;
			call cktop;
			llines = llines + 1;
		     end;
		     call ckef;
		     do tptr = eswitch, lswitch;
			if tptr ^= null then call ioa_$ioa_switch (tptr, "^8o^3x^6a^3x^a^x^a",
			     vtocx, time (), "This segment is damaged:", pn);
		     end;
		     damaged_ct = damaged_ct + 1;
		end;

/* If vacating, develop pathname and call hphcs. */

		if vacating then do;
		     if code ^= 0 then;
		     else do;
			call expand_pathname_ (pn, dir, ent, code1);
			if dbsw then code1 = 0;
			else call hphcs_$pv_move_file (dir, ent, code1);
			if code1 ^= 0 then do;
			     call ckef;
			     call ioa_$ioa_switch (eswitch, "^8o^3x^6a^3xError Moving Segment: ^a ^a",
				vtocx, time (), einterp (code1), pn);
			end;
		     end;
		end;

/* If listing, produce report line. */

		if listopt then do;
		     call cktop;
		     call ioa_$ioa_switch (lswitch, "^8o^x^[*^;^x^]^x^[^7d^;^s^7x^]^x^a^[ (^a)^]",
			vtocx, deleted, ^vtoce.dirsw, seg_vtoce.usage, pn, deleted, excuse);
		     llines = llines + 1;
		end;
	     end;
	end;

	vtocx = vtocx -1;


fin:
nlexit:
	call finish;
	return;


NOT_PRIVILEGED:
	call com_err_ (error_table_$not_privileged, myname, "hphcs_");
	return;
	

%page;


attach:	proc (tptr, head, name);

/* Make all output file attachments, incrementing rstate as we go, so that
   partially complete attachments can be cleaned up. */


dcl  atdesc char (57);
dcl  codea fixed bin (35);
dcl  tptr ptr;
dcl (head, name) char (*);

	     call ioa_$rsnnl ("vfile_ ^a.^a.^a", atdesc, 0, head, pvname, dts4);

	     call iox_$attach_ioname ("switch." || head, tptr, atdesc, codea);
	     if codea ^= 0 then do;
		call com_err_ (codea, myname, "Attaching ^a file.", head);
		go to fin;
	     end;
	     rstate = rstate + 1;

	     call iox_$open (tptr, Stream_output, "0"b, codea);
	     if codea ^= 0 then do;
		call com_err_ (codea, myname, "Opening ^a file", head);
		go to fin;
	     end;
	     rstate = rstate + 1;
	     call ioa_ ("^a: ^a file attached to ^a", myname, name, substr (atdesc, 7));
	     return;
	end;

/*  */
/* UNIQUE-NAME-FOR-ADOPT GENERATOR */

gen_uname: proc (aname) returns (char (32));

dcl  aname char (32);
dcl  uname char (15);

	     uname = unique_chars_ (""b);		/* Get a truly unique name */
	     if length (rtrim (aname)) > 15 & substr (aname, 1, 3) = "!BB"
	     then return (uname || substr (aname, 16));
	     else return (uname || rtrim (aname));

	end gen_uname;


cktop:	proc;

/* check page overflow counter */

	     if mod (llines, 54) = 0 then do;
		call ioa_$ioa_switch (lswitch, "^|PV LISTING^10xVolume ^a  ^a^3xfrom ^o to ^o^6xPage ^d",
		     pvname, dtstart, fv, lastv, pageno);
		call ioa_$ioa_switch (lswitch, "VTOC INDEX^3xUSAGE^5xPATHNAME");
		pageno = pageno + 1;
		call ioa_$ioa_switch (lswitch, "^2/");
		llines = llines + 4;
	     end;

	end cktop;

/*  */
/* VTOCE CONSISTENCY CHECK */

validate_vtoce:
     proc;

dcl  csl fixed bin;					/* working current length */
dcl  error_mess char (200);				/* Formatted message */
dcl  error_mess_len fixed bin (21);			/* Length of formatted message */
dcl  fmx fixed bin;					/* file map index */
dcl  msl fixed bin;					/* working max length */
dcl  records fixed bin;				/* working number records */




     csl, records = 0;
     msl = 256;
     do fmx = 0 to msl - 1;
	if substr (vtoce.fm (fmx), 1, 1) ^= "1"b then do; /* non-null  address			*/
	     records = records + 1;
	     csl = fmx + 1;
	end;
     end;

     if fixed (vtoce.records, 9) ^= records
	then do;
	call ioa_$rsnnl ("^8o^3x^6a^3xrecords used=^o(should be ^o):^a",
	     error_mess, error_mess_len, vtocx, time (), fixed (vtoce.records), records, pn);
	call report_error (error_mess);
     end;

     if fixed (vtoce.csl, 9) ^= csl
	then do;
	call ioa_$rsnnl ("^8o^3x^6a^3xcur length=^o(should be ^o):^a",
	     error_mess, error_mess_len, vtocx, time (), fixed (vtoce.csl), csl, pn);
	call report_error (error_mess);
     end;
     

     if fixed (vtoce.msl, 9) > msl | fixed (vtoce.msl, 9) < csl
	then do;
	call ioa_$rsnnl ("^8o^3x^6a^3xmax len=^o:^a", error_mess, error_mess_len,
	     vtocx, time (), fixed (vtoce.msl), pn);
	call report_error (error_mess);
     end;
     


     return;

report_error:
     proc (message);
     
     dcl  message char (*);
     

     if listopt then do;
	call cktop;
	llines = llines + 1;
     end;
     call ckef;
     do tptr = eswitch, lswitch;
	if tptr ^= null ()
	     then call ioa_$ioa_switch (tptr, "^a", message);
     end;
     
end report_error;


     end validate_vtoce;
     


/* 	*/
/* UTILITY CONVERSION ROUTINES */


time: proc () returns (char (6));

/* Return a printable time. */

	     return ((date_time_$format ("^Hd^99v.9MH", clock (), "", "")));
	end time;

einterp:	proc (cd) returns (char (100));

/* Provide printable error messages from error codes. It should be observed
   that vpn_cv_uid_path_ (external) returns error_table_$action_not_performed if
   he loses races with directory control after a sufficient number of
   retries. cvuid_rcurse (below) also returns this if he loses a race with a
   malicious name-changer. */

dcl  ignore char (8) aligned, long char (100) aligned, cd fixed bin (35);
	     if code = error_table_$action_not_performed
	     then return ("Unable to get consistent copy of directories/pathnames.");
	     call convert_status_code_ (cd, ignore, long);
	     return (long);
	end;

ckef:	proc;

/* Attach error file if not already attached. */

	     if rstate < EF_open then do;
		call attach (eswitch, "pvef", "Error");
		call ioa_$ioa_switch (eswitch, "PV SWEEP ERROR FILE    Volume ^a    ^a^2/", pvname, dtstart);
	     end;
	end;

dtc:	proc (fs_time) returns (char (24));
dcl  fs_time bit (36);
dcl  date char (24);

	     call date_time_$fstime ((fs_time), date);
	     return (date);
	end;

/*  */

/* PROCEDURES USED IN ARGUMENT COLLECTION/VALIDATION */

numarg:	proc (flag) returns (fixed bin);		/* Proc to pick up one more numeric arg */
						/* THIS MUST BE PL/I QUICK BLOCK */
						/* AS cu_argptr is used */

dcl  key char (10) init (arg);			/* Save old thing */
dcl  stuff fixed bin;
dcl  flag bit (1);

	     i = i + 1;				/* Step over key */
	     call cu_$arg_ptr (i, argp, argl, code);
	     if code ^= 0 then do;
		call com_err_ (code, myname, "Octal # expected after ^a.", key);
		go to nlexit;
	     end;

	     stuff = cv_oct_check_ (arg, code);
	     if code ^= 0 then do;
		call com_err_ (0, myname, "Bad octal arg for ^a: ^a", key, arg);
		go to nlexit;
	     end;
	     flag = "1"b;
	     return (stuff);
	end;


checkincon: proc (truth, message);

dcl  truth bit (1), message char (*);

	     if truth then do;
		call com_err_ (error_table_$inconsistent, myname, message);
		go to nlexit;
	     end;
	end checkincon;
						/*  */

/* GENERAL CLEANUP/TERMINATION PROCEDURE */


finish:	proc;
	     if started then do;
						/* Clean up large stuff iff started. */
		call ioa_ ("Processed to vtocx ^o.", vtocx);
		if set_priv then call system_privilege_$dir_priv_off ((0));
		if force then call restore_all_access;
	     end;
	     go to rrecover (rstate);
						/* Undo whatever was done */
rrecover (6):					/* EF_open */
	     if damaged_ct > 0 then do tptr = eswitch, lswitch, iox_$user_output;
		if tptr ^= null then call ioa_$ioa_switch (tptr, "^/Found ^d damaged segment^[s^].", damaged_ct, (damaged_ct > 1));
	     end;
	     call iox_$close (eswitch, (0));
rrecover (5):
	     call iox_$detach_iocb (eswitch, (0));
rrecover (4):					/* GC_open, maybe */
	     if gcsw then call ioa_$ioa_switch (dswitch, "^/^d Vtoces collected, ^d records", vsgotten, recsgotten);
	     if adopting then call ioa_$ioa_switch (dswitch, "^d Vtoces reconnected.", vsrecovered);
	     if gcsw then call iox_$close (dswitch, (0));
rrecover (3):
	     if gcsw then call iox_$detach_iocb (dswitch, (0));
rrecover (2):					/* LS_open, maybe */
	     if listopt then call ioa_$ioa_switch (lswitch, "^/Processed to VTOCX ^o", vtocx);
	     if listopt then call iox_$close (lswitch, (0));
rrecover (1):
	     if listopt then call iox_$detach_iocb (lswitch, (0));
rrecover (0):
	     return;
	end finish;

/* PROCEDURES TO COMPUTE NAME, POTENTIALLY FORCING ACCESS */

cv_uid_path: procedure (a_uidpp, a_pn, a_uid, a_code);

dcl  a_uidpp ptr, a_pn char (*), a_uid bit (36), a_code fixed bin (35) aligned;

dcl  lev fixed bin;
dcl  uidpth (0:15) based (a_uidpp) bit (36) aligned;

	     do lev = 0 to 15 while (uidpth (lev) ^= "0"b);
	     end;

	     if lev = 15 then if uidpth (15) ^= "0"b then lev = 16;

	     call cvuid_recurse (a_uidpp, a_pn, a_uid, lev, a_code); /* Do the dirty deed */
	     return;


cvuid_recurse: procedure (a_uidp, a_pn, a_uid, a_lev, a_code);

dcl  a_uidp ptr, a_uid bit (36), a_pn char (*), a_lev fixed bin, a_code fixed bin (35);
dcl  lpn char (168), luid bit (36), lev fixed bin;
dcl  locuidpth (0:15) bit (36) aligned;
dcl  uidpth (0:15) bit (36) aligned based (a_uidp), pc1 fixed bin;

/* Call this procedure to get pathname for (a_uidp->uidpth)>(a_uid) or reason why not.
   a_lev is 1 greater than last valid component # in a_uidp -> uidpth.

   Strategy is to call vpn_cv_uid_path_...
   And if that fails, try to identify parent and try again...
   And if that fails, give status access to parent and try again...
   And if that fails, you lost a race, return action_not_perf. */


		do pc1 = 1 to 3;			/* Prog ctr thru steps */
		     call vpn_cv_uid_path_$ent (a_uidp, a_pn, a_uid, a_code); /* Try it */
		     if a_code = 0 then return;	/* If it won, that's it. */
		     if a_code ^= error_table_$incorrect_access then return; /* If not access, we can't help */
		     if pc1 = 1 then do;		/* First desperation */
			lev = a_lev - 1;		/* Get lower lev */
			if ^force then return;	/* Not even supposed to try. */
			luid = uidpth (lev);
			locuidpth = uidpth;
			locuidpth (lev) = "0"b;	/* Get name of father */
			call cvuid_recurse (addr (locuidpth), lpn, luid, lev, a_code);
			if a_code ^= 0 then return;	/* If he can't hack it, give up */
		     end;				/* We may now have enough to complete */
		     else if pc1 = 2 then do;		/* Must give access on father */
			call giver_of_access ("100"b, lpn, lev, a_code);
			if a_code ^= 0 then return;	/* He tried his best */
		     end;				/* Try with new access */
		end;
		a_code = error_table_$action_not_performed; /* Raced pathnames */
	     end cvuid_recurse;

giver_of_access: procedure (abits, ac_pn, ac_lev, aa_code);

/* Gives abits-access to ac_pn directory, or why not */

dcl  abits bit (3), ac_pn char (*), aa_code fixed bin (35);
dcl  ac_lev fixed bin;
dcl  dir char (168), ent char (32);
dcl  pc2 fixed bin;

/* Strategy is to try to add acle. If that fails,
   give sma to father. If that fails, reflect failure. */

		call expand_pathname_ (ac_pn, dir, ent, (0)); /* Computers don't make mistakes */

		do pc2 = 1 to 2;			/* Count desperations */
		     acla.modes (1) = abits;		/* Reinit for clobberance */
		     call hcs_$add_dir_acl_entries (dir, ent, addr (acla), dim (acla, 1), aa_code);
		     if aa_code = 0 then do;
			call register_pn (ac_pn, ac_lev); /* Remember for undo */
			return;
		     end;
		     if aa_code = error_table_$root then do;
			aa_code = error_table_$incorrect_access;
			return;			/* => ultimately no access */
		     end;
		     if aa_code ^= error_table_$incorrect_access then return;
		     if pc2 = 1 then do;		/* First desperate */
			call giver_of_access ("111"b, dir, ac_lev - 1, aa_code); /* Access to father */
			if aa_code ^= 0 then return;	/* Nogo */
		     end;
		end;
						/* If we're here, we're blocked */
		return;

register_pn:	proc (b_pn, b_lev);

/* Add b_pn to a list of pathnames at level b_lev, so that restore_all_access (below)
   can hand it back reversely by level. */



dcl  b_pn char (*), b_lev fixed bin;
dcl  namp ptr;
		     do namp = chainptrs (b_lev) repeat namp -> restore_name.fp while (namp ^= null ());
		     end;
		     if namp = null then do;		/* Put in table anew */
			namealloclen = length (b_pn) + 1 - verify (reverse (b_pn), " ");
			allocate restore_name in (allocarea) set (namp);
			namp -> restore_name.namelen = namealloclen;
			namp -> restore_name.fp = chainptrs (b_lev);
			namp -> restore_name.name = b_pn;
			chainptrs (b_lev) = namp;
		     end;				/* Can refind if was s, now sma */
		end register_pn;
	     end giver_of_access;
	end cv_uid_path;


/*  */

/* CLEANUP PROC FOR NAME COMPUTER */

restore_all_access: procedure;			/* Invoked to give back what has been taken */

dcl  lev fixed bin;
dcl  rdir char (168), rent char (32);
dcl (namp, pman) ptr;

	     do lev = hbound (chainptrs, 1) to lbound (chainptrs, 1) by -1;
		do namp = chainptrs (lev) repeat pman while (namp ^= null ());
		     pman = namp -> restore_name.fp;
		     call expand_pathname_ (namp -> restore_name.name, rdir, rent, (0));
		     call hcs_$delete_dir_acl_entries (rdir, rent, addr (acla), dim (acla, 1), (0));
		     free namp -> restore_name in (allocarea);
		end;
	     end;
	end restore_all_access;
						/*  */

						/*  */
%page; %include access_mode_values;
%page; %include aim_template;
%page; %include disk_pack;
%page; %include iox_modes;
%page; %include vtoce;

end sweep_pv;




		    vtocx_to_record.pl1             10/29/86  1039.4r w 10/28/86  1025.9       43065



/****^  ***********************************************************
        *                                                         *
        * 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.
                                                   END HISTORY COMMENTS */



vtocx_to_record: proc;

dcl (ioa_, ioa_$rsnnl, com_err_, active_fnc_err_) entry options (variable);
dcl (record, sector) fixed bin;
dcl  abssec fixed bin;
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  getter entry (fixed bin, ptr, fixed bin, fixed bin (35)) variable;
dcl  gripe variable entry options (variable);
dcl  code fixed bin (35);
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  myname char (32);
dcl  arg char (arglen) based (argptr);
dcl  argptr ptr, arglen fixed bin;

dcl  vtocx fixed bin;
dcl  dvt fixed bin;
dcl  targ char (8);
dcl  nargs fixed bin;
dcl  error_table_$not_act_fnc fixed bin (35) ext;
dcl  ap1 ptr, al1 fixed bin;
dcl  answer char (al1) varying based (ap1);
dcl  nafsw bit (1) init ("0"b);

dcl (usable, unusable) fixed bin;

dcl (divide, hbound, mod) builtin;
	       

mulphy:	proc (rec) returns (fixed bin);
dcl (sect, rec) fixed bin;
	     sect = rec * 16;
	     sect = sect + divide (sect, usable, 17, 0) * unusable;
	     return (sect);
	end mulphy;

phymul:	proc (sect) returns (fixed bin);
dcl (r, sect) fixed bin;
	     r = divide (sect, sect_per_cyl (dvt), 17, 0) * unusable;
	     return (divide (sect - r, 16, 17, 0));
	end phymul;



	myname = "vtocx_to_record";
gtarg:
	call cu_$af_return_arg (nargs, ap1, al1, code);
	if code ^= 0 then
	     if code = error_table_$not_act_fnc then do;
		nafsw = "1"b;
		gripe = com_err_;
		getter = cu_$arg_ptr;
	     end;
	     else do;
		call active_fnc_err_ (code, myname, "");
		return;
	     end;
	else do;
	     gripe = active_fnc_err_;
	     getter = cu_$af_arg_ptr;
	end;
	call getter (2, argptr, arglen, code);
	if code = 0 then targ = arg; else targ = "d451";
	if targ = "m400" then targ = "d400";		/* For MR7.0 only */
	else if targ = "m451" then targ = "d451" ;	/* For MR7.0 only */
	do dvt = 1 to hbound (device_names, 1);
	     if targ = device_names (dvt) then go to gotdvt;
	end;
	call gripe (0, myname, "unknown device_type ""^a"". Legal types are ^(^a ^)", targ, device_names);
	return;
gotdvt:
	usable = divide (sect_per_cyl (dvt), sect_per_rec (dvt), 17, 0) * sect_per_rec (dvt);
	unusable = sect_per_cyl (dvt) - usable;
	call getter (1, argptr, arglen, code);
	if code ^= 0 then do;
	     call gripe (code, myname);
	     return;
	end;

	vtocx = cv_oct_check_ (arg, code);
	if code ^= 0 then do;
	     call gripe (0, myname, "Invalid octal: ^a", arg);
	     return;
	end;

	if myname = "vtocx_to_record" then do;
	     record = VTOC_ORIGIN + divide (vtocx, vtoc_per_rec (dvt), 17, 0);
	     sector = mod (vtocx, vtoc_per_rec (dvt)) * sect_per_vtoc (dvt);
	     if record > rec_per_dev (dvt) then go to toobig;
	end;
	else if myname = "record_to_sector" then do;
	     sector = 0;
	     record = vtocx;
	     if record > rec_per_dev (dvt) then do;
toobig:		call gripe (0, myname, "Address too big: ^o", vtocx);
		return;
	     end;
	end;

	if myname = "sector_to_record" then do;
	     abssec = vtocx;
	     if abssec > sect_per_cyl (dvt) * cyl_per_dev (dvt) then go to toobig;
	     record = phymul (abssec);
	     sector = abssec - mulphy (record);
	end;
	else abssec = sector + mulphy (record);
	if nafsw then do;
	     if myname = "vtocx_to_record"
	     then call ioa_ ("^-vtocx ^o = Rec ^o, rs ^o; abs sect ^o (^a)", vtocx, record, sector, abssec, device_names (dvt));
	     else call ioa_ ("^-Rec ^o, rs ^o = abs sect ^o (^a)", record, sector, abssec, device_names (dvt));
	     return;
	end;

	if myname = "vtocx_to_record" | myname = "sector_to_record"
	then call ioa_$rsnnl ("^o", answer, (0), record);
	else call ioa_$rsnnl ("^o", answer, (0), abssec);


	return;

record_to_sector: entry;
	myname = "record_to_sector";
	go to gtarg;
sector_to_record: entry;
	myname = "sector_to_record";
	go to gtarg;
%include disk_pack;
%include	fs_dev_types;
     end;






		    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
