



		    dbm_man.pl1                     11/11/89  1133.9rew 11/11/89  0800.7      103698



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

dbm_man: proc;

/* This routine manages the initialization, allocating, freeing, setting and resetting of the
   bit maps that control the system dumper. For every mounted volume there exist two bit maps,
   each as many bits long(rounded up to nearest word) as there are vtoces on that volume.
   The incremental and consolidated dumpers are driven off these bit maps and dump each vtoce and
   associated data object whose bit is on */

/* Coded by D Vinograd Feb 1976 
   Modified by E.N. Kittlitz Nov 1980 for new dtm/dtu calculation, clock builtin 
   Modified 03/21/81, W. Olin Sibert, for ADP SDW formats
   Modified 03/01/82, J. Bongiovanni, to compute proper size for dbm_seg
            and for new PVTE include file
*/


/****^  HISTORY COMMENTS:
  1) change(88-05-27,GWMay), approve(88-05-27,MCR7883),
     audit(88-06-14,Beattie), install(88-07-19,MR12.2-1061):
     Changed to allow setting of the dumper bit maps values with set_bit.
                                                   END HISTORY COMMENTS */


	idx = divide (1, 0, 17, 0);			/* should never be called here */

update_map_from_ast: entry (a_pvtep, a_pvtx);

	pvtep = a_pvtep;
	pvtx = a_pvtx;
	call lock$lock_ast;
	call lock_dbm;
	call get_mapp (incr, "1"b);

	do i = 0 to hbound (sst$level, 1);
	     first = "1"b;
	     first_fp = sst$level (i).ausedp;
	     if first_fp ^= "0"b then
		do fp = first_fp repeat (aste.fp)while (fp ^= first_fp | first);
		first = "0"b;
		astep = ptr (addr (sst_seg$), fp);
		if aste.pvtx = pvtx & ^aste.gtus & ^aste.nid & ^aste.per_process & ^aste.hc_sdw then do;
		     if ((aste.np ^= "0"b) | (aste.infp ^= "0"b)) then	/* implies 'in use' */
			aste.dtu = substr (bit (fixed (clock (), 52), 36), 1, 36);
		     if aste.fms then do;
			aste.fms = "0"b;
again1:			dump_it (aste.vtocx) = "1"b;
			if dump_it (aste.vtocx) ^= "1"b then do;
			     call syserr (LOG, "dbm_man: csl failure");
			     goto again1;
			end;
		     end;
		end;
	     end;
	end;

	call unlock_dbm;
	call lock$unlock_ast;
	return;

set_incr:	entry (a_pvtx, a_vtocx, a_code);

	type = incr;
	switch = "1"b;
	a_code = 0;
	goto set_common;

set:	entry (a_pvtx, a_vtocx, a_type, a_switch);

	type = a_type;
	switch = a_switch;

set_common:
	call lock_dbm;

	call get_pvte;

	call set_bit (a_vtocx, type, switch);

	call unlock_dbm;

	return;

get_next_vtocx: entry (a_pvtx, a_vtocx, a_type, a_reset, a_code);

	a_code = 0;
	reset = a_reset;
	call lock_dbm;

	call get_pvte;

	call get_mapp (a_type, "1"b);
	do idx = a_vtocx + 1 to pvte.n_vtoce - 1 while (dump_it (idx) = "0"b); end;

	if idx > pvte.n_vtoce - 1 then do;
	     a_code = error_table_$end_of_info;
	     call unlock_dbm;
	     return;
	end;

	pvte.curn_dmpr_vtocx (a_type) = idx;

	if reset then;
	else call set_bit (idx, a_type, "0"b);
	if a_type = incr then			/* set consolidated bit */
	     call set_bit (idx, cons, "1"b);

	call unlock_dbm;

	return;

init_map:	entry (a_pvtx, a_bmp, a_code);

	a_code = 0;
	call lock_dbm;

	call get_pvte;

	if pvte.dbmrp (incr) ^= "0"b then
	     call syserr (CRASH, "dbm_man: attempt to initialize already initialized map for PV on ^a_^a^[^a^;^1s^]",
		pvte.devname, convert (p99, pvte.logical_area_number), pvte.is_sv, pvte.sv_name);

	bit_map_len = divide (pvte.n_vtoce + 35, 36, 17, 0) * num_of_maps;

	on area call syserr (CRASH, "dbm_man: unable to allocate dumper bit map for PV on ^a_^a^[^a^;^1s^]",
	     pvte.devname, convert (p99, pvte.logical_area_number), pvte.is_sv, pvte.sv_name);
	allocate bit_map in (dbm.area) set (mapp);

	pvte.dbmrp (incr) = rel (mapp);
	pvte.dbmrp (cons) = bit (fixed (fixed (rel (mapp), 18) + divide (bit_map_len, 2, 18, 0), 18), 18);
	mapp -> bit_map = a_bmp -> bit_map;

	call unlock_dbm;
	return;

update_map: entry (a_pvtx, a_bmp, a_pageno, a_code);

	free = "0"b;
	goto free_common;

free_map:	entry (a_pvtx, a_bmp, a_pageno, a_code);

	free = "1"b;

free_common:
	a_code = 0;
	call lock_dbm;

	call get_pvte;

	call get_mapp (incr, (^free));
	if mapp = null () then goto UNLOCK_RETURN;

	bit_map_len = divide (pvte.n_vtoce + 35, 36, 17, 0) * num_of_maps;
	if (free & a_pageno = 0) then do;
	     call reset_curn_vtocx (incr);
	     call reset_curn_vtocx (cons);
	end;
	cnt1 = min (1024 - bit_map_offset, bit_map_len);
	if a_pageno = 0 then do;
	     cnt = cnt1;
	     from_ptr = mapp;
	     to_ptr = addrel (a_bmp, bit_map_offset);
	end;
	else do;
	     cnt = max (bit_map_len - cnt1, 0);
	     from_ptr = addrel (mapp, cnt1);
	     to_ptr = a_bmp;
	end;
	to_ptr -> copy = from_ptr -> copy;

	if (free & a_pageno = 1) then do;
	     free mapp -> bit_map in (dbm.area);
	     pvte.dbmrp (*) = "0"b;
	end;

UNLOCK_RETURN:
	call unlock_dbm;
	return;

init:	entry;					/* Set up the dbm seg */

/* Compute the size of dbm_seg from the number of disk devices configured */

	dbmp = addr (dbm_seg$);
	dbm_segno = binary (baseno (addr (dbm_seg$)));
	sltp = addr (slt$);
	sltep = addr (slt.seg (dbm_segno));

	dbm_seg_size = size (area_header) + binary (rel (addr (dbm.area)))
	     + pvt$n_entries * (alloc_blkhdrsz + divide (MAX_VTOCE_PER_PACK + 35, 36, 17) * num_of_maps);
	
/* Set up SLTE for dbm_seg so that we get an ASTE and address withdrawal when
   we call make_sdw. make_sdw was already called for dbm_seg. It did neither,
   since dbm_seg has the abs_seg attribute in the SLTE */

	slte.abs_seg = "0"b;
	slte.cur_length, slte.max_length = bit (divide (dbm_seg_size +1023, 1024, 9, 0), 9);
	
	call make_sdw$unthreaded (dbm_segno, tsdw, astep, ptp);
	if astep = null () 
	     then call syserr (CRASH, "dbm_man: Cannot get ASTE for dbm_seg");
	call pmut$swap_sdw (addr (dbm_seg$), addr (tsdw));

	unspec (local_area_info) = "0"b;
	area_infop = addr (local_area_info);
	area_info.version = area_info_version_1;
	area_info.zero_on_free = "1"b;
	area_info.size = dbm_seg_size - binary (rel (addr (dbm.area)), 18);
	area_info.areap = addr (dbm.area);
	call define_area_ (area_infop, code);
	if code ^= 0 then
	     call syserr$error_code (CRASH, code, "dbm_man: unable to initialize area");
	dbm.lock_data.event = unspec (DBM_LOCK_EVENT);
	dbm.init = "1"b;
	return;
%page;

lock_dbm:	proc;
	     dbmp = addr (dbm_seg$);
	     call lock$lock_fast (addr (dbm.lock));
	     return;
	end lock_dbm;

unlock_dbm: proc;
	     call lock$unlock_fast (addr (dbm.lock));
	     return;
	end unlock_dbm;

get_pvte:	proc;
	     code = 0;
	     pvtx = a_pvtx;
	     pvt_arrayp = addr (pvt$array);
	     pvtep = addr (pvt_array (pvtx));
	     return;
	end get_pvte;

set_bit:	proc (idx, type, value);
dcl  value bit (1) aligned;
dcl  type fixed bin;
dcl  idx fixed bin;

	     call get_mapp (type, "1"b);
again2:	     dump_it (idx) = value;
	     if dump_it (idx) ^= value then do;
		call syserr (LOG, "dbm_man: csl failure");
		goto again2;
	     end;
	     return;
	end set_bit;

reset_curn_vtocx: proc (type);
dcl  type fixed bin;
	     if pvte.curn_dmpr_vtocx (type) ^= -1 then do;
		call set_bit (fixed (pvte.curn_dmpr_vtocx (type)), type, "1"b);
		pvte.curn_dmpr_vtocx = -1;
	     end;
	     return;
	end reset_curn_vtocx;

get_mapp:	proc (type, crash_on_error);
dcl  type fixed bin;
dcl  crash_on_error bit (1) aligned;

	     mapp = ptr (dbmp, pvte.dbmrp (type));
	     if mapp = dbmp then
		if crash_on_error then
		     call syserr (CRASH, "dbm_man: bit map relp not set in pvte for PV on ^a_^a^[^a^;^1s^]",
			pvte.devname, convert (p99, pvte.logical_area_number), pvte.is_sv, pvte.sv_name);
	          else mapp = null ();
	end get_mapp;
%page;
dcl  a_pvtx fixed bin;
dcl  a_pvtep ptr;
dcl  a_vtocx fixed bin;
dcl  a_pageno fixed bin;
dcl  a_reset bit (1) aligned;
dcl  a_switch bit (1) aligned;
dcl  a_type fixed bin;
dcl  a_bmp ptr;
dcl  a_code fixed bin (35);

dcl  code fixed bin (35);
dcl  reset bit (1) aligned;
dcl  first bit (1) aligned;
dcl  fp bit (18);
dcl  first_fp bit (18);
dcl  pvtx fixed bin;
dcl  type fixed bin;
dcl  i fixed bin;
dcl  idx fixed bin;
dcl  free bit (1) aligned;
dcl  switch bit (1) aligned;
dcl  bit_map_len fixed bin;
dcl  cnt1 fixed bin;
dcl  cnt fixed bin;
dcl  from_ptr ptr;
dcl  to_ptr ptr;
dcl  dbm_seg_size fixed bin (19);
dcl  dbm_segno fixed bin (18);
dcl  tsdw fixed bin (71);
dcl  ptp ptr;
dcl  p99 picture "99";

dcl 1 local_area_info like area_info aligned;

dcl  copy (cnt) bit (36) based;
dcl  bit_map (bit_map_len) bit (36) aligned based;
dcl  mapp ptr init (null ());
dcl  dump_it (0:1) bit (1) unaligned based (mapp);

dcl  area condition;

dcl  bit_map_offset fixed bin static init (8) options (constant);
dcl  num_of_maps fixed bin static init (2) options (constant);
dcl  DBM_LOCK_EVENT char (4) static options (constant) aligned init ("dbm_");

dcl  sst_seg$ fixed bin external static;
dcl  pvt$n_entries fixed bin external static;
dcl  slt$ external static;

dcl 1 sst$level (0 : 3) aligned external static,
    2 ausedp bit (18) unaligned,
    2 no_aste bit (18) unaligned;

dcl  error_table_$end_of_info ext fixed bin (35);

dcl  define_area_ entry (ptr, fixed bin (35));
dcl  lock$lock_ast entry;
dcl  lock$unlock_ast entry;
dcl  lock$lock_fast entry (ptr);
dcl  lock$unlock_fast entry (ptr);
dcl  make_sdw$unthreaded entry (fixed bin (18), fixed bin (71), ptr, ptr);
dcl  pmut$swap_sdw entry (ptr, ptr);
dcl  syserr entry options (variable);
dcl  syserr$error_code entry options (variable);

dcl (addrel, addr, baseno, binary, bit, clock, convert, divide, fixed, hbound, min, max, null, ptr, rel, substr, size, unspec) builtin;
%page; %include area_info;
%page; %include area_structures;
%page; %include aste;
%page; %include backup_static_variables;
%page; %include dbm;
%page; %include disk_pack;
%page; %include pvte;
%page; %include slt;
%page; %include slte;
%page; %include syserr_constants;
%page; %include vtoce;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   dbm_man: csl failure

   S:	$log

   T:	$run

   M:	The CSL instruction appears to have failed on one of the processors.

   A:	$ignore

   Message:
   dbm_man: attempt to initialize already initialized map for PV on dskX_NNS

   S:	$crash

   T:	$run

   M:	$err

   A:	$recover

   Message:
   dbm_man: unable to allocate dumper bit map for PV on dskX_NNS

   S:	$crash

   T:	$run

   M:	The system was unable to allocate a dumper bit map in dbm_seg for
   the volume on dskX_NNS.  Too many volumes are online, or there is something
   wrong with the volume header.

   A:	$recover

   Message:
   dbm_man: Cannot get ASTE for dbm_seg

   S:     $crash

   T:	$init

   M:	The system was unable to create the dbm_seg and obtain an ASTE
   for this segment.

   A:     $contact_sa

   Message:
   dbm_man: unable to initialize area: ERROR_MESS

   S:	$crash

   T:	$run

   M:	$err

   A:	$recover

   Message:
   dbm_man: bit map relp not set in pvte for PV on dskX_NNS

   S:	$crash

   T:	$run

   M:	$err

   A:	$recover

   END MESSAGE DOCUMENTATION */

     end dbm_man;




		    hc_dmpr_primitives.pl1          11/11/89  1133.9rew 11/11/89  0800.0      306207



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

/* format: style4 */

hc_dmpr_primitives: proc;

/* Ring 0 backup procedures */
/* Coded by D. R. Vinograd 12/75 */
/* Modified by Mike Grady 1/9/80 to fix some bugs */
/* Modified 03/22/81, W. Olin Sibert, for ADP PTWs and SDWs */
/* Modified July, 1981, by D. R. Vinograd, to fix bugs and handle version numbers correctly */
/* Modified 2/82 BIM for new name on lock$unlock_dir */
/* Modified 3/82 by J. Bongiovanni for new PVTE, better error handling */
/* Modified 7/82 by J. Bongiovanni to read entire VTOCE, pc$dumper_get_file_map */
/* Modified 8/82 by GA Texada to fix phx12841	*/
/* Modified 9/82 by GA Texada to check for file map damage */
/* Modified 10/82 by J. Bongiovanni for synchronized segments, fm_damaged ,
   deltrailer problem */
/* Modified 8/83 by E. N. Kittlitz for search_ast$check. */
/* Modified Jan. 1985 by Greg Texada to ignore vtoce.(ncd nid) switches for directories and to set dtd for null vtoces.
*/

/****^  HISTORY COMMENTS:
  1) change(86-03-04,Fawcett), approve(86-04-11,MCR7383),
     audit(86-06-03,GWMay), install(86-07-17,MR12.0-1097):
     Support for subvolume devices real 512_word_io.
  2) change(88-05-27,GWMay), approve(88-05-27,MCR7883),
     audit(88-06-15,Beattie), install(88-07-19,MR12.2-1061):
     Added code for processing inconsistent volume dumper bit maps.
  3) change(88-10-05,GWMay), approve(88-10-05,MCR8005), audit(88-10-12,Farley),
     install(88-10-17,MR12.2-1173):
     Changed version of backup volume record from 1 to 2.
                                                   END HISTORY COMMENTS */

init_dmpr: entry (a_copy_dirsegp, a_dmpr_absegp, a_code);

	code = 0;					/* set return args to default */
	if pds$dmpr_copy_dirsegp ^= null then do;
	     a_code = error_table_$bad_arg;		/* only called once per process */
	     return;
	end;

	copy_dirsegp = a_copy_dirsegp;
	call grab_aste (copy_dirsegp, (sys_info$default_dir_max_length), code, astep);

	call quota_util$suspend_quota;

	pds$dmpr_copy_dirsegp = copy_dirsegp;
	a_dmpr_absegp = addr (backup_abs_seg$);
	pds$dmpr_pvid = "0"b;			/* clear some process variables */
	pds$dmpr_pvtx = 0;
	a_code = code;				/* return args */
	return;					/* all done */
%page;
dmpr_lock_pv: entry (a_pvid, a_type, a_infop, a_code);


	lock = "1"b;
lock_pv_common:
	pvtxh = "0"b;
	pvid = a_pvid;				/* copy input args */
	type = a_type;
	code = 0;					/* set return args to default */
	if (type ^= incr &				/* check input for arg error */
	     type ^= cons &
	     type ^= comp) then do;
	     a_code = error_table_$bad_arg;
	     return;
	end;

	call lock$lock_ast;				/* global lock on pvt */
	astl = "1"b;
	pvtx = get_pvtx (pvid, code);			/* search pvt for specified volume */
	if code ^= 0 then goto dmpr_lock_pv_ret;	/* all done so return */

	call get_pvtx$hold_pvtx (pvid, pvtx, code);
	if code ^= 0 then goto dmpr_lock_pv_ret;
	pvtxh = "1"b;


	pvtep = addr (addr (pvt$array) -> pvt_array (pvtx)); /* set ptr to pvt entry */
	if pvte.dmpr_in_use (type) & lock then do;	/* make sure volume not already in use */
	     code = error_table_$vol_in_use;
	     goto dmpr_lock_pv_ret;
	end;

	pvte.dmpr_in_use (type) = lock;		/* set volume lock */

	call lock$unlock_ast;
	astl = "0"b;

	if lock then do;
	     pds$dmpr_pvtx = pvtx;			/* set process variables */
	     pds$dmpr_pvid = pvid;
	     if type = incr then call dbm_man$update_map_from_ast (pvtep, pvtx);
	     bpvip = a_infop;
	     call set_info;
	     if code ^= 0 then do;
		pds$dmpr_pvtx = 0;
		pds$dmpr_pvid = "0"b;
		call lock$lock_ast;
		astl = "1"b;
		pvte.dmpr_in_use (type) = "0"b;
		code = error_table_$action_not_performed;
	     end;
	end;
	else do;
	     pds$dmpr_pvtx = 0;
	     pds$dmpr_pvid = "0"b;
	end;
dmpr_lock_pv_ret:
	if astl then call lock$unlock_ast;
	if pvtxh then call get_pvtx$release_pvtx (pvid, pvtx);
	a_code = code;
	return;
dmpr_unlock_pv: entry (a_pvid, a_type, a_code);

	lock = "0"b;
	goto lock_pv_common;
%page;
dmpr_build_vtoc_map: entry (a_vbmp, a_window, a_code);

	code = 0;
	astl = "0"b;
	pvtxh = "0"b;
	vbmp = a_vbmp;
	window = a_window;
	astep = null ();

	if pds$dmpr_pvid = "0"b then do;
	     a_code = error_table_$bad_arg;
	     return;
	end;

	call lock$lock_ast;
	astl = "1"b;

	call get_pvtx$hold_pvtx (pds$dmpr_pvid, pds$dmpr_pvtx, code);
	if code ^= 0 then goto build_vtoc_map_ret;
	pvtxh = "1"b;

	pvtep = addr (addr (pvt$array) -> pvt_array (pds$dmpr_pvtx));
	astep = get_aste (max_pages_per_segment);	/* get the biggest */
	if astep = null then do;
	     code = error_table_$action_not_performed;
	     goto build_vtoc_map_ret;
	end;

	ptp = addrel (astep, sst$astsize);

	aste.gtpd, aste.dnzp = "1"b;			/* Dont let segment go awry */
	aste.pvtx = fixed (pds$dmpr_pvtx, 8);
	aste.nqsw = "1"b;

	on page_fault_error begin;
	     code = error_table_$vtoc_io_err;
	     goto build_vtoc_map_done;
	end;

	do i = 0 to max_pages_per_segment - 1;
	     call ptw_util_$make_disk (addrel (ptp, i), ((max_pages_per_segment * window) + i + VTOC_ORIGIN));
	end;

	tsdw = get_ptrs_$given_astep (astep);
	call pmut$swap_sdw (addr (backup_abs_seg$), addr (tsdw));

	call thread$out (astep, sst$level (3).ausedp);	/* thread it out so no one gets confused */

	call lock$unlock_ast;
	astl = "0"b;

	n_vtoce_per_page = vtoc_per_rec (pvte.device_type); /* 5 or 2 */
	dev_vtoc_words = sect_per_vtoc (pvte.device_type) * words_per_sect (pvte.device_type); /* 192 or 512 */


	do i = 0 to max_pages_per_segment - 1;
	     pagep = ptr (addr (backup_abs_seg$), i * 1024);
	     do j = 0 to n_vtoce_per_page - 1;
		vtocep = addrel (pagep, j * dev_vtoc_words);
		if vtoce.uid ^= "0"b then do;		/* not null */
		     vtocx = j + i * n_vtoce_per_page + window * n_vtoce_per_page * max_pages_per_segment;
		     if vtocx > pvte.n_vtoce then goto build_vtoc_map_done;
		     vtoc_bit_map (vtocx) = "1"b;
		end;
	     end;
	end;

build_vtoc_map_done:
	revert page_fault_error;
	if ^astl then call lock$lock_ast;
	astl = "1"b;

	tsdw = 0;
	call pmut$swap_sdw (addr (backup_abs_seg$), addr (tsdw));
	if astep ^= null () then do;
	     call pc$cleanup (astep);
	     call put_aste (astep);
	end;

build_vtoc_map_ret:
	if astl then call lock$unlock_ast;
	astl = "0"b;
	if pvtxh then call get_pvtx$release_pvtx (pds$dmpr_pvid, pds$dmpr_pvtx);
	pvtxh = "0"b;
	a_code = code;
	return;
%page;

get_dmpr_data_object: entry (a_inputp, a_recordp, a_code);


	inputp = a_inputp;				/* pick up input args */
	recordp = a_recordp;

	astl = "0"b;
	dirl = "0"b;
	pvtxh = "0"b;
	pardirl = "0"b;
	code = 0;
	select_loop_cnt = 0;
	object_uid,
	     parent_uid = "0"b;
	valid_update = "0"b;
	astep, vtocep,
	     pvtep = null;

	type = dmpr_input.type;			/* copy args */
	prev_vtocx = dmpr_input.prev_vtocx;
	pvid = dmpr_input.pvid;
	start_time = dmpr_input.start_time;
	mod_after_time = dmpr_input.mod_after_time;
	volid = dmpr_input.volid;
	reset = dmpr_input.reset;
	no_update = dmpr_input.no_update;
	no_object = dmpr_input.no_object;
	retry = dmpr_input.retry;
	request = dmpr_input.request;
	request_vtocx = dmpr_input.request_vtocx;
						/* cross check all the input args */
	if (dmpr_input.version ^= dmpr_input_version_1 | backup_volume_record.version ^= backup_volume_record_version_2)
	     | (type ^= incr & type ^= cons & type ^= comp)
	     | (start_time = 0)
	     | (volid = "0"b)
	     | (pvid ^= pds$dmpr_pvid) then do;
	     a_code = error_table_$bad_arg;
	     return;
	end;

	call lock$lock_ast;				/* set dseg and pvt global lock */
	astl = "1"b;
	call get_ptrs_$given_segno (fixed (baseno (addr (backup_abs_seg$)), 18), astep); /* get astep */
	if astep ^= null () then call force_deactivate;	/* make it go away */

	call get_pvte;				/* find pvte */
	if code ^= 0 then do;
	     if astl then call lock$unlock_ast;
	     astl = "0"b;
	     a_code = code;
	     return;
	end;

	call get_pvtx$hold_pvtx (pds$dmpr_pvid, pds$dmpr_pvtx, code);
	if code ^= 0 then goto get_data_object_ret;
	pvtxh = "1"b;

	if astl then call lock$unlock_ast;
	astl = "0"b;


	if dmpr_input.Sfirst_pass_for_pv then do;
	     call check_for_inconsistent_dbm ();
	     dmpr_input.Sfirst_pass_for_pv = "0"b;
	end;

/* setup ptrs to and clear local copies */

	unspec (local_aste) = "0"b;
	tastep = addr (local_aste);
	unspec (local_dir) = "0"b;
	dp = addr (local_dir);
	vtocep = addr (local_vtoce);			/* set ptr to local copy */

select_vtoce:

	select_loop_cnt = select_loop_cnt + 1;
						/* if locks are set - unlock them */
	if astl then call lock$unlock_ast;
	astl = "0"b;
	if pardirl then call lock$dir_unlock_given_uid (parent_uid);
	pardirl = "0"b;
	if dirl then call lock$dir_unlock_given_uid (object_uid);
	dirl = "0"b;

/* find the next object to dump. if retry enable just make sure we wont go off the end */

	if type = comp | pvte.inconsistent_dbm then do;
	     if (request & select_loop_cnt > 1) then do;
		code = error_table_$action_not_performed;
		goto get_data_object_ret;
	     end;
	     if (prev_vtocx + 1 = pvte.n_vtoce)
		| (request & request_vtocx = pvte.n_vtoce) then do;
		pvte.curn_dmpr_vtocx (type) = -1;
		goto update_label;
	     end;
	     else do;
		if request then pvte.curn_dmpr_vtocx (type) = request_vtocx;
		else if ^retry then pvte.curn_dmpr_vtocx (type) = pvte.curn_dmpr_vtocx (type) + 1;
	     end;
	end;
	else if ^retry then do;
	     call dbm_man$get_next_vtocx (pds$dmpr_pvtx, prev_vtocx, type, reset, code);
	     if code ^= 0 then do;
		if code = error_table_$end_of_info then do;
update_label:	     call set_time;			/* dump all done so set label */
		     if code ^= 0 then call syserr$error_code (ANNOUNCE, code,
			     "hc_dmpr_primitives: Unable to set label time. PVID = ^w", pds$dmpr_pvid);
		     code = error_table_$end_of_info;
		end;
		goto get_data_object_ret;
	     end;
	end;

	begin;					/* Make a null VTOCE */
dcl  fm_nullifier char (256 * 2) aligned based;

	     unspec (local_vtoce) = ""b;
	     addr (local_vtoce.fm) -> fm_nullifier = high9 (256 * 2); /* Use a single MLR instruction */
	end;
						/* an mlr instruction */

/* read VTOCE - check for null vtoce and other degenerate cases */

	call vtoc_man$get_vtoce (pds$dmpr_pvid, pds$dmpr_pvtx, fixed (pvte.curn_dmpr_vtocx (type), 17), "111"b,
	     vtocep, code);
	if code ^= 0 then goto get_data_object_ret;
	if type = comp | pvte.inconsistent_dbm then
	     if vtoce.uid = "0"b			/* free vtoce */
		| vtoce.per_process
		| vtoce.deciduous then do;
		prev_vtocx = prev_vtocx + 1;
		goto select_vtoce;
	     end;
	dtd = substr (bit (fixed (clock (), 52), 52), 1, 36);
	if vtoce.deciduous | vtoce.per_process |
	     ((^vtoce.dirsw) & ((type ^= comp & ^pvte.inconsistent_dbm) & vtoce.nid)) then do;
	     vtoce.uid = "0"b;			/* treat as null vtoce */
	     goto get_data_object_ret;		/* dump as place holder */

	end;

	if vtoce.uid = "0"b then goto get_data_object_ret;

	object_uid = vtoce.uid;

	if vtoce.dirsw then do;			/* if object is a directory */
	     dir.uid = object_uid;
	     call lock$dir_lock_read (dp, (0));
	     dirl = "1"b;
	end;

	if vtoce.uid ^= (36)"1"b then do;		/* the root does not have a parent */
	     do parx = 0 to 15 while (vtoce.uid_path (parx) ^= "0"b);
	     end;

	     parx = parx - 1;
	     parent_uid,
		dir.uid = vtoce.uid_path (parx);

	     if parent_uid = "0"b then do;		/* VTOC BAD give up */
		vtoce.uid = "0"b;			/* treat it as a null vtoce */
		call syserr (LOG, "hc_dmpr_primitives: bad uid pathname detected at pvid ^w vtocx ^o",
		     pds$dmpr_pvid, fixed (pvte.curn_dmpr_vtocx (type), 17));
		goto get_data_object_ret;
	     end;

	     call lock$dir_lock_write (dp, (0));	/* Write to prevent activation of inferior */
	     pardirl = "1"b;
	end;


	call lock$lock_ast;
	astl = "1"b;

/* see if object already active - if so we don't have to activate it for ourselves */

	astep = search_ast$check ((vtoce.uid), pds$dmpr_pvid,
	     fixed (pvte.curn_dmpr_vtocx (type), 17), code); /* is our ship really in? */
	if code ^= 0 then goto get_data_object_ret;	/* double-uid */
	if astep ^= null then do;			/* its already active */
	     if aste.dius then do;
		code = error_table_$dmpr_in_use;
		goto get_data_object_ret;
	     end;

/* reread VTOCE under parent lock so tape copy and disk copy (if its updated) are correct */

	     call vtoc_man$get_vtoce (pds$dmpr_pvid, pds$dmpr_pvtx, fixed (pvte.curn_dmpr_vtocx (type), 17), "111"b,
		vtocep, code);
	     if code ^= 0 then goto get_data_object_ret;

	     if ((^vtoce.dirsw) & ((type = comp | pvte.inconsistent_dbm) & vtoce.ncd)) then do;
		prev_vtocx = prev_vtocx + 1;
		goto select_vtoce;
	     end;

/* update file map and part one header */

	     call pc$dumper_get_file_map (astep, tastep, addr (vtoce.fm), (0), null (), null ());

	     vtoce.uid = tastep -> aste.uid;
	     vtoce.msl = tastep -> aste.msl;
	     vtoce.csl = tastep -> aste.csl;
	     vtoce.records = tastep -> aste.records;
	     vtoce.dtu = tastep -> aste.dtu;
	     vtoce.dtm = tastep -> aste.dtm;
	     vtoce.nqsw = tastep -> aste.nqsw;
	     vtoce.deciduous = tastep -> aste.hc_sdw;
	     vtoce.synchronized = tastep -> aste.synchronized;
	     vtoce.per_process = tastep -> aste.per_process;
	     vtoce.dnzp = tastep -> aste.dnzp;
	     vtoce.gtpd = tastep -> aste.gtpd;
	     vtoce.nid = tastep -> aste.nid;
	     vtoce.dirsw = tastep -> aste.dirsw;

	     if vtoce.per_process | vtoce.deciduous |
		((^vtoce.dirsw) & (type ^= comp & vtoce.nid)) then do;
		if type = comp | pvte.inconsistent_dbm then do;
		     prev_vtocx = prev_vtocx + 1;
		     goto select_vtoce;
		end;
		else do;
		     vtoce.uid = "0"b;
		     goto get_data_object_ret;
		end;
	     end;

	     if tastep -> aste.dirsw then do;
		curtime = substr (bit (clock (), 52), 1, 36);
		vtoce.master_dir = tastep -> aste.master_dir;
		do i = 0, 1;
		     vtoce.used (i) = tastep -> aste.used (i);
		     if tastep -> aste.tqsw (i) then do;
			dt = fixed (curtime, 36) - fixed (vtoce.trp_time (i), 36);
			vtoce.trp (i) = vtoce.trp (i) + fixed (tastep -> aste.used (i) * dt * .65536e-1 + .5e0, 71);
			vtoce.trp_time (i) = curtime;
		     end;
		end;
	     end;

	     if ^no_update then do;			/* update vtoce desired */
		tvolid = vtoce.volid (type);		/* save value */
		vtoce.volid (type) = volid;		/* set volume id */
		valid_update = "1"b;
		tdtd = vtoce.dtd;			/* save  value */
		vtoce.dtd = dtd;			/* set dtd */
		call vtoc_man$put_vtoce (pds$dmpr_pvid, pds$dmpr_pvtx, fixed (pvte.curn_dmpr_vtocx (type), 17),
		     "001"b, vtocep, code);
		if code ^= 0 then goto get_data_object_ret;
	     end;

	end;

	else do;					/* not active now */

	     if astl then call lock$unlock_ast;
	     astl = "0"b;

/* Since not active the file maps are correct */


/* if not the same as the first read then something is out of synch. try again */

	     if (vtoce.uid ^= object_uid) |
		(vtoce.uid ^= (36)"1"b & vtoce.uid_path (parx) ^= parent_uid) then goto select_vtoce;

	     if ((^vtoce.dirsw) & ((type = comp | pvte.inconsistent_dbm) & vtoce.ncd)) then do;
		prev_vtocx = prev_vtocx + 1;
		goto select_vtoce;
	     end;

	     if vtoce.per_process | vtoce.deciduous |
		((^vtoce.dirsw) & (type ^= comp & vtoce.nid)) then do;
		if type = comp | pvte.inconsistent_dbm then do;
		     prev_vtocx = prev_vtocx + 1;
		     goto select_vtoce;
		end;
		else do;
		     vtoce.uid = "0"b;
		     goto get_data_object_ret;
		end;
	     end;


	     if ^no_update then do;			/* update vtoce desired */
		tvolid = vtoce.volid (type);		/* save value */
		vtoce.volid (type) = volid;		/* set volume id */
		valid_update = "1"b;
		tdtd = vtoce.dtd;			/* save  value */
		vtoce.dtd = dtd;			/* set dtd */
		call vtoc_man$put_vtoce (pds$dmpr_pvid, pds$dmpr_pvtx, fixed (pvte.curn_dmpr_vtocx (type), 17),
		     "001"b, vtocep, code);
		if code ^= 0 then goto get_data_object_ret;
	     end;
						/* lock ast and make object active */

	     astep = activate$backup_activate (vtocep, fixed (pvte.curn_dmpr_vtocx (type), 17), pds$dmpr_pvtx, code);
	     if code ^= 0 then goto get_data_object_ret;
	     astl = "1"b;
	end;

	if mod_after_time ^= 0 & type = comp then
	     if fixed (bit (aste.dtm, 52), 52) < mod_after_time then do; /* do not dump */
		call force_deactivate;
		prev_vtocx = prev_vtocx + 1;
		goto select_vtoce;
	     end;

	if pvte.inconsistent_dbm then do;
	     skip = "0"b;
	     last_modified = fixed (bit (aste.dtm, 52), 52);
	     call dbm_man$set (pds$dmpr_pvtx,
		fixed (pvte.curn_dmpr_vtocx (type), 17), incr, "0"b);

	     if type = incr then do;
		if last_modified < dmpr_input.last_incr_dump_time then
		     skip = "1"b;
		if last_modified < dmpr_input.last_cons_dump_time then
		     call dbm_man$set (pds$dmpr_pvtx,
			fixed (pvte.curn_dmpr_vtocx (type), 17), cons, "0"b);
		else
		     call dbm_man$set (pds$dmpr_pvtx,
			fixed (pvte.curn_dmpr_vtocx (type), 17), cons, "1"b);
	     end;
	     else do;
		call dbm_man$set (pds$dmpr_pvtx,
		     fixed (pvte.curn_dmpr_vtocx (type), 17), cons, "0"b);
		if type = cons then do;
		     if last_modified < dmpr_input.last_cons_dump_time then
			skip = "1"b;
		end;
	     end;

	     if skip then do;
		call force_deactivate;
		prev_vtocx = prev_vtocx + 1;
		goto select_vtoce;
	     end;
	end;

	call make_trailer;				/* put dumper on trailer */

	tsdw = get_ptrs_$given_astep (astep);		/* get the sdw */
	call sdw_util_$dissect (addr (tsdw), addr (sdwi));/* Dissect it, for modification */

	if vtoce.dirsw then
	     read_ring = 0;
	else read_ring = level$get ();		/* readable in the outer ring */
	sdwi.r2 = bit (binary (read_ring, 3), 3);
	sdwi.r3 = bit (binary (read_ring, 3), 3);
	sdwi.write = "0"b;				/* Read access only */
	call sdw_util_$construct (addr (tsdw), addr (sdwi)); /* And put it back together */

	call pmut$swap_sdw (addr (backup_abs_seg$), addr (tsdw)); /* put constructed sdw in dseg */
	if ^no_object then do;			/* want object also */

	     if ^vtoce.dirsw then do;			/* pre-page segs */
		if fixed (vtoce.records, 9) ^= 0
		     & fixed (vtoce.records, 9) = fixed (vtoce.csl, 9) then do;
		     last_page_index = fixed (vtoce.csl, 9) - 1;
		     if ^substr (vtoce.fm (last_page_index), 1, 1) then call pc_wired$read (astep, last_page_index, 1);
		end;
		do i = 0 to fixed (vtoce.csl, 9) - 1 while (i < 16); /* pre-page for efficiency */
		     if ^substr (vtoce.fm (i), 1, 1) then call pc_wired$read (astep, i, 1);
		end;
	     end;
	     else do;				/* treat dirs diferantly */
		aste.ehs = "1"b;			/* make sure aste doesnt go away */
		if astl then call lock$unlock_ast;
		astl = "0"b;

		if pardirl then call lock$dir_unlock_given_uid (parent_uid);
		pardirl = "0"b;

		csl = fixed (vtoce.csl, 9);
		if csl = fixed (vtoce.records, 9) then do;
		     nwords = csl * 1024;
		     pds$dmpr_copy_dirsegp -> copy = addr (backup_abs_seg$) -> copy;
		end;
		else do;
		     do i = 0 to csl - 1;
			if ^substr (vtoce.fm (i), 1, 1) then
			     ptr (pds$dmpr_copy_dirsegp, i * 1024) -> page =
				ptr (addr (backup_abs_seg$), i * 1024) -> page;
		     end;
		end;
		aste.ehs = "0"b;			/* now it can */
		if dirl then call lock$dir_unlock_given_uid (object_uid);
		dirl = "0"b;
	     end;
	end;
get_data_object_ret:
	if astl then call lock$unlock_ast;		/* turn global lock off */
	if pardirl then call lock$dir_unlock_given_uid (parent_uid);
	if dirl then call lock$dir_unlock_given_uid (object_uid);
	if pvtxh then call get_pvtx$release_pvtx (pds$dmpr_pvid, pds$dmpr_pvtx);
	if ^no_update & valid_update then do;
	     vtoce.dtd = tdtd;			/* reset pre-update values */
	     vtoce.volid (type) = tvolid;
	end;

	backup_volume_record.vtocx = pvte.curn_dmpr_vtocx (type); /* return args */
	backup_volume_record.time_dumped = dtd;
	backup_volume_record.pvid = pds$dmpr_pvid;
	local_vtoce.fm_checksum_valid = "0"b;
	backup_volume_record.vtoce = local_vtoce;
	a_code = code;
	return;
%page;
release_dmpr_aste: entry (a_type, a_code);

	code = 0;
	type = a_type;				/* copy args */
	call lock$lock_ast;				/* lock global lock */
	call get_ptrs_$given_segno (fixed (baseno (addr (backup_abs_seg$)), 18), astep); /* get astep */
	if astep = null then do;			/* the harder way */
	     call get_pvte;
	     vtocep = addr (local_vtoce);
	     call vtoc_man$get_vtoce (pds$dmpr_pvid, pds$dmpr_pvtx, fixed (pvte.curn_dmpr_vtocx (type), 17),
		"111"b, vtocep, code);
	     if code ^= 0 then goto release_dmpr_aste_ret;
	     astep = search_ast$check ((vtoce.uid), pds$dmpr_pvid,
		fixed (pvte.curn_dmpr_vtocx (type), 17), code); /* find aste */
	     if code ^= 0 then goto release_dmpr_aste_ret;
	end;

	if astep ^= null () then call force_deactivate;
release_dmpr_aste_ret:
	call lock$unlock_ast;
	a_code = code;
	return;
%page;
revert_dmpr: entry (a_code);

	code = 0;					/* set default return value */
	if pds$dmpr_copy_dirsegp = null then do;	/* can't revert what was not set */
	     a_code = error_table_$bad_arg;
	     return;
	end;
	call lock$lock_ast;
	call get_ptrs_$given_segno (fixed (baseno (pds$dmpr_copy_dirsegp), 18), astep);
	if astep ^= null () then
	     aste.ehs = "0"b;
	call get_ptrs_$given_segno (fixed (baseno (addr (backup_abs_seg$)), 18), astep); /* get astep */
	if astep ^= null () then call force_deactivate;	/* make it go away */
	call lock$unlock_ast;
	call quota_util$restore_quota;
	pds$dmpr_pvid = "0"b;			/* reset  the world */
	pds$dmpr_pvtx = 0;
	pds$dmpr_copy_dirsegp = null;
	a_code = code;				/* all done */
	return;
%page;
check_for_inconsistent_dbm: proc;

	if ^pvte.inconsistent_dbm then
	     return;

	labelp = addr (local_label);
	call lock$wait (addr (lock_word), lock_id, code);
	if code ^= 0 then return;
	call read_disk (pds$dmpr_pvtx, LABEL_ADDR, labelp, code);
	if code = 0 then do;
	     dmpr_input.last_incr_dump_time = label.time_last_dmp (1);
	     dmpr_input.last_cons_dump_time = label.time_last_dmp (2);
	end;

	call lock$unlock (addr (lock_word), lock_id);
	return;
     end check_for_inconsistent_dbm;


make_trailer: proc;

	if rel (sst$tfreep) = "0"b			/* set up trailer */
	then call syserr (CRASH, "hc_dmpr_primitives: trailer storage area exhausted");
	strep = sst$tfreep;				/* Get pointer to first free trailer */
	sst$tfreep = ptr (strep, strep -> str.fp);	/* reset free ptr */
	strep -> str.segno = bit (fixed (baseno (addr (backup_abs_seg$)), 18)); /* Fill in the new trailer */
	strep -> str.dstep = pds$dstep;		/* ditto */
	strep -> str.fp, strep -> str.bp = "0"b;	/* ditto */
	call thread$lin (strep, astep -> aste.strp);	/* Thread the new trailer in */
	astep -> aste.dius = "1"b;			/* Now it's ours */

     end make_trailer;
%page;
force_deactivate: proc;


	if aste.strp ^= ""b then			/* if any trailers exist, process */
	     if aste.dius then
		call setfaults$deltrailer (astep, fixed (baseno (addr (backup_abs_seg$)), 18), fixed (pds$dstep, 18)); /* release trailer */

	if aste.par_astep = "0"b & aste.uid ^= (36)"1"b then do; /* dumper is only user */
	     call pc$cleanup (astep);			/* get rid of all the pages */
	     call search_ast$hash_out (astep);		/* clean out hash table */
	     call put_aste (astep);			/* and the aste */
	     sst$deact_count = sst$deact_count + 1;	/* Meter */
	end;

	else aste.dius = "0"b;			/* user is using but we are done */

	tsdw = 0;					/* reset the special sdw */
	call pmut$swap_sdw (addr (backup_abs_seg$), addr (tsdw)); /* swap in zero sdw */
	return;
     end force_deactivate;
%page;
get_pvte: proc;

	code = 0;
	pvtep = addr (addr (pvt$array) -> pvt_array (pds$dmpr_pvtx)); /* get ptr to pvte */
	if pvte.pvid ^= pds$dmpr_pvid then do;		/* has it been demounted */
	     pvtx = get_pvtx (pds$dmpr_pvid, code);	/* maybe it moved */
	     if code ^= 0 then return;
	     pds$dmpr_pvtx = pvtx;			/* reset */
	end;
	return;
     end get_pvte;
%page;
set_time: proc;

	labelp = addr (local_label);
	call lock$wait (addr (lock_word), lock_id, code);
	if code ^= 0 then return;
	call read_disk (pds$dmpr_pvtx, LABEL_ADDR, labelp, code); /* read label */
	if code = 0 then do;
	     label.time_last_dmp (type) = start_time;	/* update label */
	     pvte.inconsistent_dbm, label.inconsistent_dbm = "0"b;
	     call write_disk (pds$dmpr_pvtx, LABEL_ADDR, labelp, code); /* write label */
	     pvte.dmpr_in_use (type) = "0"b;		/* all done with this volume */
	     pvte.curn_dmpr_vtocx (type) = -1;		/* ditto */
	end;
	call lock$unlock (addr (lock_word), lock_id);
	return;
     end set_time;
%page;
set_info: proc;

	labelp = addr (local_label);
	call read_disk (pds$dmpr_pvtx, LABEL_ADDR, labelp, code);
	if code ^= 0 then return;
	backup_pvol_info.label = label;

	backup_pvol_info.n_vtoce = pvte.n_vtoce;
	backup_pvol_info.n_free_vtoce = pvte.n_free_vtoce;
	backup_pvol_info.n_rec = pvte.totrec;
	backup_pvol_info.baseadd = pvte.volmap_stock_ptr -> record_stock.volmap_page (1).baseadd + 64 * 32;
	backup_pvol_info.n_free_rec = pvte.nleft;

     end set_info;
%page;

dcl  a_copy_dirsegp ptr;				/* ptr to segment used to copy directories */
dcl  a_infop ptr;					/* ptr to storage for info about physical volume */
dcl  a_dmpr_absegp ptr;				/* ptr to perprocess abs seg */
dcl  a_code fixed bin (35);				/* error code */
dcl  a_pvid bit (36) aligned;				/* physical volume id */
dcl  a_type fixed bin;				/* type of dump */
dcl  a_window fixed bin;				/* count of windows  used to scan vtoc */
dcl  a_vbmp ptr;					/* ptr to vtoc bit map */
dcl  a_inputp ptr;					/* ptr to input structure */
dcl  a_recordp ptr;					/* ptr to output structure */

dcl  copy_dirsegp ptr;				/* local copy of parameter */
dcl  select_loop_cnt fixed bin;			/* count of times in select_loop */
dcl  read_ring fixed bin;				/* ring that dumper's sdw will allow reading in */
dcl  dev_vtoc_words fixed bin;			/* words per vtoc in a page */
dcl  dtd bit (36) aligned;
dcl  curtime bit (36) aligned;			/* the current time */
dcl  dt fixed bin (35);				/* delta time */
dcl  pvtxh bit (1) aligned;				/* indicates if pvte held */
dcl  astl bit (1) aligned;				/* indicates if ast locked */
dcl  dirl bit (1) aligned;				/* indicates if dir is locked */
dcl  pardirl bit (1) aligned;				/* indicates if parent dir is locked */
dcl  parx fixed bin;				/* index of parent uid in pathname array */
dcl  tastep ptr;					/* ptr to local copy of aste */
dcl  parent_uid bit (36) aligned;			/* as stated */
dcl  object_uid bit (36) aligned;			/* ditto */
dcl  lock bit (1) aligned;				/* entry indicator and lock value */
dcl  skip bit (1) aligned;
dcl  strep ptr;					/* ptr to trailer entry */
dcl  code fixed bin (35);				/* error code */
dcl  last_page_index fixed bin;
dcl  vbmp ptr;					/* local copy of parameter */
dcl  window fixed bin;				/* local copy of parameter */
dcl  j fixed bin;					/* loop control variable */
dcl  pagep ptr;					/* ptr to page of vtoc scanning seg */
dcl  valid_update bit (1) aligned;			/* on if update variables are set */
dcl  pvid bit (36) aligned;				/* physical volume id */
dcl  prev_vtocx fixed bin;				/* value of vtocx of seg just dumped */
dcl  request_vtocx fixed bin;				/* vtocx to be dumped if request mode enabled  */
dcl  type fixed bin;				/* dump type */
dcl  pvtx fixed bin;				/* pvt index */
dcl  vtocx fixed bin;				/* vtoc index */
dcl  retry bit (1) aligned;				/* local copy of parameter */
dcl  request bit (1) aligned;				/* local copy of parameter */
dcl  csl fixed bin;					/* cur seg length */
dcl  volid bit (36) aligned;				/* id of volume onto which object dumped will be written */
dcl  start_time fixed bin (71);			/* starting time of this dump cycle */
dcl  mod_after_time fixed bin (71);			/* time to check dtm against */
dcl  last_modified fixed bin (71);			/* last time the vtoce was modified */
dcl  reset bit (1) aligned;				/* on if forced reseting desired */
dcl  n_vtoce_per_page fixed bin;			/* vtoce entries per page */
dcl  no_object bit (1) aligned;			/* on if no data object is to be dumped */
dcl  no_update bit (1) aligned;			/* on if no update of vtoce desired (dtd and volid) */
dcl  i fixed bin;					/* loop control variable */
dcl  nwords fixed bin;				/* number of words of directory to copy */
dcl  tsdw fixed bin (71);				/* tempory sdw */
dcl  tdtd bit (36) aligned;				/* temp copy of dtd */
dcl  tvolid bit (36) aligned;				/* temp copy of volid */

dcl  ptp pointer;
dcl  1 sdwi aligned like sdw_info automatic;		/* For modifying our temporary SDW */

dcl  page (1024) bit (36) aligned based;
dcl  copy (nwords) fixed bin based;			/* array used to copy directory into dumper segment */
dcl  vtoc_bit_map (0:36719) bit (1) unaligned based (vbmp);

dcl  1 local_vtoce like vtoce aligned;			/* local copy of vtoce */
dcl  1 local_aste like aste aligned;
dcl  1 local_dir like dir aligned;
dcl  1 local_label like label aligned;			/* local copy of disk label */

dcl  error_table_$bad_arg fixed bin (35) external;
dcl  error_table_$action_not_performed fixed bin (35) external;
dcl  error_table_$dmpr_in_use ext fixed bin (35);
dcl  error_table_$end_of_info ext fixed bin (35);
dcl  error_table_$vol_in_use fixed bin (35) external;
dcl  error_table_$vtoc_io_err fixed bin (35) external;
dcl  backup_abs_seg$ ext;
dcl  pds$dmpr_pvid bit (36) aligned external;
dcl  pds$dstep ext bit (18);
dcl  pds$dmpr_pvtx fixed bin external;
dcl  pds$dmpr_copy_dirsegp external ptr;
dcl  sst$astsize fixed bin external;
dcl  sst$deact_count fixed bin external;
dcl  1 sst$level (0:3) aligned external,
       2 ausedp bit (18) unaligned,
       2 no_aste bit (18) unaligned;
dcl  sst$tfreep ptr external;
dcl  sys_info$default_dir_max_length fixed bin (19) external;

dcl  max_pages_per_segment fixed bin static init (255) options (constant); /* max pages per segment */
dcl  lock_word bit (36) int static init ("0"b);		/* interlock for label update */
dcl  lock_id char (4) aligned int static init ("dmpr") options (constant); /* id to wait on */

dcl  quota_util$suspend_quota entry;
dcl  quota_util$restore_quota entry;
dcl  pmut$swap_sdw entry (ptr, ptr);
dcl  ptw_util_$make_disk entry (pointer, fixed bin (20));
dcl  sdw_util_$dissect entry (pointer, pointer);
dcl  sdw_util_$construct entry (pointer, pointer);
dcl  dbm_man$update_map_from_ast entry (ptr, fixed bin);
dcl  dbm_man$get_next_vtocx entry (fixed bin, fixed bin, fixed bin, bit (1) aligned, fixed bin (35));
dcl  dbm_man$set entry (fixed bin, fixed bin, fixed bin, bit (1) aligned);

dcl  (addr, addrel, baseno, binary, bit, clock, fixed, high9, null, ptr, rel, substr, unspec) builtin;
dcl  get_aste entry (fixed bin) returns (ptr);
dcl  get_ptrs_$given_segno entry (fixed bin, ptr);
dcl  get_ptrs_$given_astep entry (ptr) returns (fixed bin (71));
dcl  activate$backup_activate entry (ptr, fixed bin, fixed bin, fixed bin (35)) returns (ptr);
dcl  get_pvtx entry (bit (36) aligned, fixed bin (35)) returns (fixed bin (17));
dcl  get_pvtx$hold_pvtx entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  get_pvtx$release_pvtx entry (bit (36) aligned, fixed bin);
dcl  vtoc_man$get_vtoce entry (bit (36) aligned, fixed bin, fixed bin, bit (3), ptr, fixed bin (35));
dcl  vtoc_man$put_vtoce entry (bit (36) aligned, fixed bin, fixed bin, bit (3), ptr, fixed bin (35));
dcl  lock$wait entry (ptr, char (4) aligned, fixed bin (35));
dcl  lock$unlock entry (ptr, char (4) aligned);
dcl  lock$lock_ast entry;
dcl  lock$unlock_ast entry;
dcl  read_disk entry (fixed bin, fixed bin, ptr, fixed bin (35));
dcl  write_disk entry (fixed bin, fixed bin, ptr, fixed bin (35));
dcl  lock$dir_lock_read entry (ptr, fixed bin (35));
dcl  lock$dir_lock_write entry (ptr, fixed bin (35));
dcl  lock$dir_unlock_given_uid entry (bit (36) aligned);
dcl  pc$dumper_get_file_map entry (ptr, ptr, ptr, fixed bin, ptr, ptr);
dcl  pc$cleanup entry (ptr);
dcl  search_ast$hash_out entry (ptr);
dcl  put_aste entry (ptr);
dcl  search_ast$check entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (35)) returns (ptr);
dcl  thread$lin entry (ptr, bit (18));
dcl  pc_wired$read entry (ptr, fixed bin, fixed bin);
dcl  syserr entry options (variable);
dcl  syserr$error_code entry options (variable);
dcl  setfaults$deltrailer entry (ptr, fixed bin, fixed bin (18));
dcl  level$get entry returns (fixed bin);
dcl  thread$out entry (ptr, bit (18));
dcl  grab_aste entry (ptr, fixed bin, fixed bin (35), ptr);

dcl  page_fault_error condition;

/* format: off */

%page; %include aste;
%page; %include backup_pvol_info;
%page; %include backup_static_variables;
%page; %include backup_volume_header;
%page; %include backup_volume_record;
%page; %include dir_header;
%page; %include disk_pack;
%page; %include dmpr_input;
%page; %include fs_vol_label;
%page; %include fs_dev_types_sector;
%page; %include pvte;
%page; %include sdw_info;
%page; %include stock_seg;
%page; %include str;
%page; %include syserr_constants;
%page; %include vtoce;
%page;
/* format: on */

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   hc_dmpr_primitives: Unable to set label time. PVID = wwwwwwwwwwww

   S:	$info

   T:	$run

   M:	A disk error prevented the updating of the time-last-dumped field in the volume label.
   The physical volume identifier is wwwwwwwwwwww.

   A:	$inform


   Message:
   hc_dmpr_primitives: bad uid pathname detected at pvid WWWW vtocx XXXX

   S:	$log

   T:	$run

   M:	Part 3 of the indicated VTOCE is bad.
   The dumper will treat the vtoce as a null vtoce and continue.

   A:	$ignore


   Message:
   hc_dmpr_primitives: trailer storage area exhausted

   S:	$crash

   T:	$run

   M:	$err

   A:	$recover


   END MESSAGE DOCUMENTATION */

     end hc_dmpr_primitives;




		    retv_copy.pl1                   11/11/89  1133.9r w 11/11/89  0800.0      188271



/****^  ***********************************************************
        *                                                         *
        * 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: style1,ind5,^inddcls,ifthenstmt,dclind2,declareind2,ifthendo,ifthen*/

retv_copy: proc (a_dirname, a_ename, a_auth, a_userid, a_level, a_vtocep, a_objectp, a_attributes, a_code);

/* This routine provides a controlled method of copying data from a temp orary buffer
   in an outer ring either into an existant or non-existant object, regardless of whether that object is
   a segment or a directory */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Status:								*/
/* 0) Created by Dave Vinograd in the distant past.				*/
/* 1) Modified: 8/18/82 by GA Texada to fix phx13506				*/
/* 2) Modified: 8/08/83 by E. N. Kittlitz for setfaults$if_active pvid, vtocx args	*/
/* 3) Modified: 7/6/84 by Keith Loepere to use the new dc_find.			*/
/* 4) Modified: 10/15/84 by Keith Loepere to explicitly activate dir on makeknown_,	*/
/*		also for auditing info.					*/
/* 5) Modified: 12/13/84 by Keith Loepere to reload dir quota also.			*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* Parameters */

dcl a_attributes	     bit (36);
dcl a_auth	     bit (72) aligned;
dcl a_code	     fixed bin (35);
dcl a_dirname	     char (*) aligned;
dcl a_ename	     char (*) aligned;
dcl a_level	     fixed bin;
dcl a_objectp	     ptr;
dcl a_userid	     char (*) aligned;
dcl a_vtocep	     ptr;

/* Variables */

dcl attributes	     bit (36);
dcl code		     fixed bin (35);
dcl del_code	     fixed bin (35);
dcl del_ename	     char (32);
dcl del_pname	     char (168);
dcl dir_pvid	     bit (36) aligned;
dcl dir_uid	     bit (36) aligned;
dcl dir_vtocx	     fixed bin;
dcl dirl		     bit (1) aligned;
dcl dirname	     char (168);
dcl dirsw		     bit (1);
dcl ec		     fixed bin (35);
dcl ename		     char (32);
dcl found		     bit (1);
dcl hold		     bit (1);
dcl i		     fixed bin;
dcl ignore	     fixed bin (35);
dcl inf_received	     (0:1) fixed bin (18);
dcl 1 input_vtoce	     like vtoce aligned;
dcl 1 local_audit_user_info like audit_user_info aligned;
dcl 1 local_dir_header   like dir aligned;
dcl 1 local_makeknown_info like makeknown_info aligned;
dcl 1 local_quota_cell   like quota_cell aligned;
dcl 1 local_vtoce	     like vtoce aligned;
dcl mismatch	     bit (1);
dcl ncd		     fixed bin;
dcl new_ep	     ptr;
dcl new_vtoce	     bit (1);
dcl nid		     fixed bin;
dcl objectp	     ptr;
dcl old_ep	     ptr;
dcl old_uid	     bit (36) aligned;
dcl par_ep	     ptr;
dcl par_pvid	     bit (36) aligned;
dcl par_quota	     (0:1) fixed bin (18);
dcl par_received	     (0:1) fixed bin (18);
dcl par_uid	     bit (36) aligned;
dcl par_vtocx	     fixed bin;
dcl pardirl	     bit (1) aligned;
dcl pvid		     bit (36) aligned;
dcl pvtx		     fixed bin;
dcl quota_type	     fixed bin;
dcl segno		     fixed bin;
dcl segptr	     ptr;
dcl skip_list	     (1500) bit (36) aligned;
dcl skip_list_cnt	     fixed bin init (0);
dcl skip_list_idx	     fixed bin;
dcl target_dirl	     bit (1);
dcl target_dp	     ptr;
dcl 1 temp_quota_cell    like quota_cell aligned;
dcl uid		     bit (36) aligned;
dcl vtocx		     fixed bin;

/* Based */

dcl dates_set	     defined attributes position (1) bit (1);
dcl dump_info_set	     defined attributes position (3) bit (1);
dcl dump_switches_set    defined attributes position (2) bit (1);
dcl page		     (512) bit (72) aligned based;
dcl pc_switches_set	     defined attributes position (4) bit (1);
dcl quota_set	     defined attributes position (5) bit (1);

/* External */

dcl error_table_$action_not_performed ext fixed bin (35);
dcl error_table_$argerr  ext fixed bin (35);
dcl error_table_$fulldir ext fixed bin (35);
dcl error_table_$invalidsegno ext fixed bin (35);
dcl error_table_$segknown ext fixed bin (35);
dcl error_table_$vtoce_connection_fail ext fixed bin (35);
dcl sys_info$max_seg_size ext fixed bin;

/* Entries */

dcl create_vtoce	     entry (ptr, bit (36) aligned, fixed bin, fixed bin (35));
dcl del_dir_tree$retv    entry (char (*), char (*), fixed bin (35));
dcl delentry$retv	     entry (char (*), char (*), fixed bin (35));
dcl get_kstep	     entry (fixed bin, ptr, fixed bin (35));
dcl get_pvtx	     entry (bit (36) aligned, fixed bin (35)) returns (fixed bin);
dcl get_pvtx$release_pvtx entry (bit (36) aligned, fixed bin);
dcl grab_aste	     entry (ptr, fixed bin, fixed bin (35), ptr);
dcl lock$dir_lock_read   entry (ptr, fixed bin (35));
dcl lock$dir_unlock	     entry (ptr);
dcl makeknown_	     entry (ptr, fixed bin, fixed bin, fixed bin (35));
dcl makeunknown_	     entry (fixed bin, bit (36) aligned, bit (1) aligned, fixed bin (35));
dcl mountedp	     entry (bit (36) aligned) returns (fixed bin (35));
dcl setfaults$disconnect entry (fixed bin);
dcl setfaults$if_active  entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (1));
dcl sum$getbranch	     entry (ptr, bit (36), ptr, fixed bin (35));
dcl syserr$error_code    entry options (variable);
dcl truncate_vtoce$hold  entry (ptr, fixed bin, fixed bin (35));
dcl vtoc_attributes$get_quota entry (bit (36) aligned, bit (36) aligned, fixed bin, ptr, fixed bin, fixed bin (35));
dcl vtoc_attributes$set_dates entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36), bit (36), fixed bin (35));
dcl vtoc_attributes$set_dump_info entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36), (3) bit (36),
		     fixed bin (35));
dcl vtoc_attributes$set_dump_switches entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin, fixed bin,
		     fixed bin (35));
dcl vtoc_attributes$set_max_lth entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (9), bit (1),
		     fixed bin (35));
dcl vtoc_attributes$set_pc_switches entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36), bit (36),
		     fixed bin (35));
dcl vtoc_attributes$set_quota entry (bit (36) aligned, bit (36) aligned, fixed bin, ptr, fixed bin, fixed bin (35));
dcl vtoc_man$get_vtoce   entry (bit (36) aligned, fixed bin, fixed bin, bit (3), ptr, fixed bin (35));

/* Misc */

dcl bad_dir_	     condition;
dcl cleanup	     condition;

dcl (addr, baseptr, fixed, null, ptr, rel, rtrim, substr, unspec) builtin;
%page;
	audit_user_info_ptr = addr (local_audit_user_info);
	unspec (audit_user_info) = "0"b;

/* copy input args */
	dirname = a_dirname;
	ename = a_ename;
	objectp = a_objectp;
	audit_user_info.version = audit_user_info_version_1;
	audit_user_info.user_id = a_userid;
	audit_user_info.ring = a_level;
	audit_user_info.process_id = "0"b;		/* may not be logged on */
	audit_user_info.authorization_range(2),		/* use auth as max_auth until we can get real max_auth */
	     audit_user_info.authorization = a_auth;
	audit_user_info.audit_flags = (36)"1"b;		/* audit anything until we can get the real audit flags */
	input_vtoce = a_vtocep -> vtoce;
						/* initialize control variables */
	target_dirl, dirl, pardirl, hold, new_vtoce = "0"b;
	attributes = "0"b;
	code = 0;
	segno = -1;
	astep, dp, kstep = null;
						/* be prepared for vtoce connection failures */
	on cleanup begin;
		code = error_table_$action_not_performed;
		if kstep ^= null then call revert_kst_access;
		goto fin;
	     end;

/* If the object to be copied is a directory then lock it, even though it may not exist. */

	if input_vtoce.dirsw then do;
		unspec (local_dir_header) = "0"b;
		target_dp = addr (local_dir_header);
		local_dir_header.uid = input_vtoce.uid;
		call lock$dir_lock_read (target_dp, code);
		if code ^= 0 then goto fin;
		target_dirl = "1"b;
	     end;

/* set aste.ehs on outer ring buffer so we will not segfault while dir is locked */

	call grab_aste (objectp, sys_info$max_seg_size, code, astep);
	if code ^= 0 then goto fin;
						/* locate entry */
	call dc_find$obj_volume_retrieve (dirname, ename, audit_user_info_ptr, ep, code);
	if code ^= 0 then goto fin;
	dp = ptr (ep, 0);
	dirl = "1"b;
						/* check if object and entry match */
	if entry.uid ^= input_vtoce.uid then do;
		code = error_table_$vtoce_connection_fail;
		goto fin;
	     end;
						/* links don't have objects */
	if ^entry.bs then do;
		code = error_table_$action_not_performed;
		goto fin;
	     end;
	if ^entry.dirsw then do;			/* ensure that the logical volume is mounted	*/
		code = mountedp (dir.sons_lvid);	/* before we truncate the target vtoce.		*/
		if code ^= 0 then goto fin;		/* Thank you Steve Harris			*/
	     end;

	if entry.dirsw then do;			/* Get some quota info and save it. */
		call sum$getbranch (dp, "0"b, par_ep, code);
		if code ^= 0 then goto fin;
		pardirl = "1"b;

		par_uid = par_ep -> entry.uid;
		par_vtocx = par_ep -> entry.vtocx;
		par_pvid = par_ep -> entry.pvid;
		qcp = addr (local_quota_cell);
		do quota_type = 0 to 1;
		     call vtoc_attributes$get_quota (par_uid, par_pvid, par_vtocx, qcp, quota_type, code);
		     if code ^= 0 then goto fin;
		     par_received (quota_type) = quota_cell.received;
		     par_quota (quota_type) = quota_cell.quota;
		end;
						/* all done with parent so unlock */
		call lock$dir_unlock (ptr (par_ep, 0));
		pardirl = "0"b;
	     end;

/* Check to see if entry has vtoce. If not create a new one and set a flag */

	pvid = entry.pvid;
	uid = entry.uid;
	pvtx = get_pvtx (pvid, code);
	if code ^= 0 then goto fin;
	vtocx = entry.vtocx;
	vtocep = addr (local_vtoce);
	call vtoc_man$get_vtoce (pvid, pvtx, vtocx, "100"b, vtocep, code);
	if code ^= 0 then goto fin;
	if entry.uid ^= vtoce.uid then do;		/* no vtoce */
		call create_vtoce (ep, pvid, vtocx, code);
		if code ^= 0 then goto fin;
		entry.vtocx = vtocx;
		entry.pvid = pvid;
		pvtx = get_pvtx (pvid, code);
		if code ^= 0 then goto fin;
		new_vtoce = "1"b;
	     end;
						/* Make the entry known */
	makeknown_infop = addr (local_makeknown_info);
	makeknown_info.uid = uid;
	makeknown_info.entryp = ep;
	makeknown_info.activate, makeknown_info.dirsw = entry.dirsw;
	makeknown_info.rsw = "0"b;
	makeknown_info.allow_write = "1"b;
	makeknown_info.priv_init = "1"b;
	makeknown_info.audit = "0"b;
	call makeknown_ (makeknown_infop, segno, (0), code);
	if code ^= 0 then do;
		if code = error_table_$segknown then code = 0;
		else goto fin;
	     end;
						/* Fudge access in KST entry */
	call force_kst_access;
	if code ^= 0 then goto fin;
	segptr = baseptr (segno);

/* If the old object exists and it's a dir then there may entries in it that are in the newer copy.
   If so then they should be preserved, not lost. Simiarly if the old directory has entries that the new
   copy does not then they should be deleted.  */

	mismatch = "1"b;
	if ^new_vtoce & entry.dirsw then
	     do while (mismatch);
		call reset_new_dir;
		if code ^= 0 then goto fin;
	     end;
						/* Truncate the object but hold the pvol its on */
	call truncate_vtoce$hold (ep, 0, code);
	if code ^= 0 then goto fin;
	hold = "1"b;
						/* Set the max length prior to the copy */
	call vtoc_attributes$set_max_lth (uid, pvid, vtocx, fixed (input_vtoce.msl, 9), "1"b, code);
	if code ^= 0 then goto fin;
						/* Copy each non null page from the buffer */
	do i = 0 to fixed (input_vtoce.csl, 9) - 1;
	     if substr (input_vtoce.fm (i), 1, 1) = "0"b then
		ptr (segptr, i * 1024) -> page = ptr (objectp, i * 1024) -> page;
	end;
						/* Reset dir header */
	if entry.dirsw then do;
		segptr -> dir.pvid = pvid;
		segptr -> dir.vtocx = vtocx;
	     end;
						/* cleanup */
	call revert_kst_access;
	call makeunknown_ (segno, "0"b, ("0"b), ignore);
						/* reset dates from input vtoce */
	call vtoc_attributes$set_dates (uid, pvid, vtocx, input_vtoce.dtu, input_vtoce.dtm, ec);
	dates_set = (ec ^= 0);
						/* reset dump control switches from input vtoce */
	if input_vtoce.nid = "1"b then nid = 1; else nid = -1;
	if input_vtoce.ncd = "1"b then ncd = 1; else ncd = -1;
	call vtoc_attributes$set_dump_switches (uid, pvid, vtocx, nid, ncd, ec);
	dump_switches_set = (ec ^= 0);
						/* and dump info */
	call vtoc_attributes$set_dump_info (uid, pvid, vtocx, input_vtoce.dtd, input_vtoce.volid, ec);
	dump_info_set = (ec ^= 0);
						/* and pc control switches */
	call vtoc_attributes$set_pc_switches (uid, pvid, vtocx, input_vtoce.dnzp || input_vtoce.gtpd, "11"b, ec);
	pc_switches_set = (ec ^= 0);

/* Now we check if the directory being copied will
   create  new quota. If its a new vtoce we first reset the quota info from the input vtoce, otherwise just take
   the quota and recieved. Next we check to see that the total recieved at this level is less then or equal to
   the ammount the parent ditributed. If this fails we set the quota to 1. We must set it to 1 (and
   manufacture some quota) or delete the directory for if we set it to 0 we would destroy the quota tree.
*/

	if entry.dirsw then do;
		qcp = addr (local_quota_cell);
		call compute_inf_received;
		if ec ^= 0 then goto q_done;
		do quota_type = 0 to 1;
		     call vtoc_attributes$get_quota (uid, pvid, vtocx, qcp, quota_type, ec);
		     if ec ^= 0 then goto q_done;
		     if new_vtoce then do;
			     quota_cell.quota = input_vtoce.quota (quota_type);
			     quota_cell.used = input_vtoce.used (quota_type);
			     quota_cell.received = input_vtoce.received (quota_type);
			     quota_cell.tup = input_vtoce.trp_time (quota_type);
			     quota_cell.trp = input_vtoce.trp (quota_type);
			     quota_cell.pad = 0;
			end;
		     else do;
			     quota_cell.quota = input_vtoce.quota (quota_type);
			     quota_cell.received = input_vtoce.received (quota_type);
			end;
		     if inf_received (quota_type) + par_quota (quota_type) + input_vtoce.received (quota_type) <= par_received (quota_type) then
			call vtoc_attributes$set_quota (uid, pvid, vtocx, qcp, quota_type, ec);
		     else do;
			     quota_set = "1"b;
			     quota_cell.quota = 1;
			     call vtoc_attributes$set_quota (uid, pvid, vtocx, qcp, quota_type, ec);
			     goto q_next;
			end;
q_done:		     quota_set = quota_set | (ec ^= 0);
q_next:		end;
	     end;

fin:
						/* cleanup, unlock, deference, and return args */
	if hold then call get_pvtx$release_pvtx (pvid, pvtx);
	if target_dirl then call lock$dir_unlock (target_dp);
	if dp ^= null then call dc_find$finished (dp, dirl);
	if pardirl then call lock$dir_unlock (ptr (par_ep, 0));
	if astep ^= null then aste.ehs = "0"b;
	a_attributes = attributes;
ret:	a_code = code;
	return;
%page;
force_kst_access: proc;

/* This proc locates the KST entry for segno, and forces the access so we can use it. It also set faults all other users.
   users. Since we already have the directory locked, the access can not be change nor can any
   user recoonect to the segment */

	call get_kstep (segno, kstep, code);
	if code ^= 0 then return;
	kste.dtbm = entry.dtem;
	kste.access = "101"b;
	call setfaults$if_active (uid, pvid, vtocx, "0"b);
	return;

     end force_kst_access;

revert_kst_access: proc;

/* This proc resets the KST entry and disconnects it from us */

	kste.dtbm = (36)"1"b;
	call setfaults$disconnect (segno);
	return;

     end revert_kst_access;

compute_inf_received: proc;

/* This proc sums the recieved quota for all directory entries inferior to some directory */

dcl nentries	     fixed bin;
dcl ok		     fixed bin (35);
dcl seen		     fixed bin;

	inf_received (*) = 0;
	nentries = dir.lcount + dir.seg_count + dir.dir_count;
	seen = 0;
	do ep = ptr (dp, dir.entryfrp) repeat (ptr (dp, entry.efrp)) while (rel (ep) ^= "0"b);
	     seen = seen + 1;
	     if seen > nentries then signal bad_dir_;
	     if entry.bs then
		if entry.owner ^= dir.uid then signal bad_dir_;
		else ;
	     else if link.owner ^= dir.uid
		     | link.type ^= LINK_TYPE then signal bad_dir_;
	     if entry.dirsw then do;
		     if entry.type ^= DIR_TYPE then signal bad_dir_;
		     dir_vtocx = entry.vtocx;
		     dir_pvid = entry.pvid;
		     dir_uid = entry.uid;
		     qcp = addr (temp_quota_cell);
		     do quota_type = 0 to 1;
			call vtoc_attributes$get_quota (dir_uid, dir_pvid, dir_vtocx, qcp, quota_type, ok);
			if ok = 0 then inf_received (quota_type) = inf_received (quota_type) + quota_cell.received;
		     end;
		end;
	end;
	return;

     end compute_inf_received;

reset_new_dir: proc;

/* This proc compares the old and new copies of a directory. For each uid match  it resets
   the vtoce pointer. For each entry in the old not in the new it deletes it. This deletion operation is made without
   access control checks. If deletion won't work the fact is logged with the reason. Of course when the copy
   is made the subtrees will be automaticaly deleted, in the sense that they won't be found */

dcl nentries1	     fixed bin;
dcl nentries2	     fixed bin;
dcl seen1		     fixed bin;
dcl seen2		     fixed bin;

	mismatch = "0"b;
reset_loop: seen2 = 0;
	nentries2 = segptr -> dir.lcount + segptr -> dir.dir_count + segptr -> dir.seg_count;
	do old_ep = ptr (segptr, segptr -> dir.entryfrp) repeat (ptr (segptr, old_ep -> entry.efrp))
	     while (rel (old_ep) ^= "0"b);
	     seen2 = seen2 + 1;
	     if seen2 > nentries2 then signal bad_dir_;
	     seen1 = 0;
	     nentries1 = objectp -> dir.lcount + objectp -> dir.dir_count + objectp -> dir.seg_count;
	     do new_ep = ptr (objectp, objectp -> dir.entryfrp) repeat (ptr (objectp, new_ep -> entry.efrp))
		while (rel (new_ep) ^= "0"b & new_ep -> entry.uid ^= old_ep -> entry.uid);
		seen1 = seen1 + 1;
		if seen1 > nentries1 then do;
			code = error_table_$argerr;
			return;
		     end;
	     end;
	     if rel (new_ep) ^= "0"b then do;		/* entry in old and in new */
		     new_ep -> entry.pvid = old_ep -> entry.pvid;
		     new_ep -> entry.vtocx = old_ep -> entry.vtocx;
		end;
	     else if ^on_skip_list () then do;		/* entry in old but not in new - delete it */
		     mismatch = "1"b;
		     del_ename = ptr (old_ep, old_ep -> entry.name_frp) -> names.name;
		     if dirname = ">" then del_pname = ">" || ename;
		     else del_pname = rtrim (dirname) || ">" || ename;
		     old_uid = old_ep -> entry.uid;
		     dirsw = old_ep -> entry.dirsw;
		     call lock$dir_unlock (segptr);	/* for delentry/del_dir_tree to work */
		     target_dirl = "0"b;
		     call dc_find$finished (dp, "1"b);
		     dp = null;
		     dirl = "0"b;
		     if dirsw then do;
subtree:			     call del_dir_tree$retv (del_pname, del_ename, del_code);
			     if del_code ^= 0 then goto delerr;
			end;
		     call delentry$retv (del_pname, del_ename, del_code);
		     if del_code = error_table_$fulldir then goto subtree;
		     if del_code ^= 0 then do;
delerr:			     call syserr$error_code (4, del_code, "retv_copy: deleting ^a>^a without recovering resources",
				del_pname, del_ename);
			     call add_to_skip_list;
			end;
		     call lock$dir_lock_read (segptr, code);
		     if code ^= 0 then return;
		     target_dirl = "1"b;
		     call dc_find$obj_volume_retrieve (dirname, ename, audit_user_info_ptr, ep, code);
		     if code ^= 0 then return;
		     dirl = "1"b;
		     if ep -> entry.uid ^= uid then do;	/* where did our dir go? */
			code = error_table_$invalidsegno;
			return;
		     end;
		     dp = ptr (ep, 0);
		     goto reset_loop;
		end;
	end;
	return;

     end reset_new_dir;

on_skip_list: proc returns (bit (1));
	found = "0"b;
	do skip_list_idx = 1 to skip_list_cnt while (skip_list (skip_list_idx) ^= old_uid);
	end;
	if skip_list_idx <= skip_list_cnt then found = "1"b;
	return (found);

     end on_skip_list;

add_to_skip_list: proc;
	skip_list_cnt = skip_list_cnt + 1;
	skip_list (skip_list_cnt) = old_uid;
	return;

     end add_to_skip_list;
%page; %include access_audit_user_info;
%page; %include aste;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include dir_link;
%page; %include dir_name;
%page; %include fs_types;
%page; %include kst;
%page; %include makeknown_info;
%page; %include quota_cell;
%page; %include sdw;
%page; %include vtoce;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   retv_copy: deleting PATH without recovering resources ERROR_MESSAGE

   S: $log

   T: Volume retrieval

   M: While retrieving a segment,
   the retriever attempted to delete an old copy
   of a segment before using a newer one.
   The deletion attempt failed.
   Space may be wasted on the volume
   until a sweep_pv -gc is done.

   A: Note for volume administrator.

   END MESSAGE DOCUMENTATION */

     end retv_copy;




		    retv_util.pl1                   11/11/89  1133.9r w 11/11/89  0800.9      127629



/****^  ***********************************************************
        *                                                         *
        * 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: style2 */
retv_util:
     proc;

/* This routine provides some utility functions for the volume retriever.  They consist of a
   check entry to determine if an object exists, a status entry to provide information about an
   object, a name list entry to return the primary names of all enties in a directory,  an interface to the
   system's hash routine to facilitate searching of a directory image recovered from a dump volume,
   an entry to set the bit count of an object recovered by the retriever,
   an entry to delete a branch recovered by the retriever,
   and an add names entry  and add acl entry which provide access control bypass for the retriever.
*/


/* coded by Vinograd 9/76 */
/* Modified 07/77 by THVV for bad_dir_ check */
/* Added entry get_entry May 1978 by DRV */
/* Added entry to set bit count March 1981 by DRV */
/* Added entry to delete retrieved entry April 1981 by DRV */
/* Use of SystemFreeSeg removed BIM 4/82. */
/* Changed to use the new dc_find July 1984 by KPL */
/* Changed to provide auditing info, November 1984 by KPL */

/* Parameters */

	dcl     a_access_name	 char (*);
	dcl     a_aclc		 fixed bin;
	dcl     a_aclp		 ptr;
	dcl     a_areap		 ptr;
	dcl     a_auth		 bit (72) aligned;
	dcl     a_code		 fixed bin (35);
	dcl     a_dirname		 char (*);
	dcl     a_dp		 ptr;
	dcl     a_dtd		 bit (36) aligned;
	dcl     a_dtm		 bit (36);
	dcl     a_ename		 char (*);
	dcl     a_ep		 ptr;
	dcl     a_level		 fixed bin;
	dcl     a_mode		 bit (36) aligned;
	dcl     a_new_bc		 fixed bin (24);
	dcl     a_newname		 char (*);
	dcl     a_nlc		 fixed bin;
	dcl     a_nlp		 ptr;
	dcl     a_np		 ptr;
	dcl     a_old_bc		 fixed bin (24);
	dcl     a_pmode		 bit (36) aligned;
	dcl     a_pvid		 bit (36) aligned;
	dcl     a_type		 fixed bin;
	dcl     a_uid		 bit (36) aligned;
	dcl     a_volid		 (3) bit (36) aligned;

/* Variables */

	dcl     DIRECTORY		 fixed bin int static init (2) options (constant);
	dcl     LINK		 fixed bin int static init (3) options (constant);
	dcl     SEGMENT		 fixed bin int static init (1) options (constant);
	dcl     check_entry		 fixed bin static init (1) options (constant);
	dcl     delete_entry	 fixed bin static init (5) options (constant);
	dcl     get_entry		 fixed bin static init (3) options (constant);
	dcl     set_bc_entry	 fixed bin static init (4) options (constant);
	dcl     status_entry	 fixed bin static init (2) options (constant);

	dcl     access_name		 char (32);
	dcl     acl_start_ptr	 ptr;
	dcl     aclc		 fixed bin;
	dcl     aclp		 ptr;
	dcl     add_sw		 bit (1);
	dcl     auth		 bit (72);
	dcl     bmode		 bit (36) aligned;
	dcl     code		 fixed bin (35);
	dcl     dirl		 bit (1) aligned;
	dcl     dirname		 char (168);
	dcl     dtd		 bit (36) aligned;
	dcl     dtm		 bit (36);
	dcl     ename		 char (32);
	dcl     entry_sw		 fixed bin;
	dcl     exmode		 bit (36) aligned;
	dcl     i			 fixed bin;
	dcl     idx		 fixed bin;
	dcl     ignore		 fixed bin (35);
	dcl     level		 fixed bin;
	dcl     1 local_entry	 like entry;
	dcl     1 local_vtoce	 like vtoce aligned;
	dcl     mode		 bit (36) aligned;
	dcl     new_bc		 fixed bin (24);
	dcl     newname		 char (32);
	dcl     nlc		 fixed bin;
	dcl     nlp		 ptr;
	dcl     old_bc		 fixed bin (24);
	dcl     par_dirl		 bit (1) aligned;
	dcl     par_ep		 ptr;
	dcl     pmode		 bit (36) aligned;
	dcl     prior_dir_acl_count	 fixed bin;
	dcl     pvid		 bit (36) aligned;
	dcl     pvtx		 fixed bin;
	dcl     rp		 bit (18) aligned;
	dcl     saved_change_pclock	 fixed bin (35);
	dcl     type		 fixed bin;
	dcl     uid		 bit (36) aligned;
	dcl     volid		 (3) bit (36) aligned;

/* Based */

	dcl     1 acl_list		 (aclc) aligned like input_acl based;
	dcl     1 based_entry	 like entry based (a_ep);
	dcl     1 input_acl		 based aligned,
		2 person		 char (32),
		2 project		 char (32),
		2 tag		 char (1),
		2 mode		 bit (36),
		2 exmode		 bit (36);
	dcl     name_list		 (nlc) char (32) based aligned;
	dcl     user_area		 area based (a_areap);

/* External */

	dcl     error_table_$vtoce_connection_fail
				 ext fixed bin (35);

/* Entries */

	dcl     access_mode$user_effmode
				 entry (ptr, char (32), bit (72), fixed bin, bit (36) aligned, bit (36) aligned,
				 fixed bin (35));
	dcl     acl_$add_entry	 entry (fixed bin, bit (36) aligned, ptr, ptr, bit (1), fixed bin (35));
	dcl     acl_$del_acl	 entry (ptr, fixed bin (35));
	dcl     chname$retv		 entry (ptr, char (*), char (*), fixed bin (35));
	dcl     delentry$salv_delete_branch
				 entry (ptr, fixed bin (35));
	dcl     get_pvtx		 entry (bit (36), fixed bin (35)) returns (fixed bin);
	dcl     getuid		 entry returns (bit (36));
	dcl     hash$search		 entry (ptr, ptr, ptr, fixed bin (35));
	dcl     lock$dir_lock_read	 entry (ptr, fixed bin (35));
	dcl     lock$dir_unlock	 entry (ptr);
	dcl     sum$dirmod		 entry (pointer);
	dcl     sum$getbranch	 entry (ptr, fixed bin, ptr, fixed bin (35));
	dcl     vtoc_man$get_vtoce	 entry (bit (36), fixed bin, fixed bin, bit (3), ptr, fixed bin (35));

/* Misc */

	dcl     bad_dir_		 condition;
	dcl     seg_fault_error	 condition;

	dcl     addr		 builtin;
	dcl     fixed		 builtin;
	dcl     null		 builtin;
	dcl     ptr		 builtin;
	dcl     unspec		 builtin;
%page;
delete:
     entry (a_dirname, a_ename, a_code);
	entry_sw = delete_entry;
	goto common;

set_bc:
     entry (a_dirname, a_ename, a_new_bc, a_old_bc, a_code);
	entry_sw = set_bc_entry;
	new_bc = a_new_bc;
	goto common;

get:
     entry (a_dirname, a_ename, a_ep, a_code);
	entry_sw = get_entry;
	goto common;

check:
     entry (a_dirname, a_ename, a_type, a_dtm, a_code);

/* set control arg and default return value */

	entry_sw = check_entry;
	dtm = "0"b;
	goto common;

status:
     entry (a_dirname, a_ename, a_auth, a_access_name, a_level, a_type, a_mode, a_pmode, a_uid, a_pvid, a_volid, a_dtd,
	a_code);


/* set control arg, copy args */
	entry_sw = status_entry;
	access_name = a_access_name;
	level = a_level;
	auth = a_auth;

/* set default return values */
	uid = "0"b;
	pvid = "0"b;
	volid (*) = "0"b;
	dtd = "0"b;
	bmode = "0"b;
	pmode = "0"b;

common:						/* copy args */
	dirname = a_dirname;
	ename = a_ename;

/* set return valuse and control args */
	code = 0;
	type = 0;
	dp = null;
	dirl = "0"b;
	par_dirl = "0"b;

/* in the retriever's environment nothing can be trusted so be prepared */

	on seg_fault_error
	     begin;
		code = error_table_$vtoce_connection_fail;
		goto status_ret;
	     end;


/* locate entry desired */

	if entry_sw = delete_entry
	then call dc_find$obj_delete_priv (dirname, ename, DC_FIND_NO_CHASE, ep, code);
	else if entry_sw = set_bc_entry
	then call dc_find$obj_status_write_priv (dirname, ename, DC_FIND_NO_CHASE, FS_OBJ_BC_MOD, ep, code);
	else call dc_find$obj_status_read_priv (dirname, ename, DC_FIND_NO_CHASE, ep, code);
	if code ^= 0
	then goto status_ret;
	dp = ptr (ep, 0);
	dirl = "1"b;
	if entry_sw = delete_entry
	then do;
		call delentry$salv_delete_branch (ep, code);
		goto status_ret;
	     end;
	if entry_sw = get_entry
	then do;
		unspec (local_entry) = unspec (entry);
		goto status_ret;
	     end;
	if entry_sw = set_bc_entry
	then do;
		old_bc = entry.bc;
		entry.bc = new_bc;
		goto status_ret;
	     end;

/* determine type */
	if ^entry.bs
	then type = LINK;
	else if entry.dirsw
	then type = DIRECTORY;
	else type = SEGMENT;			/* if status entry determine user access */
	if entry_sw = status_entry
	then do;
		uid = entry.uid;
		if type ^= LINK
		then do;
			pvid = entry.pvid;
			call access_mode$user_effmode (ep, access_name, auth, level, mode, exmode, code);
			if code ^= 0
			then goto status_ret;
			if entry.dirsw
			then bmode = exmode;
			else bmode = mode;
		     end;
		call sum$getbranch (dp, 0, par_ep, code);
		if code ^= 0
		then goto status_ret;
		par_dirl = "1"b;

		call access_mode$user_effmode (par_ep, access_name, auth, level, mode, exmode, code);
		if code ^= 0
		then goto status_ret;
		pmode = exmode;
	     end;					/* if branch then check if object it describes exists */

	if entry.bs
	then do;
		unspec (local_vtoce) = "0"b;
		vtocep = addr (local_vtoce);
		pvtx = get_pvtx (entry.pvid, code);
		if code ^= 0
		then goto status_ret;
		call vtoc_man$get_vtoce (entry.pvid, pvtx, fixed (entry.vtocx, 17), "101"b, vtocep, code);
		if code ^= 0
		then goto status_ret;
		if vtoce.uid ^= entry.uid | vtoce.damaged
		then do;
			code = error_table_$vtoce_connection_fail;
			goto status_ret;
		     end;
		if entry_sw = status_entry
		then do;
			volid (*) = vtoce.volid (*);
			dtd = vtoce.dtd;
		     end;
		else dtm = vtoce.dtm;
	     end;

/* clean up any locks and return values found */
status_ret:
	if dp ^= null
	then call dc_find$finished (dp, dirl);
	if par_dirl
	then call lock$dir_unlock (ptr (par_ep, 0));
	if entry_sw = status_entry
	then do;
		a_mode = bmode;
		a_pmode = pmode;
		a_uid = uid;
		a_pvid = pvid;
		a_volid (*) = volid (*);
		a_dtd = dtd;
		a_type = type;
	     end;
	else if entry_sw = set_bc_entry
	then do;
		a_old_bc = old_bc;
	     end;
	else if entry_sw = check_entry
	then do;
		a_dtm = dtm;
		a_type = type;
	     end;
	else if entry_sw = get_entry
	then do;
		local_entry.uid = getuid ();
		unspec (based_entry) = unspec (local_entry);
	     end;
	a_code = code;
	return;
%page;
name_list:
     entry (a_dirname, a_areap, a_nlp, a_nlc, a_code);

/* copy arg and set control args */
	dirname = a_dirname;
	code = 0;
	dirl = "0"b;
	idx = 0;
	dp = null;

/* find and lock dir */

RETRY:	call dc_find$dir_read_priv (dirname, dp, code);
	if code ^= 0
	then goto name_list_ret;
	dirl = "1"b;

	nlc = dir.seg_count + dir.dir_count + dir.lcount; /* number of primary names */
	saved_change_pclock = dir.change_pclock;

	call lock$dir_unlock (dp);
	dirl = "0"b;

/* Unlock dir for allocate */

	allocate name_list in (user_area) set (nlp);

/* Relock */

	call lock$dir_lock_read (dp, code);
	if code ^= 0
	then goto name_list_ret;
	dirl = "1"b;

	if dir.change_pclock ^= saved_change_pclock
	then do;
		call lock$dir_unlock (dp);
		dirl = "0"b;
		free nlp -> name_list;
		go to RETRY;
	     end;

/* Now we have someplace to put the data, but it is user storage */
/* If we fault, though, the worst we do is salvage the dir. */
/* This entry is only called by trusted processes. */

	i = 0;
	do rp = dir.entryfrp repeat (entry.efrp) while (rp ^= "0"b);
	     i = i + 1;
	     if i > nlc
	     then signal bad_dir_;
	     ep = ptr (dp, rp);
	     if entry.bs
	     then if entry.owner ^= dir.uid | entry.type ^= SEG_TYPE & entry.type ^= DIR_TYPE
		then signal bad_dir_;
		else ;
	     else if link.owner ^= dir.uid | link.type ^= LINK_TYPE
	     then signal bad_dir_;
	     idx = idx + 1;
	     nlp -> name_list (idx) = ptr (ep, entry.name_frp) -> names.name;
	end;					/* unlock dir */
	call lock$dir_unlock (dp);
	dirl = "0"b;

/* Return pointer and count */

	a_nlc = nlc;
	a_nlp = nlp;

name_list_ret:					/* unlock, dereference as required */
	if dp ^= null
	then call dc_find$finished (dp, dirl);
	a_code = code;
	return;

/* hash_index_ is now available in bound_sss_active_, and this should */
/* be deleted ! */

hash_search:
     entry (a_dp, a_np, a_ep, a_code);

	call hash$search (a_dp, a_np, a_ep, a_code);
	return;

addname:
     entry (a_dirname, a_ename, a_newname, a_code);

/* copy input args and set control vars */
	dirl = "0"b;
	dirname = a_dirname;
	ename = a_ename;
	newname = a_newname;
	dp = null;

/* locate entry */

	call dc_find$obj_status_write_priv (dirname, ename, DC_FIND_NO_CHASE, FS_OBJ_RENAME, ep, code);
	if code ^= 0
	then goto addname_ret;
	dirl = "1"b;
	dp = ptr (ep, 0);				/* add name to entry bypassing access checks */
	call chname$retv (ep, "", newname, code);

addname_ret:					/* clean up */
	if dp ^= null
	then call dc_find$finished (dp, dirl);
	a_code = code;
	return;

/* lookout. This entry takes dir control acl's, not asd_ style */
/* user acl structures. !!!! */

add_acl:
     entry (a_dirname, a_ename, a_aclp, a_aclc, a_code);	/* copy input args and set control vars */
	dirname = a_dirname;
	ename = a_ename;
	aclc = a_aclc;
	aclp = a_aclp;
	dirl = "0"b;
	dp = null;

/* We do not copy the input data. First, this is called by trusted */
/* system code. Second, the worst that we can do is crawl out. */
/* boundsfaults do not hold write locks. */

/* locate entry */

	call dc_find$obj_access_write_priv (dirname, ename, DC_FIND_NO_CHASE, FS_OBJ_ACL_MOD, ep, code);
	if code ^= 0
	then goto add_acl_ret;
	dirl = "1"b;
	dp = ptr (ep, 0);

/* Loop over each acl term to be added. If unable to add delete all terms added so far.
   Reset acl counts for directory and entry. */

	prior_dir_acl_count = dir.acle_total;
	acl_start_ptr = addr (entry.acl_frp);
	do i = 1 to aclc while (code = 0);
	     call acl_$add_entry (fixed (entry.acle_count), entry.uid, acl_start_ptr, addr (aclp -> acl_list (i)),
		add_sw, code);
	     if code ^= 0
	     then do;
		     call acl_$del_acl (acl_start_ptr, ignore);
		     dir.acle_total = prior_dir_acl_count;
		end;
	     else if add_sw
	     then do;
		     dir.acle_total = dir.acle_total + 1;
		     entry.acle_count = entry.acle_count + 1;
		end;
	end;
	call sum$dirmod (dp);
add_acl_ret:					/* clean up and unlock */
	if dp ^= null
	then call dc_find$finished (dp, dirl);
	a_code = code;
	return;
%page;
%include dc_find_dcls;
%page;
%include dir_entry;
%page;
%include dir_header;
%page;
%include dir_name;
%page;
%include dir_link;
%page;
%include fs_obj_access_codes;
%page;
%include fs_types;
%page;
%include vtoce;
     end retv_util;






		    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
