



		    backup_cleanup.pl1              10/28/88  1411.9r w 10/28/88  1302.3       66474



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


backup_cleanup: bc: proc;

/* Command to dprint and delete backup maps and error files.

   Usage:
	backup_cleanup {starnames} {-no_dprint}

   If no starnames are specified, *.*.map and *.*.ef in the working directory
   are processed. If -no_dprint is specified, the segments are deleted.
   Otherwise they are dprinted and deleted.

Written 04/26/79 S. Herbst */



%include dprint_arg;

dcl 1 entries (branch_count) aligned based (entries_ptr),	/* for hcs_$star_ */
     2 type bit (2) unaligned,
     2 nnames bit (16) unaligned,
     2 nindex bit (18) unaligned;

dcl names (99) char (32) aligned based (names_ptr);	/* for hcs_$star_ */

dcl area area based (area_ptr);

dcl arg char (arg_len) based (arg_ptr);
dcl ERROR_FILE_DIR char (168) int static options (constant) init (">udd>SysDaemon>error_file");
dcl dn char (168);
dcl (en, name) char (32);

dcl (dprint_sw, ef_sw, path_sw) bit (1) aligned;

dcl (area_ptr, arg_ptr, entries_ptr, names_ptr) ptr;

dcl rings (3) fixed bin (5);
dcl (arg_count, arg_len, branch_count, i, j, queue_number) fixed bin;

dcl code fixed bin (35);
dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$noentry fixed bin (35) ext;
dcl error_table_$nomatch fixed bin (35) ext;

dcl bk_ss_$myname char (16) ext;

dcl adjust_bit_count_ entry (char (168) aligned, char (32) aligned, bit (1) aligned,
	fixed bin (24), fixed bin (35));
dcl check_star_name_$entry entry (char (*), fixed bin (35));
dcl com_err_ entry options (variable);
dcl copy_seg_ entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned, fixed bin (35));
dcl cu_$arg_count entry (fixed bin);
dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cu_$level_get entry returns (fixed bin);
dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl dprint_ entry (char (*), char (*), ptr, fixed bin (35));
dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl get_system_free_area_ entry returns (ptr);
dcl get_wdir_ entry returns (char (168));
dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35));
dcl hcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (5), fixed bin (35));
dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));

dcl (addr, fixed, length, max, null, rtrim, substr) builtin;

dcl cleanup condition;
/**/
	bk_ss_$myname = "backup_cleanup";

	call cu_$arg_count (arg_count);

	dprint_sw = "1"b;
	path_sw = "0"b;
	queue_number = 1;

	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	     if substr (arg, 1, 1) = "-" then
		if arg = "-no_dprint" | arg = "-ndp" then dprint_sw = "0"b;
		else if arg = "-dprint" | arg = "-dp" then dprint_sw = "1"b;
		else if arg = "-queue" | arg = "-q" then do;
		     i = i + 1;
		     if i > arg_count then do;
			call com_err_ (0, "backup_cleanup", "No value specified for ^a", arg);
			return;
		     end;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     queue_number = cv_dec_check_ (arg, code);
		     if code ^= 0 then do;
BAD_QUEUE:		call com_err_ (0, "backup_cleanup", "Invalid queue number ^a", arg);
			return;
		     end;
		     else if queue_number < 1 | queue_number > 4 then go to BAD_QUEUE;
		end;
		else do;
		     call com_err_ (error_table_$badopt, "backup_cleanup", "^a", arg);
		     return;
		end;
	     else path_sw = "1"b;
	end;

	area_ptr = get_system_free_area_ ();

	if dprint_sw then do;
	     dpap = addr (dprint_arg_buf);
	     dprint_arg.version = 1;
	     dprint_arg.copies = 1;
	     dprint_arg.delete = 1;
	     dprint_arg.queue = queue_number;
	     dprint_arg.pt_pch = 1;
	     dprint_arg.notify = 0;
	     dprint_arg.output_module = 1;
	     dprint_arg.dest = "SysDaemon";
	end;

	if ^path_sw then do;			/* no starnames specified */

	     call do_starname (get_wdir_ (), "*.*.map");

	     call do_starname (get_wdir_ (), "*.*.*.ef");
	end;

	else do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	     if substr (arg, 1, 1) ^= "-" then do;

		call expand_pathname_ (arg, dn, en, code);
		if code ^= 0 then do;
		     call com_err_ (code, "backup_cleanup", "^a", arg);
		     return;
		end;

		if substr (arg, arg_len - 3, 4) = ".map" | substr (arg, arg_len - 2, 3) = ".ef" then

		     call do_starname (dn, en);

		else do;

		     call do_starname (dn, rtrim (en) || ".map");

		     call do_starname (dn, rtrim (en) || ".ef");
		end;
	     end;
	end;

	return;
/**/
do_starname: proc (a_dn, a_en);

dcl (a_dn, a_en) char (*);

	call check_star_name_$entry (a_en, code);

	if code = 0 then do;
	     branch_count, j = 1;
	     name = a_en;
	     go to ONE_FILE;
	end;

	else if code = 1 | code = 2 then do;

	     entries_ptr, names_ptr = null;

	     on condition (cleanup) call clean_up;

	     call hcs_$star_ (a_dn, a_en, 2 /* branches */, area_ptr, branch_count,
		entries_ptr, names_ptr, code);
	     if code ^= 0 then do;
		if code ^= error_table_$nomatch then
		     call com_err_ (code, "backup_cleanup", "^a^[>^]^a", a_dn, a_dn ^= ">", a_en);
		return;
	     end;

	     do j = 1 to branch_count;

		name = names (fixed (entries (j).nindex, 18));

ONE_FILE:		if substr (a_en, length (rtrim (a_en)) - 2, 3) = ".ef" then do;
		     ef_sw = "1"b;
		     dprint_arg.heading = " for OLD ERROR FILE";
		end;
		else do;
		     ef_sw = "0"b;
		     dprint_arg.heading = " for OLD MAP";
		end;

		if dprint_sw | ef_sw then do;

		     call adjust_bit_count_ ((a_dn), (name), "1"b, 0, code);
		     if code ^= 0 then do;
			call com_err_ (code, "backup_cleanup", "^a^[>^]^a", a_dn, a_dn ^= ">", name);
			return;
		     end;

		     rings (1), rings (2), rings (3) = max (4, cu_$level_get ());
		     call hcs_$set_ring_brackets (a_dn, name, rings, code);
		end;

		if ef_sw then do;			/* copy error file */
		     call hcs_$status_minf (ERROR_FILE_DIR, name, 0, 0, 0, code);
		     if code ^= error_table_$noentry then do;
			call hcs_$delentry_file (ERROR_FILE_DIR, name, code);
COPY_ERROR:		if code ^= 0 then call com_err_ (code, "backup_cleanup",
			     "Copying ^a^[>^]^a to ^a>^a", a_dn, a_dn ^= ">", name, ERROR_FILE_DIR, name);
		     end;
		     else code = 0;

		     if code = 0 then do;
			call copy_seg_ (a_dn, name, ERROR_FILE_DIR, name, "backup_cleanup", "0"b, code);
			if code ^= 0 then go to COPY_ERROR;
		     end;
		end;

		if dprint_sw then call dprint_ (a_dn, name, dpap, code);

		else call hcs_$delentry_file (a_dn, name, code);
	     end;

	     call clean_up;
	end;

	else call com_err_ (code, "backup_cleanup", "^a", a_en);

end do_starname;
/**/
clean_up: proc;

	if entries_ptr ^= null then free entries_ptr -> entries in (area);
	if names_ptr ^= null then free names_ptr -> names in (area);

end clean_up;

end backup_cleanup;




		    backup_dump.pl1                 03/30/87  1135.0rew 03/30/87  1050.8      252639



/****^  ***********************************************************
        *                                                         *
        * 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-06-05,GWMay), approve(85-12-23,MCR7320), audit(86-11-19,GDixon),
     install(86-11-21,MR12.0-1223):
     Modified the process loop to abort when a fatal error is returned from the
     recursive dump subroutine. This way the program will not continue dumping
     with the next line in the control file. Added the entry
     backup_dump$abort_on_tape_errors to provide a means of returning the
     error code from a bad tape mount or write.
  2) change(87-03-03,GWMay), approve(87-03-03,MCR7627), audit(87-03-13,Farley),
     install(87-03-30,MR12.1-1018):
     added switch in the condition handling routine so that when writing to
     the map, all conditions are passed back to the default handler.
                                                   END HISTORY COMMENTS */


/* Hierarchy dumper */

/* Created:  February 1969 by R. C. Daley */
/* Modified: 29 June 1970 by R. H. Campbell */
/* Modified: 6 May 1976 by R. Bratt for pv dump */
/* Modified: 2 November 1977 by Steve Herbst to add backup_dump_ */
/* Modified: 3 August 1979 by Steve Herbst to add bk_ss_$no_primary */
/* Modified: 28 January 1980 by S. Herbst to add missing options to the map */
/* Modified: 6 November 1980 by G. Palter for version 3 backup_control structure */
/* Modified: 30 December 1980 by Steve Herbst to read control file and implement cross-dumping */
/* Modified: 4 August 1981 by G. Palter to fix interaction of cross-dumping and incremental/catchup/complete dumper */
/* Modified: July 1982 by G. Palter to add features for IMFT support of AIM: enforce a maximum access class for dumping,
   refuse to dump upgraded directories, and check a user's effective access to each branch before dumping */
/* Modified February 1983 by E. N. Kittlitz for 256K segs */
/* Modified August 1983 by Robert Coren to enforce a minimum access class for dumping */
/* Modified November 1983 by Robert Coren to copy "upgrade_to_user_auth" flag */
/* Modified 1985-03-21, BIM: fixed prehistoric busted condition handler.
   phx18650 -- does not reset transparency switches.
   phx17329 -- mishandling empty acls.
   phx17310 -- unitialized variables in cross-dumping.
   phx16651 -- rqovers on the map do not always get to level 2.
   phx13714 -- catching command_error conditions */


/* format: style4,delnl,insnl,ifthenstmt,ifthen */


backup_dump:
     procedure ();

dcl  Sfatal_error bit (1) aligned;
dcl  Stape_entry bit (1) aligned;
dcl  (i, id_length, n) fixed bin,			/* Temporary storage. */
     (a_code, code, saved_code) fixed bin (35),		/* Status codes */
     (old_trans_sw, ts) fixed bin (2),			/* To save previous transparent switch settings. */
     vers char (13) init ("21 March 1985") aligned int static options (constant),
						/* version of dumper */
     calendar char (16) aligned,			/* Temporary for time conversion. */
     ap ptr,					/* Pointer to argument list */
     p ptr,
     sp ptr,
     control_ptr ptr,				/* ptr to backup_dump_ control structure */
     path_index fixed bin,
     tchar (168) char (1) based,			/* test character array */
     saved_dtd fixed bin (52);

dcl  old_256K_switch bit (2) aligned;
dcl  (cross_dump_path, cross_dump_dn, dn, dump_dir, temp_dn) char (168);
dcl  cross_dump_en char (32);
dcl  text_line char (300);

dcl  NL char (1) int static options (constant) init ("
");
dcl  type fixed bin (2),
     btcnt fixed bin (24);				/* Arguments for status_minf call */

dcl  init static bit (1) initial ("1"b),		/* Static storage. */
     control_file_sw bit (1),				/* Reading requests from a control file */
     linep static ptr;				/* Pointer to ID line buffer. */

dcl  id static char (300);				/* Name, version of dumper and arguments. */

dcl  error_table_$noaccess fixed bin (35) external;	/* Status */
dcl  error_table_$noarg fixed bin (35) external;
dcl  error_table_$no_s_permission fixed bin (35) external;
dcl  error_table_$root fixed bin (35) external;
dcl  sys_info$seg_size_256K fixed bin (19) external;

dcl  backup_control_mgr_$initiate entry (pointer, fixed binary (35)),
     backup_control_mgr_$terminate entry (pointer),
     backup_dump_recurse entry (char (168), char (32), bit (1) aligned, bit (1) aligned, fixed bin (35)),
     backup_dump_recurse$set_directory_dtd entry (char (*) aligned, fixed bin (52)),
     backup_map_$beginning_line entry (fixed bin (52), ptr, fixed bin),
     backup_map_$fs_error_line entry (fixed bin (35), char (*), char (*), char (*)),
     backup_map_$directory_line entry (ptr, fixed bin),
     backup_map_$terminal_line entry (fixed bin (52), fixed bin (35)),
     backup_util$get_real_name entry (ptr, ptr, fixed bin, fixed bin (35)),
     bk_output$output_init entry (fixed bin, fixed bin (35)),
     bk_output$output_finish entry;

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35)),
     bk_arg_reader_$dump_arg_reader entry (fixed bin, ptr, fixed bin (35)),
     clock_ entry (fixed bin (52)),
     com_err_ entry options (variable),
     cu_$arg_count entry (fixed bin),
     cu_$arg_list_ptr entry (ptr),
     date_time_ entry (fixed bin (52), char (*) aligned),
     expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
     hcs_$fs_search_get_wdir entry (ptr, fixed bin),
     hcs_$status_minf
	entry (char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)),
     hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
     hcs_$set_256K_switch entry (bit (2) aligned, bit (2) aligned, fixed bin (35)),
     hcs_$set_max_length_seg ext entry (ptr, fixed bin (19), fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)),
     (ioa_$rs) entry options (variable);		/* Variable arguments. */

dcl  ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned);
dcl  ios_$detach entry (char (*), char (*), char (*), bit (72) aligned);
dcl  ios_$read entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned);

dcl  hphcs_$fs_get_trans_sw entry (fixed bin (2), fixed bin (2));

dcl  (
     hphcs_$suspend_quota,
     hphcs_$restore_quota
     ) external entry;

dcl  cleanup condition;
dcl  any_other condition;

dcl  (addr, index, length, max, min, null, reverse, rtrim, substr) builtin;

/**/

%include bk_ss_;
%page;
%include backup_preamble_header;
%page;
%include backup_control;
%page;
%include io_status;

/**/

	bk_ss_$sub_entry = "0"b;
	Stape_entry = "0"b;
	if bk_ss_$myname = " " then bk_ss_$myname = "backup_dump";
	go to common;

abort_on_tape_errors:
     entry (tape_code);

dcl  tape_code fixed bin;

	tape_code = 0;
	bk_ss_$sub_entry = "0"b;
	Stape_entry = "1"b;
	control_file_sw = "0"b;	/* control file is read by caller */
	go to have_args;

backup_dump_:
     entry (control_ptr, a_code);

	bk_ss_$sub_entry = "1"b;
	Stape_entry = "0"b;
	a_code = 0;
	
	bk_ss_$control_ptr = null();
	old_256K_switch = ""b;			/* initialize for cleanup */
	old_trans_sw = -1;				/* leaves the switches alone */
	on condition (cleanup)
	     begin;
	     call hcs_$set_256K_switch (old_256K_switch, (""b), (0));
	     if ^bk_ss_$debugsw then do;
	          call hphcs_$fs_get_trans_sw (old_trans_sw, (0));
	          call hphcs_$restore_quota;		/* Restore the quota */
	     end;
	     if bk_ss_$control_ptr ^= null then
	          call backup_control_mgr_$terminate (control_ptr);
          end;

	call backup_control_mgr_$initiate (control_ptr, a_code);
	if a_code ^= 0 then return;

	if bk_ss_$control_ptr -> backup_control.debug_sw then do;
	     bk_ss_$debugsw = "1"b;
	     bk_ss_$trimsw = "0"b;
	end;
	else bk_ss_$debugsw = "0"b;
	bk_ss_$mapsw = bk_ss_$control_ptr -> backup_control.map_sw;
	bk_ss_$no_reload = bk_ss_$control_ptr -> backup_control.no_reload_sw;
	bk_ss_$holdsw = bk_ss_$control_ptr -> backup_control.hold_sw;
	bk_ss_$preattached = bk_ss_$control_ptr -> backup_control.preattached;
	if bk_ss_$preattached then bk_ss_$data_iocb = bk_ss_$control_ptr -> backup_control.data_iocb;
	bk_ss_$sub_entry_errfile = bk_ss_$control_ptr -> backup_control.error_file;
	bk_ss_$caller_handles_conditions = bk_ss_$control_ptr -> backup_control.caller_handles_conditions;

	bk_ss_$enforce_max_access_class = bk_ss_$control_ptr -> backup_control.enforce_max_access_class;
	if bk_ss_$enforce_max_access_class then
	     bk_ss_$maximum_access_class = bk_ss_$control_ptr -> backup_control.maximum_access_class;

	bk_ss_$enforce_min_access_class = bk_ss_$control_ptr -> backup_control.enforce_min_access_class;
	if bk_ss_$enforce_min_access_class then
	     bk_ss_$minimum_access_class = bk_ss_$control_ptr -> backup_control.minimum_access_class;

	bk_ss_$dont_dump_upgraded_dirs = bk_ss_$control_ptr -> backup_control.dont_dump_upgraded_dirs;
	if bk_ss_$dont_dump_upgraded_dirs then
	     bk_ss_$maximum_dir_access_class = bk_ss_$control_ptr -> backup_control.maximum_dir_access_class;

	bk_ss_$check_effective_access = bk_ss_$control_ptr -> backup_control.check_effective_access;
	if bk_ss_$check_effective_access then do;
	     bk_ss_$user_id = bk_ss_$control_ptr -> backup_control.user_for_access_check.id;
	     bk_ss_$user_authorization = bk_ss_$control_ptr -> backup_control.user_for_access_check.authorization;
	     bk_ss_$user_ring = bk_ss_$control_ptr -> backup_control.user_for_access_check.ring;
	end;

	bk_ss_$upgrade_to_user_auth = bk_ss_$control_ptr -> backup_control.upgrade_to_user_auth;

	do i = 1 to bk_ss_$control_ptr -> backup_control.request_count;
	     bk_ss_$control_ptr -> backup_control.found (i) = "0"b;
	     bk_ss_$control_ptr -> backup_control.loaded (i) = "0"b;
	     bk_ss_$control_ptr -> backup_control.status_code (i) = 0;
	     bk_ss_$control_ptr -> backup_control.error_name (i) = "";
	end;

	bk_ss_$myname = "backup_dump_";
	go to common;


idump:
     entry;

	bk_ss_$sub_entry = "0"b;
	Stape_entry = "0"b;
	bk_ss_$myname = "idump";

common:
	cross_dump_path, cross_dump_dn, cross_dump_en = "";


/*	read in arguments and set switches		*/

	control_file_sw = "0"b;			/* not yet told of control file in our arguments */

	if bk_ss_$sub_entry then do;			/* if backup_dump_, get first pathname */
	     do i = 1 to bk_ss_$control_ptr -> backup_control.request_count;
		call absolute_pathname_ (bk_ss_$control_ptr -> backup_control.path (i), dn, code);
		if code = 0 & dn = ">" then code = error_table_$root;
		if code ^= 0 then do;
		     a_code, bk_ss_$control_ptr -> backup_control.status_code (i) = code;
		     go to RETURN_FROM_BACKUP_DUMP;
		end;
	     end;
	     bk_ss_$save_path = bk_ss_$control_ptr -> backup_control.path (1);
	     path_index, bk_ss_$path_index = 1;
	     bk_ss_$pathsw = "1"b;
	     bk_ss_$save_plen = length (rtrim (bk_ss_$save_path));
	end;
	else do;					/* else read command argument */
	     call cu_$arg_count (i);			/* Get the number of input arguments */
	     if i ^= 0 then do;			/* Don't bother if no args */
		call cu_$arg_list_ptr (ap);		/* Get pointer to argument list */
		call bk_arg_reader_$dump_arg_reader (1, ap, code);
						/* Do the work */
		if code ^= 0 then return;
		if bk_ss_$control_name ^= "" & bk_ss_$myname = "backup_dump" then do;
		     call ios_$attach ("dump_control", "file_", bk_ss_$control_name, "r",
			addr (status) -> status_bits);
		     if status.code ^= 0 then do;
			call com_err_ (status.code, bk_ss_$myname, "Attaching control file ^a", bk_ss_$control_name)
			     ;
			return;
		     end;
READ_CONTROL:
		     call ios_$read ("dump_control", addr (dump_dir), 0, length (dump_dir), n,
			addr (status) -> status_bits);
		     if status.code ^= 0 then do;
READ_ERROR:
			call com_err_ (status.code, bk_ss_$myname, "Reading control file ^a", bk_ss_$control_name);
			return;
		     end;
		     if substr (dump_dir, n, 1) = NL then
			substr (dump_dir, n) = "";
		     else substr (dump_dir, n + 1) = "";
		     if substr (dump_dir, 1, 1) ^= ">" then
			if status.end_of_data then
			     return;
			else go to READ_CONTROL;

		     i = index (dump_dir, "=");
		     if i ^= 0 then do;
			cross_dump_path = substr (dump_dir, i + 1);
			substr (dump_dir, i) = "";
			if substr (cross_dump_path, 1, 1) ^= ">" then
			     cross_dump_path =
				substr (dump_dir, 1, length (dump_dir) + 1 - index (reverse (dump_dir), ">"))
				|| cross_dump_path;
			if bk_ss_$mapsw then
			     text_line =
				"(Cross-dumping " || rtrim (dump_dir) || " to " || rtrim (cross_dump_path) || ")";
			call expand_pathname_ (cross_dump_path, cross_dump_dn, cross_dump_en, code);
			if code ^= 0 then do;
			     call com_err_ (code, bk_ss_$myname, "Cross-dump path ^a", cross_dump_path);
			     return;
			end;
		     end;
		     else cross_dump_path, cross_dump_dn, cross_dump_en = "";

		     bk_ss_$pathsw = "1"b;
		     bk_ss_$save_path = dump_dir;
		     bk_ss_$save_plen = n;
		     control_file_sw = "1"b;
		end;

		else if ^bk_ss_$pathsw then do;
		     call com_err_ (error_table_$noarg, bk_ss_$myname, "No absolute pathname specified.");
		     return;
		end;
		else do;
have_args:
		     cross_dump_path, cross_dump_dn, cross_dump_en = "";
		     call absolute_pathname_ (substr (bk_ss_$save_path, 1, bk_ss_$save_plen), dn, code);
		     if code = 0 & dn = ">" then code = error_table_$root;
		     if code ^= 0 then do;
			call com_err_ (code, "backup_dump", "^a", substr (bk_ss_$save_path, 1, bk_ss_$save_plen));
			return;
		     end;
		end;
	     end;
	     else if bk_ss_$myname = "backup_dump" then do;
		call com_err_ (error_table_$noarg, "backup_dump", "No pathname specified.");
		return;
	     end;
	end;

/*	initialization		*/

	Sfatal_error = "0"b;
	old_256K_switch = ""b;			/* initialize for cleanup */
	old_trans_sw = -1;				/* passing this back in has no effect */
	if ^bk_ss_$sub_entry then
	     on cleanup
		begin;				/* need a cleanup handler */
		call hcs_$set_256K_switch (old_256K_switch, (""b), (0));
						/* ignore code */
		if ^bk_ss_$debugsw then do;
		     call hphcs_$fs_get_trans_sw (old_trans_sw, (0));
		     call hphcs_$restore_quota;		/* Restore the quota */
                    end;
	     end;
	call hcs_$set_256K_switch ("11"b, old_256K_switch, (0));
						/* ignore code */
	if init then do;
	     call hcs_$make_seg ("", "dump_seg", "", 01011b, bk_ss_$sp, code);
	     call hcs_$set_max_length_seg (bk_ss_$sp, sys_info$seg_size_256K, code);
	     call hcs_$make_seg ("", "dump_area", "", 01011b, bk_ss_$areap, code);
	     call hcs_$make_seg ("", "dump_preamble", "", 01011b, bk_ss_$hp, code);
	     linep = addr (id);			/* Set up pointer to identification line. */
	     bk_ss_$areap -> h.dumper_id,		/* Insert dumper ID into preamble headers. */
		bk_ss_$hp -> h.dumper_id = "Backup_dump " || vers;
	     init = ""b;
	end;

	if bk_ss_$restart_dumpsw then do;		/* Check for restart branch */
	     call hcs_$status_minf (bk_ss_$restart_path, "", 0, type, btcnt, code);
	     if code ^= 0 then do;
		if bk_ss_$sub_entry then
		     a_code = code;
		else call com_err_ (code, bk_ss_$myname, "^a", bk_ss_$restart_path);
		go to RETURN_FROM_BACKUP_DUMP;
	     end;
	end;

/*	Start the dump .... first get absolute path name of starting directory 		*/

start:    bk_ss_$writing_map = "0"b;
	call clock_ (bk_ss_$save_time);		/* Get the current time. */

	if ^bk_ss_$pathsw then do;			/* Was a path name supplied? */
	     call hcs_$fs_search_get_wdir (addr (bk_ss_$save_path), bk_ss_$save_plen);
	     if bk_ss_$save_plen = 0 then do;		/* Is there a current working directory? */
		code = error_table_$noaccess;
		if bk_ss_$sub_entry then
		     a_code = code;
		else call com_err_ (code, bk_ss_$myname, "working directory");
						/* Gripe. */
		go to RETURN_FROM_BACKUP_DUMP;
	     end;
	end;
	if bk_ss_$sub_entry then
	     bk_ss_$no_primary = bk_ss_$control_ptr -> backup_control.no_primary_sw (bk_ss_$path_index);

	if ^bk_ss_$no_primary then do;
	     call backup_util$get_real_name (addr (bk_ss_$save_path), addr (bk_ss_$save_path), bk_ss_$save_plen, code);
	     if bk_ss_$restart_dumpsw then
		call backup_util$get_real_name (addr (bk_ss_$restart_path), addr (bk_ss_$restart_path),
		     bk_ss_$restart_plen, code);
	end;

	id_length = 0;

/*	Report switch settings		*/

	if bk_ss_$mapsw then do;			/* Is a map output desired? */
	     call append (rtrim (bk_ss_$myname));	/* set name into id line */
	     call append (vers);			/* and version */
	     if bk_ss_$tapesw then			/* Report tape option. */
		if bk_ss_$ntapes = 1 then
		     call append ("1tape");		/* How many tapes? */
		else call append ("2tapes");		/* Both. */
	     else call append ("notape");		/* No tape output enabled. */
	     call append ("map");			/* Report map option */
	     if bk_ss_$holdsw then
		call append ("hold");		/* Report tape hold option. */
	     else call append ("nohold");
	     if bk_ss_$onlysw then
		call append ("only");		/* Report whether hierarchy dump */
	     else call append ("sweep");
	     if bk_ss_$dtdsw then call append ("dtd");	/* Report dtd setting. */
	     if bk_ss_$datesw then do;		/* Report date value. */
		call date_time_ (bk_ss_$date, calendar);/* Convert the time value. */
		call append (calendar);
	     end;
	     if ^(bk_ss_$dtdsw | bk_ss_$datesw) then call append ("all");
						/* Are both off? */
	     if bk_ss_$debugsw then call append ("debug");/* Report debug mode setting */
	     if bk_ss_$err_onlinesw then call append ("error_on");
	     if bk_ss_$no_contin then call append ("nocontin");
						/* stop after catchup dump */
	     if bk_ss_$no_output then call append ("nooutput");
						/* no tape or map (bug if ON) */
	     if bk_ss_$no_primary then call append ("noprimary");
						/* do not use primary paths */
	     if bk_ss_$restart_dumpsw then call append ("restart");
						/* restarting previous dump */
	     if bk_ss_$pvsw then do;
		call append ("pvname = " || rtrim (bk_ss_$pvname));
	     end;
	end;
	if bk_ss_$tapesw then do;
	     call bk_output$output_init (bk_ss_$ntapes, code);
						/* initialize output if tape option ON */
	     if code ^= 0 then do;
		call backup_map_$fs_error_line (code, "bk_output$output_init", "Initialization", "");
		if Stape_entry then tape_code = code;
		else if bk_ss_$sub_entry then a_code = code;

		go to RETURN_FROM_BACKUP_DUMP;
	     end;
	end;
	call backup_map_$beginning_line (bk_ss_$save_time, linep, id_length);
						/* Write and type the beginning time. */
	if ^(bk_ss_$tapesw | bk_ss_$mapsw) then go to RETURN_FROM_BACKUP_DUMP;
						/* OK? */

/*	Dump header and first directory		*/

	bk_ss_$namesw = "1"b;			/* tell dump to dump only this record */
	if ^bk_ss_$debugsw then do;			/* for real not debug */
	     call hphcs_$suspend_quota;		/* dumper runs quota inhibited */
	     call hphcs_$fs_get_trans_sw (11b, old_trans_sw);
						/* Transparent use, modification. */
	end;
	on any_other call idump_signal;

/* First dump branch of starting directory to get names and ACLs */

	do;
	     p = addr (bk_ss_$save_path);		/* Get pointer to starting pathname */
	     do i = bk_ss_$save_plen to 1 by -1 while (p -> tchar (i) ^= ">");
	     end;					/* Find last ">" */
	     bk_ss_$hp -> h.dname = substr (bk_ss_$save_path, 1, max (1, i - 1));
	     bk_ss_$hp -> h.dlen = max (1, i - 1);
	     bk_ss_$ename = substr (bk_ss_$save_path, i + 1, bk_ss_$save_plen - i);

	     if bk_ss_$mapsw then do;
		if cross_dump_path ^= "" then do;
		     call backup_map_$directory_line (addr (text_line), length (rtrim (text_line)));
		     temp_dn = cross_dump_dn;
		end;
		else temp_dn = bk_ss_$hp -> h.dname;
		call backup_map_$directory_line (addr (temp_dn), length (rtrim (temp_dn)));
	     end;
	     if ^bk_ss_$pvsw then do;			/* dump branch - except in pv dump case */
		call hcs_$status_minf (bk_ss_$hp -> h.dname, bk_ss_$ename, 1, type, btcnt, code);
		if code ^= 0 & code ^= error_table_$no_s_permission then do;
		     call backup_map_$fs_error_line (code, "status_minf", (bk_ss_$hp -> h.dname), (bk_ss_$ename));
		     if bk_ss_$sub_entry then bk_ss_$control_ptr -> backup_control.status_code (path_index) = code;
		     go to dumped;
		end;
		call backup_dump_recurse (cross_dump_dn, cross_dump_en, "1"b, Sfatal_error, code);
		if Sfatal_error then go to error;	/* D U M P   T H E   B R A N C H */
		if type = 1 then do;		/* If terminal node was a segment ... */
		     if code = 1 then code = 0;	/* Code of 1 is normal return for single entry. */
		     go to dumped;			/* Clean up and leave. */
		end;
	     end;
	end;

/*	Now dump the rest of the subtree		*/

	if bk_ss_$sub_entry then saved_code = bk_ss_$control_ptr -> backup_control.status_code (path_index);

	do;
	     saved_dtd = bk_ss_$hp -> h.dtd;		/* needed to set DTD of the dir later (maybe) */
	     bk_ss_$hp -> h.dname = bk_ss_$save_path;	/* Now dump everything else */
	     bk_ss_$hp -> h.dlen = bk_ss_$save_plen;	/* .. */
	     bk_ss_$namesw = ""b;			/* set for entire dump */
	     if bk_ss_$restart_dumpsw then bk_ss_$rlen = bk_ss_$save_plen + 1;
						/* Set starting length of name for recursion in restart */

	     call backup_dump_recurse (cross_dump_dn, cross_dump_en, "0"b, Sfatal_error, code);
	     if Sfatal_error then go to error;		/* D U M P   S U B T R E E */

	     call backup_dump_recurse$set_directory_dtd (bk_ss_$hp -> h.dname, saved_dtd);
	end;

dumped:
	if bk_ss_$sub_entry then do;			/* if backup_dump_, get the next pathname */
	     if saved_code = 0 & bk_ss_$control_ptr -> backup_control.status_code (path_index) ^= 0 then
		bk_ss_$control_ptr -> backup_control.error_name (path_index) =
		     "(in subtree) " || 
		     substr (bk_ss_$control_ptr -> backup_control.error_name (path_index), 1,
		     length (bk_ss_$control_ptr -> backup_control.error_name (path_index)) - length ( "(in subtree)" ));
	     path_index, bk_ss_$path_index = path_index + 1;
	     if path_index <= bk_ss_$control_ptr -> backup_control.request_count then do;
		bk_ss_$save_path = bk_ss_$control_ptr -> backup_control.path (path_index);
		bk_ss_$save_plen = length (rtrim (bk_ss_$save_path));
		cross_dump_path = bk_ss_$control_ptr -> backup_control.new_path (path_index);
		revert any_other;
		if ^bk_ss_$debugsw then do;			/* Turn on quota, turn off trans sw if possible */
		     call hphcs_$restore_quota;		/* Restore the quota */
		     call hphcs_$fs_get_trans_sw (old_trans_sw, ts); 
						          /* Restore previous settings. */
		end;
		go to start;
	     end;
	end;
	else if control_file_sw then			/* get next control file entry */
	     if ^status.end_of_data then do;
	          revert any_other;
		if ^bk_ss_$debugsw then do;			/* Turn on quota, turn off trans sw if possible */
		     call hphcs_$restore_quota;		/* Restore the quota */
		     call hphcs_$fs_get_trans_sw (old_trans_sw, ts);
						          /* Restore previous settings. */
		end;
		go to READ_CONTROL;
               end;
	     else call ios_$detach ("dump_control", "", "", addr (status) -> status_bits);
						/* Cleanup and exit		*/
error:
	if Sfatal_error then do;
	     if Stape_entry then tape_code = code;

	     if bk_ss_$sub_entry then
		a_code = code;
	     else call com_err_ (code, bk_ss_$myname, "
Unable to continue dumping.");
	end;

	revert any_other;
	if ^bk_ss_$debugsw then do;			/* Turn on quota, turn off trans sw if possible */
	     call hphcs_$restore_quota;		/* Restore the quota */
	     call hphcs_$fs_get_trans_sw (old_trans_sw, ts);
						/* Restore previous settings. */
	end;
	if bk_ss_$tapesw then call bk_output$output_finish ();
						/* Shutdown output proceedure */
	call clock_ (bk_ss_$save_time);		/* Get time of stopping. */
	call backup_map_$terminal_line (bk_ss_$save_time, code);
						/* Write the trailer line. */
	call hcs_$truncate_seg (bk_ss_$sp, 0, code);	/* Free unused pages in buffer segments. */
	call hcs_$truncate_seg (bk_ss_$areap, 1023, code);/* Save first page of preamble segments. */
	call hcs_$truncate_seg (bk_ss_$hp, 1023, code);	/* .. */
	if (bk_ss_$myname = "backup_dump") | (bk_ss_$myname = "idump") then bk_ss_$myname = "";

RETURN_FROM_BACKUP_DUMP:
	call hcs_$set_256K_switch (old_256K_switch, (""b), (0));
						/* ignore code */
	if bk_ss_$sub_entry then			/* possibly copy info back to older structure */
	     call backup_control_mgr_$terminate (control_ptr);
	return;

/**/

append:
     procedure (string);				/* Append string to identification line. */

dcl  string character (*) aligned;			/* What to append. */
	if id_length < length (id) then do;		/* Is there room in buffer? */
	     id_length = id_length + 1;		/* Count it. */
	     substr (id, id_length, 1) = " ";		/* Prepend a blank. */
	     i = min (length (id) - id_length, length (string));
						/* Don't overflow. */
	     substr (id, id_length + 1, i) = string;	/* Append this string. */
	     id_length = id_length + i;		/* Count length. */
	end;
     end append;

/**/

/* Entry upon recieving an unclaimed signal */

idump_signal:
     procedure;

dcl  save_error fixed binary,				/* Space to save error location code. */
     is_temp fixed bin,
     is_code fixed bin (35),
     is_linep pointer,				/* Pointer to line buffer. */
     is_line character (300);				/* Line for formatting output messages. */

declare  continue_to_signal_ entry (fixed binary (35));
declare  find_condition_info_ entry (pointer, pointer, fixed binary (35));
declare  1 CI aligned like condition_info;

	if bk_ss_$sub_entry & bk_ss_$caller_handles_conditions
	   | bk_ss_$writing_map then do;
	     call continue_to_signal_ ((0));
	     return;
	end;					/* caller has any_other handler (for IMFT daemon usage) */

	CI.version = condition_info_version_1;
	call find_condition_info_ (null (), addr (CI), (0));
	if ^(CI.condition_name = "seg_fault_error" | CI.condition_name = "no_read_permission"
	     | CI.condition_name = "record_quota_overflow"/* null pages ... */
	     | CI.condition_name = "out_of_bounds"	/* joker changed maxl */
	     | CI.condition_name = "not_in_read_bracket"	/* etc. */
	     | CI.condition_name = "page_fault_error" /* disk problems */) then do;
	     call continue_to_signal_ ((0));		/* Not our problem */
	     return;
	end;

/**** If we get here, we have a condition that could possibly have
      happened while referencing a segment that we were dumping.
      Check to see if we were dumping a segment. (bk_ss_$error ^= 0)
      If not, we continue to signal anyway, since it is a problem
      with the dumper and not just a joker nailing a segment we are dumping. */

	save_error = bk_ss_$error;			/* Save copy of error location code. */
	bk_ss_$error = 0;				/* Indicate future errors fatal. */
	is_linep = addr (is_line);			/* Get pointer to line buffer. */
	if save_error ^= 0 then do;			/* If error is not fatal at this time */
	     if bk_ss_$mapsw then do;			/* Are we to report in the map? */
		call ioa_$rs ("Non-fatal ^a at ^d: ^a>^a", is_line, is_temp, CI.condition_name, save_error,
		     bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename);
		call backup_map_$directory_line (is_linep, is_temp);
	     end;
	     if bk_ss_$wasnt_known then do;		/* Should we terminate this segment? */
		bk_ss_$wasnt_known = ""b;		/* Clear indicator for safety. */
		bk_ss_$error = 1;			/* Enable error recovery attempt. */
		call hcs_$terminate_noname (bk_ss_$segptr, is_code);
						/* Terminate this segment. */
		bk_ss_$error = 0;			/* Disable error recovery. */
	     end;
	     go to bk_ss_$err_label;			/* attempt to recover with non-local go to */
	end;
	call continue_to_signal_ ((0));		/* No internal error recovery */
	return;

%include condition_info;
     end idump_signal;

     end backup_dump;




		    backup_dump_recurse.pl1         07/16/87  1350.4rew 07/16/87  1312.4      413397



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



/* Dumps a branch to tape and, optionally, dumps the contents of the subtree if the branch is a directory */


/*   Modified: 10 January 1972 by A. Kobziar to use special status entry instead of branch_info for actime,actind
     Modified: 01 March 1973 by A. Downing to make all calls to (area_,alloc_,freen_) be made to the old area package
     Modified: 15 December 1974 by A. Kobziar to set up sec_directory_list record with security info
     Modified: April 1976 by R. Bratt for tpd stuff and pv dump
     Modified: September 1976 by R. Bratt to no longer terminate directories
     Modified: ? by B. Greenberg for VTOC errors
     Modified: 26 June 1979 by S. Herbst to make incremental dumps ignore ring-0 entries
     Modified: 17 November 1980 by G. Palter to honor bk_ss_$no_primary and to always sort branches to allow restart bit to
     work properly
     Modified: 24 February 1981 by S. Herbst to retry dump twice after error_table_$device_attention
     Modified: 1 July 1981 by S. Herbst to add support -setdtd and -nosetdtd
     Modified: 4 August 1981 by G. Palter to properly handle dumping of top-level directories in the control file
     Modified: July 1982 by G. Palter to add features for IMFT support of AIM: enforce a maximum access class for dumping,
     refuse to dump upgraded directories, and check a user's effective access to each branch before dumping
     Modified: February 1983 by E. N. Kittlitz for 256K segs
     Modified: August 1983 by Robert Coren to enforce minimum access class for dumping
     Modified: November 1983 by Robert Coren to upgrade object access class to user's authorization if requested
     Modified 1985-03-21, BIM: fixed prehistoric busted condition handler.
     -------- -- Fixed not to force access in no-reload mode.
     phx17078 -- bks is not correctly zeroed.
     phx18650 -- does not reset transparency switches.
     phx17329 -- mishandling empty acls.
     phx17310 -- unitialized variables in cross-dumping.
     phx16651 -- rqovers on the map do not always get to level 2.
     phx13714 -- catching command_

/****^  HISTORY COMMENTS:
  1) change(86-06-16,Lippard), approve(86-06-02,MCR7427),
     audit(86-06-16,Farley), install(86-06-17,MR12.0-1077):
      To not use status_for_backup.(actime actind).
  2) change(86-10-15,GWMay), approve(86-10-15,MCR7320), audit(86-11-19,GDixon),
     install(86-11-21,MR12.0-1223):
     changed to return a fatal error to the caller when a tape error occurs.
  3) change(87-07-15,GDixon), approve(87-07-15,MCR7617),
     audit(87-07-16,RBarstad), install(87-07-16,MR12.1-1040):
     Modified for change to backup_record_types.incl.pl1.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,ifthenstmt,ifthen */


backup_dump_recurse: proc (A_cross_dump_dn,
		       A_cross_dump_en,
		       P_force_dump,
		       Sfatal_error,
		       A_code);

dcl  P_force_dump bit (1) aligned parameter;		/* ON => dump this entry no matter what */

dcl  A_code fixed binary (35);			/* returned non-zero if dump aborted */

dcl  Sfatal_error bit (1) aligned;			/* used to signal a fatal tape error */
						/* there are other errors which will */
						/* stop only the current line in the */
						/* control file from being dumped    */
						/* For those, the flag should not be set */

dcl  (i, j, used) fixed binary,			/* temporary storage */
     retry_count fixed bin,
     code fixed bin (35),
     ignore fixed bin (35),				/* ignored error code */
     found fixed bin,				/* Used in restarting a dump */
     (havent_output_dirname, found_object) bit (1) aligned,
     (bc, lc, dircount, curl, name_len) fixed binary,
     (np, bp, lp, hnp, hbp, aclp, ix, jx) pointer,
     pp pointer,			                    /* used within an incl file       */
     nssp ptr,					/* -> bk_nss_info struct, in area */
     dqip ptr,					/* -> bk_dq_info struct, in area */
     (dtd, dtu, dtem, dtsm, cutoff_time) fixed binary (52), /* Temporaries for date-time values. */
     blocks fixed binary (9),
     ring fixed bin (3),
     ac_stg char (256),				/* converted access class */
     ac_stg_octal character (32) aligned,
     name_line char (200),				/* dir name followed by access class */
     sv_label label;

dcl  (A_cross_dump_dn, cross_dump_dn, restore_dn) char (168);
dcl  (A_cross_dump_en, cross_dump_en, restore_en, temp_en) char (32);
dcl  (restore_dlen, restore_elen) fixed bin;

dcl  (
     incr_sw,
     incr_sw_set init ("0"b)
     ) bit (1) int static;

dcl  initialize static bit (1) initial ("1"b),		/* Static storage. */
     (header_areap, list_areap, hdp) static pointer,	/* Pointers to selected items in headers. */
     br_size fixed binary static,			/* Number of words in branch info. */
     1 ksta aligned like kst_attributes static;

dcl  mover (curl) based;				/* For fast block moves. */

dcl  (
     error_table_$ai_restricted,
     error_table_$device_attention,
     error_table_$segknown,
     error_table_$moderr,
     error_table_$noentry,
     error_table_$root
     ) fixed binary (35) external;			/*  error code. */

dcl  sys_info$seg_size_256K fixed bin (19) external,
     sys_info$page_size fixed bin ext static,
     max_length_list_area fixed bin (19) static,
     max_length_header_area fixed bin (19) static;

dcl  old_alloc_ entry (fixed bin, ptr, ptr),
     old_area_ entry (fixed bin (19), ptr),
     mdc_$find_volname entry (bit (36) aligned, char (*) aligned, char (*) aligned, fixed bin (35)),
     aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned),
     convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)),
     convert_aim_attributes_ entry (bit (72) aligned, char (32) aligned),
     expand_pathname_ entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)),
     (
     hcs_$list_acl,
     hcs_$list_dir_acl
     ) ext entry (char (*) aligned, char (*) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35)),
     hcs_$get_max_length entry (char(*), char(*), fixed bin(19), fixed bin(35)),
     hcs_$get_max_length_seg entry (ptr, fixed bin(19), fixed bin(35)),
     hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35)),
     hcs_$initiate
	entry (char (*) aligned, char (*) aligned, char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$list_dir entry (char (*) aligned, (*) fixed bin, ptr, fixed bin, ptr, fixed bin, fixed bin (35)),
     hcs_$quota_get
	entry (char (*) aligned, fixed bin, fixed bin (35), fixed bin (35), fixed bin, fixed bin (1), fixed bin,
	fixed bin (35)),
     hcs_$dir_quota_read
	entry (char (*) aligned, fixed bin, fixed bin (71), bit (36) aligned, fixed bin, fixed bin (1), fixed bin,
	fixed bin (35)),
     hcs_$get_access_class entry (char (*) aligned, char (*) aligned, bit (72) aligned, fixed bin (35)),
     hcs_$status_long entry (char (*) aligned, char (*) aligned, fixed bin (1), ptr, ptr, fixed bin (35)),
     pathname_ entry (char (*), char (*)) returns (char (168)),
     phcs_$deactivate entry (ptr, fixed bin (35)),
     hphcs_$set_kst_attributes entry (fixed bin (17), ptr, fixed bin (35)),
     hphcs_$set_backup_dump_time entry (char (*) aligned, char (*) aligned, fixed bin (52), fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     hcs_$list_inacl_all entry (char (*) aligned, ptr, ptr, ptr, fixed bin (35)),
     hcs_$status_for_backup entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)),
     ioa_$rsnnl entry options (variable);

dcl  infoptr ptr;

dcl  1 inacl_info based aligned,
       2 sia_relp (0:7) bit (18),
       2 sia_count (0:7) fixed bin,
       2 dia_relp (0:7) bit (18),
       2 dia_count (0:7) fixed bin;

%include status_for_backup;

dcl  1 bks aligned automatic like status_for_backup;

dcl  backup_map_$detail_line2
	entry (char (32) aligned, fixed bin (9), char (10) aligned, fixed bin (52), fixed bin (52), fixed bin (52),
	fixed bin (52), fixed bin (52)),
     backup_map_$error_line entry () options (variable),
     backup_map_$fs_error_line entry (fixed bin (35), char (*) aligned, char (*) aligned, char (*) aligned),
     (
     backup_map_$directory_line,
     backup_map_$name_line
     ) entry (ptr, fixed bin),
     bk_output$wr_tape entry (ptr, fixed bin (18), ptr, fixed bin, fixed bin (35));
dcl  sort_branches entry (ptr, fixed bin) external;
dcl  (addr, addrel, baseno, binary, bit, divide, fixed, index, length) builtin;
dcl  (max, min, null, pointer, ptr, rel, rtrim, substr, unspec) builtin;
dcl  clock builtin;
dcl  size builtin;	



/*	INITIALIZE	*/

	if initialize then do;			/* Is this the first time? */
	     bp = null;				/* Compute branch info size. */
	     br_size = fixed (rel (addr (bp -> br (2))), 18) - fixed (rel (bp), 18);
	     header_areap = addr (bk_ss_$hp -> h.list_area);
						/* Compute pointers to areas in headers. */
	     list_areap = addr (bk_ss_$areap -> h.list_area);
						/* .. */
	     call hcs_$get_max_length_seg (list_areap, max_length_list_area, code);
	     if code ^= 0 then do;
		call backup_map_$fs_error_line (code, "get_max_length_seg", "list_areap", "");
		go to terminate_dump;
	     end;
	     call hcs_$get_max_length_seg (header_areap, max_length_header_area, code);
	     if code ^= 0 then do;
		call backup_map_$fs_error_line (code, "get_max_length_seg", "header_areap", "");
		go to terminate_dump;
	     end;
	     hdp = addr (bk_ss_$hp -> h.dname);		/* Get pointer to directory name. */
	     bk_ss_$areap -> h.elen = 0;		/* No entry name in "directory list" records. */
	     bk_ss_$areap -> h.ename = "";
	     bk_ss_$areap -> h.record_type = ndc_directory_list;
						/* Set up type code. */
	     unspec (ksta) = "0"b;
	     ksta.set.tms, ksta.value.tms = "1"b;
	     ksta.set.tus, ksta.value.tus = "1"b;
	     ksta.set.tpd, ksta.value.tpd = "1"b;
	     ksta.set.explicit_deactivate_ok, ksta.value.explicit_deactivate_ok = "1"b;
	     ksta.set.allow_write = "1"b;
	     ksta.value.allow_write = "0"b;
	     initialize = ""b;
	end;

	retry_count = 0;
retry_dump:
	cross_dump_dn = A_cross_dump_dn;
	cross_dump_en = A_cross_dump_en;
	A_code = 0;
	havent_output_dirname = "1"b;
	bk_ss_$hp -> h.elen = 0;			/* Reset entry name to null. */
	bk_ss_$hp -> h.ename = "";
	sv_label = bk_ss_$err_label;			/* save previous error return label */
	bk_ss_$err_label = dump_rtn;			/* set up error return label variable */
	call old_area_ (max_length_list_area - 128, list_areap);
						/* initialize empty area */
	bk_ss_$areap -> h.dtd = clock ();		/* Get time data gathered. */
	bk_ss_$error = 2;				/* Inform idump_signal to expect signals. */

/* LIST THE DIRECTORY	*/

	call hcs_$list_dir (bk_ss_$hp -> h.dname, bk_ss_$areap -> h.list_area, bp, bc, lp, lc, code);
	bk_ss_$error = 0;				/* Signals are now fatal again. */
	if code ^= 0 then do;
	     call backup_map_$fs_error_line (code, "list_dir", bk_ss_$hp -> h.dname, "");
	     if bk_ss_$tapesw | bk_ss_$mapsw then go to dump_rtn;
						/* Are we still doing something? */
terminate_dump:
	     if code = error_table_$device_attention & retry_count < 3 then do;
		retry_count = retry_count + 1;
		go to retry_dump;
	     end;
	     if code = 0 then code = 1;
	     A_code = code;
	     go to dump_rtn;
	end;

	if bk_ss_$namesw then do;			/* we are dumping only a single record */
	     found_object = "0"b;
	     go to do_it;
	end;
	if bk_ss_$pvsw then go to do_it;		/*  only dump segments for pv dump */
	if bk_ss_$restart_dumpsw then do;		/* Find comparison name for restart */
	     found = 0;
	     i = index (substr (bk_ss_$restart_path, bk_ss_$rlen + 1, bk_ss_$restart_plen), ">");
						/* Find next ">" */
	     if i > 0 then do;			/* Found one */
		bk_ss_$ename = substr (bk_ss_$restart_path, bk_ss_$rlen + 1, i - 1);
						/* Save compare name */
		bk_ss_$rlen = bk_ss_$rlen + i;	/* Reset restart length */
	     end;
	     else do;
		bk_ss_$ename = substr (bk_ss_$restart_path, bk_ss_$rlen + 1, bk_ss_$restart_plen - bk_ss_$rlen);
		bk_ss_$rlen = 0;			/* This signals last name */
	     end;
	end;

	cross_dump_dn = pathname_ (A_cross_dump_dn, A_cross_dump_en);

	if bk_ss_$tapesw then do;			/* Is tape writing enabled? */
	     bk_ss_$areap -> h.dlen = bk_ss_$hp -> h.dlen;/* Copy directory name */
	     bk_ss_$areap -> h.dname = bk_ss_$hp -> h.dname;
	     if bc > 0 then bk_ss_$areap -> h.bp = rel (bp);
						/* Set up pointers in header if not garbage. */
	     bk_ss_$areap -> h.bc = bc;		/* Set up counts. */
	     if lc > 0 then bk_ss_$areap -> h.lp = rel (lp);
	     bk_ss_$areap -> h.lc = lc;
	     bk_ss_$areap -> h.aclc = 0;		/* Indicate no CACL. */
	     bk_ss_$areap -> h.aclp = ""b;

/* GET ACCESS CLASS AND VOLUME INFO */

	     bk_ss_$areap -> h.nss_info_relp = "0"b;
	     bk_ss_$error = 20;

	     unspec (bks) = ""b;
	     bks.version = status_for_backup_version_2;

	     call hcs_$status_for_backup (bk_ss_$hp -> h.dname, "", addr (bks), code);
						/* get access class */
	     bk_ss_$error = 0;
	     if code ^= 0 then
		if code = error_table_$root then do;
		     bks.access_class = "0"b;		/* root starts low */
		     bks.switches.multiple_class = "0"b;
		end;
		else do;
		     call backup_map_$fs_error_line (code, "hcs_$status_for_backup", bk_ss_$hp -> h.dname, "");
		     go to terminate_dump;
		end;
	     else do;
		curl = size (bk_nss_info);
		call old_alloc_ (curl, list_areap, nssp);
		bk_ss_$areap -> h.nss_info_relp = rel (nssp);
		nssp -> bk_nss_info.version = 1;
		nssp -> bk_nss_info.lvid = bks.lvid;
		nssp -> bk_nss_info.pvid = bks.pvid;
		call mdc_$find_volname (bks.pvid, nssp -> bk_nss_info.pvname, nssp -> bk_nss_info.lvname, ignore);
	     end;

	     if bk_ss_$upgrade_to_user_auth then	/* dump segment at user's authorization (hopefully >= access class) */
		bks.access_class = bk_ss_$user_authorization;

	     bk_ss_$areap -> h.switches = bks.switches;
	     bk_ss_$areap -> h.access_class = bks.access_class;
	     bk_ss_$areap -> h.status_version = bks.version;
						/* pass thru version for reloader */

/* GET THE INITIAL ACLS */

	     infoptr = addr (bk_ss_$areap -> h.inaclp (0));
	     bk_ss_$error = 4;
	     call hcs_$list_inacl_all (bk_ss_$hp -> h.dname, list_areap, aclp, infoptr, code);
	     bk_ss_$error = 0;
	     if code ^= 0 then do;
		call backup_map_$fs_error_line (code, "hcs_$list_inacl_all", bk_ss_$hp -> h.dname, "");
		if ^(bk_ss_$tapesw | bk_ss_$mapsw) then go to terminate_dump;
		unspec (infoptr -> inacl_info) = ""b;
	     end;
	     else do;				/* make ia_relp's relative to base of seg */
		do ring = 0 to 7;
		     if infoptr -> inacl_info.sia_count (ring) ^= 0 then
			infoptr -> inacl_info.sia_relp (ring) =
			     rel (addrel (aclp, infoptr -> inacl_info.sia_relp (ring)));
		     if infoptr -> inacl_info.dia_count (ring) ^= 0 then
			infoptr -> inacl_info.dia_relp (ring) =
			     rel (addrel (aclp, infoptr -> inacl_info.dia_relp (ring)));
		end;
	     end;

/* GET QUOTA AND ACCOUNTING INFO. */

	     bk_ss_$error = 6;			/* Set up to try error recovery. */
	     call hcs_$quota_get (bk_ss_$hp -> h.dname, bk_ss_$areap -> h.quota, bk_ss_$areap -> h.trp,
		bk_ss_$areap -> h.tlu, bk_ss_$areap -> h.inf_acct, bk_ss_$areap -> h.term_acct, used, code);
	     bk_ss_$error = 0;			/* Clear recovery indicator. */
	     if code ^= 0 then do;
		call backup_map_$fs_error_line (code, "quota_get", bk_ss_$hp -> h.dname, "");
		bk_ss_$areap -> h.quota, bk_ss_$areap -> h.trp, bk_ss_$areap -> h.tlu, bk_ss_$areap -> h.inf_acct,
		     bk_ss_$areap -> h.term_acct = 0;
	     end;
	     curl = size (bk_dq_info);
	     call old_alloc_ (curl, list_areap, dqip);	/* make room for dirquota */
	     bk_ss_$areap -> h.dq_info_relp = rel (dqip); /* set relp for reloader */
	     dqip -> bk_dq_info.version = 1;
	     bk_ss_$error = 21;			/* Set up to try error recovery. */
	     call hcs_$dir_quota_read (bk_ss_$hp -> h.dname, dqip -> bk_dq_info.quota, dqip -> bk_dq_info.ltrp,
		dqip -> bk_dq_info.tlu, dqip -> bk_dq_info.inf_acct, dqip -> bk_dq_info.term_acct, used, code);
	     bk_ss_$error = 0;			/* Clear recovery indicator. */
	     if code ^= 0 then do;
		call backup_map_$fs_error_line (code, "dir_quota_read", bk_ss_$hp -> h.dname, "");
		bk_ss_$areap -> h.dq_info_relp = ""b;
	     end;

/* WRITE OUT THE PREAMBLE, LIST_DIR AND ACCOUNTING INFO for a DIRECTORY */

	     cross_dump_en = "";
	     call output (bk_ss_$areap, null, 0, code);
	     if code ^= 0 then go to terminate_dump;
	end;

	if bk_ss_$mapsw then do;			/* if map option is on */
	     if ^bk_ss_$tapesw then do;		/* get access class if -notape */
		call hcs_$get_access_class (bk_ss_$hp -> h.dname, "", bks.access_class, code);
		if code ^= 0 then bks.access_class = "0"b;
	     end;
	     if bks.access_class ^= "0"b then do;	/* format access class */
		call convert_authorization_$to_string_short (bks.access_class, ac_stg, code);
		if code ^= 0 then do;		/* couldn't get the conversion */
		     call convert_aim_attributes_ (bks.access_class, ac_stg_octal);
		     ac_stg = ac_stg_octal;
		end;
		call ioa_$rsnnl ("^a[ac:^a]", name_line, name_len, bk_ss_$hp -> h.dname, ac_stg);
		call directory_line (addr (name_line), name_len);
	     end;
	     else call directory_line (hdp, bk_ss_$hp -> h.dlen);
	end;

/* PROCESS THE BRANCHES */

do_it:
	if bc >= 15 then
	     call sort_branches (bp, bc);		/* sort the branches in order of primary name */
	else call sort_small (bp, bc);

	bk_ss_$err_label = skip_branch;		/* Set up label for skipping segments. */
	bk_ss_$hp -> h.lp = ""b;			/* Reset link pointer. */
	bk_ss_$hp -> h.lc = 0;			/* Reset link count. */
	bk_ss_$hp -> h.bc = 1;			/* Set branch count. */
	dircount = 0;

	if ^incr_sw_set then do;
	     if bk_ss_$myname ^= "backup_dump" & bk_ss_$myname ^= "backup_dump_" then
		incr_sw = "1"b;
	     else incr_sw = "0"b;
	     incr_sw_set = "1"b;
	end;

/* GET TIMES AND COMPARE FOR OUTPUTTING */

	do i = 1 to bc;				/* scan through all branches */
	     ix = pointer (bp, bp -> br (i).ix);	/* Get effective index. */
	     np = pointer (bp, ix -> br (1).namerp);	/* Get pointer to names. */
	     if bk_ss_$namesw			/* Are we looking to dump a single branch? */
	     then do;
		do j = 1 to binary (ix -> br (1).nnames, 17, 0);
		     if (bk_ss_$ename = np -> name (j).string) then do;
			found_object = "1"b;
			go to dump_me;
		     end;
		end;
		go to skip_branch;			/* here iff no match */
	     end;
	     else if bk_ss_$restart_dumpsw		/* only if dumping more than branches */
		then
		if bk_ss_$ename > np -> name (1).string then go to skip_branch;
						/* skip all already dumped */
		else if found > 0			/* Passed dir or branches already dumped */
		     then
		     if ^ix -> br (1).dirsw then
			go to skip_branch;		/* only want dirs till last level */
		     else ;
		else if bk_ss_$ename = np -> name (1).string
						/* Found it? */
		     then
		     if bk_ss_$rlen = 0 then
			bk_ss_$restart_dumpsw = ""b;	/* Done restarting, normal dump */
		     else found = 1;		/* Found it but continue restart to lower level */
		else if bk_ss_$rlen = 0 then bk_ss_$restart_dumpsw = ""b;
						/* Done restarting */
		else found = 2;			/* Didn't find name, beyond it. Bad dir. End restart */

dump_me:
	     if incr_sw then			/* incremental dumps ignore ring 0 */
		if ix -> br (1).rb2 = "0"b then go to skip_branch;
	     if ix -> br (1).vtoc_error then
		begin;				/* handle vtoc error case */

dcl  1 brst like branch_status aligned;
dcl  mxl fixed bin (19);
dcl  cleanup condition;

		on cleanup ;			/* Force non-quick */

		np = ptr (bp, ix -> br (1).namerp);	/* Get names ptr */
		bk_ss_$error = 40;
		call hcs_$status_long (bk_ss_$hp -> h.dname, np -> name (1).string, 0, addr (brst), null (), code);
		bk_ss_$error = 0;
		if code = 0 then do;		/* Lucked out */
		     ix -> br (1).cl = bit (fixed (fixed (brst.current_length, 12), 9), 9);
		     ix -> br (1).dtu = brst.date_time_used;
		     ix -> br (1).dtm = brst.date_time_modified;
		     call hcs_$get_max_length ((bk_ss_$hp -> h.dname), (np -> name (1).string), mxl, code);
		     if code = 0 then ix -> br (1).ml = bit (divide (mxl, sys_info$page_size, 9, 0), 9);
		end;
		if code ^= 0 then do;		/* Could be bad from max-length */
		     call backup_map_$fs_error_line (code, "VTOCE error on segment", bk_ss_$hp -> h.dname,
			np -> name (1).string);
		     go to skip_branch;
		end;
	     end;
	     if bk_ss_$pvsw & ix -> br (1).dirsw then do; /* skip dirs on pvdump (must still count) */
		dircount = dircount + 1;
		go to skip_branch;
	     end;
	     dtem = fixed (ix -> br (1).dtbm, 52);	/* Extract modification times. */
	     dtsm = fixed (ix -> br (1).dtm, 52);
	     dtd = fixed (ix -> br (1).dtd, 52);	/* Extract time last dumped. */
	     ix -> br (1).dump_me = ""b;		/* Clear dump indicator. */
	     if bk_ss_$datesw then do;		/* Are we dumping by date? */
		if bk_ss_$dtdsw then		/* Are we dumping by dtd as well? */
		     cutoff_time = min (bk_ss_$date, dtd);
						/* Get earliest cutoff time. */
		else cutoff_time = bk_ss_$date;	/* By date, get it. */
		go to compare;			/* Go compare criteria. */
	     end;
	     if bk_ss_$dtdsw then do;			/* Are we dumping only by dtd? */
		cutoff_time = dtd;			/* Get cutoff time. */
compare:
		if ^P_force_dump then		/* don't have to dump this branch unless ... */
		     if max (dtem, dtsm) < cutoff_time then go to skip_branch;
	     end;					/* ... it has changed since last time */

/* STORE RECORD TYPE IN PREAMBLE HEADER */

	     if bk_ss_$enforce_max_access_class | bk_ss_$enforce_min_access_class | bk_ss_$dont_dump_upgraded_dirs
		| bk_ss_$check_effective_access then
		call perform_access_checks ();	/* only returns if OK ... */

	     ix -> br (1).dump_me = "1"b;		/* Dumpable, set indicator. */
	     if ix -> br (1).dirsw then do;		/* Is this a directory? */
		dircount = dircount + 1;		/* Count directory branches. */
		bk_ss_$hp -> h.record_type = sec_dir;	/* Insert record type in header. */
	     end;
	     else bk_ss_$hp -> h.record_type = sec_seg;	/* Insert record type in header. */
	     blocks =
		min (fixed (ix -> br (1).cl, 9),
		divide (sys_info$seg_size_256K + sys_info$page_size - 1, sys_info$page_size, 17, 0));
						/* Get current length (in 1024-word blocks) */
	     nnames = fixed (ix -> br (1).nnames, 17);	/* Extract number of names. */
	     bk_ss_$hp -> h.dtd = clock ();		/* Get time this branch processed. */

/* SET UP THE PREAMBLE */

	     call old_area_ (max_length_header_area - 128, header_areap);
						/* Reset and reinitialize buffer area. */
	     call old_alloc_ (br_size, header_areap, hbp);/* Make room for branch in preamble. */
	     bk_ss_$hp -> h.bp = rel (hbp);		/* Insert pointer to it in preamble. */
	     curl = br_size;
	     hbp -> mover = ix -> mover;		/* Compute number of words taken by name array. */
	     curl = fixed (rel (addr (np -> name (nnames + 1))), 18) - fixed (rel (np), 18);
	     call old_alloc_ (curl, header_areap, hnp);	/* Make room for the names. */
	     hbp -> br (1).namerp = rel (hnp);		/* Insert pointer to name list. */
	     hnp -> mover = np -> mover;

	     if bk_ss_$namesw & bk_ss_$no_primary then do;/* put on tape name user supplied */
		bk_ss_$hp -> h.elen = length (rtrim (bk_ss_$ename));
		bk_ss_$hp -> h.ename = bk_ss_$ename;
	     end;
	     else do;
		bk_ss_$hp -> h.elen = length (rtrim (np -> name (1).string));
		bk_ss_$hp -> h.ename = np -> name (1).string;
	     end;

	     bk_ss_$hp -> h.nss_info_relp = ""b;	/* assume volid's not known */
	     bk_ss_$error = 11;			/* Enable error recovery attempt */

	     unspec (bks) = ""b;
	     bks.version = status_for_backup_version_2;

	     call hcs_$status_for_backup (bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename, addr (bks), code);
	     bk_ss_$error = 0;			/* Disable error recovery */
	     if code ^= 0 then do;
		call backup_map_$fs_error_line (code, "hcs_$status_for_backup", bk_ss_$hp -> h.dname,
		     bk_ss_$hp -> h.ename);		/* Now zero or default all fields */
		unspec (bks) = ""b;
		bks.author = "";
		bks.bc_author = "";
	     end;
	     else do;
		curl = size (bk_nss_info);
		call old_alloc_ (curl, header_areap, nssp);
		bk_ss_$hp -> h.nss_info_relp = rel (nssp);
		nssp -> bk_nss_info.version = 1;
		nssp -> bk_nss_info.lvid = bks.lvid;
		nssp -> bk_nss_info.pvid = bks.pvid;
		call mdc_$find_volname (bks.pvid, nssp -> bk_nss_info.pvname, nssp -> bk_nss_info.lvname, ignore);
		if bk_ss_$pvsw & bk_ss_$pvname ^= nssp -> bk_nss_info.pvname then go to skip_branch;
	     end;

	     if bk_ss_$upgrade_to_user_auth then	/* dump segment at user's authorization (hopefully >= access class) */
		bks.access_class = bk_ss_$user_authorization;

	     if bk_ss_$tapesw then do;
		bk_ss_$hp -> h.status_version = bks.version;
						/* pass thru version so reloader
						   knws how much to believe */
		bk_ss_$hp -> h.actime = ""b;
		bk_ss_$hp -> h.actind = ""b;
						/* with NSS, maxl on page bndry */
		bk_ss_$hp -> h.max_length = fixed (ix -> br (1).ml) * sys_info$page_size;
		bk_ss_$hp -> h.switches = bks.switches;
		bk_ss_$hp -> h.entrypt_bound = bks.entrypt_bound;
		addr (bk_ss_$hp -> h.quota) -> author = bks.author;
						/* is quota only for dir_list recs */
		bk_ss_$hp -> h.bitcount_author = bks.bc_author;
		bk_ss_$hp -> h.switches.multiple_class = bks.switches.multiple_class;
		bk_ss_$hp -> h.access_class = bks.access_class;

		bk_ss_$error = 7;			/* Enable error recovery for reading ACL. */
		if ix -> br (1).dirsw then
		     call hcs_$list_dir_acl (bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename, header_areap, aclp, null (),
			bk_ss_$hp -> h.aclc, code);
		else call hcs_$list_acl (bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename, header_areap, aclp, null (),
			bk_ss_$hp -> h.aclc, code);
		bk_ss_$error = 0;			/* Disable error recovery attempts. */
		if code ^= 0 then do;
		     call backup_map_$fs_error_line (code, "hcs_$list_acl", bk_ss_$hp -> h.dname,
			bk_ss_$hp -> h.ename);
		     if code = error_table_$noentry then go to skip_branch;
		     bk_ss_$hp -> h.aclc = 0;		/* Indicate no ACL. */
		     bk_ss_$hp -> h.aclp = ""b;
		end;
		else if bk_ss_$hp -> h.aclc > 0 then	/* Are we safe from evaluating garbage? */
		     bk_ss_$hp -> h.aclp = rel (aclp);	/* Yes, insert pointer to it. */
		bk_ss_$hp -> h.bitcnt = fixed (ix -> br (1).bc, 24);
						/* pick up segment bit count */

/* WRITE THE PREAMBLE IF A DIRECTORY -- this is the branch info for a directory */

		if ix -> br (1).dirsw then do;
		     if bk_ss_$namesw then
			cross_dump_en = A_cross_dump_en;
		     else cross_dump_en = np -> name (1).string;
		     call output (bk_ss_$hp, null, 0, code);
		     if code ^= 0 then go to terminate_dump;
		end;
		else do;				/* Non-directory segment. */
		     bk_ss_$error = 8;		/* Enable error recovery attempt. */
		     call hcs_$initiate (bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename, "", 0, 1, bk_ss_$segptr, code);
		     bk_ss_$error = 0;		/* Disable error recovery. */
		     if code ^= 0 then
			if code ^= error_table_$segknown then do;
			     call backup_map_$fs_error_line (code, "initiate", bk_ss_$hp -> h.dname,
				bk_ss_$hp -> h.ename);
			     if ^(bk_ss_$tapesw | bk_ss_$mapsw) then go to terminate_dump;
						/* Still doing anything? */
			     go to skip_branch;	/* Yes, just skip this branch. */
			end;
			else ;
		     else if ^bk_ss_$debugsw then
			call hphcs_$set_kst_attributes (binary (baseno (bk_ss_$segptr), 18), addr (ksta), (0));
						/* unless we use it treat carefully */
		     bk_ss_$wasnt_known = "1"b;	/* We have pointer to segment. */
		     curl = min (blocks * sys_info$page_size, bk_ss_$hp -> h.max_length);
						/* get length of segment in words */


/* OUTPUT PREAMBLE (branch info) AND DATA SEGMENT IF NOT A DIRECTORY */
/* NOTE: a ptr to the segment is passed to bk_output which will copy one record */
/* at a time into a one record buffer, and then write the buffer to tape. */
/* Formerly the whole segment was copied at once to the buffer, and then */
/* the whole buffer was written.  Now, if a user deletes the segment during */
/* one of the mini-copys, bk_output will write zeroes for the rest of the */
/* segment.  (Iff that happens the fault catcher will have reset bk_ss_$wasnt_known.) */
/* It is known that this strategy will cause fewer page faults on the buffer */
/* and in addition reduce backups working set.  It may also be  advantageous */
/* that page faults from disk are more spread out, rather than coming in bursts. */

/* It may be that a two record buffer would be more efficiently written to tape */
/* while still maintaining a small working set---but the needed metering */
/* has not been pursued.  REM */

		     cross_dump_en = np -> name (1).string;

		     call output (bk_ss_$hp, bk_ss_$segptr, curl, code);
						/* Write segment out. */
		     if code ^= 0 then go to terminate_dump;
		     if ^bk_ss_$wasnt_known then	/* fault & termination must have occured */
			go to terminate_branch;	/* forget about this segment */

		     bk_ss_$wasnt_known = ""b;	/* Reset indicator for safety. */
		     bk_ss_$error = 10;		/* Enable error recovery attempt. */
		     if ^bk_ss_$debugsw then call phcs_$deactivate (bk_ss_$segptr, (0));
						/* try to deactivate it */
		     call hcs_$terminate_noname (bk_ss_$segptr, code);
						/* Terminate original segment. */
		     bk_ss_$error = 0;		/* Disable error recovery. */
		     if code ^= 0 then
			call backup_map_$fs_error_line (code, "hcs_$terminate_noname", bk_ss_$hp -> h.dname,
			     bk_ss_$hp -> h.ename);
		end;

		if ix -> br (1).dirsw		/* Is this a directory? */
		     then
		     ix -> br (1).dtd = bit (bk_ss_$hp -> h.dtd, 52);
						/* Yes, stash the time the dump started. */
		else call set_dtd (bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename, bk_ss_$hp -> h.dtd, 30);
	     end;
	     if bk_ss_$mapsw then do;
		if bk_ss_$pvsw & havent_output_dirname then do;
						/* identify the directory we are in */
		     call directory_line (hdp, bk_ss_$hp -> h.dlen);
		     havent_output_dirname = "0"b;
		end;
		dtu = fixed (ix -> br (1).dtu, 52);
		if A_cross_dump_dn ^= "" then
		     temp_en = cross_dump_en;
		else temp_en = np -> name (1).string;
		call backup_map_$detail_line2 ((temp_en), blocks, RECORD_TYPE (bk_ss_$hp -> h.record_type),
		     bk_ss_$hp -> h.dtd, dtem, dtd, dtu, dtsm);
		do j = 2 to nnames;			/* Write all the entry names. */
		     if ^bk_ss_$mapsw then go to terminate_branch;
		     jx = addr (np -> name (j));
		     call backup_map_$name_line (addr (jx -> name (1).string), fixed (jx -> name (1).size, 17));
		end;
terminate_branch:
		if ^(bk_ss_$tapesw | bk_ss_$mapsw) then go to terminate_dump;
						/* Still doing something? */
	     end;
skip_branch:
	end;

/* PROCESS INFERIOR DIRECTORIES */

	if bk_ss_$restart_dumpsw & found = 2 then bk_ss_$restart_dumpsw = ""b;
						/* Finish restart for this level then normal dump */
	if bk_ss_$namesw then do;
	     if ^found_object then do;
		code = error_table_$noentry;
		call backup_map_$fs_error_line (code, "Searching for object.", bk_ss_$hp -> h.dname, bk_ss_$ename);
	     end;
	     go to terminate_dump;
	end;
	if ^bk_ss_$onlysw & dircount > 0		/* dump inferior directories */
	     then
	     call dir_scan (dircount);
dump_rtn:
	bk_ss_$err_label = sv_label;			/* restore error label */
	return;					/* Return to caller. */

/**/

/* Performs several access checks required by IMFT */

perform_access_checks:
     procedure ();

dcl  the_dirname character (168);
dcl  the_ename character (32);

dcl  (other_access_class_text, object_access_class_text) character (256);
dcl  access_class_octal character (32) aligned;
dcl  object_access_class bit (72) aligned;
dcl  (code, aim_code) fixed binary (35);
dcl  user_mode fixed binary (5);


	the_dirname = bk_ss_$hp -> h.dname;		/* makes life simpler */

	if bk_ss_$namesw & bk_ss_$no_primary then	/* use name provided by user */
	     the_ename = bk_ss_$ename;
	else the_ename = np -> name (1).string;		/* random branch in a subtree: use primary name */

	call hcs_$get_access_class ((the_dirname), (the_ename), object_access_class, code);
	if code ^= 0 then do;
	     call backup_map_$error_line (code, bk_ss_$myname, "Getting access class of ^a.",
		pathname_ (the_dirname, the_ename));
	     go to skip_branch;
	end;

	if bk_ss_$enforce_max_access_class then
	     if ^aim_check_$greater_or_equal (bk_ss_$maximum_access_class, object_access_class) then do;
		call convert_authorization_$to_string_short (bk_ss_$maximum_access_class, other_access_class_text,
		     aim_code);
		if aim_code ^= 0 then do;		/* couldn't convert it: get octal representation */
		     call convert_aim_attributes_ (bk_ss_$maximum_access_class, access_class_octal);
		     other_access_class_text = access_class_octal;
		end;
		call convert_authorization_$to_string_short (object_access_class, object_access_class_text, aim_code);
		if aim_code ^= 0 then do;		/* couldn't convert it: get octal representation */
		     call convert_aim_attributes_ (object_access_class, access_class_octal);
		     object_access_class_text = access_class_octal;
		end;
		call backup_map_$error_line (error_table_$ai_restricted, bk_ss_$myname,
		     "Access class of ^a (^[^a^;^ssystem_low^]) exceeds the maximum permitted for this dump (^[^a^;^ssystem_low^]).",
		     pathname_ (the_dirname, the_ename), (object_access_class_text ^= ""), object_access_class_text,
		     (other_access_class_text ^= ""), other_access_class_text);
		go to skip_branch;
	     end;

	if bk_ss_$enforce_min_access_class then
	     if ^aim_check_$greater_or_equal (object_access_class, bk_ss_$minimum_access_class) then do;
		call convert_authorization_$to_string_short (bk_ss_$minimum_access_class, other_access_class_text,
		     aim_code);
		if aim_code ^= 0 then do;		/* couldn't convert it: get octal representation */
		     call convert_aim_attributes_ (bk_ss_$minimum_access_class, access_class_octal);
		     other_access_class_text = access_class_octal;
		end;
		call convert_authorization_$to_string_short (object_access_class, object_access_class_text, aim_code);
		if aim_code ^= 0 then do;		/* couldn't convert it: get octal representation */
		     call convert_aim_attributes_ (object_access_class, access_class_octal);
		     object_access_class_text = access_class_octal;
		end;
		call backup_map_$error_line (error_table_$ai_restricted, bk_ss_$myname,
		     "Access class of ^a (^[^a^;^ssystem_low^]) is below the minimum permitted for this dump (^[^a^;^ssystem_low^]).",
		     pathname_ (the_dirname, the_ename), (object_access_class_text ^= ""), object_access_class_text,
		     (other_access_class_text ^= ""), other_access_class_text);
		go to skip_branch;
	     end;

	if bk_ss_$dont_dump_upgraded_dirs & (ix -> br (1).dirsw) then
	     if ^aim_check_$greater_or_equal (bk_ss_$maximum_dir_access_class, object_access_class) then do;
		call convert_authorization_$to_string_short (bk_ss_$maximum_dir_access_class, other_access_class_text,
		     aim_code);
		if aim_code ^= 0 then do;		/* couldn't convert it: get octal representation */
		     call convert_aim_attributes_ (bk_ss_$maximum_dir_access_class, access_class_octal);
		     other_access_class_text = access_class_octal;
		end;
		call convert_authorization_$to_string_short (object_access_class, object_access_class_text, aim_code);
		if aim_code ^= 0 then do;		/* couldn't convert it: get octal representation */
		     call convert_aim_attributes_ (object_access_class, access_class_octal);
		     object_access_class_text = access_class_octal;
		end;
		call backup_map_$error_line (error_table_$ai_restricted, bk_ss_$myname,
		     "Access class of ^a (^[^a^;^ssystem_low^]) exceeds the maximum permitted for a directory for this dump (^[^a^;^ssystem_low^]).",
		     pathname_ (the_dirname, the_ename), (object_access_class_text ^= ""), object_access_class_text,
		     (other_access_class_text ^= ""), other_access_class_text);
		go to skip_branch;
	     end;

	if bk_ss_$check_effective_access then do;
	     call hcs_$get_user_effmode (the_dirname, the_ename, bk_ss_$user_id, bk_ss_$user_ring, user_mode, code);
	     if code ^= 0 then do;
		call backup_map_$error_line (code, bk_ss_$myname, "Attempting to determine ^a's access to ^a.",
		     bk_ss_$user_id, pathname_ (the_dirname, the_ename));
		go to skip_branch;
	     end;
	     if ^((bit (user_mode, 5) & bit (R_ACCESS_BIN, 5)) = bit (R_ACCESS_BIN, 5)) then do;
		call backup_map_$error_line (error_table_$moderr, bk_ss_$myname,
		     "^a does not have at least ""^[s^;r^]"" access to ^a.", bk_ss_$user_id,
		     (ix -> br (1).dirsw & (ix -> br (1).bc = ""b)), pathname_ (the_dirname, the_ename));
		go to skip_branch;
	     end;

	     if ^aim_check_$greater_or_equal (bk_ss_$maximum_dir_access_class, object_access_class) then do;
		call convert_authorization_$to_string_short (bk_ss_$user_authorization, other_access_class_text,
		     aim_code);
		if aim_code ^= 0 then do;		/* couldn't convert it: get octal representation */
		     call convert_aim_attributes_ (bk_ss_$user_authorization, access_class_octal);
		     other_access_class_text = access_class_octal;
		end;
		call backup_map_$error_line (error_table_$ai_restricted, bk_ss_$myname,
		     "^a (at authorization ^[^a^;^ssystem_low^]) can not ^[examine^;read^] ^a.", bk_ss_$user_id,
		     (object_access_class_text ^= ""), object_access_class_text,
		     (ix -> br (1).dirsw & (ix -> br (1).bc = ""b)), pathname_ (the_dirname, the_ename));
		go to skip_branch;
	     end;
	end;

	return;					/* here iff everything's OK */

     end perform_access_checks;

/**/

/* SCAN INFERIOR DIRECTORIES */

dir_scan:
     procedure (dcount);

dcl  (
     dcount,
     i,
     j init (0),
     save_dlen
     ) fixed bin,					/* Additional temporary storage for dir_scan. */
     code fixed bin (35),
     (ix, jx, np) pointer,				/* Declare inside block to speed up execution. */
     save_dname character (168) aligned;		/* Temporary storage for directory path name. */

dcl  1 save (dcount) aligned,				/* One adjustable structure. */
       2 ename character (32),			/* temporary storage for directory names */
       2 dtd fixed binary (52);			/* Time directory dump began. */

dcl  1 save1 based (jx) aligned,
       2 ename character (32),			/* temporary storage for directory names */
       2 dtd fixed binary (52);
	do i = 1 to bc;				/* pick up all first directory names */
	     ix = pointer (bp, bp -> br (i).ix);	/* Get effective index. */
	     if ix -> br (1).dirsw & (ix -> br (1).dump_me | bk_ss_$pvsw) then do;
						/* Is this a dumpable directory? */
		j = j + 1;			/* Count directory names. */
		jx = addr (save (j));
		np = pointer (bp, ix -> br (1).namerp); /* get pointer to directory name array */
		jx -> save1.ename = np -> name (1).string;
						/* Pick up directory entry name. */
		jx -> save1.dtd = fixed (ix -> br (1).dtd, 52);
						/* Copy time directory dump started. */
	     end;
	end;
	save_dlen = bk_ss_$hp -> h.dlen;		/* Save current path name length. */
	save_dname = bk_ss_$hp -> h.dname;		/* Save the name. */
						/* DUMP INFERIOR DIRECTORYS */
	do i = 1 to j;
	     jx = addr (save (i));			/* Get pointer to structure element. */
	     call ioa_$rsnnl ("^a^[>^]^a", bk_ss_$hp -> h.dname, bk_ss_$hp -> h.dlen, save_dname, save_dlen ^= 1,
		jx -> save1.ename);
	     if A_cross_dump_dn = "" then
		cross_dump_dn, cross_dump_en = "";
	     else do;
		cross_dump_dn = pathname_ (A_cross_dump_dn, A_cross_dump_en);
		cross_dump_en = jx -> save1.ename;
	     end;

	     call backup_dump_recurse (cross_dump_dn, cross_dump_en, "0"b, Sfatal_error, code);
	     if code ^= 0 then do;
		A_code = code;
		go to scan_rtn;
	     end;
	     call set_dtd (save_dname, jx -> save1.ename, jx -> save1.dtd, 31);
	end;
scan_rtn:
	bk_ss_$hp -> h.dlen = save_dlen;		/* Restore directory name. */
	bk_ss_$hp -> h.dname = save_dname;
	return;
     end dir_scan;

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

set_dtd:
     procedure (dirname, ename, dtd, bk_ss_error_value);

dcl  dirname character (*) aligned parameter;
dcl  ename character (*) aligned parameter;
dcl  dtd fixed binary (52) parameter;
dcl  bk_ss_error_value fixed binary parameter;

dcl  local_code fixed binary (35);

	if ^bk_ss_$debugsw then			/* don't set DTD without hphcs_ */
	     if bk_ss_$set_dtd_explicit & bk_ss_$set_dtd then go to SET_DTD;
						/* caller asked for it */

	     else if ^bk_ss_$set_dtd_explicit & (bk_ss_$datesw | bk_ss_$dtdsw) then
						/* otherwise, only set it for incremental dumps */
		if bk_ss_$myname ^= "catchup_dump" then /* but never for catchup dumps */
		     if ^bk_ss_$no_output & bk_ss_$tapesw then do;
						/* and only if writing a tape */
SET_DTD:
			bk_ss_$error = bk_ss_error_value;
			call hphcs_$set_backup_dump_time (dirname, ename, dtd, local_code);
			bk_ss_$error = 0;
			if local_code ^= 0 then
			     call backup_map_$fs_error_line (code, "hphcs_$set_backup_dump_time", dirname, ename);
		     end;

	return;

     end set_dtd;


set_directory_dtd:					/* for backup_dump */
     entry (P_dirname, P_dtd);

dcl  P_dirname character (*) aligned parameter;
dcl  P_dtd fixed binary (52) parameter;

	begin;
dcl  dirname character (168) aligned;
dcl  ename character (32) aligned;

	     call expand_pathname_ ((P_dirname), dirname, ename, (0));
	     call set_dtd (dirname, ename, P_dtd, 30);
	end;

	return;


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

output:
     procedure (area_pointer, seg_pointer, seg_count, code);/* Compute preamble length and write record. */
dcl  (area_pointer, seg_pointer, p) pointer;
dcl  seg_count fixed bin,
     code fixed bin (35),
     n fixed bin (18);


          Sfatal_error = "0"b;
	if A_cross_dump_dn ^= "" then do;		/* fake pathname in preamble */
	     restore_dlen = area_pointer -> h.dlen;
	     restore_dn = area_pointer -> h.dname;
	     restore_elen = area_pointer -> h.elen;
	     restore_en = area_pointer -> h.ename;
	     area_pointer -> h.dname = cross_dump_dn;
	     area_pointer -> h.ename = cross_dump_en;
	     area_pointer -> h.dlen = length (rtrim (area_pointer -> h.dname));
	     area_pointer -> h.elen = length (rtrim (area_pointer -> h.ename));
	end;
	call old_alloc_ (1, addr (area_pointer -> h.list_area), p);
						/* Compute length of preamble. */
	if p ^= null then n = fixed (rel (p), 18);
	else if area_pointer = bk_ss_$hp		/* Pointer to header area */
	     then
	     n = max_length_header_area;
	else n = max_length_list_area;		/* Otherwise pointer to list area */
	call bk_output$wr_tape (area_pointer, n, seg_pointer, seg_count, code);
						/* Write the record. */
	if code ^= 0 then Sfatal_error = "1"b;

	if A_cross_dump_dn ^= "" then do;
	     area_pointer -> h.dlen = restore_dlen;
	     area_pointer -> h.dname = restore_dn;
	     area_pointer -> h.elen = restore_elen;
	     area_pointer -> h.ename = restore_en;
	end;
     end output;

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

directory_line:
     proc (P_ptr, P_len);

dcl  P_ptr ptr;
dcl  P_len fixed bin;

	if A_cross_dump_dn ^= "" then
	     call backup_map_$directory_line (addr (cross_dump_dn), length (rtrim (cross_dump_dn)));

	else call backup_map_$directory_line (P_ptr, P_len);

     end directory_line;

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

sort_small:
     proc (aap, ac);				/* Proceedure to shell sort less than 15 branches */
						/* Actually sort an array of indices of the branches */
						/* Then insert pointers in order of the sorted indices */
dcl  (aap, ap, pxk) ptr,
     (
     ac,
     count,
     d,
     i,
     j,
     k,
     n,
     xj,
     xk,
     x (14)
     ) fixed bin;

	ap = aap;					/* copy args, pointer to branch array */
	count = ac;
	if count = 1 then do;
	     ap -> br (1).ix = rel (addr (ap -> br (1)));
	     return;
	end;
	do n = 1 to count;				/* loop over all branches */
	     x (n) = n;				/* place index in index list */
	end;
	d = count;				/* initialize distance for shell sort */
	do;					/* do the shell sort */
down:
	     d = 2 * divide (d, 4, 17, 0) + 1;		/* set the distance for the sort */
	     do i = 1 to count - d;
		k = i + d;			/* higher index */
		xk = x (k);			/* index from index array */
		pxk = ptr (ap, ap -> br (xk).namerp);	/* pointer for name comparixon */
up:
		j = k - d;			/* lower index */
		xj = x (j);			/* lower index from index array */
		if ptr (ap, ap -> br (xj).namerp) -> name (1).string <= pxk -> name (1).string then go to ok;
						/* no change if ok */
		x (k) = xj;			/* swap in index array */
		k = j;				/* check next lower in steps of size d */
		if k > d then go to up;		/* if there is a lower element */
ok:
		x (k) = xk;			/* finish, put highest index in its proper place */
	     end;
	     if d > 1 then go to down;		/* sort with smaller distance */
	end;
	do i = 1 to count;				/* now thread branches according to index array */
	     xk = x (i);
	     ap -> br (i).ix = rel (addr (ap -> br (xk)));
	end;
	return;
     end sort_small;

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

/**/

%include kst_attributes;

%include bk_nss_info;
%include backup_dir_list;
%include backup_fs_times;
%include backup_preamble_header;
%include backup_record_types;
%include bk_ss_;

%include branch_status;

%include access_mode_values;

     end backup_dump_recurse;




		    backup_preattach.pl1            11/15/82  1824.4rew 11/15/82  1505.1       36072



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


backup_preattach: bpa: proc ();

/* Hack to preattach bk_ss_$data_iocb */

/* 11/18/80, WOS */

dcl  ap pointer;
dcl  al fixed bin (21);
dcl  arg char (al) based (ap);
dcl (nargs, argno) fixed bin;
dcl  code fixed bin (35);
dcl  open_mode fixed bin;
dcl  attach_desc char (512) varying;
dcl  iocbp pointer;
dcl  stream_name char (32);

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
dcl  iox_$attach_name entry (char (*), pointer, char (*), pointer, fixed bin (35));
dcl  iox_$open entry (pointer, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$close entry (pointer, fixed bin (35));
dcl  iox_$detach_iocb entry (pointer, fixed bin (35));
dcl  iox_$destroy_iocb entry (pointer, fixed bin (35));
dcl  unique_chars_ entry (bit (*)) returns (char (15));

dcl  bk_ss_$data_iocb pointer external static;
dcl  bk_ss_$preattached bit (1) aligned external static;

dcl (error_table_$badopt,
     error_table_$noarg) fixed bin (35) external static;

dcl  WHOAMI char (32) internal static options (constant) init ("backup_preattach");

dcl (addr, substr, null) builtin;

/*  */

	call cu_$arg_count (nargs, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI);
MAIN_RETURN:   return;
	     end;

	if nargs = 0 then do;
	     call com_err_ (error_table_$noarg, WHOAMI,
		"^/Usage:^-^a open_mode attach_desc^/^2x(or)^-^a -detach",
		WHOAMI, WHOAMI);
	     goto MAIN_RETURN;
	     end;

	if nargs = 1 then do;			/* Close, or something like that */
	     call cu_$arg_ptr (1, ap, al, (0));
	     if (arg = "-close") | (arg = "-detach") then do;
		if bk_ss_$preattached = "0"b then do;
NOT_PREATTACHED:	     call com_err_ (0, WHOAMI, "Backup I/O is not preattached.");
		     goto MAIN_RETURN;
		     end;

		bk_ss_$preattached = "0"b;
		if bk_ss_$data_iocb = null () then
		     goto NOT_PREATTACHED;

		call iox_$close (bk_ss_$data_iocb, (0));
		call iox_$detach_iocb (bk_ss_$data_iocb, (0));
		call iox_$destroy_iocb (bk_ss_$data_iocb, (0));
		goto MAIN_RETURN;
		end;

	     else do;
		call com_err_ (0, WHOAMI, "Unknown control function ^a.", arg);
		goto MAIN_RETURN;
		end;
	     end;

	call cu_$arg_ptr (1, ap, al, (0));		/* Get the opening mode */

	if bk_ss_$preattached then do;
ALREADY_PREATTACHED:
	     call com_err_ (0, WHOAMI, "Backup I/O is already preattached. Use ^a -detach first.", WHOAMI);
	     goto MAIN_RETURN;
	     end;

	if arg = "input" then
	     open_mode = Stream_input;
	else if arg = "output" then
	     open_mode = Stream_output;
	else do;
	     call com_err_ (0, WHOAMI, "Invalid opening mode ^a. Must be either ""input"" or ""output"".", arg);
	     goto MAIN_RETURN;
	     end;

	attach_desc = "";
	do argno = 2 to nargs;
	     call cu_$arg_ptr (argno, ap, al, (0));
	     if length (attach_desc) > 0 then
		attach_desc = attach_desc || " ";
	     attach_desc = attach_desc || arg;
	     end;

	stream_name = "backup." || unique_chars_ (""b);

	call iox_$attach_name (stream_name, iocbp, (attach_desc), codeptr (backup_preattach), code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "Cannot attach stream.");
	     goto MAIN_RETURN;
	     end;

	call iox_$open (iocbp, open_mode, "0"b, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "Cannot open stream.");
	     return;
	     end;

	bk_ss_$preattached = "1"b;
	bk_ss_$data_iocb = iocbp;

	return;

%page;
%include iox_modes;

	end backup_preattach;




		    bk_output.pl1                   03/30/87  1135.0r w 03/30/87  1054.1      151614



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



/****^  HISTORY COMMENTS:
  1) change(86-01-01,GWMay), approve(), audit(), install():
     old history comments.
     Coded February 1969, R C Daley.
     25 March 1970, R H Campbell.
     9/77 by Noel I. Morris to use tape_mult_.
     11/9/77 by Steve Herbst
     Changed to call command_query_ for tape labels 02/28/80 S. Herbst
     17 October 1980 by G. Palter to use preattached switches if requested.
     Fixed to retry correctly after open fails 06/02/81 S. Herbst
     84Feb01 by Art Beattie to allow longer tape labels to be used.
     1984-03-25, BIM: Use async mode in tape_mult_
     9 May 1985 by G. Palter to not try error_count/unmounts for preattached
     switches.
  2) change(86-06-05,GWMay), approve(86-07-07,MCR7445), audit(86-11-20,GDixon),
     install(86-11-21,MR12.0-1223):
     Moved call for "error_count" tally out of the write loop in wrbufout. The
     result will be that the tape will continue to spin until the entire buffer
     is emptied rather that synchonizing after each write. This should improve
     dump time.
     MCR7320 - added a command loop so that the operator may enter a new tape
     label id after a bad mount.  This way if the wrong tape gets mounted, the
     operator can deny the mount and give a correct tape id without stopping
     the dump.
                                                   END HISTORY COMMENTS */


/* format: style2,idind30,indcomtxt */

bk_output:
     procedure;

	dcl     uptr		        ptr;	/* ptr to user seg, or junk if we get a fault */
	dcl     temp		        fixed bin,	/* Temporary storage. */
	        code		        fixed bin (35),
	        attach_descrip	        char (168),
	        buffer		        pointer,	/* Pointer to output line buffer. */
	        line		        character (132);
						/* Output line buffer. */

	dcl     answer		        char (64) aligned varying;

	dcl     (primary_dump_tape, secondary_dump_tape)
				        static character (64),
						/* Tape labels. */
	        (iocbp1, iocbp2)	        ptr static,
	        mounted		        static bit (1) initial (""b),
						/* Flag to show tape mounted. */
	        two_tapes		        bit (1) static,
	        blanks		        char (4) static init (""),
						/* To reset tape label */
	        s			        character (1) static;
						/* To make comments plural. */

	dcl     1 header		        static,	/* Backup logical record header */
		2 zz1		        character (32) initial (" z z z z z z z z z z z z z z z z"),
		2 english		        character (56)
				        initial ("This is the beginning of a backup logical record."),
		2 zz2		        character (32) initial (" z z z z z z z z z z z z z z z z"),
		2 hdrcnt		        fixed binary,
		2 segcnt		        fixed binary;

	dcl     end_of_tape_encountered       static options (constant) char (24) initial ("End of tape encountered.");

	declare parse_tape_reel_name_	        entry (char (*), char (*)),
	        backup_map_$error_line        entry options (variable),
	        backup_map_$fs_error_line     entry (fixed bin (35), char (*), char (*), char (*)),
	        (
	        backup_map_$on_line,
	        backup_map_$tapes
	        )			        entry (pointer, fixed binary);

%include iox_dcls;

	dcl     command_query_	        entry options (variable);
	dcl     ioa_$rsnnl		        entry options (variable);

	dcl     error_table_$action_not_performed
				        fixed bin (35) ext static,
	        error_table_$dev_nt_assnd     fixed bin (35) ext static,
	        error_table_$device_end       fixed bin (35) ext static;


	dcl     (addr, addrel, divide, length, min, null, mod, rtrim, unspec)
				        builtin;

%include query_info;

%include iox_modes;

%include bk_ss_;

%include backup_control;

output_init:
     entry (ntapes, wstat);				/* entry to initialize backup output procedure */
	dcl     ntapes		        fixed bin;	/* 1 or 2 tapes */

	if bk_ss_$no_output
	then do;					/* No output */
		wstat = 0;			/* Error code to zero */
		go to exit;			/* Quit */
	     end;

	buffer = addr (line);			/* Set up pointer to output line buffer. */
	if bk_ss_$preattached
	then do;					/* caller has requested we use a specific I/O switch */
		mounted = "1"b;			/* make sure I/O gets done */
		two_tapes = "0"b;			/* act as if only a single tape is being made */
		s = " ";
		iocbp1 = bk_ss_$data_iocb;
		wstat = 0;
	     end;
	else if mounted
	then wstat = 0;				/* reset status code */
	else do;					/* Mount a new set of tapes. */
		if ntapes > 1 & ^bk_ss_$sub_entry
		then do;				/* Decide how many tapes to use. */
			two_tapes = "1"b;		/* Use two. */
			s = "s";			/* Make comments plural. */
		     end;
		else if ntapes = 1
		then do;
			two_tapes = ""b;		/* Use one. */
			s = " ";			/* Make comments singular. */
		     end;
		call mount (wstat);			/* mount first dump tape(s) */
	     end;
	if bk_ss_$mapsw
	then /* Are we writing a map? */
	     if wstat = 0
	     then do;				/* Yes, did we succeed in attaching the tape(s)? */
		     if two_tapes
		     then /* Are we writing two tapes? */
			call ioa_$rsnnl ("Primary tape label: ^a, secondary tape label: ^a.", line, temp,
			     primary_dump_tape, secondary_dump_tape);
		     else call ioa_$rsnnl ("Tape label: ^a.", line, temp, primary_dump_tape);
		     call backup_map_$tapes (buffer, temp);
						/* Write the comment in the map. */
		end;
	go to exit;

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

output_finish:
     entry;					/* to terminate backup dump */

	if bk_ss_$no_output
	then go to exit;				/* No output so quit. */

	buffer = addr (line);			/* Set up pointer to output line buffer. */
	if bk_ss_$preattached
	then ;					/* nothing to do here */
	else if bk_ss_$holdsw
	then do;
		call iox_$control (iocbp1, "error_count", addr (temp), code);
		if code ^= 0
		then do;				/* All OK? */
flush_error:
			call backup_map_$fs_error_line (code, "bk_output", "", "");
unmo:
			call unmount;		/* Unmount the tape anyway. */
		     end;
		if mounted
		then if two_tapes
		     then do;			/* Is the other tape mounted? */
			     call iox_$control (iocbp2, "error_count", addr (temp), code);
			     if code ^= 0
			     then go to flush_error;	/* OK? */
			end;
	     end;
	else call unmount;				/* unmount any reel(s) still mounted */
	go to exit;

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

wr_tape:
     entry (lblptr, lblcnt, segptr, segcnt, wstat);	/* to write next backup record on tape */

	dcl     lblptr		        pointer,	/* pointer to preamble area */
	        lblcnt		        fixed binary,
						/* length of preamble in words */
	        segptr		        pointer,	/* pointer to segment (if any) */
	        segcnt		        fixed binary,
						/* length of segment (if any) in words */
	        wstat		        fixed bin (35);
						/* status code (returned) */

	uptr = segptr;				/* copy this arg so we can mung it if err */
	if bk_ss_$no_output
	then do;					/* No output */
		wstat = 0;			/* Zero error code */
		go to exit;
	     end;

	if ^mounted
	then do;
		wstat = error_table_$dev_nt_assnd;
		go to exit;
	     end;
	wstat = 0;
	buffer = addr (line);			/* Set up pointer to output line buffer. */
	header.hdrcnt = lblcnt;			/* pick up preamble length */
	header.segcnt = segcnt;			/* and segment length */
retry:
	call wrout (addr (header), 32);		/* write out backup logical record header */
	if code = error_table_$device_end
	then go to enderr;				/* Check end of reel */
	if code ^= 0
	then go to tsterr;
	temp = header.hdrcnt + 32 + 255;		/* adjust to write preamble thru next higher block */
	temp = temp - mod (temp, 256) - 32;		/* 32 words are already written. */
	call wrout (lblptr, temp);			/* write out preamble thru next higher 256-word block */
	if code = error_table_$device_end
	then go to enderr;				/* Check end of reel */
	if code ^= 0
	then go to tsterr;
	if header.segcnt > 0
	then do;					/* Is there any segment to write? */
		temp = header.segcnt;
		call wrbufout (uptr, temp);		/* write out segment thru next higher 256-word block */
		if code = error_table_$device_end
		then go to enderr;			/* Check end of reel */
		if code ^= 0
		then go to tsterr;
	     end;
exit:
	return;					/* exit to caller */
enderr:
	call backup_map_$on_line (addr (end_of_tape_encountered), length (end_of_tape_encountered));
	go to unm;				/* Go get new reel */
tsterr:
	call backup_map_$fs_error_line (code, "bk_output", "", "");

unm:
	if bk_ss_$preattached
	then do;					/* preattached => not using tapes => can't unmount anything */
		wstat = code;
		go to exit;
	     end;

	call unmount;				/* unmount current tape(s) */
	call output_init (-1, wstat);			/* mount next reel(s) */
	if wstat = 0
	then go to retry;
	go to exit;				/* go to exit to caller on operator message */

get_label:
     procedure (type, label, Squit_the_dump);		/* Procedure to read label typed on console. */
	dcl     type		        character (*),
						/* Type of tape (primary or secondary). */
	        label		        character (64),
						/* The label. */
	        Squit_the_dump	        bit (1) aligned;


	Squit_the_dump = "0"b;
	unspec (query_info) = "0"b;
	query_info.version = query_info_version_4;
	query_info.suppress_name_sw = "1"b;
	query_info.question_iocbp, query_info.answer_iocbp = null;
	call command_query_ (addr (query_info), answer, bk_ss_$myname, "Type ^a dump tape label:", type);
	label = answer;

	if label = "quit" | label = "q"
	then Squit_the_dump = "1"b;

	else do;
		if ^bk_ss_$debugsw
		then /* caller wants privilege */
		     label = rtrim (label) || ",sys";
	     end;
	return;
     end get_label;

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

mount:
     procedure (mount_status);			/* internal procedure to mount first or next reel(s) */
	dcl     mount_status	        fixed bin (35);
	dcl     Squit_the_dump	        bit (1) aligned;

	mount_status = 0;
	mounted = "0"b;
	Squit_the_dump = "0"b;
	iocbp1, iocbp2 = null;

	do while (^mounted & ^Squit_the_dump);
	     if bk_ss_$sub_entry
	     then /* get first tape label from tape_entry */
		call bk_ss_$control_ptr -> backup_control.tape_entry (primary_dump_tape);
	     else /* else read it from the terminal */
		call get_label ("primary", primary_dump_tape, Squit_the_dump);

	     call mount_tape (Squit_the_dump, iocbp1, "bk_output_1", primary_dump_tape, mount_status);
	end;					/* Do we need another tape? */
	if two_tapes & mounted & mount_status = 0
	then do;
		mounted = "0"b;
		do while (^mounted & ^Squit_the_dump);
		     call get_label ("secondary", secondary_dump_tape, Squit_the_dump);

		     call mount_tape (Squit_the_dump, iocbp2, "bk_output_2", secondary_dump_tape, mount_status);
		end;
	     end;
	return;


mount_tape:
     proc (Squit, Piocb, switch_name, tape_id, code);

	dcl     Squit		        bit (1) aligned,
	        Piocb		        ptr,
	        switch_name		        char (11),
	        tape_id		        char (64),
	        code		        fixed bin (35);

	code = 0;

	if Squit
	then do;
		code = error_table_$action_not_performed;
		call backup_map_$error_line (code, "bk_output", "Aborted tape mount.");
		if iocbp1 ^= null
		then do;
			call iox_$close (iocbp1, (0));
			call iox_$detach_iocb (iocbp1, (0));
		     end;
		return;
	     end;

	call parse_tape_reel_name_ (tape_id, attach_descrip);
	call iox_$attach_name (switch_name, Piocb, "tape_mult_ " || attach_descrip || " -write", null (), code);
						/* null refptr to use user-supplied tape_mult_ */
	if code ^= 0
	then call backup_map_$fs_error_line (code, "bk_output", tape_id, "");
	else do;
		call iox_$open (Piocb, Stream_output, "0"b, code);
		if code = 0
		then mounted = "1"b;
		else do;
			call backup_map_$fs_error_line (code, "bk_output", tape_id, "");
			code = 0;
			call iox_$detach_iocb (Piocb, code);
			if code ^= 0
			then call backup_map_$fs_error_line (code, "bk_output", tape_id, "");
		     end;
	     end;
	if code = 0
	then call iox_$modes (Piocb, "async", (""), (0));

	return;
     end mount_tape;
     end mount;

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

wrbufout:
     proc (wrptr, wrcnt);				/* internal proc to write user seg to tape */
	dcl     wrptr		        ptr;
	dcl     wrcnt		        fixed bin;
	dcl     ttbuf		        (words_to_write) fixed bin (35) aligned based;
	dcl     zzbuf		        (1024) fixed bin (35) aligned based;
	dcl     xptr		        ptr;
	dcl     words_to_go		        fixed bin;
	dcl     words_to_write	        fixed bin;
	dcl     save_err_label	        label;
	dcl     EC		        fixed bin (35);
						/* control order puts count of errors here */

	save_err_label = bk_ss_$err_label;		/* remember err recovery location */
	bk_ss_$err_label = wbo_clean;			/* and set up to recover here */

	words_to_go = wrcnt;
wbo_retry:					/* come here from wbo_clean */
	xptr = wrptr;
	do while (words_to_go > 0);

	     words_to_write = min (1024, words_to_go);	/* one page at most */
						/* then copy a page of users seg */
	     if wrptr ^= bk_ss_$sp
	     then do;				/* if not already recovering from an error */
		     if words_to_write ^= 1024
		     then /* if not copying whole page */
			unspec (bk_ss_$sp -> zzbuf) = ""b;
						/* clear the buffer */
		     bk_ss_$error = 9;		/* then copy the user's page */
		     bk_ss_$sp -> ttbuf = xptr -> ttbuf;/* if fault then will go to wbo_clean */
		     bk_ss_$error = 0;		/* make faults fatal again */
		end;

	     words_to_write = 256 * divide (words_to_write + 255, 256, 17, 0);
						/* write mod 256 */
	     call iox_$put_chars (iocbp1, bk_ss_$sp, words_to_write * 4, code);
	     if two_tapes & code = 0			/* two_tapes is only true when not preattached */
	     then call iox_$put_chars (iocbp2, bk_ss_$sp, words_to_write * 4, code);
	     if code ^= 0
	     then go to wbo_ret;

	     xptr = addrel (xptr, words_to_write);	/* step thru user's seg */
	     words_to_go = words_to_go - words_to_write;	/* account for stuff just written */
	end;

wbo_ret:
	if ^bk_ss_$preattached & (code = 0)		/* preattached => not using tapes => no error_count order */
	then do;
		call iox_$control (iocbp1, "error_count", addr (EC), code);

		if two_tapes & code = 0
		then call iox_$control (iocbp2, "error_count", addr (EC), code);
	     end;

	bk_ss_$err_label = save_err_label;		/* restore error recovery location */
	return;					/* and return */

wbo_clean:					/* This handles faults taken on user's seg */
	unspec (bk_ss_$sp -> zzbuf) = ""b;		/* clear it */
	wrptr = bk_ss_$sp;				/* Forget user seg, set flag thatwr're recovering */
	bk_ss_$err_label = save_err_label;		/* We are no longer interested in faults */

	go to wbo_retry;				/* Go write zeroes onto tape as needed */

     end wrbufout;

/* -------------------------------------------------------- */

wrout:
     procedure (wrptr, wrcnt);			/* internal procedure to write on current tape(s) */
	dcl     wrptr		        pointer,	/* write workspace pointer */
	        wrcnt		        fixed binary;
						/* no. of words to write */
	call iox_$put_chars (iocbp1, wrptr, wrcnt * 4, code);
	if two_tapes
	then if code = 0
	     then /* Even if two don't bother if previous in error. */
		call iox_$put_chars (iocbp2, wrptr, wrcnt * 4, code);
						/* Write second tape. */
     end wrout;

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

unmount:
     procedure;					/* internal procedure to unmount current reel(s) */
	if ^mounted
	then return;

	call iox_$close (iocbp1, code);
	if code ^= 0
	then call backup_map_$fs_error_line (code, "bk_output", primary_dump_tape, "");
	call iox_$detach_iocb (iocbp1, code);
	if code ^= 0
	then call backup_map_$fs_error_line (code, "bk_output", primary_dump_tape, "");
	if two_tapes
	then do;					/* Is another tape attached? */
		call iox_$close (iocbp2, code);
		if code ^= 0
		then /* Give error comment if close not OK. */
		     call backup_map_$fs_error_line (code, "bk_output", secondary_dump_tape, "");
		call iox_$detach_iocb (iocbp2, code);
		if code ^= 0
		then /* Give error comment if detach not OK. */
		     call backup_map_$fs_error_line (code, "bk_output", secondary_dump_tape, "");
	     end;
	call backup_map_$tapes (addr (blanks), 4);	/* Reset label info in map header */
	mounted = "0"b;
	iocbp1, iocbp2 = null;

     end unmount;
     end bk_output;




		    list_err.pl1                    11/15/82  1824.4rew 11/15/82  1505.2      174267



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


list_err:       proc;
/*  This program will scan the error file and list, by user within group  */
/*  which programs MULTICS was not able to access for backup purposes.    */



dcl erfil char(32);
dcl argptr ptr;
dcl arglen fixed bin;
dcl arg_string char (arglen) based (argptr);


/*  ios_declarations  */

dcl ios_$attach           entry (char(*), char(*), char(*), char(*), bit(72) aligned);
dcl hcs_$status_          entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));
dcl 1 branch aligned,
      (2 type bit(2),
       2 nnames bit (16),
       2 nrp bit (18),
       2 dtm bit (36),
       2 dtu bit (36),
       2 mode bit (5),
       2 pad1 bit (13),
       2 records bit (18)) unaligned;


dcl ioa_                  entry options (variable);
dcl date_time_$fstime     entry (bit(36), char(*));
dcl ios_$read             entry (char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned);
dcl ioa_$ioa_stream       entry options (variable);
dcl ios_$detach           entry (char(*), char(*), char(*), bit(72) aligned);
dcl hcs_$status_minf      entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
dcl com_err_              entry options (variable);
dcl get_wdir_             entry returns (char(168));

dcl cu_$arg_ptr           entry (fixed bin, ptr, fixed bin, fixed bin(35));
dcl expand_path_          entry (ptr, fixed bin(17), ptr, ptr, fixed bin(35));
dcl cu_$arg_count         entry (fixed bin);


/*  data items  */

dcl (tproj, tname, name_hold) char (32) varying,
    chase fixed bin(1),
    (eptr, nreap) ptr,
    string char(24),


nargs fixed bin,

    (tprog, namep) char(168),
    dirctp char(168) aligned,

     real_proj char (tp_len) based (addr (tproj)),
     real_name char (tn_len) based (addr (tname)),
    (tp_len, tn_len, tleng, str_len, entree) fixed bin (8),
    (msg_start, msg_end, msg_length, line_len) fixed bin (8),
    (scode, code) fixed bin (35),
          fulpath char(168),
     sp_line char (120),
    (die, ab) fixed bin (1),
    (bufptr, pnamep, dirp, enamep) ptr,
     nl char (1) aligned static init ("
"),
     nareap fixed bin (24),
     pnamel fixed bin (17),
     working_dir char (168),
    (stch1, stch2, stch3) fixed bin,			/* used to segment the input line */
     EOF bit (1),					/* end of file indicator          */
     chstr char (4) aligned,				/* check for a normal line        */
     outstr char (168) aligned init ("OUT"),
     error_table_$noentry external fixed bin (35),
     error_table_$no_dir  external fixed bin (35),
    (tmesg, tpath) char (168),
    (status, ostatus) bit (72) aligned,			/* did the read or write go OK? */
     nelemt fixed bin (17),				/* number of elements read in     */
    (temp1, temp2, temp3) char (100),			/* line segmentation areas        */
     lin char (400) aligned;				/* input line                     */


/*  built in functions  */

dcl (addr, init, null, before, fixed, length, index, substr) builtin;


/*  I/O status bits  */

dcl 1 sbits aligned based (addr (status)),
    (2 code bit (36),
    2 pad bit (9),
    2 eof bit (1),					/* end of file bit                */
    2 pd2 bit (29)) unal;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  Initialize the end-of-file switch to zero.  Check the number of arguments passed.  If this number is     */
/*  greater or less than one, the wrong no. of arguments have been passed to this program.  In this case     */
/*  an error message is sent and the program suicides.                                                       */
/*									                   */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



setup:
	name_hold = "";
          EOF = "0"b;
          call cu_$arg_count (nargs);
          if nargs ^= 1 then do;
               call ioa_ ("list_err:  Wrong number of arguments.");
               return;
          end;
          call cu_$arg_ptr (1, argptr, arglen, code);
          erfil = arg_string;




/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  Set up the parameters for a call to expand_path_:  a ptr to the path name, the path name length,         */
/*  a ptr to a place to put the expanded directory name, and a ptr to a place to put the expanded entry name.*/
/*  Set up the buffer ptr for ios_$read, set off the "strange_line" switch and blank out the temporary       */
/*  storage areas for the message and the path name.                                                         */
/*							                                       */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



          pnamep = addr (erfil);
          pnamel = length (erfil);
	dirp = addr (dirctp);
	enamep = addr (namep);
	bufptr = addr (lin);
	ab = 0;
	tmesg = " ";
	tpath = " ";
          erfil = before (erfil, " ");
          fulpath = (">udd>SysDaemon>error_file>"||erfil);
          fulpath = before (fulpath, " ");




/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  Attempt to expand the path name of the erfil to an absolute path name.  If the attempt fails, a request  */
/*  is sent to the user to check the path name and try again and the program suicides.                       */
/*                                                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

          call expand_path_ (pnamep, pnamel, dirp, enamep, code);
          if code ^= 0 then do;
               call com_err_ (code, "list_err", "Error in input file name.");
               return;
          end;

          fulpath = (before (dirctp, " ")||">"||erfil);





/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  Using the absolute path name, attempt to attach a stream in order to read the erfil.  If the attach fails*/
/*  then the processing cannot continue and the program suicides, issuing the appropriate message.           */
/*                                                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */




          call ios_$attach ("my_input", "file_", fulpath, "r", status);
	if sbits.code ^= "0"b then do;
	     code = fixed (sbits.code);
               call com_err_ (code, "list_err", "Attach failed.");
	     go to suicide;
	end;







/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  THIS IS THE START OF THE MAIN LOOP WHICH CYCLES THROUGH THE ERFIL, PROCESSING ONE ENTRY AT A TIME.       */
/*                                                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



          do while (EOF = "0"b);





/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  Blank out the buffer which holds the input line and read a new input line into it.  If there was an      */
/*  error in the read, put out an IO error message and try the next one.  Otherwise pick up the line length  */
/*  from the nelemt parameter of ios_$read.                                                                  */
/*                                                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



read:          lin = " ";
               call ios_$read ("my_input", bufptr, 0, 168, nelemt, status);
               EOF = sbits.eof;
               if sbits.code ^= "0"b & EOF = "0"b then do;
                    code = fixed (sbits.code);
                    call com_err_ (code, "list_err", "IO error.  Please retry.");
                    go to suicide;
               end;
               line_len = nelemt;




/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  Divide the input line into the message and the path name.  If the message is Entry not found, ignore     */
/*  this particular line and go to get the next one.  If there is a different message, save it in tmesg then */
/*  pick up the path name and save it in tpath.                                                              */
/*                                                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



line_div:      entree = index (lin, "Entry not found.");
               if entree = 0 then do;
                    msg_start = index (lin, ":");
                    msg_end = index (lin, ">");
                    if msg_start ^= 0 then do;
                         msg_length = (msg_end - msg_start) -3;
                         tmesg = substr (lin, (msg_start + 2), msg_length);
                         tpath = substr (lin, msg_end, (line_len - msg_end));
                    end;





/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  Check the directory for the standard user_dir_dir.  If this is some other directory, then we don't       */
/*  know what to do with it and the whole line will be written unparsed into a segment called strange line.  */
/*  If, however this is a user_dir_dir directory, we will pick out the user and the project names and put    */
/*  them in tname and tproj respectively.                                                                    */
/*                                                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



                    chstr = substr (tpath, 2, 4);
                    if chstr = "user" then do;
norm:                    tleng = length (tpath);
                         temp1 = substr (tpath, 15, (tleng - 14));
                         stch1 = index (temp1, ">");
		     if stch1 = 0 then do;
			stch1 = index (temp1, " ");
			tproj = substr (temp1, 1, (stch1-1));
			tname = "no_userid";
		     end;
		     else do;
                         tproj = substr (temp1, 1, (stch1 - 1));
                         str_len = length (temp1);
                         temp2 = substr (temp1, (stch1 + 1), (str_len - (stch1 + 1)));
                         stch2 = index (temp2, ">");
                         if stch2 = 0 then stch2 = index (temp2, " ");
                         tname = substr (temp2, 1, (stch2 - 1));
		     end;
                    end;
                    else do;
                         tname = "strange";
                         tproj = "line";
                         ab = 1;
                    end;












/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  If the current name is different from the previous one, detach the stream of the current                 */
/*  output segment.  Pick up the length of the new name and project and adjust the size of the               */
/*  name and project variables accordingly.                                                                  */
/*                                                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



		if tname ^= name_hold then do;
old_seg:                 call ios_$detach ("outstr", "", "", ostatus);
new_seg:		     tp_len = index (tproj, " ");






/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  Attempt to attach a stream for processing this segment.  If the attach is successful, see if this        */
/*  segment is being attached for the first time.  If it is a new segment, output as the first line, a       */
/*  header explaining that the system was unable to backup the segment.  If this is an old segment, bypass   */
/*  header output.  If the attempt to attach failed, go to get the next erfil entry for processing.          */
/*                                                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



                                    working_dir = ">udd>SysDaemon>error_file";
                                    call hcs_$status_minf (working_dir, ("EF."||tname||"."||tproj), 1b, 01b,
                                         nareap, scode);
                                    if scode = error_table_$no_dir then do;
                                         call com_err_ (scode, "list_err", "No directory >udd>SysDaemon>error_file.");
                                         return;
                                    end;
                                    call ios_$attach
                                     ("outstr", "file_", (">udd>SysDaemon>error_file>"||"EF."||tname||"."
                                      ||tproj), "w", status);
                                    if sbits.code ^= "0"b then do;
                                         call com_err_ (ostatus, "list_err", "Attach failed ^a ^a", tname, tproj);
                                         return;
                                    end;
                         if ab ^= 1 then do;
                              nreap = null;
                              chase = 0;
                              eptr = addr(branch);
                              call hcs_$status_ (">udd>SysDaemon>error_file", erfil, chase, eptr, nreap, code);

                              call date_time_$fstime (branch.dtm, string);
                              call ioa_$ioa_stream
                          ("outstr", "The system was unable to access these entries for backup at ^a.", string);
                     end; 
                    end; 






/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  Set up an output buffer containing the full line in case it is needed.  If the strange line switch is on */
/*  output the full line in the segment called strange^line.  Otherwise, output the name, proj, message and  */
/*  path name in that order.  Set off the strange line switch.  Store the current name in name_hold for      */
/*  comparison with the next name picked up in tname.                                                        */
/*                                                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



line_out: 	sp_line = substr (lin, 1, 120);
		if ab = 1 then call ioa_$ioa_stream ("outstr", sp_line);
                    else call ioa_$ioa_stream ("outstr", "^a^x^a", tmesg, tpath);
                    ab = 0;
                    name_hold = tname;







/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  THIS IS THE END OF THE MAIN LOOP.                                                                        */
/*                                                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



	     end;





/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  Clear all the work areas in preparation for the next line to be processed.                               */ 
/*                                                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



re_init:       temp1 = " ";
	     temp2 = " ";
	     temp3 = " ";
	     tprog = " ";
	     tname = " ";
	     tproj = " ";
	     tmesg = " ";
	     tpath = " ";
	     sbits.eof = "0"b;
	end;





/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */
/*  Make sure that both the input and the output streams are detached before quitting and then quit.         */
/*                                                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



cleanup:  call ios_$detach ("my_input", "", "", status);
          call ios_$detach ("outstr", "", "", ostatus);
suicide:  end;




		    mail_errfiles.pl1               10/28/88  1411.9r w 10/28/88  1302.3      143667



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


mail_errfiles:           proc;

/*     ENTRY DECLARATIONS     */

dcl  get_wdir_ entry returns (char (168));		/* wdir of err segs */
dcl  (temp_string1, temp_string) char(32);
dcl  hcs_$star_ entry (char (*) aligned, char (*) aligned, fixed bin (2), ptr,
     fixed bin, ptr, ptr, fixed bin (35));		/* names of err segs */
dcl  hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)); /* mailbox accessable ? */
dcl  delete_$path entry (char (*) aligned, char (*), bit (6), char (*), fixed bin (35));
dcl  continue_to_signal_  entry (fixed bin(35));
dcl  find_condition_info_ entry (ptr, ptr, fixed bin(35));
dcl  ioa_$ioa_stream      entry options (variable);
dcl  com_err_ entry options(variable);
dcl  mailbox_$close entry(fixed bin,fixed bin(35));
dcl  mailbox_$get_mode_index entry(fixed bin,bit(*)aligned,fixed bin(35));
dcl  mailbox_$open entry(char(*)aligned,char(*)aligned,fixed bin,fixed bin(35));
dcl  mail entry options(variable);			/* new mail, ring 1 mailboxes */
dcl  old_mail entry options(variable);			/* old mail, "mailbox" segments */
dcl  hcs_$terminate_noname
     entry (ptr, fixed bin (35));			/* mail went OK         */
dcl  dprint_ entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35));
dcl  get_system_free_area_
     entry returns (ptr);				/* for hcs_$star        */
dcl  hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*), fixed bin (24),
     fixed bin (2), ptr, fixed bin (35));		/* find mailbox of err causer */
dcl  hcs_$delentry_seg entry (ptr, fixed bin (35));	/* no access, scratch err seg */

/*     BUILTIN FUNCTIONS     */

dcl (addr, after, before, null, substr) builtin;

/*     BASED STRUCTURES     */

dcl 1 box based (p) aligned,				/* mailbox structure    */
    2 lock bit (36) aligned,
    2 nchr fixed bin,
    2 nmsg fixed bin,
    2 lins fixed bin,
    2 secret fixed bin,
    2 pad (3) fixed bin,
    2 b,
      3 yte (1000) bit (9) unaligned;

dcl 1 in based (p) aligned,				/* used by initiate_seg    */
    2 put (1000)bit (9) unaligned;


% include dprint_arg;
dcl 1 entries (encount) aligned based (eptr),		/* for hcs_$star        */
    2 type bit (2) unaligned,
    2 nname bit (16) unaligned,
    2 nindex bit (18) unaligned;

/*     MISCELLANEOUS DATA ITEMS AND POINTERS     */

dcl  names (0:100) char (32) aligned based (nptr);	/* EF seg names from list_err */
dcl  areap ptr init (null);				/* ptr to sys free area         */
dcl  encount fixed bin (17);				/* no of err seg names        */
dcl  mseg_index fixed bin(17) init(0);			/* index of ring 1 mailbox */
dcl (eptr, delptr, nptr) ptr init (null);		/* miscellaneous pointers       */
dcl  xmode bit(36) aligned;				/* extended access on ring 1 mailbox */
dcl  star_arg char (6) aligned init ("EF.**");		/* indicates all segs beg w EF. */
dcl  mode fixed bin (5);				/* access mode                  */
dcl  bmode bit (36) based (addr (mode));		/* for testing mode             */
dcl  ind fixed bin;					/* index of no of EF. segs      */
dcl  dptr ptr init (null);				/* ptr to dprint buffer         */
dcl  dir_name char(168) aligned int static		/* directory in which to look for errfiles */
	init(">udd>SysDaemon>error_file");
dcl  code fixed bin (35);				/* std error code ind           */
dcl dirp char(168) aligned;				/* mailbox dirname */
dcl  p ptr init (null);
dcl enamep char(32) aligned;				/* mailbox entry name */
dcl  ec fixed bin (35);				/* std sys err code             */
dcl  bitct fixed bin (24);				/* bitct of err causers mailbox */
dcl (this_seg, cur_seg) char (70);			/* name of seg in my directory  */
dcl  cur_name char (22) aligned;			/* err causers name             */
dcl  error_table_$noentry fixed bin (35) ext;		/* in case no mailbox           */
dcl  error_table_$no_dir fixed bin (35) ext;		/* sm dir in pth nm not spec    */
dcl  error_table_$no_info fixed bin (35) ext;		/* not enuf acc to rtn any info */
dcl  cur_proj char (9) aligned;			/* err causers proj             */
dcl  my_path char (168) aligned;			/* pathname of seg in my wdir   */
dcl  any_other condition;

/*     BEGIN PROGRAM EXECUTION     */



/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */ 
/*  Initialize all the components of the dprint_arg structure                                                */
/*                                                                                                           */ 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */


          dpap = addr (dprint_arg_buf);                     /* set ptr to the dprint_ args  */
          dpap -> dprint_arg.version = 1;                   /* the version no is one        */
          dpap -> dprint_arg.copies  = 1;                   /* only one copy                */
          dpap -> dprint_arg.delete  = 1;                   /* dprint and delete the seg    */
          dpap -> dprint_arg.queue   = 3;                   /* no hurry, so print in Q 3    */
          dpap -> dprint_arg.pt_pch  = 1;                   /* print it don't punch it      */
          dpap -> dprint_arg.notify  = 1;                   /* don't bother to notify       */
          dpap -> dprint_arg.output_module = 1;             /* tell again to print not punch*/
          dpap -> dprint_arg.class   = "printer";           /* make it perfectly clear      */



/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */ 
/*  Get the name of the wdir containing the backup dump exceptions processed by list_err                     */
/*  Pick up any segment names beginning with EF. and store them in the variable 'names where they will       */
/*  be processed one at a time.  if there are no EF. segments today then quit till tomorrow                  */
/*                                                                                                           */ 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

          areap = get_system_free_area_ ();
          call hcs_$star_ (dir_name, star_arg, 11b, areap, encount, eptr, nptr, code);
          if code ^= 0 then do;
               call com_err_ (code, "mail_errfiles", "Error in obtaining error segments.");
               go to fin;
          end;



/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */ 
/*  For each un backed up segment, pick up the name, strip off the EF. prefis and parse out                  */
/*  the name and the project.                                                                                */
/*                                                                                                           */ 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

          do ind = 1 to encount;
               this_seg = nptr -> names (ind-1);
	     my_path = before(dir_name," ")||">"||this_seg;
               cur_seg = after (this_seg, "EF.");
               temp_string = cur_seg;
               do while (index (temp_string, ".") ^= 0);
                    temp_string1 = before (temp_string, ".");
                    temp_string = after (temp_string, ".");
               end;
                    cur_name = temp_string1;
                    cur_proj = temp_string;



/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */ 
/*  Check to see if this is the segment named EF.strange^line which is the storage place that list_err       */
/*  uses for all lines in the backup dump which it cannot recognize as normal processing.                    */
/*  If this is the strange^line segment it is bypassed and left in the directory so that it can be           */
/*  dprinted and examined for any serious problems.                                                          */
/*                                                                                                           */ 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

             if cur_name = "strange" then go to fin;


/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */ 
/*  Look for a ring 1 mailbox to mail this segment to. If mail cannot be sent to a ring 1 mailbox for any   */
/*  reason, either because no such mailbox exists or because of insufficient access, try sending to an old  */
/*  mailbox. If there is not enough information available to say whether an old mailbox exists,             */
/*  then assume that the receiver doesn't want to know about his un backed up segments and delete the        */
/*  segment from the wdir.  If there is no mailbox or if some directory in the pathname is missing, then     */
/*  dprint the segment and go get the next one if any.                                                       */
/*                                                                                                           */ 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

	     on condition(any_other) call default_handler;
               dirp = ">udd>"||before (cur_proj, " ")||">"||before (cur_name, " ");
               enamep = before(cur_name," ")||".mbx";
	     call mailbox_$open(dirp,enamep,mseg_index,code);
	     if mseg_index=0 then do;			/* can't send to new mailbox */

try_old:		enamep = "mailbox";
		call hcs_$initiate_count (dirp, enamep, "", bitct, 1, p, ec);
		if p=null then do;

		     if ec = error_table_$no_info then go to del_seg;
		     else if ec = error_table_$noentry | ec = error_table_$no_dir then do;
print_it:
			dpap -> dprint_arg.dest = cur_proj;
			dpap -> dprint_arg.heading = cur_name;

			call dprint_ (dir_name, ("EF."||before(cur_name, " ")||"."||cur_proj), dpap, code);
			go to fin;
		     end;



/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */ 
/*  If there is a null pointer where the mailbox pointer should be then call com_err_ to say why and go      */
/*  to get the next entry.  If there is a valid pointer, check to see if we have access.  If we have been    */
/*  refused access assume the potential receiver doesn't want to hear from us and delete the segment         */
/*  and go get the next one.                                                                                 */
/*                                                                                                           */ 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

	               call com_err_ (ec, "mail_errfiles", "Null pointer returned to mailbox ^a>^a",dirp,enamep);
	               go to fin;
		end;
		call hcs_$fs_get_mode (p, mode, code);
		if ^substr (bmode, 33, 1) | ^substr (bmode, 35, 1) then do;

		     call hcs_$terminate_noname(p,code);
del_seg:
		     call delete_$path (dir_name, this_seg, "000100"b, "mail_errfiles", code);
		     if code ^= 0 then
		          call com_err_ (code, "mail_errfiles", "Unsuccessful delete attempt of seg", "^a", my_path);
		     go to fin;
		end;





/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*                                                                                                           */ 
/*  When we finally have access, see first if this is a real mailbox.  If it is not, go dprint               */
/*  the segment instead.  If this is a real mailbox, mail the segment at last, and go get the next           */
/*  one , if any.                                                                                            */
/*                                                                                                           */ 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

		if bitct > 0 then if p -> box.secret ^= 2962 then do;
                                 call hcs_$terminate_noname (p, code);
                                 go to print_it;
		end;
		call old_mail (my_path, before(cur_name, " "), before(cur_proj, " "));
		call hcs_$terminate_noname (p, ec);
		p = null;
	     end;


/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *  */
/*										  */
/*  There is a ring 1 mailbox. Check extended access and if insufficient, go back and try old mail.   */
/*  If we have append extended access (first bit), send mail and close the mailbox.		  */
/*										  */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *  */


	     else do;
		call mailbox_$get_mode_index(mseg_index,xmode,ec);
		if ec^=0 | ^substr(xmode,1,1) then do;
		     call mailbox_$close(mseg_index,code);
		     go to try_old;
		end;

		call mail (my_path,before(cur_name," "),before(cur_proj," "));
		call mailbox_$close(mseg_index,code);
	     end;
fin:	end;

default_handler:     proc;

dcl 1 cond_info      aligned,
      2 mcptr                 ptr,
      2 version               fixed bin,
      2 condition_name        char(32) varying,
      2 infop                 ptr,
      2 wcptr                 ptr,
      2 loc_ptr               ptr,
      2 flags        aligned,
        3 crawlout            bit(1) unal,
        3 pad1                bit(35) unal,

      2 pad_word              bit(36) aligned,
      2 user_loc              ptr,
      2 pad(4)                bit(36) aligned;


call find_condition_info_ (null, addr(cond_info), code);
if code ^= 0 then do;

     call ioa_$ioa_stream ("error_output", "Error: Unknown signal has been received.");
     return;
end;

if cond_info.condition_name = "alrm" then do;

continue:
     call continue_to_signal_ (code);
     return;
end;

if cond_info.condition_name = "cput" then go to continue;
if cond_info.condition_name = "linkage_error" then go to continue;
if cond_info.condition_name = "mme2" then go to continue;
if cond_info.condition_name = "quit" then go to continue;
if cond_info.condition_name = "command_error" then go to continue;
if cond_info.condition_name = "finish" then go to continue;
if cond_info.condition_name = "stack" then go to continue;
if cond_info.condition_name = "program_interrupt" then return;

call hcs_$terminate_noname (p, code);
go to fin;

end default_handler;


/*  This is the end                                                                                          */

end;




		    sort_branches.pl1               11/15/82  1824.4rew 11/15/82  1505.3       37413



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


sort_branches:  procedure(root, a_count);  /* Procedure to sort branches in order of thier primary names. */

/* This proc uses a singleton sort.  It should be able to sort about 2**18 items .
If it bombs out on a lesser number there is a programming error.
*/


dcl
	root ptr,
	pp ptr,
	(i, j, k, l, m, n, q, xi, xj,
	 xk, xl, xq) fixed bin,
	(vxi, vxj, vxk, vxq, bp) ptr,
	Cut fixed bin int static init(12),
	stacki(18) fixed bin,
	stackj(18) fixed bin,
	a_count fixed bin,
	count fixed bin;

% include backup_dir_list;


dcl (addr, divide, null, ptr, rel) builtin;


/* Set up arrays of pointers to names and indices of pointers */

	if root = null then go to sort_ret;

	bp = root;				/* get pointer to first branch structure */
	count = a_count;				/* copy the count of branches */

begin;
dcl x (count) fixed bin;

	do n = 1 to count;
	     x(n) = n;				/* place index into index list */
	end;

	n = n - 1;

	i, m = 1;
	j = n;

/* Now sort */

/* Start by getting and ordering first middle and last elements in current list */
/* Arrange indices accordingly since only they get sorted and set test value to middle value */

sloop:
	k = i;
	l = j;
	q = divide(i+j, 2, 17, 0);

	xi = x(i);
	xj = x(j);
	xq = x(q);

	vxi = ptr(bp, bp->br(xi).namerp);
	vxj = ptr(bp, bp->br(xj).namerp);
	vxq = ptr(bp, bp->br(xq).namerp);



	if vxq->name(1).string < vxi->name(1).string then

	   if vxj->name(1).string < vxi->name(1).string then

	      if vxq->name(1).string < vxj->name(1).string then do;
	         x(i) = xq;
	         x(q) = xj;
	         x(j) = xi;
	         vxq = vxj;
	         end;

	      else do;
	         x(i) = xj;
	         x(j) = xi;
	         end;

	   else do;
	      x(i) = xq;
	      x(q) = xi;
	      vxq = vxi;
	      end;

	else if vxj->name(1).string < vxq->name(1).string then

	   if vxi->name(1).string < vxj->name(1).string then do;
	      x(q) = xj;
	      x(j) = xq;
	      vxq = vxj;
	      end;

	   else do;
	      x(q) = xi;
	      x(i) = xj;
	      x(j) = xq;
	      vxq = vxi;
	      end;

/* Now order into lists above and below the test value  */

lloop:
	l = l - 1;
	xl = x(l);



	if ptr(bp, bp->br(xl).namerp)->name(1).string > vxq->name(1).string then go to lloop;

kloop:
	k = k + 1;
	xk = x(k);



	if ptr(bp, bp->br(xk).namerp)->name(1).string < vxq->name(1).string then go to kloop;



	if k<=l then do;
	   x(k) = xl;
	   x(l) = xk;
	   go to lloop;
	   end;



/* now put the longer list on the stack, and try to sort the smaller.*/
	if l-i<j-k then do;
	   stacki(m) = k;
	   stackj(m) = j;
	   j = l;
	   end;

	else do;
	   stacki(m) = i;
	   stackj(m) = l;
	   i = k;
	   end;

	m = m + 1;


test:

	if j-i>Cut then go to sloop;



	if i=1 then if i<j then go to sloop;

/* Bubble sort if small number of names in this list */
/*  Note that we do this for the lists headed by stacki(n) */

	do i = i+1 by 1 while (i<=j);
	   k = i;
	   xk = x(k);
	   vxk = ptr(bp, bp->br(xk).namerp);
bubble:	   l = k - 1;
	   xl = x(l);
	   if ptr(bp, bp->br(xl).namerp)->name(1).string <= vxk->name(1).string then go to ok;
	   x(k) = xl;
	   x(l) = xk;
	   k = l;
	   go to bubble;
ok:	   end;

/* Start work on the next list */


	m = m - 1;


	if m=0 then go to thread;


	i = stacki(m);

	j = stackj(m);



	go to test;



thread:					/* store branch pointers in the store of the sorted primary names */
	do i = 1 to count;			/* loop over all branches */
	     xi = x(i);			/* get index to next branch  ordered by name */
	     bp->br(i).ix = rel(addr(bp->br(xi)));  /* place rel pointer in appropriate branch */
	end;

end;	/* end begin block in which x array is declared */

sort_ret:
	return;

	end;




		    start_dump.pl1                  10/28/88  1411.9r w 10/28/88  1302.3      209349



/****^  ***********************************************************
        *                                                         *
        * 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-06-09,GWMay), approve(85-12-23,MCR7320), audit(86-11-19,GDixon),
     install(86-11-21,MR12.0-1223):
     Added ability to abort upon return of non-zero code from backup_dump. This
     will allow the dumper to abort tape errors and not continue with the next
     entry in the control file.  The reason this should be done is to protect
     against data loss.
  2) change(87-05-10,Gilcrease), approve(87-07-31,MCR7686),
     audit(88-02-01,Farley), install(88-02-02,MR12.2-1019):
      Update dprint_msg version.
                                                   END HISTORY COMMENTS */



/* This is the Multics dumper driver. */
start_dump: proc;

/* Initial coding by T.P. Skinner. */
/* Modified 3 June 1970, R H Campbell. */
/* IPC revision 25 March 1970, N I Morris. */
/* Restart path comparison fixed BIM 12/82 */
/* The Multics dumper driver is called at the time the system is brought up and will run the dumper until the
   end_dump command is given.  If the alarm clock fails to operate properly, the operator may manually start an
   increment by issuing the wakeup_dump command. */
/* Changed to handle -no_primary, bugs fixed 09/24/79 S. Herbst */
/* MCR 4311 Fix error messages 02/08/80 S. Herbst */
/* Add -dprint and -no_dprint 03/19/80 S. Herbst */
/* Changed to detach tape on cleanup 02/25/81 S. Herbst */
/* Changed to prevent calling end_dump first with dumper uninitialized 07/01/81 S. Herbst */
/* Changed dprinting to see -ds, -he, and -rqt 12/01/81 S. Herbst */
/* Fixed restart option (again), Keith Loepere, 1/30/85. */

dcl (m, n, i) fixed bin;				/* Temporary storage. */

dcl (line, p, sp, ap) ptr;				/* .. */

dcl  string based char (n);				/* The argument in the command line. */

dcl  substring based char (n) aligned;			/* For non-copying "substr (dump_dir, 1, n)". */

dcl  dump_in_progress static bit (1);			/* Flag to prevent recursive entry to wakeup_dump. */
dcl  dumper_initialized static bit (1) init ("0"b);	/* Flag to prevent calling end_dump first */

dcl  type static fixed bin,				/* Code for type of dump. */
     pid fixed bin (35),				/* Our process ID. */
    (map_name, err_name) char (32),			/* Name of map "file_". */
     device char (16),
     mode char (6),
     dump_dir char (168),
     efpath char (168) aligned,
     dir char (168) aligned,
     dir_name char (168),
     error_string char (32),
     rings (3) fixed bin (6),
     rb (3) fixed bin (5),
     unique_chars_ entry (bit (*) aligned) returns (char (15) aligned); /* Get new map name. */

dcl  static_map_name char (32) int static;		/* saved for end_dump */
dcl  time_now fixed bin (52),				/* Time this pass started. */
     char1 char (1) based;

dcl  chname static fixed bin (71);			/* IPC event channel name. */

dcl  code fixed bin;				/* Error code. */


dcl  efl_name char (32);

dcl  errsw bit (1) aligned;

dcl  cleanup condition;

dcl  start_dump$wakeup_dump external;			/* Entry to wake up dumper. */

dcl  backup_map_$beginning_line entry (fixed bin (52), ptr, fixed bin),
     backup_dump$abort_on_tape_errors entry (fixed bin),
     backup_util$get_real_name entry (ptr, ptr, fixed bin, fixed bin),
     bk_output$output_finish entry;

dcl (error_table_$noarg,
     error_table_$no_dir,
     error_table_$argerr,
     error_table_$ioname_not_found,
     error_table_$namedup) ext fixed bin (35);

dcl  bk_arg_reader_$dump_arg_reader entry (fixed bin, ptr, fixed bin);

dcl  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)),
     timer_manager_$reset_alarm_wakeup entry (fixed bin (71)),
     copy_seg_ entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned, fixed binary),
     clock_ entry (fixed bin (52)),			/* Get current time. */
     convert_date_to_binary_ entry (char (*), fixed bin (52), fixed bin),
     cu_$arg_list_ptr entry (ptr),			/* Arg list location */
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin), /* Get pointer to an argument */
     cv_dec_ entry (char (*) aligned) returns (fixed bin (35)),
     get_group_id_$get_process_id_ entry (fixed bin (35)),
     ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned),
     ios_$detach entry (char (*), char (*), char (*), bit (72) aligned),
     ios_$get_at_entry_ entry (char (*), char (*), char (*), char (*), fixed bin),
     ios_$order entry (char (*), char (*) aligned, ptr, bit (72) aligned),
     ios_$read entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned),
     ios_$seek entry (char (*), char (*), char (*), fixed bin, bit (72) aligned),
    (ipc_$create_ev_chn, ipc_$delete_ev_chn) entry (fixed bin (71), fixed bin),
     ipc_$decl_ev_call_chn entry (fixed bin (71), ptr, ptr, fixed bin, fixed bin),
     dprint_ entry (char (*) aligned, char (*), ptr, fixed bin),
    (com_err_, ioa_, ioa_$rs, listen_$start) entry options (variable);

dcl  hphcs_$pxss_set_timax entry (fixed bin (35), fixed bin (35));


dcl  hcs_$append_branchx entry (char (*) aligned, char (*), fixed bin (5), (3) fixed bin (6),
     char (*) aligned, fixed bin (1), fixed bin (1), fixed bin (24), fixed bin),
     hcs_$set_ring_brackets entry (char (*) aligned, char (*), (3) fixed bin (5), fixed bin),
     hcs_$add_acl_entries entry (char (*) aligned, char (*), ptr, fixed bin, fixed bin),
     get_group_id_$tag_star returns (char (32) aligned),
     cu_$level_get returns (fixed bin),
     get_wdir_ returns (char (168) aligned);

dcl 1 sysd_acl aligned,
    2 aclname char (32) init ("*.SysDaemon.*"),
    2 aclmode bit (36) init ("101"b),
    2 zeropad bit (36) init (""b),
    2 aclcode fixed bin (35) init (0);

dcl (addr, index, length, max, null, unspec, substr) builtin;


%include bk_ss_;
%include dprint_arg;
%include io_status;
/*  */
	type = 0;					/* Normal entry, indicate "start_dump" called. */
	bk_ss_$myname = "start_dump";
	bk_ss_$datesw = ""b;			/* Reset "dump all since given date" */
	bk_ss_$dtdsw = "1"b;			/* Default. Dump all changed since last dumped */
	go to examine_arguments;			/* Go get arguments. */

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

catchup_dump: entry;				/* Exception entry to make cutoff-time pass. */

	type = 2;					/* Indicate catchup dump in progress. */
	bk_ss_$myname = "catchup_dump";
	bk_ss_$dtdsw = ""b;				/* Reset "dump all changed since last dumped" */
	bk_ss_$datesw = "1"b;			/* Use "dump all changed since given date" */
	call convert_date_to_binary_ ("2400.", bk_ss_$date, code); /* Get midnight of this date */
	bk_ss_$date = bk_ss_$date - 172800000000;	/* Default. Dump all changed since midnight 2 days ago. */
	go to examine_arguments;			/* Go get arguments. */

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


complete_dump: entry;				/* Entry to do complete dump */

	type = 1;					/* Set up complete_dump code. */
	bk_ss_$myname = "complete_dump";
	bk_ss_$dtdsw, bk_ss_$datesw = ""b;		/* Reset and ignore dates.  We are dumping all. */

examine_arguments: call cu_$arg_list_ptr (ap);		/* Get arg ptr for sub */

	on cleanup call bk_output$output_finish;	/* detach tape if released */

	bk_ss_$control_name = "";			/* Reset for later test */
	bk_ss_$operator = "";
	bk_ss_$tapesw = "1"b;
	bk_ss_$holdsw = "1"b;
	bk_ss_$wakeup_interval = 3600000000;		/* Default, one hour (in micro seconds) */
	code = 0;


	error_string = "Control file path required.";
	m = 1;					/* First arg */
	call cu_$arg_ptr (m, p, n, code);		/* Get first arg - should be control file name */
	if code ^= 0 then do;
arg_error:     call com_err_ (code, bk_ss_$myname, error_string);
	     go to final;
	end;

	if n = 0 then do;				/* Must have first argument */
noarg:	     code = error_table_$noarg;
	     go to arg_error;
	end;

	if p -> char1 = "-" then go to arg_reader;	/* use argument reader if leading hyphen */
	if substr (p -> string, n-4, 5) ^= ".dump"
	then bk_ss_$control_name = p -> string || ".dump";
	else bk_ss_$control_name = p -> string;		/* Got control file name */

	error_string = "Operator name required.";
	m = 2;					/* Second arg */
	call cu_$arg_ptr (m, p, n, code);		/* Get operator */
	if code ^= 0 then go to arg_error;
	if n = 0 then go to noarg;			/* Must have operator */
	if p -> char1 = "-" then go to arg_reader;	/* use standard argument reading routine */

	bk_ss_$operator = p -> string;		/* Got bk_ss_$operator */

	error_string = "";
	m = 3;					/* Get third arg */
	call cu_$arg_ptr (m, p, n, code);		/* Get number of tapes if any */
	if code ^= 0 then
	     if code ^= error_table_$noarg then go to arg_error;
	     else do;				/* Set up default */
		bk_ss_$ntapes = 1;			/* Default is one tape */
		code = 0;
		go to args_done;
	     end;

	if p -> char1 = "-" then go to arg_reader;	/* Go to standard reading routine */
	if p -> string = "2" then bk_ss_$ntapes = 2;
	else bk_ss_$ntapes = 1;			/* Not more than 2 tapes */


	if bk_ss_$myname = "complete_dump" then m = 4;	/* Set up to read next arg */
	else do;					/* Set timer interval if not complete dump */
	     call cu_$arg_ptr (4, p, n, code);		/* Get wakeup interval in minutes */
	     if code ^= 0
	     then if code ^= error_table_$noarg
		then go to arg_error;
		else do;				/* Use default wakeup interval */
		     code = 0;
		     go to args_done;
		end;

	     if p -> char1 = "-" then go to arg_reader;	/* Do standart reading */

	     bk_ss_$wakeup_interval = cv_dec_ ((p -> string));
	     if bk_ss_$wakeup_interval <= 0 then go to interval_error;
	     if bk_ss_$wakeup_interval > 360 then do;
interval_error:	call ioa_ ("^a: Improper wakeup interval, ^d", bk_ss_$myname, bk_ss_$wakeup_interval);
		go to final;
	     end;
	     bk_ss_$wakeup_interval = bk_ss_$wakeup_interval * 60000000; /* in micro seconds */
	     m = 5;				/* set up to read next arg */
	end;

arg_reader:
	call bk_arg_reader_$dump_arg_reader (m, ap, code); /* Get any other arguments */
	if code ^= 0 then go to final;
args_done:

	if bk_ss_$restart_dumpsw & ^bk_ss_$no_primary then
	     call backup_util$get_real_name (addr (bk_ss_$restart_path), addr (bk_ss_$restart_path),
	     bk_ss_$restart_plen, code);		/* Name may be longer or different */

	if bk_ss_$control_name = "" | bk_ss_$operator = "" then do;
	     code = error_table_$argerr;		/* Must have dump control file and operator */
	     call com_err_ (code, bk_ss_$myname, "Missing control file or operator name");
	     go to final;
	end;

	sp = addr (status);				/* Get pointer to status structure. */
	line = addr (dump_dir);			/* Get pointer to IO buffer. */
	call ios_$attach ("dump_control", "file_", bk_ss_$control_name, "r", sp -> status_bits); /* Control segment. */
	if status.code ^= 0 then do;			/* Was an error encountered? */
	     call com_err_ (status.code, bk_ss_$myname, "ios_$attach for ^a", bk_ss_$control_name);
	     go to final;				/* Quit. */
	end;

	if type ^= 1 then do;			/* Is this a complete dump? */
	     call ipc_$create_ev_chn (chname, code);	/* Create an event channel. */
	     if code ^= 0 then do;
		call com_err_ (code, bk_ss_$myname, "ipc_$create_ev_chn");
		go to final;
	     end;					/* Make channel into call channel. */
	     call ipc_$decl_ev_call_chn (chname, addr (start_dump$wakeup_dump), null, 1, code);
	     if code ^= 0 then do;			/* OK? */
		call com_err_ (code, bk_ss_$myname, "ipc_$decl_ev_call_chn");
		go to final;			/* Give up. */
	     end;
	end;

	if (^bk_ss_$debugsw) & (type = 2) then do;
	     call get_group_id_$get_process_id_ (pid);	/* Get our process ID. */
	     call hphcs_$pxss_set_timax (pid, 7000000);	/* Help us along with priority. */
	end;

	dump_in_progress = "1"b;			/* Set flag to prevent recursion. */
	dumper_initialized = "1"b;			/* and we're off and runnning... */
	go to over;				/* Start dump pass. */

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


wakeup_dump: entry;					/* Enter here on alarm or operator wakeup. */

	sp = addr (status);				/* Get pointer for I/O system status. */
	if dump_in_progress then do;			/* Is a dump pass being done now? */

	     call ioa_ ("wakeup_dump:  Dump pass presently in progress; this call ignored.");

	     call listen_$start;			/* Make sure we don't die. */
	     go to restart_IO;			/* Ignore call. */
	end;

	call timer_manager_$reset_alarm_wakeup (chname);	/* Reset the alarm in case of manual invocation */
	bk_ss_$myname = "wakeup_dump";
	dump_in_progress = "1"b;			/* Set flag. */
	line = addr (dump_dir);			/* Get pointer to directory name. */
	call ioa_ ("^/Dumper waking up.");

over:	call clock_ (time_now);			/* Read the clock. */

	call ios_$seek ("dump_control", "read", "first", 0, sp -> status_bits); /* Reset read pointer. */
	if status.code ^= 0 then do;			/* OK? */
	     call com_err_ (status.code, bk_ss_$myname, "ios_$seek for ^a", bk_ss_$control_name);
	     go to stop;				/* Give up. */
	end;

	map_name, static_map_name = unique_chars_ (""b) || ".dump.map";	/* Make up new map name. */
	rings (1), rings (2), rings (3) = max ((cu_$level_get ()), 4);
	dir = get_wdir_ ();
	call hcs_$append_branchx (dir, map_name, 01011b, rings, (get_group_id_$tag_star ()), 0, 0, 0, code);
	if (code = 0) | (code = error_table_$namedup)
	then call hcs_$add_acl_entries (dir, map_name, addr (sysd_acl), 1, code);
	call ios_$attach ("map", "file_", map_name, "w", sp -> status_bits);
	if status.code ^= 0 then do;			/* All OK? */
	     call com_err_ (status.code, bk_ss_$myname, "ios_$attach for ^a", map_name);
	     go to stop;
	end;


	call ioa_$rs ("Dump control file: ^a, operator: ^a.", dump_dir, n, bk_ss_$control_name, bk_ss_$operator);

	bk_ss_$mapsw = "1"b;			/* Make sure map is enabled. */
	call backup_map_$beginning_line (time_now, line, n); /* Write the ID line. */

next:	call ios_$read ("dump_control", line, 0, length (dump_dir), n, sp -> status_bits);

	if status.code ^= 0 then do;			/* OK? */
	     call com_err_ (status.code, bk_ss_$myname, "ios_$read for ^a", bk_ss_$control_name);
	     go to done;				/* Give up. */
	end;

	n = n - 1;				/* Remove NL from consideration. */
	call ioa_ ("^/^a", line -> substring);		/* Space and type root name. */
						/* Is this a path name or comment? */
	if substr (dump_dir, 1, length (">")) = ">" then do;

	     bk_ss_$save_path = line -> substring;	/* save the pathname */
	     bk_ss_$save_plen = n;			/* and its length */
	     bk_ss_$pathsw = "1"b;			/* and signal its presence */
	     if bk_ss_$restart_dumpsw then do;		/* Restarting this dump */
		if ^bk_ss_$no_primary then call backup_util$get_real_name
		     (addr (bk_ss_$save_path), addr (bk_ss_$save_path), bk_ss_$save_plen, code);
 		if substr (bk_ss_$save_path, 1, bk_ss_$save_plen) ^= substr (bk_ss_$restart_path, 1, bk_ss_$save_plen) then go to check_end;
						/* save path contained within restart path */
		if bk_ss_$save_plen < bk_ss_$restart_plen then
		     if substr (bk_ss_$restart_path, bk_ss_$save_plen + 1, 1) ^= ">" then go to check_end;
						/* if save path ^= restart path, then restart path 
						must be = save path || > || <subdirs> */
	     end;
 	     		                             /* D U M P   S P E C I F I E D   S U B T R E E */
	    call backup_dump$abort_on_tape_errors (code);
	    if code ^= 0 then
	        go to ended;
	end;

check_end:
	if ^ status.bits.end_of_data then		/* Any more lines? */
	     go to next;

done:	call finish_maps (0);			/* Detach and dprint map and error file. */
	bk_ss_$mapsw = ""b;				/* Clear switch to suppress comment from bk_output. */
	if type = 2 then do;			/* Is this exceptional case? */
	     if bk_ss_$no_contin then go to ended;	/*  DONE.  Do not continue */
	     bk_ss_$holdsw = ""b;			/* Dismount tape when finished */
	     if bk_ss_$tapesw then			/* Detach only if tape is present */
		call bk_output$output_finish ();	/* Detach the tape. */
	     call ioa_ ("^/Catchup_dump has finished; start_dump will be called."); /* Announce completion. */
	     type = 0;				/* Reset to normal incremental operation. */
	     bk_ss_$myname = "start_dump";
	     bk_ss_$dtdsw = "1"b;
	     bk_ss_$holdsw = "1"b;
	     bk_ss_$datesw = ""b;			/* Turn off date check */
	     if ^bk_ss_$debugsw then call hphcs_$pxss_set_timax (pid, 0); /* Reset timax */
	     go to over;				/* Start next pass immediately. */
	end;

	call ioa_ ("^/Dump finished.");
	if type ^= 1 then do;			/* Is this either type of incremental dump? */
	     call timer_manager_$alarm_wakeup (time_now + bk_ss_$wakeup_interval, "00"b, chname);
	     call ioa_ ("Dumper going to sleep.^/");

restart_IO:    call ios_$order ("user_i/o", "start", null, sp -> status_bits); /* Ensure tty does not lock up. */

	     if status.code ^= 0 then			/* OK? */
		call com_err_ (status.code, bk_ss_$myname, "ios_$order on user_i/o"); /* No, give error comment. */
	     dump_in_progress = ""b;			/* Indicate dump no longer active. */
	     bk_ss_$myname = "";			/* done for now */
	     return;
	end;

	go to ended;

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


end_dump:	entry;					/* Finish up dumping. */

	bk_ss_$myname = "end_dump";

	if ^dumper_initialized then do;
	     call com_err_ (0, bk_ss_$myname, "Dumper not initialized; ""end_dump"" ignored.");
	     return;
	end;

	sp = addr (status);				/* Gotta set it again. */

ended:	bk_ss_$mapsw = ""b;				/* Clear map enabling switch for following comment. */

	bk_ss_$holdsw = ""b;			/* Dismount tape when finished */
	if bk_ss_$tapesw then			/* Detach only if tape present */
	     call bk_output$output_finish ();
	call finish_maps (1);			/* Detach and dprint map and error file. */

stop:	call ios_$detach ("dump_control", "", "", sp -> status_bits); /* Detach control segment. */

	if status.code ^= 0 then			/* Terminated OK? */
	     call com_err_ (status.code, bk_ss_$myname, "ios_$detach for ^a", bk_ss_$control_name); /* Give comment. */
	if type ^= 1 then do;			/* Is this incremental? */
	     call ipc_$delete_ev_chn (chname, code);	/* Remove the event channel. */
	     if code ^= 0 then do;			/* OK? */
		call com_err_ (code, bk_ss_$myname, "ipc_$delete_ev_chn");
		go to final;			/* Give up. */
	     end;
	end;


final:	bk_ss_$myname = "";				/* reset name */

	dumper_initialized = "0"b;			/* can't call end_dump twice in a row */

	return;					/* terminate processing */

/* ------------------------------------------------------ */

finish_maps: proc (detsw);

dcl  detsw fixed bin;				/* 0 if det err file only on complete, 1 if always. */
dcl (have_error_file, have_map) bit (1) aligned init ("0"b);

	     sp = addr (status);
	     dir = get_wdir_ ();
	     call ios_$detach ("map", "", "", sp -> status_bits);
	     if status.code ^= 0 then			/* All OK? */
		if status.code ^= error_table_$ioname_not_found then
		     call com_err_ (status.code, bk_ss_$myname, "ios_$detach for ^a", map_name); /* Give comment. */
		else;
	     else have_map = "1"b;

	     if detsw = 0 then if type ^= 1 then go to skip_errfile;
						/* Detach error file sometimes only. */
	     call ios_$get_at_entry_ ("err_file", device, err_name, mode, status.code); /* see if error file made */
	     if status.code ^= 0 then if status.code ^= error_table_$ioname_not_found
		then call com_err_ (status.code, bk_ss_$myname, "ios_$get_at_entry_ for err_file");
		else;
	     else do;
		call ios_$detach ("err_file", "", "", sp -> status_bits);
		if status.code ^= 0 then if status.code ^= error_table_$ioname_not_found then
			call com_err_ (status.code, bk_ss_$myname, "ios_$detach for ^a", err_name);
		     else;
		else do;
		     have_error_file = "1"b;
		     i = index (dir, " ");		/* make full name */
		     efpath = substr (dir, 1, i-1) || ">" || err_name;
		     rb (1), rb (2), rb (3) = max ((cu_$level_get ()), 4);
		     call hcs_$set_ring_brackets (efpath, "", rb, code);
		     if code ^= 0 then call com_err_ (code, bk_ss_$myname, "hcs_$set_ring_brackets for err file");
		end;
	     end;

/* Queue maps for printing. */

skip_errfile:  if ^bk_ss_$dprintsw then return;
	     dpap = addr (dprint_arg_buf);		/* Set up args to dprint */
	     unspec (dprint_arg) = "0"b;
	     dprint_arg.version = dprint_arg_version_9;
	     dprint_arg.copies = 1;
	     dprint_arg.delete = 1;
	     dprint_arg.queue = bk_ss_$dprint_queue;
	     dprint_arg.pt_pch = 1;
	     dprint_arg.notify = 0;
	     dprint_arg.output_module = 1;
	     dprint_arg.lmargin = 0;
	     dprint_arg.line_lth = -1;
	     dprint_arg.page_lth = -1;
	     dprint_arg.top_label = "";
	     dprint_arg.bottom_label = "";
	     dprint_arg.form_name = "";
	     dprint_arg.chan_stop_path = "";
	     if bk_ss_$dprint_heading_setsw then dprint_arg.heading = bk_ss_$dprint_heading;
	     else
	        dprint_arg.heading = " for " || substr (bk_ss_$control_name, 1, length (dprint_arg.heading) - length (" for "));
	     if bk_ss_$dprint_request_type_setsw then dprint_arg.request_type = bk_ss_$dprint_request_type;
	     else dprint_arg.request_type = "";
	     if have_error_file then do;
		efl_name = err_name;
		dir_name = dir;
		if ^bk_ss_$debugsw then call copy_seg_ (dir_name, efl_name, ">udd>SysDaemon>error_file", efl_name,
		     bk_ss_$myname, errsw, code);
		if code ^= 0 & code ^= error_table_$no_dir then call
		     com_err_ (code, bk_ss_$myname, "copy of error file");
		if bk_ss_$dprint_destination_setsw then dprint_arg.destination = bk_ss_$dprint_destination;
		else dprint_arg.destination = "ERROR FILE";
		call dprint_ (dir, err_name, dpap, code);
		if code ^= 0 then call com_err_ (code, bk_ss_$myname, "Unable to dprint ^a>^a", dir, err_name);
	     end;
	     if ^have_map then return;
	     if type = 0 then do;			/* Is this a normal incremental dump? */
		dprint_arg.destination = "INCREMENTAL";
DPRINT:		if bk_ss_$dprint_destination_setsw then dprint_arg.destination = bk_ss_$dprint_destination;
		call dprint_ (dir, static_map_name, dpap, code);
		if code ^= 0 then
		     call com_err_ (code, bk_ss_$myname, "Unable to dprint ^a>^a", dir, static_map_name);
	     end;
	     else if type = 2 then do;		/* Is this a catchup dump? */
		if bk_ss_$dprint_destination_setsw then dprint_arg.destination = bk_ss_$dprint_destination;
		else dprint_arg.destination = "CATCHUP MAP";
		go to DPRINT;
	     end;
	     else do;				/* This is a complete dump. */
		if bk_ss_$dprint_destination_setsw then dprint_arg.destination = bk_ss_$dprint_destination;
		else dprint_arg.destination = "COMPLETE MAP";
		dprint_arg.copies = bk_ss_$ntapes;	/* Want a map for each set. */
		go to DPRINT;
	     end;

	end finish_maps;

     end start_dump;




		    copy_dump_tape.pl1              07/16/87  1351.7r   07/15/87  1558.3      975609



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

/****^  HISTORY COMMENTS:
  1) change(87-01-05,GDixon), approve(87-04-15,MCR7617),
     audit(87-06-22,RBarstad), install(87-07-15,MR12.1-1040):
     Completely rewritten, combining copy and compare functions into a single
     command.
                                                   END HISTORY COMMENTS */

copy_dump_tape:
	proc options(variable);
	
    dcl	ME			char(17),		/* command called*/
	abort_sw			bit(1),		/* on: -abort    */
	code			fixed bin(35),
	1 compared		aligned like copied,/* count compares*/
	1 copied			aligned,		/* count copied  */
	  2 segs			fixed bin,	/*  entries      */
	  2 msfs			fixed bin,	/*  msfs	       */
	1 cpbf			aligned like inbf,	/* copy record   */
	1 cphe			aligned like inhe based (cpbf.hp),
	1 cphe_name		aligned like inhe_name based (cpbf.hp),
	1 cplast			aligned like inlast,/* last rec read */
						/*  from copy    */
						/*  tape.	       */
	1 inbf			aligned,		/* input record  */
	  2 blrh,					/*  backup dump  */
	    3 zz1			char(32),		/*   record head */
	    3 english		char(56),
	    3 zz2			char(32),
	    3 sizes,
	      4 hl		fixed bin(21),
	      4 segl		fixed bin(21),
	  2 hp			ptr,		/*  header ptr   */
	  2 segp			ptr,		/*  segment ptr  */
	1 inhe			aligned like h based (inbf.hp),
						/*  header       */
	1 inhe_name		aligned based (inbf.hp),
	  2 dname			char(168) varying,
	  2 ename			char(32) varying,
	1 inlast			aligned,		/* last seg read */
	  2 path			unal,		/*  from in tape.*/
	    3 dir			char (168),
	    3 ent			char (32),
	  2 sizes,
	    3 he			fixed bin(35),
	    3 seg			fixed bin(35),
	1 input			aligned,		/* input medium  */
	  2 header		like in_out.header,
	  2 vol (20)		like in_out.vol,	/*  tape names   */
	1 map			aligned,		/* map file      */
	  2 header		like in_out.header,
	1 map_prev		aligned,		/* map file      */
	  2 header		like in_out.header,
	1 mbf			aligned like inbf based(addr(inbf)),
						/* master record */
	1 mhe			aligned like h based (mbf.hp),
						/*  header       */
	1 mhe_name		aligned like inhe_name based (mbf.hp),
	1 mlast			aligned like inlast,/* last record   */
						/*  read from    */
						/*  master tape. */
	maximize_devices_sw		bit(1),		/* on: -maxdv    */
	operation_now		fixed bin,	/* cur function  */
	operation_wanted		fixed bin,	/* wanted fcn    */
	1 output			aligned,		/* output medium */
	  2 header		like in_out.header,
	  2 vol (20)		like in_out.vol,	/*  tape names   */
	1 select			aligned,		/* copy selected */
	  2 header		like in_out.header, /*  files only   */
	  2 listp			ptr,		/*  path list    */
	  2 select_sw		bit(1),		/*  on: -select  */
						/*   without opt,*/
						/*   -select used*/
						/*  by compare ep*/
	state			fixed bin,	/* result of     */
						/*  read_seg fcn */
	trace			fixed bin;	/* -trace XXX    */

    dcl	1 in_out			aligned based (in_outp),
	  2 header,
	    3 name		char(8) varying,	/* log file name */
	    3 iocbp		ptr,		/* IOCB ptr      */
	    3 target_iocbp		ptr,
	    3 mode		fixed bin,	/* opening mode  */
	    3 recx		fixed bin,	/* cur rec       */
	    3 vfile,				/* input file    */
	      4 path		char(168) unal,
	      4 expath		char(168) unal,
	      4 charpos		fixed bin(35),	/* pos of last   */
						/*  char read    */
	    3 tape,				/* input tapes.  */
	      4 voln		fixed bin,	/*  total	       */
	      4 volx		fixed bin,	/*  current      */
	      4 track		fixed bin,	/*  track	       */
	      4 density		fixed bin,	/*  density      */
	  2 vol (20),
	    3 name		char(32),		/*  vol names    */
	    3 device		char(32),		/*  device used  */
	in_outp			ptr,		/* ptr to input  */
						/*  or output    */
	severity			fixed bin based (severityp),
	severityp			ptr;

    dcl  (addr, bin, char, clock, dim, divide, hbound, index,
	lbound, length, ltrim, max, maxlength, min, mod, null, ptr, rtrim,
	search, string, substr, unspec, verify)
				builtin;

    dcl	cleanup			condition;

    dcl	absolute_pathname_		entry (char(*), char(*), fixed bin(35)),
	absolute_pathname_$add_suffix	entry (char(*), char(*), char(*), fixed bin(35)),
 	backup_map_$beginning_line	entry (fixed bin(52), ptr, fixed bin),
	backup_map_$detail_line2	entry (char(32) aligned, fixed bin(9),
				     char(10) aligned, fixed bin(52),
				     fixed bin(52), fixed bin(52),
				     fixed bin(52), fixed bin(52)),
	backup_map_$detach_for_cdt	entry (fixed bin(35)),
	backup_map_$directory_line	entry (ptr, fixed bin),
	backup_map_$heading_line	entry,
	backup_map_$init_for_cdt	entry (char(128) var),
	backup_map_$name_line	entry (ptr, fixed bin),
	backup_map_$tapes		entry (ptr, fixed bin),
	backup_map_$terminal_line	entry (fixed bin(52), fixed bin),
	backup_util$idline		entry (char(*), char(*), ptr,
				     fixed bin),
	convert_ipc_code_		entry options(variable),
	cu_$arg_list_ptr		entry returns(ptr),
	date_time_$format		entry (char(*), fixed bin(71),
				     char(*), char(*))
				     returns(char(250) var),
	get_line_length_$switch	entry (ptr, fixed bin(35)) returns(fixed bin),
	get_shortest_path_		entry (char(*)) returns(char(168)),
	ioa_			entry() options(variable),
	iox_$attach_name		entry (char(*), ptr, char(*), ptr,
				     fixed bin(35)),
	iox_$attach_ptr		entry (ptr, char(*), ptr,
				     fixed bin(35)),
	iox_$close		entry (ptr, fixed bin(35)),
	iox_$control		entry (ptr, char(*), ptr,
				     fixed bin(35)),
	iox_$destroy_iocb		entry (ptr, fixed bin(35)),
	iox_$detach_iocb		entry (ptr, fixed bin(35)),
	iox_$find_iocb		entry (char(*), ptr, fixed bin(35)),
	iox_$get_chars		entry (ptr, ptr, fixed bin(21),
				     fixed bin(21), fixed bin(35)),
	iox_$get_line		entry (ptr, ptr, fixed bin(21),
				     fixed bin(21), fixed bin(35)),
	iox_$modes		entry (ptr, char(*), char(*),
				     fixed bin(35)),
	iox_$move_attach		entry (ptr, ptr, fixed bin(35)),
	iox_$open			entry (ptr, fixed bin, bit(1) aligned,
				     fixed bin(35)),
	iox_$position		entry (ptr, fixed bin, fixed bin(35),
				     fixed bin(35)),
	iox_$put_chars		entry (ptr, ptr, fixed bin(21),
				     fixed bin(35)),
	ipc_$block		entry (ptr, ptr, fixed bin(35)),
	ipc_$create_ev_chn		entry (fixed bin(71), fixed bin(35)),
	ipc_$delete_ev_chn		entry (fixed bin(71), fixed bin(35)),
	pathname_			entry (char(*), char(*))
				     returns(char(168)),
	rcp_$assign_device		entry (char (*), ptr, fixed bin (71),
				     char (*), bit (36) aligned,
				     fixed bin (35)),
	rcp_$check_assign		entry (bit (36) aligned, ptr, char (*),
				     fixed bin, fixed bin (35)),
	rcp_$copy_list		entry (ptr, fixed bin (21),
				     fixed bin (35)),
	rcp_$unassign		entry (bit (36) aligned, bit (*),
				     char (*), fixed bin (35)),
	ssu_$get_invocation_count	entry (ptr, fixed bin, fixed bin),
	ssu_$get_temp_segment	entry (ptr, char(*), ptr),
	unique_chars_		entry (bit(*)) returns(char(15));

    dcl	BLOCK_SIZE		fixed bin int static options(constant) init(256),
	BLRH_DELIMITER		char(32) int static options(constant)
				init(
				  " z z z z z z z z z z z z z z z z"),
	BLRH_ENGLISH		char(56) int static options(constant)
				init("This is the beginning of a backup logical record."),
         (DESTROY			init(1),
          KEEP			init(2)) fixed bin int static options(constant),
         (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
	FOR_MOVE_ATTACH		fixed bin int static options(constant) init(-1),
         (REJECTS			init(-1),
	OFF			init(0),
	COPY			init(1),
	COMPARE			init(2),
	COPY_AND_COMPARE		init(3)) fixed bin int static options(constant),
         (OK			init(0),
	READ_AGAIN		init(1),
	NOMORE			init(2)) fixed bin int static options(constant),
	compare_dump_tape_severity_	fixed bin ext static init (0),
	copy_dump_tape_map_		char(168) varying ext static init(""),
	copy_dump_tape_severity_	fixed bin ext static init (0),
	copy_dump_tape_tapes	char(300) varying ext static init(""),
         (error_table_$bad_opt,
	error_table_$device_end,
	error_table_$end_of_info,
	error_table_$inconsistent,
	error_table_$noarg,
	error_table_$not_detached,
	error_table_$resource_reserved,
	error_table_$resource_unavailable,
	error_table_$too_many_names,
	error_table_$wrong_no_of_args)
				fixed bin(35) ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ENTRY POINT IDENTIFICATION:				       */
/* 1) Identify command entrypoint.				       */
/* 2) Set operation code.					       */
/* 3) Identify command severity variable.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	ME = "copy_dump_tape";
	operation_wanted = COPY;
	severityp = addr(copy_dump_tape_severity_);
	copy_dump_tape_tapes = "";
	copy_dump_tape_map_ = "";
	go to COPY_COMPARE;
	
compare_dump_tape:
	entry options(variable);
	
	ME = "compare_dump_tape";
	operation_wanted = COMPARE;
	severityp = addr(compare_dump_tape_severity_);
	go to COPY_COMPARE;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* INVOCATION TYPE AND ARGUMENTS:				       */
/* 1) Set severity variable to indicate success.			       */
/* 2) Initialize variables used in cleanup handler, and establish handler.   */
/* 3) Create standalone ssu_ invocation for argument processing.	       */
/* 4) Initialize argument handling routines.			       */
/* 5) Process input arguments, reporting any errors as they are encountered. */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

COPY_COMPARE:
	severity = 0;
	sci_ptr = null;
	call initialize_args();
	on cleanup call cleanup_invocation();
	call ssu_$standalone_invocation (sci_ptr, ME, "1.0",
	   cu_$arg_list_ptr(), exit_proc, code);
	call check_invocation_type (ALLOW_COMMAND);
	call process_args();

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* PROCESSING:						       */
/* 1) If -select was given, process the select file to build a select tree.  */
/* 2) If -map was given, open the map file.			       */
/* 3) If tapes are being used for input or output, survey tape drives	       */
/*    assigned to the process.				       */
/* 4) If copying, attach input/output files, do the copying, detach	       */
/*    input/output files.  If output was to tape, report which tapes were    */
/*    actually written on.					       */
/* 5) If comparing, attach master/copy files, do the comparing, detach       */
/*    input/output files.					       */
/* 6) If copying and comparing, report discrepancy between number of segs    */
/*    copied vs number compared.				       */
/* 7) If -trace, report any -select pathnames that were not matched.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if select.vfile.path ^= "" then do;
	   call ioa_ ("");
	   call attach (addr(select), Stream_input);
	   call skip_seg$init();
	   call ssu_$print_message (sci_ptr, 0,
	      "^a: ^d select lines processed.", hhmmm(), select.recx);
	   call detach (addr(select), DESTROY);
	   end;

	if map.vfile.path ^= "" then do;
	   call ioa_ ("");
	   call attach (addr(map), Stream_output);
	   copy_dump_tape_map_ = map.vfile.expath;
	   end;

	if input.tape.voln > 0 | output.tape.voln > 0 then
	   call tape_drive$survey();

	if mod (operation_wanted, 2) = COPY then do;
	   operation_now = COPY;
	   call header("BEGIN COPYING", input, output);
	   call attach (addr(input), Stream_input);
	   call attach (addr(output), Stream_output);
	   call map_seg$init (output);
	   call copy_segs();
	   if output.tape.voln > 0 then do;
	      output.tape.voln = output.tape.volx;
	      call ioa_ ("");
	      call ssu_$print_message (sci_ptr, 0,
	         "NOTE: Files were copied onto ^d ^a tape^[s^]:^v( ^a^)^/",
	         output.tape.voln, output.header.name, output.tape.voln>1,
	         output.tape.voln, output.vol.name);
	      copy_dump_tape_tapes = output.vol(1).name;
	      do output.tape.volx = 2 to output.tape.voln;
	         copy_dump_tape_tapes = copy_dump_tape_tapes || " ";
	         copy_dump_tape_tapes = copy_dump_tape_tapes ||
		  output.vol(output.tape.volx).name;
	         end;
	      end;
	   end;

	if operation_wanted >= COMPARE then do;
	   operation_now = COMPARE;
	   call header ("BEGIN COMPARING", input, output);
	   call attach (addr(input), Stream_input);
	   call attach (addr(output), Stream_input);
	   call compare_segs();
	   end;

	if operation_wanted = COPY_AND_COMPARE then do;
	   operation_now = COPY_AND_COMPARE;
	   if copied.segs ^= compared.segs |
	      copied.msfs ^= compared.msfs then do;
	      severity = max(severity, 3);
	      call ioa_ ("");
	      call error (sci_ptr, -1,
	         "^a: FATAL ERROR: Copy/Compare Count Discrepancy.
Copied:    ^5d segment^[s,^;, ^] ^5d msf^[s^]
Compared:  ^5d segment^[s,^;, ^] ^5d msf^[s^]",
	         hhmmm(),
	         copied.segs, copied.segs^=1, copied.msfs, copied.msfs^=1, 
	         compared.segs, compared.segs^=1, compared.msfs, compared.msfs^=1);
	      end;
	   end;

	call skip_seg$term();

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* REVOCATION AND EXIT:					       */
/*   This point is reached when normal processing completes successfully,    */
/* or when the error$fatal routine is called to abnormally end processing.   */
/*							       */
/* 1) Report status of all processing.				       */
/* 2) Cleanup the standalone invocation.			       */
/* 3) Return to command processor.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

EXIT:	call ioa_ ("");
	call ssu_$print_message (sci_ptr, 0,
"^a: ^[Copy^;Compare^;Copy and compare^] ^" ||
"[completed successfully.^;
^;completed successfully,
  except for unmatched lines in select file (severity 2 error).
^;failed due to 
  comparison errors (severity 3 error).
^;failed due to 
  fatal error (severity 4 error).^]^2/", 
	   hhmmm(), operation_wanted, severity+1);
	call cleanup_invocation();
	return;

exit_proc:
	proc;
	severity = max(severity, 4);
	go to EXIT;
	end exit_proc;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ATTACH to TAPE or STORAGE SYSTEM FILE:			       */
/* 1) Name and get pointer to I/O switch.			       */
/* 2) Attach and open switch.  Tapes are attached by mount_next_tape_vol.    */
/* 3) Report the attachment.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

attach:	proc (iop, mode);

    dcl	iop			ptr,
	1 io			aligned like input based(iop),
	mode			fixed bin;
    dcl	atd			char(300) varying,
	code			fixed bin(35),
	count			fixed bin,
	io_switch_name		char(32);

	io.mode = mode;
	io.recx = 0;
	call ssu_$get_invocation_count (sci_ptr, count, 0);
	io_switch_name = rtrim(ME) || "." || ltrim(char(count)) ||
	   "." || io.header.name;
	if mode = FOR_MOVE_ATTACH then
	   call iox_$find_iocb (io_switch_name, io.target_iocbp, code);
	else
	   call iox_$find_iocb (io_switch_name, io.iocbp, code);

	if io.vfile.path ^= "" then do;
	   atd = "vfile_ " || rtrim(io.vfile.expath);
	   if mode = Stream_input then
	      atd = atd || " -old";
	   call iox_$attach_ptr (io.iocbp, (atd), null, code);
	   call error$fatal (sci_ptr, code,
	      "^/FATAL ERROR: Attaching ^a file ^a.", io.header.name,
	      io.vfile.expath);
	   call iox_$open (io.iocbp, mode, ""b, code);
	   call error$fatal (sci_ptr, code,
	      "^/FATAL ERROR: Opening ^a file ^a for ^a.", io.header.name,
	      io.vfile.expath, iox_modes(mode));
	   call ssu_$print_message (sci_ptr, 0,
	      "^a: Attached ^a for ^a to file:^/  ^a.^[^/  (^a)^]",
	      hhmmm(), io.header.name, iox_modes(mode),
	      io.vfile.expath, trace ^= OFF, atd);
	   io.vfile.charpos = 0;
	   end;
	else if io.tape.voln > 0 then do;
	   io.tape.volx = 0;
	   if mount_next_tape_vol (io) then;
	   else
	      call error$fatal (sci_ptr, -1,
	         "FATAL ERROR: Unable to attach^[ first^] ^a tape ^a.",
	         io.tape.voln>1, io.header.name, io.vol(1).name);
	   end;
	end attach;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ARGUMENT PROCESSING:					       */
/* Declare variables and subroutines needed for argument processing.	       */
/*							       */
/* CHECK INVOCATION TYPE:					       */
/* 1) Initialize error handling subroutines.			       */
/* 2) Determine whether invoked as command or af.			       */
/* 3) Is this type of invocation allowed?			       */
/* 4) Initialize af return argument, and index of current argument.	       */
/*							       */
/* SEE OTHER ARGUMENT PROCESSING PROGRAMS:			       */
/*   get_arg, get_ctl_arg, get_opt, get_num_opt			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    dcl	af_sw			bit(1) aligned,	/* on: active fnc*/
	arg			char(argl) based(argp),
	argl			fixed bin(21),	/* current arg   */
	argp			ptr,
	argn			fixed bin,	/* arg count     */
	argx			fixed bin,	/* arg index     */
	num_opt			fixed bin,	/* numeric option*/
	opt			char(optl) based(optp),
	optl			fixed bin(21),	/* current option*/
	optp			ptr,
	ret			char(retl) varying based(retp),
	retl			fixed bin(21),	/* af return val */
	retp			ptr,
	sci_ptr			ptr;		/* ssu_ info ptr */

    dcl	ssu_$abort_subsystem	entry() options(variable),
	ssu_$arg_ptr		entry (ptr, fixed bin, ptr, fixed bin(21)),
	ssu_$destroy_invocation	entry (ptr),
	ssu_$print_message		entry() options(variable),
	ssu_$return_arg		entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)),
       	ssu_$standalone_invocation	entry (ptr, char(*), char(*), ptr,
				     entry, fixed bin(35));

    dcl  (ALLOW_COMMAND		init(1),
          ALLOW_AF			init(2),
	ALLOW_COMMAND_AF		init(3)) fixed bin int static options(constant);

check_invocation_type:
	proc (allowed);

    dcl	allowed			fixed bin;
    dcl  (error_table_$active_function,
	error_table_$not_act_fnc)	fixed bin(35) ext static;

	call error$init();
	call ssu_$return_arg (sci_ptr, argn, af_sw, retp, retl);
	if allowed = ALLOW_COMMAND & af_sw then
	   call error$fatal (sci_ptr, error_table_$active_function);
	else if allowed = ALLOW_AF & ^af_sw then
	   call error$fatal (sci_ptr, error_table_$not_act_fnc);
	else if allowed = ALLOW_COMMAND_AF then;
	if af_sw then
	   ret = "";
	argx = 0;
	end check_invocation_type;



/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* CLEANUP:						       */
/* 1) Close attachment (via syn_) of map switch used by backup_map_ subrs.   */
/* 2) Unassign any reserved tape drives we assigned to the process.	       */
/* 3) Silently close/detach all opened I/O switches.		       */
/* 4) Destroy the ssu_ invocation (releasing temp segs obtained thru ssu_).  */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

cleanup_invocation:
       	proc;

	call map_seg$term();
	call tape_drive$term();

	call detach (addr(input),    DESTROY);
	call detach (addr(output),   DESTROY);
	call detach (addr(map),      DESTROY);
	call detach (addr(select),   DESTROY);

	if sci_ptr ^= null then
	   call ssu_$destroy_invocation (sci_ptr);
	end cleanup_invocation;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* COMPARE A SEGMENT FROM MASTER with SEGMENT FROM COPY MEDIUM:	       */
/* 1) Initialize error detect remembering switch.  If any comparisons fail,  */
/*    report the error, and let the error routine remember that one	       */
/*    occurred.						       */
/* 2) Compare pathnames of the two segments from backup logical record       */
/*    headers.						       */
/* 3) Compare length of backup logical record headers.		       */
/* 4) Compare header words.					       */
/* 5) Compare segment lengths.				       */
/* 6) Compare segment words.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

compare_seg:
       	proc (bf1, bf2, segx) returns (bit(1));

    dcl   1 (bf1, bf2)		aligned like inbf,
	segx			fixed bin;

    dcl	first_disagreement		fixed bin(18),
	words_disagreeing		fixed bin(18),
	wordx			fixed bin(18);

    dcl	1 he1			aligned like h based (bf1.hp),
	1 he2			aligned like h based (bf2.hp),
	1 he1_name		aligned like inhe_name based (bf1.hp),
	1 he2_name		aligned like inhe_name based (bf2.hp),
	he1_words (bf1.hl)		fixed bin(35) based (bf1.hp),
	he2_words (bf2.hl)		fixed bin(35) based (bf2.hp),
	seg1_words (bf1.segl)	fixed bin(35) based (bf1.segp),
	seg2_words (bf2.segl)	fixed bin(35) based (bf2.segp);

	call error$init();
	if he1_name.dname ^= he2_name.dname |
	   he1_name.ename ^= he2_name.ename then
	   call error (sci_ptr, -1,
	      "^a: Segment ^d -- Pathname Discrepancy.
  Master: ^a
  Copy:   ^a", hhmmm(), segx,
	      rtrim(pathname_((he1.dname), (he1.ename)), " >"),
	      rtrim(pathname_((he2.dname), (he2.ename)), " >"));
	else if dim(he1_words,1) ^= dim(he2_words,1) then
	   call error (sci_ptr, -1,
	      "^a: Segment ^d -- Record Header Length Discrepancy.
  Master: ^5d words for ^a 
  Copy:   ^5d words for ^a", hhmmm(), segx,
	      dim(he1_words,1), rtrim(pathname_((he1.dname), (he1.ename)), " >"),
	      dim(he2_words,1), rtrim(pathname_((he2.dname), (he2.ename)), " >"));

	else if unspec(he1_words) ^= unspec(he2_words) then do;
	   words_disagreeing = 0;
	   first_disagreement = 0;
	   do wordx = lbound(he1_words,1) to hbound(he1_words,1);
	      if he1_words(wordx) ^= he2_words(wordx) then do;
	         words_disagreeing = words_disagreeing + 1;
	         if words_disagreeing = 1 then
		  first_disagreement = wordx;
	         end;
	      end;
	   call error (sci_ptr, -1,
	      "^a: Segment ^d -- Record Header Discrepancy, ^d word^[s^].
--FIRST DISCREPANCY--
  Master: word(^d) = ^w, for ^a 
  Copy:   word(^d) = ^w, for ^a", hhmmm(), segx,
	      words_disagreeing^=1, words_disagreeing,
	      first_disagreement, he1_words(first_disagreement),
	      rtrim(pathname_((he1.dname), (he1.ename)), " >"),
	      first_disagreement, he2_words(first_disagreement),
	      rtrim(pathname_((he2.dname), (he2.ename)), " >"));
	   end;
	else if dim(seg1_words,1) ^= dim(seg2_words,1) then
	   call error (sci_ptr, -1,
	      "^a: Segment ^d -- Segment Length Discrepancy.
  Master: ^5d words for ^a 
  Copy:   ^5d words for ^a", hhmmm(), segx,
	      dim(seg1_words,1), rtrim(pathname_((he1.dname), (he1.ename)), " >"),
	      dim(seg2_words,1), rtrim(pathname_((he2.dname), (he2.ename)), " >"));
	else if unspec(seg1_words) ^= unspec(seg2_words) then do;
	   words_disagreeing = 0;
	   first_disagreement = 0;
	   do wordx = lbound(seg1_words,1) to hbound(seg1_words,1);
	      if seg1_words(wordx) ^= seg2_words(wordx) then do;
	         words_disagreeing = words_disagreeing + 1;
	         if words_disagreeing = 1 then
		  first_disagreement = wordx;
	         end;
	      end;
	   call error (sci_ptr, -1,
	      "^a: Segment ^d -- Segment Contents Discrepancy, ^d word^[s^].
--FIRST DISCREPANCY--
  Master: word(^d) = ^w, for ^a 
  Copy:   word(^d) = ^w, for ^a", hhmmm(), segx,
	      words_disagreeing^=1, words_disagreeing,
	      first_disagreement, seg1_words(first_disagreement),
	      rtrim(pathname_((he1.dname), (he1.ename)), " >"),
	      first_disagreement, seg2_words(first_disagreement),
	      rtrim(pathname_((he2.dname), (he2.ename)), " >"));
	   end;
	if error$occurred() then do;
	   severity = max(severity, 3);
	   return (FALSE);
	   end;
	else
	   return (TRUE);

	end compare_seg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* COMPARE ALL SEGMENTS ON COPY with SEGMENTS ON MASTER:		       */
/* 1) Get temp segments to hold dir entry header, and entry contents	       */
/*    (segment) from master and copy tapes.			       */
/* 2) Initialize variables for "last entry read".  This is needed since a    */
/*    backup tape can end with a complete segment while backup_dump thinks   */
/*    the segment was incomplete.  Therefore, it rewrites the segment at     */
/*    the beginning of the next tape.  Such duplicate entries are ignored    */
/*    via the "last entry read" variables.			       */
/* 3) Read master and copy segs in a loop until input is exhausted.	       */
/*    Reading occurs in two steps: first read the header; then read the      */
/*    segment contents if header says this segment participates in the       */
/*    comparison.  Some master segments may be omitted from comparison,      */
/*    because they aren't selected by the -select file.		       */
/* 4) If master entry wasn't selected, then skip it.		       */
/* 5) If master selected, compare the two segs.  Count segs comparing equal. */
/* 6) Report how many entries and msfs were successfully compared.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

compare_segs:
       	proc ();

    dcl  (compare_continues, need_copy, need_master)
				bit(1),
         (error_count, extra_masters)	fixed bin,
	MAX_ERRORS		fixed bin int static options(constant) init(20);

	if mbf.hp = null then
	   call ssu_$get_temp_segment (sci_ptr, "master header", mbf.hp);
	if mbf.segp = null then
	   call ssu_$get_temp_segment (sci_ptr, "master segment", mbf.segp);
	call ssu_$get_temp_segment (sci_ptr, "copy header", cpbf.hp);
	call ssu_$get_temp_segment (sci_ptr, "copy segment", cpbf.segp);

	mlast.path = "";
	mlast.sizes = 0;
	cplast.path = "";
	cplast.sizes = 0;

	error_count, extra_masters = 0;
	compare_continues = TRUE;
	need_master = TRUE;
	need_copy = TRUE;
	do while (compare_continues);
	   if need_copy then do;
READ_COPY:      if read_seg$header(cpbf, cplast, output) then do;
	         state = read_seg$contents (cpbf, cplast, output);
	         if state = READ_AGAIN then go to READ_COPY;
	         else if state = OK then
		  need_copy = FALSE;
	         end;
	      end;

	   if need_master then do;
	      if read_seg$header(mbf, mlast, input) then
	         need_master = FALSE;
	      end;

	   if need_master & need_copy then		/* When input    */
	      compare_continues = FALSE;		/* ends from     */
						/* both, compare */
						/* is done.      */

	   else if need_master then do;		/* copy has seg  */
						/*  not on master*/
	      compared.segs = compared.segs + 1;
	      if (cphe.record_type = sec_dir |
	         cphe.record_type = ndc_directory) &
	         cphe.bitcnt > 0 then
	         compared.msfs = compared.msfs + 1;
	      call error (sci_ptr, -1,
"^a: Segment ^d -- 
  Copy contains segment not on master media.
  Copy:  ^a",      hhmmm(), compared.segs,
	         rtrim(pathname_((cphe.dname), (cphe.ename))," >"));
	      error_count = error_count + 1;
	      if abort_sw then
	         compare_continues = FALSE;
	      else if error_count > MAX_ERRORS then
	         compare_continues = FALSE;
	      else
	         need_copy = TRUE;
	      end;

	   else if skip_seg (mbf, cpbf, need_copy) then do;
	      state = read_seg$skip_contents(mbf, mlast, input);
	      need_master = TRUE;			/* master seg    */
	      end;				/*  not selected */

	   else if need_copy then do;			/* master has seg*/
						/*  not on copy  */
	      state = read_seg$skip_contents (mbf, mlast, input);
	      need_master = state = NOMORE;
	      if ^need_master then do;
	         extra_masters = extra_masters + 1;
	         call error (sci_ptr, -1,
"^a: Segment ^d -- 
  Master contains segment not on copy media.
  Master:  ^a",	  hhmmm(), compared.segs+extra_masters,
		  rtrim(pathname_((mhe.dname),(mhe.ename))," >"));
	         error_count = error_count + 1;
	         if abort_sw then
		  compare_continues = FALSE;
	         else if error_count > MAX_ERRORS then
		  compare_continues = FALSE;
	         else
		  need_master = TRUE;
	         end;
	      end;

	   else do;				/* read rest of  */
						/*  master       */
	      state = read_seg$contents(mbf, mlast, input);
	      if state ^= OK then			/* master seg    */
	         need_master = TRUE;			/*  incomplete.  */
	      else do;				/* compare segs  */
	         if compare_seg(mbf, cpbf, compared.segs+1) then do;
		  compared.segs = compared.segs + 1;
		  if (mhe.record_type = sec_dir |
		      mhe.record_type = ndc_directory) &
		      mhe.bitcnt > 0 then
		     compared.msfs = compared.msfs + 1;
		  need_master, need_copy = TRUE;
		  end;
	         else do;
		  error_count = error_count + 1;
		  if abort_sw then
		     compare_continues = FALSE;
		  else if error_count > MAX_ERRORS then
		     compare_continues = FALSE;
		  else if mhe_name.dname <= cphe_name.dname &
			mhe_name.ename <= cphe_name.ename then
		     need_master = TRUE;
		  else
		     need_copy = TRUE;
		  end;
	         end;
	      end;
	   end;

	call detach (addr(input), KEEP);
	call detach (addr(output), KEEP);

	call ioa_ ("");
	call ssu_$print_message (sci_ptr, 0,
	   "^a: Compared ^d entr^[ies^;s^], including ^d multisegment file^[s^].^[
^d comparison error^[ was^;s were^] found.^]^/",
	   hhmmm(), compared.segs, compared.segs^=1,
	   compared.msfs, compared.msfs^=1,
	   error_count>0, error_count, error_count=1);
	if error_count > 0 then
	   severity = max(severity,3);
	return;

	end compare_segs;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* COPYING ENTRIES:						       */
/* 1) Get temp segments to hold dir entry header, and entry contents	       */
/*    (segment).						       */
/* 2) Initialize variables for last entry read.			       */
/* 3) Initialize map file.					       */
/* 4) Read segs in a loop until input is exhausted.		       */
/* 5) If entry just read is same as last entry, then skip it.  This can      */
/*    occur if an entry just fits on the end of one tape, but was rewritten  */
/*    at the beginning of the next tape.			       */
/* 6) If not same as last entry, then write it onto the output.  Put segment */
/*    into the map.  Count number of segs actually copied.		       */
/* 7) Report how many entries and msfs were copied.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


copy_segs:
       	proc ();

	call ssu_$get_temp_segment (sci_ptr, "input header", inbf.hp);
	call ssu_$get_temp_segment (sci_ptr, "input segment", inbf.segp);

	inlast.path = "";
	inlast.sizes = 0;

	state = READ_AGAIN;
	do while (read_seg$header(inbf, inlast, input) & state^=NOMORE);
	   if skip_seg (inbf, inbf, FALSE) then
	      state = read_seg$skip_contents(inbf, inlast, input);
	   else do;
	      state = read_seg$contents(inbf, inlast, input);
	      if state = READ_AGAIN then;
	      else if state = NOMORE then;
	      else do;
	         if write_seg(inbf, output) then do;
		  call map_seg  (inbf);
		  copied.segs = copied.segs + 1;
		  if (inhe.record_type = sec_dir |
		      inhe.record_type = ndc_directory) &
		      inhe.bitcnt > 0 then
		     copied.msfs = copied.msfs + 1;
		  end;
	         else do;
		  call error$fatal (sci_ptr, -1,
		     "^a: FATAL ERROR: Too few output tapes to hold all copied files.",
		     hhmmm());
		  end;
	         end;
	      end;
	   end;

	call detach (addr(input), KEEP);
	call detach (addr(output), KEEP);

	call ioa_("");
	call ssu_$print_message (sci_ptr, 0,
	   "^a: Copied ^d entr^[ies^;y^], including ^d multisegment file^[s^].^/",
	   hhmmm(), copied.segs, copied.segs^=1,
	   copied.msfs, copied.msfs^=1);

	end copy_segs;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* CLOSE/DETACH I/O SWITCHES:					       */
/* 1) Check if switch was even found (or if already destroyed).	       */
/* 2) If switch was used used for iox_$move_attach, move back the original   */
/*    attachment.						       */
/* 3) Otherwise, close an opened switch; detach an attached switch.	       */
/* 4) If disposition = DESTROY, then destroy the I/O switch.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

detach:	proc (iop, disp);

    dcl	iop			ptr,
	disp			fixed bin;

    dcl	1 io			aligned based (iop),
	  2 header		like in_out.header,
	  2 vol (0 refer (io.header.voln))
				like in_out.vol;

	if io.iocbp = null then;

	else if io.mode = FOR_MOVE_ATTACH then do;
	   call iox_$detach_iocb (io.iocbp, code);
	   call iox_$move_attach (io.target_iocbp, io.iocbp, code);
	   call iox_$destroy_iocb (io.target_iocbp, code);
	   io.iocbp = null;
	   end;

	else do;
	   if io.iocbp -> iocb.open_descrip_ptr ^= null then do;
	      if io.vfile.path ^= "" then do;
	         call iox_$close (io.iocbp, code);
	         call error (sci_ptr, code,
		  "^/Closing ^a file: ^a", io.header.name,
		  io.vfile.expath);
	         end;
	      else do;
	         call iox_$close (io.iocbp, code);
	         call error (sci_ptr, code,
		  "^/^a: Closing ^a tape: ^a", hhmmm(), io.header.name,
		  io.vol(io.tape.volx).name);
	         end;
	      end;

	   if io.iocbp -> iocb.attach_descrip_ptr ^= null then do;
	      if io.vfile.path ^= "" then do;
	         call iox_$detach_iocb (io.iocbp, code);
	         call error (sci_ptr, code,
		  "^/Detaching ^a file: ^a", io.header.name,
		  io.vfile.expath);
	         end;
	      else do;
	         call iox_$detach_iocb (io.iocbp, code);
	         call error (sci_ptr, code,
		  "^/^a: Detaching ^a tape: ^a", hhmmm(), io.header.name,
		  io.vol(io.tape.volx).name);
	         if disp = KEEP then
		  call ssu_$print_message (sci_ptr, 0,
		     "^a: Dismounted ^a tape: ^a", hhmmm(), io.header.name,
		     io.vol(io.tape.volx).name);
	         end;
	      end;
	   end;

	if io.iocbp ^= null then
	if disp = DESTROY then do;
	   call iox_$destroy_iocb (io.iocbp, code);
	   io.iocbp = null;
	   end;

	end detach;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ERROR REPORTING ROUTINES:					       */
/* 1) Nonfatal errors set a switch, which can be tested via error_occurred   */
/*    function.						       */
/* 2) Fatal errors abort the subsystem by calling the exit_proc, which       */
/*    branches to the EXIT label to exit the command.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    dcl	error_occurred_sw		bit(1);

error: 	proc options (variable);

    dcl	code			fixed bin(35) based (codep),
	codep			ptr;

    dcl	cu_$arg_list_ptr		entry returns(ptr),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21),
				     fixed bin(35)),
	cu_$generate_call		entry (entry, ptr);

    dcl	CODE_ARG			fixed bin int static options(constant) init(2),
         (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant);

	call cu_$arg_ptr (CODE_ARG, codep, 0, 0);
	if code = 0 then return;
	if code = -1 then code = 0;
	error_occurred_sw = TRUE;
	call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr());
	return;

error$init:
	entry;

	error_occurred_sw = FALSE;
	return;
	

error$occurred:
	entry returns (bit(1));

	return (error_occurred_sw);
	

error$fatal:
	entry options(variable);
	
	call cu_$arg_ptr (CODE_ARG, codep, 0, 0);
	if code = 0 then return;
	if code = -1 then code = 0;
	error_occurred_sw = TRUE;
	call ioa_ ("");
	call cu_$generate_call (ssu_$abort_subsystem, cu_$arg_list_ptr());
	end error;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ARGUMENT GETTING FUNCTIONS:				       */
/*  get_arg: 	Get next argument.				       */
/*  get_arg_count:	Get number of arguments.			       */
/*  get_ctl_arg:	Get next argument, which must be a control argument.     */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

get_arg:	proc returns (bit(1));

    dcl  (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant);

	if argx < argn then do;
	   argx = argx + 1;
	   call ssu_$arg_ptr (sci_ptr, argx, argp, argl);
	   return (TRUE);
	   end;
	else
	   return (FALSE);
	end get_arg;


get_arg_count:
       	proc returns (fixed bin);
	return (argn);
	end get_arg_count;
       

get_ctl_arg:
       	proc returns (bit(1));

    dcl	index			builtin;

    dcl  (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
	error_table_$bad_arg	fixed bin(35) ext static;

	if get_arg() then
	   if index(arg, "-") = 1 then
	      return (TRUE);
	   else
	      call error$fatal (sci_ptr, error_table_$bad_arg,
	      "^a.^/A control argument was expected.", arg);
	return (FALSE);
	end get_ctl_arg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* EXTRACT FINAL ENTRYNAME from pathname			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

get_entry:
       	proc (path) returns (char(32));

    dcl	path			char(168);
	
    dcl	code			fixed bin(35),
	dir			char(168),
	ent			char(32);

    dcl	expand_pathname_		entry (char(*), char(*), char(*), fixed bin(35));

	call expand_pathname_ (path, dir, ent, code);
	return (ent);
	end get_entry;



















/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* CONTROL ARG OPERAND GETTING FUNCTIONS:			       */
/*  get_num_opt:  Gets next arg, treats it as an integer operand, checks     */
/*	        that its value is valid.			       */
/*  get_opt:      Gets next arg.				       */
/*							       */
/* Both allow the caller to specify whether the operand is required (an      */
/* opt_desc is provided) or optional (opt_desc="").		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

get_num_opt:
	proc (arg_name, opt_desc, default_value, allowed_values)
	returns (bit(1));

    dcl	arg_name			char(*),
	opt_desc			char(*),
	default_value		fixed bin,
	allowed_values (*)		fixed bin;

    dcl	valx			fixed bin;

    dcl  (convert, dim, hbound, lbound)	builtin;

    dcl  (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
         (error_table_$bad_arg,
	error_table_$noarg)		fixed bin(35) ext static;

	if argx < argn then do;
	   argx = argx + 1;
	   call ssu_$arg_ptr (sci_ptr, argx, optp, optl);
	   if verify (opt, "0123456789") > 0 then go to BAD_OPT;
	   num_opt = convert (num_opt, opt);
	   do valx = lbound(allowed_values,1)
	          to hbound(allowed_values,1)
	       while (num_opt ^= allowed_values(valx));
	      end;
	   if valx <= hbound(allowed_values,1) then
	      return (TRUE);
	   else do;
BAD_OPT:	      call error (sci_ptr, error_table_$bad_arg,
	         "^a ^a
^a must be followed by a^[n^] ^a.^[
Default value is:^- ^d^;^s^]^[
Allowed ^[value is^;values are^]:^-^( ^d^)^]",
	         arg_name, opt, arg_name,
	         vowel(opt_desc), opt_desc, 
	         default_value ^= -1, default_value,
	       ^(dim(allowed_values,1)=1 & default_value=allowed_values(1)),
	         dim(allowed_values,1)=1, allowed_values);
	      return (FALSE);
	      end;
	   end;
	else if opt_desc ^= "" then do;
	   call error (sci_ptr, error_table_$noarg,
	      "^/^a must be followed by a^[n^] ^a.^[
Default value is:^- ^d^;^s^]^[
Allowed ^[value is^;values are^]:^-^( ^d^)^]", arg_name,
	      vowel(opt_desc), opt_desc,
	      default_value ^= -1, default_value,
	      ^(dim(allowed_values,1)=1 & default_value=allowed_values(1)),
	      dim(allowed_values,1)=1, allowed_values);
	   return (FALSE);
	   end;
	end get_num_opt;

get_opt:	proc (arg_name, opt_desc) returns (bit(1));

    dcl	arg_name			char(*),
	opt_desc			char(*);

    dcl  (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
	error_table_$noarg		fixed bin(35) ext static;

	if argx < argn then do;
	   argx = argx + 1;
	   call ssu_$arg_ptr (sci_ptr, argx, optp, optl);
	   if index(opt, "-") = 1 then do;		/* options cannot*/
	      argx = argx - 1;			/*  look like    */
	      go to NO_OPT;				/*  control args */
	      end;
	   else
	      return (TRUE);
	   end;
	else
NO_OPT:	   if opt_desc ^= "" then do;
	      call error (sci_ptr, error_table_$noarg,
	         "^/^a must be followed by a^[n^] ^a.", arg_name,
	         vowel(opt_desc), opt_desc);
	      return (FALSE);
	      end;
	return (FALSE);
	end get_opt;


vowel: 	proc (str) returns (bit(1));			/* does opt_desc */
						/* begin with a  */
						/* vowel?	       */

    dcl	str			char(*),
         (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant);

	if search ("aeiouAEIOU", substr(str,1,1)) > 0 then
	   return (TRUE);
	else
	   return (FALSE);
	end vowel;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* MAJOR OPERATION HEADER:					       */
/* Pretty-print a header describing:				       */
/* 1) the name of the operation about to begin;			       */
/* 2) the input media;					       */
/* 3) the output media.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

header:	proc (op, in, out);

    dcl	op			char(*),
	1 in			aligned like input,
	1 out			aligned like output;

    dcl  (from, to)			char(32) varying,
	indent			fixed bin;

    dcl	SP			char(1) int static options(constant) init(" ");

	call ioa_ ("");
	call ssu_$print_message (sci_ptr, 0,
	   "^a: ^a...", hhmmm(), op);

	call label (from, "from", in);
	call label (to,   "to",  out);
	indent = max (length(from), length(to)) + length(SP);
	call medium (from, indent, in);
	call medium (to,   indent, out);
	return;


label:	proc (lab, name, out);			/* compute value */
						/* of media label*/

    dcl	lab			char(32) varying,
	name			char(*),
	1 out			aligned like output;

	lab = "  ";
	lab = lab || name;
	lab = lab || " ";
	lab = lab || out.header.name;
	if out.vfile.path ^= "" then 
	   lab = lab || " file:";
	else if out.tape.voln = -1 then
	   lab = lab || " sink:";
	else if out.tape.voln ^= 1 then
	   lab = lab || " tapes:";
	else
	   lab = lab || " tape:";

	end label;


medium:	proc (lab, indent, out);			/* print medium  */
						/* label & value */

    dcl	lab			char(32) varying,
	indent			fixed bin,
	1 out			aligned like output;
	
    dcl	code			fixed bin(35),
	len			fixed bin,
	maxlen			fixed bin,
	printed			fixed bin,
	x			fixed bin;

	if out.vfile.path ^= "" then
	   call ioa_ ("^a^vt ^a", lab, indent, out.vfile.expath);
	else if out.tape.voln = -1 then
	   call ioa_ ("^a^vt ^a", lab, indent, "discard");
	else if out.tape.voln > 0 then do;
	   len = indent-1;
	   maxlen = get_line_length_$switch (null, code);
	   if code ^= 0 then maxlen = 79;
	   printed = 0;
	   do x = 1 to out.tape.voln;
	      if len + length(SP) + length(out.vol(x).name) > maxlen then do;
	         call ioa_ ("^a^vt^vs^v( ^a^)",
		  lab, indent, printed, x-1-printed, out.vol(*).name);
	         printed = x-1;
	         lab = "";
	         end;
	      end;
	   call ioa_ ("^a^vt^vs^v( ^a^)",
	      lab, indent, printed, x-1-printed, out.vol(*).name);
	   end;
	end medium;
	end header;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* CURRENT TIME: in form of ^Hd^99v.9MH (ie, HHMM.M).		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

hhmmm: 	proc returns (char(6) varying);

    dcl	1 time_form		aligned,
	  2 hhmm			char(4) unal,
	  2 ss			pic "99" unal,
	result			char(6) varying;

    dcl	time			builtin;

	string(time_form) = substr(time(),1,length(string(time_form)));
	result = time_form.hhmm;
	result = result || ".";
	result = result || ltrim(char(divide(time_form.ss, 6, 1, 0)));
	return (result);

	end hhmmm;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* INITIALIZATION.						       */
/* 1) Initialize variables holding argument values.		       */
/* 2) Initialize other program data variables.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

initialize_args:
	proc;

    dcl	UNSET			char(1) int static options(constant) init("~"),
	UNSPECIFIED		ptr int static options(constant) init(null);

	in_outp = UNSPECIFIED;

	if operation_wanted = COMPARE then
	   input.header.name = "master";
	else
	   input.header.name = "input";
	input.iocbp = null;
	input.target_iocbp = null;
	input.mode = 0;
	input.recx = 0;
	input.vfile.path, input.vfile.expath = ""; input.vfile.charpos = 0;
	input.tape.voln,  input.tape.volx = 0;
	input.tape.track, input.tape.density = 0;
	input.vol(*) = "";

	output = input;
	if operation_wanted = COMPARE then
	   output.header.name = "copy";
	else
	   output.header.name = "output";

	select = output, by name;
	select.name = "select";
	select.listp = null;
	select.select_sw = FALSE;

	map = output, by name;
	map.name = "map";
	map.vfile.path = UNSET;

	map_prev = map;
	map_prev.name = "map_prev";

	abort_sw = FALSE;
	maximize_devices_sw = FALSE;
	trace = OFF;

	inbf.blrh.zz1, inbf.blrh.zz2 = BLRH_DELIMITER;
	inbf.blrh.english = BLRH_ENGLISH;
	inbf.blrh.hl, inbf.blrh.segl = 0;
	inbf.hp, inbf.segp = null;
	cpbf = inbf;

	copied, compared = 0;

	pp = addr(pp);				/* Used in an    */
						/* include file  */
	call tape_drive$init();
	
	end initialize_args;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ADD A MAP ENTRY for a segment.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    dcl	map_last_dir		char(168);

map_seg:	proc (bf);

    dcl	1 bf			aligned like inbf,
	bp			ptr,
	1 b			aligned like br based(bp),
	1 he			aligned like h based (bf.hp),
	nn			fixed bin,
	np			ptr,
	nx			fixed bin,
	1 n (nn)			aligned based (np),
	  2 l			fixed bin(17) uns unal,
	  2 pad			bit(19) unal,
	  2 string		char(32) unal,
	1 seg			aligned,
	  2 type			char(10),
	  2 blocks		fixed bin(9),
	  2(dtem, dtd, dtu, dtcm)	fixed bin(52);

    dcl	TYPE_STRING (0:20)		char(10) aligned int static options(constant) init (
	  "link", "segment", "directory", "directory",
	  (15)*,  "segment", "directory");

    dcl	sys_info$page_size		fixed bin external static,
	sys_info$seg_size_256K	fixed bin external static;

	if map.vfile.path = "" then
	   return;

	if map_last_dir ^= he.dname then do;
	   map_last_dir  = he.dname;
	   call backup_map_$directory_line (addr(he.dname), he.dlen);
	   end;

	seg.type = TYPE_STRING (he.record_type);
	bp = ptr (addr(he), he.bp);
	seg.blocks = min (bin (bp -> br (1).cl, 9),
	   divide (sys_info$seg_size_256K + sys_info$page_size - 1,
	   sys_info$page_size, 17, 0));
	seg.dtem = bin (b.dtbm, 52, 0); seg.dtd  = bin (b.dtd,  52, 0);
	seg.dtu  = bin (b.dtu,  52, 0); seg.dtcm = bin (b.dtm,  52, 0);

	call backup_map_$detail_line2 (he.ename, seg.blocks, seg.type,
	   clock(), seg.dtem, seg.dtd, seg.dtu, seg.dtcm);

	np = ptr (addr(he), b.namerp);  nn = bin (b.nnames, 17);
	if he.record_type ^= ndc_directory_list then 
	do nx = 2 to nn;
	   call backup_map_$name_line (addr(n.string(nx)), (n.l(nx)));
	   end;

	end map_seg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* BACKUP MAP INITIALIZATION:					       */
/* 1) Return if -map not given.				       */
/* 2) The backup_map_ subr does all its output on the map I/O switch, so     */
/*    attach it as a synonym for the switch our map file is attached thru.   */
/* 3) Put description of output medium in map header line, along with	       */
/*    current date, and name of -select file.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

       

map_seg$init:
       	proc (out);

    dcl	1 out			aligned like output;

    dcl	date_time_string		char(40) varying,
	map_header		char(300) varying,
	map_line			char(300),
	out_header		char(128) varying;

	if map.vfile.path = "" then
	   return;

	call iox_$attach_name ("map", map_prev.iocbp,
	   "syn_ " || map.iocbp -> iocb.name, null, code);
	if code = error_table_$not_detached then do;
	   call attach (addr(map_prev), FOR_MOVE_ATTACH);
	   call iox_$move_attach (map_prev.iocbp, map_prev.target_iocbp,
	      code);
	   call error$fatal (sci_ptr, code,
	      "^/FATAL ERROR: Moving attachment of map switch.");
	   call iox_$attach_name ("map", map_prev.iocbp,
	      "syn_ " || map.iocbp -> iocb.name, null, code);
	   end;
	call error$fatal (sci_ptr, code,
	   "^/FATAL ERROR: Attaching map switch as synonym for ^a.",
	   map.iocbp -> iocb.name);

	if out.vfile.path ^= "" then
	   out_header = "File: " || get_entry (out.vfile.path);
	else if out.tape.voln > 1 then
	   out_header = "Tape: " || out.vol(1).name;
	else
	   out_header = "discard sink";
	call backup_map_$init_for_cdt (out_header);

	date_time_string = date_time_$format ("date_time", clock(), "", "");
	call backup_util$idline (map.vfile.expath,
	   (date_time_string), addr(map_line), length(map_line));

	map_line = out_header;
	call backup_map_$tapes (addr(map_line), length(rtrim(map_line)));

	map_header = rtrim(ME);
	map_header = map_header || " version 1.0";
	if select.vfile.path ^= "" then do;
	   map_header = map_header || " -select ";
	   map_header = map_header || select.vfile.expath;
	   end;
	map_line = map_header;
	call backup_map_$beginning_line (clock(), addr(map_line),
	   length(map_line));

	map_last_dir = "";
	end map_seg$init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* BACKUP MAP NEW OUTPUT TAPE:				       */
/* 1) Change name of output tape in the map.			       */
/* 2) Repeat directory name at top of new map page.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

       

map_seg$new_tape:
	proc (out);

    dcl	1 out			aligned like output;

    dcl	map_line			char(300);

	if map.vfile.path = "" then
	   return;

	if out.tape.voln > 0 then do;
	   map_line = "Tape: " || out.vol(out.tape.volx).name;
	   call backup_map_$tapes (addr(map_line), length(rtrim(map_line)));
	   end;
	call backup_map_$heading_line();
	map_last_dir = "";

	end map_seg$new_tape;
	


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* BACKUP MAP TERMINATION:					       */
/* 1) Detach synonym for map switch.				       */
/* 2) Close the map file.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

map_seg$term:
	proc;

    dcl	code			fixed bin(35);

	if map.vfile.path = "" then;
	else do;
	   if map_prev.iocbp ^= null then do;
	      call backup_map_$terminal_line (clock(), 0);
	      call backup_map_$detach_for_cdt (code);
	      call detach (addr(map_prev), DESTROY);
	      call detach (addr(map), DESTROY);
	      end;
	   end;
	end map_seg$term;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* MOUNT NEXT TAPE:						       */
/* 1) Detach current input or output tape.			       */
/* 2) If no more tapes exist, return FALSE.			       */
/* 3) Otherwise, select drive on which to mount tape (if -maxdv given).      */
/* 4) Attach and open the tape, via tape_mult_.  For stream_output	       */
/*    openings, set mode to asynchronous.  This means we must do an	       */
/*    error_count operation after every backup logical record, to ensure     */
/*    that it gets completely written to tape.			       */
/* 5) Report time to tape mount to the user.			       */
/* 6) Find out for sure (from RCP) which tape drive the tape was mounted on  */
/*    (if -maxdv given).					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

mount_next_tape_vol:
       	proc (io) returns (bit(1));

    dcl	1 io			aligned like input;

    dcl	atd			char(256) varying,
	code			fixed bin(35);

	if io.iocbp -> iocb.open_descrip_ptr ^= null then 
	   call detach (addr(io), KEEP);

	if io.tape.volx >= io.tape.voln then
	   return (FALSE);

	io.tape.volx = io.tape.volx + 1;
	if io.vol(io.tape.volx).device ^= "" then
	   call tape_drive$select_another_device (io);
	else
	   call tape_drive$select_a_device (io);

	atd = "tape_mult_ " || rtrim(io.vol(io.tape.volx).name);
	if io.mode = Stream_output | 
	   (^maximize_devices_sw &
	    io.header.name = "output" &
	    operation_wanted = COPY_AND_COMPARE) then
	   atd = atd || " -write";
	if io.vol(io.tape.volx).device ^= "" then do;
	   atd = atd || " -device ";
	   atd = atd || rtrim(io.vol(io.tape.volx).device);
	   end;
	atd = atd || " -density ";
	atd = atd || ltrim(char(io.tape.density));
	atd = atd || " -track ";
	atd = atd || ltrim(char(io.tape.track));
	atd = atd || " -error_tally";

	call ssu_$print_message (sci_ptr, 0,
	   "^a: Mounting ^a tape ^a^[ on ^a^;^s^].^[^/  (^a)^]",
	   hhmmm(), io.header.name, io.vol(io.tape.volx).name,
	   io.vol(io.tape.volx).device ^= "", io.vol(io.tape.volx).device,
	   trace ^= OFF, atd);
	call iox_$attach_ptr (io.iocbp, (atd), null, code);
	call error$fatal (sci_ptr, code,
	   "^/^a: FATAL ERROR: Attaching ^a tape ^a for ^[reading^;writing^].",
	   hhmmm(), io.header.name, io.vol(io.tape.volx).name,
	   io.mode=Stream_input);
	call iox_$open (io.iocbp, io.mode, ""b, code);
	call error$fatal (sci_ptr, code,
	   "^/^a: FATAL ERROR: Opening ^a tape ^a for ^[reading^;writing^].",
	   hhmmm(), io.header.name, io.vol(io.tape.volx).name,
	   io.mode=Stream_input);
	if io.mode = Stream_output then do;
	   call iox_$modes (io.iocbp, "async", "", code);
	   call error$fatal (sci_ptr, code,
	      "^/^a: FATAL ERROR: Setting aync mode on ^a tape: ^a",
	      hhmmm(), io.header.name, io.vol(io.tape.volx).name);
	   end;
	call tape_drive$find_device (io.vol(io.tape.volx));
	call ssu_$print_message (sci_ptr, 0,
	   "^a: Finished mounting ^a tape: ^a",
	   hhmmm(), io.header.name, io.vol(io.tape.volx).name);
	return (TRUE);

	end mount_next_tape_vol;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* PROCESS ARGUMENTS					       */
/* 1) Match argument to ctl_arg name and operands.		       */
/* 2) Validate that proper input and output media are specified.	       */
/* 3) Complete specification of map pathname if -map is given.	       */
/*							       */
/* NOTE: Several control arguments affect either input or output media,      */
/*       depending upon whether -input_XXX or -output_XXX control arg was    */
/*       most recently given.  in_outp records this choice.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

process_args:
	proc;

    dcl	UNSET			char(1) int static options(constant) init("~"),
	UNSPECIFIED		ptr int static options(constant) init(null),
	VAL_7_9 (2)		fixed bin int static options(constant) init(7, 9),
	VAL_8_16_62 (3)		fixed bin int static options(constant) init(800, 1600, 6250);

    dcl	opt_desc			char(32);

	if get_arg_count() = 0 then
	   call error$fatal (sci_ptr, error_table_$wrong_no_of_args,
  	      "^/Usage:  ^a INPUT_SPEC OUTPUT_SPEC^[ {-compare}^] {-control_args}",
	      ME, operation_wanted = COPY);

CTL_ARG_LOOP:
	do while (get_ctl_arg ());
	   if arg = "-input_volume" | arg = "-ivol" then do;
	      in_outp = addr(input);
SET_REEL:	      in_out.tape.voln = 0;
	      in_out.vol(*) = "";
	      input.tape.track = 9;
	      input.tape.density = 1600;
	      in_out.vfile.path = "";
	      opt_desc = in_out.header.name || " tape volume name";
	      if get_opt (arg, opt_desc) then do;
	         in_out.tape.voln = 1;
	         in_out.vol(1).name = opt;
	         end;
	      do while (get_opt ("", ""));
	         if in_out.tape.voln >= hbound(in_out.vol,1) then
		  call error (sci_ptr, error_table_$too_many_names,
		     "^a ^a.^/Only ^d names may be given.", arg, opt,
		     hbound(in_out.vol,1));
	         else do;
		  in_out.tape.voln = in_out.tape.voln + 1;
		  in_out.vol(in_out.tape.voln).name = opt;
		  end;
	         end;
	      end;

	   else if arg = "-input_file" | arg = "-if" then do;
	      in_outp = addr(input);
SET_PATH:	      in_out.tape.voln = 0;
	      in_out.vol(*) = "";
	      in_out.tape.track, in_out.tape.density = 0;
	      in_out.vfile.path = "";
	      opt_desc = in_out.header.name || " file pathname";
	      if get_opt (arg, opt_desc) then do;
	         if in_out_selected() then do;
		  in_out.vfile.path = opt;
		  call absolute_pathname_ (in_out.vfile.path,
		     in_out.vfile.expath, code);
		  call error (sci_ptr, code, "^a ^a", arg, opt);
		  if code = 0 then
		     in_out.vfile.expath = get_shortest_path_ (in_out.vfile.expath);
		  end;
	         end;
	      end;

	   else if arg = "-output_volume" | arg = "-ovol" then do;
	      in_outp = addr(output);
	      go to SET_REEL;
	      end;
	   else if arg = "-output_file" | arg = "-of" then do;
	      in_outp = addr(output);
	      go to SET_PATH;
	      end;
	   else if (arg = "-output_discard" | arg = "-od") &
		  mod(operation_wanted,2) = COPY then do;
	      in_outp = addr(output);
	      in_out.tape.voln = -1;
	      in_out.vol(*) = "";
	      in_out.tape.track, in_out.tape.density = 0;
	      in_out.vfile.path = "";
	      end;

	   else if (arg = "-master_volume" | arg = "-mvol") &
		 operation_wanted = COMPARE then do;
	      in_outp = addr(input);
	      go to SET_REEL;
	      end;
	   else if (arg = "-copy_volume" | arg = "-cvol") &
		 operation_wanted = COMPARE then do;
	      in_outp = addr(output);
	      go to SET_REEL;
	      end;

	   else if arg = "-track" | arg = "-tk" then do;
	      if get_num_opt (arg, "tape track specification", 9, VAL_7_9) then do;
	         if in_out_selected() then
		  in_out.tape.track = num_opt;
	         end;
	      end;
	   else if arg = "-density" | arg = "-den" then do;
	      if get_num_opt (arg, "tape density specification", 1600, VAL_8_16_62) then do;
	         if in_out_selected() then 
		  in_out.tape.density = num_opt;
	         end;
	      end;

	   else if arg = "-abort" then
	      abort_sw = TRUE;
	   else if arg = "-no_abort" | arg = "-nabort" then
	      abort_sw = FALSE;

	   else if arg = "-trace" then do;
	      if get_opt ("", "") then do;
	         if opt = "rejects" | opt = "reject" | opt = "rej" then
		  trace = REJECTS;
	         else if opt = "off" then
		  trace = OFF;
	         else if opt = "copy" | opt = "cp" then
		  trace = COPY;
	         else if opt = "compare" | opt = "cmp" then
		  trace = COMPARE;
	         else if opt = "all" | opt = "a" then
		  trace = COPY_AND_COMPARE;
	         else
		  call error (sci_ptr, error_table_$bad_opt,
		     "^a ^a^/Allowed trace types are:
  off
  rejects, rej
  copy, cp
  compare, cmp
  all, a", arg, opt);
	         end;
	      else if operation_wanted = COMPARE then
	         trace = COMPARE;
	      else 
	         trace = COPY;
	      end;
	   else if arg = "-no_trace" | arg = "-ntrace" then
	      trace = OFF;

	   else if arg = "-maximize_devices" | arg = "-maxdv" then
	      maximize_devices_sw = TRUE;
	   else if arg = "-no_maximize_devices" | arg = "nmaxdv" then
	      maximize_devices_sw = FALSE;

	   else if arg = "-select" | arg = "-slct" then do;
	      opt_desc = select.header.name || " file pathname";
	      if operation_wanted = COMPARE then	/* -select path  */
						/* optional for  */
						/* old compare ep*/
	         if get_opt ("", "") then go to SET_SELECT;
	         else select.select_sw = TRUE;
	      else if get_opt (arg, opt_desc) then do;
SET_SELECT:        select.vfile.path = opt;
	         call absolute_pathname_ (select.vfile.path,
		  select.vfile.expath, code);
	         call error (sci_ptr, code, "^a ^a", arg, opt);
	         if code = 0 then
		  select.vfile.expath = get_shortest_path_ (select.vfile.expath);
	         end;
	      end;
	   else if arg = "-no_select" | arg = "-nslct" then do;
	      select.vfile.path = "";
	      select.select_sw = FALSE;
	      end;

	   else if (arg = "-compare" | arg = "-cmp") &
		 mod(operation_wanted,2) = COPY then
	      operation_wanted = COPY_AND_COMPARE;
	   else if (arg = "-no_compare" | arg = "-ncmp") &
		 mod(operation_wanted,2) = COPY then
	      operation_wanted = COPY;

	   else if arg = "-map" & mod(operation_wanted,2) = COPY then do;
	      map.vfile.path = "";			/* Use default   */
						/*  map path     */
	      if get_opt ("", "") then do;		/* optional path */
	         map.vfile.path = opt;
	         call absolute_pathname_$add_suffix (map.vfile.path, "map",
		  map.vfile.expath, code);
	         call error (sci_ptr, code, "^a ^a", arg, opt);
	         if code = 0 then
		  map.vfile.expath = get_shortest_path_ (map.vfile.expath);
	         end;
	      end;
	   else if (arg = "-no_map" | arg = "-nmap") &
		 mod(operation_wanted,2) = COPY then do;
	      map.vfile.path = UNSET;
	      end;
	   else
	      call error (sci_ptr, error_table_$bad_opt, "^a", arg);
	   end CTL_ARG_LOOP;

	if error$occurred() then			/* stop now if   */
	   call error$fatal (sci_ptr, -1);		/* ctl arg errs  */

	if input.tape.voln = 0 & input.vfile.path = "" then
	   call error$fatal (sci_ptr, error_table_$noarg,
	      " An input specification must be
given by -input_volume or -input_file control arguments.");
	if output.tape.voln = 0 & output.vfile.path = "" then
	   call error$fatal (sci_ptr, error_table_$noarg,
	      " An output specification must be
given by -output_volume, -output_file or -output_discard control arguments.");

	if input.tape.density  = 0 then input.tape.density  = 1600;
	if input.tape.track    = 0 then input.tape.track    = 9;
	if output.tape.density = 0 then output.tape.density = 1600;
	if output.tape.track   = 0 then output.tape.track   = 9;

	if output.tape.voln = -1 &
	   operation_wanted = COPY_AND_COMPARE then
	   call error$fatal (sci_ptr, error_table_$inconsistent,
	      "^/-compare is inconsistent with -output_discard.");

	if map.vfile.path = UNSET then
	   map.vfile.path = "";
	else if map.vfile.path = "" then do;
	   if output.vfile.path ^= "" then
	      map.vfile.path = get_entry(output.vfile.path);
	   else if output.tape.voln > 0 then
	      map.vfile.path = output.vol(1).name;
	   else if select.vfile.path ^= "" then 
	      map.vfile.path = get_entry (select.vfile.path);
	   else
	      map.vfile.path = unique_chars_(""b);
	   call absolute_pathname_$add_suffix (map.vfile.path, "map",
	      map.vfile.expath, code);
	   call error$fatal (sci_ptr, code,
	      "Adding map suffix to -output_file or -output_volume name ^a.",
	      map.vfile.path);
	   map.vfile.expath = get_shortest_path_ (map.vfile.expath);
	   end;
	return;


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ARG CONSISTENCY CHECKER:					       */
/* 1) Check for -input_XXX or -output_XXX having been specified, prior to    */
/*    receiving -track or -density.				       */
/* 2) If neither -input_XXX nor -output_XXX was given, diagnose error.       */
/* 3) Otherwise return TRUE to caller.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

in_out_selected:
	proc returns (bit(1));

	if in_outp = UNSPECIFIED then do;
	   call error (sci_ptr, error_table_$inconsistent,
	      "^/^a must follow -input_volume, -input_file, -output_volume, -output_file, or^/-output_discard.", arg);
	   return (FALSE);
	   end;
	return (TRUE);

	end in_out_selected;

	end process_args;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* READ LINE FROM FILE:					       */
/* 1) Read line from -select file.  Remove trailing NL.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    dcl	line			char(300) varying;

read_line:
       	proc (inp) returns (bit(1));

    dcl	inp			ptr,
	1 in			aligned like select based(inp);

    dcl	code			fixed bin(35);

    dcl	1 line_buffer		aligned based(addr(line)),
	  2 l			fixed bin(21),
	  2 data			char(300);

    dcl	HT_SP			char(2) int static options(constant) init("	 "),
	NL			char(1) int static options(constant) init("
");

RE_READ:	call iox_$get_line (in.iocbp, addr(line_buffer.data),
	   length(line_buffer.data), line_buffer.l, code);
	if code = 0 then do;			/* remove NL     */
	   in.recx = in.recx + 1;
	   line = substr (line, 1, length(line) - length(NL));
	   line = ltrim(line, HT_SP);
	   line = rtrim(line, HT_SP);
	   if line = "" then go to RE_READ;		/* blank line    */
	   return (TRUE);
	   end;
	else if code = error_table_$end_of_info then do;
	   line = "";
	   return (FALSE);
	   end;
	else
	   call error$fatal (sci_ptr, code,
	      "^/FATAL ERROR: Reading line ^d from ^a file ^a.", in.recx,
	      in.name, in.vfile.expath);

	end read_line;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* READ BACKUP LOGICAL RECORD HEADER:				       */
/*   Read the header and segment attributes of next segment from input       */
/* medium.  If it is a segment we are interested in, then we will read       */
/* segment contents later; otherwise, we will iox_$position (skip) over the  */
/* segment contents.					       */
/*							       */
/* 1) Decide whether input is from vfile_ or tape.		       */
/* 2) If from vfile_, read size fields from backup logical record header     */
/*    (blrh), followed by the attributes of the segment.		       */
/* 3) If from tape, read backup logical record header itself from tape,      */
/*    followed by the attributes of the segment.  If current tape is	       */
/*    exhausted, mount next tape and try reading blrh again.	       */
/* 4) Return TRUE if another header exists, FALSE if input is exhausted.     */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

read_seg$header:
	proc (bf, last, in) returns(bit(1));

    dcl	1 bf			aligned like inbf,
	1 he			aligned like h based (bf.hp),
	1 last			aligned like inlast,
	1 in			aligned like input;

    dcl   1 blrh			aligned like inbf.blrh based,
	1 blrh_sizes		aligned like inbf.blrh.sizes based,
	readl			fixed bin(21),
	readneed			fixed bin(21);

    dcl	size			builtin;

	if in.vfile.path ^= "" then do;		/* read from file*/
	   call iox_$get_chars (in.iocbp, addr(bf.blrh.sizes),
	      size(blrh_sizes) * CHARS_PER_WORD, readl, code);
	   if code = 0 &
	      readl = size(blrh_sizes) * CHARS_PER_WORD then do;
	      in.vfile.charpos = in.vfile.charpos + readl;
	      bf.blrh.zz1, bf.blrh.zz2 = BLRH_DELIMITER;
	      bf.blrh.english = BLRH_ENGLISH;
	      call iox_$get_chars (in.iocbp, addr(he),
	         bf.blrh.hl * CHARS_PER_WORD, readl, code);
	      if code = 0 &
	         readl = bf.blrh.hl * CHARS_PER_WORD then do;
	         in.vfile.charpos = in.vfile.charpos + readl;
	         return (TRUE);
	         end;
	      end;
	   if code = error_table_$end_of_info then
	      return (FALSE);
	   else
	      call error$fatal (sci_ptr, code,
	         "^/^a: FATAL ERROR: Reading header of record ^d of ^a file:^/  ^a.",
	         hhmmm(), in.recx+1, in.header.name, in.vfile.expath);
	   end;

	else if in.iocbp -> iocb.open_descrip_ptr = null then
	   return (FALSE);				/* all input     */
						/* tapes 	       */
						/* exhausted     */

	else do;					/* read from tape*/
REREAD:	   call iox_$get_chars (in.iocbp, addr(bf.blrh),
	      size(blrh) * CHARS_PER_WORD, readl, code);
	   if code = 0 &
	      readl = size(blrh) * CHARS_PER_WORD then do;
	      if bf.blrh.zz1 ^= BLRH_DELIMITER |
	         bf.blrh.zz2 ^= BLRH_DELIMITER |
	         bf.blrh.english ^= BLRH_ENGLISH then
	         call error$fatal (sci_ptr, -1,
	         "^a: FATAL ERROR: Reading header of record ^d of ^a file:^/  ^a.
Record did not begin with a proper backup logical record header.
Header.zz1:     ^a
Header.english: ^a
Header.zz2:     ^a",
	         hhmmm(), in.recx, in.header.name, in.vol(in.tape.volx).name,
	         bf.blrh.zz1, bf.blrh.english, bf.blrh.zz2);

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* blrh + he, and seg are written in 256-word blocks, so we must round up    */
/* the amount we read to the next 256-word boundary.  At this point,	       */
/* blrh-words have already been read.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	      readneed = bf.blrh.hl + size(blrh) + BLOCK_SIZE - 1;
	      readneed = readneed - mod(readneed, BLOCK_SIZE) - size(blrh);
	      call iox_$get_chars (in.iocbp, addr(he),
	         readneed * CHARS_PER_WORD, readl, code);
	      if code = 0 &
	         readl = readneed * CHARS_PER_WORD then do;
	         if last.dir ^= "" &
		  last.path.dir = he.dname   &
		  last.path.ent = he.ename   &
		  last.sizes.he = bf.blrh.hl &
		  last.sizes.seg= bf.blrh.segl then do;
		  call ssu_$print_message (sci_ptr, 0,
		     "^a: Skipping duplicate ^a segment:^/  ^a",
		     hhmmm(), in.header.name,
		     rtrim(pathname_(last.path.dir, last.path.ent), " >"));
		  readneed = bf.blrh.segl + BLOCK_SIZE - 1;
		  readneed = readneed - mod(readneed, BLOCK_SIZE);
		  call iox_$position (in.iocbp, 3,
		     readneed * CHARS_PER_WORD, code);
		  if code = 0 then 
		     go to REREAD;
		  end;
	         return (TRUE);
	         end;
	      end;
	   if code = error_table_$end_of_info then do;
	      if mount_next_tape_vol (in) then
	         go to REREAD;
	      else
	         return (FALSE);
	      end;
	   else
	      call error$fatal (sci_ptr, code,
	         "^/^a: FATAL ERROR: Reading header of record ^d of ^a tape: ^a.",
	         hhmmm(), in.recx+1, in.header.name,
	         in.vol(in.tape.volx).name);
	   end;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* READ SEGMENT CONTENTS:					       */
/* 1) If input from vfile, read segment contents based upon sizes from blrh. */
/* 2) If input from tape, read segment contents based upon sizes from blrh.  */
/*    Record pathname of segment as the last one which was read completely   */
/*    from tape.						       */
/* 3) In either case, there are three possible outcomes: reading segment     */
/*    contents was successful (OK); input was exhausted (NOMORE); segment    */
/*    contents was incomplete on this tape, need to read header from next    */
/*    tape (READ_AGAIN).					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

read_seg$contents:
	entry (bf, last, in) returns (fixed bin);

	if in.vfile.path ^= "" then do;		/* read from file*/
	   if bf.blrh.segl > 0 then do;
	      call iox_$get_chars (in.iocbp, bf.segp,
	         bf.blrh.segl * CHARS_PER_WORD, readl, code);
	      if code = 0 &
	         readl = bf.blrh.segl * CHARS_PER_WORD then do;
	         in.vfile.charpos = in.vfile.charpos + readl;
	         in.recx = in.recx + 1;
	         return (OK);
	         end;
	      end;
	   else do;
	      in.recx = in.recx + 1;
	      return (OK);
	      end;
	   if code = error_table_$end_of_info then
	      return (NOMORE);
	   else
	      call error$fatal (sci_ptr, code,
	         "^/^a: FATAL ERROR: Reading contents of record ^d of ^a file:^/  ^a.",
	         hhmmm(), in.recx+1, in.header.name, in.vfile.expath);
	   end;
	else do;					/* read from tape*/
	   if bf.blrh.segl > 0 then do;
	      readneed = bf.blrh.segl + BLOCK_SIZE - 1;
	      readneed = readneed - mod(readneed, BLOCK_SIZE);
	      call iox_$get_chars (in.iocbp, bf.segp,
	         readneed * CHARS_PER_WORD, readl, code);
	      if code = 0 &
	         readl = readneed * CHARS_PER_WORD then do;
SETREAD:	         in.recx = in.recx + 1;
	         last.path.dir = he.dname;
	         last.path.ent = he.ename;
	         last.sizes.he = bf.blrh.hl;
	         last.sizes.seg= bf.blrh.segl;
	         return (OK);
	         end;
	      end;
	   else go to SETREAD;

	   if code = error_table_$end_of_info then do;
	      if mount_next_tape_vol (in) then
	         return (READ_AGAIN);
	      else
	         return (NOMORE);
	      end;
	   else
	      call error$fatal (sci_ptr, code,
	         "^/^a: FATAL ERROR: Reading contents of record ^d of ^a tape: ^a",
	         hhmmm(), in.recx+1, in.header.name,
	         in.vol(in.tape.volx).name);
	   end;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* SKIP SEGMENT CONTENTS:					       */
/* 1) If input from vfile, skip segment contents based upon sizes from blrh. */
/* 2) If input from tape, skip segment contents based upon sizes from blrh.  */
/*    Record pathname of segment as the last one which was read completely   */
/*    from tape.						       */
/* 3) In either case, there are three possible outcomes: skipping segment    */
/*    contents was successful (OK); input was exhausted (NOMORE); segment    */
/*    contents was incomplete on this tape, need to read header from next    */
/*    tape (READ_AGAIN).					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

read_seg$skip_contents:
	entry (bf, last, in) returns (fixed bin);

	if in.vfile.path ^= "" then do;		/* read from file*/
	   if bf.blrh.segl > 0 then do;
	      readl = bf.blrh.segl * CHARS_PER_WORD;
	      call iox_$position (in.iocbp, 2, in.vfile.charpos + readl,
	         code);
	      if code = 0 then do;
	         in.vfile.charpos = in.vfile.charpos + readl;
	         in.recx = in.recx + 1;
	         return (OK);
	         end;
	      end;
	   else do;
	      in.recx = in.recx + 1;
	      return (OK);
	      end;
	   if code = error_table_$end_of_info then
	      return (NOMORE);
	   else
	      call error$fatal (sci_ptr, code,
	         "^/^a: FATAL ERROR: Skipping contents of record ^d of ^a file:^/  ^a",
	         hhmmm(), in.recx+1, in.header.name, in.vfile.expath);
	   end;
	else do;					/* read from tape*/
	   if bf.blrh.segl > 0 then do;
	      readneed = bf.blrh.segl + BLOCK_SIZE - 1;
	      readneed = readneed - mod(readneed, BLOCK_SIZE);
	      call iox_$position (in.iocbp, 3, 
	         readneed * CHARS_PER_WORD, code);
	      if code = 0 then do;
SETSKIP:	         in.recx = in.recx + 1;
	         last.path.dir = he.dname;
	         last.path.ent = he.ename;
	         last.sizes.he = bf.blrh.hl;
	         last.sizes.seg= bf.blrh.segl;
	         return (OK);
	         end;
	      end;
	   else go to SETSKIP;

	   if code = error_table_$end_of_info then do;
	      if mount_next_tape_vol (in) then
	         return (READ_AGAIN);
	      else
	         return (NOMORE);
	      end;
	   else
	      call error$fatal (sci_ptr, code,
	         "^/^a: FATAL ERROR: Skipping contents of record ^d of ^a tape: ^a",
	         hhmmm(), in.recx+1, in.header.name,
	         in.vol(in.tape.volx).name);
	   end;

	end read_seg$header;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* PERFORM -select SELECTIONS:				       */
/*   skip_seg chooses which records from the master tape should be selected  */
/* for copying onto copy tape, or for comparision with contents of copy      */
/* tape.							       */
/*							       */
/* SELECT INITIALIZATION:					       */
/* 1) Get temp segment to hold -select data.			       */
/* 2) Read lines from -select file, and add them to -select data list.       */
/*							       */
/* PARSE SELECT LINES:					       */
/* 1) Lines beginning with ^ identify entries NOT to be selected.	       */
/* 2) Lines ending with >** identify entire subtrees to be selected or       */
/*    rejected.						       */
/*							       */
/* SELECT TERMINATION:					       */
/* 1) Report lines in -select data which were not matched by entries on the  */
/*    master tape.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

skip_seg$init:
       	proc;

    dcl	1 list			aligned based (select.listp),
	  2 n			fixed bin,
	  2 x			fixed bin,
	  2 e (0 refer (list.n)),
	    3 path		char(168) varying,
	    3 type		fixed bin(17) unal,
	    3 dont_select		fixed bin(1) uns unal,
	    3 subtree		bit(1) unal,
	    3 matched		bit(1) unal,
	    3 added_as_msf		bit(1) unal,
	    3 pad1		bit(14) unal;

    dcl  (UNKNOWN			init(-1),
	LINK			init(0),
	SEG			init(1),
	DIR			init(2),
	MSF			init(3)) fixed bin int static options(constant),
	TYPE_NAME (-1:3)		char(7) varying int static options(constant) init(
				"UNKNOWN", "LINK", "SEG", "DIR",
				"MSF");

	call ssu_$get_temp_segment (sci_ptr, "select_paths", select.listp);
	list.n, list.x = 0;
	do while (read_line(addr(select)));
	   call add_to_select_list (line, UNKNOWN, FALSE, FALSE);
	   end;
	return;

add_to_select_list:
	proc (line, type, matched, added_as_msf);

    dcl	line			char(*) varying,
	type			fixed bin,
	matched			bit(1),
	added_as_msf		bit(1);

    dcl	1 en			aligned like list.e;

	list.n = list.n + 1;
	if substr (line, 1, length("^")) = "^" then do;
	   en.path = substr (line, 2);
	   en.dont_select = 1;
	   end;
	else do;
	   en.path = line;
	   en.dont_select = 0;
	   end;
	en.type = type;
	en.matched = matched;
	en.added_as_msf = added_as_msf;
	en.pad1 = ""b;
	en.subtree = FALSE;
	if length (en.path) >= length (">**") then
	if substr(en.path, length(en.path)-length(">**")+1,
				     length(">**")) = ">**" then do;
	   en.path = substr(en.path, 1,  length(en.path)-length(">**"));
	   en.subtree = TRUE;
	   end;
	list.e(list.n) = en;
	end add_to_select_list;


skip_seg$term:
       	entry;
	
    dcl	header_needed		bit(1);

	if select.vfile.path = "" then
	   return;
	header_needed = TRUE;
	do list.x = lbound(list.e,1) to hbound(list.e,1);
	   if ^list.e(list.x).matched then do;
	      if header_needed then do;
	         call ioa_ ("");
	         call error (sci_ptr, -1, "^a: Unmatched Select Entries:",
		  hhmmm());
	         header_needed = FALSE;
	         end;
	      call ioa_ ("^[^^^; ^]^a^[>**^]",
	         list.e(list.x).dont_select=1, list.e(list.x).path,
	         list.e(list.x).subtree);
	      severity = 2;
	      end;
	   end;
	return;
	
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* MATCH SEGS AGAINST -select FILE SPECS:			       */
/* There are several cases of selection, which are dealt with separately.    */
/*  1) -select was not specified				       */
/*       =>  all master segs are matched.			       */
/*  2) compare_dump_tape -select was given without a SELECT_PATH (an	       */
/*     obsolete feature implemented for compatibility sake)		       */
/*       =>  master seg whose path matches copy seg path is "selected";      */
/*	   other master segs are not matched.			       */
/*  3) copy_dump_tape -select SELECT_PATH			       */
/*     compare_dump_tape -select SELECT_PATH			       */
/*       =>  use specs in SELECT_PATH to determine match status of master    */
/*	   segs.						       */
/*							       */
/* Type 3 selection will be explained below, since it is somewhat complex.   */
/* If -trace XXX is given, then selected or rejected master seg paths are    */
/* printed.  The first set of code below sets up that tracing.	       */
/*							       */
/* The following selection results are possible:			       */
/*  SELECTED: master seg path exactly matches path in -select file.	       */
/*  SELECTED_SUBTREE: master seg path is in the subtree below one of the     */
/*    paths in the -select file, and subtree selection was specified for     */
/*    that path.						       */
/*  SUPERIOR_DIR: master seg is an entry superior in the hierarchy tree to   */
/*    one of the paths in the -select file.			       */
/*  REJECTED: master seg path exactly matches a ^path in -select file.       */
/*  REJECTED_SUBTREE: master seg path is in the subtree below one of the     */
/*    ^paths in the -select file, subtree selection was specified, and the   */
/*    master seg did not match a later path in the -select file.  NOTE:      */
/*    order of paths in -select file is important; they should be sorted by  */
/*    pathname.						       */
/*  REJECTED_SUPERIOR_DIR: master seg is an entry superior in the hierarchy  */
/*    tree to one of the ^paths in the -select file and the master seg did   */
/*    not match a later path in the -select file.			       */
/*  UNMATCHED: master seg did not fit one of the criteria above.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    dcl  (UNMATCHED			init(0),
	SUPERIOR_DIR		init(1),
	REJECTED_SUPERIOR_DIR	init(2),
	SELECTED			init(3),
	REJECTED			init(4),
	SELECTED_SUBTREE		init(5),
	REJECTED_SUBTREE		init(6)) fixed bin int static options(constant),
	STATE_NAME (0:6)		char(16) varying int static options(constant) init(
				"unmatched",
				"superior dir",
				"rejected sup dir",
				"selected",
				"rejected",
				"selected subtree",
				"rejected subtree");

skip_seg: entry (mbf, cpbf, need_copy) returns(bit(1));

    dcl	1 mbf			aligned like inbf,
	1 cpbf			aligned like inbf,
	need_copy			bit(1);

    dcl	1 seg			aligned,
	  2 path			char(168) varying,
	  2 type			fixed bin,
	  2 state			fixed bin;

    dcl	1 cphe_name		aligned like inhe_name based (cpbf.hp),
	1 mhe			aligned like h based (mbf.hp),
	1 mhe_name		aligned like inhe_name based (mbf.hp);

	if select.vfile.path ^= "" | 
	   trace = REJECTS |
	   trace = operation_now | 
	   trace = COPY_AND_COMPARE then do;
	   seg.path = rtrim(pathname_ ((mhe.dname), (mhe.ename)), " >");
	   if mhe.record_type = LINK then
	      seg.type = LINK;
	   else if mhe.record_type = sec_seg |
		 mhe.record_type = ndc_segment then
	      seg.type = SEG;
	   else if mhe.record_type = ndc_directory |
		 mhe.record_type = ndc_directory_list |
		 mhe.record_type = sec_dir then
	      seg.type = DIR;
	   if seg.type = DIR & mhe.bitcnt > 0 then
	      seg.type = MSF;
	   end;

	seg.state = UNMATCHED;			/* assume master */
						/*  seg unmatched*/

	if select.vfile.path = "" then		/* not selecting */
	   state = SELECTED;			/*  skip nothing */

	else if select.select_sw then do;		/* -select given */
						/* without path  */
	   if need_copy then			/* copy media    */
	      state = UNMATCHED;			/*  exhausted?   */
	   else 
	   if mbf.blrh.hl    = cpbf.blrh.hl &		/* see if two    */
	      mbf.blrh.segl  = cpbf.blrh.segl &		/*  segs are the */
	      mhe_name.dname = cphe_name.dname &	/*  same.	       */
	      mhe_name.ename = cphe_name.ename then
	      state = SELECTED;
	   end;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* TYPE 3 SELECTION:					       */
/* 1) Loop through each -select file pathname specification, comparing it    */
/*    with the master seg path.				       */
/* 2) Check master seg path as superior to select file path, equal to it,    */
/*    or inferior to it.  If any test is true, then apply any ^path criteria */
/*    for that select file path.				       */
/* 3) For equal paths, assign the type of the master seg (LINK, SEG, DIR,    */
/*    MSF) to the select path entry.  If the type = DIR, mark the select     */
/*    path for subtree selection, since dir select paths are really dir      */
/*    subtree select paths.					       */
/* 4) For an MSF in a selected directory which does not have subtree	       */
/*    specified (now an impossibility because of (3), but I'll leave this    */
/*    code in anyway), add the MSF dir to the selection list so its	       */
/*    components will be properly copied.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	else do;
	   do list.x = lbound(list.e,1) to hbound(list.e,1);
	      if length(seg.path) < length(list.e(list.x).path) &
	         seg.path = 
	            substr(list.e(list.x).path,1,
	                   min(length(list.e(list.x).path),
		             length(seg.path))) &
	         seg.type = DIR then
	         seg.state = SUPERIOR_DIR + list.e(list.x).dont_select;
	      else if list.e(list.x).path = seg.path then do;
	         seg.state = SELECTED + list.e(list.x).dont_select;
	         list.e(list.x).matched = TRUE;
	         if list.e(list.x).type = UNKNOWN then
		  list.e(list.x).type = seg.type;
	         else if list.e(list.x).type = MSF &
		       mhe.record_type = ndc_directory_list then;
	         else if list.e(list.x).type ^= seg.type then
		  call error$fatal (sci_ptr, -1,
		     "^a: FATAL ERROR: Type Mismatch Discrepancy.
   Path:  ^a
   Master:^23tType ^a
   Select Item(^d):^23tType ^a^[, added as an MSF^].",
		     hhmmm(), seg.path, TYPE_NAME(seg.type),
		     list.x, TYPE_NAME(list.e(list.x).type),
		     list.e(list.x).added_as_msf);
	         if list.e(list.x).type = DIR then
		  list.e(list.x).subtree = TRUE;
	         end;
	      else if list.e(list.x).path = mhe_name.dname &
		   (list.e(list.x).type = DIR |
		    list.e(list.x).type = MSF) &
		    seg.type ^= DIR then do;
	         seg.state = SELECTED + list.e(list.x).dont_select;	      
	         if list.e(list.x).type = DIR &		/* Add MSF to    */
		 ^list.e(list.x).subtree &		/* list to be    */
		  list.e(list.x).dont_select=0 &	/* sure all comps*/
		  seg.type = MSF then		/* get copied.   */
		  call add_to_select_list (seg.path, MSF, TRUE, TRUE);
	         end;


	      else if length(seg.path) > length(list.e(list.x).path) then
		 if list.e(list.x).path = 
		       substr(seg.path,1,length(list.e(list.x).path)) &
		    list.e(list.x).type = DIR &
		    list.e(list.x).subtree then
	         seg.state = SELECTED_SUBTREE + list.e(list.x).dont_select;
	      end;
	   end;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* 
/* TRACE SELECTIONS:
/* Trace the selection mechanism, listing either selected entries, rejected  */
/* entries or all entries.  The trace entry includes the selection result    */
/* (one of the STATE_NAME values).				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if trace = operation_now then do;
	   if seg.state = UNMATCHED |
	      seg.state = REJECTED |
	      seg.state = REJECTED_SUPERIOR_DIR |
	      seg.state = REJECTED_SUBTREE then;
	   else
	      call ioa_ (" ^va ^[^va^2s^;^2s^va^] ^a",
	      maxlength(STATE_NAME(1)),  STATE_NAME(seg.state),
	      seg.type = MSF,
	      maxlength(RECORD_TYPE(1)), TYPE_NAME(seg.type),
	      maxlength(RECORD_TYPE(1)), RECORD_TYPE(mhe.record_type),
	      get_shortest_path_((seg.path)));
	   end;
	else if trace = REJECTS then do;
	   if seg.state = UNMATCHED |
	      seg.state = REJECTED |
	      seg.state = REJECTED_SUPERIOR_DIR |
	      seg.state = REJECTED_SUBTREE then
	      call ioa_ (" ^va ^[^va^2s^;^2s^va^] ^a",
	         maxlength(STATE_NAME(1)),  STATE_NAME(seg.state),
	         seg.type = MSF,
	         maxlength(RECORD_TYPE(1)), TYPE_NAME(seg.type),
	         maxlength(RECORD_TYPE(1)), RECORD_TYPE(mhe.record_type),
	         get_shortest_path_((seg.path)));
	   end;
	else if trace = COPY_AND_COMPARE then do;
	   call ioa_ (" ^va ^[^va^2s^;^2s^va^] ^a",
	      maxlength(STATE_NAME(1)),  STATE_NAME(seg.state),
	      seg.type = MSF,
	      maxlength(RECORD_TYPE(1)), TYPE_NAME(seg.type),
	      maxlength(RECORD_TYPE(1)), RECORD_TYPE(mhe.record_type),
	      get_shortest_path_((seg.path)));
	   end;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* RETURN SELECTION RESULT as a TRUE/FALSE value.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if seg.state = REJECTED_SUPERIOR_DIR | seg.state = REJECTED  |
	   seg.state = REJECTED_SUBTREE      | seg.state = UNMATCHED   then
	   return (TRUE);
	else
	   return (FALSE);

	end skip_seg$init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* TAPE DRIVE MAXIMIZATION:					       */
/*   -maximize_devices (-maxdv) has two goals: to ensure that all devices    */
/* available to the process get used equally during a copy/compare	       */
/* operation; and to ensure that a tape written (copied) on one drive is     */
/* read (compared) on a different drive.  This involves several operations,  */
/* that will be described below.				       */
/*							       */
/*   The tape_drives structure is the central database for these	       */
/* operations.  It includes the number of drives reserved/assigned to the    */
/* process, a round-robin device selector, and event channel for device      */
/* operations, and for each device: device name, volume name last mounted    */
/* on the device, track and density specs, assignment rcp_id and a flag      */
/* indicating whether copy_dump_tape assigned a reserved device to the       */
/* process.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

       

    dcl	1 tape_drives		aligned,
	  2 count			fixed bin,	/* no devices    */
	  2 dvx			fixed bin,	/* cur device    */
	  2 event_wait_list		like event_wait_channel,
	  2 device (6),
	    3 name		char(32),
	    3 vol			char(32),
	    3 track		fixed bin,
	    3 density		bit(36),
	    3 rcp_id		bit(36),
	    3 assigned_by_us	bit(1) aligned;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ASSIGN RESERVED TAPE DRIVE:				       */
/*   This is called to assign a tape drive already reserved to the process.  */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


tape_drive$assign:
       	proc (dx);

    dcl	dx			fixed bin;

    dcl	code			fixed bin(35),
	1 ev_info			aligned like event_wait_info,
	statex			fixed bin,
	1 ti			aligned like tape_info;

	tape_drives.device(dx).assigned_by_us = FALSE;

	ti.version_num = tape_info_version_3;
	ti.usage_time = 0;
	ti.wait_time = 0;
	ti.system_flag = FALSE;
	ti.device_name =
	   substr(tape_drives.device(dx).name,1,length(ti.device_name));
	ti.model = 0;
	ti.tracks = 0;
	ti.density = ""b;
	ti.speed = ""b;
	ti.unused_qualifier = ""b;
	ti.volume_name = "";
	ti.write_flag = FALSE;
	ti.position_index = 0;
	ti.volume_type = 0;
	ti.volume_density = 0;
	ti.opr_auth = FALSE;

	call rcp_$assign_device (DEVICE_TYPE(TAPE_DRIVE_DTYPEX), addr(ti),
	   tape_drives.event_wait_list.channel_id(1), "",
	   tape_drives.device(dx).rcp_id, code);
	if code = error_table_$resource_unavailable |
	   code = error_table_$resource_reserved then;
	else
	   call error (sci_ptr, code,
	      "^/^a: Assigning tape drive ^a.", hhmmm(),
	      tape_drives.device(dx).name);

ASSIGN_CHECK:
	call rcp_$check_assign (tape_drives.device(dx).rcp_id,
	   addr(ti), "", statex, code);
	go to ASSIGN(statex);
	
ASSIGN(0):
	tape_drives.device(dx).assigned_by_us = TRUE;
	return;
	
ASSIGN(1):
	call ipc_$block (addr(tape_drives.event_wait_list),
	   addr(ev_info), code);
	if code ^= 0 then do;
	   call convert_ipc_code_ (code);
	   call error$fatal (sci_ptr, code,
	      "While blocking for tape_drive$assign.");
	   end;
	go to ASSIGN_CHECK;
	
ASSIGN(2):					/* long wait.    */
	return;

ASSIGN(3):					/* fatal error   */
	call error (sci_ptr, code,
	   "^/^a: Assigning tape drive ^a.", hhmmm(),
	   tape_drives.device(dx).name);
	return;

	end tape_drive$assign;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* VOLUME MOUNTED ON TAPE DRIVE:				       */
/*   This finds out which device a given tape volume was actually mounted    */
/* upon.  Prior to availability of "tape_mult_ VOL -device DEV", there was   */
/* no way to tell RCP which device to mount the tape on.  Even with the -dv  */
/* attach arg, there is no absolute assurance.  So this procedure surveys    */
/* RCP data to find out which device it was actually mounted on.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


tape_drive$find_device:
       	proc (vol);

    dcl	1 vol			aligned like in_out.vol;

    dcl	code			fixed bin(35),
         (da, dx)			fixed bin;

	vol.device = "";
	if tape_drives.count = 0 then return;
	call rcp_$copy_list (rli_ptr, WORDS_PER_SEGMENT, code);
	do da = 1 to rli.head.num_attach while (vol.device="");
	   attach_ptr = addr(rli.attaches(da));
	   if attach.dtypex = TAPE_DRIVE_DTYPEX then
	   if vol.name =   attach.volume_name then do;
	      vol.device = attach.device_name;
	      do dx = 1 to tape_drives.count 
	         while (tape_drives.device(dx).name ^= attach.device_name);
	         end;
	      if dx <= tape_drives.count then
	         tape_drives.device(dx).vol = vol.name;
	      end;
	   end;
	return;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* SELECT A TAPE DRIVE:					       */
/*   This procedure selects a drive on which to mount a given volume.  If    */
/* the volume was mounted before during copying, then		       */
/* $select_another_device is called to select a different device during      */
/* comparing.  Otherwise, $select_a_device is called to select a device on   */
/* a round-robin basis.					       */
/*							       */
/* Selection is done by:					       */
/* 1) Surveying attached devices to see which devices are already occupied   */
/*    for mounts.						       */
/* 2) Scanning the remaining devices (round-robin) to find one with	       */
/*    compatible track/density attributes.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


tape_drive$select_another_device:
	entry (io);

    dcl	1 io			aligned like input;

    dcl	densityx			fixed bin,
	selected_dx		fixed bin,
	unwanted_device		char(32);

	unwanted_device = io.vol(io.tape.volx).device;
	go to SELECT_JOIN;
	
tape_drive$select_a_device:
	entry (io);

	unwanted_device = "~";
	go to SELECT_JOIN;
	
SELECT_JOIN:
	if tape_drives.count = 0 then return;
	call rcp_$copy_list (rli_ptr, WORDS_PER_SEGMENT, code);

	tape_drives.device(*).vol = "";
	do da = 1 to rli.head.num_attach;
	   attach_ptr = addr(rli.attaches(da));
	   if attach.dtypex = TAPE_DRIVE_DTYPEX then do;
	      do dx = 1 to tape_drives.count 
	         while (tape_drives.device(dx).name ^= attach.device_name);
	         end;
	      if dx <= tape_drives.count then
	         tape_drives.device(dx).vol = attach.volume_name;
	      end;
	   end;
	
	if io.tape.density = 800 then
	   densityx = 3;
	else if io.tape.density = 1600 then
	   densityx = 4;
	else if io.tape.density = 6250 then
	   densityx = 5;
	else densityx = 4;

	tape_drives.dvx = mod(tape_drives.dvx+1, tape_drives.count);
						/* start point   */
	
	selected_dx = 0;
	do dx = tape_drives.dvx+1 to tape_drives.count
	          while (selected_dx = 0),
	        1 to tape_drives.dvx
	          while (selected_dx = 0);
	   if tape_drives.device(dx).name = unwanted_device |
	      tape_drives.device(dx).vol ^= "" |
	      tape_drives.device(dx).track ^= io.tape.track |
	      ^substr(tape_drives.device(dx).density, densityx, 1) then;
	   else selected_dx = dx;
	   end;

	if selected_dx ^= 0 then 
	   io.vol(io.tape.volx).device =
	      tape_drives.device(selected_dx).name;
	return;
	
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* SURVEY TAPE DRIVES:					       */
/*  This procedure finds out which drives are reserved or assigned to the    */
/*  process.						       */
/* 1) Those just reserved to the process get assigned to it, so	       */
/*    their track/density attributes become known (the attributes are not    */
/*    listed in the device_resvs structure).			       */
/* 2) Then all assigned devices are recorded in the tape_drives structure.   */
/* 3) Finally, the user is told which devices are available for use.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


tape_drive$survey:
	entry;

	if ^maximize_devices_sw then return;

	tape_drives.count = 0;
	tape_drives.dvx = -1;
	tape_drives.device.name = "";
	tape_drives.device.vol = "";
	tape_drives.device.track = 0;
	tape_drives.device.density = ""b;
	tape_drives.device.rcp_id = ""b;
	tape_drives.device.assigned_by_us = FALSE;

	call ipc_$create_ev_chn (tape_drives.event_wait_list.channel_id(1), code);
	call error$fatal (sci_ptr, code, "Creating an event wait channel.");
	tape_drives.event_wait_list.n_channels = 1;

	call ssu_$get_temp_segment (sci_ptr, "tape survey", rli_ptr);
	rli.head.version_num = rli_version_4;
	call rcp_$copy_list (rli_ptr, WORDS_PER_SEGMENT, code);
	call error (sci_ptr, code, "Getting tape survey data.");
	if code ^= 0 then return;

	do da = 1 to rli.head.num_device_resv;
	   device_resv_ptr = addr(rli.device_resvs(da));
	   if substr(device_resv.device_name,1,length("tap")) = "tap" then do;
	      if tape_drives.count < hbound(tape_drives.device,1) then do;
	         tape_drives.count, dx = tape_drives.count + 1;
	         tape_drives.device(dx).name = device_resv.device_name;
	         end;
	      end;
	   end;

	if tape_drives.count > 0 then do;		/* assign resv   */
	   do dx = 1 to tape_drives.count;		/*  devs to get  */
						/*  attributes   */
	      do da = 1 to rli.head.num_dassign
	        while (rli.dassigns(da).device_name ^= 
		     tape_drives.device(dx).name);
	         end;
	      if da > rli.head.num_dassign then		/* not already   */
	         call tape_drive$assign (dx);		/*  assigned?    */
	      end;				/*  I'll do it.  */
	   call rcp_$copy_list (rli_ptr, WORDS_PER_SEGMENT, code);
	   end;					/* new rcp info  */

	do da = 1 to rli.head.num_dassign;		/* fill in       */
	   dassign_ptr = addr(rli.dassigns(da));	/*  tape_drives  */
	   if dassign.dtypex = TAPE_DRIVE_DTYPEX then do; /*  for assigned */
	      do dx = 1 to tape_drives.count		/*  drives.      */
	        while (tape_drives.device(dx).name ^= dassign.device_name);
	         end;
	      if dx >  tape_drives.count &
	         dx <= hbound(tape_drives.device,1) then
	         tape_drives.count = dx;
	      if tape_drives.count >= dx then do;
	         tape_drives.device(dx).name = dassign.device_name;
	         tape_drives.device(dx).track = dassign.qualifiers(1);
	         tape_drives.device(dx).density =
		  unspec(dassign.qualifiers(2));
	         end;
	      end;
	   end;

	call ioa_("");
	if tape_drives.count > 0 then
	   call ssu_$print_message (sci_ptr, 0,
	      "^a: ^d tape drive^[s^] assigned to process:^/ ^v( ^a^)",
	      hhmmm(), tape_drives.count, tape_drives.count^=1,
	      tape_drives.count, tape_drives.device.name);
	else
	   call error (sci_ptr, -1,
	      "No tape drives are currently assigned to or reserved for
the process.  The -maximize_devices operation will not occur.");
	return;

%include rcp_list_info;

	end tape_drive$find_device;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* TAPE DRIVE INITIALIZATION:					       */
/*   Initialize the tape_drives structure.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

tape_drive$init:
	proc;

	tape_drives.count = 0;
	tape_drives.dvx = -1;
	tape_drives.event_wait_list.channel_id = -1;
	tape_drives.device(*).name, tape_drives.device(*).vol = "";
	tape_drives.device(*).track = 0;
	tape_drives.device(*).density, tape_drives.device(*).rcp_id,
	   tape_drives.device(*).assigned_by_us = ""b;

	end tape_drive$init;


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* TAPE DRIVE TERMINATION:					       */
/* 1) Unassigned reserved devices assigned by us.			       */
/* 2) Delete the event channel used for RCP operations.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


tape_drive$term:
	proc;

    dcl	code			fixed bin(35),
	dx			fixed bin;

	do dx = 1 to tape_drives.count;
	   if tape_drives.device(dx).assigned_by_us then
	      call tape_drive$unassign (dx);
	   end;

	if tape_drives.event_wait_list.channel_id(1) ^= -1 then
	   call ipc_$delete_ev_chn (tape_drives.event_wait_list.channel_id(1), code);
	end tape_drive$term;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* TAPE DRIVE UNASSIGN:					       */
/*   Unassign a tape drive assigned by copy_dump_tape.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


tape_drive$unassign:
       	proc (dx);

    dcl	dx			fixed bin;
    dcl	code			fixed bin(35);

	call rcp_$unassign (tape_drives.device(dx).rcp_id, ""b, "", code);
	call error (sci_ptr, code,
	   "^/^a: Unassigning tape drive ^a.", hhmmm(),
	   tape_drives.device(dx).name);
	tape_drives.device(dx).assigned_by_us = FALSE;

	end tape_drive$unassign;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* WRITE BACKUP LOGICAL RECORD HEADER and SEGMENT:		       */
/* 1) Decide whether output is to vfile_ or tape.			       */
/* 2) If to vfile, write out blrh sizes, the segment attributes in the       */
/*    remainder of blrh, and the segment contents.		       */
/* 3) If to tape, write out the blrh with segment attributes, and the	       */
/*    segment contents.  The blrh and contents must each be written as a     */
/*    group of 256 word blocks, so that blrh's begin on a 256-char tape      */
/*    record boundary.  After brlh/contents are written, do an error_count   */
/*    control request to synchronize output, forcing any unwritten tape      */
/*    buffers onto tape to ensure the segment actually gets written to       */
/*    tape.						       */
/* 4) When end-of-volume is found on one output tape, switch to the next     */
/*    tape and rewrite entire blrh/contents on new tape.		       */
/* 5) Both types return TRUE if the segment is successfully written, FALSE   */
/*    if it isn't.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

write_seg:	proc (bf, out) returns(bit(1));

    dcl	1 bf			aligned like inbf,
	1 he			aligned like h based (bf.hp),
	1 out			aligned like output;

    dcl	count			fixed bin(21);

    dcl   1 blrh			aligned like inbf.blrh based,
	1 blrh_sizes		aligned like inbf.blrh.sizes based,
	writel			fixed bin(21);

    dcl   size			builtin;

	if out.vfile.path ^= "" then do;		/* write file    */
	   call iox_$put_chars (out.iocbp, addr(bf.blrh.sizes),
	      size(blrh_sizes) * CHARS_PER_WORD, code);
	   if code = 0 then do;
	      call iox_$put_chars (out.iocbp, addr(he),
	         bf.blrh.hl * CHARS_PER_WORD, code);
	      if code = 0 then do;
	         if bf.blrh.segl > 0 then do;
		  call iox_$put_chars (out.iocbp, bf.segp,
		     bf.blrh.segl * CHARS_PER_WORD, code);
		  if code = 0 then do;
		     out.recx = out.recx + 1;
		     return (TRUE);
		     end;
		  end;
	         else do;
		  out.recx = out.recx + 1;
		  return (TRUE);
		  end;
	         end;
	      end;

	   if code = error_table_$end_of_info then
	      return (FALSE);
	   else
	      call error$fatal (sci_ptr, code,
	         "^/^a: FATAL ERROR: Writing ^a file ^a, record ^d.",
	         hhmmm(), out.header.name, out.vfile.expath, out.recx+1);
	   end;

	else if out.tape.voln > 0 then do;		/* write tape    */
REWRITE:	   call iox_$put_chars (out.iocbp, addr(bf.blrh),
	      size(blrh) * CHARS_PER_WORD, code);
	   if code = 0 then do;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* blrh + he, and seg are written in 256-word blocks, so we must round up    */
/* the amount we write to the next 256-word boundary.  At this point,	       */
/* blrh-words have already been written.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	      writel = bf.blrh.hl + size(blrh) + BLOCK_SIZE - 1;
	      writel = writel - mod(writel, BLOCK_SIZE) - size(blrh);
	      call iox_$put_chars (out.iocbp, addr(he),
	         writel * CHARS_PER_WORD, code);
	      if code = 0 then do;
	         if bf.blrh.segl > 0 then do;
		  writel = bf.blrh.segl + BLOCK_SIZE - 1;
		  writel = writel - mod(writel, BLOCK_SIZE);
		  call iox_$put_chars (out.iocbp, bf.segp,
		     writel * CHARS_PER_WORD, code);
		  end;
	         end;
	      end;
	   if code = 0 then do;
	      call iox_$control (out.iocbp, "error_count", addr(count),
	         code);
	      if code = 0 then do;
	         out.recx = out.recx + 1;
	         return (TRUE);
	         end;
	      end;
	   if code = error_table_$end_of_info | 
	      code = error_table_$device_end  then do;
	      if mount_next_tape_vol (out) then do;
	         call map_seg$new_tape (out);
	         go to REWRITE;
	         end;
	      else
	         return (FALSE);
	      end;
	   else
	      call error$fatal (sci_ptr, code,
	         "^/^a: FATAL ERROR: Writing ^a tape ^a, record ^d.",
	         hhmmm(), out.header.name,
	         out.vol(out.tape.volx).name, out.recx+1);
	   end;

	else do;					/* discard out   */
	   out.recx = out.recx + 1;
	   return (TRUE);
	   end;
	end write_seg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

%include backup_dir_list;
 
    dcl	pp			ptr;

%include backup_preamble_header;

%include backup_record_types;

%include event_wait_channel;

%include event_wait_info;

%include iocb;

%include iox_modes;

%include rcp_resource_types;

%include rcp_tape_info;

%include system_constants;

	end copy_dump_tape;






		    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
