



		    retrieve_from_volume_.pl1       10/21/92  1511.6rew 10/21/92  1509.3      376938



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



/****^  HISTORY COMMENTS:
  1) change(88-08-10,GWMay), approve(88-10-05,MCR8005), audit(88-10-12,Farley),
     install(88-10-17,MR12.2-1173):
     Updated iox_ dcls and calls.
     Changed read mechanism to deal with incomplete data from dump tapes.
  2) change(91-11-12,Schroth), approve(91-12-02,MCR8252),
     audit(92-10-15,Zimmerman), install(92-10-21,MR12.5-1035):
     Correct error in truncating segments containing embedded nulled pages.
                                                   END HISTORY COMMENTS */


/* format: style1,ind2,^inddcls,ifthenstmt,dclind2,declareind2,ifthendo,ifthen*/

retrieve_from_volume_: proc (a_rvcp, code);


/* This proc searches a dump volume specified by the volume control seg for all the objects specified therein.
   If one is found, then the appropriate action, either entry appending, or object copying is attempted. If
   successful the operator, and the requestor if he indicated, are notified.  The dump volume is searched
   until no more useful information can be read. It is then closed but not detached in case the next volume to be read
   should be the same.
*/

/* Modified by D. Vinograd 6/79 to change check for logical header, to correct authorization in notify
   messages, to fix bug in buffer truncation, and xxx.
*/
/* Modified 2/10/82 by GA Texada to delete a recovered branch if the object cannot be recovered (hardcore 347)     */
/* Modified 4/27/82 by GA Texada to change error handling on read errors.     */
/* Modified July 1982 by GA Texada to fix a bug introduced above.		     */
/* Modified: 8/82 by GA Texada to fix phx07704				     */
/* Modified: 84-03-16 by BIM to put in temporary fix to retrieve multi-class segments. 
	   This introduces a security hole that is closed by code in ring zero 
	   that sets SOOS when retv-appending multiclass objects. */
/* Modified: 84-12-27 by Keith Loepere for version 2 create_branch_info. */
/* Modified 03/12/85 by Greg Texada to fix phx19165, don't give up so soon when resynching (D. Kitson)	*/

dcl a_rvcp	     ptr;
dcl aclc		     fixed bin;
dcl aclp		     ptr;
dcl aclrp		     bit (18);
dcl answer	     char (3) var;
dcl att_desc	     char (256);
dcl attributes	     bit (36);
dcl nelt		     fixed bin (21);
dcl code		     fixed bin (35);
dcl crbp		     ptr;
dcl dp		     ptr;
dcl dtd		     bit (36);
dcl dtm		     bit (36);
dcl emode		     bit (36);
dcl ename		     char (32) aligned;
dcl cslx		     fixed bin;
dcl nmx		     fixed bin;
dcl rvlx		     fixed bin;
dcl ignore	     fixed bin (35);
dcl iocbp		     ptr;
dcl long		     char (100) aligned;
dcl message	     char (512) var init ("");
dcl message_len	     fixed bin;
dcl new_contentsp	     ptr;
dcl nlc		     fixed bin;
dcl nlp		     ptr;
dcl nrp		     bit (18);
dcl object_read	     bit (1);
dcl object_size	     fixed bin (19);
dcl objectp	     ptr;
dcl page_bufferp	     ptr;
dcl page_offset	     fixed bin (21);
dcl pmode		     bit (36);
dcl pname		     char (168) aligned;
dcl pnl		     fixed bin;
dcl pvid		     bit (36);
dcl nel		     fixed bin (21);
dcl requests_left	     fixed bin;
dcl resynch_retry_count  fixed bin;
dcl resynching	     bit (1);
dcl resynching_completed bit (1);
dcl short		     char (8) aligned;
dcl temp_dirname	     char (168);
dcl temp_ename	     char (32);
dcl type		     fixed bin;
dcl uid		     bit (36);
dcl volid		     bit (36);
dcl volname	     char (32);
dcl vtoce_volid	     (3) bit (36);
dcl words_skipped	     fixed bin (35);

dcl page		     bit (BITS_PER_PAGE) aligned based;
dcl based_area	     area based (retv_data_.areap);
dcl copy		     (divide (nel, CHARS_PER_WORD, 17, 0)) fixed bin based;
dcl name_list	     (2) char (32) aligned based (nlp);

dcl 1 local_entry	     like entry;
dcl 1 local_retv_append_args like retv_append_args aligned;
dcl 1 local_create_branch_info like create_branch_info aligned;
dcl 1 local_mseg_return_args like mseg_return_args aligned;

dcl 1 acl_list	     (1) based (aclp) aligned,
    2 person	     char (32),
    2 project	     char (32),
    2 tag		     char (1),
    2 mode	     bit (36),
    2 ex_mode	     bit (36);


dcl dates_set	     defined attributes position (1) bit (1);
dcl dump_switches_set    defined attributes position (2) bit (1);
dcl dump_info_set	     defined attributes position (3) bit (1);
dcl pc_switches_set	     defined attributes position (4) bit (1);
dcl quota_info_set	     defined attributes position (5) bit (1);

dcl word		     (size (backup_volume_header)) bit (36) based (recordp);
dcl input_buf	     (divide (nelt, CHARS_PER_WORD, 17, 0)) bit (36) based (recordp);
dcl string	     bit (BITS_PER_WORD * size (backup_volume_header)) based (recordp);
dcl DELIMITED	     bit (1) aligned internal static options (constant)
		     init ("1"b);
dcl FORWARD_CHAR_POSITIONING fixed bin int static init (3) options (constant);
dcl myname	     char (32) int static init ("retrieve_from_volume_") options (constant);
dcl SEG		     fixed bin static init (1) options (constant);
dcl sm		     bit (3) int static init ("110"b) options (constant);
dcl directory	     fixed bin int static init (1) options (constant);

dcl (error_table_$namedup,
  error_table_$data_loss,
  error_table_$force_unassign,
  error_table_$notadir,
  error_table_$resource_unavailable,
  error_table_$noentry,
  error_table_$moderr,
  error_table_$vtoce_connection_fail,
  error_table_$bad_segment,
  error_table_$device_end,
  error_table_$end_of_info,
  error_table_$root)     fixed bin (35) ext static;

dcl retv_notify_	     entry (char (*), ptr, char (*));
dcl command_query_	     entry options (variable);
dcl hc_backup_$delete    entry (char (*), char (*), fixed bin (35));
dcl hc_backup_$set_bc    entry (char (*), char (*), fixed bin (24), fixed bin (24), fixed bin (35));
dcl hc_backup_$get_entry entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35));
dcl hc_backup_$decode_uidpath entry ((16) bit (36) aligned, char (*), char (*), fixed bin (35));
dcl suffixed_name_$make  entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35));
dcl hc_backup_$retv_status entry (char (*) aligned, char (*) aligned, bit (72) aligned, char (*) aligned,
		     fixed bin, fixed bin, bit (36), bit (36), bit (36), bit (36), (3) bit (36), bit (36), fixed bin (35));
dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl hcs_$truncate_seg    entry (ptr, fixed bin (19), fixed bin (35));
dcl hcs_$make_seg	     entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35));
dcl ioa_$rsnnl	     entry options (variable);
dcl message_segment_$incremental_read_index entry (fixed bin, ptr, bit (2), bit (72) aligned, ptr, fixed bin (35));
dcl message_segment_$update_message_index entry (fixed bin, fixed bin, bit (72) aligned, ptr, fixed bin (35));
dcl retv_report_$error_output entry options (variable);
dcl retv_report_$online_output entry options (variable);
dcl hc_backup_$retv_check entry (char (*) aligned, char (*) aligned, fixed bin, bit (36), fixed bin (35));
dcl hc_backup_$retv_add_acl entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35));
dcl hc_backup_$retv_addname entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35));
dcl hc_backup_$retv_hash_search entry (ptr, ptr, ptr, fixed bin (35));
dcl hc_backup_$retv_append entry (char (*) aligned, char (*) aligned, ptr, ptr, fixed bin (35));
dcl hc_backup_$retv_copy entry (char (*) aligned, char (*) aligned, bit (72) aligned, char (*) aligned, fixed bin,
		     ptr, ptr, bit (36), fixed bin (35));
dcl (addcharno, addr, bit, divide, fixed, index, length, min, null, ptr, rtrim, size, substr, unspec) builtin;

    rvcp = a_rvcp;
    code = 0;
    if retv_vol_control.in_use_cnt = 0 then return;	/* nothing to look at */
						/* pick static ptr */
    recordp = retv_data_.recordp;
    nlp = retv_data_.nlp;
    aclp = retv_data_.aclp;
    objectp = retv_data_.objectp;
    page_bufferp = retv_data_.page_buffer_ptr;
						/* initialize local variables */
    ms_arg_ptr = addr (local_mseg_return_args);
    resynching = "0"b;
    resynching_completed = "0"b;
    iocbp = null;
    inputp = null;
						/* initialize mail structure */

/* construct attach description */
    volname = retv_vol_control.volname;
    volid = retv_vol_control.volid;
    if retv_data_.input_volume_desc ^= "" then
      call ioa_$rsnnl (retv_data_.input_volume_desc, att_desc, (0), volname);
    else call ioa_$rsnnl ("tape_mult_ ^a -system", att_desc, (0), volname);

/* Check if volume to be read is same as last volume read. If so then its already mounted and at
   load point. If not then detach old volume and attach new volume. In either case open volume */

    if volname ^= retv_data_.last_volname then do;
        if retv_data_.input_iocbp ^= null then
	call iox_$detach_iocb (retv_data_.input_iocbp, ignore);
        iocbp = null;
retry:  call iox_$attach_name ("input_volume", iocbp, att_desc, null (), code);
        retv_data_.input_iocbp = iocbp;
        if code ^= 0 then do;
	  if code = error_table_$resource_unavailable |
	       code = error_table_$force_unassign then do;
	      if ^retv_vol_control.skip_query then do;
		query_info.version = query_info_version_5;
		call command_query_ (addr (query_info), answer, myname, "^/^a^/^a",
		     "The physical drive or dump volume is not available or is in use by an other process.",
		     "Do you wish to retry the attachment ");
		if answer = "yes" then goto retry;
		else retv_vol_control.skip_query = "1"b;
	        end;
	      else code = -1;			/* special code that we skipped volume */
	    end;
	  call retv_report_$error_output (code, myname, "Unable to attach dump volume ^a via desc ^a",
	       volname, att_desc);
	  goto finish;
	end;
      end;
    else iocbp = retv_data_.input_iocbp;

    call iox_$open (iocbp, Stream_input, "0"b, code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Unable to  open dump volume ^a", volname);
        goto finish;
      end;
    retv_data_.last_volname = volname;
    requests_left = retv_vol_control.n_entries;
    if retv_data_.long then do;
        call retv_report_$online_output (0, "", "Reading ^a looking for:", volname);
        do rvlx = 1 to retv_vol_control.n_entries;
	rvcep = addr (retv_vol_control.array (rvlx));
	if rvce.in_use then do;
	    if rvce.entry_retrieval then
	      call retv_report_$online_output (0, "", "Entry retrieval of ^a^[>^]^[^a>^;^s^]^a",
		 rvce.dirname, (rvce.dirname ^= ">"), (rvce.ename ^= ""), rvce.ename, rvce.entry_name);
	    else call retv_report_$online_output (0, "", "Object retrieval of ^a^[>^]^a",
		    rvce.dirname, (rvce.dirname ^= ">"), rvce.ename);
	  end;
        end;
      end;

/* This is the main reading loop. The reading scheme is like that of the reloader. Each read is checked for
   an error and if one occured recovery is attempted. Recovery is made a brute force resynching on the pattern
   contained in the record header.  If a read is ok then then the header pattern is checked. If ok then the rest of the
   header is read and checked for type. If it is contents seg then a check is made to see if
   the segment is online. If not an attempt is made to recover it for latter retrievals. If the version of the
   header does not check then the data in the record is skipped. */
search_loop:
    nel = CHARS_PER_WORD * size (backup_volume_header);
    call read (recordp, nel, nelt, ^DELIMITED, code);
    call check_input_error;

    if backup_volume_record.pattern1 ^= pattern1
         | backup_volume_record.pattern2 ^= pattern2
         | backup_volume_record.pattern3 ^= pattern3 then do;
        code = -1;
        call check_input_error;			/* treat as bad read */
      end;

pattern_match:
    nel = backup_volume_record.rec1_len - size (backup_volume_header) * CHARS_PER_WORD;
    call read (ptr (recordp, size (backup_volume_header)), nel, nelt,
         ^DELIMITED, code);
    call check_input_error;

    if backup_volume_record.rec1_type = contents_type then do;
        call record_contents_segment;
        goto search_loop;
      end;

    if backup_volume_record.rec1_type ^= vtoce_type then do;
        nel = backup_volume_record.rec2_len;
        if nel ^= 0 then call skip_chars;
        goto search_loop;
      end;

    if backup_volume_record.version ^= backup_volume_record_version_1 &
         backup_volume_record.version ^= backup_volume_record_version_2 then do;
        call retv_report_$error_output (0, myname, "Invalid volume record on dump volume ^a", volname);
        nel = backup_volume_record.rec2_len;
        if nel ^= 0 then call skip_chars;
        goto search_loop;
      end;

    if backup_volume_record.uid ^= "0"b then do;
        retv_data_.last_valid_puid = backup_volume_record.uid_path;
        retv_data_.last_valid_vtoce_ename = backup_volume_record.primary_name;
      end;
						/* inform operator of last valid object read */
    if resynching_completed & backup_volume_record.uid ^= "0"b then do;
        resynching_completed = "0"b;
        call retv_report_$error_output (0, myname,
	   "First object after resynching ^a on dump volume ^a", convert_puid_ (), volname);
      end;

    object_read = "0"b;

/* Once an object has been read successfully the volume control segment is scanned for a uid match.  */

    do rvlx = 1 to retv_vol_control.n_entries;
      rvcep = addr (retv_vol_control.array (rvlx));
      if rvce.in_use & rvce.uid = backup_volume_record.uid then do;

/* The two following checks make sure that that we recover either the most recent object or the object specified
   by the requestor.  As dump volumes are read in reverse chronological order once an object is
   recovered it should not be recovered again unless it comes from the same dump volume. The requestor may though
   want an object dumped within
   some specific time bracket.  If the conditions are not met we skip the request and try the next one. */

/* Now read the request associated with this control segment entry */

	call read_incremental_queue_message;
	inputp = mseg_return_args.ms_ptr;

	if (retv_input.object_recovered | retv_input.entry_recovered)
	     & retv_input.volid ^= volid then goto check_next_request;

	if ^rvce.entry_retrieval then do;
	    if (rvce.to_time ^= 0 & fixed (bit (backup_volume_record.time_dumped, 52), 52) > rvce.to_time)
	         | (rvce.from_time ^= 0 & fixed (bit (backup_volume_record.time_dumped, 52), 52) < rvce.from_time)
	         then goto check_next_request;
	  end;

/* The object is read only once even though there may be many request for it. When it was written on the
   dump volume it was written in a compact form with no full zero pages. Thus if csl does not
   equal records the zero pages must be reconstructed according to the file map. */

	if ^object_read then do;
	    object_read = "1"b;
	    nel = backup_volume_record.rec2_len;
	    if fixed (backup_volume_record.csl) = fixed (backup_volume_record.records) then do;
	        call read (objectp, nel, nelt,
		   (backup_volume_record.version > backup_volume_record_version_1), code);
	        call check_input_error;
	      end;
	    else do;
	        call read (page_bufferp, nel, nelt,
		   (backup_volume_record.version > backup_volume_record_version_1), code);
	        call check_input_error;

	        page_offset = 0;
	        do cslx = 0 to fixed (backup_volume_record.csl) - 1;
		if ^substr (backup_volume_record.fm (cslx), 1, 1) then do;
		    ptr (objectp, cslx * WORDS_PER_PAGE) -> page =
		         ptr (page_bufferp, page_offset) -> page;
		    page_offset = page_offset + WORDS_PER_PAGE;
		  end;
		else
		     ptr (objectp, cslx * WORDS_PER_PAGE) -> page = "0"b;
	        end;
	      end;
	  end;


/*  If the request is for entry retrieval then what has been recovered is a parent directory. First we locate
   the entry in the directory by name. Once located we constructed a name and access conrol lists. The we initialize
   some control structures and call a special entry in append which appends a given entry structure. If successful
   we notify the operator and requestor(if requested) and attemp to add the other names and the access
   information. If any failures occurr, the operator and possibly the requestor are notified. If though the request
   is for an object then the input buffer is truncated. Next a check is made to see if the object is already there.
   This may have happend as the result of a previous retrieval. If so we will only overwrite
   it if the dump copy is newer or the requestor has specified a time bracket. In either case the
   operator and possibly the requestor are notified.
*/

	if rvce.entry_retrieval then do;
	    call locate_entry;
	    if ep ^= null then do;
	        call build_name_list;
	        call build_access_list;
	        call init_append_args;
	        call ioa_$rsnnl ("^a^[>^]^a", pname, pnl, rvce.dirname, rvce.dirname ^= ">",
		   rvce.ename);
retry_append:     call hc_backup_$retv_append (pname, name_list (1), crbp, retv_append_argp, code);
	        if code ^= 0 then do;
		  if code = error_table_$namedup then do;
		      call ioa_$rsnnl ("Failed to append branch ^a^[>^]^a "
			 || "because object already there with other name",
			 message, (0), pname, pname ^= ">", name_list (1));
		      call retv_notify_ ((message), inputp, myname);
		      code = -1;
		    end;
		  retv_input.errcode = code;
		end;
	        else do;
		  retv_input.entry_recovered = "1"b;
		  call ioa_$rsnnl ("Appended branch ^a^[>^]^a", message, message_len,
		       pname, pname ^= ">", name_list (1));
		  call retv_notify_ ((message), inputp, myname);
		  call hc_backup_$retv_add_acl (pname, name_list (1), aclp, aclc, code);
		  if code ^= 0 then do;
		      call convert_status_code_ (code, short, long);
		      call ioa_$rsnnl ("Failed to append access list to ^a^[>^]^a because ^a",
			 message, message_len, pname, pname ^= ">", name_list (1), long);
		      call retv_notify_ ((message), inputp, myname);
		    end;
		  do nmx = 2 to nlc;
		    call hc_backup_$retv_addname (pname, name_list (1), name_list (nmx), code);
		    if code ^= 0 then do;
		        call convert_status_code_ (code, short, long);
		        call ioa_$rsnnl ("Failed to add name ^a to ^a^[>^]^a because ^a",
			   message, message_len, name_list (nmx), pname, pname ^= ">",
			   name_list (1), long);
		        call retv_notify_ ((message), inputp, myname);
		      end;
		  end;
		end;
	      end;
	    else goto check_next_request;
	  end;
	else do;
	    object_size = fixed (backup_volume_record.csl, 18, 0) * WORDS_PER_PAGE;
	    call hcs_$truncate_seg (objectp, object_size + 1, ignore); /* object_size + 1 is first word to discard */
	    if retv_input.new_dirname ^= "" then do;	/* cross object retrieval */
	        call hc_backup_$retv_status (retv_input.new_dirname, "",
		   retv_input.access_class, retv_input.requestor, retv_input.level, type,
		   emode, pmode, uid, pvid, vtoce_volid, dtd, code);
	        if code ^= 0 then do;
		  if uid = "0"b then
		    code = error_table_$noentry;
		  else if type ^= directory then
		    code = error_table_$notadir;
		  else if ^((emode & sm) = sm | (pmode & sm) = sm) then
		    code = error_table_$moderr;
		  call convert_status_code_ (code, short, long);
		  call ioa_$rsnnl ("Failed to cross retrieve into ^a  because ^a", message, message_len,
		       retv_input.new_dirname, long);
		  call retv_notify_ ((message), inputp, myname);
		  code = -1;
		  goto set_code;
		end;
	        ep = addr (local_entry);
	        call hc_backup_$get_entry (retv_input.dirname, retv_input.ename, ep, code);
	        if code ^= 0 then do;
		  call convert_status_code_ (code, short, long);
		  call ioa_$rsnnl (
		       "Failed to cross retrieve  ^a^[>^]^a because unable to locate ^a^[>^]^a because ^a",
		       message, message_len, retv_input.new_dirname, retv_input.new_dirname ^= ">",
		       retv_input.new_ename, retv_input.dirname, retv_input.dirname ^= ">",
		       retv_input.ename, long);
		  call retv_notify_ ((message), inputp, myname);
		  code = -1;
		  goto set_code;
		end;
	        backup_volume_record.uid = entry.uid;
	        backup_volume_record.dtd = "0"b;
	        backup_volume_record.volid (*) = "0"b;
	        call init_append_args;
	        retv_append_args.cross_segment = "1"b;
	        call hc_backup_$retv_append (retv_input.new_dirname, retv_input.new_ename, crbp,
		   retv_append_argp, code);
	        if code ^= 0 then do;
		  call convert_status_code_ (code, short, long);
		  call ioa_$rsnnl ("Failed to append cross retrieval branch ^a^[>^]^a  because ^a",
		       message, message_len, retv_input.new_dirname, retv_input.new_dirname ^= ">",
		       retv_input.new_ename, long);
		  call retv_notify_ ((message), inputp, myname);
		  code = -1;
		  goto set_code;
		end;
	        call hc_backup_$retv_copy (retv_input.new_dirname, retv_input.new_ename,
		   retv_input.access_class, retv_input.requestor, retv_input.level,
		   addr (backup_volume_record.vtoce), objectp, attributes, code);
	        if code ^= 0 then do;
		  call convert_status_code_ (code, short, long);
		  call ioa_$rsnnl ("Failed to copy cross retrieval object ^a^[>^]^a  because ^a",
		       message, message_len, retv_input.new_dirname, retv_input.new_dirname ^= ">",
		       retv_input.new_ename, long);
		  call retv_notify_ ((message), inputp, myname);
		  code = -1;
		  goto set_code;
		end;
	      end;
	    else do;				/* object retrieval */
	        call hc_backup_$retv_check (rvce.dirname, rvce.ename, type, dtm, code);
	        if code = error_table_$vtoce_connection_fail
		   | code = 0 & backup_volume_record.dtm >= dtm
		   | code = 0 & (rvce.from_time ^= 0 | rvce.to_time ^= 0)
		   | code = 0 & rvce.previous then do;
		  call hc_backup_$retv_copy (rvce.dirname, rvce.ename, retv_input.access_class,
		       retv_input.requestor, retv_input.level, addr (backup_volume_record.vtoce), objectp,
		       attributes, code);
		end;
	        else if code = 0 then do;
		  call ioa_$rsnnl ("Failed to recover object ^a^[>^]^a because more recent copy online",
		       message, message_len, rvce.dirname, rvce.dirname ^= ">", rvce.ename);
		  call retv_notify_ ((message), inputp, myname);
		  retv_input.errcode = -1;		/* in this case, we don't want to delete the recovered*/
		  goto update_message;		/* branch, or we would leave a connection failure.*/
		end;
	      end;
set_code:	    if code ^= 0 then do;
	        retv_input.errcode = code;
	        if retv_input.entry_recovered then do;
		  if retv_append_args.cross_segment then
		    call hc_backup_$delete ((retv_input.new_dirname),
		         (retv_input.new_ename), code);
		  else call hc_backup_$delete ((rvce.dirname), (rvce.ename), code);
		end;
	        goto update_message;
	      end;
	    else do;
	        if retv_input.new_dirname ^= "" then temp_dirname = retv_input.new_dirname;
	        else temp_dirname = rvce.dirname;
	        if retv_input.new_ename ^= "" then temp_ename = retv_input.new_ename;
	        else temp_ename = rvce.ename;
	        call ioa_$rsnnl ("Recovered ^[segment^;directory^] ^a^[>^]^a", message, message_len,
		   type = SEG, temp_dirname, temp_dirname ^= ">", temp_ename);
	        if ^backup_volume_record.dirsw then
		call set_bc (temp_dirname, temp_ename);
	        call retv_notify_ ((message), inputp, myname);
	        if attributes then do;
		  call ioa_$rsnnl
		       ("Failed to set ^[dates ^]^[dump_switches ^]^[dump_info ^]^[pc_switches ^]"
		       || "^[quota_info^] for ^a^[>^]^a",
		       message, message_len, dates_set, dump_switches_set, dump_info_set, pc_switches_set,
		       quota_info_set, temp_dirname, temp_dirname ^= ">", temp_ename);
		  call retv_notify_ ((message), inputp, myname);
		end;
	        retv_input.object_recovered = "1"b;
	        retv_input.errcode = 0;
	      end;
	  end;
update_message:
	retv_input.volid = volid;
	call update_queue_message;
	if retv_vol_control.dump_type ^= incr then requests_left = requests_left - 1;
	if requests_left = 0 then do;
	    call close;
	    goto finish;
	  end;
        end;
check_next_request:
    end;
    if ^object_read then do;
        nel = backup_volume_record.rec2_len;
        if nel ^= 0 then do;
/**** skip object, but use read procedure to skip the full object and check for
      object delimiters (if applicable). */
	  call read (objectp, nel, nelt,
	       (backup_volume_record.version > backup_volume_record_version_1), code);
	  call check_input_error;
	end;
      end;
    goto search_loop;
finish:
    if inputp ^= null then free retv_input in (based_area);
    return;

skip_chars: proc;

/* This proc skips foward the number of chars specified in the variable nel.
*/

    nelt = nel;
    call read (null (), nel, nelt, ^DELIMITED, code);
    call check_input_error;
  end skip_chars;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


check_input_error: proc;

/* This proc checks for errors after a read of the dump volume. It we have reached the end of the volume then a non
   local return is made and the main routine returns to its caller. Otherwise if an error has
   occurred we attempted to recover. If we are already recovering we terminate the retrieval. Of course
   in the errorless case we just return */

    if code ^= 0 | nelt ^= nel then do;
        if (code = error_table_$end_of_info | code = error_table_$device_end) then do;
	  if resynching then do;
	      call retv_report_$error_output (0, myname, "Resynchronization terminated by end of volume ^a",
		 volname);
	      call retv_report_$error_output (0, myname, "Skipped ^d words on dump volume ^a",
		 words_skipped, volname);
	    end;
	  call close;
	  goto finish;
	end;
        else do;
	  if ^resynching then do;
	      if nel ^= nelt then
	        call retv_report_$error_output (0, myname, "Read did not complete on dump volume ^a", volname);
	      if code = -1 then
	        call retv_report_$error_output (0, myname, "Invalid dump record header on ^a", volname);
	      else call retv_report_$error_output (code, myname, "I/O error reading dump volume ^a",
		      volname);
	      call retv_report_$error_output (0, myname,
		 "Invalid input record on dump volume ^a after ^a  - resynching started",
		 volname, convert_puid_ ());
	      resynch_retry_count = 0;
	      call resynch_input_volume;
	    end;
	  else do;				/* already had an error			*/
	      resynch_retry_count = resynch_retry_count + 1;
						/* keep track so we don't try this forever	*/
	      if resynch_retry_count > 64 then do;
		call retv_report_$error_output (code, myname,
		     "Resynchronization failed due to I/O error during resynching on volume ^a", volname);
		call close;
		goto finish;
	        end;
	    end;
	end;
      end;
  end check_input_error;

close: proc;

/* This proc closes the open switch. It does not detach it, as the next dump volume to be read
   may be the same volume just read. */

    call iox_$close (iocbp, code);
    if code ^= 0 then
      call retv_report_$error_output (code, myname, "Unable to close input volume ^a", volname);
  end close;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


resynch_input_volume: proc;

/* This proc  resynchronizes a dump volume by stepping through the input one word at a time until it
   recognizes the volume header unique pattern or until we get to the end of the volume. An upper
   bound of one million words is placed on the loop so it will finish */

    resynching = "1"b;
    input_buf (*) = "0"b;
    nel = CHARS_PER_WORD * size (backup_volume_header);
    call read (recordp, nel, nelt, ^DELIMITED, code);
    call check_input_error;

    words_skipped = 0;
test: if word (1) = pattern1 & word (4) = pattern2 & word (7) = pattern3 then do;
        call retv_report_$error_output (0, myname,
	   "Synchronization completed ^d words skipped on dump volume ^a",
	   words_skipped, volname);
        resynching = "0"b;
        resynching_completed = "1"b;
        goto pattern_match;
      end;

    string = substr (string, 37, (size (backup_volume_header) - 1) * BITS_PER_WORD);
    nel = CHARS_PER_WORD;
    call read (addr (word (size (backup_volume_header))), nel, nelt,
         ^DELIMITED, code);
    call check_input_error;

    words_skipped = words_skipped + 1;
    if words_skipped > 256 * WORDS_PER_PAGE then do;	/* put a limit on it */
        call retv_report_$error_output (0, myname, "Resynchronization failed on dump volume ^a", volname);
        code = error_table_$end_of_info;
        call check_input_error;
      end;
    goto test;
  end resynch_input_volume;

locate_entry: proc;

/* This proc locates an entry in a temp copy of a directory by using an interface to the
   ring 0 hash routine. It returns a non null entry pointer if the entry was found */

    ep = null;
    dp = objectp;
    np = addr (rvce.entry_name);
    call hc_backup_$retv_hash_search (dp, np, ep, code);
    if code ^= 0 then ep = null;
    if ep = null then return;
    if rvce.link_retrieval then if entry.bs then ep = null;
  end locate_entry;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


build_name_list: proc;

/* This proc constructs an array of names associated with some entry. */

    nlc = 0;
    do nrp = entry.name_frp repeat (np -> names.fp) while (nrp ^= "0"b);
      np = ptr (ep, nrp);
      nlc = nlc + 1;
      name_list (nlc) = np -> names.name;
    end;
    return;
  end build_name_list;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


build_access_list: proc;

/* This proc constructs an array of access control items associated with some entry */

    aclc = 0;
    if ^entry.bs then return;
    do aclrp = entry.acl_frp repeat (acl_entry.frp) while (aclrp ^= "0"b);
      aclep = ptr (ep, aclrp);
      aclc = aclc + 1;
      if acl_entry.pers_rp = "0"b then acl_list (aclc).person = "*";
      else acl_list (aclc).person = ptr (ep, acl_entry.pers_rp) -> access_name.name;
      if acl_entry.proj_rp = "0"b then acl_list (aclc).project = "*";
      else acl_list (aclc).project = ptr (ep, acl_entry.proj_rp) -> access_name.name;
      acl_list (aclc).tag = acl_entry.tag;
      acl_list (aclc).mode = acl_entry.mode;
      acl_list (aclc).ex_mode = acl_entry.ex_mode;
    end;
    return;
  end build_access_list;

record_contents_segment: proc;

/* This proc recovers a contents segment from the dump volume if it is not already online. */

    contentsp = recordp;
    call suffixed_name_$make (backup_volume_contents.volname, "contents", ename, code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Unable to construct ^a.contents",
	   backup_volume_contents.volname);
        return;
      end;
    call hcs_$make_seg (rtrim (retv_data_.sys_dir) || ">contents",
         ename, "", 01010b, new_contentsp, code);
    if code = 0 then new_contentsp -> copy = contentsp -> copy;
  end record_contents_segment;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

update_queue_message: proc;

/* This proc updates an existant message in the retrieve's private queue */

retry_update: call message_segment_$update_message_index (retv_data_.qidx (retriever),
         size (retv_input) * BITS_PER_WORD, rvce.retv_ms_id, inputp, code);
    if code ^= 0 then do;
        if code = error_table_$bad_segment then do;
	  call retv_report_$error_output (0, myname, "Private queue has been salvaged");
	  goto retry_update;
	end;
        else do;
	  call retv_report_$error_output (code, myname, "Update of private queue failed");
	  goto finish;
	end;
      end;
  end update_queue_message;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

read_incremental_queue_message: proc;

/* This proc reads a specified message from the retrievers private queue. It takes care to manage the allocated
   storage so it is not slowly eaten away */

    if inputp ^= null then free retv_input in (based_area);
reread: call message_segment_$incremental_read_index (retv_data_.qidx (retriever), retv_data_.areap,
         "00"b, rvce.retv_ms_id, ms_arg_ptr, code);
    if code ^= 0 then do;
        if code = error_table_$bad_segment then do;
	  call retv_report_$error_output (0, myname, "Private queue has been salvaged");
	  goto reread;
	end;
        else do;
	  call retv_report_$error_output (code, myname, "Read of private queue failed");
	  goto finish;
	end;
      end;
  end read_incremental_queue_message;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


init_append_args: proc;

/* This proc setups the control structures for the special entry appending call */

    crbp = addr (local_create_branch_info);
    crbp -> create_branch_info.version = create_branch_version_2;
    if entry.bs then crbp -> create_branch_info.dir_sw = entry.dirsw;
    else crbp -> create_branch_info.dir_sw = "0"b;
    if entry.bs then crbp -> create_branch_info.copy_sw = entry.copysw;
    else crbp -> create_branch_info.copy_sw = "0"b;
    crbp -> create_branch_info.chase_sw = "0"b;
    crbp -> create_branch_info.parent_ac_sw = "0"b;
    crbp -> create_branch_info.priv_upgrade_sw = "1"b;
    crbp -> create_branch_info.mode = "0"b;
    if entry.bs then crbp -> create_branch_info.rings (*) = fixed (entry.ring_brackets (*), 3);
    else crbp -> create_branch_info.rings (*) = 0;
    crbp -> create_branch_info.userid = retv_input.requestor;
    if entry.bs then crbp -> create_branch_info.bitcnt = entry.bc;
    else crbp -> create_branch_info.bitcnt = 0;
    crbp -> create_branch_info.quota = 0;
    crbp -> create_branch_info.dir_quota = 0;
    if entry.bs then crbp -> create_branch_info.access_class = entry.access_class;
    else crbp -> create_branch_info.access_class = "0"b;
    unspec (local_retv_append_args) = "0"b;
    retv_append_argp = addr (local_retv_append_args);
    retv_append_args.version = RETV_APPEND_ARGS_VERSION_1;
    retv_append_args.level = retv_input.level;
    retv_append_args.access_authorization = retv_input.access_class; /* user auth at time of err */
    retv_append_args.max_access_authorization = crbp -> create_branch_info.access_class; /* This is a LIE. We have no idea what the user's max */
						/* authorization is. This is high enough to make the append succeed, and then */
						/* append in ring zero will set it SOOS until an administrator wanders by. */
    retv_append_args.ep = ep;
    retv_append_args.link = ^entry.bs;
    return;

  end init_append_args;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


convert_puid_: proc returns (char (168) var);

/* This proc is used to convert a unique id pathname to an ascii pathname  */

dcl dn		     char (168);
dcl en		     char (32);
dcl ret_dn	     char (168);
    call hc_backup_$decode_uidpath (retv_data_.last_valid_puid, dn, en, code);
    if code = error_table_$root then ;
    else if code ^= 0 then return ("UNKNOWN_PATH>" || rtrim (retv_data_.last_valid_vtoce_ename));
    call ioa_$rsnnl ("^a^[>^]^[^a>^;^s^]^a", ret_dn, (0), dn, dn ^= ">", en ^= "", en, retv_data_.last_valid_vtoce_ename);
    return (ret_dn);
  end convert_puid_;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
read: proc (return_buffer_ptr,
       Nrequested_chars,
       Nreturned_chars,
       Sdelimited,
       code);

dcl return_buffer_ptr    ptr,
  Nrequested_chars	     fixed bin (21),
  Nreturned_chars	     fixed bin (21),
  Sdelimited	     bit (1) aligned,
  code		     fixed bin (35);

dcl input_buffer	     char (256 * CHARS_PER_PAGE)
		     based (retv_data_.input_buffer_ptr);

dcl return_string	     char (Nrequested_chars)
		     based (return_buffer_ptr);

dcl Nassign_chars	     fixed bin (21),
  Nread_chars	     fixed bin (21),
  end_of_record	     fixed bin,
  tape_check1 /* bit (72) */ char (8),
  tape_check2 /* bit (72) */ char (8);

    Nreturned_chars, Nread_chars, code = 0;

    do while (Nreturned_chars < Nrequested_chars & code = 0);
      if retv_data_.input_buffer_len = 0 then do;
	retv_data_.input_buffer_start = 1;

	if Sdelimited & Nreturned_chars = 0 then do;
	    call iox_$get_chars (retv_data_.input_iocbp,
	         addr (tape_check1), length (tape_check1), Nread_chars, code);
	    if code ^= 0 then return;
	  end;

	if return_buffer_ptr = null then do;
	    call iox_$position (retv_data_.input_iocbp, FORWARD_CHAR_POSITIONING,
	         Nrequested_chars - Nreturned_chars, code);
	    Nreturned_chars = Nreturned_chars + Nrequested_chars;
	  end;
	else do;
	    call iox_$get_chars (retv_data_.input_iocbp,
	         addcharno (return_buffer_ptr, Nreturned_chars),
	         Nrequested_chars - Nreturned_chars, Nread_chars, code);
	    Nreturned_chars = Nreturned_chars + Nread_chars;
	  end;
	if code ^= 0 then return;

	if Sdelimited then do;
	    call iox_$get_chars (retv_data_.input_iocbp,
	         addr (tape_check2), length (tape_check2), Nread_chars, code);
	    if code ^= 0 then
	      return;

	    if tape_check1 ^= tape_check2 then do;
						/* found a short segment, move       */
						/* return string into the temp input */
						/* buffer and start parsing          */
	        retv_data_.input_buffer_len = Nreturned_chars;
	        substr (input_buffer, 1, retv_data_.input_buffer_len) =
		   return_string;
	      end;
	  end;
        end;

      else
	 if Sdelimited then do;
	tape_check1 = substr (input_buffer,
	     retv_data_.input_buffer_start, length (tape_check1));
	tape_check2 = "";
	retv_data_.input_buffer_start =
	     retv_data_.input_buffer_start + length (tape_check1);
	retv_data_.input_buffer_len =
	     retv_data_.input_buffer_len - length (tape_check1);
        end;

      if retv_data_.input_buffer_len > 0 then do;
	Nassign_chars =
	     min (retv_data_.input_buffer_len, Nrequested_chars);

	if Sdelimited then do;
	    if tape_check1 ^= tape_check2 then do;
	        end_of_record = index (substr (input_buffer, retv_data_.input_buffer_start,
		   retv_data_.input_buffer_len), tape_check1);
	        if end_of_record > 0 then do;
		  Nassign_chars = end_of_record - 1;
		  if Nrequested_chars ^= Nassign_chars then
		    code = error_table_$data_loss;
		end;
	      end;
	  end;

	if return_buffer_ptr ^= null then
	  return_string = substr (input_buffer,
	       retv_data_.input_buffer_start, Nassign_chars);
	Nreturned_chars = Nassign_chars;

	retv_data_.input_buffer_start =
	     retv_data_.input_buffer_start + Nassign_chars;
	retv_data_.input_buffer_len =
	     retv_data_.input_buffer_len - Nassign_chars;

	if Sdelimited & retv_data_.input_buffer_len > 0 then do;
	    retv_data_.input_buffer_start =
	         retv_data_.input_buffer_start + length (tape_check2);
	    substr (input_buffer, 1, retv_data_.input_buffer_len) =
	         substr (input_buffer, retv_data_.input_buffer_start,
	         retv_data_.input_buffer_len - length (tape_check2))
	         || tape_check2;
	    retv_data_.input_buffer_start = 1;
	  end;
        end;
    end;

    return;
  end read;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


set_bc: proc (dirname, ename);
dcl old_bc	     fixed bin (24);
dcl (dirname, ename)     char (*);
dcl new_bc	     fixed bin (24);

/* This proc sets the bit count of the recovered object */

    new_bc = 9 * backup_volume_record.rec2_len;
    if fixed (backup_volume_record.csl, 9) ^= fixed (backup_volume_record.records, 9) then
      new_bc = new_bc + WORDS_PER_PAGE * BITS_PER_WORD * (fixed (backup_volume_record.csl, 9)
	 - fixed (backup_volume_record.records, 9));
    call hc_backup_$set_bc (dirname, ename, new_bc, old_bc, code);
    if code ^= 0 then do;
        call convert_status_code_ (code, short, long);
        call ioa_$rsnnl ("^a^/Bit count could not be set for ^a>^a because ^a",
	   message, 0, message, rvce.dirname, rvce.ename, long);
        return;
      end;
    if new_bc ^= old_bc then do;
        call ioa_$rsnnl ("^a^/Bit count of ^a>^a reset to ^d from ^d", message, 0,
	   message, dirname, ename, new_bc, old_bc);
      end;

  end set_bc;

%include retv_data_;
%include retv_request;
%include queue_msg_hdr;
%include retv_input;
%include mseg_return_args;
%include backup_static_variables;
%include backup_volume_contents;
%include backup_volume_record;
%include backup_volume_header;
%include backup_pvol_info;
%include fs_vol_label;
%include vtoce;
%include dir_entry;
%include dir_name;
%include dir_acl;
%include retv_vol_control;
%include retv_append_args;
%include create_branch_info;
%include iox_dcls;
%include iox_modes;
%include query_info;
%include system_constants;

  end retrieve_from_volume_;




		    retriever.pl1                   10/17/88  1530.8rew 10/17/88  1425.4      335007



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * 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-11-17,GWMay), approve(86-11-17,MCR7445), audit(86-11-20,GDixon),
     install(86-11-21,MR12.0-1223):
     added entrypoint "test" for debugging the retriever from a user process
     without changes to the system volume retriever queues.
  2) change(88-08-10,GWMay), approve(88-10-05,MCR8005), audit(88-10-12,Farley),
     install(88-10-17,MR12.2-1173):
     Added administrative support for two additional temporary work segments.
                                                   END HISTORY COMMENTS */


/* format: style1,ind2,^inddcls,ifthenstmt,dclind2,declareind2,ifthendo,ifthen*/

retriever: retrieve_from_volume: retv: proc;

/* This is the main control routine of the volume retriever subsystem. It initializes the
   static control structure, parses the arguments, and controls which requests are processed. It uses two
   other routines, retv_vol_control_, to determine which dump volumes a request may be recovered from
   and retrieve_from_volume_, to recover objects from a specified dump volume. The major data bases created by
   this subsystem are in the process directory or in external static and are initialize/created for each invocation.
*/

/* Modified 6/79 by D. Vinograd to correct notification bug, add accounting control argument ,
   add directory name space searching option, and xxx
   Modified: 12/18/81 by GA Texada to correct a bug in cross-retrieval (phx12113)
   Modified: 09/03/82 by GA Texada to fix a bug in scan_sub_tree when it calls submit_request.
   Modified: 3/83 by E. N. Kittlitz for 256K segments.
   Modified: 8/83 by GA Texada to make the "list" request go thru all the q's.
   Modified: 5/15/85 by GA Texada to ensure that retv_data_.qidx(X) is zeroed after calling message_segment_$delete
*/

dcl wdir		     char (168);
dcl short		     char (8) aligned;
dcl ac		     fixed bin;
dcl options_string	     char (256);
dcl osl		     fixed bin;
dcl narg		     fixed bin;
dcl answer	     char (3) var;
dcl long		     char (100) aligned;
dcl message	     char (256);
dcl message_len	     fixed bin;
dcl line		     char (32);
dcl tp		     (9) ptr;
dcl nelemt	     fixed bin (21);
dcl rvcx		     fixed bin;
dcl sorty		     fixed bin;
dcl sortx		     fixed bin;
dcl nvolx		     fixed bin;
dcl q		     fixed bin;
dcl qx		     fixed bin;
dcl to_from	     bit (1);
dcl retv_ms_id	     bit (72) aligned;
dcl more_messages	     bit (1);
dcl more_to_do	     bit (1);
dcl dtm		     bit (36);
dcl queue_name	     char (32);
dcl step		     bit (1);
dcl list		     bit (1);
dcl code		     fixed bin (35);
dcl type		     fixed bin;
dcl ignore	     fixed bin (35);
dcl arg		     char (argl) based (argp);
dcl argl		     fixed bin;
dcl argp		     ptr;
dcl old_256K_switch	     bit (2) aligned;

dcl based_area	     area based (retv_data_.areap);

dcl LINK		     fixed bin static init (3) options (constant);
dcl DIR		     fixed bin int static init (2) options (constant);
dcl recursive_invocation bit (1) aligned int static init ("0"b);
dcl myname	     char (32) int static init ("retrieve_from_volume") options (constant);
dcl max_q_num	     fixed bin static init (3) options (constant);

dcl 1 local_mseg_return_args like mseg_return_args aligned;
dcl 1 local_retv_input   like retv_input aligned;

dcl error_table_$noentry ext fixed bin (35);
dcl error_table_$resource_unavailable ext fixed bin (35);
dcl error_table_$badopt  fixed bin (35) ext;
dcl error_table_$vtoce_connection_fail ext fixed bin (35);
dcl error_table_$bad_segment ext fixed bin (35);
dcl error_table_$no_message ext fixed bin (35);
dcl sys_info$seg_size_256K fixed bin (19) ext static;
dcl sys_info$max_seg_size fixed bin (18) ext static;

dcl retv_vol_control_$sort entry (ptr, fixed bin (35));
dcl retv_notify_	     entry (char (*), ptr, char (*));
dcl request_id_	     entry (fixed bin (71)) returns (char (19));
dcl get_wdir_	     entry returns (char (168));
dcl retv_report_$error_output entry options (variable);
dcl retv_report_$online_output entry options (variable);
dcl message_segment_$close entry (fixed bin, fixed bin (35));
dcl message_segment_$open entry (char (*), char (*), fixed bin, fixed bin (35));
dcl message_segment_$delete entry (char (*), char (*), fixed bin (35));
dcl message_segment_$delete_index entry (fixed bin, bit (72) aligned, fixed bin (35));
dcl command_query_	     entry options (variable);
dcl system_privilege_$ring1_priv_on entry (fixed bin (35));
dcl system_privilege_$ring1_priv_off entry (fixed bin (35));
dcl system_privilege_$ipc_priv_on entry (fixed bin (35));
dcl system_privilege_$ipc_priv_off entry (fixed bin (35));
dcl retv_account_$create entry (fixed bin (35));
dcl retv_account_$update entry (char (*) aligned);
dcl hc_backup_$retv_name_list entry (char (*) aligned, ptr, ptr, fixed bin, fixed bin (35));
dcl hc_backup_$retv_check entry (char (*) aligned, char (*) aligned, fixed bin, bit (36), fixed bin (35));
dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl hcs_$delentry_seg    entry (ptr, fixed bin (35));
dcl hcs_$set_256K_switch entry (bit (2) aligned, bit (2) aligned, fixed bin (35));
dcl hcs_$set_max_length_seg entry (ptr, fixed bin (19), fixed bin (35));
dcl hcs_$truncate_seg    entry (ptr, fixed bin (19), fixed bin (35));
dcl date_time_	     entry (fixed bin (71), char (*));
dcl get_system_free_area_ entry returns (ptr);
dcl get_temp_segments_   entry (char (*), (*) ptr, fixed bin (35));
dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl cu_$arg_count	     entry (fixed bin);
dcl cu_$arg_ptr	     entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl com_err_	     entry options (variable);
dcl ioa_$rsnnl	     entry options (variable);
dcl ioa_		     entry options (variable);
dcl cv_oct_check_	     entry (char (*), fixed bin (35)) returns (fixed bin);
dcl ioa_$nnl	     entry options (variable);
dcl message_segment_$create entry (char (*), char (*), fixed bin (35));
dcl message_segment_$add_index entry (fixed bin, ptr, fixed bin, bit (72) aligned, fixed bin (35));
dcl message_segment_$read_index entry (fixed bin, ptr, bit (1), ptr, fixed bin (35));
dcl retrieve_from_volume_ entry (ptr, fixed bin (35));
dcl retv_vol_control_    entry (ptr, fixed bin (35));
dcl message_segment_$incremental_read_index entry (fixed bin, ptr, bit (2), bit (72) aligned, ptr,
		     fixed bin (35));
dcl message_segment_$update_message_index entry (fixed bin, fixed bin, bit (72) aligned, ptr, fixed bin (35));

dcl cleanup	     condition;
dcl linkage_error	     condition;

dcl (fixed, hbound, before) builtin;
dcl addr		     builtin;
dcl size		     builtin;
dcl unspec	     builtin;
dcl length	     builtin;
dcl null		     builtin;
dcl substr	     builtin;

main: goto common;

test: entry (test_dir);

/*  This entry point is the counter part to the test entry point in the     */
/*  enter_retrieval_request (err) command program.  It is designed for use  */
/*  in testing the volume dumper/retriever.  To use it type		      */
/*  "retrieve_from_volume$test wdir"  where wdir is the directory where you */
/*  have created private message_segments named volume_retiever.ms and      */
/*  volume_retiever(1 2 3).ms for use as the retriever queues.	      */
/*  Type "err$test wdir" before entering the retrieval request giving the   */
/*  same directory which contains the queue.			      */

dcl test_dir	     char (*);
    queue_dir = test_dir;
    return;

common:
						/* protect against recursive invocation */
    if recursive_invocation then do;
        call com_err_ (0, myname, "Recursive invocation not allowed ");
        return;
      end;
						/* initialize static variables */
    old_256K_switch = ""b;
    tp (*) = null;
    retv_data_.ptrs = null;
    retv_data_.chars = "";
    retv_data_.bits = ""b;
    retv_data_.sys_dir = ">daemon_dir_dir>volume_backup";
    retv_data_.fixed = 0;
    retv_data_.all = "1"b;
    retv_data_.io_module = "tape_mult_";
						/* and some local variables */
    ms_arg_ptr = addr (local_mseg_return_args);
    q = 1;
    list = "0"b;
    wdir = get_wdir_ ();
    step = "0"b;
						/* initialize mail structure */
						/* process arguments */
    inputp, requestp = null;
    ac = 1;
    call cu_$arg_count (narg);
    do while (ac <= narg);
      call cu_$arg_ptr (ac, argp, argl, code);
      if code ^= 0 then do;
no_arg:	call retv_report_$error_output (code, myname, "Unable to access arg after ^a", arg);
	goto finale;
        end;
      ac = ac + 1;
      if arg = "-step" then step = "1"b;
      else if arg = "-manual" then retv_data_.manual = "1"b;
      else if arg = "-long" then retv_data_.long = "1"b;
      else if arg = "-working_dir" | arg = "-wd" then retv_data_.sys_dir = wdir;
      else if arg = "-accounting" then retv_data_.accounting = "1"b;
      else if arg = "-all" | arg = "-a" then ;
      else if arg = "-error_on" then retv_data_.err_online = "1"b;
      else if arg = "-list" then list = "1"b;
      else if arg = "-input_volume_desc" then do;
	call cu_$arg_ptr (ac, argp, argl, code);
	if code ^= 0 then goto no_arg;
	ac = ac + 1;
	retv_data_.input_volume_desc = arg;
	retv_data_.io_module = before (arg, " ");
        end;
      else if arg = "-q" | arg = "-queue" then do;
	retv_data_.all = "0"b;
	call cu_$arg_ptr (ac, argp, argl, code);
	if code ^= 0 then goto no_arg;
	ac = ac + 1;
	q = cv_oct_check_ (arg, code);
	if code ^= 0 | (q < 1 | q > 3) then do;
	    call retv_report_$error_output (0, myname,
	         "Invalid queue number ^a", arg);
	    goto finale;
	  end;
        end;
      else do;
	call retv_report_$error_output (error_table_$badopt, myname, "^a", arg);
	goto finale;
        end;
    end;
    retv_data_.queue = q;
    on cleanup call clean_it_up;
    recursive_invocation = "1"b;
start:
    call message_segment_$open (queue_dir, queue_seg_ (), retv_data_.qidx (user), code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Unable to open user queue ^a>^a", queue_dir, queue_seg_ ());
        goto finish;
      end;

    call message_segment_$open (wdir, "volume_retriever.ms", retv_data_.qidx (retriever), code);
    if code ^= 0 & code ^= error_table_$noentry then do;
        call retv_report_$error_output (code, myname, "Unable to open private queue ^a>volume_retriever.ms", wdir);
        goto finale;
      end;
    retv_data_.arg_init = "1"b;
    retv_data_.areap = get_system_free_area_ ();
						/* create temp segs and set static ptrs */
    call get_temp_segments_ (myname, tp, code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Unable to create temp segs");
        goto finale;
      end;
    retv_data_.nlp = tp (1);
    retv_data_.aclp = tp (2);
    retv_data_.recordp = tp (3);
    retv_data_.objectp = tp (4);
    retv_data_.vlp = tp (5);
    retv_data_.contentsp = tp (6);
    retv_data_.skip = tp (7);
    retv_data_.input_buffer_ptr = tp (8);
    retv_data_.page_buffer_ptr = tp (9);

    call hcs_$set_256K_switch ("11"b, (""b), code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Could not enable 256KW segments.");
        go to finale;
      end;
    call hcs_$set_max_length_seg (retv_data_.objectp, sys_info$seg_size_256K, code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Could not make 256K word temp seg (7).");
        go to finale;
      end;

    call hcs_$set_max_length_seg (retv_data_.input_buffer_ptr, sys_info$seg_size_256K, code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Could not make 256K word temp seg (8).");
        go to finale;
      end;

    call hcs_$set_max_length_seg (retv_data_.page_buffer_ptr, sys_info$seg_size_256K, code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Could not make 256K word temp seg (9).");
        go to finale;
      end;

    on linkage_error begin;
        call retv_report_$error_output (0, myname, "AIM ring 1 and ipc privileges not enabled.");
        goto set_cleanup;
      end;

    call system_privilege_$ring1_priv_on (ignore);
    call system_privilege_$ipc_priv_on (ignore);

/* establish cleanup handler and set flag */
set_cleanup:
    revert linkage_error;
    if retv_data_.qidx (retriever) ^= 0 then do;
        call read_queue_message (retriever);
        do while (more_messages);
	inputp = mseg_return_args.ms_ptr;
	call ioa_ ("ID: ^a Retrieval request of ^a^[>^]^a for ^a",
	     substr (request_id_ (retv_input.msg_time), 7, 8),
	     retv_input.dirname, retv_input.dirname ^= ">",
	     retv_input.ename, retv_input.requestor);
	call ioa_$rsnnl (
	     "^[-skip ^]^[-subtree ^]^[-notify ^]^[-previous ^]^[-to ^a ^;^s ^]^[-from ^a ^;^s^]^[-new path ^a^[->^]^a^;^s^]",
	     options_string, osl, retv_input.skip_it,
	     retv_input.subtree, retv_input.notify, retv_input.previous,
	     retv_input.to_time ^= 0 & ^retv_input.previous,
	     time_ (retv_input.to_time), retv_input.from_time ^= 0,
	     time_ (retv_input.from_time), retv_input.new_dirname ^= "", retv_input.new_dirname,
	     retv_input.new_dirname ^= ">", retv_input.new_ename);
	if osl > 1 then
	  call ioa_ ("options: ^a", options_string);
	if ^list & step then do;
reread1:	    call ioa_$nnl ("command:  ");
	    call iox_$get_line (iox_$user_input, addr (line), length (line), nelemt, code);
	    if code ^= 0 then do;
	        call retv_report_$error_output (code, myname, "Command read error");
	        goto reread1;
	      end;
	    line = substr (line, 1, nelemt - 1);
	    if line = "quit" | line = "q" then goto finish;
	    else if line = "skip" | line = "s" then do;
	        retv_input.skip_it = "1"b;
	        call update_queue_message;
	      end;
	    else if line = "cancel" | line = "c" then do;
	        if ^retv_input.proxy then
		call delete_queue_message (user, retv_input.user_ms_id);
	        call delete_queue_message (retriever, mseg_return_args.ms_id);
	      end;
	    else if line = "proceed" | line = "p" then do;
	        retv_input.skip_it = "0"b;
	        call update_queue_message;
	      end;
	    else if line = "help" | line = "h" then do;
	        call ioa_ ("Allowable commands are quit(q)^/skip(s)^/cancel(c)^/proceed(p)^/help(h)");
	        goto reread1;
	      end;
	    else do;
	        call ioa_ ("Unrecognized command: ^a", line);
	        goto reread1;
	      end;
	  end;
	call read_incremental_queue_message (retriever);
        end;
        if list then goto finish;			/* go to the next q				*/
      end;
						/* create retriever's private queue if necessary */
    else do;
        if list then goto finale;
        call message_segment_$create (wdir, "volume_retriever.ms", code);
        if code ^= 0 then do;
	  call retv_report_$error_output (code, myname,
	       "Unable to create private queue ^a>volume_retriever.ms", wdir);
	  goto finish;
	end;
        call message_segment_$open (wdir, "volume_retriever.ms", retv_data_.qidx (retriever), code);
        if code ^= 0 then do;
	  call retv_report_$error_output (code, myname,
	       "Unable to open private queue ^a>volume_retriever.ms", wdir);
	  goto finish;
	end;
      end;

/* Read each request from user queue. If the request is not valid then delete it. If the caller
   wants to review  each request before processing then   display each request . */

user_queue:
    call read_queue_message (user);
    do while (more_messages);
      requestp = mseg_return_args.ms_ptr;
      if retv_request.version ^= retv_request_version_2 then do;
	call retv_report_$error_output (0, myname,
	     "Invalid version of retrieval request encountered and deleted");
	call delete_queue_message (user, mseg_return_args.ms_id);
	goto next;
        end;
      if step then do;
	call ioa_ ("ID: ^a Retrieval request of ^a^[>^]^a for ^a",
	     substr (request_id_ (retv_request.msg_time), 7, 8),
	     retv_request.dirname, retv_request.dirname ^= ">",
	     retv_request.ename, mseg_return_args.sender_id);
	call ioa_$rsnnl (
	     "^[-subtree ^]^[-notify ^]^[-previous ^]^[-to ^a ^;^s ^]^[-from ^a ^;^s^]^[-new path ^a^[->^]^a^;^s^]",
	     options_string, osl,
	     retv_request.subtree, retv_request.notify, retv_request.previous,
	     retv_request.to_time ^= 0 & ^retv_request.previous,
	     time_ (retv_request.to_time), retv_request.from_time ^= 0,
	     time_ (retv_request.from_time), retv_request.new_dirname ^= "", retv_request.new_dirname,
	     retv_request.new_dirname ^= ">", retv_request.new_ename);
	if osl > 1 then call ioa_ ("options: ^a", options_string);
reread:	call ioa_$nnl ("command:  ");
	call iox_$get_line (iox_$user_input, addr (line), length (line), nelemt, code);
	if code ^= 0 then do;
	    call retv_report_$error_output (code, myname, "Command read error");
	    goto reread;
	  end;
	line = substr (line, 1, nelemt - 1);
	if line = "quit" | line = "q" then goto finish;
	else if line = "skip" | line = "s" then goto next;
	else if line = "cancel" | line = "c" then do;
	    call delete_queue_message (user, mseg_return_args.ms_id);
	    goto next;
	  end;
	else if line = "proceed" | line = "p" then ;
	else if line = "help" | line = "h" then do;
	    call ioa_ ("Allowable commands are quit (q)^/skip (s)^/cancel (c)^/proceed (p)^/help (h)");
	    goto reread;
	  end;
	else do;
	    call ioa_ ("Unrecognized command: ^a", line);
	    goto reread;
	  end;
        end;
      unspec (local_retv_input) = "0"b;
      local_retv_input.request = retv_request;
      local_retv_input.user_ms_id = mseg_return_args.ms_id;
      local_retv_input.access_class = mseg_return_args.sender_authorization;
      local_retv_input.level = mseg_return_args.level;
      local_retv_input.q_num = retv_data_.queue;
      local_retv_input.requestor = mseg_return_args.sender_id;
      local_retv_input.submission_time = fixed (mseg_return_args.ms_id, 71);
      call message_segment_$add_index (retv_data_.qidx (retriever), addr (local_retv_input),
	 size (local_retv_input) * 36, retv_ms_id, code);
      if code ^= 0 then
        call retv_report_$error_output (code, myname,
	   "Unable to add to private queue ^a>volume_retriever.ms", wdir);
next:
      call read_incremental_queue_message (user);
    end;


/* This is the main recovery loop. Each dump volume that has a volume control seg is read
   After each dump volume is read the private queue is scanned
   to check for any requests that may have been satisified. If one is found then a check is made to see  if all
   is well. This check is necessary since the retrieval of an entry may make a whole subtree accessible. If
   all is well then the request is marked as completed in the private queue. If a subtree retrieval was requested
   then  the subtree is scanned.
*/

recovery_loop:

/* Loop through the queue setting the in_progress flag. This flag will be used latter to determine if a
   request has not been satisfied */

    call read_queue_message (retriever);
    do while (more_messages);
      inputp = mseg_return_args.ms_ptr;
      if ^retv_input.skip_it then do;
	retv_input.retv_ms_id = mseg_return_args.ms_id;
	call retv_vol_control_ (inputp, code);
	if code ^= 0 then
	  retv_input.errcode = code;
	retv_input.in_progress = "1"b;
	call update_queue_message;
        end;
      call read_incremental_queue_message (retriever);
    end;
						/* if any dump volumes - setup accounting */
    if retv_data_.nvol > 0 & retv_data_.accounting then do;
        call retv_account_$create (code);
        if code ^= 0 then do;
	  call retv_report_$error_output (code, myname, "Accounting error");
	  goto finish;
	end;
      end;
    do rvcx = 1 to retv_data_.nvol;			/* sort the control seg */
      call retv_vol_control_$sort (retv_data_.rvcp (rvcx), code);
    end;
    do rvcx = 1 to retv_data_.nvol;			/* scan the volumes */
      rvcp = retv_data_.rvcp (rvcx);
      call retrieve_from_volume_ (rvcp, code);
      if code ^= 0 then do;
	if code = -1 then
	  call ioa_ ("Volume ^a in use - it will be skipped", retv_vol_control.volname);
	else if code = error_table_$resource_unavailable then do;
	    query_info.version = query_info_version_5;
	    call command_query_ (addr (query_info), answer, myname, "^/^a^/^a",
	         "The physical drive or dump volume is not available or is in use by another process.",
	         "Do you wish to continue the retrieval ");
	    if answer = "no" then goto finish;
	  end;
	else call retv_report_$error_output (code, myname, "Error processing volume ^a",
		retv_vol_control.volname);
        end;
      call read_queue_message (retriever);
      do while (more_messages);
        inputp = mseg_return_args.ms_ptr;
        if retv_input.object_recovered | retv_input.entry_recovered | retv_input.errcode ^= 0 then do;
	  if retv_input.errcode = 0 then do;
	      if retv_input.new_dirname ^= "" then	/* cross-retrieval */
	        call hc_backup_$retv_check (retv_input.new_dirname, retv_input.new_ename, type, dtm, code);
	      else call hc_backup_$retv_check (retv_input.dirname, retv_input.ename, type, dtm, code);
	      if code ^= 0 & code ^= error_table_$vtoce_connection_fail then
	        call retv_report_$error_output (code, myname, "Request check failed for ^[^a^[>^]^a^3s^;^3s^a^[>^]^a^]",
		   (retv_input.new_dirname = ""), retv_input.dirname, retv_input.dirname ^= ">", retv_input.ename,
		   retv_input.new_dirname, retv_input.new_dirname ^= ">", retv_input.new_ename);
	      if code = 0 then do;
		if retv_input.subtree & type = DIR then do;
		    to_from = (retv_input.to_time ^= 0) | (retv_input.from_time ^= 0);
		    call scan_sub_tree (retv_input.dirname, retv_input.ename,
		         to_from, ignore);
		  end;
		if retv_input.entry_retrieval then do;
		    call ioa_$rsnnl ("Recovery of object ^a^[>^]^a not necessary as object already there",
		         message, message_len, retv_input.dirname, retv_input.dirname ^= ">",
		         retv_input.ename);
		    call retv_notify_ (message, inputp, myname);
		  end;
		if ^retv_input.proxy then
		  call delete_queue_message (user, retv_input.user_ms_id);
		call delete_queue_message (retriever, retv_input.retv_ms_id);
		if retv_data_.accounting then call retv_account_$update (retv_input.requestor);
	        end;
	    end;

/* Having completed a request we now scan all other volume control segments for the same
   request and delete it if we find it. We must take care to delete the right request since more then one request may
   exist for the same object.
*/

	  do sortx = 1 to retv_data_.nvol;
	    rvcp = retv_data_.rvcp (sortx);
	    do sorty = 1 to retv_vol_control.n_entries;
	      rvcep = addr (retv_vol_control.array (sorty));
	      if rvce.in_use
		 & (rvce.uid = retv_input.uid)
		 & (rvce.retv_ms_id = retv_input.retv_ms_id) then do;
		retv_vol_control.in_use_cnt = retv_vol_control.in_use_cnt - 1;
		rvce.in_use = "0"b;
	        end;
	    end;
	  end;
	end;
        call read_incremental_queue_message (retriever);
      end;
    end;

/* When we get here all the requests that were queued in volume control segments have been processed for
   better or for worse. When a request is looked for on a dump volume the in_progress switch is set. If nothing
   is found then a message is reported to the operator, and if requested to the requestor. Then the request is deleted
   from the private queue, and the user queue. Note that proxy requests, because they are issued by the retriever
   do not exist in the user queue.
*/

    call read_queue_message (retriever);
    do while (more_messages);
      inputp = mseg_return_args.ms_ptr;
      if retv_input.in_progress & (^retv_input.object_recovered & ^retv_input.entry_recovered) then do;
	if retv_input.errcode ^= -1 then do;
	    call hc_backup_$retv_check (retv_input.dirname, retv_input.ename, type, dtm, code);
	    if code = 0 then do;
	        call ioa_$rsnnl ("Recovery of object ^a^[>^]^a not necessary as already there",
		   message, message_len, retv_input.dirname, retv_input.dirname ^= ">",
		   retv_input.ename);
	      end;
	    else do;
	        if retv_input.errcode = 0 then long = "object not found on dump media";
	        else call convert_status_code_ (retv_input.errcode, short, long);
	        call ioa_$rsnnl ("Failed to recover ^a^[>^]^a for ^a because ^a", message, message_len,
		   retv_input.dirname, retv_input.dirname ^= ">", retv_input.ename,
		   retv_input.requestor, long);
	      end;
	    call retv_notify_ (message, inputp, myname);
	  end;
	if ^retv_input.proxy then
	  call delete_queue_message (user, retv_input.user_ms_id);
	call delete_queue_message (retriever, retv_input.retv_ms_id);
        end;
      call read_incremental_queue_message (retriever);
    end;


/* delete the volume control segs */

    do nvolx = 1 to retv_data_.nvol;
      rvcp = retv_data_.rvcp (nvolx);
      if rvcp ^= null then do;
	call hcs_$delentry_seg (rvcp, code);
	if code ^= 0 then
	  call retv_report_$error_output (code, myname,
	       "Unable to delete control seg ^a.control", retv_vol_control.volname);
        end;
    end;
    retv_data_.rvcp (*) = null;
    retv_data_.nvol = 0;

/* Now go through the private queue once more to see if any requests remain. If one does reset
   some control flags. Then go back to the main recovery loop */


    more_to_do = "0"b;
    call read_queue_message (retriever);
    do while (more_messages);
      inputp = mseg_return_args.ms_ptr;
      if ^retv_input.skip_it then do;
	retv_input.uid = "0"b;
	retv_input.volid = "0"b;
	retv_input.entry_retrieval = "0"b;
	retv_input.in_progress = "0"b;
	retv_input.entry_name = "";
	retv_input.entry_recovered = "0"b;
	retv_input.object_recovered = "0"b;
	retv_input.errcode = 0;
	call update_queue_message;
	more_to_do = "1"b;
        end;
      call read_incremental_queue_message (retriever);
    end;
    if more_to_do then goto recovery_loop;
    else do;
        call message_segment_$delete (wdir, "volume_retriever.ms", code);
        retv_data_.qidx (retriever) = 0;		/* so it can be reused later			*/
        if code ^= 0 then call retv_report_$error_output (code, myname,
	     "Unable to delete private queue ^a>volume_retriever.ms", wdir);
      end;
finish:
    if retv_data_.queue ^= max_q_num & retv_data_.all then do;
        retv_data_.queue = retv_data_.queue + 1;
        goto start;
      end;
finale:
    call clean_it_up;
    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

queue_seg_: proc returns (char (32));

/* This proc constructs the user queue segment name and returns it */

    call ioa_$rsnnl ("volume_retriever_^d.ms", queue_name, (0), retv_data_.queue);
    return (queue_name);
  end queue_seg_;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

read_queue_message: proc (idx);
dcl idx		     fixed bin;

/* This proc reads the first message from the specified queue.  */

    more_messages = "1"b;
read: call message_segment_$read_index (retv_data_.qidx (idx), retv_data_.areap, "0"b, ms_arg_ptr,
         code);
    if code ^= 0 then do;
        if code = error_table_$no_message then more_messages = "0"b;
        else if code = error_table_$bad_segment then do;
	  call retv_report_$error_output (0, myname, "^[Private^;User^] queue has been salvaged",
	       idx = retriever);
	  goto read;
	end;
        else do;
	  call retv_report_$error_output (code, myname, "^[Private^;User^] queue read failed",
	       retriever = idx);
	  goto finish;
	end;
      end;

  end read_queue_message;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

update_queue_message: proc;

/* This proc updates a specified message in the private queue.
*/

reupdate: call message_segment_$update_message_index (retv_data_.qidx (retriever), size (retv_input) * 36,
         mseg_return_args.ms_id, inputp, code);
    if code ^= 0 then do;
        if code = error_table_$bad_segment then do;
	  call retv_report_$error_output (0, myname, "Private retriever queue ^a>volume_retriever.ms has been salvaged", wdir);
	  goto reupdate;
	end;
        else call retv_report_$error_output (code, myname, "Private queue ^a>volume_retriever.ms update failed", wdir);
      end;
  end update_queue_message;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

read_incremental_queue_message: proc (idx);
dcl idx		     fixed bin;

/* This proc reads the next message from the specified queue.  */

    if idx = retriever then do;
        if inputp ^= null then free retv_input in (based_area);
        inputp = null;
      end;
    else do;
        if requestp ^= null then free retv_request in (based_area);
        requestp = null;

      end;
retry_inc: call message_segment_$incremental_read_index (retv_data_.qidx (idx), retv_data_.areap, "01"b,
         mseg_return_args.ms_id, ms_arg_ptr, code);
    if code ^= 0 then do;
        if code = error_table_$bad_segment then do;
	  call retv_report_$error_output (0, myname, "^[Private^;User^] queue has been salvaged",
	       idx = retriever);
	  goto retry_inc;
	end;
        else if code = error_table_$no_message then more_messages = "0"b;
        else do;
	  call retv_report_$error_output (code, myname, "^[Private^;User^] queue read failed",
	       retriever = idx);
	  goto finish;
	end;
      end;
  end read_incremental_queue_message;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

scan_sub_tree: proc (dn, en, force, ec);

/* This proc scans a directory and checks if each object in the directory is accessable. If not
   it submitts a proxy requests for the missing object. If any object
   encountered is a directory  then we recurse to
   the next level. This proc is used during subtree retrieval to check for what is missing at some level
   inferior to the subtree node and to issue the necessary request to get the object back.  In certain cases
   even if the object is there a request is submitted. An example of this is a general request to move an existant
   subtree back in time. */

dcl (dn, en)	     char (*) aligned;
dcl dtm		     bit (36);
dcl force		     bit (1);
dcl nlp		     ptr;
dcl pname		     char (168) aligned;
dcl ec		     fixed bin (35);
dcl (nlc, ndx, type)     fixed bin;
dcl names		     (1) char (32) aligned based (nlp);
    call ioa_$rsnnl ("^a^[>^]^a", pname, (0), dn, dn ^= ">", en);
    nlc = 0;
    ec = 0;
    call hc_backup_$retv_name_list (pname, retv_data_.areap, nlp, nlc, ec);
    if ec ^= 0 then do;
        call retv_report_$error_output (ec, myname, "Unable to list names of ^a",
	   pname);
        return;
      end;
    do ndx = 1 to nlc;
      ec = 0;
      call hc_backup_$retv_check (pname, names (ndx), type, dtm, ec);
      if ec ^= 0 & ec ^= error_table_$vtoce_connection_fail then
        call retv_report_$error_output (ec, myname, "Subtree check failed for ^a>^a",
	   pname, names (ndx));
      if ((ec = error_table_$vtoce_connection_fail) | force) & type ^= LINK then do;
	call submit_request (pname, names (ndx), type);
        end;
      if ec = 0 & type = DIR then
        call scan_sub_tree (pname, names (ndx), force, ec);
    end;
    free names in (based_area);
  end scan_sub_tree;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

submit_request: proc (dn, en, type);

/* This proc makes up a proxy request. A proxy request occurs when the retriever, during a subtree request,
   discovers something missing. The proxy request, while submitted by the retriever, preserves the requestor's
   access_class, validation level, etc. It differs from the normal request in that it does not have
   a specific request in the user's queue. */

dcl (dn, en)	     char (*) aligned;
dcl type		     fixed bin;
    unspec (local_retv_input) = "0"b;
    local_retv_input.request = retv_input.request;
    local_retv_input.dirname = dn;
    local_retv_input.ename = en;
    local_retv_input.user_ms_id = retv_input.user_ms_id;
    local_retv_input.access_class = retv_input.access_class;
    local_retv_input.level = retv_input.level;
    local_retv_input.q_num = retv_input.q_num;
    local_retv_input.requestor = retv_input.requestor;
    local_retv_input.proxy = "1"b;
    local_retv_input.submission_time = fixed (mseg_return_args.ms_id, 71);
    call message_segment_$add_index (retv_data_.qidx (retriever), addr (local_retv_input),
         size (retv_input) * 36, retv_ms_id, code);
    if code ^= 0 then call retv_report_$error_output (code, myname, "Proxy update error");
    else if retv_data_.long then call retv_report_$online_output (0,
	 myname, "Proxy submission of ^[directory^;segment^] ^a^[>^]^a", type = DIR, dn, (dn ^= ">"), en);
  end submit_request;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


delete_queue_message: proc (idx, msid);
dcl idx		     fixed bin;
dcl msid		     bit (72) aligned;

/* This proc deletes the specified message just read from the specified queue */

    call message_segment_$delete_index (retv_data_.qidx (idx), msid, code);
    if code ^= 0 then
      call retv_report_$error_output (code, myname, "^[Private^;User^] queue delete failed",
	 retriever = idx);
  end delete_queue_message;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

time_: proc (bin_time) returns (char (24));

/* This proc converts a binary time into a suitable prinable form and returns it. */

dcl bin_time	     fixed bin (71);
dcl time_string	     char (24);
    call date_time_ (bin_time, time_string);
    return (time_string);
  end time_;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

clean_it_up: proc;

/* This proc cleans up and frees whats ever left around */

    if requestp ^= null then free retv_request in (based_area);
    if inputp ^= null then free retv_input in (based_area);
    if tp (1) ^= null then do;
        call hcs_$truncate_seg (retv_data_.objectp, 0, ignore); /* clean up our 256K seg */
        call hcs_$set_max_length_seg (retv_data_.objectp, (sys_info$max_seg_size), ignore); /* be a good neighbour */
        call hcs_$truncate_seg (retv_data_.input_buffer_ptr, 0, ignore); /* clean up our 256K seg */
        call hcs_$set_max_length_seg (retv_data_.input_buffer_ptr, (sys_info$max_seg_size), ignore); /* be a good neighbour */
        call hcs_$truncate_seg (retv_data_.page_buffer_ptr, 0, ignore); /* clean up our 256K seg */
        call hcs_$set_max_length_seg (retv_data_.page_buffer_ptr, (sys_info$max_seg_size), ignore); /* be a good neighbour */

        call release_temp_segments_ (myname, tp, ignore);
      end;
    if retv_data_.error_iocbp ^= null then do;
        call iox_$close (retv_data_.error_iocbp, ignore);
        call iox_$detach_iocb (retv_data_.error_iocbp, ignore);
      end;
    if retv_data_.input_iocbp ^= null then do;
        call iox_$close (retv_data_.input_iocbp, ignore);
        call iox_$detach_iocb (retv_data_.input_iocbp, ignore);
      end;
    do nvolx = 1 to retv_data_.nvol;
      call hcs_$delentry_seg (retv_data_.rvcp (nvolx), ignore);
    end;
    do qx = 1 to hbound (retv_data_.qidx, 1);
      call message_segment_$close (retv_data_.qidx (qx), ignore);
    end;
    call hcs_$set_256K_switch (old_256K_switch, (""b), ignore);
    on linkage_error goto end_clean_it_up;
    call system_privilege_$ring1_priv_off (ignore);
    call system_privilege_$ipc_priv_off (ignore);
end_clean_it_up:
    recursive_invocation = "0"b;

  end clean_it_up;

%include retv_data_;
%include retv_request;
%include retv_input;
%include mseg_return_args;
%include retv_vol_control;
%include queue_msg_hdr;
%include query_info;
%include iox_dcls;

  end retriever;




		    retv_account_.pl1               10/17/88  1530.8r w 10/17/88  1428.0       28305



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


retv_account_: proc;

/* This routine provides all the accounting functions for the volume retriever.  It creates and initializes the
   account segment in the directory >system_control_1>volume_backup_accounts with a time stamp name. For each object that the
   retriever recovers, the requestors name is entered into the account segment, if not already there, and the
   objects recovered count is incremented by one. A test entry is provided to bypass the system directory. */

dcl  test_dir char (*);
dcl  ename char (32) aligned;
dcl  code fixed bin (35);
dcl  enl fixed bin;
dcl  time_string char (15) aligned;
dcl  i fixed bin;
dcl  found bit (1);
dcl  requestor char (*);

dcl  myname char (32) int static init ("retv_account_") options (constant);

dcl  retv_report_$error_output entry options (variable);
dcl  get_wdir_ entry returns (char (168) aligned);
dcl  date_time_ entry (fixed bin (71), char (*) aligned);
dcl  ioa_$rsnnl entry options (variable);
dcl  hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35));

dcl (addr, substr, clock) builtin;

%include retv_data_;
%include retv_account_seg;

create:	entry (code);

/* This entry creates an retrieval account seg with a time stamp name, initializes it and sets the
   static ptr to it. */

	code = 0;
	call date_time_ (clock (), time_string);
	call ioa_$rsnnl ("^a.^a.^a", ename, enl, "retv_account", substr (time_string, 1, 8), substr (time_string, 11, 4));
	call hcs_$make_seg (retv_account_dir, ename, "", 01011b, rasp, code);
	if code ^= 0 then do;
	     call retv_report_$error_output (code, myname, "Unable to create ^a>^a", retv_account_dir, ename);
	     return;
	end;
	retv_account_seg.version = retv_account_seg_version_1;
	retv_data_.rasp = rasp;
	return;

update:	entry (requestor);

/* This entry adds the requestors name to the next empty slot in the accounting table, if not already in the table,
   and incremets the count of objects recovered. */

	rasp = retv_data_.rasp;
	found = "0"b;
	do i = 1 to retv_account_seg.next while (^found);
	     rasep = addr (retv_account_seg.array (i));
	     if rase.requestor = requestor then do;
		found = "1"b;
		rase.n_objects = rase.n_objects + 1;
	     end;
	end;
	if ^found then do;
	     retv_account_seg.next = retv_account_seg.next + 1;
	     rasep = addr (retv_account_seg.array (i));
	     rase.requestor = requestor;
	     rase.n_objects = 1;
	end;
	return;

test:	entry (test_dir);

/* This entry allows testing by resetting the directory in which the account seg is created */

	retv_account_dir = test_dir;
	return;

     end retv_account_;




		    retv_notify_.pl1                11/17/82  1640.9rew 11/17/82  1626.4       20376



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


retv_notify_: proc (message, inputp, myname);

/* This proc prints informative messages and notifies the user if requested */

dcl  message char (*);
dcl  myname char (*);
dcl  new_message char (256);
dcl  code fixed bin (35);
dcl  ignore fixed bin(35);

dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  retv_report_$error_output entry options (variable);
dcl  request_id_ entry (fixed bin (71)) returns (char (19));
dcl  send_message_$notify_mail entry (char (*), char (*), fixed bin (35));
dcl  send_mail_$access_class entry (char (*), char (*), ptr, bit (72) aligned, fixed bin (35));

dcl (addr, substr, after, reverse) builtin;

%include retv_input;
%include retv_request;
%include send_mail_info;
%include queue_msg_hdr;

	send_mail_info.version = send_mail_info_version_2;
	send_mail_info.sent_from = "Volume Retriever";
	send_mail_info.wakeup = "0"b;
	send_mail_info.always_add = "1"b;
	send_mail_info.never_add = "0"b;
	send_mail_info.acknowledge = "0"b;
	call ioa_ ("^a", message);
	if retv_input.notify then do;
	     call ioa_$rsnnl ("ID: ^a ^a", new_message, (0), substr (request_id_ (retv_input.msg_time), 7, 8),
		message);
	     call send_mail_$access_class (mail_destination_ (), new_message,
		addr (send_mail_info), retv_input.access_class, code);
	     if code ^= 0 then
		call retv_report_$error_output (code, myname, "Unable to notify ^a",
		mail_destination_ ());
	     call send_message_$notify_mail (mail_destination_ (), "", ignore);
	end;

mail_destination_: proc returns (char (32));

/* This proc constructs the mail/send_message  destination from the requestor's name */

	     return (reverse (after (reverse (retv_input.requestor), ".")));
	end mail_destination_;
     end retv_notify_;




		    retv_report_.pl1                10/17/88  1530.8r w 10/17/88  1428.0       35829



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

retv_report_: proc;

/* This routine is used by the volume retriever to report and log error and status
   messages. It is modled after the system routine com_err_. When called for the first time in a volume retriever
   invocation, it creates, in the working directory, an error file, in which it logs all error and status messages.
   If requested it also writes error messages on the stream error_output. */

dcl  code fixed bin (35);
dcl  icode fixed bin (35);
dcl  tstring char (24);
dcl  uname char (32);
dcl  caller char (*);
dcl  message char (*);
dcl  argp ptr;
dcl  retv_string char (512);
dcl  control_string char (32) aligned;
dcl  len fixed bin;
dcl  error_output bit (1);
dcl  short char (8) aligned;
dcl  long char (100) aligned;

dcl  myname char (15) static init ("retv_report_") options (constant);

dcl  iox_$error_output ptr ext;

dcl  date_time_ entry (fixed bin (71), char (*));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned);
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35));
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  ioa_$ioa_switch entry options (variable);
dcl  retv_report_$online_output entry options (variable);

dcl  null builtin;
dcl  clock builtin;
dcl  substr builtin;

%include retv_data_;
%include iox_modes;

error_output: entry (icode, caller, message);

/* If an error file is not attached then fabricate a name with a data/time stamp, attach and open it. If
   successsful then report via online mechanism. */

	if retv_data_.disable_error_report then return;
	error_output = "1"b;

	if retv_data_.error_iocbp = null then do;	/* error file not attached */

	     call date_time_ (clock, tstring);
	     uname = "retv_err." || substr (tstring, 1, 8)||"."|| substr (tstring, 11, 4);
	     call iox_$attach_ioname ("error_file", retv_data_.error_iocbp, "vfile_ " || uname, code);
	     if code ^= 0 then do;
		call retv_report_$online_output (code, myname, "Unable to attach error file");
		return;
	     end;
	     call iox_$open (retv_data_.error_iocbp, Stream_output, ""b, code);
	     if code ^= 0 then do;
		call retv_report_$online_output (code, myname, "Error opening error file");
		return;
	     end;
	     call retv_report_$online_output (0, myname, "Error file ^a created", uname);
	end;

common:
						/* If given a non-zero code convert to a message */
	if icode ^= 0 then do;
	     call convert_status_code_ (icode, short, long);
	     control_string = "^a:^x^a;^x^a";
	end;
	else do;
	     short, long = "";
	     control_string = "^a:^x^a^s";
	end;
						/* pick up arg list ptr */
	call cu_$arg_list_ptr (argp);
						/* convert args to message */
	call ioa_$general_rs (argp, 3, 4, retv_string, len, "0"b, "0"b);
	if error_output then			/* write to file if specified */
	     call ioa_$ioa_switch (retv_data_.error_iocbp, control_string, caller, substr (retv_string, 1, len), long);


/* Write online if requested, if args not initialized yet, or if online entry */

	if (error_output & retv_data_.err_online) | ^error_output | ^retv_data_.arg_init then
	     call ioa_$ioa_switch (iox_$error_output, control_string, caller, substr (retv_string, 1, len), long);

	return;

online_output: entry (icode, caller, message);

	error_output = "0"b;
	goto common;

     end retv_report_;




		    retv_vol_control_.pl1           10/10/89  1423.0rew 10/10/89  1355.3      371394



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


/****^  HISTORY COMMENTS:
  1) change(89-08-31,GWMay), approve(89-10-03,MCR8135),
     audit(89-10-04,Beattie), install(89-10-10,MR12.3-1089):
     Updated to process version 3 of backup_volume_log.incl.pl1 structures.
                                                   END HISTORY COMMENTS */


/* format: style1,ind2,^inddcls,ifthenstmt,dclind2,declareind2,ifthendo,ifthen*/

retv_vol_control_: proc (inputp, code);

/*
   This routine computes the set of volumes that a retrieval request might be
   found on and then creates, if not already existent, the retriever_volume_control segment
   for that volume and adds an entry to it for the retrieval request. If the object
   does not have a branch in the hierarchy then the parent tree is searched until a existant
   superior directory is found. This directory is then recovered and the branch structure is appended.
*/
/* Modified 6/79 by D. Vinograd to add directory name space searching from files created by volume dumper.
   This feature means that if the directory name space file is available then one can check if an entry name
   is in the directory dumped on tape and thus not have to read the tape during branch retrieval.
  Modified: 8/83 by GA Texada to
	     1) not look in the volume logs when -manual has been specified.
	     2) announce only once that a volume may be searched when contents seg is missing.
	     3) Reformatted and moved the %include's too.
*/
dcl answer	     char (3) var;
dcl a_rvcp	     ptr;
dcl message	     char (256);
dcl char_num	     char (32);
dcl code		     fixed bin (35);
dcl comp_cycle_uid	     bit (36);
dcl found		     bit (1);
dcl comp_indx	     fixed bin;
dcl comp_open_time	     fixed bin (71);
dcl cons_cycle_uid	     bit (36);
dcl cons_indx	     fixed bin;
dcl cons_open_time	     fixed bin (71);
dcl contents_idx	     fixed bin;
dcl control_name	     char (32);
dcl dirname	     char (168);
dcl done		     bit (1);
dcl emode		     bit (36);
dcl ename		     char (32);
dcl entry_name	     char (32);
dcl entry_retrieval	     bit (1);
dcl rvlx		     fixed bin;
dcl idx		     fixed bin;
dcl lns		     fixed bin;
dcl logged	     bit (1);
dcl test_name	     char (32);
dcl ignore	     fixed bin (35);
dcl incr_indx	     fixed bin;
dcl incr_close_time	     fixed bin (71);
dcl cons_close_time	     fixed bin (71);
dcl comp_close_time	     fixed bin (71);
dcl incr_open_time	     fixed bin (71);
dcl latest_indx	     fixed bin;
dcl link_retrieval	     bit (1);
dcl lock		     bit (1);
dcl lsearch_name	     char (32);
dcl ncp		     ptr;
dcl nelemt	     fixed bin;
dcl no_contents_seg	     bit (1);
dcl num		     fixed bin;
dcl object_retrieval     bit (1);
dcl old_dirname	     char (168);
dcl open_time	     fixed bin (71);
dcl parent_check	     bit (1);
dcl pmode		     bit (36);
dcl psearch_name	     char (32);
dcl pvid		     bit (36);
dcl recursion_level	     fixed bin;
dcl search_name	     char (32);
dcl sortx		     fixed bin;
dcl sorty		     fixed bin;
dcl start_numeric	     fixed bin;
dcl type		     fixed bin;
dcl uid		     bit (36);
dcl vdtd		     bit (36) aligned;
dcl vlx		     fixed bin;
dcl volid		     bit (36);
dcl volname	     char (32);
dcl vtoce_derived_volname char (32);
dcl fcbp		     ptr;
dcl vtoce_volid	     (3) bit (36);
dcl dump_type	     fixed bin;
dcl nsp		     ptr;

dcl based_char_string    char (1048576) based (ptr (contents_namesp, backup_volume_contents.offset (contents_idx)));
dcl name_string	     based (nsp) char (lns);

dcl 1 local_rvce	     like rvce aligned;

dcl 1 volume_id	     aligned,
    2 char	     char (2) unaligned,
    2 num		     fixed bin unaligned;


dcl myname	     char (32) static init ("retv_vol_control_") options (constant);
dcl segment	     fixed bin int static init (1) options (constant);
dcl DIR		     fixed bin int static init (2) options (constant);
dcl LINK		     fixed bin int static init (3) options (constant);
dcl rw		     bit (3) int static init ("101"b) options (constant);
dcl sm		     bit (3) int static init ("110"b) options (constant);

dcl iox_$user_input	     ptr ext;
dcl error_table_$action_not_performed ext fixed bin (35);
dcl error_table_$segfault ext fixed bin (35);
dcl error_table_$bad_volid ext fixed bin (35);
dcl error_table_$locked_by_this_process ext fixed bin (35);
dcl error_table_$bad_segment ext fixed bin (35);
dcl error_table_$invalid_lock_reset ext fixed bin (35);

dcl retv_notify_	     entry (char (*), ptr, char (*));
dcl get_temp_segment_    entry (char (*), ptr, fixed bin (35));
dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl hcs_$fs_move_seg     entry (ptr, ptr, fixed bin (1), fixed bin (35));
dcl msf_manager_$close   entry (ptr);
dcl msf_manager_$open    entry (char (*), char (*), ptr, fixed bin (35));
dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin, fixed bin (35));
dcl suffixed_name_$make  entry (char (*), char (*), char (*), fixed bin (35));
dcl expand_pathname_     entry (char (*), char (*), char (*), fixed bin (35));
dcl ioa_		     entry options (variable);
dcl ioa_$nnl	     entry options (variable);
dcl iox_$get_line	     entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35));
dcl cv_dec_check_	     entry (char (*), fixed bin (35)) returns (fixed bin);
dcl command_query_	     entry options (variable);
dcl retv_report_$error_output entry options (variable);
dcl retv_report_$online_output entry options (variable);
dcl ioa_$rsnnl	     entry options (variable);
dcl message_segment_$update_message_index entry (fixed bin, fixed bin, bit (72) aligned, ptr, fixed bin (35));
dcl hcs_$make_seg	     entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl mdc_$find_volname    entry (bit (36), char (*), char (*), fixed bin (35));
dcl set_lock_$lock	     entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl set_lock_$unlock     entry (bit (36) aligned, fixed bin (35));
dcl hcs_$initiate	     entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl hc_backup_$retv_status entry (char (*), char (*), bit (72) aligned, char (*) aligned,
		     fixed bin, fixed bin, bit (36), bit (36), bit (36), bit (36),
		     (3) bit (36), bit (36) aligned, fixed bin (35));

dcl seg_fault_error	     condition;

dcl min		     builtin;
dcl hbound	     builtin;
dcl index		     builtin;
dcl ptr		     builtin;
dcl unspec	     builtin;
dcl null		     builtin;
dcl search	     builtin;
dcl max		     builtin;
dcl addr		     builtin;
dcl length	     builtin;
dcl size		     builtin;
dcl substr	     builtin;
dcl rtrim		     builtin;

/* initialize local variables to default values */
    code = 0;
    lock = "0"b;
    vtoce_derived_volname = "";
    entry_name = "";
    link_retrieval = "0"b;
    parent_check = "0"b;
    entry_retrieval = "0"b;
    object_retrieval = "0"b;
    vtoce_volid (*) = "0"b;
    uid = "0"b;
    vdtd = "0"b;
    emode = "0"b;
    pmode = "0"b;
    logged = "0"b;
    bvlp, rvcp, rvcep = null;
    contentsp, contents_namesp = null;
    recursion_level = 0;

/* pick up static ptrs */
    skip = retv_data_.skip;
    vlp = retv_data_.vlp;
						/* copy args from input structure */
    dirname = retv_input.dirname;
    ename = retv_input.ename;

/* Check to see if object in hierarchy. if so get what ever information we can about it. If not in the
   hierarcy then the uid will be zero */

status:
    call hc_backup_$retv_status (dirname, ename, retv_input.access_class, retv_input.requestor,
      retv_input.level, type, emode, pmode, uid, pvid, vtoce_volid, vdtd, code);

/* In cross retrieval case object must exist and must be a segment. Check that this is so */

    if retv_input.new_dirname ^= "" then do;
        if recursion_level ^= 0
	| uid = "0"b then do;
	  call ioa_$rsnnl ("Cannot locate ^a^[>^]^a for cross retrieval ", message, 0,
	    dirname, dirname ^= ">", ename);
	  call retv_notify_ (message, inputp, myname);
	  code = -1;
	  goto finish;
	end;
        if type ^= segment then do;
	  call ioa_$rsnnl ("Cross directory retrieval of ^a^[>^]^a not allowed", message, 0,
	    dirname, dirname ^= ">", ename);
	  call retv_notify_ (message, inputp, myname);
	  code = -1;
	  goto finish;
	end;
      end;

/* First check to see if requestor has the correct access.  Access must be sufficient to modify the object
   either directly or be able to set access at the parent level to do so. */

    if uid ^= "0"b & type ^= LINK then do;
        if type = segment & ((emode & rw) = rw | (pmode & sm) = sm) then goto access_ok;
        if (type = DIR | type = LINK) & ((emode & sm) = sm | (pmode & sm) = sm) then goto access_ok;
        call ioa_$rsnnl ("Incorrect access to retrieve ^a^[>^]^a", message, 0, dirname, dirname ^= ">", ename);
        code = -1;
        call retv_notify_ (message, inputp, myname);
        goto finish;
access_ok:
        if parent_check then entry_retrieval = "1"b;
        else object_retrieval = "1"b;

/* If dump information exists then determine the most recent volume id by back scanning the volume log for a match.
   The volume log is located by converting the object's pvid to name and initiating that name in the sub-system dir.
   If a time bracket has been specified then the found volume must fit within it. Save the volume name and id if found */

        if ^retv_data_.manual & (vtoce_volid (incr) ^= "0"b |
	vtoce_volid (cons) ^= "0"b |
	vtoce_volid (comp) ^= "0"b) then do;
	  call find_volume_log;
	  if bvlp = null then do;
no_volog:	      call retv_report_$error_output (code, myname, "Unable to locate ^a.volog", psearch_name);
	      goto finish;
	    end;
	  if ^lock then call lock_volume_log;
	  if code ^= 0 then do;
volog_lock_err: call retv_report_$error_output (code, myname, "Error locking ^a", psearch_name);
	      goto finish;
	    end;
	  lock = "1"b;

	  incr_open_time = 0;
	  cons_open_time = 0;
	  comp_open_time = 0;
	  incr_close_time = 0;
	  cons_close_time = 0;
	  comp_close_time = 0;
	  incr_indx, cons_indx, comp_indx = 0;

	  do idx = backup_volume_log.next to 1 by -1;
	    bvlep = addr (backup_volume_log.array (idx));
	    if vtoce_volid (incr) ^= "0"b & vtoce_volid (incr) = bvle.volid then do;
	        incr_open_time = bvle.open_time;
	        incr_close_time = bvle.close_time;
	        incr_indx = idx;
	      end;
	    else if vtoce_volid (cons) ^= "0"b & vtoce_volid (cons) = bvle.volid then do;
	        cons_open_time = bvle.open_time;
	        cons_close_time = bvle.close_time;
	        cons_indx = idx;
	      end;
	    else if vtoce_volid (comp) ^= "0"b & vtoce_volid (comp) = bvle.volid then do;
	        comp_open_time = bvle.open_time;
	        comp_close_time = bvle.close_time;
	        comp_indx = idx;
	      end;
	  end;

	  if retv_input.to_time ^= 0 then do;
	      if incr_open_time > retv_input.to_time then incr_indx = 0;
	      if cons_open_time > retv_input.to_time then cons_indx = 0;
	      if comp_open_time > retv_input.to_time then comp_indx = 0;
	    end;

	  if retv_input.from_time ^= 0 then do;
	      if incr_close_time < retv_input.from_time then incr_indx = 0;
	      if cons_close_time < retv_input.from_time then cons_indx = 0;
	      if comp_close_time < retv_input.from_time then comp_indx = 0;
	    end;

	  latest_indx = max (incr_indx, cons_indx, comp_indx);
	  if latest_indx ^= 0 then do;
	      bvlep = addr (backup_volume_log.array (latest_indx));
	      vtoce_derived_volname = bvle.volname;
	    end;

	end;

/* Now search the volume log as if there was no dump information, as well there might. Find the
   volume log, if not already found, lock it, and back scan it. If no time bracket is specified then we
   skip over incremental tapes that are superceeded by consolidated tape and consolidated tapes that are
   superceeded by complete dumps. If a time bracket is specified then we look at all the
   dump volumes in case the object was deleted prematurely. For each dump volume we find we add it to the
   volume list. Once the volume list is complete then try to save time by searching the contents seg for that
   volume if it is available. If it is and the object is not found in it then we
   can skip that dump volume. If the contents seg can not be found then the object is assumed to be on the
   dump volume. For each dump volume a search request is entered into the volume control segment.
   If this segemnt does not exist then it is created */

        if ^retv_data_.manual
	| (retv_data_.manual & recursion_level > 1) then do;
	  if bvlp = null then do;
	      call find_volume_log;
	      if bvlp = null then goto no_volog;
	    end;

	  if ^lock then do;
	      call lock_volume_log;
	      if code ^= 0 then goto volog_lock_err;
	    end;

	  lock = "1"b;
	  vlx = 0;
	  if retv_input.to_time = 0 & retv_input.from_time = 0 then do;
	      incr_open_time = 0;
	      cons_open_time = 0;
	      comp_open_time = 0;
	      cons_cycle_uid = "0"b;
	      comp_cycle_uid = "0"b;
	      do idx = backup_volume_log.next to 1 by -1;
	        bvlep = addr (backup_volume_log.array (idx));
	        if bvle.dump_type = incr then do;
		  if cons_open_time ^= 0 | comp_open_time ^= 0 then do;
		      if (cons_open_time ^= 0 & cons_open_time < bvle.close_time)
		        | (comp_open_time ^= 0 & comp_open_time < bvle.close_time)
		      then call update_volume_list;
		    end;
		  else do;
		      call update_volume_list;
		      incr_open_time = get_open_time ();
		    end;
		end;
	        else if bvle.dump_type = cons then do;
		  if comp_open_time ^= 0 then do;
		      if comp_open_time < bvle.close_time
		        | cons_cycle_uid = bvle.cycle_uid then call update_volume_list;
		    end;
		  else do;
		      call update_volume_list;
		      cons_open_time = get_open_time ();
		      cons_cycle_uid = bvle.cycle_uid;
		    end;
		end;
	        else if bvle.dump_type = comp then do;
		  if comp_cycle_uid ^= "0"b then do;
		      if comp_cycle_uid = bvle.cycle_uid then call update_volume_list;
		      comp_open_time = get_open_time ();
		    end;
		  else do;
		      comp_cycle_uid = bvle.cycle_uid;
		      comp_open_time = get_open_time ();
		      call update_volume_list;
		    end;
		end;
	      end;
	    end;
	  else do idx = backup_volume_log.next to 1 by -1;
	      bvlep = addr (backup_volume_log.array (idx));
	      call update_volume_list;
	    end;
	end;
        else do;
	  done = "0"b;
	  do vlx = 1 by 1 while (^done);
	    call get_volname;
	    retv_volume_list (vlx).open_time = 0;
	    if retv_volume_list (vlx).volname = "." then done = "1"b;
	    else retv_volume_list (vlx).use = "1"b;
	  end;
	  retv_volume_list.next = vlx - 2;
	end;
        do rvlx = 1 to retv_volume_list.next;
	if retv_volume_list (rvlx).use then do;
	    volname = retv_volume_list (rvlx).volname;
	    volid = retv_volume_list (rvlx).volid;
	    open_time = retv_volume_list (rvlx).open_time;
	    dump_type = retv_volume_list (rvlx).dump_type;
	    call find_contents_seg;
	    if contentsp = null then do;
	        no_contents_seg = "1"b;
	        if entry_retrieval
		| retv_input.to_time ^= 0
		| retv_input.from_time ^= 0
		| vtoce_derived_volname = volname
		| vtoce_derived_volname = "" then do;
		  call log_uid;
		  if ^(retv_volume_list (rvlx).announced) then do;
		      call retv_report_$online_output (0, myname,
		        "May search volume ^a because contents segment not available", volname);
		      retv_volume_list (rvlx).announced = "1"b;
		    end;
		end;
	      end;
	    else do;
	        call search_contents_seg (contents_idx, found);
	        if found then call log_uid;
	        call term_contents_segs;
	      end;
	  end;
        end;
      end;

/* We come here if an entry must be recovered, either because it does not already exist, or because the request
   is for a link.  If the entry does not exist then we reset dirname and ename to indicate that it is the
   parent directory that is wanted. */

    else do;
        recursion_level = recursion_level + 1;
        if type = LINK then link_retrieval = "1"b;
        parent_check = "1"b;
        entry_name = ename;
        old_dirname = dirname;
        call expand_pathname_ (old_dirname, dirname, ename, code);
        if code ^= 0 then do;
	  call ioa_$rsnnl ("Unable to expand ^a^[>^]^a", message, 0, retv_input.dirname,
	    retv_input.dirname ^= ">", retv_input.ename);
	  code = -1;
	  call retv_notify_ (message, inputp, myname);
	  goto finish;
	end;
        goto status;
      end;
finish:
    if code ^= 0 & code ^= -1 then do;
        call retv_report_$error_output (code, myname, "ERROR");
        code = 0;
      end;
    if ^logged & (code ^= -1) then do;
        call ioa_$rsnnl ("Online records indicate that ^a^[>^]^a^[>^a^;^s^] can not be found for^/retrieval of ^a^[>^]^a",
	message, (0), dirname, dirname ^= ">", ename, entry_name ^= "", entry_name, retv_input.dirname, retv_input.dirname ^= ">", retv_input.ename);
        call retv_notify_ (message, inputp, myname);
        code = -1;
      end;
    if lock then call unlock_volume_log;
    return;
sort: entry (a_rvcp, code);

/* This entry re sorts the entries in the control seg by the contents
   index. This index marks the relative position on the dump medium of each file.
   Thus sorting the entries allows the scan function in retrieve_from_volume_
   to operate a max efficiency.
*/
    rvcp = a_rvcp;
    code = 0;
    do sortx = 1 to retv_vol_control.n_entries;
      do sorty = 1 to retv_vol_control.n_entries;
        if retv_vol_control.array (sorty).in_use then do;
	  if retv_vol_control.array (sorty).contentsx < retv_vol_control.array (sortx).contentsx then do;
	      local_rvce = retv_vol_control.array (sortx);
	      retv_vol_control.array (sortx) = retv_vol_control.array (sorty);
	      retv_vol_control.array (sorty) = local_rvce;
	    end;
	end;
      end;
    end;
    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


update_volume_list: proc;
dcl (new_entry, use)     bit (1);
dcl (vlx, sortx)	     fixed bin;

/* This proc is called to add a dump volume to the volume list associated with some object.
   It is added to the list if it contains any segments or directories  from this volume and
   it is not already in the list or in the dont use list.
   If the dump volume was created with a different dim then the one that will
   be used to read it the operator is queried as to wheter he wants to use it.
   If not it is added to the don't   use list so the question is asked only once */

    if bvle.dir_num = 0 & bvle.seg_num = 0 then return;

    do sortx = 1 to retv_skip_list.next;
      if bvle.volname = retv_skip_list (sortx).volname then return; /* dont use it */
    end;
    do sortx = 1 to retv_volume_list.next while
      (retv_volume_list (sortx).volname ^= bvle.volname
      & retv_volume_list (sortx).volid ^= bvle.volid);	/* already in list */
    end;
    if sortx > retv_volume_list.next then do;		/* add or update to the list */
        vlx, retv_volume_list.next = retv_volume_list.next + 1;
        new_entry = "1"b;
      end;
    else do;
        new_entry = "0"b;
        vlx = sortx;
      end;
    use = "1"b;
    if retv_input.to_time ^= 0 & bvle.open_time > retv_input.to_time then use = "0"b;
    if bvle.open_time > retv_input.submission_time then use = "0"b;
    if retv_input.from_time ^= 0 & bvle.close_time < retv_input.from_time then use = "0"b;
    retv_volume_list (vlx).volname = bvle.volname;
    retv_volume_list (vlx).volid = bvle.volid;
    retv_volume_list (vlx).use = use | retv_volume_list (vlx).use;
    if new_entry then do;
        retv_volume_list (vlx).open_time = bvle.open_time;
        retv_volume_list (vlx).announced, retv_volume_list (vlx).unused = "0"b;
      end;
    else retv_volume_list (vlx).open_time = min (bvle.open_time, retv_volume_list (vlx).open_time);
    retv_volume_list (vlx).close_time = max (retv_volume_list (vlx).close_time, bvle.close_time);
    retv_volume_list (vlx).dump_type = bvle.dump_type;

    if bvle.io_module ^= retv_data_.io_module then do;
        query_info.version = query_info_version_5;
        call command_query_ (addr (query_info), answer, myname, "^a ^a ^a ^a^/^a",
	"io outer module", bvle.io_module, "which wrote volume", bvle.volname,
	"different than that specified to read volume. Do you wish to use the volume ?");
        if answer = "no" then do;
	  retv_volume_list (vlx).use = "0"b;
	  retv_skip_list.next = retv_skip_list.next + 1;
	  retv_skip_list (retv_skip_list.next).volname = bvle.volname;
	end;
      end;
    return;
  end update_volume_list;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


find_volume_log: proc;

/* This proc is called to located the volume log associated with an object. It does this by converting
   the physical volume id of the object to a physical volume name and searching for it in the
   sub-system directory. If the volume log is found a few validity checks are made also. */

    bvlp = null;
    psearch_name = "";
    call mdc_$find_volname (pvid, psearch_name, lsearch_name, code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Unable to convert pvid to pvname");
        return;
      end;
    call suffixed_name_$make (psearch_name, "volog", search_name, code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Unable to construct ^a.volog", psearch_name);
        return;
      end;
    on seg_fault_error begin;
        bvlp = null;
        code = error_table_$segfault;
        goto find_volume_log_ret;
      end;
    call hcs_$initiate ((retv_data_.sys_dir), search_name, "", 0, 0, bvlp, code);
    if bvlp ^= null then do;
        code = 0;
        if backup_volume_log.pvname = pvname
	& backup_volume_log.pvid = pvid
	& (backup_volume_log.version = backup_volume_log_version_1) |
	  (backup_volume_log.version = backup_volume_log_version_2) |
	  (backup_volume_log.version = backup_volume_log_version_3) then ;
        else do;
	  bvlp = null;
	  code = error_table_$bad_segment;
	  call retv_report_$error_output (code, myname, "Invalid volog ^a>^a found",
	    retv_data_.sys_dir, search_name);
	end;
      end;
find_volume_log_ret:
    if bvlp = null then call retv_report_$error_output (code, myname, "Unable to locate ^a>^a",
	 retv_data_.sys_dir, search_name);
    return;
  end find_volume_log;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


lock_volume_log: proc;

/* This proc locks the volume log.  It treats invalid lock ids and mylocks as recoverable errors. For all others
   it returns an error code and leaves the volume log unlocked */

    call set_lock_$lock (backup_volume_log.lock, -1, code);
    if code ^= 0 then if code = error_table_$invalid_lock_reset then code = 0;
    if code = error_table_$locked_by_this_process then do;
        call retv_report_$error_output (code, myname, "Volume log ^a", psearch_name);
        code = 0;
        call unlock_volume_log;
        call lock_volume_log;
      end;
    return;
  end lock_volume_log;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


unlock_volume_log: proc;

/* This proc unlocks the volume log. */

    call set_lock_$unlock (backup_volume_log.lock, ignore);
    return;
  end unlock_volume_log;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


create_control_seg: proc;
dcl (nvol_idx, insert_idx) fixed bin;

/* This proc is caled to create a volume control seg for some specified dump volume.
   The volume control seg is created in the process directory and a pointer to
   it is mainted in a static array. The order of pointers in the static array is very important for
   it determines the order in which the dump volumes will be read.  For this reason empty volume control
   segments may be created as place markers so that a time wise order is maintained. Once the volume
   control segment has been located and verified a set of checks is carried out to see if the object
   should be recovered(searched for) from this dump volume. If so an entry is made in the
   control segment and the queue entry is updated to reflect this.
*/

    rvcp = null;
    call suffixed_name_$make (volname, "control", control_name, code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Unable to construct ^a.control", volname);
        return;
      end;
    call hcs_$make_seg ("", control_name, "", 01010b, rvcp, code);
    if rvcp = null then do;
bad_seg: call retv_report_$error_output (code, myname,
	"Unable to create control seg ^a", control_name);
        return;
      end;
						/* new control seg */
    if code = 0 then do;
        retv_vol_control.version = retv_vol_control_version_1;
        retv_vol_control.volname = volname;
        retv_vol_control.volid = volid;
        retv_vol_control.open_time = open_time;
        retv_vol_control.dump_type = dump_type;
        do nvol_idx = 1 to retv_data_.nvol
	while (retv_data_.rvcp (nvol_idx) -> retv_vol_control.open_time > open_time);
        end;
        if nvol_idx > retv_data_.nvol then do;		/* no match */
	  if retv_data_.nvol = hbound (retv_data_.rvcp, 1) then do;
	      rvcp = null;
	      call retv_report_$error_output (0, myname, "Limit of ^d control segs exceeded.",
	        hbound (retv_data_.rvcp, 1));
	      code = error_table_$action_not_performed;
	      return;
	    end;
	  retv_data_.nvol = retv_data_.nvol + 1;
	  retv_data_.rvcp (retv_data_.nvol) = rvcp;
	end;
        else do;
	  insert_idx = nvol_idx;
	  do nvol_idx = retv_data_.nvol to insert_idx by -1;
	    retv_data_.rvcp (nvol_idx + 1) = retv_data_.rvcp (nvol_idx);
	  end;
	  retv_data_.rvcp (insert_idx) = rvcp;
	  retv_data_.nvol = retv_data_.nvol + 1;
	end;
      end;

    code = 0;
  end create_control_seg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


log_uid: proc;


/* This proc is called to insert a retrieval request in a specific control seg */

    call create_control_seg;
    if rvcp = null then goto finish;
    retv_vol_control.n_entries = retv_vol_control.n_entries + 1;
    retv_vol_control.in_use_cnt = retv_vol_control.in_use_cnt + 1;
    rvcep = addr (retv_vol_control.array (retv_vol_control.n_entries));
    rvce.in_use = "1"b;
    rvce.uid = uid;
    rvce.contentsx = contents_idx;
    rvce.vdtd = vdtd;
    rvce.dirname = dirname;
    rvce.ename = ename;
    rvce.entry_name = entry_name;
    rvce.to_time = retv_input.to_time;
    rvce.from_time = retv_input.from_time;
    rvce.queue = retv_data_.queue;
    rvce.retv_ms_id = retv_input.retv_ms_id;
    rvce.entry_retrieval = entry_retrieval;
    rvce.link_retrieval = link_retrieval;
    rvce.no_contents_seg = no_contents_seg;
    rvce.object_retrieval = object_retrieval;
    rvce.vtoce_volname = (vtoce_derived_volname ^= "");
    rvce.previous = retv_input.previous;
    if retv_input.uid = "0"b then do;
        retv_input.entry_name = rvce.entry_name;
        retv_input.entry_retrieval = entry_retrieval;
        retv_input.uid = rvce.uid;
        call update_queue_message;
      end;
    logged = "1"b;
    return;
  end log_uid;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


find_contents_seg: proc;

/* This proc locates the contents segment, if it exists, in the sub-system directory. If found it performs
   a few validity tests to be sure. The contents segment of a dump volume contains an array of uids,
   one for each object that was written on this volume */

    contentsp = null;
    call suffixed_name_$make (volname, "contents", search_name, code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Unable to construct ^a.contents", volname);
        return;
      end;
    call hcs_$initiate (rtrim (retv_data_.sys_dir) || ">contents", search_name, "", 0, 0, contentsp, code);
    on seg_fault_error begin;				/* it may not be there */
        contentsp = null;
        code = error_table_$segfault;
        goto find_contents_seg_ret;
      end;
    if contentsp ^= null then do;
        if backup_volume_contents.version ^= backup_volume_contents_version_3
        then call convert_contents_seg;
        if contentsp ^= null then do;
	  if (backup_volume_contents.volname = volname
	    & backup_volume_contents.volid = volid
	    & backup_volume_contents.version = backup_volume_contents_version_3) then return;
	  else do;
	      contentsp = null;
	      code = error_table_$bad_segment;
	      call retv_report_$error_output (code, myname, "Invalid contents seg ^a>contents>^a",
	        retv_data_.sys_dir, search_name);
	    end;
	end;
      end;
find_contents_seg_ret:
    if contentsp = null then
         call retv_report_$error_output (code, myname, "Unable to access ^a>contents>^a",
	 retv_data_.sys_dir, search_name);
    return;
  end find_contents_seg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


search_contents_seg: proc (contents_idx, found);
dcl (contents_idx, startx, endx) fixed bin;
dcl found		     bit (1);

/* This proc searchs the contents segment for a match. If one is found then
   a code of zero is returned */

    found = "0"b;
    do contents_idx = backup_volume_contents.next to 1 by -1;
      if backup_volume_contents.uid (contents_idx) = uid then do;
	if entry_retrieval & backup_volume_contents.offset (contents_idx) > 0 then do;
	    call find_contents_names_seg;
	    if contents_namesp ^= null then do;
	        nsp = addr (based_char_string);
	        lns = index (based_char_string, ">>") + 1;
	        if index (name_string, rtrim (entry_name)) ^= 0 then do;
		  startx = 1;
		  endx = index (name_string, ">");
		  do while (endx > 0);
		    test_name = substr (name_string, startx, endx - 1);
		    if test_name = entry_name then goto gotit;
		    startx = startx + endx;
		    endx = index (substr (name_string, startx), ">");
		  end;
		  if substr (name_string, startx, lns - startx - 1) = entry_name then goto gotit;
		end;
	      end;
	    call msf_manager_$close (fcbp);
	  end;
	else do;
gotit:	    found = "1"b;
	    return;
	  end;
        end;
    end;
    return;
  end search_contents_seg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


update_queue_message: proc;

/* This proc updates an existant message in the retrievers privite queue */

retry_update: call message_segment_$update_message_index (retv_data_.qidx (retriever), size (retv_input) * 36,
      retv_input.retv_ms_id, inputp, code);
    if code = error_table_$bad_segment then do;
        call retv_report_$error_output (code, myname, "Private queue has been salvaged");
        goto retry_update;
      end;
    if code ^= 0 then call retv_report_$error_output (code, myname, "Unable to update request in private queue");
  end update_queue_message;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


get_volname: proc;

/* This proc reads a dump volume name and converts it to a  volume id. Volume names are restricted to two or less
   acsii characters preceeding a numeric value(eg ic12345 is ok but qwqw01 is not). */

request: call ioa_$nnl ("Type retrieval volume name: ");	/* Make up request line. */
    call iox_$get_line (iox_$user_input, addr (retv_volume_list (vlx).volname),
      length (retv_volume_list (vlx).volname), nelemt, code);
    if code ^= 0 then do;
        call ioa_ ("input error");
        goto request;
      end;
    retv_volume_list (vlx).volname = substr (retv_volume_list (vlx).volname, 1, nelemt - 1); /* strip new line */
    if retv_volume_list (vlx).volname = "." then return;
    call set_volid_;
    if code ^= 0 then do;
        call ioa_ ("Invalid volume id ^a specified.", retv_volume_list (vlx).volname);
        goto request;
      end;
    return;
  end get_volname;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


set_volid_: proc;

/* This proc constructs a volume id from a volume name. This is a interim measure until all dump volume are registered
   and have a unique id. This construction restricts the volume name to two or less non numeric characters followed
   by any numeric value lest then 262144. */

/* when rcp_ interface is defined
   call rcp_$volname_info (retv_volume_list(vlx).volname, retv_volume_list(vlx).volid, code);
   if code ^= 0 then
   call retv_report_$error_output (code, myname, "Unable to set volid");

   but until then  fudge it */


    start_numeric = search (retv_volume_list (vlx).volname, "0123456789");
    if start_numeric > 3 | start_numeric = 0 then do;
bad_volid: code = error_table_$bad_volid;
        return;
      end;
    else do;
        if start_numeric > 1 then volume_id.char = substr (retv_volume_list (vlx).volname, 1, start_numeric - 1);
        else volume_id.char = "";
        char_num = substr (retv_volume_list (vlx).volname, start_numeric,
	length (retv_volume_list (vlx).volname) - start_numeric);
        num = cv_dec_check_ (char_num, code);
        if code ^= 0 then goto bad_volid;
        volume_id.num = num;
      end;
    retv_volume_list (vlx).volid = unspec (volume_id);
    return;
  end set_volid_;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


get_open_time: proc returns (fixed bin (71));
dcl temp		     fixed bin (71);
dcl jdx		     fixed bin;
    if bvle.dump_type = incr then return (bvle.open_time);
    do jdx = idx to 1 by -1;
      if backup_volume_log.array (jdx).cycle_uid = bvle.cycle_uid then
	 temp = backup_volume_log.array (jdx).open_time;
    end;
    return (temp);

  end get_open_time;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


find_contents_names_seg: proc;

/* This proc locates the contents_names segment, if it exists, in the sub-system directory.
   The contents_names segment of a dump volume contains the name space
   of the dirs dumped on the  dump volume. */

    contents_namesp = null;
    call suffixed_name_$make (volname, "contents_names", search_name, code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Unable to construct ^a.contents_name", volname);
        return;
      end;
    on seg_fault_error begin;				/* it may not be there */
        contents_namesp = null;
        goto find_contents_names_seg_ret;
      end;
    call msf_manager_$open (rtrim (retv_data_.sys_dir) || ">contents", search_name, fcbp, code);
    if code ^= 0 then do;
        call retv_report_$error_output (code, myname, "Unable to open ^a>contents>^a",
	retv_data_.sys_dir, search_name);
        return;
      end;
    call msf_manager_$get_ptr (fcbp, (backup_volume_contents.component (contents_idx)), "0"b,
      contents_namesp, 0, code);
    if code ^= 0 then
         call retv_report_$error_output (code, myname, "Unable to get ptr to component ^d of ^a>contents>^a",
	 backup_volume_contents.component (contents_idx), retv_data_.sys_dir, search_name);
find_contents_names_seg_ret:
    return;
  end find_contents_names_seg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


convert_contents_seg: proc;
dcl contents_idx	     fixed bin;
    call get_temp_segment_ (myname, ncp, code);
    if code ^= 0 then do;
        call retv_report_$online_output (code, myname, "Unable to get temp for contents seg conversion");
        contentsp = null;
        return;
      end;
    ncp -> backup_volume_contents.version = backup_volume_contents_version_3;
    if backup_volume_contents.version = 2 then do;
        ncp -> backup_volume_contents.volname = v2_backup_volume_contents.volname;
        ncp -> backup_volume_contents.volid = v2_backup_volume_contents.volid;
        ncp -> backup_volume_contents.next = v2_backup_volume_contents.next;
      end;
    else if backup_volume_contents.version = 1 then do;
        ncp -> backup_volume_contents.volname = v1_backup_volume_contents.volname;
        ncp -> backup_volume_contents.volid = v1_backup_volume_contents.volid;
        ncp -> backup_volume_contents.next = v1_backup_volume_contents.next;
      end;
    else do;
        call retv_report_$online_output (0, myname, "Unable to convert ^a.contents because of unknown version ^d",
	volname, backup_volume_contents.version);
        contentsp = null;
        call release_temp_segment_ (myname, ncp, ignore);
        return;
      end;
    do contents_idx = 1 to ncp -> backup_volume_contents.next;
      if backup_volume_contents.version = 1 then do;
	ncp -> backup_volume_contents (contents_idx).uid = v1_backup_volume_contents (contents_idx).uid;
	ncp -> backup_volume_contents (contents_idx).component = 0;
	ncp -> backup_volume_contents (contents_idx).offset = 0;
	ncp -> backup_volume_contents (contents_idx).tape_loc = 0;
        end;
      else if backup_volume_contents.version = 2 then do;
	if v2_backup_volume_contents (contents_idx).offset = -1 then do;
	    ncp -> backup_volume_contents (contents_idx).component = 0;
	    ncp -> backup_volume_contents (contents_idx).offset = 0;
	  end;
	else do;
	    ncp -> backup_volume_contents (contents_idx).component =
	      v2_backup_volume_contents (contents_idx).component;
	    ncp -> backup_volume_contents (contents_idx).offset =
	      v2_backup_volume_contents (contents_idx).offset;
	  end;
	ncp -> backup_volume_contents (contents_idx).uid = v2_backup_volume_contents (contents_idx).uid;
        end;
    end;
    call hcs_$fs_move_seg (ncp, contentsp, 1, code);
    if code ^= 0 then do;
        call retv_report_$online_output (code, myname, "Unable to move converted contents seg");
        contentsp = null;
      end;
    call release_temp_segment_ (myname, ncp, ignore);
  end convert_contents_seg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


term_contents_segs: proc;
dcl segp		     ptr;

/* This proc terminates the contents and contents name segs */

    do segp = contentsp;
      if segp ^= null then
	 call hcs_$terminate_noname (segp, code);
      if code ^= 0 then call retv_report_$error_output (code, myname, "Unable to terminate contents segs");
    end;

  end term_contents_segs;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include retv_data_;

%include retv_volume_list;
%include retv_request;

%include queue_msg_hdr;

%include retv_input;

%include retv_vol_control;

%include backup_volume_contents;

%include backup_volume_log;

%include backup_volume_header;
%include backup_pvol_info;

%include fs_vol_label;
%include backup_static_variables;

%include retv_skip_list;
%include query_info;

  end retv_vol_control_;





		    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
