


		    ta_delete_.pl1                  02/16/84  1307.2r w 02/16/84  1249.3       60309


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

ta_delete_: proc (table_ptr, arg_array, force, table_name, code);

/* This subroutine handles the delete key of tape_archive. */

/* Written 06/28/77 by C. D. Tavares.
   Modified 09/24/79 by CDT to implement star convention and fix a few minor
   bugs.
   Last modified 09/21/80 by CDT to implement table workspace strategy
   (indivisible updates).
*/

/* PARAMETERS */

dcl  arg_array (*) char (168) parameter,
     force bit (1) aligned parameter,
     table_name char (*) parameter,
     code fixed bin (35) parameter;

/* AUTOMATIC */

dcl  answer char (4) varying,
     arg char (168),
     component_slot fixed bin,
     dirname char (168),
     ename char (32),
     i fixed bin,
     locked bit (1) aligned,
     request_slot fixed bin;

/* CONDITIONS */

dcl  cleanup condition;

/* EXTERNAL STATIC */

dcl (error_table_$arg_ignored,
     error_table_$noarg) ext fixed bin (35) static;

dcl  sys_info$max_seg_size ext fixed bin (35) static;

/* INTERNAL STATIC */

dcl  system_free_ptr pointer static initial (null);

/* BASED */

dcl  system_free_area area (sys_info$max_seg_size) based (system_free_ptr);

/* ENTRIES */

dcl  check_star_name_$entry ext entry (char (*), fixed bin (35)),
     com_err_ ext entry options (variable),
     command_query_ ext entry options (variable),
     get_system_free_area_ ext entry returns (pointer);

dcl  ta_table_mgr_$find_component ext entry (pointer, char (*), char (*), bit (1) aligned, fixed bin, fixed bin, fixed bin (35)),
     ta_table_mgr_$lock ext entry (pointer, char (*), fixed bin, fixed bin (35)),
     ta_table_mgr_$star_list ext entry (pointer, char (*), fixed bin, pointer, fixed bin (35)),
     ta_table_mgr_$unlock ext entry (pointer, fixed bin (35)),
     ta_table_mgr_$setup_workspace ext entry (pointer, fixed bin, fixed bin, pointer),
     ta_table_mgr_$complete_table_op ext entry (pointer);

/* BUILTINS */

dcl (addr, dim, null, substr) builtin;

%page;
%include tape_archive_table_dcl;
%page;
%include tape_archive_star;
%page;
%include status_info_branch;
%page;
%include query_info_;
%page;

/* ta_delete_: proc... */

	locked = ""b;

	if system_free_ptr = null then
	     system_free_ptr = get_system_free_area_ ();


	if dim (arg_array, 1) = 0 then do;
	     code = error_table_$noarg;
	     call com_err_ (code, "tape_archive");
	     return;
	end;

	query_info.version = query_info_version_5;
	query_info.yes_or_no_sw = "1"b;

	do i = 1 to dim (arg_array, 1);

	     arg = arg_array (i);

/* Following line handles control args */

	     if substr (arg, 1, 1) = "-" then
		call com_err_ (error_table_$arg_ignored, "tape_archive", arg);

/* Following line handles args which should be component_names */

	     else call process_filearg (arg);
	end;

	code = 0;
return_hard:
	return;
%skip(5);
process_filearg: proc (component_name);

dcl  component_name char (*) parameter;

	     ename = component_name;

	     call check_star_name_$entry (ename, code);
	     if code = 0 then
		call delete_one (dirname, ename);

	     else if (code = 1) | (code = 2) then begin;	/* arbitrary starname or "**" */
						/* the begin keeps the current procedure fast by limiting
						   the scope of the following cleanup handler. */

dcl  i fixed bin;

		if code = 2 then do;		/* user specified "**" or equivalent */
		     call command_query_ (addr (query_info), answer, "tape_archive",
			"Do you really want to delete all components in ^a??", table_name);
		     if answer = "no" then return;
		end;

		ta_component_star_ptr = null;

		on cleanup begin;
		     if ta_component_star_ptr ^= null then
			free ta_component_star_info in (system_free_area);
		end;

		call ta_table_mgr_$star_list (table_ptr, ename, Component, ta_component_star_ptr, code);
		if code ^= 0 then goto not_processed;

		do i = 1 to ta_component_star_info.n_entries;
		     call delete_one (dirname, ta_component_star_info (i).ename);
		end;

		free ta_component_star_info in (system_free_area);
	     end;

	     else
not_processed: call com_err_ (code, "tape_archive", """^a"" not processed.", component_name);

	     return;
%skip(5);
delete_one:    proc (dirname, ename);

dcl (dirname, ename) char (*) parameter;

		on cleanup call ta_table_mgr_$unlock (table_ptr, code);

		locked = "1"b;
		call ta_table_mgr_$lock (table_ptr, table_name, Modify, code);
		if code ^= 0 then do;
		     call com_err_ (code, "tape_archive",
			"Arguments from ""^a"" could not be processed.", arg);
		     goto return_hard;
		end;

		call ta_table_mgr_$find_component (table_ptr, table_name, ename, "1"b, /* should be there */
		     component_slot, request_slot, code);
		if code ^= 0 then goto unlock_and_return; /* msg already printed */

		component_ptr = addr (component_table (component_slot));

		if component.safety_switch then
		     if ^force then do;
			call command_query_ (addr (query_info), answer, "tape_archive",
			     "Component ^a is protected.  Do you wish to delete it??  ", ename);
			if answer = "no" then goto unlock_and_return;
		     end;

		call ta_table_mgr_$setup_workspace (table_ptr, component_slot, request_slot, workspace_ptr);

		component_ptr = addr (workspace_ptr -> workspace.component_copy);
		component.date_time_deleted = (36)"1"b; /* make it nonzero, use it as "to be deleted" flag */

		workspace_ptr -> workspace.dead_records = workspace_ptr -> workspace.dead_records + component.file_length;
		workspace_ptr -> workspace.n_queued_requests = workspace_ptr -> workspace.n_queued_requests + 1;

		if workspace_ptr -> workspace.next_mount_type < Delete then
		     workspace_ptr -> workspace.next_mount_type = Delete;

		call ta_table_mgr_$complete_table_op (table_ptr);

unlock_and_return:
		call ta_table_mgr_$unlock (table_ptr, code);
		return;

	     end delete_one;
	end process_filearg;
     end ta_delete_;
   



		    ta_extract_.pl1                 02/16/84  1307.2r w 02/16/84  1249.3       72648


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

ta_extract_: proc (table_ptr, arg_array, delete, force, table_name, code);

/* This subroutine handles the extract key of tape_archive.

   Written 05/10/77 by C. D. Tavares.
   Modified 09/24/79 by CDT to implement star convention.
   Modified 09/21/80 by CDT to implement table workspace strategy
   (indivisible updates).
   Last modified 83-03-24 by S. G. Harris (UNCA) for version 4.
*/

/* PARAMETERS */

dcl  arg_array (*) char (168) parameter,
     delete bit (1) aligned parameter,
     force bit (1) aligned parameter,
     table_name char (*) parameter,
     code fixed bin (35) parameter;

/* AUTOMATIC */

dcl  answer char (4) varying,
     arg char (168),
     component_slot fixed bin,
     dirname char (168),
     ename char (32),
     i fixed bin,
     request_slot fixed bin,
     single_name_sw bit (1) aligned,
     specific_component bit (1) aligned;

/* CONDITIONS */

dcl  cleanup condition;

/* INTERNAL STATIC */

dcl  system_free_ptr pointer static initial (null);

/* EXTERNAL STATIC */

dcl  error_table_$badopt ext fixed bin (35) static;

dcl  sys_info$max_seg_size ext fixed bin (35) static;

/* ENTRIES */

dcl  check_star_name_$entry ext entry (char (*), fixed bin (35)),
     command_query_ ext entry options (variable),
     com_err_ ext entry options (variable),
     expand_pathname_ ext entry (char (*), char (*), char (*), fixed bin (35)),
     get_system_free_area_ ext entry returns (pointer),
     hcs_$status_minf ext entry (char (*), char (*), fixed bin, fixed bin, fixed bin (24), fixed bin (35));

dcl  ta_table_mgr_$find_component ext entry (pointer, char (*), char (*), bit (1) aligned, fixed bin, fixed bin, fixed bin (35)),
     ta_table_mgr_$lock ext entry (pointer, char (*), fixed bin, fixed bin (35)),
     ta_table_mgr_$unlock ext entry (pointer, fixed bin (35)),
     ta_table_mgr_$star_list ext entry (pointer, char (*), fixed bin, pointer, fixed bin (35)),
     ta_table_mgr_$setup_workspace ext entry (pointer, fixed bin, fixed bin, pointer),
     ta_table_mgr_$complete_table_op ext entry (pointer);

/* BASED */

dcl  system_free_area area (sys_info$max_seg_size) based (system_free_ptr);

/* BUILTINS */

dcl (addr, dim, null, substr, unspec) builtin;

/* INCLUDE FILES */
%include query_info;
%page;
%include status_info_branch;
%page;
%include tape_archive_table_dcl;
%page;
%include tape_archive_star;
%page;

/* ta_extract_: proc... */

	if system_free_ptr = null then
	     system_free_ptr = get_system_free_area_ ();

	single_name_sw = ""b;
	specific_component = ""b;
	query_info.version = query_info_version_5;
	query_info.yes_or_no_sw = "1"b;

/* Following block handles control args */

	do i = 1 to dim (arg_array, 1);

	     arg = arg_array (i);

	     if substr (arg, 1, 1) = "-" then do;
		if (arg = "-single_name" | arg = "-snm") then single_name_sw = "1"b;

		else do;
		     code = error_table_$badopt;
		     call com_err_ (code, "tape_archive", "Arguments from ""^a"" were not processed.",
			arg);
		     return;
		end;
	     end;

	     else specific_component = "1"b;
	end;

/* Following block handles args which should be storage system pathnames */

	if specific_component then
	     do i = 1 to dim (arg_array, 1);

	     arg = arg_array (i);

	     if substr (arg, 1, 1) ^= "-" then call process_filearg (arg);
	end;

	else					/* user wants everything extracted */
	do i = 1 to tape_archive_table.n_component_slots;
	     if component_table (i).valid then
		call process_filearg (component_table (i).entry_name);
	end;

	code = 0;
returner:	return;

%skip(5);
process_filearg: proc (component_name);

dcl  component_name char (*) parameter;

	     call expand_pathname_ (component_name, dirname, ename, code);
	     if code ^= 0 then do;
not_processed:	call com_err_ (code, "tape_archive", """^a"" not processed.", component_name);
		return;
	     end;

	     call check_star_name_$entry (ename, code);
	     if code = 0 then do;
		call extract_one (dirname, ename);
		return;
	     end;

	     else if (code = 1) | (code = 2) then begin;	/* arbitrary starname or "**" */
						/* the begin keeps the current procedure fast by limiting
						   the scope of the following cleanup handler. */

dcl  i fixed bin;

		ta_component_star_ptr = null;

		on cleanup begin;
		     if ta_component_star_ptr ^= null then
			free ta_component_star_info in (system_free_area);
		end;

		call ta_table_mgr_$star_list (table_ptr, ename, Component, ta_component_star_ptr, code);
		if code ^= 0 then goto not_processed;

		do i = 1 to ta_component_star_info.n_entries;
		     call extract_one (dirname, ta_component_star_info (i).ename);
		end;

		free ta_component_star_info in (system_free_area);
	     end;

	     else goto not_processed;
	     return;
%skip(5);
extract_one:   proc (dirname, ename);

dcl (dirname, ename) char (*) parameter;

		if ^force then do;
		     call hcs_$status_minf (dirname, ename, 1 /* chase */, 0, 0, code);
		     if code = 0 then call com_err_ (0, "tape_archive", "Warning - ^a>^a already exists.", dirname, ename);
		end;

		on cleanup call ta_table_mgr_$unlock (table_ptr, code);

		call ta_table_mgr_$lock (table_ptr, table_name, Modify, code);
		if code ^= 0 then do;
		     call com_err_ (code, "tape_archive",
			"Arguments from ""^a"" could not be processed.", component_name);
		     goto returner;
		end;

		call ta_table_mgr_$find_component (table_ptr, table_name, ename, "1"b /* should be there */, component_slot, request_slot, code);
		if code ^= 0 then do;
		     call ta_table_mgr_$unlock (table_ptr, code);

		     return;
		end;

		component_ptr = addr (component_table (component_slot));

		call ta_table_mgr_$setup_workspace (table_ptr, component_slot, request_slot, workspace_ptr);

		if request_slot > workspace_ptr -> workspace.n_request_slots then
		     workspace_ptr -> workspace.n_request_slots = request_slot;

		request_ptr = addr (workspace_ptr -> workspace.request_copy);
		unspec (request) = ""b;		/* clear out any old garbage */

		request.extract = "1"b;
		if delete then do;
		     request.delete = "1"b;
		     if ^force then 		/* check safety switch */
			if component.safety_switch then do;
			     call command_query_ (addr (query_info), answer, "tape_archive",
				"Component ^a is protected. Do you wish to delete it??  ", ename);
			     if answer = "no" then request.delete = "0"b;
			end;
		end;
		request.force = force;	
		request.directory_name = dirname;
		request.entry_name = ename;
		request.single_name = single_name_sw;
		request.existing_reference = component_slot;
		request.valid = "1"b;

		workspace_ptr -> workspace.component_copy.associated_request_index = request_slot;
		if request.delete then
		     workspace_ptr -> workspace.dead_records = workspace_ptr -> workspace.dead_records + component.file_length;
		workspace_ptr -> workspace.n_queued_requests = workspace_ptr -> workspace.n_queued_requests + 1;
		if workspace_ptr -> workspace.next_mount_type < Read then
		     workspace_ptr -> workspace.next_mount_type = Read;

		call ta_table_mgr_$complete_table_op (table_ptr);

		call ta_table_mgr_$unlock (table_ptr, code);
	     end extract_one;
	end process_filearg;
     end ta_extract_;



		    ta_file_io_.pl1                 12/01/87  0800.5rew 11/30/87  1322.6      196785


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


/****^  HISTORY COMMENTS:
  1) change(87-08-17,GWMay), approve(87-09-09,MECR0006),
     audit(87-09-04,Farley), install(87-09-09,MR12.1-1101):
     Changed to init the msf_fcp_ptr so that non-creation of an output file is
     diagnosed.  Changed to always set the name of the output directory for
     extractions.
  2) change(87-10-19,GWMay), approve(87-10-19,MCR7779), audit(87-11-02,Farley),
     install(87-11-30,MR12.2-1006):
     Formally install MECR0006.
                                                   END HISTORY COMMENTS */


ta_file_io_: proc; return;

/* This module does tape and file I/O for tape_archive.
   Written 06/06/77 by C. D. Tavares
   Modified 04/11/79 by CDT to handle unexpired file abort better and to
   clean up garbage error message printed when processing table of contents.
   Modified 10/24/80 by CDT to add tape_ibm_ capability.
   Modified 12/05/80 by CDT to diagnose error_table_$short_record from
   vfile_ as no_final_newline, not an error.
   Last modified 83-03-25 by S. G. Harris for version 4.
   Modified 6/83 by S. Krupp for conversion to mtape_.
   Modified November 1984 by Greg Texada to make file names conform to both
    IBM and ANSI standards.
   Modified 12/84 by Keith Loepere to remove create_branch_info.
   Modified 85-2-19 by C Spitzer. not to complain if cannot find a file on the tape when compacting.
*/


/* AUTOMATIC */

	dcl     attribute_file_name	 char (17) aligned,
	        binary_mode		 bit (1) aligned,
	        bit_count		 fixed bin (24),
	        cancel_deletion	 bit (1) aligned,
	        char_count		 fixed bin (21),
	        compacting		 bit (1) aligned,
	        dirname		 char (168),
	        ename		 char (32),
	        extracting		 bit (1) aligned,
	        i			 fixed bin,
	        input_opd		 char (520),
	        j			 fixed bin,
	        max_chars_in_seg	 fixed bin (21),
	        msf_fcb_ptr		 pointer,
	        n_chars_read	 fixed bin (21),
	        n_words_read	 fixed bin (18),
	        output_atd		 char (520),
	        output_opd		 char (520),
	        readin_ptr		 pointer,
	        seg_ptr		 pointer,
	        temp_file_no	 fixed bin;

/* ENTRIES */

	dcl     com_err_		 ext entry options (variable),
	        hcs_$set_bc_seg	 ext entry (pointer, fixed bin (24), fixed bin (35)),
	        hcs_$truncate_seg	 ext entry (pointer, fixed bin (18), fixed bin (35)),
	        (ioa_, ioa_$rsnnl)	 ext entry options (variable),
	        msf_manager_$close	 ext entry (pointer),
	        msf_manager_$get_ptr	 ext entry (pointer, fixed bin, bit (1) aligned, pointer, fixed bin (24), fixed bin (35)),
	        msf_manager_$open	 ext entry (char (*), char (*), pointer, fixed bin (35));

	dcl     ta_filesys_util_$create_attribute_file ext entry (pointer, fixed bin, pointer, bit (1) aligned, fixed bin (35)),
	        ta_filesys_util_$prepare_extraction ext entry (pointer, fixed bin, fixed bin (35)),
	        ta_filesys_util_$replace_attributes ext entry (pointer, fixed bin, pointer, fixed bin (35));

/* CONSTANTS */

	dcl     Legal_name_chars_ansi	 char (128) static options (constant) initial
				 ("//////////////////////////////////""//%&'()*+,-./0123456789:;<=>?/ABCDEFGHIJKLMNOPQRSTUVWXYZ////_/ABCDEFGHIJKLMNOPQRSTUVWXYZ/////"),
	        Legal_name_chars_ibm	 char (128) static options (constant) initial
				 ("@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@""#$@@@@@@@@@@@0123456789@@@@@@@ABCDEFGHIJKLMNOPQRSTUVWXYZ@@@@@@ABCDEFGHIJKLMNOPQRSTUVWXYZ@@@@@"),
	        Upper_case		 char (26) static options (constant) initial
				 ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
	        Newline		 char (1) static options (constant) initial ("
");

/* EXTERNAL STATIC */

	dcl     (error_table_$end_of_info,
	        error_table_$no_file,
	        error_table_$short_record) ext fixed bin (35) static;

	dcl     sys_info$max_seg_size	 fixed bin (35) external static;

/* BASED */

	dcl     1 tape_archive_io_info aligned based (tii_ptr),
%include tape_archive_io_info;

	dcl     based_segment	 (n_words_read) bit (36) aligned based (seg_ptr),
	        buffer		 char (max_chars_in_seg) based (buffer_ptr);

/* INCLUDE FILES */

%include tape_archive_table_dcl;
%page;
%include tape_archive_attributes;
%page;
%include iox_modes;
%page;
%include iox_dcls;
%page;

/* BUILTINS */

	dcl     (addr, binary, bit, clock, collate, divide, index, length, max,
	        maxlength, mod, null, substr, translate, unspec) builtin;

/* CONDITION */

	dcl     cleanup		 condition;

extract: entry (table_ptr, component_no, tii_ptr, code);

/* PARAMETERS */

	dcl     component_no	 fixed bin parameter,
	        tii_ptr		 pointer parameter,
	        code		 fixed bin (35) parameter;

	compacting = (tape_archive_table.next_mount_type = Compact);
	extracting = "1"b;
	goto extract_compact_common;


compact: entry (table_ptr, component_no, tii_ptr, code);

	compacting = "1"b;
	extracting = "0"b;

extract_compact_common:
	component_ptr = addr (component_table (component_no));

	if extracting then do;			/* Don't copy it if it's going to be deleted */
		request_ptr = addr (request_queue (component.associated_request_index));
		if request.delete then compacting = "0"b;
	     end;
	else
	     request_ptr = null;			/* Compact entry does not have any requests */

	cancel_deletion = "0"b;
	max_chars_in_seg = sys_info$max_seg_size * 4;
	temp_file_no = tape_archive_table.last_tape_file_no;
	msf_fcb_ptr = null;

	dirname = "";
	ename = component.entry_name;

/* first, open the attribute file for this component */

	attribute_file_name = make_filename ("ATTRIBUTEFILE", component.attribute_file_no);
	call ioa_$rsnnl (input_opd_template, input_opd, 0,
	     "binary", attribute_file_name, component.attribute_file_no);

	if tape_archive_io_info.long_sw then
	     call ioa_ ("Searching for ^a for^[ extraction^[-deletion^]^;^s^]^[ and^;^]^[ compaction^;^].",
		component.entry_name, extracting, request.delete, (extracting & compacting), compacting);

	on cleanup begin;
		if msf_fcb_ptr ^= null
		then call msf_manager_$close (msf_fcb_ptr);
		call cleanerup ();
	     end;

	call iox_$open_file (tape_input_switch, Sequential_input, input_opd, ""b, code);
	if code ^= 0
	then if code = error_table_$no_file
	     then do;
		     call cleanerup;
		     goto returner;
		end;
	     else call abort;

	if compacting then do;			/* create a new attribute file on the new tape */
		temp_file_no = temp_file_no + 1;
		attribute_file_name = make_filename ("ATTRIBUTEFILE", temp_file_no);
		call open_tape_output_file (attribute_file_name, temp_file_no, "binary");
	     end;

	call iox_$read_record (tape_input_switch, attribute_seg_ptr, max_chars_in_seg, n_chars_read, code);
						/* The whole attributes file is one large record */
	if code = error_table_$short_record then code = 0;
	if code ^= 0 then call abort;

	call close_switch (tape_input_switch);

	if compacting then do;			/* copy the attribute file onto new tape */

		call iox_$write_record (tape_output_switch, attribute_seg_ptr, n_chars_read, code);
		if code ^= 0 then call abort;

		call close_switch (tape_output_switch);
	     end;

/* Keep the attribute file aside for a moment and read in the segment */

	call ioa_$rsnnl (input_opd_template, input_opd, 0,
	     component.recording_mode, component.tape_file_name,
	     component.attribute_file_no + 1);

	call iox_$open_file (tape_input_switch, Sequential_input, input_opd, ""b, code);
	if code ^= 0 then call abort;

	if compacting then do;			/* create a new file on new tape to copy this into also */
		temp_file_no = temp_file_no + 1;
		component.tape_file_name = make_filename (substr (component.tape_file_name, 1, 13), temp_file_no);
		call open_tape_output_file (component.tape_file_name, temp_file_no, component.recording_mode);
	     end;

	if extracting then do;			/* we may be just compacting;
						   otherwise, check for namedups, noaccess, etc. */
		dirname = request.directory_name;
		call ta_filesys_util_$prepare_extraction (table_ptr, component.associated_request_index, code);
		if code ^= 0 then call cant_extract;
	     end;

/* Now  we must figure out where and how to read in the file.  If we are truly
   extracting,  we  should read the file right into place;  otherwise, we will
   read  it  into a buffer just long enough to write it back out.  Also, if it
   is  binary, we want to treat records a bit differently than if it is one of
   the character mode.  */

/* Note  that  at  any  time an error is noticed on extraction, the extracting
   switch  will  be  turned  off  so  that  extraction  will  cease,  although
   compaction may continue to take place.  */

	if extracting then
	     if component.recording_mode = "binary" then do; /* records represent segments and not lines */
		     binary_mode = "1"b;
		     msf_fcb_ptr = null;
		     call msf_manager_$open (dirname, ename, msf_fcb_ptr, code);
		     if msf_fcb_ptr = null then call cant_extract;
		end;

	     else do;				/* ascii or ebcdic mode */
						/* open the target file right in place */
		     binary_mode = ""b;
		     call ioa_$rsnnl ("vfile_ ^a>^a ", output_atd, 0, dirname, ename);

		     call iox_$attach_ptr (file_output_switch, output_atd, null, code);
		     if code ^= 0 then call cant_extract;

		     call iox_$open (file_output_switch, Stream_output, ""b, code);
		     if code ^= 0 then call cant_extract;
		end;

/* Now read in the file itself.  If this is a binary file, we will read records and make segments out of each one.
   If it is a character file, we will treat individual records as lines. */

	if /* still */ extracting then
	     if tape_archive_io_info.long_sw then
		call ioa_ ("Reading ^a.", component.entry_name);

	do j = 1 by 1 to component.n_tape_records while (extracting | compacting);

	     if (extracting & binary_mode) then do;
		     call msf_manager_$get_ptr (msf_fcb_ptr, j - 1, "1"b /* create */, seg_ptr, 0, code);
						/* create an SSF or an MSF component to put the data into */
		     if seg_ptr = null then do;
			     call cant_extract;
			     readin_ptr = buffer_ptr;
			end;
		     else readin_ptr = seg_ptr;
		end;

	     else readin_ptr = buffer_ptr;

/* Read one record from the tape */

	     if (extracting | compacting) then do;
		     call iox_$read_record (tape_input_switch, readin_ptr, max_chars_in_seg, n_chars_read, code);
		     if code = error_table_$short_record then code = 0;
		     if code ^= 0 then call abort;
		end;

	     if compacting then do;
		     call iox_$write_record (tape_output_switch, readin_ptr, n_chars_read, code);
		     if code ^= 0 then call abort;
		end;

	     if extracting then do;
		     if binary_mode then do;
			     n_words_read = divide (n_chars_read + 3, 4, 18, 0);
			     call hcs_$truncate_seg (seg_ptr, n_words_read, 0);

			     i = mod (n_chars_read, 4);
			     if i > 0 then substr (based_segment (n_words_read), i * 9 + 1) = ""b;

			     call hcs_$set_bc_seg (seg_ptr, ta_attributes.component_bc (j - 1), code);
			end;

		     else do;			/* add a final newline and pump out the line */
			     n_chars_read = n_chars_read + 1;
			     substr (buffer, n_chars_read, 1) = Newline;

/* Special hack: If the file had no final newline, don't add one */

			     if j = component.n_tape_records then
				if component.no_final_newline then n_chars_read = n_chars_read - 1;

			     call iox_$put_chars (file_output_switch, buffer_ptr, n_chars_read, code);
			     if code ^= 0 then call abort;
			end;
		end;
	end;

/* Everything's off the tape (and/or on the new tape);  clean up */

	if (extracting & binary_mode)
	then call msf_manager_$close (msf_fcb_ptr);

	call cleanerup ();

/* Now apply the attributes (ACL, names, etc.) to our newly extracted file. */

	if extracting then do;
		call ta_filesys_util_$replace_attributes (table_ptr, component.associated_request_index, attribute_seg_ptr, code);
		if code ^= 0 then call abort;
	     end;

	if compacting then component.attribute_file_no = temp_file_no - 1; /* remember to reset the attribute file no. */
	tape_archive_table.last_tape_file_no = temp_file_no;

	if cancel_deletion then code = 1; else code = 0;	/* tell caller if deletion cancelled */
	return;
%skip (5);
cant_extract: proc;

/* This  internal procedure will print out whatever error caused extraction to
   fail,  reset  the  extraction  flag,  and the RETURN so that compaction, if
   being done, may continue to completion.  

   Special handling is required if the component is to be deleted. If the
   request is for an extraction only, then the deletion request can simply be
   cancelled. If a compaction is also taking place, however, then it has
   already been suppressed.  Now that the extraction has failed, an attempt
   must be made to go back and recover this component for the compacted volume
   set.

   Since the request.delete flag is used by ta_table_mgr_ for dead record
   management, it cannot be used to cancel the deletion. The caller must be
   notified through a code indicating this special case. */

	extracting = "0"b;
	call com_err_ (code, "tape_archive", "^a>^a^/^5xExtraction^[-deletion^] request will be ignored.",
	     dirname, ename, request.delete);
	if request.delete then
	     if output_opd_template ^= "" then do;	/* if compacting, try to recover component */
		     cancel_deletion = "1"b;
		     compacting = "1"b;
		     call cleanerup ();
		     if msf_fcb_ptr ^= null
		     then call msf_manager_$close (msf_fcb_ptr);
		     goto extract_compact_common;
		end;
	     else cancel_deletion = "1"b;		/* just extracting -- cancel deletion */
     end cant_extract;

append: entry (table_ptr, request_no, tii_ptr, code);

/* PARAMETER */

	dcl     request_no		 fixed bin parameter;

/* ENTRY */


	request_ptr = addr (request_queue (request_no));
	max_chars_in_seg = sys_info$max_seg_size * 4;
	temp_file_no = tape_archive_table.last_tape_file_no;
	msf_fcb_ptr = null;

	dirname = request.directory_name;
	ename = request.entry_name;

/* Create  an attribute file for this file, which will contain the ACL, names,
   etc.   for  replacement  purposes  when the time comes to recreate the file
   online */

	if request.recording_mode = "" then
	     request.recording_mode = "binary";

	binary_mode = (request.recording_mode = "binary");

	call ta_filesys_util_$create_attribute_file (table_ptr, request_no,
	     attribute_seg_ptr, binary_mode, code);
	if code ^= 0 then return;

/* Choose  the  proper  recording  mode  for this file, based on what the user
   requested and what the data really is */

	if binary_mode then /* seg is not legal ASCII */
	     if request.recording_mode ^= "binary" then do;
		     call com_err_ (0, "tape_archive",
			"^a cannot be recorded in ^a mode;  using binary mode.",
			ename, request.recording_mode);
		     request.recording_mode = "binary";
		end;

/* End of fun and games, now comes the serious work of getting it out there */

	request.date_time_archived = substr (bit (clock ()), 20, 36); /* standard file system time */
	request.no_final_newline = ""b;

	on cleanup begin;
		if msf_fcb_ptr ^= null
		then call msf_manager_$close (msf_fcb_ptr);
		call cleanerup ();
	     end;

/* Put the attribute file out to tape first */

	if tape_archive_io_info.long_sw then
	     call ioa_ ("Appending ^a.", request.entry_name);

	temp_file_no = temp_file_no + 1;
	request.attribute_file_no = temp_file_no;
	attribute_file_name = make_filename ("ATTRIBUTEFILE", temp_file_no);
	call open_tape_output_file (attribute_file_name, temp_file_no, "binary");

/* Write out the attribute file as one huge record */

	call iox_$write_record (tape_output_switch, attribute_seg_ptr, ta_attributes.own_length_in_chars, code);
	if code ^= 0 then call abort;

	call close_switch (tape_output_switch);

/* Now, down to the business of recording the file itself */

	temp_file_no = temp_file_no + 1;
	request.tape_file_name =
	     make_filename (substr (ename, 1, 12), temp_file_no);
	call open_tape_output_file (request.tape_file_name, temp_file_no, request.recording_mode);

	if request.recording_mode = "binary" then do;
		call msf_manager_$open (dirname, ename, msf_fcb_ptr, code);
						/* Nice that msf_manager_ works on SSF's too! */
		if code ^= 0 then call abort;

		do i = 1 to max (ta_attributes.n_components, 1);
		     call msf_manager_$get_ptr (msf_fcb_ptr, i - 1, ""b /* don't create */, seg_ptr, bit_count, code);
		     if code ^= 0 then call abort;

		     char_count = divide (bit_count, 9, 21, 0);

		     call iox_$write_record (tape_output_switch, seg_ptr, char_count, code);
		     if code ^= 0 then call abort;
		end;

		request.n_tape_records = i - 1;
	     end;

	else do;

		call ioa_$rsnnl ("vfile_ ^a>^a", output_atd, 0, dirname, ename);

		call iox_$attach_ptr (file_input_switch, output_atd, null, code);
		if code ^= 0 then call abort;

		call iox_$open (file_input_switch, Stream_input, ""b, code);
		if code ^= 0 then call abort;

		do i = 1 by 1 while (code ^= error_table_$end_of_info);

		     call iox_$get_line (file_input_switch, buffer_ptr, max_chars_in_seg, n_chars_read, code);

		     if code = 0 then /* strip newline */
			n_chars_read = n_chars_read - 1;
		     else if code = error_table_$short_record then do;
			     if substr (buffer, n_chars_read, 1) = Newline then
				call abort;	/* shouldn't! */
			     request.no_final_newline = "1"b;
			     code = 0;
			end;
		     else if code = error_table_$end_of_info then
			request.n_tape_records = i - 1;
		     else call abort;

		     if code = 0 then do;
			     call iox_$write_record (tape_output_switch, buffer_ptr, n_chars_read, code);
			     if code ^= 0 then call abort;
			end;
		end;

	     end;

	call cleanerup ();
	if msf_fcb_ptr ^= null
	then call msf_manager_$close (msf_fcb_ptr);

	tape_archive_table.last_tape_file_no = temp_file_no;
	code = 0;
	return;

append_table: entry (table_ptr, tii_ptr, code);

/* This entry writes the tape archive table out to tape. */

/* AUTOMATIC */

	dcl     tablefile_name	 char (17) aligned;

	tape_archive_table.last_table_no = tape_archive_table.last_table_no + 1;
	tablefile_name = make_filename ("ONLINE-TABLE-", tape_archive_table.last_table_no);

	tape_archive_table.last_tape_file_no = tape_archive_table.last_tape_file_no + 1;
						/* bump for file taken up by the table */
	dirname = "";				/* for error messages */
	ename = "tape copy of online table";
	call open_tape_output_file (tablefile_name, tape_archive_table.last_tape_file_no, "binary");

	char_count = divide (length (unspec (tape_archive_table)), 9, 21, 0);

	call iox_$write_record (tape_output_switch, table_ptr, char_count, code);

	call close_switch (tape_output_switch);

	return;
%page;
open_tape_output_file: proc (file_name, file_no, mode);

	dcl     file_name		 char (17) aligned parameter,
	        file_no		 fixed bin parameter,
	        mode		 char (8) aligned parameter;

	call ioa_$rsnnl (output_opd_template, output_opd, 0,
	     mode, file_name, file_no);

	call iox_$open_file (tape_output_switch, Sequential_output, output_opd, ""b, code);
	if code ^= 0 then call abort;

	return;

     end open_tape_output_file;
%skip (5);
make_filename: entry (table_ptr, arg_filename_part, arg_file_no) returns (char (17) aligned);

	dcl     arg_filename_part	 char (13) parameter,
	        arg_file_no		 fixed bin parameter;

	return (make_filename (arg_filename_part, arg_file_no));
%skip (3);
make_filename: proc (filename_part, file_no) returns (char (17) aligned);

	dcl     filename_part	 char (13) parameter,
	        file_no		 fixed bin parameter;

	dcl     complete_filename	 char (17) aligned,
	        file_no_picture	 pic "9999";

	file_no_picture = file_no;

	if tape_archive_table.io_module_name = "tape_ansi_" then
	     complete_filename = translate (filename_part, Legal_name_chars_ansi, collate ()) || file_no_picture;

	else do;
		if filename_part = "ONLINE-TABLE-" then
		     complete_filename = "ONLINE#TABLE#" || file_no_picture;
		else complete_filename = translate (filename_part, Legal_name_chars_ibm, collate ()) || file_no_picture;
		if index (Upper_case || "@#$", substr (complete_filename, 1, 1)) > 0
						/* ensure first character meets requirements of IBM*/
		then complete_filename = "X" || substr (complete_filename, 1, maxlength (complete_filename) - 1);
		substr (complete_filename, 9, 1) = ".";
		if index (Upper_case, substr (complete_filename, 10, 1)) = 0 then
		     substr (complete_filename, 10, 1) = "X";
	     end;

	return (complete_filename);

     end make_filename;
%skip (5);
close_switch: proc (switch_ptr);

	dcl     switch_ptr		 pointer parameter;
	dcl     code		 fixed bin (35);

	call iox_$close (switch_ptr, code);

     end close_switch;
%skip (5);
cleanerup: proc;

	dcl     temp_ptr		 pointer;

	do temp_ptr = file_input_switch, file_output_switch;

	     call iox_$close (temp_ptr, 0);
	     call iox_$detach_iocb (temp_ptr, 0);
	end;

	do temp_ptr = tape_input_switch, tape_output_switch;
	     call iox_$close (temp_ptr, 0);
	end;

     end cleanerup;
%skip (5);
abort: proc options (non_quick);

	call com_err_ (code, "tape_archive", "Unexpected error while processing ^[^s^;^a>^]^a", (dirname = ""), dirname, ename);
	call cleanerup ();
	goto returner;
     end abort;

returner: return;

     end ta_file_io_;
   



		    ta_filesys_util_.pl1            06/17/86  1505.2r w 06/17/86  1444.3      181188


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

ta_filesys_util_: proc; return;

/* This module performs branch manipulation for tape_archive.  It examines
   files and records all their interesting attributes for storage on tape.
   It also replaces as many of these as possible when a file is
   extracted from tape.
   Written 06/07/77 by C. D. Tavares.
   Modified 09/24/79 by CDT to implement star convention entry.
   Modified 09/03/80 by CDT for version 3.
   Last modified 83-03-16 by S. G. Harris (UNCA) for version 4.
   Modified 7/83 by S. Krupp for conversion to mtape_.
*/

/* BASED */

dcl 1 based_acl_list (ta_attributes.acl_count) aligned based (acl_list_ptr) like ta_attributes.acl_list;

dcl  name_array (binary (branch.nnames)) char (32) aligned based;
dcl  system_free_area area (sys_info$max_seg_size) based (system_free_ptr);
dcl  based_segment char (char_count) based (seg_ptr) aligned;

/* AUTOMATIC */

dcl  dirname char (168),
     ename char (32);

dcl 1 auto_branch like status_branch aligned automatic;

dcl 1 info like indx_info automatic;

dcl 1 auto_sfb aligned automatic like status_for_backup;

dcl  acl_list_ptr pointer,
     char_count fixed bin (21),
     check_for_binary bit (1),
     i fixed bin,
     n_components fixed bin,
     msf_fcb_ptr pointer,
     seg_ptr pointer,
     temp_area area (3000),
     temp_bit bit (1) aligned;

/* ENTRIES */

dcl  get_system_free_area_ ext entry returns (pointer),
     hcs_$get_bc_author ext entry (char (*), char (*), char (*) aligned, fixed bin (35)),
     hcs_$get_max_length ext entry (char (*), char (*), fixed bin (19), fixed bin (35)),
     hcs_$get_safety_sw ext entry (char (*), char (*), bit (1) aligned, fixed bin (35)),
     hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin, fixed bin, pointer, fixed bin (35)),
     hcs_$list_acl ext entry (char (*), char (*), pointer, pointer, pointer, fixed bin, fixed bin (35)),
     hcs_$star_dir_list_ ext entry (char (*), char (*), fixed bin (3), pointer, fixed bin, fixed bin, pointer, pointer, fixed bin (35)),
     hcs_$status_for_backup ext entry (char (*), char (*), pointer, fixed bin (35)),
     hcs_$status_long ext entry (char (*), char (*), fixed bin, pointer, pointer, fixed bin (35)),
     hcs_$terminate_noname ext entry (pointer, fixed bin (35)),
     msf_manager_$acl_list ext entry (pointer, pointer, pointer, pointer, fixed bin, fixed bin (35)),
     msf_manager_$get_ptr ext entry (pointer, fixed bin, bit (1) aligned, pointer, fixed bin (24), fixed bin (35)),
     msf_manager_$close ext entry (pointer),
     msf_manager_$open ext entry (char (*), char (*), pointer, fixed bin (35)),
     nd_handler_ ext entry (char (*), char (*), char (*), fixed bin (35)),
     nd_handler_$force ext entry (char (*), char (*), char (*), fixed bin (35)),
     vfile_status_ ext entry (char (*), char (*), pointer, fixed bin (35));

/* INTERNAL STATIC */

dcl  system_free_ptr pointer static initial (null);

/* EXTERNAL STATIC */

dcl (error_table_$action_not_performed,
     error_table_$dirseg,
     error_table_$namedup,
     error_table_$noentry,
     error_table_$segnamedup) fixed bin (35) external static;

dcl  sys_info$max_seg_size fixed bin (35) external static;

/* BUILTINS AND CONDITIONS */

dcl (addr, binary, collate, divide, empty, length, max, null, pointer, rtrim, sum, unspec, verify) builtin;

dcl  cleanup condition;
%include tape_archive_table_dcl;
%page;
%include tape_archive_attributes;
%page;
%include tape_archive_star;
%page;
%include star_structures;
%page;
%include status_for_backup;
%page;
%include vfs_info;
%page;
star_list: entry (a_dirname, a_starname, ta_filesys_star_ptr, code);

dcl  a_starname char (*) parameter;

	if system_free_ptr = null then
	     system_free_ptr = get_system_free_area_ ();

	ta_filesys_star_ptr,
	     star_list_branch_ptr,
	     star_list_names_ptr = null;

	on cleanup begin;
	     if star_list_names_ptr ^= null then
		free star_list_names in (system_free_area);
	     if star_list_branch_ptr ^= null then
		free star_dir_list_branch in (system_free_area);
	     if ta_filesys_star_ptr ^= null then
		free ta_filesys_star_info in (system_free_area);
	end;

	star_select_sw = star_BRANCHES_ONLY;

	call hcs_$star_dir_list_ (a_dirname, a_starname, star_select_sw, system_free_ptr, star_branch_count, star_link_count,
	     star_list_branch_ptr, star_list_names_ptr, code);
	if code ^= 0 then return;

	ta_star_match_count = 0;

	do i = 1 to star_branch_count;
	     if star_dir_list_branch (i).type = star_DIRECTORY then
		if star_dir_list_branch (i).bit_count > 0 then /* it's an MSF */
		     star_dir_list_branch (i).type = star_SEGMENT; /* so lie. */

	     if star_dir_list_branch (i).type = star_SEGMENT then
		ta_star_match_count = ta_star_match_count + 1;
	end;

	allocate ta_filesys_star_info in (system_free_area);

	ta_star_match_count = 0;

	do i = 1 to star_branch_count;
	     if star_dir_list_branch (i).type = star_SEGMENT then do;
		ta_star_match_count = ta_star_match_count + 1;
		ta_filesys_star_info.ename (ta_star_match_count) = star_list_names (star_dir_list_branch (i).nindex);
	     end;
	end;

	free star_list_names in (system_free_area);
	free star_dir_list_branch in (system_free_area);
	return;
%page;
get_file_info: entry (a_dirname, a_ename, branch_type, file_length, safety_sw, binary_file, dtbm, code);

/* This entry returns a short status of a segment or MSF in the file system, including whether or not its
   contents contain any non-ASCII characters. */

dcl (a_dirname char (*),
     a_ename char (*),
     branch_type fixed bin,
     file_length fixed bin (35),
     safety_sw bit (1) aligned,
     binary_file bit (1) aligned,
     dtbm bit (36),
     code fixed bin (35)) parameter;

	call hcs_$status_long (a_dirname, a_ename, 1 /* chase */, addr (auto_branch), null, code);
	if code ^= 0 then return;

	call hcs_$get_safety_sw (a_dirname, a_ename, safety_sw, code);
	if code ^= 0 then return;

	branch_type = binary (auto_branch.type);
	dtbm = auto_branch.dtem;

	if auto_branch.type = Segment then do;
	     file_length = (binary (auto_branch.bit_count) + 36863) / 36864e0; /* 1024 * 36 */
						/* we return file length in pages */
	     if ^binary_file then binary_file = check_binary_file (a_dirname, a_ename, binary (auto_branch.bit_count));
	end;

	else do;					/* MSF, this is a toughy */

	     n_components = binary (auto_branch.bit_count);
	     if n_components = 0 then do;		/* real dir, not an MSF */
		code = error_table_$dirseg;
		return;
	     end;

	     begin;

dcl  component_file_lengths (0:n_components-1) fixed bin (24);

		call get_component_lengths (a_dirname, a_ename, n_components, component_file_lengths, binary_file);
		component_file_lengths = (component_file_lengths + 36863) / 36864e0;
		file_length = sum (component_file_lengths) + binary (auto_branch.records_used);
	     end;
	end;

returner:
	return;
%skip(5);
check_binary_file: proc (a_dirname, a_ename, bitcount) returns (bit (1) aligned);

dcl (a_dirname char (*),
     a_ename char (*),
     bitcount fixed bin (24)) parameter;

dcl  binary_file bit (1) aligned;

	     call hcs_$initiate (a_dirname, a_ename, "", 0, 0, seg_ptr, code);
	     if seg_ptr = null then goto returner;

	     char_count = divide (bitcount, 9, 21, 0);
	     binary_file = ""b;

	     if verify (based_segment, collate ()) > 0 then binary_file = "1"b;

	     call hcs_$terminate_noname (seg_ptr, code);
	     return (binary_file);
	end check_binary_file;
%page;
create_attribute_file: entry (table_ptr, request_no, attribute_seg_ptr, binary_file, code);

/* This entry fills in the contents of the attribute file which will be put onto tape preceding each component.
   The attribute file contains all the attributes of a segment in the file system (like ACL, names,
   and other things) which have to be restored whenever the file is reloaded into the file system.
   Also, since it has the information handy, it fills in components of the request structure with
   the same information where necessary. */

dcl  request_no fixed bin parameter,
     attribute_seg_ptr pointer parameter;

	ta_attributes.version_no = tape_archive_version_4;
	status_ptr = addr (ta_attributes.branch);
	temp_area = empty ();
	request_ptr = addr (request_queue (request_no));

	dirname = request.directory_name;
	ename = request.entry_name;

	call hcs_$status_long (dirname, ename,
	     1 /* chase */, addr (ta_attributes.branch), addr (temp_area), code);
	if code ^= 0 then return;

	request.entry_status_descriptor.uid = ta_attributes.branch.uid;  /* used for checking against table deletion */

	if request.single_name then do;		/* user requested that only one name be recorded */
	     ta_attributes.branch.nnames = 1b;
	     ta_attributes.names (1) = ename;
	end;
	else unspec (ta_attributes.names) = unspec (pointer (addr (temp_area), branch.names_relp) -> name_array);

	call hcs_$get_safety_sw (dirname, ename, ta_attributes.safety_switch, code);
	if code ^= 0 then return;

	request.safety_switch = ta_attributes.safety_switch;

	call hcs_$get_bc_author (dirname, ename, request.bitcount_author, code);
	if code ^= 0 then return;

	temp_area = empty ();

	check_for_binary = (^binary_file) & (binary (ta_attributes.dtem) > binary (request.date_time_branch_modified));
						/* only check for ascii-ness if it was ascii before and someone changed it since */

	if ta_attributes.branch.type = Segment then do;

	     call hcs_$get_max_length (dirname, ename, ta_attributes.max_length, code);
	     if code ^= 0 then return;

	     ta_attributes.n_components = 0;

	     auto_sfb.version = status_for_backup_version_2;

	     call hcs_$status_for_backup (dirname, ename, addr (auto_sfb), code);
	     if code ^= 0 then return;

	     ta_attributes.entrypt_is_bounded = auto_sfb.entrypt;
	     ta_attributes.entrypt_bound = auto_sfb.entrypt_bound;

	     call hcs_$list_acl (dirname, ename,
		addr (temp_area), acl_list_ptr, null, ta_attributes.acl_count, code);
	     if code ^= 0 then return;

	     unspec (ta_attributes.acl_list) = unspec (based_acl_list);

	     if ^binary_file then binary_file = check_binary_file (dirname, ename, binary (ta_attributes.bit_count));
	end;

	else do;					/* MSF (we hope) */
	     if ta_attributes.bit_count = 0 then do;
		code = error_table_$dirseg;
		return;
	     end;

	     ta_attributes.n_components = binary (ta_attributes.bit_count);

	     call msf_manager_$open (dirname, ename, msf_fcb_ptr, code);
	     if code ^= 0 then return;

	     call msf_manager_$acl_list (msf_fcb_ptr, addr (temp_area), acl_list_ptr, null, acl_count, code);
	     if code ^= 0 then return;

	     unspec (ta_attributes.acl_list) = unspec (based_acl_list);

	     call msf_manager_$close (msf_fcb_ptr);

	     temp_bit = ^check_for_binary;		/* temp bit of 0 means to check for binary */

bugblock:	     begin;				/* PL/I bug won't generate calling seq right for the array */
dcl  temp_ptr pointer,				/* unless we fake it out this way */
     based_array (0:ta_attributes.n_components - 1) fixed bin (24) based (temp_ptr);

		temp_ptr = addr (ta_attributes.component_bc); /* This forces correct address computation */

		call get_component_lengths (dirname, ename, ta_attributes.n_components, based_array (*), temp_bit);
	     end bugblock;

	     if check_for_binary then binary_file = temp_bit;
	end;

	request.date_time_branch_modified = ta_attributes.dtem;
	request.date_time_dumped = ta_attributes.dtd;

	ta_attributes.own_length_in_chars = length (unspec (ta_attributes)) / 9e0;

	return;
%page;
prepare_extraction: entry (table_ptr, request_no, code);

/* This entry simply checks to see if something we are extracting already exists or not, and figures out
   how to handle things in case it does. */

	request_ptr = addr (request_queue (request_no));

	dirname = request.directory_name;
	ename = request.entry_name;

	call hcs_$status_long (dirname, ename, 1 /* chase */, addr (auto_branch), null (), code);

	if code = 0 then do;			/* file already exists */
	     if auto_branch.uid = table_ptr -> tape_archive_table.perm_table_uid then do;
		call ioa_ ("tape_archive: Extraction into active table ^a has been suppressed.", ename);
		code = error_table_$action_not_performed;
	     end;
	     else do;
		if request.force then call nd_handler_$force ("tape_archive", dirname, ename, code);
		else call nd_handler_ ("tape_archive", dirname, ename, code);
		if code = 1 then code = error_table_$action_not_performed;
	     end;
	     return;
	end;

	if code = error_table_$noentry then code = 0;	/* file not found, this is what we want */

	return;
%page;
replace_attributes: entry (table_ptr, request_no, attribute_seg_ptr, code);

/* This entry takes the attribute file read in from the tape and places every attribute which is replaceable
   back onto the segment branch.  Things like dates and unique ID's are ignored (of course) */

/* ENTRIEs */

dcl  com_err_ ext entry options (variable),
     ioa_ ext entry options (variable),
     cu_$level_get ext entry (fixed bin);

dcl  hcs_$chname_file ext entry (char (*), char (*), char (*), char (*), fixed bin (35)),
     hcs_$replace_acl ext entry (char (*), char (*), pointer, fixed bin, bit (1) aligned, fixed bin (35)),
     hcs_$set_bc ext entry (char (*), char (*), fixed bin (24), fixed bin (35)),
     hcs_$set_copysw ext entry (char (*), char (*), fixed bin (1), fixed bin (35)),
     hcs_$set_entry_bound ext entry (char (*), char (*), fixed bin (18), fixed bin (35)),
     hcs_$set_max_length ext entry (char (*), char (*), fixed bin (19), fixed bin (35)),
     hcs_$set_ring_brackets ext entry (char (*), char (*), fixed bin dimension (3), fixed bin (35)),
     hcs_$set_safety_sw ext entry (char (*), char (*), bit (1) aligned, fixed bin (35)),
     msf_manager_$acl_replace ext entry (pointer, pointer, fixed bin, bit (1) aligned, fixed bin (35));

/* STATIC */

dcl  validation_level fixed bin static initial (-1);

dcl  rb (3) fixed bin;

	request_ptr = addr (request_queue (request_no));

	dirname = request.directory_name;
	ename = request.entry_name;
	code = 0;

	if ta_attributes.version_no ^= tape_archive_version_4 then; /* doesn't matter, this structure */
						/* has been identical from version 1 of tape_archive */
						/* the versions differed only in the online table format */

	if ta_attributes.safety_switch then
	     call hcs_$set_safety_sw (dirname, ename, "1"b, code);
	if code ^= 0 then call explain (code, "set safety switch of");

	if ta_attributes.copy_switch then
	     call hcs_$set_copysw (dirname, ename, 1, code);
	if code ^= 0 then call explain (code, "set copy switch of");

	if ta_attributes.type = Segment then do;

	     if ta_attributes.entrypt_is_bounded then
		call hcs_$set_entry_bound (dirname, ename, binary (ta_attributes.entrypt_bound), code);
	     if code ^= 0 then call explain (code, "set entrypoint bound of");

	     call hcs_$set_bc (dirname, ename, binary (ta_attributes.bit_count), code);
						/* set the bitcount even though vfile_ has ostensibly set it */
	     if code ^= 0 then call explain (code, "set bit count of");

	     call hcs_$set_max_length (dirname, ename, ta_attributes.max_length, code);
	     if code ^= 0 then call explain (code, "set max length of");

	     call hcs_$replace_acl (dirname, ename, addr (ta_attributes.acl_list), ta_attributes.acl_count, "1"b, code);
						/* don't add SysDaemons if they weren't on before. */
	     if code ^= 0 then call explain (code, "replace ACL of");

	     do i = 0 to 2;
		rb (i+1) = binary (ta_attributes.ring_brackets (i));
	     end;

	     if validation_level = -1 then call cu_$level_get (validation_level);

	     if rb (1) < validation_level then do;
		rb = max (rb, validation_level);
		call ioa_ ("tape_archive: Warning - raising ring brackets of ^a to ^d,^d,^d.", ename, rb);
	     end;

	     call hcs_$set_ring_brackets (dirname, ename, rb, code);
	     if code ^= 0 then call explain (code, "set ring brackets of");
	end;

	else do;					/* file is an MSF */

	     call msf_manager_$open (dirname, ename, msf_fcb_ptr, code);
	     if code ^= 0 then call explain (code, "open MSF");

	     call msf_manager_$acl_replace (msf_fcb_ptr, addr (ta_attributes.acl_list), ta_attributes.acl_count, "1"b, code);
	     if code ^= 0 then call explain (code, "replace ACL of MSF");

	     call msf_manager_$close (msf_fcb_ptr);
	end;

	if ^request.single_name then
	     do i = 1 to binary (ta_attributes.nnames);

	     call hcs_$chname_file (dirname, ename, "", ta_attributes.names (i), code);
	     if code = error_table_$segnamedup then code = 0;
	     else if code = error_table_$namedup then do;
		call hcs_$status_long (dirname, ta_attributes.names (i), 1 /* chase */, addr (auto_branch), null (), code);
		if code = 0 then do;
		     if auto_branch.uid = table_ptr -> tape_archive_table.perm_table_uid then
			call ioa_ ("tape_archive: Potential conflict with active table, name ^a not added to ^a>^a.", ta_attributes.names (i), dirname, ename);
		     else do;
			if request.force then call nd_handler_$force ("tape_archive", dirname, ta_attributes.names (i), code);
			else call nd_handler_ ("tape_archive", dirname, ta_attributes.names (i), code);
			if code = 0 then i = i - 1;		/* name removal succeeded, try again */
			else code = error_table_$namedup;
		     end;
		end;
	     end;
	     if code ^= 0 then call explain (code, "add name " || rtrim (ta_attributes.names (i)) || " to");
	end;

	code = 0;
	return;
%page;
get_component_lengths: proc (a_dirname, a_ename, n_components, bc_array, binary_file);

/* This internal subroutine returns an array of lengths (in pages) for all the components of an MSF.
   Additionally, it checks each component (if necessary) to ensure that it contains only ASCII chars. */

dcl (a_dirname char (*),
     a_ename char (*),
     n_components fixed bin,
     bc_array (*) fixed bin (24),
     binary_file bit (1) aligned) parameter;

/* AUTOMATIC */

dcl  i fixed bin,
     bit_count fixed bin (24);

	     unspec (bc_array) = ""b;

	     if ^binary_file then do;			/* make sure the file is a stream file */
		uns_info.info_version = vfs_version_1;

		call vfile_status_ (a_dirname, a_ename, addr (uns_info), code);
		if code ^= 0 then return;

		if info.type > 1 then binary_file = "1"b; /* structured file, don't even try to stream it */
	     end;

	     call msf_manager_$open (a_dirname, a_ename, msf_fcb_ptr, code);
	     if code ^= 0 then return;

	     do i = 0 to n_components - 1;

		call msf_manager_$get_ptr (msf_fcb_ptr, i, ""b /* do not create */, seg_ptr, bit_count, code);
		if seg_ptr = null then do;
		     call msf_manager_$close (msf_fcb_ptr);
		     return;
		end;

		char_count = divide (bit_count, 9, 21, 0);

		bc_array (i) = bit_count;

		if ^binary_file then		/* check for legal ASCII */
		     if verify (based_segment, collate ()) > 0 then /* AHA, a binary byte */
			binary_file = "1"b;
	     end;

	     call msf_manager_$close (msf_fcb_ptr);
	     return;
	end get_component_lengths;
%skip(5);
explain:	proc (code, explanation);

dcl  code fixed bin (35) parameter,
     explanation char (*) parameter;

	     call com_err_ (code, "tape_archive", "Cannot ^a ^a>^a.", explanation, dirname, ename);
	     code = 0;
	end explain;

     end ta_filesys_util_;



		    ta_list_table_.pl1              02/16/84  1307.2r w 02/16/84  1249.4      144045


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

ta_list_table_: proc (table_ptr, arg_array, table_entry, code);

/* This subroutine prints a listing of the contents of a tape archive using
   the information in the table, including pending requests which have not yet
   been processed.

   Written 05/09/77 by C. D. Tavares.
   Modified 04/11/79 by CDT to add control args and clean up interaction
   between control args.
   Modified 09/24/79 by CDT to implement star convention and
   fix up interactions between deleted components and -pending.
   Modified 09/03/80 by CDT to add density field in header.
   Modified 12/9/81 by CDT for highest_mount_type stuff
   Last modified 83-03-16 by S. G. Harris (UNCA) for version 4.
   Modified 6/83 by S. Krupp for conversion to mtape_ (to print vol_type
      rather than io_module in header).
*/

dcl  table_entry char (*) parameter,
     arg_array (*) char (168) parameter,
     code fixed bin (35) parameter;

/* AUTOMATIC */

dcl  brief bit (1) aligned,
     component_control fixed bin,
    (dta_string, dtem_string, dtd_string) char (16),
     dtlc_string char (32),
     dttm_string char (32),
     extra_line char (176),
     header_printed fixed bin,
     header_wanted fixed bin,
    (i, j) fixed bin,
     key_chars char (4) varying,
     long bit (1) aligned,
     match bit (1) aligned,
     mode_char char (1),
     nargs fixed bin,
     n_comp_names fixed bin,
     print_extra_line bit (1) aligned,
     vol_type char(32),
     volset fixed bin;

dcl 1 comp_name_struc (dim (arg_array, 1)) automatic,	/* adjustable */
    2 comp_name char (32),
    2 comp_name_used bit (1) aligned,
    2 comp_name_is_starname bit (1) aligned;


/* STATIC */

dcl  my_lock_id bit (36) aligned static initial ((36)"1"b);


/* CONSTANTS */

dcl (Never_wanted initial (0),			/* header_wanted */
     Whenever_wanted initial (1),
     Always_wanted initial (2),

     No_components initial (0),			/* component_control */
     Pending_components initial (1),
     Usual_components initial (2),
     All_components initial (3),

     No_header initial (0),
     Partial_header initial (1),
     Full_header initial (2)) fixed bin static options (constant);


/* EXTERNAL STATIC */

dcl (error_table_$badopt,
     error_table_$inconsistent) ext fixed bin (35) static;

/* BUILTINS */

dcl (addr, dim, max, null, string, substr) builtin;

/* ENTRIES */

dcl  check_star_name_$entry ext entry (char (*), fixed bin (35)),
     com_err_ ext entry options (variable),
     com_err_$suppress_name ext entry options (variable),
     com_err_var entry variable options (variable),
     date_time_$fstime ext entry (bit (36) aligned, char (*)),
     get_lock_id_ ext entry returns (bit (36) aligned),
     ioa_ ext entry options (variable),
     match_star_name_ ext entry (char (*), char (*), fixed bin (35));

/* INCLUDE FILES */

%include tape_archive_table_dcl;

	if my_lock_id = (36)"1"b then
	     my_lock_id = get_lock_id_ ();

	nargs = dim (arg_array, 1);

	brief, long = ""b;
	n_comp_names = 0;
	component_control = Usual_components;
	header_wanted = Whenever_wanted;
	header_printed = No_header;

	do i = 1 to nargs;
	     if substr (arg_array (i), 1, 1) = "-" then do;
		comp_name_used (i) = "1"b;
		if (arg_array (i) = "-bf") | (arg_array (i) = "-brief") then
		     brief = "1"b;
		else if (arg_array (i) = "-lg") | (arg_array (i) = "-long") then
		     long = "1"b;
		else if (arg_array (i) = "-nhe") | (arg_array (i) = "-no_header") then
		     if header_wanted = Whenever_wanted then
			header_wanted = Never_wanted;
		     else call crump (error_table_$inconsistent, "-header and -no_header");
		else if (arg_array (i) = "-he") | (arg_array (i) = "-header") then
		     if header_wanted = Whenever_wanted then
			header_wanted = Always_wanted;
		     else call crump (error_table_$inconsistent, "-header and -no_header");
		else if (arg_array (i) = "-all") | (arg_array (i) = "-a") then
		     if component_control = Usual_components then
			component_control = All_components;
		     else call crump (error_table_$inconsistent, "-all and -pending");
		else if arg_array (i) = "-pending" then
		     if component_control = Usual_components then
			component_control = Pending_components;
		     else call crump (error_table_$inconsistent, "-all and -pending");
		else call crump (error_table_$badopt, arg_array (i));
	     end;

	     else do;
		call check_star_name_$entry (arg_array (i), code);
		if code > 2 then
		     call crump (code, arg_array (i));
		n_comp_names = n_comp_names + 1;
(nostrz):		comp_name (n_comp_names) = arg_array (i);
		comp_name_used (n_comp_names) = ""b;
		comp_name_is_starname (n_comp_names) = (code > 0);
	     end;
	end;


	if brief & long then
	     call crump (error_table_$inconsistent, "-brief and -long");

	if header_wanted = Always_wanted then
	     if n_comp_names = 0 then
		if component_control = Usual_components then
		     component_control = No_components;


/* Begin examining the table.  We take a small chance of printing garbage by
   doing this operation without locking the table, but the table-of-contents
   operation should be available without write permission to the table
   segment, so we make this concession to convenience.  */


	if header_wanted = Always_wanted then
	     call print_header (Partial_header);

	if component_control = All_components then j = tape_archive_table.n_component_slots;
	else j = tape_archive_table.n_components;
	if j + tape_archive_table.n_queued_requests = 0 then do;
	     if long then call print_header (Partial_header);
	     if header_printed = No_header then
		call ioa_ ("^a is empty.", table_entry);
	     return;
	end;

	if tape_archive_table.n_queued_requests = 0 then
	     if component_control = Pending_components then do;
		if header_printed = No_header then
		     call ioa_ ("No pending requests in ^a.", table_entry);
		return;
	     end;


	do i = 1 to tape_archive_table.n_component_slots;

               component_ptr = addr (tape_archive_table.component_table (i));

	     if component_table (i).entry_status_descriptor.valid | (component_control = All_components) then do;

		match = (component_control > No_components) & (n_comp_names = 0);

		do j = 1 to n_comp_names;
		     if match & comp_name_used (j) then; /* don't bother making ext call */
		     else if comp_name_is_starname (j) then do;
			call match_star_name_ (component_table (i).entry_name, comp_name (j), code);
			if code = 0 then
			     match, comp_name_used (j) = "1"b;
		     end;
		     else if component_table (i).entry_name = comp_name (j) then
			match, comp_name_used (j) = "1"b;
		end;

		if component_control = Pending_components then
		     if component.associated_request_index = 0 then /* no pending replacement or extraction for this one */
			if component.date_time_deleted ^= (36)"1"b then /* and also not in the process of deletion */
			     match = ""b;		/* only wants pending requests */

		if component_control ^= All_components then
		     if component.date_time_deleted then
			if component.date_time_deleted ^= (36)"1"b then /* really deleted, not just pending */
			     match = ""b;		/* doesn't want deleted components */

		if match then do;
		     call print_header (Full_header);
		     print_extra_line = ""b;

		     if component.associated_request_index > 0 then do;
			if component.valid then do;
			     request_ptr =
				addr (request_queue
				(component.associated_request_index));
			     if string (request.requested_ops) then do;
				print_extra_line = "1"b;
				if request.extract then
				     extra_line = "into " ||
				     request.directory_name;
				else extra_line = "from " ||
				     request.directory_name;
			     end;
			end;

			if ^component.valid then
			     mode_char = substr
			     (component.recording_mode, 1, 1);
						/* no mode associated with deaders */
			else if request.extract then
			     mode_char = substr (component.recording_mode, 1, 1);
						/* no mode associated with extractions */
			else mode_char = substr (request.recording_mode, 1, 1);
		     end;

		     else do;
			request_ptr = null;
			mode_char = substr (component.recording_mode, 1, 1);
		     end;

		     if ^component.valid then do;
			key_chars = "---";
			print_extra_line = "1"b;
			if component.date_time_deleted then do;
			     call date_time_$fstime (component.date_time_deleted, dtd_string);
			     extra_line = "deleted " || dtd_string;
			end;
			else extra_line = "subsequently replaced";
		     end;

		     else if component.associated_request_index = 0 then
			if component.date_time_deleted = (36)"1"b then key_chars = "d";
			else key_chars = "";
		     else if request.extract then
			if request.delete then
			     if request.force then key_chars = "xdf";
			     else key_chars = "xd";
			else if request.force then key_chars = "xf";
			else key_chars = "x";
		     else if request.replace then
			if request.delete then
			     if request.force then key_chars = "rdf";
			     else key_chars = "rd";
			else key_chars = "r";
		     else if request.delete then key_chars = "d";
		     else key_chars = "";

		     if long then do;

			call date_time_$fstime (component.date_time_archived, dta_string);
			call date_time_$fstime (component.date_time_branch_modified, dtem_string);
			if component.date_time_dumped = ""b then dtd_string = "";
			else call date_time_$fstime (component.date_time_dumped, dtd_string);

			call ioa_ ("^5a^34a^17a (^1a) ^3d^3x^a^/^-^5x^16a^2(^6x^16a^)^[^/^-^5x(^1a)^;^]",
			     key_chars, component.entry_name,
			     component.tape_file_name, mode_char, component.file_length,
			     component.bitcount_author, dta_string, dtem_string, dtd_string,
			     print_extra_line, extra_line);
		     end;

		     else call ioa_ ("^5a^[^34a(^a)^;^a^]", key_chars,
			print_extra_line, component.entry_name, extra_line);
		end;
	     end;
	end;

	do i = 1 to tape_archive_table.n_request_slots;

	     if request_queue (i).entry_status_descriptor.valid then /* invalid requests are never interesting */
		if request_queue (i).existing_reference = 0 then do; /* if nonzero, we got this above */

		     match = (component_control > No_components) & (n_comp_names = 0);

		     do j = 1 to n_comp_names;
			if match & comp_name_used (j) then; /* don't bother making ext call */
			else if comp_name_is_starname (j) then do;
			     call match_star_name_ (request_queue (i).entry_name, comp_name (j), code);
			     if code = 0 then
				match, comp_name_used (j) = "1"b;
			end;
			else if request_queue (i).entry_name = comp_name (j) then
			     match, comp_name_used (j) = "1"b;
		     end;

		     if match then do;
			call print_header (Full_header);

			request_ptr = addr (tape_archive_table.request_queue (i));

			if request.delete then	/* by now there are only appends left */
			     if request.force then key_chars = "adf";
			     else key_chars = "ad";
			else key_chars = "a";

			call ioa_ ("^5a^34a(from ^a)", key_chars,
			     request.entry_name, request.directory_name);
		     end;
		end;
	end;

	if (header_printed ^= No_header) then com_err_var = com_err_$suppress_name;
	else com_err_var = com_err_;

	do j = 1 to n_comp_names;
	     if ^comp_name_used (j) then do;
		if header_printed = Partial_header then call print_header (Full_header);
		call com_err_var (0, "tape_archive", "^[^5x^;^]^a not found in ^a",
		     (header_printed ^= No_header), arg_array (j), table_entry);
	     end;
	end;

	return;

print_header: proc (part_to_print);

dcl  part_to_print fixed bin parameter;

dcl  i fixed bin;

	     if header_wanted = Never_wanted then goto fini;
	     goto skip_already_printed_part (header_printed);


skip_already_printed_part (0):			/* nothing yet printed */
	     if ^brief | (header_wanted = Always_wanted) then
		call ioa_ ("^/^[No^s^;^d^] component^[^;s^] in ^a^[^2s^;;  ^d pending request^[^;s^]^].
^[No requests^;Only deletions^;Extractions^;Replacements/additions^;Compaction^] pending.^[
^[Both volume sets are^;Primary volume set is^] currently mounted.^;^]",
		(tape_archive_table.n_components = 0),
		tape_archive_table.n_components,
		(tape_archive_table.n_components = 1),
		table_entry,
		(tape_archive_table.n_queued_requests = 0),
		tape_archive_table.n_queued_requests,
		(tape_archive_table.n_queued_requests = 1),
		tape_archive_table.next_mount_type + 1,
		(tape_archive_table.mount_lock = my_lock_id),
		(tape_archive_table.highest_mount_type = Compact));

	     if long then do;
		call ioa_ ("^/Auto compaction limit    = ^.2f^/Compaction warning limit = ^.2f
Waste factor: ^d/^d pages = ^.2f",
		     tape_archive_table.auto_compaction_threshold, tape_archive_table.compaction_warning_threshold,
		     tape_archive_table.dead_records, tape_archive_table.total_records,
		     tape_archive_table.dead_records / max (1, tape_archive_table.total_records));

/* 		call ioa_ ("^/I/O Module:  ^a", tape_archive_table.io_module_name); */

		if tape_archive_table.io_module_name = "tape_ansi_"
		then vol_type = "ansi";
		else vol_type = "ibm";

		if tape_archive_table.date_time_tape_modified = ""b then dttm_string = "Volume set never mounted.";
		else call date_time_$fstime (tape_archive_table.date_time_tape_modified, dttm_string);
		if tape_archive_table.date_time_last_compacted = ""b then dtlc_string = "Volume set never compacted.";
		else call date_time_$fstime (tape_archive_table.date_time_last_compacted, dtlc_string);

		call ioa_ ("^/Date-time tape modified:   ^a^/Date-time tape compacted:  ^a",
		     dttm_string, dtlc_string);

		call ioa_ ("^/Tapes Labeled:^17x^a^/Current volume set density:  ^2x^d bpi^/Alternate volume set density:  ^d bpi",
		     vol_type,
		     tape_archive_table.tape_info.density (tape_archive_table.active_set),
		     tape_archive_table.tape_info.density (3 - tape_archive_table.active_set));

		do i = 1 to 2;
		     if i = 1 then volset = tape_archive_table.active_set;
		     else volset = 3 - tape_archive_table.active_set;

		     call ioa_ ("^/^[Current^;Alternate^] volume set contains ^[no^s^;^d^] tape^[s^;^]^[:^;.^]",
			i, (tape_archive_table.n_volumes_in_set (volset) = 0),
			tape_archive_table.n_volumes_in_set (volset),
			(tape_archive_table.n_volumes_in_set (volset) ^= 1),
			(tape_archive_table.n_volumes_in_set (volset) ^= 0));

		     call ioa_ ("^4x^v( ^a^)", tape_archive_table.n_volumes_in_set (volset),
			tape_archive_table.volume_set (volset).volume_id (*));
		end;

	     end;


skip_already_printed_part (1):			/* most of header already printed */
	     if part_to_print <= 1 then goto fini;

	     if long then
		call ioa_ ("^/REQ  COMPONENT^25xFILENAME (MODE)^7xLEN   BC AUTHOR
^-^5xDATE ARCHIVED^9xDATE MODIFIED^9xDATE DUMPED^/");
	     else if ^brief then call ioa_ ("^/REQ  COMPONENT^/");

skip_already_printed_part (2):			/* already all been done */
fini:
	     header_printed = max (header_printed, part_to_print);

	     return;
	end print_header;
%skip(5);
crump:	proc (code, reason);

dcl (code fixed bin (35),
     reason char (*)) parameter;

	     call com_err_ (code, "tape_archive", reason);
	     goto returner;
	end crump;

returner:
	return;

     end ta_list_table_;
   



		    ta_load_table_.pl1              03/26/85  0950.2rew 03/25/85  1508.3      132354


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

/* format: style1,^inddcls,ifthenstmt,ifthendo,ifthen,indcomtxt,dclind5 */
ta_load_table_: proc (table_ptr, arg_array, table_name, code);

/* This procedure implements the load_table key of tape_archive. */

/* Written 06/29/77 by C. D. Tavares.
   Modified 09/24/79 to work if the final table on tape has a tape error smack
   in the middle of it.
   Modified 09/03/80 by CDT to fix ref thru null ptr and to warn user if volid
   supplied by user doesn't match volid in loaded table (source of problems
   when volumes shipped to other sites and given other volids).
   Modified 10/24/80 by CDT to add tape_ibm_ capability.
   Modified 12/9/81 by CDT for highest_mount_type stuff.
   Modified 12/17/81 by CDT to make it upgrade the table to the current
   version before checking the table for consistency.
   BIM 3/82 -density control argument.
   Last modified 83-03-16 by S. G. Harris (UNCA) for version 4.
   Modified 7/83 by S. Krupp for conversion to mtape_.
   Modified 01/09/84 by J. A. Bush to enable the referencing dir search rule
   for finding I/O module
   Modified 85-2-14 by C Spitzer. Correct algorithm for finding the last good
   table on the tape. Use volume ids from command line rather than from table.
   Take out -retain implying -ring.
*/

dcl  (arg_array	        (*) char (168),
     table_name	        char (*),
     code		        fixed bin (35)) parameter;

/* AUTOMATIC */

dcl  answer	        char (256) varying,
     attach_description     char (256),
     date_time_string       char (24),
     density	        fixed bin,
     dname	        char (168),
     ename	        char (32),
     got_older_table        bit (1),
     i		        fixed bin,
     iom_ctl_arg	        bit (1) aligned,
     max_chars_in_seg       fixed bin (21),
     n_chars_read	        fixed bin (21),
     n_table_volids	        fixed bin,
     n_volids	        fixed bin,
     n_words_read	        fixed bin (18),
     open_description       char (256),
     retain_sw	        bit (1) aligned,
     table_volid	        char (168),
     tape_input_switch      pointer,
     temp_seg_ptrs	        (2) pointer,
     last_good_copy_ptr     pointer,
     ptr_active	        fixed bin,
     file_number	        fixed bin,
     table_file_number      fixed bin,
     volume_type	        char (32),
     volid	        (8) char (32),
     vt_ctl_arg	        bit (1) aligned;

%include query_info_;

/* ENTRIES */

dcl  (com_err_,
     com_err_$suppress_name,
     command_query_,
     ioa_,
     ioa_$rsnnl)	        entry options (variable),
     date_time_$fstime      entry (bit (36) aligned, char (*)),
     get_lock_id_	        entry returns (bit (36) aligned),
     (release_temp_segments_,
     get_temp_segments_)    entry (char (*), pointer dimension (*),
		        fixed bin (35)),
     hcs_$fs_get_path_name  entry (ptr, char (*), fixed bin, char (*),
		        fixed bin (35)),
     hcs_$set_bc_seg        entry (pointer, fixed bin (24), fixed bin (35)),
     hcs_$set_safety_sw_seg entry (pointer, bit (1) aligned, fixed bin (35)),
     hcs_$terminate_noname  entry (ptr, fixed bin (35)),
     hcs_$truncate_seg      entry (pointer, fixed bin (18), fixed bin (35)),
     resource_info_$canonicalize_name
		        entry (char (*), char (*), char (*),
		        fixed bin (35));

dcl  ta_table_mgr_$find_and_verify
		        entry (char (*), char (*), ptr, bit (1) aligned,
		        fixed bin (35));

%include iox_dcls;

/* EXTERNAL STATIC */

dcl  (error_table_$bad_arg,
     error_table_$badopt,
     error_table_$noarg,
     error_table_$no_file,
     error_table_$not_detached,
     error_table_$short_record,
     error_table_$too_many_args)
		        ext fixed bin (35) static,
     sys_info$max_seg_size  ext fixed bin (35) static;

/* CONSTANTS */

dcl  TABLE_PREFIX	        char (13) int static options (constant) init ("ONLINE-TABLE-");
dcl  myname	        char (32) int static options (constant) init ("tape_archive");

%include iox_modes;

/* CONDITION */

dcl  cleanup	        condition;

/* BUILTINS */

dcl  (addr, binary, char, codeptr, dim, divide, fixed, hbound, length, min, null, substr, unspec) builtin;

/* BASED VARIABLES */

%include tape_archive_table_dcl;
%include mtape_file_status;

/* BASED */

dcl  based_table	        (n_words_read) bit (36) aligned based;
dcl  1 automatic_fst        aligned like mtape_fst;

	got_older_table = "0"b;

	call iox_$find_iocb ("ta_tape_input_", tape_input_switch, code);
	if code ^= 0 then do;
		call com_err_ (code, myname, "Searching for the tape input switch.");
		goto end_processing;
	     end;

	max_chars_in_seg = sys_info$max_seg_size * 4;
	query_info.version = query_info_version_5;

	if tape_archive_table.n_component_slots
	     + tape_archive_table.n_request_slots > 0 then do;
		query_info.yes_or_no_sw = "1"b;
		call command_query_
		     (addr (query_info), answer, myname,
		     "^a already exists.  Do you wish to overwrite it?? ",
		     table_name);
		if answer = "no" then return;
	     end;

	volume_type = "";
	n_volids = 0;
	volid (*) = "";
	density = 0;
	retain_sw = ""b;
	iom_ctl_arg, vt_ctl_arg = "0"b;

	do i = 1 to dim (arg_array, 1);
	     if arg_array (i) = "-io_module" | arg_array (i) = "-iom" |
		arg_array (i) = "-volume_type" | arg_array (i) = "-vt"
	     then do;
		     if arg_array (i) = "-io_module" | arg_array (i) = "-iom"
			then iom_ctl_arg = "1"b;
		     else vt_ctl_arg = "1"b;
		     i = i + 1;
		     if i > dim (arg_array, 1) then do;
			     call com_err_
				(error_table_$noarg, myname,
				"^[I/O module^;Volume type^] must follow ^a",
				iom_ctl_arg, arg_array (i - 1));
			     return;
			end;

		     if (iom_ctl_arg & ^(arg_array (i) = "tape_ansi_" | arg_array (i) = "tape_ibm_")) |
			(vt_ctl_arg & ^(arg_array (i) = "ansi" | arg_array (i) = "ibm"))
		     then do;
			     call com_err_
				(error_table_$bad_arg, myname,
				"^[I/O module^;Volume type^] ^a not supported.",
				iom_ctl_arg, volume_type);
			     return;
			end;

(nostrz):		     if iom_ctl_arg
		     then do;
			     if arg_array (i) = "tape_ansi_"
				then volume_type = "ansi";
			     else volume_type = "ibm";
			end;
		     else volume_type = arg_array (i);

		end;

	     else if arg_array (i) = "-retain" then do;
		     i = i + 1;
		     if i > dim (arg_array, 1) then retain_sw = "1"b;
		     else if arg_array (i) = "all" then retain_sw = "1"b;
		     else if arg_array (i) = "none" then retain_sw = ""b;
		     else do;
			     call com_err_
				(error_table_$badopt, myname,
				"^a; Use -retain all or -retain none.",
				arg_array (i));
			     return;
			end;
		end;

	     else if arg_array (i) = "-density"
		| arg_array (i) = "-den"
	     then do;
		     i = i + 1;
		     if i > hbound (arg_array, 1)
		     then do;
			     call com_err_ (error_table_$noarg, myname, "-density requires a density number.");
			     return;
			end;
		     density = binary (arg_array (i));
		end;

	     else if char (arg_array (i), 1) = "-" then do;
		     call com_err_
			(error_table_$badopt, myname,
			arg_array (i));
		     return;
		end;


	     else do;
		     n_volids = n_volids + 1;
		     if n_volids > hbound (volid, 1) then do;
			     call com_err_
				(error_table_$too_many_args,
				myname,
				"Only ^d volume ids allowed.",
				n_volids - 1);
			     return;
			end;

(nostrz):		     volid (n_volids) = arg_array (i);
		end;
	end;

	if n_volids = 0 then do;
		query_info.yes_or_no_sw = ""b;
		call command_query_
		     (addr (query_info), answer, myname,
		     "Enter volume name of first volume: ");

		volid (1) = answer;
		n_volids = 1;
	     end;

	if density = 0 then density = Default_density;

	tape_archive_table.n_volumes_in_set (tape_archive_table.active_set) = n_volids;
	tape_archive_table.volume_set (tape_archive_table.active_set).volume_id (*) = volid (*);

	do i = 1 to n_volids;
	     call resource_info_$canonicalize_name
		("tape_vol", (volid (i)), volid (i), code);
	     if code ^= 0 then do;
		     call com_err_ (code, myname, "Canonicalizing the volume ^a name.", volid (i));
		     goto end_processing;
		end;
	end;

	if volume_type = ""
	then volume_type = "ansi";			/* default */

	temp_seg_ptrs = null;

	on cleanup call cleanerup;

	call get_temp_segments_ (myname, temp_seg_ptrs (*), code);
	if code ^= 0 then do;
		call com_err_ (code, myname, "Unable to get temporary segments.");
		goto end_processing;
	     end;

	ptr_active = 1;
	last_good_copy_ptr = null;

	call ioa_$rsnnl ("^a^v( ^a^) -density ^d -volume_type ^a",
	     attach_description, 0, TAPE_ARCHIVE_IO_MODULE, dim (volid, 1),
	     volid (*), density, volume_type);

	call iox_$attach_ptr (tape_input_switch, attach_description, codeptr (ta_load_table_), code);
	if code ^= 0
	then if code ^= error_table_$not_detached
	     then do;
		call com_err_ (code, myname, "Attaching the tape input switch.");
		goto end_processing;
	     end;

	open_description = "-mode binary -block 8192 -number 1";
	fst_ptr = addr (automatic_fst);
	mtape_fst.version = fst_version_1;
	file_number = 0;

	call iox_$open_file (tape_input_switch, Sequential_input, open_description, ""b, code);
	open_description = "-mode binary -block 8192";

	last_good_copy_ptr = null;			/* read no tables yet */
	do while (code = 0);
	     file_number = file_number + 1;
	     call iox_$control (tape_input_switch, "file_status", fst_ptr, code);
	     if code = 0
	     then do;
		     if substr (mtape_fst.f_stat.file_id, 1, length (TABLE_PREFIX)) = TABLE_PREFIX
		     then do;
			     table_file_number = file_number;
			     call hcs_$truncate_seg (temp_seg_ptrs (ptr_active), 0, 0);
			     call iox_$read_record (tape_input_switch,
				temp_seg_ptrs (ptr_active), max_chars_in_seg, n_chars_read, code);
			     if code = error_table_$short_record
				then code = 0;
			     if code = 0
			     then do;
				     last_good_copy_ptr = temp_seg_ptrs (ptr_active);
				     ptr_active = 3 - ptr_active;
				end;
			end;
		     call iox_$close (tape_input_switch, code);
		     if code = 0
			then call iox_$open_file (tape_input_switch, Sequential_input, open_description, ""b, code);
		end;
	end;					/* do while */

	if code = error_table_$no_file
	     then code = 0;				/* read to the EOT */

	if code ^= 0 then do;
		call com_err_ (code, myname, "Searching for the table on the tape.");
end_processing:
		call cleanerup;
		return;
	     end;

	if last_good_copy_ptr = null then do;
		call com_err_ (error_table_$no_file, myname, "There is no valid table on the tape.");
		call cleanerup;
		return;
	     end;

	if table_file_number ^= file_number
	     then got_older_table = "1"b;		/* table wasn't last file on the tape */

	n_words_read = divide (n_chars_read + 3, 4, 18, 0);

	unspec (table_ptr -> based_table) =
	     unspec (last_good_copy_ptr -> based_table);

	call hcs_$truncate_seg (table_ptr, n_words_read, 0);

	call hcs_$set_bc_seg (table_ptr, n_chars_read * 9, code);

	call hcs_$set_safety_sw_seg (table_ptr, "1"b, code);


/* The following set of calls checks the table for consistency, upgrading the
   version if necessary */

	call hcs_$fs_get_path_name (table_ptr, dname, 0, ename, code);

	call ta_table_mgr_$find_and_verify
	     (dname, ename, table_ptr, "0"b, code);
	if code ^= 0 then do;
		call com_err_ (code, myname,
		     "^a>^a", dname, ename);
		call cleanerup;
		return;
	     end;

/* Kill the extra null refname put onto the segment by find_and_verify */

	call hcs_$terminate_noname (table_ptr, 0);

	if got_older_table then do;
		call date_time_$fstime (last_good_copy_ptr ->
		     tape_archive_table.date_time_tape_modified,
		     date_time_string);
		call com_err_$suppress_name (0, myname,
		     "The most recent readable copy of ^a (^a) has been loaded.",
		     table_name, date_time_string);
	     end;

/* Now that we're sure we know where everything is, check the volume names in
   the table for consistency with the names used to load this table. */

	n_table_volids =
	     tape_archive_table.n_volumes_in_set
	     (tape_archive_table.active_set);

	if n_volids ^= n_table_volids then
	     call ioa_
		("^a-- ^a contains ^[only ^;^]^d volumes in volume set.",
		"tape_archive: Warning", table_name,
		(n_table_volids < n_volids), n_table_volids);

	do i = 1 to min (n_volids, n_table_volids);
	     call resource_info_$canonicalize_name ("tape_vol",
		(tape_archive_table.volume_set
		(tape_archive_table.active_set).volume_id (i)),
		table_volid, code);
	     if code ^= 0 then do;
		     table_volid =
			tape_archive_table.volume_set
			(tape_archive_table.active_set).volume_id (i);
		     call com_err_ (code, myname,
			"Canonicalizing volume name ""^a"" from table.",
			table_volid);
		end;

	     if volid (i) ^= table_volid then do;
		     call ioa_
			("^a: ^a-- At least one volume name supplied (^a)
     does not match volume name in table (^a).",
			myname, "Warning",
			volid (i), table_volid);
		     call ioa_
			("^15xAn ""alter_volume"" operation may be indicated.");
		     i = 100;
		end;
	end;

	tape_archive_table.density (tape_archive_table.active_set) = density; /* why force the user to alter? */
	call PUT_VOLUME_TYPE (volume_type);

	call cleanerup;
	return;

cleanerup: proc;

	if temp_seg_ptrs (1) ^= null then
	     call release_temp_segments_
		(myname, temp_seg_ptrs (*), (0));

	call iox_$close (tape_input_switch, (0));

	if retain_sw
	then do;
		tape_archive_table.mount_lock = get_lock_id_ ();
		tape_archive_table.highest_mount_type = Read;
	     end;
	else call iox_$detach_iocb (tape_input_switch, (0));

	return;
     end cleanerup;


PUT_VOLUME_TYPE: proc (volume_type);

dcl  volume_type	        char (*);

	if volume_type = "ansi"
	     then tape_archive_table.io_module_name = "tape_ansi_";
	else tape_archive_table.io_module_name = "tape_ibm_";

     end PUT_VOLUME_TYPE;

     end ta_load_table_;
  



		    ta_process_volume_set_.pl1      03/26/85  0950.2rew 03/25/85  1508.3      296298


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

/* format: style1,^inddcls,ifthenstmt,ifthendo,ifthen,indcomtxt,dclind5 */
ta_process_volume_set_: proc (perm_table_ptr, arg_array, table_name, code);

/* This subroutine implements the "go" key of tape_archive.  It is responsible
   for orchestrating the order in which files are extracted, appended, and so
   on, and for the bookkeeping of the files on the tape.  Certain duties that
   are left to subroutines include actual tape mount, dismount, and I/O, and
   bookkeeping of tape records used and tape file names.

   Written 05/12/77 by C. D. Tavares.
   Modified 04/11/79 by CDT to fix some problems with error handling.
   Modified 09/24/79 by CDT to add -long and to fix bug resulting in
   run-time additions to the volume set failing.
   Modified 09/03/80 by CDT to implement density selection.
   Modified 10/24/80 by CDT to add tape_ibm_ capability.
   Modified 12/9/81 by CDT for highest_mount_type stuff.
   Last modified 83-03-16 by S. G. Harris (UNCA) for version 4.
   Modified 6/83 by S. Krupp for conversion to mtape_.
   Modified 12/83 by T. A. Casey for ssu usage monitoring
   Modified 01/84 by J. A. Bush to enable referencing dir search rule to find
   target I/O module
   Modified: June 1984 by Greg Texada to fix a bug in max volume set size.
   Modified: 85-2-18 by C Spitzer add test for not finding a file when compacting.
*/

/* The following constant is the ssu_usage version ID. It should be changed
   whenever a new version of tape_archive is installed. The version ID decode
   is as follows:
   "tbX_mtY_ZZZ"
   where:
   X = tape_archive table version number
   Y = mtape_ I/O module version number
   ZZZ = either EXL or sss, depending on where this version of tape_archive resides */

dcl  SSU_USAGE_VERSION      char (11) int static options (constant) init
		        ("tb4_mt1_SSS");		/* change this as defined above */

dcl  perm_table_ptr	        pointer parameter,
     arg_array	        (*) char (168) parameter,
     table_name	        char (*) parameter,
     code		        fixed bin (35) parameter,
     a_retain_sw	        bit (1) aligned;

/* AUTOMATIC */

dcl  alternate_volume_set   fixed bin,
     compacting	        bit (1) aligned,
     cur_time	        bit (36) aligned,
     debug_sw	        bit (1) aligned,
     (dlp, sci_ptr)	        pointer,
     (i, j)	        fixed bin,
     lock_entry	        bit (1) aligned,
     max_chars_in_seg       fixed bin (21),
     prev_retain_sw	        bit (1) aligned,
     reel_no	        fixed bin,
     retain_sw	        bit (1) aligned,
     set_incomplete_bit     bit (1) aligned,
     system_free_ptr        pointer,
     tape_has_changed       bit (1) aligned,
     tape_in_volume_string  char (264),
     tape_out_volume_string char (264),
     this_mount_type        fixed bin,
     varying_reel_id        char (168) varying,
     volume_no	        fixed bin,
     volume_string	        char (64) varying;

/* BUILTINS */

dcl  (addr, bit, clock, codeptr, dim, hbound, index, max, null, substr) builtin;

/* STATIC */

dcl  my_lock_id	        bit (36) aligned static initial ((36)"1"b);

/* EXTERNAL STATIC */

dcl  (error_table_$action_not_performed,
     error_table_$bad_mount_request,
     error_table_$badopt,
     error_table_$file_aborted,
     error_table_$lock_wait_time_exceeded,
     error_table_$no_file,
     error_table_$no_next_volume,
     error_table_$not_attached,
     error_table_$not_detached,
     error_table_$not_done,
     error_table_$unexpired_file,
     error_table_$unexpired_volume,
     error_table_$unimplemented_version,
     error_table_$uninitialized_volume,
     error_table_$vol_in_use) external fixed bin (35) static;

dcl  sys_info$max_seg_size  external fixed bin (35) static;

/* ENTRIES */

dcl  (com_err_, com_err_$suppress_name, command_query_, command_query_$yes_no) ext entry options (variable),
     continue_to_signal_    ext entry (fixed bin (35)),
     debug	        ext entry,
     delete_$path	        ext entry (char (*), char (*), bit (6), char (*), fixed bin (35)),
     find_condition_info_   ext entry (pointer, pointer, fixed bin (35)),
     get_lock_id_	        entry returns (bit (36) aligned),
     get_system_free_area_  ext entry returns (pointer),
     get_temp_segments_     ext entry (char (*), pointer dimension (*), fixed bin (35)),
     ioa_		        ext entry options (variable),
     ioa_$rsnnl	        ext entry options (variable),
     release_temp_segments_ ext entry (char (*), pointer dimension (*), fixed bin (35)),
     set_lock_$lock	        entry (bit (36) aligned, fixed bin, fixed bin (35)),
     set_lock_$unlock       entry (bit (36) aligned, fixed bin (35)),
     ssu_$record_usage      entry (ptr, ptr, fixed bin (35)),
     ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, ptr, fixed bin (35)),
     ssu_$destroy_invocation entry (ptr);

dcl  ta_file_io_$append     ext entry (pointer, fixed bin, pointer, fixed bin (35)),
     ta_file_io_$append_table ext entry (pointer, pointer, fixed bin (35)),
     ta_file_io_$compact    ext entry (pointer, fixed bin, pointer, fixed bin (35)),
     ta_file_io_$dismount   ext entry (pointer, pointer, bit (1) aligned, fixed bin (35)),
     ta_file_io_$extract    ext entry (pointer, fixed bin, pointer, fixed bin (35)),
     ta_table_mgr_$cancel_request_no ext entry (pointer, fixed bin, fixed bin (35)),
     ta_table_mgr_$copy_to_perm ext entry (ptr, ptr, fixed bin (35)),
     ta_table_mgr_$copy_to_temp ext entry (ptr, ptr, fixed bin (35)),
     ta_table_mgr_$finish_requests ext entry (pointer, fixed bin (35)),
     ta_table_mgr_$lock     ext entry (ptr, char (*), fixed bin, fixed bin (35)),
     ta_table_mgr_$unlock   ext entry (pointer, fixed bin (35));

/* CONDITIONS */

dcl  (command_question, cleanup) condition;

/* BASED VARIABLES */

dcl  1 delete_list	        aligned based (dlp),
       2 n_entries	        fixed bin initial (0),
       2 entries	        (tape_archive_table.n_queued_requests) aligned,
         3 dirname	        char (168) unaligned,
         3 uid	        bit (36) aligned,
         3 ename	        char (32) unaligned,
         3 force	        bit (1) aligned;

dcl  system_free_area       area based (system_free_ptr);
%page;
%include tape_archive_table_dcl;
%page;
dcl  1 tape_archive_io_info aligned automatic,
%include tape_archive_io_info;
	;
%page;

%include condition_info;
dcl  1 cond_info	        aligned automatic like condition_info;
%page;
%include query_info_;
%page;
%include iox_dcls;
%page;
%include mtape_volume_status;
%page;
%include mtape_err_stats;
%page;

/* ta_process_volume_set_ entry */

	lock_entry = "1"b;

	goto MAIN;

/* ta_process_volume_set_$lock entry */

no_lock: entry (perm_table_ptr, arg_array, table_name, code);

	lock_entry = "0"b;

/* Main procedure. */

MAIN:

/* Record usage in >site>ssudir>tape_archive.ssusage if it exists, if not this is nop */
/* Each "go" request counts as one use, as it will cause tape I/O to happen */

	call ssu_$standalone_invocation (sci_ptr, "tape_archive", SSU_USAGE_VERSION, null (), null (), (0));
	call ssu_$record_usage (sci_ptr, codeptr (ta_process_volume_set_), (0));
	call ssu_$destroy_invocation (sci_ptr);

	table_ptr = perm_table_ptr;
	debug_sw, tape_archive_io_info.long_sw = "0"b;
	temp_seg_ptrs = null;
	max_chars_in_seg = sys_info$max_seg_size * 4;
	dlp = null;
	query_info.version = query_info_version_5;

	if my_lock_id = (36)"1"b then
	     my_lock_id = get_lock_id_ ();

	prev_retain_sw, retain_sw = (tape_archive_table.mount_lock = my_lock_id);

	alternate_volume_set = 3 - tape_archive_table.active_set;

	call iox_$find_iocb ("ta_file_output_", tape_archive_io_info.file_output_switch, code);
	if code ^= 0 then call abort (code, "");

	call iox_$find_iocb ("ta_file_input_", tape_archive_io_info.file_input_switch, code);
	if code ^= 0 then call abort (code, "");

	call iox_$find_iocb ("ta_tape_output_", tape_archive_io_info.tape_output_switch, code);
	if code ^= 0 then call abort (code, "");

	call iox_$find_iocb ("ta_tape_input_", tape_archive_io_info.tape_input_switch, code);
	if code ^= 0 then call abort (code, "");

/* Process arguments if any */

	do i = 1 to dim (arg_array, 1);
	     if (arg_array (i) = "-debug" | arg_array (i) = "-db") then
		debug_sw, tape_archive_io_info.long_sw = "1"b; /* do things loudly on command_question and call db if failure */

	     else if (arg_array (i) = "-long") | (arg_array (i) = "-lg") then
		tape_archive_io_info.long_sw = "1"b;

	     else if arg_array (i) = "-retain" then do;
		     if i = dim (arg_array, 1) then retain_sw = "1"b;
		     else do;
			     i = i + 1;
			     if arg_array (i) = "all" then retain_sw = "1"b;
			     else if arg_array (i) = "none" then retain_sw = ""b;
			     else do;
				     call com_err_ (error_table_$badopt, "tape_archive", "Use -retain all or -retain none.");
				     return;
				end;
			end;
		end;

	     else do;
		     call com_err_ (error_table_$badopt, "tape_archive", arg_array (i));
		     return;
		end;
	end;


	this_mount_type = tape_archive_table.next_mount_type;

	if this_mount_type = None then do;
		if (^retain_sw &
		     (tape_archive_table.mount_lock = my_lock_id)) then do; /* wants to dismount tapes */

			call cleanerup;

			tape_archive_table.highest_mount_type = None;
			call set_lock_$unlock
			     (tape_archive_table.mount_lock, 0);
		     end;
		else do;
			code = error_table_$not_done;
			call com_err_ (code, "tape_archive", "No processing is scheduled for ^a.", table_name);
		     end;
		return;
	     end;

	on cleanup call cleanerup;

	call get_temp_segments_ ("tape_archive", based_temp_seg_ptrs (*), code);
	if code ^= 0 then call abort (code, "");

	if lock_entry
	then do;
		call ta_table_mgr_$lock (perm_table_ptr, table_name, Process_tape, code);
		if code ^= 0 then call abort (code, "Unable to lock the table.");
	     end;

	call ta_table_mgr_$copy_to_temp (perm_table_ptr, tape_archive_io_info.temp_table_ptr, code);
	if code ^= 0 then call abort (code, "Unable to copy the table to a temporary work area.");

	table_ptr = tape_archive_io_info.temp_table_ptr;

	call set_lock_$lock (tape_archive_table.mount_lock, 0, code);
	if code = error_table_$lock_wait_time_exceeded then do;
		call com_err_ (error_table_$vol_in_use, "tape_archive",
		     "^a", table_name);
		call cleanerup;
		return;
	     end;
	if code = 0 then tape_archive_table.highest_mount_type = None;

	perm_table_ptr -> tape_archive_table.mount_lock = my_lock_id;

	tape_archive_table.highest_mount_type =
	     max (tape_archive_table.highest_mount_type, this_mount_type);

	compacting = (this_mount_type = Compact);
	if compacting then i = alternate_volume_set;
	else i = tape_archive_table.active_set;

	if tape_info.n_volumes_in_set (i) = 0 then do;
		query_info.suppress_name_sw = "1"b;
		call command_query_ (addr (query_info),
		     volume_string,
		     "tape_archive", "Enter volume name of new first volume: ");

		tape_info.volume_set (i).volume_id (1) = volume_string;

		tape_info.n_volumes_in_set (i) = 1;
	     end;

%page;
	on command_question begin;
%skip (3);
%include command_question_info;
%include condition_info_header;

dcl  cq_answer	        char (command_question_info.max_answer_lth) based (command_question_info.answer_ptr),
     cq_callername	        char (command_question_info.name_lth) based (command_question_info.name_ptr);
dcl  yes_sw	        bit (1) aligned;
%skip (3);

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

		cq_info_ptr = cond_info.info_ptr;

		if cq_callername ^= TAPE_ARCHIVE_IO_MODULE then goto resignal;

		else if command_question_info.status_code = error_table_$file_aborted then goto resignal;

		else if command_question_info.status_code = error_table_$unexpired_volume then cq_answer = "yes";

		else if command_question_info.status_code = error_table_$uninitialized_volume then
		     if command_question_info.query_code = 3 then goto resignal; /* Valid volume but different label */
		     else cq_answer = "yes";

		else if command_question_info.status_code = error_table_$no_next_volume then do;
			call command_query_$yes_no (yes_sw, 0, "tape_archive",
			     "Volume set is now full. Another tape volume will be required to complete the current operation.",
			     "End of volume reached. Do you wish to extend the volume set?");
			if yes_sw then cq_answer = "no";
			else cq_answer = "yes";
		     end;

		else if command_question_info.status_code = error_table_$unexpired_file then
		     if perm_table_ptr -> tape_archive_table.incomplete_write_op_last then cq_answer = "yes";
		     else if compacting then cq_answer = "yes"; /* destroy any old contents of alternate volume set */
		     else do;
			     call com_err_ (command_question_info.status_code, "tape_archive",
				"^/There may be more recent data on the volume set than is reflected in the table.");
			     call com_err_$suppress_name (0, "tape_archive",
				"^5xUnless you are sure this is not the case, answer ""no"" to the following
^5xquestion and perform a ""load_table"" operation on this volume set to regain^/^5xthe most recent table.");
			     goto resignal;
			end;

		else if command_question_info.status_code = 0 then do; /* wants name of next tape to mount */

			if compacting then volume_no = 3 - tape_archive_table.active_set;
			else volume_no = tape_archive_table.active_set;

			reel_no = tape_archive_table.tape_info.n_volumes_in_set (volume_no) + 1;
			if reel_no > dim (tape_archive_table.volume_set (1).volume_id (*), 2) then do;
				code = error_table_$no_next_volume;
				call com_err_ (code, "tape_archive", "Maximum volume set size exceeded.");
				call abort (code, "");
			     end;

			call command_query_ (addr (query_info), varying_reel_id,
			     "tape_archive", "Enter name of new volume to be appended to the volume set: ");

			tape_info.n_volumes_in_set (volume_no) = reel_no;
			cq_answer, tape_info.volume_set (volume_no).volume_id (reel_no) = varying_reel_id;
		     end;

		command_question_info.question_sw,
		     command_question_info.answer_sw = debug_sw;
						/* blab only if user wants to know */
		command_question_info.answer_lth = index (cq_answer, " ") - 1;
		command_question_info.preset_sw = "1"b;

		goto endblock;

resignal:		call continue_to_signal_ (0);

endblock:	     end;					/* of begin block, command_question handler */
%page;

/* Make lists of input and output volume sets. */

	do i = tape_archive_table.active_set, alternate_volume_set;
	     call ioa_$rsnnl ("^v(^a ^)", tape_out_volume_string, 0,
		tape_archive_table.n_volumes_in_set (i), tape_archive_table.volume_set (i).volume_id (*));
	     if i = tape_archive_table.active_set then tape_in_volume_string = tape_out_volume_string;
	end;

/* Mount necessary volume sets. */

/* Always try to attach the input switch (mount the active volume set)
   because the table might indicate that the user has retained when he
   really hasn't. */

	call attach_switch (tape_archive_io_info.tape_input_switch,
	     tape_in_volume_string, tape_archive_table.active_set,
	     (this_mount_type = Write | retain_sw), code);
	if code = error_table_$not_detached & prev_retain_sw
	then ;
	else if code = error_table_$bad_mount_request
	then call abort (code, "Drive unavailable.");
	else if code ^= 0
	then call abort (code, "Unable to mount active volume set.");

/* Now attach the output switch, if necessary. */

	if this_mount_type >= Write
	then do;
		if compacting
		then do;
			call attach_switch (tape_archive_io_info.tape_output_switch,
			     tape_out_volume_string, alternate_volume_set,
			     compacting, code);
			if code = error_table_$not_detached
			then ;
			else if code = error_table_$bad_mount_request
			then call abort (code, "Drive unavailable.");
			else if code ^= 0
			then call abort (code, "Unable to mount alternate volume set.");
		     end;
		else tape_archive_io_info.tape_output_switch = tape_archive_io_info.tape_input_switch;
	     end;

/* Find the correct open description templates for the tape input and
   output switches.  In conversion to mtape_ -create and -clear have
   been left out of the open descriptions because their jobs are implicitly
   done by mtape_. */

	call ioa_$rsnnl ("-format ^[sb^;vbs^] -block 8192 -mode ^^a -name ^^a -number ^^d",
	     tape_archive_io_info.input_opd_template, 0, (tape_archive_table.io_module_name = "tape_ansi_"));

	if this_mount_type >= Write
	then call ioa_$rsnnl ("-expires 12/31/99 -format ^[sb^;vbs^] -block 8192 -mode ^^a -record ^d -name ^^a -number ^^d",
		tape_archive_io_info.output_opd_template, 0, (tape_archive_table.io_module_name = "tape_ansi_"), sys_info$max_seg_size * 4);
	else tape_archive_io_info.output_opd_template = "";

/* Perform deletions */

	cur_time = substr (bit (clock ()), 20, 36);

	do i = 1 to tape_archive_table.n_component_slots;

	     component_ptr = addr (component_table (i));

	     if component.valid then
		if component.date_time_deleted then do;
			component.valid = ""b;
			component.date_time_deleted = cur_time;
			tape_archive_table.n_components = tape_archive_table.n_components - 1;
			if tape_archive_io_info.long_sw then
			     call ioa_ ("Deleting component ^a", component.entry_name);
		     end;

	end;

/* All deletions are done, now do the extractions */

	if this_mount_type >= Read then do;
		if compacting then
		     tape_archive_table.last_tape_file_no,
			tape_archive_table.last_table_no,
			tape_archive_table.total_records,
			tape_archive_table.dead_records = 0;

		if retain_sw then do;		/* mark the table so we remember */
			perm_table_ptr -> tape_archive_table.mount_lock
			     = tape_archive_table.mount_lock;
						/* the tapes stay up regardless of invocation-specific errors */
			perm_table_ptr -> tape_archive_table.highest_mount_type
			     = tape_archive_table.highest_mount_type;
		     end;

		do i = 1 to tape_archive_table.n_component_slots;

		     component_ptr = addr (component_table (i));

		     if component.valid then
			if component.associated_request_index > 0 then
			     if request_queue (component.associated_request_index).extract then do;
				     j = component.associated_request_index;
				     call ta_file_io_$extract (table_ptr, i, addr (tape_archive_io_info), code);
				     if code = 1
				     then ;	/* special case: cancel deletion, msg already issued */
				     else if code ^= 0
				     then call com_err_ (code, "tape_archive", "^a could not be extracted ^[and was not deleted^].",
					     component.entry_name, request_queue (j).delete);
				     else do;	/* extraction ok, check if deletion requested */
					     if request_queue (j).delete then do;
						     component.valid = ""b;
						     component.date_time_deleted = cur_time;
						     tape_archive_table.n_components = tape_archive_table.n_components - 1;
						     if tape_archive_io_info.long_sw then
							call ioa_ ("Deleting component ^a", component.entry_name);
						     request_queue (j).delete = ""b; /* tell cancel_request_no extract/delete ok */
						end;
					end;
				     call ta_table_mgr_$cancel_request_no (table_ptr, j, code);
				     call ta_table_mgr_$cancel_request_no (perm_table_ptr, j, code);
						/* file successfully extracted, might as well note it in perm table */
				end;
			     else ;		/* must be a replace pending, don't copy it */
			else if compacting then do;
				call ta_file_io_$compact (table_ptr, i, addr (tape_archive_io_info), code);
				if code ^= 0
				then if code = error_table_$no_file
				     then do;
					call com_err_ (code, "tape_archive",
					     "Unable to read ^a from the original tape, it will not appear on the compacted tape.",
					     component.entry_status_descriptor.file_info.entry_name);
					component.entry_status_descriptor.valid = "0"b;
					component.date_time_deleted = cur_time;
					tape_archive_table.n_components = tape_archive_table.n_components - 1;
					end;
				     else call abort (code, "");
			     end;
		end;
	     end;

/* All the extractions are done, now do the replacements and appendings. */

	if this_mount_type >= Write then do;


		set_incomplete_bit = "1"b;

/* The incomplete_write_op_last will be set the first time we successfully
   append something.  This is a hedge in case the user or system crashes
   before table is consistent again.  What this means is that the tape may
   very well have files on the end which are not reflected in the table.  When
   we re-run this table, the tape I/O module will ask whether we want to
   destroy these unexpired files.  If the bit is on, we say yes.  On the other
   hand, if someone's online table gets backed-up (an earlier version
   retrieved), the same situation will occur, and this bit being off will tell
   us that the tape is probably MORE recent than the table, and that the user
   must take remedial action (a load_table or a reconstruct op) to recover
   without losing data.  */


		system_free_ptr = get_system_free_area_ ();
		allocate delete_list set (dlp) in (system_free_area);

		do i = 1 to tape_archive_table.n_request_slots;

		     request_ptr = addr (request_queue (i));

		     if request.valid then do;
			     call ta_file_io_$append (table_ptr, i, addr (tape_archive_io_info), code);
			     if code = error_table_$unexpired_file
			     then do;
				     call com_err_ (code, "tape_archive", "Terminating processing of this volume.");
				     call cleanerup;
				     return;
				end;
			     else if code ^= 0
			     then do;
				     call com_err_ (code, "tape_archive", "^a>^a could not be appended to volume set; removing request.",
					request.directory_name, request.entry_name);
				     call ta_table_mgr_$cancel_request_no (table_ptr, i, code);
						/* remove request; if "rdf" specified, we don't want to delete it! */
				end;
			     else do;		/* successful append */
				     if request.delete then do;
					     delete_list.n_entries, j = delete_list.n_entries + 1;
					     delete_list.dirname (j) = request.directory_name;
					     delete_list.ename (j) = request.entry_name;
					     delete_list.uid (j) = request.uid;
					     delete_list.force (j) = request.force;
					end;
				     if set_incomplete_bit then do;
					     tape_archive_table.incomplete_write_op_last = "1"b;
					     perm_table_ptr -> tape_archive_table.incomplete_write_op_last = "1"b;
					     set_incomplete_bit = ""b;
					end;
				end;
			end;
		end;
	     end;


	tape_has_changed = compacting | tape_archive_table.incomplete_write_op_last; /* next call resets incomplete_write_op_last */
	call ta_table_mgr_$finish_requests (table_ptr, code);
	if tape_archive_table.n_components = 0 then
	     call ioa_ ("tape_archive: All components of ^a have been deleted.", table_name);

	if tape_has_changed then do;			/* here, output the table to tape */
		tape_archive_table.mount_lock = ""b;	/* wouldn't do to have locked table on tape */
		call ta_file_io_$append_table (table_ptr, addr (tape_archive_io_info), code);
		if code ^= 0 then call abort (code, "");
	     end;

/* Copy the new table into permanent storage */

	if (tape_archive_table.highest_mount_type >= Read &
	     retain_sw) then
	     tape_archive_table.mount_lock = my_lock_id;	/* don't bother with set_lock_, it's in the [pd] */
	else tape_archive_table.mount_lock = ""b;	/*  note we no longer have volumes retained */

	call ta_table_mgr_$copy_to_perm (tape_archive_io_info.temp_table_ptr, perm_table_ptr, code);
	if code ^= 0 then call abort (code, "");

	if dlp ^= null then
	     do i = 1 to delete_list.n_entries;
		if delete_list.uid (i) = tape_archive_table.perm_table_uid then /* avoid disaster */
		     call ioa_ ("tape_archive: Deletion of active table ^a has been suppressed.", table_name);
		else do;
			if tape_archive_io_info.long_sw then
			     call ioa_ ("Deleting ^a>^a.", delete_list.dirname (i), delete_list.ename (i));
			call delete_$path (delete_list.dirname (i), delete_list.ename (i), delete_list.force (i) || "11111"b,
			     "tape_archive", code);	/* force if asked, otherwise delete anything that moves,
						   and chase links. */
			if code ^= 0 then
			     call com_err_ (code, "tape_archive", "Unable to delete ^a>^a.",
				delete_list.dirname (i), delete_list.ename (i));
		     end;
	     end;

	table_ptr = perm_table_ptr;

	call cleanerup;
	return;
%page;
cleanerup: proc;

	call dismount_tapes (perm_table_ptr, retain_sw, code);

	if (^retain_sw | (retain_sw & code ^= 0)) & perm_table_ptr -> tape_archive_table.lock = get_lock_id_ ()
	then do;
		perm_table_ptr -> tape_archive_table.highest_mount_type = None;
		call set_lock_$unlock (perm_table_ptr -> tape_archive_table.mount_lock, code);
	     end;

	if lock_entry
	then call ta_table_mgr_$unlock (perm_table_ptr, code);

	call release_temp_segments_ ("tape_archive", based_temp_seg_ptrs (*), code);

	if dlp ^= null then free delete_list in (system_free_area);

	return;
     end cleanerup;
%skip (5);
abort: proc (code, msg) options (non_quick);

/* Parameter */

dcl  code		        fixed bin (35);
dcl  msg		        char (*);

	call com_err_ (code, "tape_archive", msg);
	if debug_sw then do;
		call ioa_ ("Calling debug...");
		call debug;
	     end;
	call cleanerup;
	goto returner;
     end abort;

returner: return;

%page;

dismount: entry (perm_table_ptr, a_retain_sw, code);

	retain_sw = a_retain_sw;

	call iox_$find_iocb ("ta_tape_output_", tape_archive_io_info.tape_output_switch, code);
	if code ^= 0 then call abort (code, "");

	call iox_$find_iocb ("ta_tape_input_", tape_archive_io_info.tape_input_switch, code);
	if code ^= 0 then call abort (code, "");

	call dismount_tapes (perm_table_ptr, retain_sw, code);

	if ^(retain_sw | (retain_sw & code ^= 0)) & perm_table_ptr -> tape_archive_table.lock = get_lock_id_ ()
	then do;
		perm_table_ptr -> tape_archive_table.highest_mount_type
		     = None;
		call set_lock_$unlock
		     (perm_table_ptr -> tape_archive_table.mount_lock, 0);
	     end;

	code = 0;
	return;


%page;

/* This procedure dismounts the volume sets by detaching the
   tape input and output switches.

   If -retain was specified somewhere along the way,
   dismount_tapes tries to do the right thing.  It first
   checks to see if the tape input and output switches need adjustment.
   Tape_archive likes the tape input switch to talk about the active
   volume set.  If for example, we have just done a compaction, this will
   not be the case and we will have to adjust the switches.  If the switches
   cannot be properly adjusted, nothing will be retained.  Otherwise,
   the active set and possibly the alternate set (if used) are
   retained (i.e., the tape input and output switches are left attached).

   Also, we want to take our best shot at dismounting the tapes so we don't
   just return when we get a nonzero error code, we try to keep going.
   We do, however, save the first interesting error code we get and return
   it when we are done. */

dismount_tapes: proc (perm_table_ptr, retain_sw, code);

/* Automatic */

dcl  temp_code	        fixed bin (35);

/* Parameter */

dcl  code		        fixed bin (35);
dcl  retain_sw	        bit (1) aligned;
dcl  perm_table_ptr	        ptr;

	if retain_sw
	then do;
		call adjust_switches (perm_table_ptr, retain_sw, code);
		if code = 0
		then return;
	     end;

	call iox_$detach_iocb (tape_archive_io_info.tape_input_switch, temp_code);
	call save_code (temp_code, code);

	call iox_$detach_iocb (tape_archive_io_info.tape_output_switch, temp_code);
	if temp_code = error_table_$not_attached
	then ;
	else call save_code (temp_code, code);

     end dismount_tapes;


save_code: proc (code1, code2);

/* Parameter */

dcl  code1	        fixed bin (35);
dcl  code2	        fixed bin (35);

	if code2 = 0
	then code2 = code1;

     end save_code;
%page;

/* This procedure makes sure that the tape input switch is talking
   about the active volume set.  If this is not the case (an example
   is, just after a compaction), it will adjust the switches. */

adjust_switches: proc (perm_table_ptr, retain_sw, code);

/* Automatic */

dcl  active_vol_set_ptr     ptr;
dcl  input_sw	        ptr;
dcl  n_active_vols	        fixed bin;
dcl  output_sw	        ptr;
dcl  temp_iocb_ptr	        ptr;
dcl  vol_name_len	        fixed bin (21);
dcl  which_set	        fixed bin;

/* Parameter */

dcl  code		        fixed bin (35);
dcl  retain_sw	        bit (1) aligned;
dcl  perm_table_ptr	        ptr;

/* Based */

dcl  active_vol_set	        (n_active_vols) char (vol_name_len) aligned based (active_vol_set_ptr);

	code = 0;

	input_sw = tape_archive_io_info.tape_input_switch;
	output_sw = tape_archive_io_info.tape_output_switch;

/* Check to see if we need to adjust at all.  If we aren't retaining or
   if we haven't compacted it is not necessary to adjust the switches.
   Just return. */

	if ^retain_sw
	then do;
		code = error_table_$action_not_performed;
		return;
	     end;

	if perm_table_ptr -> tape_archive_table.highest_mount_type < Compact
	then return;

	if input_sw = output_sw
	then return;				/* Compaction occurred, but not this time around. */

/* Looks like we need to adjust the switches.  Get information
   on the volume set assocated with the tape output switch and the
   volume set that we consider to be the active volume set. */

	vsst_ptr = null;

	call iox_$control (output_sw, "volume_set_status", vsst_ptr, code);
	if code = error_table_$not_attached /* Compaction occurred, but not this time around. */
	then do;
		code = 0;
		return;
	     end;
	else if code ^= 0
	then return;

	if mtape_vsst.version ^= vsst_version_1
	then do;
		code = error_table_$unimplemented_version;
		return;
	     end;

	which_set = perm_table_ptr -> tape_archive_table.active_set;
	n_active_vols = perm_table_ptr -> tape_archive_table.n_volumes_in_set (which_set);
	vol_name_len = length (perm_table_ptr -> tape_archive_table.volume_set (which_set).volume_id (1));
	active_vol_set_ptr = addr (perm_table_ptr -> tape_archive_table.volume_set (which_set));

/* If the active set is associated with the tape output switch,
   move it to the tape input switch and the alternate to the
   tape output switch. */

	if same_volume_set (mtape_vsst.vs_stat.volume_name (*), active_vol_set (*))
	then do;					/* Need adjustment */
		call iox_$find_iocb ("ta_temp_iocb_", temp_iocb_ptr, code);
		if code ^= 0
		then return;
		call iox_$move_attach (output_sw, temp_iocb_ptr, code);
		if code ^= 0
		then return;
		call iox_$move_attach (input_sw, output_sw, code);
		if code ^= 0
		then return;
		call iox_$move_attach (temp_iocb_ptr, input_sw, code);
		if code ^= 0
		then return;
	     end;

	free mtape_vsst;

     end adjust_switches;


same_volume_set: proc (set_1, set_2) returns (bit (1) aligned);

/* Parameter */

dcl  set_1	        (*) char (*) aligned;
dcl  set_2	        (*) char (*) aligned;

/* Automatic */

dcl  n_set_1	        fixed bin;
dcl  n_set_2	        fixed bin;

	n_set_1 = hbound (set_1, 1);
	n_set_2 = hbound (set_2, 1);

	do i = 1 by 1 while (i <= n_set_1 & i <= n_set_2 & set_1 (i) = set_2 (i));
	end;

	return (i > n_set_1 & i > n_set_2);

     end same_volume_set;

%page;

/* This procedure determines the necessary attach description with the given
   information.  It then tries to attach the specified I/O switch with
   the attach description. */

attach_switch: proc (iocb_ptr, vol_list_str, vol_set_num, write_sw, code);

/* Parameter */

dcl  code		        fixed bin (35);
dcl  iocb_ptr	        ptr;
dcl  vol_list_str	        char (*);
dcl  vol_set_num	        fixed bin;
dcl  write_sw	        bit (1) aligned;

/* Automatic */

dcl  atd		        char (520);

	atd = "";

	call ioa_$rsnnl ("^a ^a -volume_type ^[ansi^;ibm^] -density ^d ^[-ring^;^]", atd, 0,
	     TAPE_ARCHIVE_IO_MODULE, vol_list_str,
	     (tape_archive_table.io_module_name = "tape_ansi_"), tape_archive_table.density (vol_set_num),
	     write_sw);

	call iox_$attach_ptr (iocb_ptr, atd, codeptr (ta_process_volume_set_), code);

     end attach_switch;


     end ta_process_volume_set_;
  



		    ta_reconstruct_table_.pl1       12/17/85  1305.3rew 12/16/85  1652.9      180045


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

/****^  HISTORY COMMENTS:
  1) change(85-09-27,Spitzer), approve(85-09-27,MCR7212),
     audit(85-10-11,Blair), install(85-12-16,MR12.0-1001):
     Initial coding.
                                                   END HISTORY COMMENTS */


/* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */

ta_reconstruct_table_:
     proc (Ptable_ptr, arg_array, table_name, code);

/*
This procedure implements the reconstruct key of tape_archive.
Usage:  ta reconstruct <table_name> {volume_id_list} {-control_args}
     volume_id_list = up to 8 tape names
     -force, -fc
     -long, -lg
     -density N, -den N
     -retain {all|none}
     -io_module tape_ansi_|tape_ibm_, -iom tape_ansi_|tape_ibm_
     -volume_type ansi|ibm, -vt ansi|ibm
*/

/* Written 85-2-19 by Charlie Spitzer. */

	table_ptr = Ptable_ptr;

	n_volids = 0;
	density = 0;
	retain_sw = "0"b;
	io_module = "";
	volume_type = "";
	volid (*) = "";
	nargs = dim (arg_array, 1);
	force_sw, long_sw = "0"b;

	do i = 1 to nargs;
	     arg = arg_array (i);
	     if substr (arg, 1, 1) = "-"
	     then if /* case */ arg = "-io_module" | arg = "-iom"
		then if i = nargs
		     then do;
missing_arg:
			call com_err_ (error_table_$noarg, myname, "After ^a.", arg);
			return;
			end;
		     else do;
			i = i + 1;
			io_module = arg_array (i);
			if io_module ^= "tape_ansi_" & io_module ^= "tape_ibm_"
			then do;
			     call com_err_ (error_table_$bad_arg, myname, "I/O module ^a not supported.", io_module)
				;
			     return;
			     end;
			end;
		else if arg = "-volume_type" | arg = "-vt"
		then if i = nargs
		     then goto missing_arg;
		     else do;
			i = i + 1;
			volume_type = arg_array (i);
			if volume_type ^= "ansi" & volume_type ^= "ibm"
			then do;
			     call com_err_ (error_table_$bad_arg, myname, "Volume type ^a not supported.",
				io_module);
			     return;
			     end;
			end;
		else if arg = "-retain"
		then if i = nargs
		     then retain_sw = "0"b;
		     else if substr (arg_array (i + 1), 1, 1) = "-"
		     then retain_sw = "0"b;
		     else do;
			i = i + 1;
			if arg_array (i) = "all"
			then retain_sw = "1"b;
			else if arg_array (i) = "none"
			     then retain_sw = "0"b;
			     else do;
bad_argument:
				call com_err_ (error_table_$bad_arg, myname, "^a", arg_array (i));
				return;
				end;
			end;
		else if arg = "-density" | arg = "-den"
		then if i = nargs
		     then goto missing_arg;
		     else do;
			i = i + 1;
			density = cv_dec_check_ (arg_array (i), code);
			if code ^= 0
			then do;
			     call com_err_ (0, myname, "^a is not a valid density.", arg_array (i));
			     return;
			     end;
			end;
		else if arg = "-force" | arg = "-fc"
		then force_sw = "1"b;
		else if arg = "-long" | arg = "-lg"
		then long_sw = "1"b;
		else do;
		     call com_err_ (error_table_$badopt, myname, "^a", arg);
		     return;
		     end;
	     else if n_volids = hbound (volid, 1)
		then do;
		     call com_err_ (error_table_$too_many_args, myname, "Only ^d volume ids allowed.", n_volids);
		     return;
		     end;
		else do;
		     n_volids = n_volids + 1;
		     volid (n_volids) = arg;
		     end;
	     end;

	if io_module ^= ""
	then if volume_type ^= ""
	     then if (io_module = "tape_ansi_" & volume_type = "ansi") | (io_module = "tape_ibm_" & volume_type = "ibm")
		then ;				/* ok */
		else do;
		     call com_err_ (error_table_$inconsistent, myname, "io_module = ^a and volume_type = ^a.",
			io_module, volume_type);
		     return;
		     end;
	     else if io_module = "tape_ansi_"
		then volume_type = "ansi";
		else volume_type = "ibm";
	else if volume_type ^= ""
	     then if volume_type = "ansi"
		then io_module = "tape_ansi_";
		else io_module = "tape_ibm_";
	     else do;				/* default them */
		volume_type = "ansi";
		io_module = "tape_ansi_";
		end;

	query_info.version = query_info_version_5;
	if ^force_sw
	     & (tape_archive_table.tape_info.n_volumes_in_set (1) + tape_archive_table.tape_info.n_volumes_in_set (2))
	     ^= 0
	then do;					/* there appears to be some data in the table already */
	     query_info.yes_or_no_sw = "1"b;
	     call command_query_ (addr (query_info), answer, myname, "^a^/^14x^a^/^14x^a?  ",
		"Reconstructing the table from the tape volume will destroy all",
		"information in the table before reading the tape volume.", "Do you wish to proceed");
	     if answer = "no"
	     then return;
	     end;

	if n_volids = 0
	then do;
	     query_info.yes_or_no_sw = "0"b;
	     call command_query_ (addr (query_info), answer, myname, "Enter volume name of first volume:  ");
	     n_volids = 1;
	     volid (1) = answer;
	     end;

	do i = 1 to n_volids;
	     call resource_info_$canonicalize_name ("tape_vol", (volid (i)), volid (i), code);
	     if code ^= 0
	     then do;
		call com_err_ (code, myname, "Canonicalizing volume ^a.", volid (i));
		return;
		end;
	     end;

	call iox_$find_iocb ("ta_tape_input_", tape_input_switch, code);
	if code ^= 0
	then do;
	     call com_err_ (code, myname, "Finding tape input switch.");
	     goto DONE;
	     end;

	if density = 0
	then density = Default_density;

	temp_ptrs (*) = null;
	on cleanup call cleaner;

	call get_temp_segments_ (myname, temp_ptrs, code);
	if code ^= 0
	then do;
	     call com_err_ (code, myname, "Unable to get temporary segments.");
	     goto DONE;
	     end;
	temp_table_ptr = temp_ptrs (1);
	attribute_seg_ptr = temp_ptrs (2);
	data_seg_ptr = temp_ptrs (3);

	call ta_table_mgr_$lock_and_copy (table_ptr, temp_table_ptr, table_name, Modify, code);
	if code ^= 0
	then do;
	     call com_err_ (code, myname, "Unable to lock the table.");
	     goto DONE;
	     end;

	current_time = substr (bit (clock ()), 20, 36);
	table_ptr = temp_table_ptr;			/* operate on the temp segment */

/* Mount the volume */
	call ioa_$rsnnl ("^a^v( ^a^) -density ^d -volume_type ^a", attach_description, 0,
	     TAPE_ARCHIVE_IO_MODULE, hbound (volid, 1), volid (*), density, volume_type);

	call iox_$attach_ptr (tape_input_switch, attach_description, codeptr (ta_reconstruct_table_), code);
	if code ^= 0
	then if code = error_table_$not_detached
	     then ;				/* ok */
	     else do;
		call com_err_ (code, myname, "Attaching tape with attach description ""^a"".", attach_description);
		goto DONE;
		end;

	open_description = "-mode binary -block 8192 -number 1";
	call iox_$open_file (tape_input_switch, Sequential_input, open_description, ""b, code);
	if code ^= 0
	then do;
	     call com_err_ (code, myname, "Opening tape with open description ""^a"".", open_description);
	     goto DONE;
	     end;
	open_description = "-mode binary -block 8192";

/* Start filling in the pieces of the table that we know */

/* tape_archive_table.nonvolatile_part */
	tape_archive_table.io_module_name = io_module;
	tape_archive_table.table_is_consistent = "0"b;

/* tape_archive_table.volatile_part */
	unspec (tape_archive_table.volatile_part) = "0"b;

	tape_archive_table.incomplete_write_op_last = "1"b;
	tape_archive_table.tape_info.density (1) = density;
	tape_archive_table.tape_info.density (2) = Default_density;
	tape_archive_table.tape_info.active_set = 1;
	tape_archive_table.n_volumes_in_set (1) = n_volids;
	tape_archive_table.volume_set (1).volume_id (*) = volid (*);
	tape_archive_table.volume_set (2).volume_id (*) = "";

	max_chars_in_seg = sys_info$max_seg_size * 4;
	fst_ptr = addr (automatic_fst);
	mtape_fst.version = fst_version_1;
	table_number = 0;

/* Read all the files on the tape */
	do while (code = 0);
	     call iox_$control (tape_input_switch, "file_status", fst_ptr, code);
	     if code = 0
	     then do;
check_file_name:
		attribute_file_name = mtape_fst.f_stat.file_id;
		if substr (attribute_file_name, 1, length (ATTRIBUTE_FILE_PREFIX)) = ATTRIBUTE_FILE_PREFIX
		then do;				/* found an attribute file */
		     call iox_$read_record (tape_input_switch, attribute_seg_ptr, max_chars_in_seg, n_chars_read,
			code);
		     if code = error_table_$short_record
		     then code = 0;
		     if code = 0
		     then do;
			attribute_file_number =
			     fixed (substr (attribute_file_name, length (ATTRIBUTE_FILE_PREFIX) + 1, 4));
			call iox_$close (tape_input_switch, code);
			call iox_$open_file (tape_input_switch, Sequential_input, open_description, ""b, code);
			if code = 0
			then do;
			     call iox_$control (tape_input_switch, "file_status", fst_ptr, code);
			     if code = 0
			     then do;
				data_file_name = mtape_fst.f_stat.file_id;
				data_file_number =
				     fixed (substr (data_file_name, length (ATTRIBUTE_FILE_PREFIX) + 1, 4));
				if data_file_number = attribute_file_number + 1
				then call process_file;
				else do;
				     call com_err_ (error_table_$no_file, myname,
					"Could not locate the data file for attribute file ^d, skipping to next file."
					, attribute_file_number);
				     goto check_file_name;
				     end;
				end;
			     end;
			end;
		     end;
		else if substr (attribute_file_name, 1, length (TABLE_FILE_PREFIX)) = TABLE_FILE_PREFIX
		     then call process_table;
		     else call com_err_ (0, myname, "Found file named ^a, skipping to next file.",
			     attribute_file_name);

		if code = 0
		then do;
		     call iox_$close (tape_input_switch, code);
		     if code = 0
		     then call iox_$open_file (tape_input_switch, Sequential_input, open_description, "0"b, code);
		     end;

		end;
	     end;					/* do while */

	if code ^= error_table_$no_file
	then call com_err_ (code, myname, "Reading the tape searching for files.");

	tape_archive_table.table_is_consistent = "1"b;

	call ta_table_mgr_$copy_and_unlock (table_ptr, Ptable_ptr, code);
	if code ^= 0
	then call com_err_ (code, myname, "Unable to unlock the table.");

	table_ptr = Ptable_ptr;
	call hcs_$truncate_seg (table_ptr, currentsize (tape_archive_table) + 1, (0));
	call hcs_$set_bc_seg (table_ptr, currentsize (tape_archive_table) * 4, (0));
	call hcs_$set_safety_sw_seg (table_ptr, "1"b, (0));

DONE:
	call cleaner;
	return;
%page;
/* We have successfully read in the attribute file and the tape is positioned
at the beginning of the data file. We need to parse the attribute file and fill
in the tape_archive_table.component section */

process_file:
     proc;

dcl  binary_segment bit (1) aligned;

	if long_sw
	then call com_err_$suppress_name (0, myname, "Processing file ^a.", ta_attributes.names (1));

	tape_archive_table.n_components, tape_archive_table.n_component_slots = tape_archive_table.n_components + 1;
	component_ptr = addr (tape_archive_table.component_table (tape_archive_table.n_components));

	component.safety_switch = ta_attributes.safety_switch;
	component.pad = ""b;
	component.tape_file_name = data_file_name;
	component.entry_name = ta_attributes.names (1);
	component.date_time_archived = current_time;	/* not in table, use now */
	component.date_time_branch_modified = ta_attributes.dtem;
	component.date_time_dumped = ta_attributes.dtd;
	component.bitcount_author = "???";		/* ??? not in table */
	component.attribute_file_no = attribute_file_number;
	component.uid = ta_attributes.uid;
	component.future_expansion (*) = ""b;

	component.previous_instance_backchain = 0;
	component.associated_request_index = 0;
	component.date_time_deleted = ""b;
	component.future_expansion (*) = ""b;

	component.file_length = 0;
	component.n_tape_records = 0;
	component.no_final_newline = "0"b;
	binary_segment = "0"b;

/*
read the data file to see how long it is, the recording mode, and if we
can read the entire file
*/
	call iox_$read_record (tape_input_switch, data_seg_ptr, max_chars_in_seg, n_chars_read, code);
	do while (code = 0);
	     component.no_final_newline = (substr (data_seg, n_chars_read, 1) = NL);
	     component.n_tape_records = component.n_tape_records + divide (n_chars_read + 8191, 8192, 35, 0);
	     component.file_length = component.file_length + n_chars_read;
	     if ^binary_segment
	     then binary_segment = (verify (substr (data_seg, 1, n_chars_read), collate ()) > 0);

	     call iox_$read_record (tape_input_switch, data_seg_ptr, max_chars_in_seg, n_chars_read, code);
	     if code = error_table_$short_record
	     then code = 0;
	     end;
	if code ^= error_table_$end_of_info
	then do;
	     call com_err_ (code, myname, "Reading data file ^a.", ta_attributes.names (1));
	     return;
	     end;
	else code = 0;

	component.file_length = divide (component.file_length + 4095, 4096, 35, 0);
						/* length in Multics records */

	tape_archive_table.total_records = tape_archive_table.total_records + component.file_length;
	tape_archive_table.last_tape_file_no = tape_archive_table.last_tape_file_no + 1;

	if binary_segment
	then component.recording_mode = "binary";
	else if volume_type = "ibm"
	     then component.recording_mode = "ebcdic";
	     else component.recording_mode = "ascii";

	component.valid = "1"b;

	return;
     end process_file;
%page;
process_table:
     proc;

dcl  done bit (1) aligned;
dcl  first_found fixed bin;
dcl  new_component_ptr ptr;
dcl  (i,j) fixed bin;

	table_number = fixed (substr (attribute_file_name, length (TABLE_FILE_PREFIX)+1, 4));
	if long_sw
	then call com_err_$suppress_name (0, myname, "Processing table ^i", table_number);

	call iox_$read_record (tape_input_switch, data_seg_ptr, max_chars_in_seg, n_chars_read, code);
	if code ^= 0
	then if code ^= error_table_$short_record
	     then do;
		call com_err_ (code, myname, "Reading table ^i.", table_number);
		return;
		end;
	     else code = 0;

	if data_seg_ptr -> tape_archive_table.version_number ^= tape_archive_version_4
	then do;
	     call com_err_ (error_table_$unimplemented_version, myname,
		"Found table version ^i, expecting version ^i. Skipping to next file.",
		data_seg_ptr -> tape_archive_table.version_number, tape_archive_version_4);
	     return;
	     end;

/* Loop through all entries in the table. If an entry in the table matches
what we read in recently, use the information from the read-in table to update
the information in the table we are building, as not all the component
information is stored in the attribute files. Logically deleted files will come
back, as will files that are replaced by ones further down the tape. The user
will have to clean this up, as we have no idea from mtape_ whether any portions
of the tape were skipped, thus loosing the backchain indices in the table. */

	first_found = 1;
	do i = 1 to data_seg_ptr -> tape_archive_table.n_component_slots;
	     new_component_ptr = addr (data_seg_ptr -> tape_archive_table.component_table (i));
	     if new_component_ptr -> component.valid
	     then do;
		done = "0"b;
		do j = first_found to tape_archive_table.n_component_slots while (^done);
		     component_ptr = addr (tape_archive_table.component_table (j));
		     if component.valid
		     then if new_component_ptr -> component.tape_file_name = component.tape_file_name
			then do;			/* same file, use data not found on tape */
			     component.bitcount_author = new_component_ptr -> component.bitcount_author;
			     component.date_time_archived = new_component_ptr -> component.date_time_archived;
			     first_found = j + 1;	/* for next time through loop */
			     done = "1"b;
			     end;
		     end;				/* do j */
		end;
	     end;					/* do i */

	tape_archive_table.last_table_no = table_number;
	tape_archive_table.date_time_tape_modified = data_seg_ptr -> tape_archive_table.date_time_tape_modified;
	tape_archive_table.date_time_last_compacted = data_seg_ptr -> tape_archive_table.date_time_last_compacted;

	return;
     end process_table;
%page;
cleaner:
     proc;

	if temp_ptrs (1) ^= null
	then call release_temp_segments_ (myname, temp_ptrs, (0));

	if tape_input_switch ^= null
	then do;
	     call iox_$close (tape_input_switch, (0));
	     if retain_sw
	     then do;
		tape_archive_table.mount_lock = get_lock_id_ ();
		tape_archive_table.highest_mount_type = Read;
		end;
	     else call iox_$detach_iocb (tape_input_switch, (0));
	     tape_input_switch = null;
	     end;

	call ta_table_mgr_$unlock (Ptable_ptr, (0));

	return;
     end cleaner;
%page;
%include iox_dcls;
%include iox_modes;
%include query_info_;
%include mtape_file_status;
%include tape_archive_attributes;
%include tape_archive_table_dcl;
%page;
/* Arguments */

dcl  arg_array (*) char (168) parameter;
dcl  code fixed bin (35) parameter;
dcl  max_chars_in_seg fixed bin (21);
dcl  Ptable_ptr ptr parameter;
dcl  table_name char (*) parameter;

/* Automatic */

dcl  answer char (32) varying;
dcl  arg char (168);
dcl  attach_description char (256);
dcl  attribute_file_name char (32);
dcl  attribute_file_number fixed bin;
dcl  attribute_seg_ptr ptr;
dcl  1 automatic_fst aligned like mtape_fst;
dcl  current_time bit (36);
dcl  data_file_name char (32);
dcl  data_file_number fixed bin;
dcl  data_seg_ptr ptr;
dcl  density fixed bin;
dcl  force_sw bit (1) aligned;
dcl  i fixed bin;
dcl  io_module char (10);
dcl  long_sw bit (1) aligned;
dcl  n_chars_read fixed bin (21);
dcl  n_volids fixed bin;
dcl  nargs fixed bin;
dcl  open_description char (168);
dcl  retain_sw bit (1) aligned;
dcl  table_number fixed bin;
dcl  tape_input_switch ptr;
dcl  temp_ptrs (3) ptr;
dcl  temp_table_ptr ptr;
dcl  volid (8) char (32);
dcl  volume_type char (4);

/* Based */

dcl  data_seg char (max_chars_in_seg) based (data_seg_ptr);

/* Builtins */

dcl  addr builtin;
dcl  binary builtin;
dcl  bit builtin;
dcl  clock builtin;
dcl  codeptr builtin;
dcl  collate builtin;
dcl  currentsize builtin;
dcl  dim builtin;
dcl  divide builtin;
dcl  fixed builtin;
dcl  hbound builtin;
dcl  length builtin;
dcl  null builtin;
dcl  substr builtin;
dcl  unspec builtin;
dcl  verify builtin;

/* Conditions */

dcl  cleanup condition;

/* Static */

dcl  ATTRIBUTE_FILE_PREFIX char (13) int static options (constant) init ("ATTRIBUTEFILE");
dcl  error_table_$bad_arg fixed bin (35) ext static;
dcl  error_table_$badopt fixed bin (35) ext static;
dcl  error_table_$end_of_info fixed bin (35) ext static;
dcl  error_table_$inconsistent fixed bin (35) ext static;
dcl  error_table_$no_file fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  error_table_$not_detached fixed bin (35) ext static;
dcl  error_table_$short_record fixed bin (35) ext static;
dcl  error_table_$too_many_args fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  myname char (32) int static options (constant) init ("tape_archive");
dcl  NL char (1) int static options (constant) init ("
");
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  TABLE_FILE_PREFIX char (13) int static options (constant) init ("ONLINE-TABLE-");

/* Entries */

dcl  com_err_ ext entry options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  command_query_ entry () options (variable);
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  get_lock_id_ entry () returns (bit (36) aligned);
dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$set_safety_sw_seg entry (ptr, bit (1), fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35));
dcl  ioa_$rsnnl entry () options (variable);
dcl  release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  resource_info_$canonicalize_name entry (char (*), char (*), char (*), fixed bin (35));
dcl  ta_table_mgr_$copy_and_unlock entry (ptr, ptr, fixed bin (35));
dcl  ta_table_mgr_$lock_and_copy entry (ptr, ptr, char (*), fixed bin, fixed bin (35));
dcl  ta_table_mgr_$unlock entry (ptr, fixed bin (35));

     end ta_reconstruct_table_;
   



		    ta_replace_.pl1                 02/16/84  1307.2r w 02/16/84  1249.4      111375


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

ta_replace_: proc (table_ptr, arg_array, delete, force, table_name, code);

/* This subroutine handles the replace, append, and update keys of
   tape_archive.

   Written 05/10/77 by C. D. Tavares.
   Modified 09/24/79 by CDT to add star convention.
   Last modified 09/21/80 by CDT to implement table workspace strategy
   (indivisible updates).
*/

/* PARAMETERS */

dcl  arg_array (*) char (168) parameter,
     delete bit (1) aligned parameter,
     force bit (1) aligned parameter,
     table_name char (*) parameter,
     code fixed bin (35) parameter;

/* AUTOMATIC */

dcl  answer char (4) varying,
     arg char (168),
     binary_file bit (1),
     branch_type fixed bin,
     component_slot fixed bin,
     current_mode char (8),
     dirname char (168),
     dtbm bit (36),
     ename char (32),
     file_length fixed bin (35),
     i fixed bin,
     operation fixed bin,
     request_slot fixed bin,
     safety_sw bit (1),
     single_name_sw bit (1) aligned,
     specific_component bit (1) aligned,
     wdir char (168);

/* CONDITIONS */

dcl  cleanup condition;


/* CONSTANTS */

dcl (Append initial (1),
     Replace initial (2),
     Update initial (3)) fixed bin static options (constant);

/* INTERNAL STATIC */

dcl  system_free_ptr pointer static initial (null);

/* EXTERNAL STATIC */

dcl (error_table_$bad_mode,
     error_table_$badopt,
     error_table_$namedup,
     error_table_$noarg) ext fixed bin (35) static;

dcl  sys_info$max_seg_size ext fixed bin (35) static;

/* ENTRIES */

dcl  check_star_name_$entry ext entry (char (*), fixed bin (35)),
     com_err_ ext entry options (variable),
     command_query_ ext entry options (variable),
     expand_pathname_ ext entry (char (*), char (*), char (*), fixed bin (35)),
     get_system_free_area_ ext entry returns (pointer),
     get_wdir_ ext entry returns (char (168)),
     hcs_$status_ ext entry (char (*), char (*), fixed bin, pointer, pointer, fixed bin (35)),
     hcs_$status_minf ext entry (char (*), char (*), fixed bin, fixed bin, fixed bin (24), fixed bin (35)),
     ioa_ ext entry options (variable);

dcl  ta_filesys_util_$get_file_info ext entry (char (*), char (*), fixed bin, fixed bin (35), bit (1), bit (1), bit (36), fixed bin (35)),
     ta_filesys_util_$star_list ext entry (char (*), char (*), pointer, fixed bin (35));

dcl  ta_table_mgr_$find_component ext entry (pointer, char (*), char (*), bit (1) aligned, fixed bin, fixed bin, fixed bin (35)),
     ta_table_mgr_$lock ext entry (pointer, char (*), fixed bin, fixed bin (35)),
     ta_table_mgr_$unlock ext entry (pointer, fixed bin (35)),
     ta_table_mgr_$setup_workspace entry (ptr, fixed bin, fixed bin, ptr),
     ta_table_mgr_$complete_table_op entry (ptr);

/* BASED */

dcl  system_free_area area (sys_info$max_seg_size) based (system_free_ptr);

/* BUILTINS */

dcl (addr, binary, dim, null, substr, unspec) builtin;

/* INCLUDE FILES */
%include status_info_branch;
%page;
%include query_info_;
%page;
%include tape_archive_table_dcl;
%page;
%include tape_archive_star;
%page;

/* ta_replace_: proc... */

	operation = Replace;
	goto common;

update:	entry (table_ptr, arg_array, delete, force, table_name, code);

	operation = Update;
	goto common;

append:	entry (table_ptr, arg_array, delete, force, table_name, code);

	operation = Append;

common:
	if system_free_ptr = null then
	     system_free_ptr = get_system_free_area_ ();

	current_mode = "";				/* the "we choose" recording mode */
	single_name_sw = ""b;
	specific_component = ""b;
	query_info.version = query_info_version_5;

/* Following block handles control args */

	do i = 1 to dim (arg_array, 1);

	     arg = arg_array (i);

	     if substr (arg, 1, 1) = "-" then do;
		if arg = "-mode" then do;
		     i = i + 1;
		     if i > dim (arg_array, 1) then do;
			code = error_table_$noarg;
			call com_err_ (code, "tape_archive", "-mode must be followed by a recording mode.");
			return;
		     end;

		     current_mode = arg_array (i);
		     if current_mode ^= "ascii" then
			if current_mode ^= "binary" then
			     if current_mode ^= "ebcdic" then do;
				code = error_table_$bad_mode;
				call com_err_ (code, "tape_archive",
				     "Arguments following ""-mode ^a"" were not processed.", current_mode);
				return;
			     end;

		     arg_array (i) = "-";		/* so pathname loop skips it */
		end;

		else if (arg = "-single_name" | arg = "-snm") then single_name_sw = "1"b;

		else do;
		     code = error_table_$badopt;
		     call com_err_ (code, "tape_archive", "Arguments from ""^a"" were not processed.",
			arg);
		     return;
		end;
	     end;

	     else specific_component = "1"b;
	end;

/* Following block handles args which should be storage system pathnames */

	if specific_component then
	     do i = 1 to dim (arg_array, 1);

	     arg = arg_array (i);

	     if substr (arg, 1, 1) ^= "-" then call process_filearg (arg);
	end;

	else if operation = Append then
	     call com_err_ (error_table_$noarg, "tape_archive", "At least one file must be specified to append.");
	else do;

	     wdir = get_wdir_ ();

	     do i = 1 to tape_archive_table.n_component_slots; /* non-specific replace or update */
		component_ptr = addr (component_table (i));
		if component.valid then do;
		     call hcs_$status_minf (wdir, component.entry_name, 1 /* chase */, 0, 0, code);
		     if code = 0 then call process_filearg (component.entry_name);
		end;
	     end;
	end;

	code = 0;
return_hard:
	return;
%skip(5);
process_filearg: proc (component_name);

dcl  component_name char (*) parameter;

	     call expand_pathname_ (component_name, dirname, ename, code);
	     if code ^= 0 then do;
not_processed:	call com_err_ (code, "tape_archive", """^a"" not processed.", component_name);
		return;
	     end;

	     call check_star_name_$entry (ename, code);
	     if code = 0 then do;
		call replace_one (dirname, ename);
		return;
	     end;

	     else if (code = 1) | (code = 2) then begin;	/* arbitrary starname or "**" */
						/* the begin keeps the current procedure fast by limiting
						   the scope of the following cleanup handler. */

dcl  i fixed bin;

		ta_filesys_star_ptr = null;

		on cleanup begin;
		     if ta_filesys_star_ptr ^= null then
			free ta_filesys_star_info in (system_free_area);
		end;

		call ta_filesys_util_$star_list (dirname, ename, ta_filesys_star_ptr, code);
		if code ^= 0 then goto not_processed;

		do i = 1 to ta_filesys_star_info.n_entries;
		     call replace_one (dirname, ta_filesys_star_info (i).ename);
		end;

		free ta_filesys_star_info in (system_free_area);
	     end;

	     else goto not_processed;
	     return;
%skip(5);
replace_one:   proc (dirname, ename);

dcl (dirname, ename) char (*) parameter;

		on cleanup call ta_table_mgr_$unlock (table_ptr, code);

		call ta_table_mgr_$lock (table_ptr, table_name, Modify, code);
		if code ^= 0 then do;
		     call com_err_ (code, "tape_archive",
			"Arguments from ""^a"" could not be processed.", component_name);
		     goto return_hard;
		end;

		call ta_table_mgr_$find_component (table_ptr, table_name, ename,
		     "0"b /* doesn't have to be there */, component_slot, request_slot, code);
		if code ^= 0 then goto unlock_and_return;

		request_ptr = addr (tape_archive_table.request_queue (request_slot));
		unspec (request) = ""b;		/* clear out any old garbage */

		if current_mode ^= "" then		/* user specified recording mode */
		     request.recording_mode = current_mode;

		else if component_slot > 0 then do;	/* get default mode from old copy */
		     component_ptr = addr (tape_archive_table.component_table (component_slot));
		     request.recording_mode = component.recording_mode;
		end;

		else request.recording_mode = "binary"; /* last resort default */

		component_ptr = null;		/* catch wild refs */

		if request.recording_mode = "binary" then binary_file = "1"b;
		else binary_file = ""b;

		call ta_filesys_util_$get_file_info (dirname, ename, branch_type, file_length,
		     safety_sw, binary_file, dtbm, code);
		if code ^= 0 then do;
		     call com_err_ (code, "tape_archive", "^a>^a", dirname, ename);
		     goto unlock_and_return;
		end;

		if binary_file then
		     if request.recording_mode ^= "binary" then do;
			call com_err_ (0, "tape_archive",
			     "^a cannot be recorded in ^a mode;  using binary mode.", ename, request.recording_mode);
			request.recording_mode = "binary";
		     end;

		if operation = Append then do;
		     if component_slot > 0 then do;	/* already there, complain */
			call com_err_ (error_table_$namedup, "tape_archive", "^a already exists in ^a.", ename, table_name);
			goto unlock_and_return;
		     end;
		     else request.append = "1"b;
		end;

		else if operation = Replace then do;
		     if component_slot = 0 then do;
			call com_err_ (0, "tape_archive", "Appending ^a to ^a", ename, table_name);
			request.append = "1"b;
		     end;
		     else do;
			request.replace = "1"b;
			request.existing_reference = component_slot;
		     end;
		end;

		else if operation = Update then do;
		     if component_slot = 0 then goto unlock_and_return; /* update never appends, only replaces */

		     call hcs_$status_ (dirname, ename, 1, addr (status_info_branch), null, code);
		     if code ^= 0 then do;
			call com_err_ (code, "tape_archive", "^a>^a", dirname, ename);
			goto unlock_and_return;
		     end;

		     if binary (status_info_branch.dtm) <= binary (component_table (component_slot).date_time_archived)
		     then goto unlock_and_return;
		     request.replace = "1"b;
		     request.existing_reference = component_slot;
		     call ioa_ ("tape_archive: Updating ^a in ^a", ename, table_name);
		end;

		request.directory_name = dirname;
		request.entry_name = ename;
		request.delete = delete;
		request.force = force;
		request.single_name = single_name_sw;
		request.file_length = file_length;
		request.date_time_branch_modified = dtbm;
		request.n_tape_records = 0;

		if (delete & safety_sw & ^force) then do;
		     query_info.yes_or_no_sw = "1"b;
		     call command_query_ (addr (query_info), answer, "tape_archive",
			"^a>^a is protected.  Do you wish to delete it?? ", dirname, ename);
		     if answer = "no" then request.delete, request.force = ""b;
		     else request.delete, request.force = "1"b;
		end;

		call ta_table_mgr_$setup_workspace (table_ptr, component_slot, request_slot, workspace_ptr);

		request_ptr = addr (workspace_ptr -> workspace.request_copy);
		component_ptr = addr (workspace_ptr -> workspace.component_copy);

		workspace_ptr -> workspace.n_queued_requests = workspace_ptr -> workspace.n_queued_requests + 1;
		if request.replace then
		     workspace_ptr -> workspace.dead_records = workspace_ptr -> workspace.dead_records
		     + component.file_length;
		workspace_ptr -> workspace.total_records = workspace_ptr -> workspace.total_records + file_length;

		if request_slot > tape_archive_table.n_request_slots then
		     workspace_ptr -> workspace.n_request_slots = request_slot;

		if workspace_ptr -> workspace.next_mount_type < Write then
		     workspace_ptr -> workspace.next_mount_type = Write;

		if component_slot > 0 then		/* we are replacing an existing component */
		     component.associated_request_index = request_slot;

		request.valid = "1"b;

		call ta_table_mgr_$complete_table_op (table_ptr);

unlock_and_return:
		call ta_table_mgr_$unlock (table_ptr, code);
		return;
	     end replace_one;
	end process_filearg;
     end ta_replace_;
 



		    ta_table_mgr_.pl1               02/16/84  1307.2r w 02/16/84  1249.5      444429


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

ta_table_mgr_: proc;
	return;

/* This subroutine manages the online table for tape_archive.  It performs
   operations on the header fields and other operations on the table proper
   (as distinct from one particular entry-- other modules modify individual
   entries.) It also does particular operations on entries when that operation
   is simply a bookkeeping operation (e.g.  deleting a component is simply
   setting a flag;  no tapes are mounted, and the file system is never
   consulted..)

   Written 05/09/77 by C. D. Tavares
   Modified 09/24/79 by CDT to implement star convention entry, star
   convention in cancel, new table version with longer volume names,
   and to diddle n_queued_requests when canceling deletions.
   Modified 09/03/80 by CDT for version 3, adding density field;
   also added "alter density" operation.
   Modified 09/21/80 by CDT to implement indivisible table update
   strategy (setup_workspace, complete_table_op).
   Modified 10/24/80 by CDT to add "alter module".
   Last modified 83-03-16 by S. G. Harris (UNCA) for version 4.
   Modified 7/83 by S. Krupp for conversion to mtape_.  This
      involved:  addition of the volume_type alterspec and addition
      of the -volume_type (-vt) control argument to the load_table key.

*/

%include tape_archive_table_dcl;
%page;
%include tape_archive_star;
%page;
%include query_info_;
%page;
create_table: entry (table_dir, table_name, table_ptr, code);

dcl  table_dir char (*) parameter,
     table_name char (*) parameter,
     code fixed bin (35) parameter;

/* STATIC */

dcl  group_id char (32) static initial (""),
     initialized bit (1) aligned static initial (""b);

/* CONDITIONS */

dcl  cleanup condition;

/* ENTRIES */

dcl (com_err_, com_err_$suppress_name) ext entry options (variable),
     get_group_id_ ext entry returns (char (32)),
     hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)),
     hcs_$set_bc_seg ext entry (pointer, fixed bin (24), fixed bin (35)),
     hcs_$set_safety_sw_seg entry (pointer, bit (1), fixed bin (35)),
     hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin, pointer, fixed bin (35)),
     ioa_ ext entry options (variable),
     set_lock_$lock ext entry (bit (36) aligned, fixed bin, fixed bin (35)),
     set_lock_$unlock ext entry (bit (36) aligned, fixed bin (35));

dcl  ta_upgrade_version_ ext entry (char (*), char (*), pointer, bit (1) aligned, fixed bin (35));


	call ioa_ ("tape_archive:  Creating ^a>^a.", table_dir, table_name);

	call hcs_$make_seg (table_dir, table_name, "", 1010b, table_ptr, code);
	if code ^= 0 then do;			/* If we didn't flat out CREATE this one */
create_err:    call com_err_ (code, "tape_archive", "Creating ^a>^a", table_dir, table_name);
	     return;
	end;

	on cleanup call unlock_table (code);

	call set_lock_$lock (tape_archive_table.lock, 0, code);
	if code ^= 0 then goto create_err;

	group_id = get_group_id_ ();
	initialized = "1"b;
	tape_archive_table.locker_id = group_id;
	tape_archive_table.lock_reason = Modify;

	tape_archive_table.version_number = tape_archive_version_4;
	tape_archive_table.magic_constant = Magic_constant;
	tape_archive_table.compaction_warning_threshold = 0.5e0;
	tape_archive_table.auto_compaction_threshold = 1.0e0;
	tape_archive_table.io_module_name = "tape_ansi_";
	tape_archive_table.tape_info.density (*) = Default_density;
	tape_archive_table.tape_info.active_set = 1;
	tape_archive_table.tape_info.volume_id (*, *) = " ";

	call hcs_$set_bc_seg (table_ptr, size (tape_archive_table) * 36, code);
	call hcs_$set_safety_sw_seg (table_ptr, "1"b, code);

	tape_archive_table.table_is_consistent = "1"b;

	call set_lock_$unlock (tape_archive_table.lock, code);
	return;
%page;
find_and_verify: entry (table_dir, table_name, table_ptr, w_permit, code);

dcl  w_permit bit (1) aligned;

/* ENTRIES */

dcl  hcs_$fs_get_mode ext entry (pointer, fixed bin, fixed bin (35)),
     hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin, fixed bin, pointer, fixed bin (35));

/* AUTOMATIC */

dcl  mode fixed bin;

/* EXTERNAL STATIC */

dcl (error_table_$bad_segment,
     error_table_$improper_data_format,
     error_table_$moderr,
     error_table_$too_many_args) external fixed bin (35) static;

/* BUILTINS */

dcl (bit, clock, currentsize, divide, float, hbound, lbound, length,
     max, mod, null, pointer, substr) builtin;

	w_permit = "1"b;				/* until we find out otherwise */

	call hcs_$initiate (table_dir, table_name, "", 0, 0, table_ptr, code);
	if table_ptr = null then return;		/* no error, maybe this invocation will create one */

	if tape_archive_table.magic_constant ^= Magic_constant then do;
	     code = error_table_$improper_data_format;
	     call com_err_ (code, "tape_archive", "^a>^a is not a tape_archive table.",
		table_dir, table_name);
	     return;
	end;

	call hcs_$fs_get_mode (table_ptr, mode, code);
	if code ^= 0 then do;
	     call com_err_ (code, "tape_archive", "^a>^a", table_dir, table_name);
	     return;
	end;

	if mod (mode, 4) < 2 then w_permit = ""b;

          if tape_archive_table.version_number ^= tape_archive_version_4
          then do;
               call ta_upgrade_version_ (table_dir, table_name, table_ptr, w_permit, code);
	     if code ^= 0 then return;			/* message already printed */
          end;

	if w_permit then do;
	     on cleanup call unlock_table (0);

	     call lock_table (Examine, code);
	     if code ^= 0 then return;
	end;

	if ^tape_archive_table.table_is_consistent then
	     if ^w_permit then do;
		code = error_table_$bad_segment;
		call com_err_ (code, "tape_archive", "^a>^a", table_dir, table_name);
		call com_err_$suppress_name (error_table_$moderr, "tape_archive", "Write permission needed to salvage this table.");
	     end;
	     else call complete_table_op (table_ptr);	/* salvage the table */

	if w_permit then call unlock_table (0);
	return;
%page;
find_component: entry (table_ptr, table_name, component_name, must_be_there, component_slot, request_slot, code);

dcl  component_name char (*) parameter,
     must_be_there bit (1) aligned parameter,
     component_slot fixed bin parameter,
     request_slot fixed bin parameter;

/* EXTERNAL STATIC */

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

/* ENTRIES */

dcl  sub_err_ ext entry options (variable);

/* AUTOMATIC */

dcl  words char (24);

	code = error_table_$action_not_performed;	/* assume the worst */

	do request_slot = 1 to tape_archive_table.n_request_slots
		while (^request_queue (request_slot).valid
		| (request_queue (request_slot).entry_name ^= component_name));
	end;

	if request_slot ^> tape_archive_table.n_request_slots then do;
	     request_ptr = addr (request_queue (request_slot));
	     if request.append then words = "appended to";
	     else if request.replace then words = "replaced onto";
	     else if request.extract then words = "extracted from";
	     else call sub_err_ (code, "tape_archive", "s", null, 0,
		"Valid request found with no request bits.");

	     call com_err_ (code, "tape_archive",
		"^/^5x^a is already scheduled to be ^a the volume set.",
		component_name, words);
	     return;
	end;

	do component_slot = tape_archive_table.n_component_slots to 1 by -1
		while (component_table (component_slot).entry_name ^= component_name
		| ^component_table (component_slot).valid);
	end;

	if component_slot = 0 then
	     if must_be_there then do;
		call com_err_ (code, "tape_archive", "^a not found in ^a.", component_name, table_name);
		return;
	     end;
	     else;				/* no such component found, ok */

	else if component_table (component_slot).date_time_deleted then do;
	     call com_err_ (code, "tape_archive",
		"^/^5x^a is already scheduled to be deleted from the volume set.",
		component_name);

	     return;
	end;

	do request_slot = 1 to tape_archive_table.n_request_slots
		while (request_queue (request_slot).valid);
	end;

	code = 0;
	return;
%page;
alter_attributes: entry (table_ptr, arg_array, table_name, code);

/* This entry implements the "alter" key of tape_archive. */

dcl  arg_array (*) char (168) parameter;

/* AUTOMATIC */

dcl  alter_module bit(1) aligned,
     alter_vol_type bit(1) aligned,
     alterspec char (32),
     args_ok bit (1) aligned,
     old_vol_idx fixed bin,
     fixnum fixed bin,
     floatnum float bin,
    (old_volume_spec, new_volume_spec) char (8),
     prev_retain_sw bit(1) aligned,
     value_arg char (32),
     which_set fixed bin;

/* EXTERNAL STATIC */

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

/* CONSTANTS */

dcl  known_alterspecs (7) char (32) static options (constant) initial
    ("volume_type", "module", "warning_limit", "auto_limit", "compaction", "volume", "density");

dcl  known_densities (3) fixed bin static options (constant) initial
    (800, 1600, 6250);

dcl  known_vol_types (2) char (4) var static options (constant) initial
    ("ansi", "ibm");

dcl  known_io_modules (2) char(10) var static options (constant) initial
    ("tape_ansi_", "tape_ibm_");

/* ENTRIES */

dcl  cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin),
     cv_float_ ext entry (char (*), fixed bin (35)) returns (float bin),
     get_lock_id_ entry() returns(bit(36) aligned);

	nargs = dim (arg_array, 1);
	if nargs = 0 then do;
	     code = error_table_$noarg;
	     call com_err_ (code, "tape_archive", "Attributes to be altered.");
	     return;
	end;

	on cleanup call unlock_table (code);

	call lock_table (Modify, code);
	if code ^= 0 then do;
	     call com_err_ (code, "tape_archive", "alter request not processed.");
	     return;
	end;

	do i = 1 to nargs by 2;
	     alterspec = arg_array (i);
	     value_arg = alterspec;

	     do j = lbound (known_alterspecs, 1) to hbound (known_alterspecs, 1)
		     while (alterspec ^= known_alterspecs (j));
	     end;

	     if j > hbound (known_alterspecs, 1) then
		call alter_err (error_table_$badopt, "^a", alterspec);

	     if i+1 > nargs then
		call alter_err (error_table_$noarg, "^a must be followed by another argument.", alterspec);

	     value_arg = arg_array (i+1);

	     goto alter (j);

alter (1):					/* volume_type */

               alter_vol_type = "1"b;
	     alter_module = "0"b;
	     goto ALTER_MOD_VOL;

alter (2):					/* module */

               alter_module = "1"b;
	     alter_vol_type = "0"b;

ALTER_MOD_VOL:

	     prev_retain_sw = (tape_archive_table.mount_lock = get_lock_id_());

	     if prev_retain_sw
	     then call alter_err(0, "Cannot change this attribute while the volume set is retained: ^a", known_alterspecs(j));

	     if tape_archive_table.n_component_slots > 0 then
		call alter_err (error_table_$badopt,
		"The tape archive must be empty if the ""^a"" attribute is to be changed.", known_alterspecs(j));

               if alter_vol_type
	     then do;
	          do j = lbound (known_vol_types, 1) to hbound (known_vol_types, 1) while (value_arg ^= known_vol_types (j));
	          end;

	          if j > hbound (known_vol_types, 1)
		then call alter_err (error_table_$badopt, """^a"" is not a valid volume type.", value_arg);
	     end;
	     else do;
	          do j = lbound (known_io_modules, 1) to hbound (known_io_modules, 1) while (value_arg ^= known_io_modules (j));
		end;

		if j > hbound (known_io_modules, 1)
		then call alter_err(error_table_$badopt, """^a"" is not a valid I/O module.", value_arg);
	     end;

	     if alter_vol_type
	     then do;
	          if value_arg = known_vol_types(1)
		then tape_archive_table.io_module_name = known_io_modules(1);
		else tape_archive_table.io_module_name = known_io_modules(2);
	     end;
	     else tape_archive_table.io_module_name = value_arg;

	     goto alter_end;

alter (3):					/* warning_limit */
	     floatnum = cv_float_ (value_arg, code);
	     if code ^= 0 then call alter_err (0, "^a non-numeric.", value_arg);
	     if (floatnum < 0 | floatnum > 1e0) then call alter_err (0, "^a not between 0 and 1.", value_arg);
	     else tape_archive_table.compaction_warning_threshold = floatnum;
	     call test_waste_thresholds (""b);
	     goto alter_end;

alter (4):					/* auto_limit */
	     floatnum = cv_float_ (value_arg, code);
	     if code ^= 0 then call alter_err (0, "^a non-numeric.", value_arg);
	     if (floatnum < 0e0 | floatnum > 1e0) then call alter_err (0, "^a not between 0 and 1.", value_arg);
	     else tape_archive_table.auto_compaction_threshold = floatnum;
	     call test_waste_thresholds (""b);
	     goto alter_end;

alter (5):					/* compaction */
	     if value_arg = "on" then tape_archive_table.next_mount_type = Compact;
	     else if value_arg = "off" then call compute_mount_type (-1, -1, tape_archive_table.next_mount_type);
	     else call alter_err (error_table_$badopt, """^a"" not ""off"" or ""on"".", value_arg);
	     goto alter_end;

alter (6):					/* volume */

	     old_vol_idx = -1;
	     old_volume_spec, new_volume_spec = "";
	     which_set = tape_archive_table.active_set;
	     args_ok = ""b;

	     do i = i+1 to nargs;

		value_arg = arg_array (i);

		if substr (value_arg, 1, 1) = "-" then do; /* control argument */
		     if (value_arg = "-number" | value_arg = "-nb") then do;
			if old_vol_idx ^= -1 then call alter_err (error_table_$badopt, "Old volume specification supplied more than once.", "");

			i = i + 1;
			value_arg = arg_array (i);
			old_vol_idx = cv_dec_check_ (value_arg, code);
			if code ^= 0 then call alter_err (0, "^a non-numeric.", value_arg);
			if old_vol_idx <= 0 then call alter_err (0, "^a negative or zero.", value_arg);
		     end;

		     else if value_arg = "-alternate" then
			which_set = 3 - tape_archive_table.active_set;

		     else call alter_err (error_table_$badopt, "^a", value_arg);
		end;

		else do;				/* volume specifications */
		     if old_vol_idx = -1 then do;	/* is the first spec */
			old_volume_spec = value_arg;
			old_vol_idx = 0;
		     end;

		     else if args_ok then
			call alter_err (error_table_$too_many_args, "for ^a.", alterspec);

		     else do;
			args_ok = "1"b;
			new_volume_spec = value_arg;
		     end;
		end;
	     end;

               prev_retain_sw = (tape_archive_table.mount_lock = get_lock_id_());

	     if prev_retain_sw
	     then do;
	          if ((tape_archive_table.highest_mount_type < Compact &
		     which_set = tape_archive_table.active_set) |
		    tape_archive_table.highest_mount_type = Compact)
                    then call alter_err(0, "Cannot change this attribute while the volume set is retained: ^a", known_alterspecs(j));
	     end;

               if which_set = tape_archive_table.active_set
	     then do;
	          if tape_archive_table.n_component_slots > 0
	          then call ioa_("tape_archive: Warning - changing the volume set at this time may damage the archive.");
	     end;


	     if ^ args_ok then call alter_err (error_table_$noarg, "Not enough arguments for ^a.", alterspec);

	     if old_vol_idx > 0 then
		if old_vol_idx > tape_archive_table.n_volumes_in_set (which_set) + 1 then
		     call alter_err (0, "Request would not result in contiguous volumes.", "");

		else;

	     else if old_volume_spec = "" then
		old_vol_idx = tape_archive_table.n_volumes_in_set (which_set) + 1;

	     else do;
		do old_vol_idx = 1 to tape_archive_table.n_volumes_in_set (which_set)
			while (tape_archive_table.volume_set (which_set).volume_id (old_vol_idx) ^= old_volume_spec);
		end;

		if old_vol_idx > tape_archive_table.n_volumes_in_set (which_set) then call alter_err (0, "^a not in volume set.", old_volume_spec);
	     end;

	     call setup_workspace (table_ptr, 0, 0, workspace_ptr);
	     tape_info_ptr = addr (workspace.tape_info_copy);

	     based_tape_info.volume_set (which_set).volume_id (old_vol_idx) = new_volume_spec;
	     if old_vol_idx = based_tape_info.n_volumes_in_set (which_set) + 1 then
		based_tape_info.n_volumes_in_set (which_set) = old_vol_idx;

	     if new_volume_spec = "" then do;

		do old_vol_idx = old_vol_idx to based_tape_info.n_volumes_in_set (which_set) - 1;
		     based_tape_info.volume_set (which_set).volume_id (old_vol_idx)
			= based_tape_info.volume_set (which_set).volume_id (old_vol_idx+1);
		end;

		based_tape_info.n_volumes_in_set (which_set) = old_vol_idx - 1;

	     end;

	     call complete_table_op (table_ptr);

	     goto alter_end;

alter (7):					/* density */
	     which_set = tape_archive_table.active_set;
	     if i+2 <= nargs then
		if arg_array (i+2) = "-alternate" then do;
		     i = i + 1;
		     which_set = 3 - tape_archive_table.active_set;
		end;

               prev_retain_sw = (tape_archive_table.mount_lock = get_lock_id_());

	     if prev_retain_sw
	     then do;
	          if ((tape_archive_table.highest_mount_type < Compact &
		     which_set = tape_archive_table.active_set) |
		    tape_archive_table.highest_mount_type = Compact)
                    then call alter_err(0, "Cannot change this attribute while the volume set is retained: ^a", known_alterspecs(j));
	     end;

	     fixnum = cv_dec_check_ (value_arg, code);
	     if code ^= 0 then call alter_err (0, "^a non-numeric.", value_arg);
	     do j = 1 to hbound (known_densities, 1) while (known_densities (j) ^= fixnum);
	     end;

	     if j > hbound (known_densities, 1) then
		call ioa_ ("tape_archive: Warning-- density ^d may be unacceptable to ^a.", fixnum, tape_archive_table.io_module_name);

	     if tape_archive_table.last_tape_file_no > 0 then
		if which_set = tape_archive_table.active_set then
		     call ioa_ ("tape_archive: Warning-- density change of current volume set may be incompatible with existing recording density for ^a.", table_name);
		else do;
		     call ioa_ ("tape_archive: ^a has been scheduled for compaction due to density change.", table_name);
		     tape_archive_table.next_mount_type = Compact;
		end;

               tape_archive_table.tape_info.density(which_set) = fixnum;

	     goto alter_end;

alter_end: end;

	call unlock_table (code);
	return;

alter_err: proc (code, reason, value);

dcl  code fixed bin (35) parameter,
    (reason, value) char (*) parameter;

	     call com_err_ (code, "tape_archive", reason, value);
	     call unlock_table (0);
	     goto returner;
	end alter_err;

returner:	return;
%skip(5);
compute_mount_type: proc (ignore_component, ignore_request, next_mount_type);

dcl (ignore_component, ignore_request, next_mount_type) fixed bin parameter;

dcl (i, k) fixed bin,
    (component_ptr, request_ptr) pointer;

	     k = None;

	     do i = 1 to tape_archive_table.n_component_slots;
		component_ptr = addr (component_table (i));
		if ((i ^= ignore_component) & component_ptr -> component.valid) then
		     if component_ptr -> component.date_time_deleted = (36)"1"b then k = max (k, Delete);
		     else if component_ptr -> component.associated_request_index > 0 then do;
			request_ptr = addr (request_queue (component_ptr -> component.associated_request_index));
			if request_ptr -> request.extract then k = max (k, Read);
			else do;
			     k = max (k, Write);
			     i = tape_archive_table.n_component_slots; /* no need to continue */
			end;
		     end;
	     end;

	     if k < Write then
		do i = 1 to tape_archive_table.n_request_slots;
		request_ptr = addr (request_queue (i));
		if ((i ^= ignore_request) & request_ptr -> request.valid) then
		     if request_ptr -> request.append then do;
			k = Write;
			i = tape_archive_table.n_request_slots;
		     end;
	     end;

	     next_mount_type = k;
	end compute_mount_type;
%page;
cancel_component: entry (table_ptr, arg_array, table_name, code);

/* This entry implements the "cancel" key of tape_archive. */

/* AUTOMATIC */

dcl (i, j, k) fixed bin,
     dtd_string char (24),
     match bit (1) aligned,
     nargs fixed bin;

/* BUILTINS */

dcl (addr, binary, dim, rel, size, string, unspec) builtin;

/* EXTERNAL STATIC */

dcl  error_table_$nomatch ext fixed bin (35) static;

/* ENTRIES */

dcl  check_star_name_$entry ext entry (char (*), fixed bin (35)),
     date_time_$fstime ext entry (bit (36) aligned, char (*)),
     command_query_ ext entry options (variable);

/* AUTOMATIC */

dcl  yes_or_no char (4) varying;

	nargs = dim (arg_array, 1);

	on cleanup call unlock_table (code);

	call lock_table (Modify, code);
	if code ^= 0 then do;
	     call com_err_ (code, "tape_archive", "cancel request not processed.");
	     return;
	end;

	do i = 1 to nargs;
	     call check_star_name_$entry (arg_array (i), code);
	     if code = 0 then;
	     else if code = 1 then;			/* is a discretionary starname */
	     else if code = 2 then nargs = 0;		/* user said "**" or equivalent */
	     else do;
		call com_err_ (code, "tape_archive", "^a", arg_array (i));
		call unlock_table (0);
		return;
	     end;
	end;

	query_info.version = query_info_version_5;
	query_info.yes_or_no_sw = "1"b;

	if nargs = 0 then do;
	     call command_query_ (addr (query_info), yes_or_no, "tape_archive",
		"Do you wish to cancel all pending requests in ^a??  ", table_name);
	     if yes_or_no = "yes" then do;
		do i = 1 to tape_archive_table.n_request_slots;
		     if request_queue (i).valid then
			call cancel_request (i);
		end;

		do i = 1 to tape_archive_table.n_component_slots;
		     if component_table (i).valid then
			if component_table (i).date_time_deleted = (36)"1"b then
			     call cancel_deletion (i);
		end;
	     end;

	end;

	else begin;

dcl  arg_used (nargs) bit (1) aligned automatic,
     is_starname (nargs) bit (1) aligned automatic;


dcl  already_hit (0:tape_archive_table.n_component_slots) bit (1) aligned automatic;

	     unspec (arg_used), unspec (already_hit), unspec (is_starname) = ""b;

	     do i = 1 to nargs;
		call check_star_name_$entry (arg_array (i), code);
		is_starname (i) = (code = 1);
	     end;

	     do j = 1 to tape_archive_table.n_request_slots;
		match = ""b;

		request_ptr = addr (tape_archive_table.request_queue (j));

		if request.valid then do k = 1 to nargs;
		     if is_starname (k) then do;
			call match_star_name_ (request.entry_name, arg_array (k), code);
			if code = 0 then match, arg_used (k) = "1"b;
		     end;
		     else if request.entry_name = arg_array (k) then
			match, arg_used (k) = "1"b;
		end;

		if match then do;
		     already_hit (request.existing_reference) = "1"b;
		     call cancel_request (j);
		end;
	     end;

	     do j = 1 to tape_archive_table.n_component_slots;
		match = ""b;

		component_ptr = addr (tape_archive_table.component_table (j));

		if component.valid then do k = 1 to nargs;
		     if is_starname (k) then do;
			call match_star_name_ (component.entry_name, arg_array (k), code);
			if code = 0 then match, arg_used (k) = "1"b;
		     end;
		     else if component.entry_name = arg_array (k) then
			match, arg_used = "1"b;
		end;

		if match then
		     if ^already_hit (j) then
			call cancel_deletion (j);
	     end;

/* Check to see if the user is trying to cancel something that has already been processed as deleted.
   If so, allow it, but warn him about what he is doing. */

	     do i = 1 to nargs;
		if (^arg_used (i) & ^is_starname (i)) then do;
		     do j = tape_archive_table.n_component_slots to 1 by -1
			     while (tape_archive_table.component_table.entry_name (j) ^= arg_array (i));
		     end;

		     if j > 0 then do;
			component_ptr = addr (tape_archive_table.component_table (j));
			call date_time_$fstime (component.date_time_deleted, dtd_string);

			call command_query_ (addr (query_info), yes_or_no, "tape_archive",
			     "Component ^a was already processed as deleted on ^a.^/^-^4xDo you wish to cancel its deletion?",
			     component.entry_name, dtd_string);

			if yes_or_no = "yes" then call cancel_deletion (j);
			arg_used (i) = "1"b;
		     end;
		end;
	     end;

/* Complain about any we never found. */

	     do i = 1 to nargs;
		if arg_used (i) = ""b then do;
		     if is_starname (i) then code = error_table_$nomatch;
		     else code = 0;
		     call com_err_ (code, "tape_archive", "^a^[^; not found^] in ^a", arg_array (i), is_starname (i), table_name);
		end;
	     end;
	end;

	call unlock_table (code);

	return;
%page;
cancel_request_no: entry (table_ptr, request_slot, code);

/* This entry is like cancel_component except that it is called at tape
   processing time to remove both successful extractions and unsuccessful
   operations of any type. */

	call cancel_request (request_slot);
	code = 0;
	return;
%skip(5);
cancel_request: procedure (idx);

dcl  idx fixed bin parameter;

dcl (auto_request_no, auto_component_no) fixed bin;

	     auto_request_no = idx;
	     auto_component_no = request_queue (idx).existing_reference;

	     call setup_workspace (table_ptr, auto_component_no, auto_request_no, workspace_ptr);

	     request_ptr = addr (workspace_ptr -> workspace.request_copy);
	     component_ptr = addr (workspace_ptr -> workspace.component_copy);

	     if request.extract then
		if request.delete then		/* successful extract/delete resets this */
		     workspace_ptr -> workspace.dead_records = workspace_ptr -> workspace.dead_records - component.file_length;
	     if request.append | request.replace then do;
		workspace_ptr -> workspace.dead_records = workspace_ptr -> workspace.dead_records - component.file_length;
		workspace_ptr -> workspace.total_records = workspace_ptr -> workspace.total_records - request.file_length;
	     end;

	     workspace_ptr -> workspace.n_queued_requests = workspace_ptr -> workspace.n_queued_requests - 1;

	     workspace_ptr -> workspace.component_copy.associated_request_index = 0;

	     if workspace_ptr -> workspace.next_mount_type ^= Compact then
		call compute_mount_type (auto_component_no, auto_request_no, workspace_ptr -> workspace.next_mount_type);

	     unspec (request_ptr -> request) = ""b;	/* wipe out request */

	     call complete_table_op (table_ptr);

	     return;

cancel_deletion: entry (idx);

	     auto_component_no = idx;

	     component_ptr = addr (component_table (auto_component_no));

	     if component.date_time_deleted = ""b then do;
		call com_err_ (error_table_$action_not_performed, "tape_archive", "No requests pending for ^a.", component.entry_name);
		return;
	     end;

	     call setup_workspace (table_ptr, auto_component_no, 0, workspace_ptr);
	     component_ptr = addr (workspace_ptr -> workspace.component_copy);

	     workspace_ptr -> workspace.dead_records = workspace_ptr -> workspace.dead_records - component.file_length;
	     if component.valid then
		workspace_ptr -> workspace.n_queued_requests = workspace_ptr -> workspace.n_queued_requests - 1;
	     else workspace_ptr -> workspace.n_components = workspace_ptr -> workspace.n_components + 1;

	     component.date_time_deleted = ""b;
	     component.valid = "1"b;

	     if workspace_ptr -> workspace.next_mount_type ^= Compact then
		call compute_mount_type (auto_component_no, 0, workspace_ptr -> workspace.next_mount_type);

	     call complete_table_op (table_ptr);

	     return;
	end cancel_request;
%page;
lock:	entry (table_ptr, table_name, lock_reason, code);

dcl  lock_reason fixed bin;

	call lock_table (lock_reason, code);
	return;
%skip(5);
unlock:	entry (table_ptr, code);

	call unlock_table (code);
	return;
%skip(5);
lock_and_copy: entry (table_ptr, temp_table_ptr, table_name, lock_reason, code);

/* PARAMETER */

dcl  temp_table_ptr pointer parameter;

/* ENTRIES */

dcl  hcs_$get_uid_seg entry (ptr, bit (36) aligned, fixed bin (35));


	call lock_table (lock_reason, code);
	if code ^= 0 then return;

	call copy_to_temp_table(table_ptr, temp_table_ptr, code);

	return;
%skip(5);
copy_and_unlock: entry (temp_table_ptr, table_ptr, code);

          call copy_to_perm(temp_table_ptr, table_ptr, code);
	if code ^= 0 then return;

	call unlock_table (code);

	return;
%page;
copy_to_temp: entry(table_ptr, temp_table_ptr, code);

          call copy_to_temp_table(table_ptr, temp_table_ptr, code);

	return;


copy_to_perm: entry(temp_table_ptr, table_ptr, code);

          call copy_to_perm_table(temp_table_ptr, table_ptr, code);

	return;
%page;
lock_table: proc (reason_arg, code);

dcl  reason_arg fixed bin parameter,
     code fixed bin (35) parameter;

dcl (error_table_$lock_wait_time_exceeded,
     error_table_$locked_by_this_process) external fixed bin (35) static;

	     call set_lock_$lock (tape_archive_table.lock, 10, code);
	     if code = error_table_$lock_wait_time_exceeded then do;
						/* there is contention on this lock */
		call com_err_ (code, "tape_archive", "^/^5x^a already locked by ^a for ^a.",
		     table_name, tape_archive_table.locker_id, Lock_reasons (tape_archive_table.lock_reason));
		return;
	     end;

	     else if code = error_table_$locked_by_this_process then do;
						/* Mylock condiion shouldn't really occur unless the user */
						/* quit out of tape_archive at a lower command level previously and */
						/* never released */
		call com_err_ (code, "tape_archive",
		     "^/^5x^a still locked by a previous incomplete command invocation.",
		     table_name);
		return;
	     end;

	     else code = 0;

	     if ^initialized then do;
		group_id = get_group_id_ ();
		initialized = "1"b;
	     end;

	     tape_archive_table.locker_id = group_id;
	     tape_archive_table.lock_reason = reason_arg;
	     return;

unlock_table:  entry (code);

	     if tape_archive_table.lock ^= ""b then
		call set_lock_$unlock (tape_archive_table.lock, code);
	     else code = 0;
	     return;

	end lock_table;
%page;
copy_to_temp_table: proc(table_ptr, temp_table_ptr, code);

/* PARAMETER */

dcl  code fixed bin(35);
dcl  table_ptr ptr;
dcl  temp_table_ptr ptr;

/* AUTOMATIC */

dcl  overlay_length fixed bin (18);

/* BASED */

dcl  overlay (overlay_length) bit (36) aligned based;

/* ENTRIES */

dcl  hcs_$get_uid_seg entry (ptr, bit (36) aligned, fixed bin (35));

          code = 0;

/* Update table uid -- load_table, copy, etc. may have changed it. */

	call hcs_$get_uid_seg (table_ptr, table_ptr->tape_archive_table.perm_table_uid, code);
	if code ^= 0 then tape_archive_table.perm_table_uid = "0"b; /* shouldn't happen -- but suppress table check */

/* Now copy table. */

	overlay_length = currentsize (table_ptr->tape_archive_table);
	temp_table_ptr -> overlay = table_ptr -> overlay;

	temp_table_ptr -> tape_archive_table.lock = ""b;	/* interactive mode hates mylocks */
	temp_table_ptr -> tape_archive_table.lock_reason = 0;

     end copy_to_temp_table;
%skip(5);
copy_to_perm_table: proc(temp_table_ptr, table_ptr, code);

/* PARAMETER */

dcl  code fixed bin(35);
dcl  temp_table_ptr ptr;
dcl  table_ptr ptr;

/* AUTOMATIC */

dcl  old_mask bit (36) aligned;
dcl  overlay_length fixed bin(18);

/* BASED */

dcl  overlay(overlay_length) bit(36) aligned based;

/* ENTRIES */

dcl (hcs_$set_ips_mask, hcs_$reset_ips_mask) entry (bit (36) aligned, bit (36) aligned);


          code = 0;

	old_mask = ""b;
	on cleanup begin;
	     if old_mask ^= ""b then
		call hcs_$reset_ips_mask ((old_mask), old_mask);
	end;

          overlay_length = currentsize(temp_table_ptr->tape_archive_table);

	table_ptr -> tape_archive_table.recovery_info_offset = ""b;
						/* if we blow up during copy, too bad */

	call hcs_$set_ips_mask (""b, old_mask);

/* OK, now run like hell. */

	table_ptr -> tape_archive_table.table_is_consistent = ""b;

          table_ptr->overlay = temp_table_ptr->overlay;

	table_ptr->tape_archive_table.table_is_consistent = "1"b;

/* Whew-- made it! */

	call hcs_$set_bc_seg (table_ptr, length (unspec (table_ptr->tape_archive_table)), code);
	call hcs_$truncate_seg (table_ptr, currentsize (table_ptr->tape_archive_table), code);

	call hcs_$reset_ips_mask ((old_mask), old_mask);

     end copy_to_perm_table;
%page;
check_compaction: entry (table_ptr, table_name, code);

dcl  waste float bin;

	code = 0;

	if tape_archive_table.next_mount_type ^= Compact then call test_waste_thresholds ("1"b);
	return;
%skip(5);
test_waste_thresholds: proc (lockit);

dcl  lockit bit (1) aligned parameter;

	     if tape_archive_table.total_records = 0 then waste = 0;
	     else waste = float (tape_archive_table.dead_records) / float (tape_archive_table.total_records);

	     if waste > tape_archive_table.auto_compaction_threshold then do;
		if lockit then do;
		     call lock_table (Modify, code);
		     if code ^= 0 then return;
		end;

		tape_archive_table.next_mount_type = Compact;

		if lockit then call unlock_table (code);

		call ioa_ ("tape_archive:  ^a has been scheduled for compaction.", table_name);
		return;
	     end;

	     if waste >= tape_archive_table.compaction_warning_threshold then
		call ioa_ ("tape_archive: Waste factor of ^a is ^d%.", table_name, waste * 100);

	     return;
	end test_waste_thresholds;
%page;
finish_requests: entry (table_ptr, code);

/* This entry cleans up the table just prior to putting it out to tape.
   This operation is always performed on a temp copy of the table in the
   process dir-- hence no locking or IPS masking is necessary or done. */

/* AUTOMATIC */

dcl  compacting bit (1) aligned,
     cur_time bit (36) aligned,
     last_new_idx fixed bin,
     overlay_length fixed bin(18),
     temp_ptr pointer;

/* BASED */

dcl  based_temp_ptr (1) pointer based (addr (temp_ptr));
dcl  overlay(overlay_length) bit(36) aligned based;

/* ENTRIES */

dcl  get_temp_segments_ ext entry (char (*), pointer dimension (*), fixed bin (35)),
     release_temp_segments_ ext entry (char (*), pointer dimension (*), fixed bin (35));

	code = 0;
	cur_time = substr (bit (clock ()), 20, 36);	/* standard file system time */

	tape_archive_table.incomplete_write_op_last = ""b;

	if tape_archive_table.next_mount_type = Read then do;
	     tape_archive_table.next_mount_type = None;
	     return;
	end;

	temp_ptr = null;
	on cleanup begin;
	     if temp_ptr ^= null then call release_temp_segments_ ("tape_archive", based_temp_ptr, code);
	end;

	call get_temp_segments_ ("tape_archive", based_temp_ptr, code);

	last_new_idx = tape_archive_table.n_component_slots;

	compacting = (tape_archive_table.next_mount_type = Compact);

	if compacting then do;

	     last_new_idx = 0;			/* start from beginning again */
	     tape_archive_table.date_time_last_compacted = cur_time;
	     tape_archive_table.total_records = 0;

	     do i = 1 to tape_archive_table.n_component_slots;

		component_ptr = addr (component_table (i));

		if component.valid then
		     if component.associated_request_index = 0 then do; /* extracts all removed by this point */
			last_new_idx = last_new_idx + 1;
			if last_new_idx ^= i then do;
			     unspec (component_table (last_new_idx)) = unspec (component_table (i));
			     component_table (last_new_idx).previous_instance_backchain = 0;
			end;
			tape_archive_table.total_records = tape_archive_table.total_records + component.file_length;
		     end;
	     end;

	     tape_archive_table.n_components = last_new_idx;

	     tape_archive_table.dead_records = 0;
	     tape_archive_table.date_time_last_compacted = cur_time;
	     tape_archive_table.last_table_no = 0;
	     tape_archive_table.tape_info.active_set = 3 - tape_archive_table.tape_info.active_set;
	end;

	overlay_length = currentsize (tape_archive_table);
	temp_ptr -> overlay = table_ptr -> overlay;	/* copy table to temp seg */

	tape_archive_table.n_component_slots = last_new_idx;

	call hcs_$truncate_seg (table_ptr, binary (rel (addr (tape_archive_table.request_queue))), code);
	if code ^= 0 then goto release_and_return;

	do i = 1 to tape_archive_table.n_request_slots;
	     request_ptr = addr (temp_ptr -> tape_archive_table.request_queue (i));
	     if request.valid then do;
		last_new_idx = last_new_idx + 1;
		tape_archive_table.n_component_slots = last_new_idx;
		component_ptr = addr (tape_archive_table.component_table (last_new_idx));
		string (request.requested_ops) = ""b;
		unspec (component.entry_status_descriptor) = unspec (request.entry_status_descriptor);
		component.associated_request_index = 0;

		if request.existing_reference ^= 0 then /* This is a replacement, not an addition */
		     if ^compacting then do;
			component.previous_instance_backchain = request.existing_reference;
			component_table (component.previous_instance_backchain).valid = ""b;
		     end;
		     else do;			/* compacting, old copy no longer there */
			component.previous_instance_backchain = 0;
			tape_archive_table.n_components = tape_archive_table.n_components + 1;
		     end;
		else tape_archive_table.n_components = tape_archive_table.n_components + 1;
						/* addition, not replacement */
	     end;
	end;

	if tape_archive_table.next_mount_type > Read then tape_archive_table.date_time_tape_modified = cur_time;
	tape_archive_table.n_queued_requests, tape_archive_table.n_request_slots = 0;

	tape_archive_table.next_mount_type = None;

release_and_return:
	call release_temp_segments_ ("tape_archive", based_temp_ptr, code);
	return;
%page;
star_list: entry (table_ptr, a_starname, selector, a_ta_component_star_ptr, code);

dcl  a_starname char (32) parameter,
     selector fixed bin parameter,
     a_ta_component_star_ptr pointer;

dcl  match_star_name_ ext entry (char (*), char (*), fixed bin (35));

dcl  sys_info$max_seg_size ext fixed bin (35) static;

dcl  system_free_area area (sys_info$max_seg_size) based (system_free_ptr);

dcl  system_free_ptr pointer static initial (null);

dcl  get_system_free_area_ ext entry returns (pointer);

	on cleanup call unlock_table (0);

	call lock_table (Examine, code);
	if code ^= 0 then return;

	call star_list (a_starname, selector, a_ta_component_star_ptr, code);

	if code ^= 0 then call unlock_table (0);
	else call unlock_table (code);

	return;
%skip(5);
star_list: proc (starname, selector, a_ta_component_star_ptr, code);

dcl (starname char (32),
     selector fixed bin,
     a_ta_component_star_ptr pointer,
     code fixed bin (35)) parameter;

dcl  i fixed bin;

dcl 1 select_table (tape_archive_table.n_component_slots + tape_archive_table.n_request_slots) aligned automatic like ta_component_star_info.entry;

	     if system_free_ptr = null then
		system_free_ptr = get_system_free_area_ ();

	     a_ta_component_star_ptr, ta_component_star_ptr = null;

	     ta_star_match_count = 0;

	     if selector ^= Request then
		do i = 1 to tape_archive_table.n_component_slots;

		component_ptr = addr (tape_archive_table.component_table (i));

		if component.valid then do;
		     call match_star_name_ (component.entry_name, starname, code);
		     if code = 0 then do;
			ta_star_match_count = ta_star_match_count + 1;
			select_table (ta_star_match_count).ename = component.entry_name;
			select_table (ta_star_match_count).type = Component;
			select_table (ta_star_match_count).table_idx = i;
		     end;

		     else if code = error_table_$nomatch then;

		     else return;
		end;
	     end;

	     if selector ^= Component then
		do i = 1 to tape_archive_table.n_request_slots;

		request_ptr = addr (tape_archive_table.request_queue (i));

		if request.valid then do;
		     call match_star_name_ (request.entry_name, starname, code);
		     if code = 0 then do;
			ta_star_match_count = ta_star_match_count + 1;
			select_table (ta_star_match_count).ename = request.entry_name;
			select_table (ta_star_match_count).type = Request;
			select_table (ta_star_match_count).table_idx = i;
		     end;

		     else if code = error_table_$nomatch then;

		     else return;
		end;
	     end;

	     if ta_star_match_count = 0 then do;
		code = error_table_$nomatch;
		return;
	     end;

	     code = 0;

	     on cleanup begin;
		if ta_component_star_ptr ^= null then
		     free ta_component_star_info in (system_free_area);
	     end;

	     allocate ta_component_star_info in (system_free_area);

	     unspec (ta_component_star_info.entry) = unspec (select_table);
	     a_ta_component_star_ptr = ta_component_star_ptr;

	     return;

	end star_list;
%page;
setup_workspace: entry (table_ptr, arg_component_no, arg_request_no, arg_workspace_ptr);

dcl (arg_component_no, arg_request_no) fixed bin parameter,
     arg_workspace_ptr pointer;

	call setup_workspace (table_ptr, arg_component_no, arg_request_no, arg_workspace_ptr);
	return;

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

setup_workspace: proc (table_ptr, arg_component_no, arg_request_no, workspace_ptr);

/* This entry and entry complete_table_op implement the "indivisible" table
   update strategy necessary to make sure that the table always remains
   consistent.  Any tape_archive operation which has only to modify one item
   in the table (e.g., "alter density") can do so without going through a
   window where the table is inconsistent.  Thus it can operate on the table
   data directly.  Any other operation, however (e.g., extract, which has to
   set up a request queue entry and update several header variables such as
   next_mount_type, n_queued_requests, etc.) must use these two entries.  The
   strategy is to call setup_workspace, giving the component and request
   number (if any) before starting the work.  All pertinent variables,
   including the request, component, and header variables, are copied into the
   workspace.  All changes are then made to the copies of the pertinent
   information in the workspace.  Should the operation be aborted anywhere
   during this time, the table remains consistent and the workspace is later
   flushed.  When the new information is complete and consistent,
   complete_table_op is called to put the information into place in an
   indivisible fashion (exactly how is described in it's own header comment. */

dcl (arg_component_no, arg_request_no) fixed bin parameter,
    (table_ptr, workspace_ptr) pointer parameter;

dcl  temp_offset fixed bin (18) automatic;

/* First, clean up any old workspaces hanging around. */

	     if table_ptr -> tape_archive_table.recovery_info_offset ^= ""b then do;
		workspace_ptr = pointer (table_ptr, table_ptr -> tape_archive_table.recovery_info_offset);
		if workspace_ptr -> workspace.workspace_id = Magic_workspace_constant then
		     unspec (workspace_ptr -> workspace) = ""b;
		table_ptr -> tape_archive_table.recovery_info_offset = ""b;
	     end;

/* Calculate a safe place to put the workspace.  Put it at the end of the
   segment, leaving enough room for extra request structures to be added on
   to the segment without clobbering our workspace. */

	     temp_offset = currentsize (table_ptr -> tape_archive_table)
		+ 3 * size (null -> request)		/* only 1 should really be needed */
		+ 20;				/* for good luck */

	     workspace_ptr = pointer (table_ptr, bit (temp_offset));

	     unspec (workspace_ptr -> workspace) = ""b;
	     workspace_ptr -> workspace.component_no = arg_component_no;
	     workspace_ptr -> workspace.request_no = arg_request_no;
	     workspace_ptr -> workspace.n_queued_requests = table_ptr -> tape_archive_table.n_queued_requests;
	     workspace_ptr -> workspace.dead_records = table_ptr -> tape_archive_table.dead_records;
	     workspace_ptr -> workspace.total_records = table_ptr -> tape_archive_table.total_records;
	     workspace_ptr -> workspace.n_components = table_ptr -> tape_archive_table.n_components;
	     workspace_ptr -> workspace.n_request_slots = table_ptr -> tape_archive_table.n_request_slots;
	     workspace_ptr -> workspace.next_mount_type = table_ptr -> tape_archive_table.next_mount_type;
	     unspec (workspace_ptr -> workspace.tape_info_copy) = unspec (table_ptr -> tape_archive_table.tape_info);
	     if arg_component_no ^= 0 then
		unspec (workspace_ptr -> workspace.component_copy)
		= unspec (table_ptr -> tape_archive_table.component_table (arg_component_no));
	     if arg_request_no ^= 0 then
		unspec (workspace_ptr -> workspace.request_copy)
		= unspec (table_ptr -> tape_archive_table.request_queue (arg_request_no));
	     workspace_ptr -> workspace.workspace_id = Magic_workspace_constant;

	     table_ptr -> tape_archive_table.recovery_info_offset = rel (workspace_ptr);
	     return;

	end setup_workspace;

/* ------------------------------------------------------------ */
%page;
complete_table_op: entry (table_ptr);

	call complete_table_op (table_ptr);
	return;

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

complete_table_op: proc (table_ptr);

/* This entry contracts to perform table updates of multiple, interdependent
   values into the table indivisibly.  Once it turns off the bit
   tape_archive_table.table_is_consistent, it is committed to finishing off
   the operation described in the workspace.  Even if a fault, IPS signal, or
   crash occurs in the middle of execution of this module, a future operation
   on this table will see that bit off and will automatically re-attempt to
   commit the values in the workspace back into the table.  Thus the
   operation, while not structly "indivisible", is at least guaranteed of
   consummation. */

dcl  table_ptr pointer parameter;

dcl  i fixed bin,
    (request_ptr, component_ptr, workspace_ptr) pointer;

/* First, a couple of "gullibility checks". */

	     if table_ptr -> tape_archive_table.recovery_info_offset = ""b then do;
		call sub_err_ (error_table_$bad_segment, "tape_archive", "c", null, 0,
		     "Table workspace missing-- please notify system maintenance.");
		return;
	     end;

	     workspace_ptr = pointer (table_ptr, table_ptr -> tape_archive_table.recovery_info_offset);
	     if workspace_ptr -> workspace.workspace_id ^= Magic_workspace_constant then do;
		call sub_err_ (error_table_$bad_segment, "tape_archive", "c", null, 0,
		     "Table workspace has been damaged-- please notify system maintenance.");
		return;
	     end;

	     if workspace_ptr -> workspace.component_no ^= 0 then
		component_ptr =
		addr (table_ptr -> tape_archive_table.component_table (workspace_ptr -> workspace.component_no));
	     else component_ptr = null;
	     if workspace_ptr -> workspace.request_no ^= 0 then
		request_ptr =
		addr (table_ptr -> tape_archive_table.request_queue (workspace_ptr -> workspace.request_no));
	     else request_ptr = null;

/* The order of the setting of the consistent bit, clearing of the workspace,
   etc., is highly important to ensure repeatability without interference. */

	     table_ptr -> tape_archive_table.table_is_consistent = ""b;

	     table_ptr -> tape_archive_table.n_queued_requests = workspace_ptr -> workspace.n_queued_requests;
	     table_ptr -> tape_archive_table.dead_records = workspace_ptr -> workspace.dead_records;
	     table_ptr -> tape_archive_table.total_records = workspace_ptr -> workspace.total_records;
	     table_ptr -> tape_archive_table.n_components = workspace_ptr -> workspace.n_components;
	     table_ptr -> tape_archive_table.n_request_slots = workspace_ptr -> workspace.n_request_slots;
	     table_ptr -> tape_archive_table.next_mount_type = workspace_ptr -> workspace.next_mount_type;
	     unspec (table_ptr -> tape_archive_table.tape_info) = unspec (workspace_ptr -> workspace.tape_info_copy);
	     if workspace_ptr -> workspace.component_no ^= 0 then
		unspec (component_ptr -> component) = unspec (workspace_ptr -> workspace.component_copy);
	     if workspace_ptr -> workspace.request_no ^= 0 then
		unspec (request_ptr -> request) = unspec (workspace_ptr -> workspace.request_copy);

/* See if we can truncate unused request queue entries. */

	     if workspace_ptr -> workspace.request_copy.valid = ""b then
		if workspace_ptr -> workspace.request_no >= table_ptr -> tape_archive_table.n_request_slots then do;
		     do i = workspace_ptr -> workspace.request_no - 1 to 1 by -1
			     while (table_ptr -> request_queue (i).valid = ""b);
			unspec (table_ptr -> request_queue (i)) = ""b;
		     end;

		     if i ^< 0 then
			table_ptr -> tape_archive_table.n_request_slots = i;
		end;

/* All is copied.  Shut off the "must salvage" indicator */

	     table_ptr -> tape_archive_table.table_is_consistent = "1"b;

/* Wipe out the workspace.  The order of these lines is significant in terms
   of the cleanup we can do later if we happen to be interrupted here. */

	     call hcs_$truncate_seg
		(table_ptr, currentsize (table_ptr -> tape_archive_table),
		0);
	     table_ptr -> tape_archive_table.recovery_info_offset = ""b;

	     call hcs_$set_bc_seg (table_ptr, length (unspec (table_ptr -> tape_archive_table)), 0);
	     return;
	end complete_table_op;

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

     end ta_table_mgr_;
   



		    ta_upgrade_version_.pl1         02/16/84  1307.2r w 02/16/84  1249.5       52110


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

ta_upgrade_version_: proc (table_dir, table_name, table_ptr, w_permit, code);

/* This subroutine is used to upgrade a tape_archive table to a new version.
   It is called only from ta_table_mgr_.

   Written 04/11/79 by C. D. Tavares.
   Modified 09/03/80 by CDT for version 3.
   Last modified 83-03-16 by S. G. Harris (UNCA) for version 4.
   Modified 6/83 by S. Krupp for conversion to mtape_.
*/

/* Parameter */

dcl (table_dir char (*),
     table_name char (*),
     w_permit bit (1) aligned,
     code fixed bin (35)) parameter;

/* Automatic */

dcl i fixed bin;
dcl  reason char (256) varying;

/* Based */


/* Entries */

dcl (ioa_, ioa_$rsnnl, com_err_) ext entry options (variable),
     hcs_$set_bc_seg ext entry (pointer, fixed bin (24), fixed bin (35)),
     hcs_$set_safety_sw_seg ext entry (pointer, bit (1) aligned, fixed bin (35));

/* Static */

dcl (error_table_$unimplemented_version,
     error_table_$insufficient_access) ext fixed bin (35) static;

/* Builtin */

dcl (addr, dim, size, unspec) builtin;

%include tape_archive_table_dcl;


/* First check to see that the version number makes any sense at all. */

	if tape_archive_table.version_number > 4 | tape_archive_table.version_number < 1
	then do;
	     code = error_table_$unimplemented_version;
	     call ioa_$rsnnl ("Version ^d is not a defined version.", reason, 0, tape_archive_table.version_number);
	     goto err;
	end;

/* Now we know that the operation we are about to perform makes sense.
   Now see if we can perform it. */

	if ^w_permit
	then do;
	     code = error_table_$insufficient_access;
	     call ioa_$rsnnl ("^/^-^a>^a is an obsolete version and must be upgraded before it may be used.",
		reason, 0, table_dir, table_name);
	     goto err;
	end;


/* Now we perform the upgrade, step by step */


/* Upgrade for version 2 */
/* Version 2 extended the volume_id field from 6 chars. */

          if tape_archive_table.version_number < 2 then begin;

dcl 1 tape_archive_table_v1 aligned based (table_ptr),
    2 nonvolatile_part aligned,
      3 version_number fixed bin,
      3 magic_constant char (8),
      3 compaction_warning_threshold float bin,
      3 auto_compaction_threshold float bin,
      3 table_is_consistent bit (1) unaligned,
      3 lock bit (36),
      3 lock_reason fixed bin,
      3 locker_id char (32),
      3 io_module_name char (32),
      3 future_expansion (8) bit (36),
    2 volatile_part aligned,
      3 n_components fixed bin,
      3 n_component_slots fixed bin,
      3 n_queued_requests fixed bin,
      3 n_request_slots fixed bin,
      3 next_mount_type fixed bin,
      3 date_time_tape_modified bit (36),
      3 date_time_last_compacted bit (36),
      3 total_records fixed bin (35),
      3 dead_records fixed bin (35),
      3 incomplete_write_op_last bit (1),
      3 last_tape_file_no fixed bin,
      3 last_table_no fixed bin,
      3 future_expansion (9) bit (36),
      3 tape_info aligned,
        4 active_set fixed bin,
        4 n_volumes_in_set (2) fixed bin,
        4 volume_set (2) aligned,
	5 volume_id (8) char (6),
      3 component_table (0 refer (tape_archive_table.n_component_slots)) aligned like component,
      3 request_queue (0 refer (tape_archive_table.n_request_slots)) aligned like request;

dcl (i, j) fixed bin;

               do i = tape_archive_table.n_request_slots to 1 by -1;
                    unspec (tape_archive_table.request_queue (i)) = unspec (tape_archive_table_v1.request_queue (i));
               end;

	     do i = tape_archive_table.n_component_slots to 1 by -1;
		unspec (tape_archive_table.component_table (i)) = unspec (tape_archive_table_v1.component_table (i));
	     end;

	     do i = 2 to 1 by -1;
		do j = dim (tape_archive_table_v1.volume_id, 2) to 1 by -1;
		     tape_archive_table.volume_id (i, j) = tape_archive_table_v1.volume_id (i, j);
		end;
	     end;

	     tape_archive_table.version_number = 2;

	     call hcs_$set_bc_seg (table_ptr, size (tape_archive_table) * 36, 0);

	end;


/* Upgrade for version 3. */
/* Version 3 introduced density field */

	if tape_archive_table.version_number < 3 then do;
	     tape_archive_table.tape_info.density (*) = Default_density;
	     tape_archive_table.version_number = 3;
	end;


/* Upgrade for version 4. */

          if tape_archive_table.version_number < 4
          then do;
               tape_archive_table.tape_info.density(1) = tape_archive_table.tape_info.density(2);
               tape_archive_table.version_number = 4;
               call hcs_$set_safety_sw_seg(table_ptr, "1"b, code);
          end;


/* No more versions to upgrade, return. */

	call ioa_ ("tape_archive:  ^a>^a upgraded to version ^d.",
	     table_dir, table_name, tape_archive_table.version_number);

	code = 0;
	return;
%skip(5);
err:	call com_err_ (code, "tape_archive", reason);
	return;
     end ta_upgrade_version_;
  



		    ta_util_.pl1                    02/16/84  1307.2r w 02/16/84  1249.5       18342


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


ta_util_: proc; return;

/* This module handles random utility functions for tape_archive.

   Written 06/29/77 by C. D. Tavares.
   Last modified 09/24/79 by CDT to make it understand ".." and ".".
*/

%skip(5);
get_next_token: entry (input_line) returns (char (168));

dcl  input_line char (*) parameter;

dcl  output_token char (168) varying,
     i fixed bin;

dcl (search, index, ltrim, length, substr) builtin;

dcl  TAB_SP char (2) static options (constant) initial ("	 ");

	output_token = "";

	input_line = ltrim (input_line, TAB_SP);

	if substr (input_line, 1, 1) = """" then do;
	     do while (substr (input_line, 1, 1) = """");
		i = index (substr (input_line, 2), """") + 1;
		if i = 0 then i = length (input_line);
		output_token = output_token || substr (input_line, 2, i-1);
		if i = length (input_line) then input_line = "";
		else input_line = substr (input_line, i+1);
	     end;

	     return (substr (output_token, 1, length (output_token) - 1));
	end;

	if substr (input_line, 1, 1) = "." then do;
	     if substr (input_line, 1, 2) = ".." then do;
		input_line = substr (input_line, 3);
		return ("..");
	     end;

	     else do;				/* single dot */
		output_token = input_line;
		input_line = "";
		return (output_token);
	     end;
	end;

	i = search (input_line, TAB_SP) - 1;
	if i = -1 then i = length (input_line);
	output_token = substr (input_line, 1, i);
	if i = length (input_line) then input_line = "";
	else input_line = substr (input_line, i+1);

	return (output_token);
     end ta_util_;
  



		    tape_archive.pl1                02/16/84  1307.2r w 02/16/84  1249.5      195372


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

tape_archive: ta: proc;

/* This procedure is the main command interface for the tape_archive command.
   The tape_archive command gives a user the facility of keeping a set of
   files on magnetic tape for archival or file transfer purposes, and provides
   an easy interface for extracting, rewriting, deleting, and keeping track
   of these files.

   Written 05/10/77 by C. D. Tavares.
   Modified 09/24/79 by CDT for "." and ".." in direct mode.
   Modified 09/03/80 by CDT for version 3; also to improve output of "."
   request.
   Modified 09/16/80 by CDT to fix error message when no access to table.
   Last modified 83-03-16 by S. G. Harris (UNCA) for version 4.
   Modified 7/83 by S. Krupp for conversion to mtape_
*/

/* INCLUDE FILES */

%include tape_archive_table_dcl;
%page;
%include query_info_;
%page;
%include object_info;
%page;
/* AUTOMATIC */

dcl  al fixed bin,
     alp pointer,
     answer char (4) varying,
     ap pointer,
     arg char (al) based (ap),
     code fixed bin (35),
     delete bit (1) aligned,
     dummy fixed bin,
     dummy_args (100) char (168),
     dummy_args_based (n_dummy_args) char (168) based (addr (dummy_args)),
     me_bc fixed bin (24),
     me_ptr pointer,
     my_date_time char (24),
     n_dummy_args fixed bin,
     force bit (1) aligned,
     i fixed bin,
     input_line char (300),
     key char (12),
     keynum fixed bin,
     library_description char (168),
     n_chars_read fixed bin (21),
     nargs fixed bin,
     p pointer,
     perm_table_ptr pointer,
     prog_dir char (168),
     prog_ent char (32),
     requests_outstanding bit (1) aligned,
     retain_sw bit (1) aligned,
     table_dir char (168),
     table_name char (32),
     temp_table_ptr (1) pointer,
     w_permit bit (1) aligned;

dcl 1 oi aligned automatic like object_info;

/* CONSTANTS */

dcl 1 key_structure aligned static options (constant),
    2 key_names (23) char (12) initial
    ("a", "ad", "adf",				/* 1, 2, 3 */
     "r", "rd", "rdf",				/* 4, 5, 6 */
     "u", "ud", "udf",				/* 7, 8, 9 */
     "x", "xd", "xdf", "xf",				/* 10, 11, 12, 13 */
     "d", "df",					/* 14, 15 */
     "cancel",					/* 16 */
     "t",						/* 17 */
     "compact",					/* 18 */
     "alter",					/* 19 */
     "go",					/* 20 */
     "load_table",					/* 21 */
     "reconstruct",					/* 22 */
     "direct"),					/* 23 */
    2 delete bit (23) initial ("011011011011"b),
    2 force bit (23) initial ("001001001001101"b),
    2 table_must_exist bit (23) initial ("00000011111111111111000"b),
    2 w_permit_needed bit (23) initial ("11111111111111110111001"b);

dcl  allowed_in_input_mode fixed bin static initial (19) options (constant),
     explanation char (168) static initial ("Usage:  ta key table_path filepath1... filepathN.") options (constant);

dcl 1 search_libraries (2) static options (constant),
    2 dir char (168) initial (">sss", ">exl>tape_archive_dir"),
    2 description char (64) initial ("Installed", "Experimental");

/* EXTERNAL STATIC */

dcl (error_table_$badopt,
     error_table_$moderr,
     error_table_$noentry,
     error_table_$long_record) ext fixed bin (35) static,
     iox_$user_input ext pointer static;

/* ENTRIES */

dcl  com_err_ ext entry options (variable),
     com_err_$suppress_name ext entry options (variable),
     command_query_ ext entry options (variable),
     cu_$arg_count ext entry (fixed bin),
     cu_$arg_list_ptr ext entry (pointer),
     cu_$arg_ptr ext entry (fixed bin, pointer, fixed bin, fixed bin (35)),
     cu_$arg_ptr_rel ext entry (fixed bin, pointer, fixed bin, fixed bin (35), pointer),
     cu_$cp ext entry (pointer, fixed bin, fixed bin (35)),
     date_time_ entry (fixed bin (71), char (*)),
     expand_pathname_ ext entry (char (*), char (*), char (*), fixed bin (35)),
     get_temp_segments_ ext entry (char (*), pointer dimension (*), fixed bin (35)),
     hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
     hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)),
     hcs_$terminate_noname ext entry (pointer, fixed bin (35)),
     ioa_ ext entry options (variable),
     iox_$get_line ext entry (pointer, pointer, fixed bin (21), fixed bin (21), fixed bin (35)),
     object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35)),
     release_temp_segments_ ext entry (char (*), pointer dimension (*), fixed bin (35)),
     sub_err_ ext entry options (variable),
     suffixed_name_$make ext entry (char (*), char (*), char (32), fixed bin (35));

dcl  ta_delete_ ext entry (pointer, char (168) dimension (*), bit (1) aligned, char (*), fixed bin (35)),
     ta_extract_ ext entry (pointer, char (168) dimension (*), bit (1) aligned, bit (1) aligned, char (*), fixed bin (35)),
     ta_list_table_ ext entry (pointer, char (168) dimension (*), char (*), fixed bin (35)),
     ta_load_table_ ext entry (pointer, char (168) dimension (*), char (*), fixed bin (35)),
     ta_process_volume_set_$no_lock ext entry (pointer, char (168) dimension (*), char (*), fixed bin (35)),
     ta_process_volume_set_ ext entry (pointer, char (168) dimension (*), char (*), fixed bin (35)),
     ta_process_volume_set_$dismount ext entry (pointer, bit (1) aligned, fixed bin (35)),
     ta_reconstruct_table_ ext entry (pointer, char (168) dimension (*), char (*), fixed bin (35)),
     ta_replace_ ext entry (pointer, char (168) dimension (*), bit (1) aligned, bit (1) aligned, char (*), fixed bin (35)),
     ta_replace_$append ext entry (pointer, char (168) dimension (*), bit (1) aligned, bit (1) aligned, char (*), fixed bin (35)),
     ta_replace_$update ext entry (pointer, char (168) dimension (*), bit (1) aligned, bit (1) aligned, char (*), fixed bin (35)),
     ta_table_mgr_$alter_attributes ext entry (pointer, char (168) dimension (*), char (*), fixed bin (35)),
     ta_table_mgr_$check_compaction ext entry (pointer, char (*), fixed bin (35)),
     ta_table_mgr_$copy_to_perm ext entry (pointer, pointer, fixed bin (35)),
     ta_table_mgr_$copy_to_temp ext entry (pointer, pointer, fixed bin(35)),
     ta_table_mgr_$create_table ext entry (char (*), char (*), pointer, fixed bin (35)),
     ta_table_mgr_$find_and_verify ext entry (char (*), char (*), pointer, bit (1) aligned, fixed bin (35)),
     ta_table_mgr_$cancel_component ext entry (pointer, char (168) dimension (*), char (*), fixed bin (35)),
     ta_table_mgr_$lock ext entry (pointer, char(*), fixed bin, fixed bin(35)),
     ta_table_mgr_$unlock ext entry (pointer, fixed bin (35)),
     ta_util_$get_next_token ext entry (char (*)) returns (char (168));

/* BUILTINS */

dcl (addr, baseno, baseptr, codeptr, dim, length, null, substr) builtin;

/* CONDITIONS */

dcl (cleanup, program_interrupt) condition;

	table_ptr = null;				/* initialize state of the world */
	query_info.version = query_info_version_5;

	call cu_$arg_ptr (1, ap, al, code);		/* get key */
	if code ^= 0 then do;
print_usage:   call com_err_ (code, "tape_archive", explanation);
	     return;
	end;

	key = arg;

	call cu_$arg_ptr (2, ap, al, code);		/* get table name */
	if code ^= 0 then goto print_usage;

	call expand_pathname_ (arg, table_dir, table_name, code);
	if code ^= 0 then goto print_usage;

	call suffixed_name_$make ((table_name), "ta", table_name, code); /* force the "ta" suffix */
	if code ^= 0 then do;
	     call com_err_ (code, "tape_archive", "^a.ta", table_name);
	     return;
	end;

	do keynum = 1 to dim (key_names, 1) while (key_names (keynum) ^= key);
	end;					/* search to see if key is a known key */

	if keynum > dim (key_names, 1) then do;		/* no, it wasn't */
	     call com_err_ (0, "tape_archive", "^a not a valid key.", key);
	     return;
	end;

	call ta_table_mgr_$find_and_verify (table_dir, table_name, table_ptr, w_permit, code);
						/* find the table if it exists */
	if code ^= 0 then				/* some error */
	     if table_ptr = null then
		if code = error_table_$noentry then;	/* can't find table, but this may not matter */
		else do;				/* some other reason for null ptr */
		     call com_err_ (code, "tape_archive", "^a>^a", table_dir, table_name);
		     return;
		end;
	     else do;				/* bad code but good pointer */
		call hcs_$terminate_noname (table_ptr, code);
		return;				/* error message already printed */
	     end;

	if substr (w_permit_needed, keynum, 1) = "1"b then
	     if ^w_permit then do;			/* doesn't have w access to table and needs it */
		call com_err_ (error_table_$moderr, "tape_archive", "^a>^a", table_dir, table_name);
		call hcs_$terminate_noname (table_ptr, code);
		return;
	     end;
%skip(5);

/* INTERACTIVE MODE SECTION */

	if key = "direct" then do;

	     call cu_$arg_count (nargs);		/* are there any more arguments? */

	     retain_sw = ""b;			/* default is to dismount tapes when done */

	     do i = 3 to nargs;			/* process the extra args */
		call cu_$arg_ptr (i, ap, al, code);	/* get one arg */
		if arg = "-retain" then do;
		     i = i + 1;			/* see if next arg */
		     call cu_$arg_ptr (i, ap, al, code);
		     if i > nargs then retain_sw = "1"b; /* no next arg, but what the heck, give it to him */
		     else if arg = "all" then retain_sw = "1"b;
		end;
		if retain_sw = ""b then do;		/* we didn't recognize something */
		     call com_err_ (error_table_$badopt, "tape_archive", arg);
		     call hcs_$terminate_noname (table_ptr, code);
		     return;
		end;
	     end;

	     if table_ptr = null then do;		/* we have to create a new table */
		call ta_table_mgr_$create_table (table_dir, table_name, table_ptr, code);
		if code ^= 0 then do;		/* oops */
		     call com_err_ (code, "tape_archive", "Creating ^a>^a.", table_dir, table_name);
		     return;
		end;
	     end;

	     temp_table_ptr (1) = null;
	     perm_table_ptr = table_ptr;		/* get set to copy table */

	     on cleanup call cleanerup;

cleanerup:     proc;

		if temp_table_ptr (1) ^= null then
		     call release_temp_segments_ ("tape_archive", temp_table_ptr, 0);
		if perm_table_ptr ^= null then do;
		     call ta_process_volume_set_$dismount (perm_table_ptr, retain_sw, code);
		     call ta_table_mgr_$unlock (perm_table_ptr, code);
		     call hcs_$terminate_noname (perm_table_ptr, 0);
		end;
		retain_sw = ""b;
		perm_table_ptr, table_ptr = null;
	     end cleanerup;

	     call ta_table_mgr_$lock(perm_table_ptr, table_name, Modify, code);
	     if code ^= 0
	     then do;
	          call cleanerup();
		return;
	     end;

	     do dummy = 1, 1 by 1 while (retain_sw);	/* This is a wierd way to get "trailing test" loop */

		call get_temp_segments_ ("tape_archive", temp_table_ptr, code); /* create libensraum */
		if code ^= 0 then do;
		     call com_err_ (code, "tape_archive", "Could not get temp segment.");
		     return;
		end;

		call ta_table_mgr_$copy_to_temp(perm_table_ptr, temp_table_ptr (1), code);
						/* make a copy of the table to fiddle with */
		if code ^= 0 then do;
		     call cleanerup;
		     return;
		end;

		table_ptr = temp_table_ptr (1);	/* remember to use the copy */

		requests_outstanding = ""b;		/* no diffs between perm and temp table yet */

		on program_interrupt goto pi_label;

pi_label:		key = "";

		call ioa_ ("Input.");

		do while (key ^= "go");		/* process requests one by one */

		     code = 1;
		     do while (code ^= 0);		/* get an input line */
			call iox_$get_line (iox_$user_input, addr (input_line), length (input_line),
			     n_chars_read, code);
			if code ^= 0 then
			     if code = error_table_$long_record then
				call com_err_ (code, "tape_archive",
				"Max input line length = ^d chars; line discarded.",
				length (input_line));
			     else do;		/* uglies */
				call com_err_ (code, "tape_archive", "While reading from user_input.");
				call cleanerup;	/* take no chances */
				return;
			     end;

			else if n_chars_read = 1 then /* blank line */
			     code = 1;
		     end;

		     substr (input_line, n_chars_read) = ""; /* kill from the newline out */
		     key = ta_util_$get_next_token (input_line);

		     do keynum = 1 to allowed_in_input_mode while (key ^= key_names (keynum));
		     end;				/* search known keys to see if key is valid */

		     if keynum > allowed_in_input_mode then do; /* not clearly valid */

			if key = "save" then do;	/* This one is ok */
			     call ta_table_mgr_$copy_to_perm(table_ptr, perm_table_ptr, code);
						/* replace perm table with temp table */
			     if code ^= 0 then call sub_err_ (code, "tape_archive", "s", null, 0,
				"Cannot save table, cannot recover.");
			     call ta_table_mgr_$copy_to_temp(perm_table_ptr, temp_table_ptr (1), code);   /* now whip it back to continue */
			     if code ^= 0 then do;
				call com_err_ (code, "tape_archive",
				     "Requests have been saved, but processing cannot continue.");
				call cleanerup;	/* could be worse. */
				return;
			     end;
			     requests_outstanding = ""b; /* back to ground zero again */
			end;

			else if key = "go" then do;	/* spin tapes */
			     dummy_args (1) = "-retain";
			     if retain_sw then
				dummy_args (2) = "all";
			     else dummy_args (2) = "none";

			     do n_dummy_args = 3 to dim (dummy_args, 1) while (input_line ^= "");
				dummy_args (n_dummy_args) = ta_util_$get_next_token (input_line);
			     end;

			     n_dummy_args = n_dummy_args - 1;

			     if input_line ^= "" then do;
				call com_err_ (0, "tape_archive", "Max number of args allowed = ^d; line discarded.",
				     dim (dummy_args, 1) - 2);
				key = "not go";
			     end;

			     else do;
				call ta_table_mgr_$copy_to_perm(table_ptr, perm_table_ptr, code);
						/* first make the requests permanent */
				table_ptr = perm_table_ptr;

				call release_temp_segments_ ("tape_archive", temp_table_ptr, 0);
				temp_table_ptr = null; /* lead us not into temptation */

				call ta_process_volume_set_$no_lock(table_ptr, dummy_args_based, table_name, code); /* roll 'em */
				requests_outstanding = ""b;
			     end;
			end;

			else if key = "quit" | key = "q" then do;

			     if ^requests_outstanding then answer = "yes"; /* we're clean */

			     else do;		/* unsaved requests exist */
				query_info.yes_or_no_sw = "1"b; /* must answer yes or no */
				call command_query_ (addr (query_info), answer, "tape_archive",
				     "Unsaved requests may be lost if you quit now.^/^-Do you still wish to quit?");
			     end;

			     if answer = "yes" then do;
				call ta_table_mgr_$unlock (perm_table_ptr, code); /* unlock the perm table */
				if code ^= 0 then call sub_err_ (code, "tape_archive", "s", null, 0,
				     "Cannot unlock table, cannot recover.");
				call cleanerup;
				return;
			     end;
			end;

			else if key = ".." then
			     call cu_$cp (addr (input_line), length (input_line), 0);

			else if key = "." then do;
here_label:		     me_ptr = baseptr (baseno (codeptr (here_label)));
						/* get pointer to base of my own segment */

			     library_description = "";

			     do i = 1 to dim (search_libraries, 1) while (library_description = "");
				call hcs_$initiate (search_libraries (i).dir, "tape_archive", "", 0, 0, p, code);
				if p ^= null then do;
				     if p = me_ptr then library_description = search_libraries.description (i);
				     call hcs_$terminate_noname (p, 0);
				end;
			     end;

			     if library_description = "" then do;
				call hcs_$fs_get_path_name (me_ptr, prog_dir, 0, prog_ent, code);
				if code ^= 0 then
				     call com_err_ (code, "tape_archive",
				     "Determining pathname of this version of tape_archive.");

				else call ioa_ ("tape_archive version ^d; ^a>^a (private version)",
				     tape_archive_version_4, prog_dir, prog_ent);
			     end;

			     else do;
				oi.version_number = object_info_version_2;

				call hcs_$status_mins (me_ptr, 0, me_bc, code);
				if code = 0 then
				     call object_info_$display (me_ptr, me_bc, addr (oi), code);
				if code ^= 0 then
				     call com_err_ (code, "tape_archive",
				     "Determining version of tape_archive.");

				else do;
				     call date_time_ (oi.compile_time, my_date_time);

				     call ioa_ ("tape_archive; ^a version ^d of ^a.", library_description,
					tape_archive_version_4, my_date_time);
				end;
			     end;
			end;

			else call com_err_$suppress_name (0, "tape_archive", "Not a recognized request:  ^a", key);
		     end;

		     else do;			/* process the good key */

			do i = 1 to dim (dummy_args, 1) while (input_line ^= "");
			     dummy_args (i) = ta_util_$get_next_token (input_line);
						/* split input line into "arguments" */
			end;

			if input_line ^= "" then call com_err_ (0, "tape_archive",
			     "Max number of args allowed = ^d;  line discarded.", dim (dummy_args, 1));

			else do;
			     call process_command_line (i-1, null, dummy_args, code);
			     if code = 0 then requests_outstanding = "1"b;
						/* This errs on the side of safety, because some
						   subroutines don't return nonzero codes for errors */
			end;
		     end;
		end;
	     end;
	end;
%skip(5);

/* ONE-SHOT INVOCATION MODE SECTION */

	else do;
	     call cu_$arg_count (nargs);		/* get extra args */
	     call cu_$arg_list_ptr (alp);
	     call process_command_line (nargs-2, alp, dummy_args, code); /* send 'em on in */
	end;

	if table_ptr ^= null then call hcs_$terminate_noname (table_ptr, code);
	return;

process_command_line: proc (nargs, alp, passed_args, code);

/* This internal subroutine dispatches commands and arguments to the proper subroutine to
   handle that particular key. */

dcl  nargs fixed bin parameter,
     alp pointer parameter,
     passed_args char (168) dimension (*) parameter,
     code fixed bin (35) parameter;

dcl  rest_of_args (nargs) char (168);

	     if alp = null then			/* args are passed in passed_args */
		do i = 1 to nargs;
		rest_of_args (i) = passed_args (i);
	     end;

	     else					/* args are in the arglist at alp */
	     do i = 1 to nargs;
		call cu_$arg_ptr_rel (i+2, ap, al, code, alp);
		rest_of_args (i) = arg;
	     end;

	     if table_ptr = null then			/* no table, should we create? */
		if substr (key_structure.table_must_exist, keynum, 1) then do; /* no, we should complain */
		     call com_err_ (error_table_$noentry, "tape_archive",
			"^a must already exist to process the ""^a"" request.", table_name, key);
		     return;
		end;

		else do;				/* ok to create table, so do it */
		     call ta_table_mgr_$create_table (table_dir, table_name, table_ptr, code);
		     if code ^= 0 then return;	/* it has already complained */
		end;

	     delete = substr (key_structure.delete, keynum, 1);
	     force = substr (key_structure.force, keynum, 1);

	     goto act_on_key (keynum);

act_on_key (1): act_on_key (2): act_on_key (3):		/* a, ad, adf */
	     call ta_replace_$append (table_ptr, rest_of_args, delete, force, table_name, code);
	     goto act_on_key_end;

act_on_key (4): act_on_key (5): act_on_key (6):		/* r, rd, rdf */
	     call ta_replace_ (table_ptr, rest_of_args, delete, force, table_name, code);
	     goto act_on_key_end;

act_on_key (7): act_on_key (8): act_on_key (9):		/* u, ud, udf */
	     call ta_replace_$update (table_ptr, rest_of_args, delete, force, table_name, code);
	     goto act_on_key_end;
						
act_on_key (10): act_on_key (11): act_on_key (12): act_on_key (13):	/* x, xd, xdf, xf */
               call ta_extract_ (table_ptr, rest_of_args, delete, force, table_name, code);
	     goto act_on_key_end;

act_on_key (14): act_on_key (15):			/* d, df */
	     call ta_delete_ (table_ptr, rest_of_args, force, table_name, code);
	     goto act_on_key_end;

act_on_key (16):					/* cancel */
	     call ta_table_mgr_$cancel_component (table_ptr, rest_of_args, table_name, code);
	     goto act_on_key_end;

act_on_key (17):					/* t */
	     call ta_list_table_ (table_ptr, rest_of_args, table_name, code);
	     return;

act_on_key (18):					/* compact */
	     tape_archive_table.next_mount_type = Compact;
	     return;

act_on_key (19):					/* alter */
	     call ta_table_mgr_$alter_attributes (table_ptr, rest_of_args, table_name, code);
	     return;

act_on_key (20):					/* go */
	     call ta_process_volume_set_ (table_ptr, rest_of_args, table_name, code);
	     return;

act_on_key (21):					/* load_table */
	     call ta_load_table_ (table_ptr, rest_of_args, table_name, code);
	     return;

act_on_key (22):					/* reconstruct */
	     call ta_reconstruct_table_ (table_ptr, rest_of_args, table_name, code);
	     return;


act_on_key_end:
	     call ta_table_mgr_$check_compaction (table_ptr, table_name, code);
						/* see if this request deserves an auto compaction or warning */
	     return;

	end process_command_line;

     end tape_archive;


		    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