



		    ta_delete_.pl1                  01/03/84  1349.8rew 01/03/84  1315.4       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                 01/03/84  1349.8rew 01/03/84  1315.4       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                 01/03/84  1349.8rew 01/03/84  1315.1      196137



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

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

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


/* 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_atd 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),
     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  iox_$attach_ptr ext entry (pointer, char (*), pointer, fixed bin (35)),
     iox_$close ext entry (pointer, fixed bin (35)),
     iox_$detach_iocb ext entry (pointer, fixed bin (35)),
     iox_$get_line ext entry (pointer, pointer, fixed bin (21), fixed bin (21), fixed bin (35)),
     iox_$open ext entry (pointer, fixed bin, bit (1) aligned, fixed bin (35)),
     iox_$read_record ext entry (pointer, pointer, fixed bin (21), fixed bin (21), fixed bin (35)),
     iox_$put_chars ext entry (pointer, pointer, fixed bin (21), fixed bin (35)),
     iox_$write_record ext entry (pointer, pointer, fixed bin (21), 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_$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;
%include tape_archive_attributes;
%include create_branch_info;
%include iox_modes;

/* BUILTINS */

dcl (addr, binary, collate, divide, length, max, 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 = (output_atd_template ^= "");
	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));
	request_ptr = addr (request_queue (component.associated_request_index));
	if extracting then				/* Don't copy it if it's going to be deleted */
	     if request.delete then compacting = "0"b;
	cancel_deletion = "0"b;
	max_chars_in_seg = sys_info$max_seg_size * 4;
	temp_file_no = tape_archive_table.last_tape_file_no;

	dirname = "";
	ename = component.entry_name;

/* We close the switches upon arrival and leave them open on departure.  Seems
   sloppy,  but  we  can  dismount the tapes more easily if we leave them open
   when  we  are  done.   Also, the -retain option fits right into this way of
   doing things.  */

	if compacting then call close_switch (tape_output_switch);
	call close_switch (tape_input_switch);

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

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

	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);

	call iox_$attach_ptr (tape_input_switch, input_atd, null, code);
	if code ^= 0 then return;

	on cleanup call abort_silent;

	call iox_$open (tape_input_switch, Sequential_input, ""b, code);
	if code ^= 0 then 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_atd_template, input_atd, 0,
	     component.tape_file_name, component.attribute_file_no + 1,
	     component.recording_mode);

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

	call iox_$open (tape_input_switch, Sequential_input, ""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;

	dirname = request.directory_name;

	if extracting then do;			/* we may be just compacting;
						   otherwise, check for namedups, noaccess, etc. */
	     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;
		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);
	else call close_switch (file_output_switch);

/* 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_atd_template ^= "" then do;	/* if compacting, try to recover component */
		     cancel_deletion = "1"b;
		     compacting = "1"b;
		     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 */

dcl  clock_ ext entry returns (bit (72) aligned);

	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;

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

	call close_switch (tape_input_switch);		/* if extract was last operation we must clean up input side */
	call close_switch (tape_output_switch);		/* see entry above for explanation */

/* 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 (clock_ (), 21, 36); /* standard file system time */
	request.no_final_newline = ""b;

	on cleanup call abort_silent;

/* 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;
	     call msf_manager_$close (msf_fcb_ptr);
	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;

	     call close_switch (file_input_switch);
	end;

	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;

	call close_switch (tape_output_switch);

	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);

	return;

dismount:	entry (table_ptr, switch_ptr, retain_sw, code);

/* This entry dismounts and detaches a tape */

dcl  switch_ptr pointer parameter,
     retain_sw bit (1) aligned parameter;

dcl  iox_$control ext entry (pointer, char (*), pointer, fixed bin (35));

	call iox_$close (switch_ptr, code);

	if ^retain_sw then call iox_$control (switch_ptr, "retain_none", null, code);

	call iox_$detach_iocb (switch_ptr, code);
	return;

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_atd_template, output_atd, 0,
		file_name, file_no, (file_no = 1), mode);

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

	     call iox_$open (tape_output_switch, Sequential_output, ""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;
		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;

	     call iox_$close (switch_ptr, 0);

	     call iox_$detach_iocb (switch_ptr, 0);

	end close_switch;
%skip(5);
abort_silent: 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;
	end abort_silent;
%skip(5);
abort:	proc options (non_quick);

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

returner:	return;

     end ta_file_io_;




		    ta_list_table_.pl1              01/03/84  1349.8rew 01/03/84  1315.4      141984



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

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,
     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;

	     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;

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

		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.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_ ("^/Tape I/O Module:^15x^a^/Current volume set density:  ^2x^d bpi^/Alternate volume set density:  ^d bpi",
		     tape_archive_table.io_module_name,
		     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_replace_.pl1                 01/03/84  1349.8rew 01/03/84  1315.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               01/03/84  1349.8rew 01/03/84  1315.1      410121



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

%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  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),
     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 (6) char (32) static options (constant) initial
    ("module", "warning_limit", "auto_limit", "compaction", "volume", "density");

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

dcl  known_io_modules (2) char (12) 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);

	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):					/* module */
	     if tape_archive_table.n_component_slots > 0 then
		call alter_err (error_table_$badopt,
		"The tape archive must be empty if the I/O module is to be changed.", "");

	     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"" not a valid I/O module", value_arg);

	     tape_archive_table.io_module_name = value_arg;
	     goto alter_end;

alter (2):					/* 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 (3):					/* 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 (4):					/* 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 (5):					/* 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;

	     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 (6):					/* 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;

	     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);

dcl  temp_table_ptr pointer parameter;

/* 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));


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

	call hcs_$get_uid_seg (table_ptr, tape_archive_table.perm_table_uid, code);	/* update table uid -- load_table, copy, etc. may have changed it */
	if code ^= 0 then tape_archive_table.perm_table_uid = "0"b;	/* shouldn't happen -- but suppress table check */

	overlay_length = currentsize (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;

	return;
%skip(5);
copy_and_unlock: entry (temp_table_ptr, table_ptr, code);

dcl (hcs_$set_ips_mask, hcs_$reset_ips_mask) entry (bit (36) aligned, bit (36) aligned);

dcl  old_mask bit (36) aligned;

	old_mask = ""b;
	on cleanup begin;
	     if old_mask ^= ""b then
		call hcs_$reset_ips_mask ((old_mask), old_mask);
	end;

	overlay_length = divide (length (unspec (temp_table_ptr -> tape_archive_table.volatile_part)) + 35, 36, 18, 0);

	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;

	addr (table_ptr -> tape_archive_table.volatile_part) -> overlay =
	     addr (temp_table_ptr -> tape_archive_table.volatile_part) -> overlay;

	tape_archive_table.table_is_consistent = "1"b;

/* Whew-- made it! */

	call hcs_$set_bc_seg (table_ptr, length (unspec (tape_archive_table)), code);
	call hcs_$truncate_seg (table_ptr, currentsize (tape_archive_table), code);

	call hcs_$reset_ips_mask ((old_mask), old_mask);

	call unlock_table (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;
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,
     temp_ptr pointer;

/* BASED */

dcl  based_temp_ptr (1) pointer based (addr (temp_ptr));

/* 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         01/03/84  1349.8rew 01/03/84  1315.4       53217



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

dcl (table_dir char (*),
     table_name char (*),
     w_permit bit (1) aligned,
     code fixed bin (35)) parameter;

dcl  reason char (256) varying;

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));

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

dcl (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 = tape_archive_version_4 then do;
	     code = error_table_$action_not_performed;
	     call ioa_$rsnnl ("^a>^a is already the proper version and cannot be upgraded.",
		reason, 0, table_dir, table_name);
	     goto err;
	end;

	if tape_archive_table.version_number > tape_archive_version_4
	| tape_archive_table.version_number < 1 then do;
	     code = error_table_$unimplemented_version;
	     call ioa_$rsnnl ("Version ^d 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. */
/* Version 4 made the density field an array. */

	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                    01/03/84  1349.8rew 01/03/84  1315.4       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                01/03/84  1349.8rew 01/03/84  1315.1      193518



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

/* 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),
     table_path char (168),
     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_ 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_and_unlock 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_$lock_and_copy ext entry (pointer, pointer, char (*), fixed bin, fixed bin (35)),
     ta_table_mgr_$cancel_component ext entry (pointer, char (168) dimension (*), char (*), 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 the 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;


	     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_$lock_and_copy (perm_table_ptr, temp_table_ptr (1), table_name, Modify, 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_and_unlock (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_$lock_and_copy (perm_table_ptr, temp_table_ptr (1), table_name,
				Modify, 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_and_unlock (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_table_mgr_$unlock (perm_table_ptr, code);
						/* ta_process_volume_set_ will relock this */

				call ta_process_volume_set_ (table_ptr, dummy_args_based, table_name, code); /* roll 'em */
				requests_outstanding = ""b;
			     end;
			end;

			else if key = "quit" 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;




		    ta_load_table_.pl1              01/03/84  1349.8rew 01/03/84  1315.5      114237



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

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

/* AUTOMATIC */

dcl  answer	        char (256) varying,
     attach_description     char (256),
     attach_template        char (256),
     date_time_string       char (24),
     detach_code	        fixed bin (35),
     density	        fixed bin,
     dname	        char (168),
     ename	        char (32),
     filename	        char (17),
     got_older_table        bit (1),
     i		        fixed bin,
     io_module	        char (32),
     max_chars_in_seg       fixed bin (21),
     n_chars_read	        fixed bin (21),
     nelemt	        fixed bin (21),
     n_table_volids	        fixed bin,
     n_volids	        fixed bin,
     n_words_read	        fixed bin (18),
     retain_sw	        bit (1),
     table_volid	        char (168),
     tape_input_switch      pointer,
     temp_seg_ptrs	        (2) pointer,
     last_good_copy_ptr     pointer,
     ptr_active	        fixed bin,
     volid	        (8) char (32);

%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_file_io_$make_filename
		        entry (ptr, char (13), fixed bin)
		        returns (char (17) aligned),
     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_$short_record,
     error_table_$too_many_args)
		        ext fixed bin (35) static,
     sys_info$max_seg_size  ext fixed bin (35) static;

/* CONSTANTS */

%include iox_modes;

/* CONDITION */

dcl  cleanup	        condition;

/* BUILTINS */

dcl  (dim, null, unspec)    builtin;

/* BASED VARIABLES */

%include tape_archive_table_dcl;

/* BASED */

dcl  based_table	        (n_words_read) bit (36) aligned based;


	got_older_table = "0"b;

	call iox_$find_iocb ("ta_tape_input_", tape_input_switch, code);
	if code ^= 0 then goto end_processing;

	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, "tape_archive",
		     "^a already exists.  Do you wish to overwrite it?? ",
		     table_name);
		if answer = "no" then return;
	     end;

	io_module = tape_archive_table.io_module_name;
	if io_module = "" then io_module = "tape_ansi_";
	n_volids = tape_archive_table.n_volumes_in_set (tape_archive_table.active_set);
	volid (*) = "";
	if n_volids ^= 0
	then volid (*) = tape_archive_table.volume_set (tape_archive_table.active_set).volume_id (*);

	density = tape_archive_table.density (tape_archive_table.active_set);
	if density = 0 then density = Default_density;

	retain_sw = ""b;


	do i = 1 to dim (arg_array, 1);
	     if arg_array (i) = "-io_module"
		| arg_array (i) = "-iom" then do;
		     i = i + 1;
		     if i > dim (arg_array, 1) then do;
			     call com_err_
				(error_table_$noarg, "tape_archive",
				"I/O module name must follow ^a",
				arg_array (i - 1));
			     return;
			end;

(nostrz):		     io_module = arg_array (i);

		     if io_module ^= "tape_ansi_" &
			io_module ^= "tape_ibm_" then do;
			     call com_err_
				(error_table_$bad_arg, "tape_archive",
				"I/O module ^a not supported.",
				io_module);
			     return;
			end;
		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, "tape_archive",
				"^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, "tape_archive", "-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, "tape_archive",
			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,
				"tape_archive",
				"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, "tape_archive",
		     "Enter volume name of first volume: ");

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

	do i = 1 to n_volids;
	     call resource_info_$canonicalize_name
		("tape_vol", (volid (i)), volid (i), code);
	     if code ^= 0 then goto end_processing;
	end;

	tape_archive_table.io_module_name = io_module;

	temp_seg_ptrs = null;

	on cleanup call cleanerup;

	call get_temp_segments_ ("tape_archive", temp_seg_ptrs (*), code);
	if code ^= 0 then goto end_processing;

	ptr_active = 1;
	last_good_copy_ptr = null;


	call ioa_$rsnnl
	     ("^a^v( ^a^) -name ^^a -retain all^^[ -clear^^;^^]^[ -ring^;^] -mode binary -density ^d",
	     attach_template, 0, io_module, dim (volid, 1), volid (*),
	     retain_sw, density);

	do i = 1 by 1 while (code = 0);

	     filename = ta_file_io_$make_filename
		(table_ptr, "ONLINE-TABLE-", i);

	     call ioa_$rsnnl (attach_template, attach_description, 0,
		filename, (i = 1));

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

	     call iox_$attach_ptr
		(tape_input_switch, attach_description, null, code);
	     if code = 0 then do;

		     call iox_$open
			(tape_input_switch, Sequential_input, ""b, code);
		     if code = 0 then do;

			     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, nelemt, code);
			     if code = error_table_$short_record then
				code = 0;
			     if code ^= 0 then goto end_processing;
			     n_chars_read = nelemt;
			     last_good_copy_ptr =
				temp_seg_ptrs (ptr_active);
			     if ptr_active = 1 then ptr_active = 2;
			     else ptr_active = 1;
			end;
		end;
	end;

end_processing:
	if last_good_copy_ptr = null then do;
		call com_err_
		     (code, "tape_archive",
		     "No readable copy of ^a was found.", table_name);
		call cleanerup;
		return;
	     end;

	if code ^= error_table_$no_file then do;
		call com_err_ (code, "tape_archive");
		got_older_table = "1"b;
	     end;

	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, "tape_archive",
		     "^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, "tape_archive",
		     "The most recent readable copy of ^a (^a) has ^a.",
		     table_name, date_time_string, "been loaded");
	     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, "tape_archive",
			"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).",
			"tape_archive", "Warning",
			volid (i), table_volid);
		     call ioa_
			("^15xAn ""^a"" operation may be indicated.",
			"alter volume");
		     i = 100;
		end;
	end;

	tape_archive_table.density (tape_archive_table.active_set) = density;		/* why force the user to alter? */
	tape_archive_table.io_module_name = io_module;

	call cleanerup;
	return;

cleanerup: proc;

	if temp_seg_ptrs (1) ^= null then
	     call release_temp_segments_
		("tape_archive", temp_seg_ptrs (*), code);

	if retain_sw = ""b then
	     call iox_$control (tape_input_switch, "retain_none",
		null, code);
	else do;
		tape_archive_table.mount_lock = get_lock_id_ ();
		tape_archive_table.highest_mount_type = Read;
	     end;

	call iox_$close (tape_input_switch, code);
	call iox_$detach_iocb (tape_input_switch, code);

	return;
     end cleanerup;

     end ta_load_table_;




		    ta_reconstruct_table_.pl1       01/03/84  1349.8rew 01/03/84  1315.5        4878



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
ta_reconstruct_table_: proc;

dcl (com_err_, com_err_$suppress_name) ext entry options (variable);

	call com_err_ (0, "tape_archive", "The reconstruct key is not yet implemented.");
	return;
     end ta_reconstruct_table_;




		    ta_filesys_util_.pl1            01/03/84  1349.8rew 01/03/84  1315.1      181665



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

/* 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_$status_minf ext entry (char (*), char (*), fixed bin, fixed bin, fixed bin (24), 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_process_volume_set_.pl1      01/03/84  1349.8rew 01/03/84  1315.1      221652



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

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

/* AUTOMATIC */

dcl  compacting	        bit (1) aligned,
     cur_time	        bit (36) aligned,
     debug_sw	        bit (1) aligned,
     dlp		        pointer,
     (i, j)	        fixed bin,
     max_chars_in_seg       fixed bin (21),
     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, clock, dim, index, null, substr) builtin;

/* STATIC */

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

/* EXTERNAL STATIC */

dcl  (error_table_$bad_mount_request,
     error_table_$badopt,
     error_table_$file_aborted,
     error_table_$lock_wait_time_exceeded,
     error_table_$no_next_volume,
     error_table_$not_done,
     error_table_$unexpired_file,
     error_table_$unexpired_volume,
     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)),
     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),
     iox_$find_iocb	        ext entry (char (*), pointer, fixed bin (35)),
     iox_$attach_ptr        ext entry (pointer, char (*) aligned, pointer, fixed bin (35)),
     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));

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_and_unlock ext entry (pointer, pointer, fixed bin (35)),
     ta_table_mgr_$finish_requests ext entry (pointer, fixed bin (35)),
     ta_table_mgr_$lock_and_copy ext entry (pointer, pointer, 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;
	table_ptr = perm_table_ptr;
	debug_sw, tape_archive_io_info.long_sw = ""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_ ();

	retain_sw = (tape_archive_table.mount_lock = my_lock_id);

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

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

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

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

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

			if tape_archive_table.highest_mount_type >= Read then
			     call attach_for_detach
				(tape_archive_table.active_set,
				tape_archive_io_info.tape_input_switch);

			if tape_archive_table.highest_mount_type = Compact then
			     call attach_for_detach
				(3 - tape_archive_table.active_set,
				tape_archive_io_info.tape_output_switch);

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

attach_for_detach: proc (set_no, sw_ptr);

dcl  (set_no	        fixed bin,
     sw_ptr	        pointer) parameter;

	call ioa_$rsnnl ("^v(^a ^)",
	     tape_in_volume_string, 0,
	     tape_archive_table.n_volumes_in_set (set_no),
	     tape_archive_table.volume_set (set_no).volume_id (*));

	call ioa_$rsnnl ("^a ^a -number 1 -density ^d",
	     tape_archive_io_info.input_atd_template, 0,
	     tape_archive_table.io_module_name,
	     tape_in_volume_string,
	     tape_archive_table.density (set_no));

	call iox_$attach_ptr
	     (sw_ptr, tape_archive_io_info.input_atd_template, null, code);

	return;
     end attach_for_detach;

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

			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;

	call ta_table_mgr_$lock_and_copy (perm_table_ptr, tape_archive_io_info.temp_table_ptr, table_name, Process_tape, code);
	if code ^= 0 then return;

	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;

	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 = 3 - tape_archive_table.active_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;

	do i = tape_archive_table.active_set, 3 - tape_archive_table.active_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;

	call ioa_$rsnnl ("^a ^a -name ^^a -number ^^d -retain all^[ -ring^;^] -mode ^^a -density ^d",
	     tape_archive_io_info.input_atd_template, 0,
	     tape_archive_table.io_module_name,
	     tape_in_volume_string,
	     ((this_mount_type = Write) | retain_sw),
	     tape_archive_table.density (tape_archive_table.active_set));

	if this_mount_type < Compact then tape_archive_io_info.output_atd_template = "";
	else call ioa_$rsnnl
		("^a ^a -name ^^a -number ^^d^^[ -clear^^] -create -expires 12/31/99 -format sb -block 8192 -retain all -ring -mode ^^a -density ^d",
		tape_archive_io_info.output_atd_template, 0,
		tape_archive_table.io_module_name,
		tape_out_volume_string,
		tape_archive_table.tape_info.density (3 - tape_archive_table.active_set));
%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_table.io_module_name 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 (*), 1) then do;
				code = error_table_$no_next_volume;
				call com_err_ (code, "tape_archive", "Maximum volume set size exceeded.");
				call abort;
			     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;

/* 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 ^= 0 then
					if code = error_table_$bad_mount_request then do;
						call com_err_ (code, "tape_archive", "Extraction ^[and deletion^] of ^a could not be processed.", request_queue (j).delete, component.entry_name);
						call cleanerup;
						return;
					     end;
					else if code = 1 then ;  /* special case: cancel deletion, msg already issued */
					else 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 call abort;
			     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.  */

		if ^compacting then do;
			tape_out_volume_string = tape_in_volume_string;
			call ioa_$rsnnl
			     ("^a ^a -name ^^a -number ^^d^^[ -clear^^] -create -expires 12/31/99 -format ^[sb^;vbs^] -block 8192 -retain all -ring -mode ^^a -density ^d",
			     tape_archive_io_info.output_atd_template, 0,
			     tape_archive_table.io_module_name,
			     tape_out_volume_string,
			     (tape_archive_table.io_module_name = "tape_ansi_"),
			     tape_archive_table.tape_info.density (tape_archive_table.active_set));
		     end;

		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 ^= 0 then
				if code = error_table_$bad_mount_request then do;
					call com_err_ (code, "tape_archive", "Append of ^a>^a could not be processed.", request.directory_name, request.entry_name);
					call cleanerup;
					return;
				     end;
				else if code = error_table_$unexpired_file then do;
					call com_err_ (code, "tape_archive", "Terminating processing of this volume.");
					call cleanerup;
					return;
				     end;
				else 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;
%skip (5);
	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;
	     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_and_unlock (tape_archive_io_info.temp_table_ptr, perm_table_ptr, code);
	if code ^= 0 then call abort;

	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;
%skip (5);
cleanerup: proc;

	call ta_file_io_$dismount (perm_table_ptr, tape_archive_io_info.tape_input_switch, retain_sw, code);
	call ta_file_io_$dismount (perm_table_ptr, tape_archive_io_info.tape_output_switch, retain_sw, code);

	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 options (non_quick);

dcl  debug	        ext entry;

	call com_err_ (code, "tape_archive", "");
	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);

dcl  a_retain_sw	        bit (1) aligned parameter;

	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;

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

	call ta_file_io_$dismount (perm_table_ptr, tape_archive_io_info.tape_input_switch, retain_sw, code);
	call ta_file_io_$dismount (perm_table_ptr, tape_archive_io_info.tape_output_switch, retain_sw, code);

	if ^retain_sw 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;

     end ta_process_volume_set_;



		    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
