{ TPC - Program to copy a tape image onto a disk file and then back to tape.

Physical records are read from the tape and written to the disk file as 
logical records of the same length. Tape marks are written to the disk file 
as zero-length logical records. The end of tape occurs when 2 tape marks in a
row are encountered (if the /ansi qualifier is specified on the command line,
end of tape is after the EOV records).

Command format:

	$ TPC dev: filespec [ /ANSI ]		from tape to disk
	$ TPC filespec dev: [ /ANSI ]		from disk to tape 
}

[inherit ('sys$library:starlet')] program tpc (input, output);

type
	line_type = varying [80] of char;
	char_2 = packed array [1..2] of char;

var
	command_line:
	record
		ansi: boolean;
		direction: (from_tape, to_tape);
		filespec: array [1..2] of line_type;
	end;
	disk_file: text;


(* ERROR - this procedure prints out a syntax error message *)

procedure error (err: line_type);

begin
	writeln (err);
	halt;
end;

(* FRONTEND - Front end procedure for the TPC utility. 

	Returns all the parameters and switches with which the utility was 
invoked. Uses the file TPC.CLD to define the command line, and the CLI 
utility routines to acquire the command line information. All such information
is inserted into the global structure COMMAND_LINE, which is then referenced by 
the various other routines in the utility.

	Most of the following information is also included in TPC.HLP.

TPC utility command line format:

	$ TPC dev: filespec [ /ANSI ]		from tape to disk
	$ TPC filespec dev: [ /ANSI ]		from disk to tape 

	Qualifier:

		/ANSI
			If /ANSI is specified, the end of tape is defined as
			being the tape marks beyond the EOV records. Else, it
			is any 2 adjacent tape marks.

	SYS$FILESCAN is used to parse file specifications.
	
*)

procedure frontend;

const
	%include 'climsgdef'

type
	$uword = [word] 0..65535;
	spec_type = (tape, user_file);

var
	i: integer;	
	specs_type: array [1..2] of spec_type;

[external, unbound] function cli$present 
	(%stdescr entity: packed array [$l1..$u1:integer] of char): integer;
	extern;
[external, unbound] function cli$get_value 
	(%stdescr entity: packed array [$l1..$u1:integer] of char;
	%stdescr value: packed array [$l2..$u2:integer] of char;
	var value_length: [volatile] $uword): integer;
	extern;

(* GET_TRUE_FALSE - Procedure to process a boolean qualifier.

Calling Sequence:
	get_true_false (keyword, variable);

	keyword  - string containing the name of the qualifier (global).
	variable - boolean variable: false if absent or negated
*)

procedure get_true_false (keyword: packed array [$l1..$u1:integer] of char;
	var variable: boolean);

var
	result: integer;
begin
	result := cli$present (keyword);

	if (result = cli$_absent)  or  (result = cli$_negated) then
		variable := false
	else if result = cli$_present then
		variable := true
	else
		error (keyword + ' qualifier must be global');
end;

(* GET_FILESPEC - procedure to retreive the file specification and all file 
	qualifiers from the command line and populate command_line.filespec [p]

Calling Sequence:
	get_filespec (filespec, specs_type, p_name);

Where:
	filespec   - file specification string
	specs_type - either TAPE or USER_FILE
	p_name     - parameter name (P1, P2, etc)

Note:
	specs_type is set to TAPE if only a device is specified, and that 
		refers to a tape drive (as determined by $getdvi).
	the filetype portion of filespec is defaulted to TAP if specs_type is 
		determined to be USER_FILE
*)

procedure get_filespec (var filespec: line_type; var specs_type: spec_type; 
	p_name: char_2);

var
	value: packed array [1..80] of char;
	value_length: $uword;
	result: integer;
	parameter_names: [static] array [1..8] of varying [2] of char := 
		('P1', 'P2', 'P3', 'P4', 'P5', 'P6', 'P7', 'P8');
	node, device, root, directory, name, file_type, version: line_type;


(* PARSE_FILESPEC - procedure to parse file specification string, supplying a
	default of .TAP if not present 

Calling Sequence:
	parse_filespec (filespec: line_type; var node, device, root, 
		directory, name, file_type, version: line_type);

Where:
	filespec  - raw filespec as entered on command line
	node      - DECnet node name
	device    - device name
	root      - root directory (eg, [sys0.])
	directory - directory name 
	name      - file name
	file_type - file type
	version   - version number string
*)

procedure parse_filespec (filespec: line_type; var node, device, root, 
	directory, name, file_type, version: line_type);

const
	FSCN$_FILESPEC = 1;	(* taken from LB:[1,1]STARLET.MLB/EX:$FSCNDEF *)
	FSCN$_NODE = 2;
	FSCN$_DEVICE = 3;
	FSCN$_ROOT = 4;
	FSCN$_DIRECTORY = 5;
	FSCN$_NAME = 6;
	FSCN$_TYPE = 7;
	FSCN$_VERSION = 8;

type
	$length = [word] 0..65535;
	$item_code = [word] 0..65535;
	$address = integer;
	value_list_type = 
		record
			items: array [1..7] of 
				record
					length: $length; 
					code: $item_code; 
					address: $address
				end;
			terminator: integer;
		end;

var
	i: integer;
	value_list: value_list_type;
	result: integer;
	offset: array [1..7] of integer;

begin
	value_list.terminator := 0;
	value_list.items [1].code := fscn$_node;
	value_list.items [2].code := fscn$_device;
	value_list.items [3].code := fscn$_root;
	value_list.items [4].code := fscn$_directory;
	value_list.items [5].code := fscn$_name;
	value_list.items [6].code := fscn$_type;
	value_list.items [7].code := fscn$_version;

	result := $filescan (filespec, value_list); 

	offset [1] := 1;
	for i:= 2 to 7 do
		offset [i] := offset [i-1] + value_list.items [i-1].length;

	node := substr (filespec, offset [1], value_list.items [1].length);
	device := substr (filespec, offset [2], value_list.items [2].length);
	root := substr (filespec, offset [3], value_list.items [3].length);
	directory := substr (filespec, offset [4], value_list.items [4].length);
	name := substr (filespec, offset [5], value_list.items [5].length);
	file_type := substr (filespec, offset [6], value_list.items [6].length);
	version:= substr (filespec, offset [7], value_list.items [7].length);
end;

(* CHECK_DEVICE - determine if device is to a foreign mounted tape 

Calling Sequence:
	tf := check_device (device);

Where:
	tf     - a boolean result
	device - file specification string
*)
	function check_device (device: line_type): boolean;

var
	status: integer;
	item_list: array [1..3] of 
	packed record
		buffer_length: $uword;
		item_code: $uword;
		buffer_address: ^integer;
		return_length_address: ^integer;
	end;
	temp_ptr: ^integer;
	acp_type, dev_class: integer;
	message: varying [256] of char;

begin 
	item_list [1].buffer_length := 4;
	item_list [2].buffer_length := 4;
	item_list [3].buffer_length := 0;

	item_list [1].item_code:= dvi$_acptype;
	item_list [2].item_code:= dvi$_devclass;
	item_list [3].item_code:= 0;

	new (temp_ptr); item_list [1].buffer_address := temp_ptr;
	new (temp_ptr); item_list [2].buffer_address := temp_ptr;
	                item_list [3].buffer_address := nil;

	new (temp_ptr); item_list [1].return_length_address := temp_ptr;
	new (temp_ptr); item_list [2].return_length_address := temp_ptr;
	                item_list [3].return_length_address := nil;

	status := $getdviw (, , 'MS:', item_list, , , , );
	if (status <> ss$_normal) then
	begin
		writeln ('TPC - directive error in processing command line');
		$getmsg (status, message.length, message.body);
		writeln (message);
	end;


	acp_type := item_list [1].buffer_address^;
	dev_class := item_list [2].buffer_address^;

	check_device := (acp_type = 0) and (dev_class = dc$_tape);

end;

(* get_filespec main line code *)
begin
	if ss$_normal <> cli$get_value (p_name, value, value_length) then
		error ('File specification missing');

	filespec := substr (value, 1, value_length);
	parse_filespec (filespec, node, device, root, directory, name, 
		file_type, version);
	specs_type := user_file;
	if (node.length      = 0) and
	   (device.length    > 0) and
	   (root.length      = 0) and
	   (directory.length = 0) and
	   (name.length      = 0) and
	   (file_type.length = 0) and
	   (version.length   = 0) then
		if check_device (device) then	
			specs_type := tape;

	if (specs_type = user_file) and (file_type.length = 0) then
		file_type := '.tap';

	filespec := node + device + root + directory + name + file_type + version;
end;

(* frontend main line code *)
begin

	get_true_false ('ansi', command_line.ansi);
	get_filespec (command_line.filespec [1], specs_type [1], 'P1');
	get_filespec (command_line.filespec [2], specs_type [2], 'P2');
	if (specs_type [1] = tape) and (specs_type [2] = user_file) then
		command_line.direction := from_tape
	else if (specs_type [1] = user_file) and (specs_type [2] = tape) then
		command_line.direction := to_tape
	else
		error ('Exactly one of the files MUST be a tape drive');

end;

{ read_tape - copy from tape to disk file }

procedure read_tape (%stdescr file_spec: packed array [$l1..$u1:integer] of char);
	fortran;

{ write_tape - copy from disk file to tape 

Calling Sequence:
	write_tape (file_spec);

Where:
	file_spec - name of disk file to read tape image from

}

procedure write_tape (file_spec: line_type);

type
	rfa_type = array [1..2] of integer;
	buffer_type = varying [32766] of char;

var
	mschan: [volatile, word] 0..65535;
	prl: array [1..6] of integer;
	iosb: array [1..4] of [word] 0..65535;
	status: integer;
	message: varying [256] of char;
	buffer: buffer_type;
	end_of_file: boolean;
	rfa: rfa_type;
	eof_in: boolean;

[external, unbound] function open_in (%descr filename: line_type): integer; 
	extern;
[external, unbound] function close_in: integer; 
	extern;
[external, unbound] function get_in (%descr buffer: buffer_type): integer;
	extern;

begin

{ Open disk file for output }
	status := open_in (file_spec);
	if (status <> rms$_normal) then
	begin
		writeln ('TPC - error on opening disk file for input');
		$getmsg (status, message.length, message.body);
		writeln (message);
	end;

{ Assign a channel to the tape drive }
	status := $assign ('MS:', mschan, , );
	if (status <> ss$_normal) then
	begin
		writeln ('TPC - error on assigning tape drive');
		$getmsg (status, message.length, message.body);
		writeln (message);
	end;

{ write tape blocks, write them to the disk file }
	eof_in := false;
	while not eof_in do
	begin

{ read record from disk file }
		status := get_in (buffer);
		if (status = rms$_eof) then
			eof_in := true
		else if (status <> rms$_normal) then
		begin
			writeln ('TPC - error on reading from disk file');
			$getmsg (status, message.length, message.body);
			writeln (message);
		end;


{ write tape record - handle errors }
		if (buffer.length = 0) then
			status := $qiow (, mschan, io$_writeof,
				iosb, , , , , , , , )
		else
			status := $qiow (, mschan, io$_writevblk, 
				iosb, , , buffer, buffer.length, , , , );
		if (status <> ss$_normal) then
		begin
			writeln ('TPC - directive error on write to tape drive');
			$getmsg (status, message.length, message.body);
			writeln (message);
		end;
		if (iosb [1] <> ss$_normal) then
			writeln ('TPC - i/o error: iosb =', 
				iosb [1], iosb [2], iosb [3], iosb [4]);
	end;


{ close disk file }
	status := close_in;
	if (status <> rms$_normal) then
	begin
		writeln ('TPC - error on closing disk file for input');
		$getmsg (status, message.length, message.body);
		writeln (message);
	end;

end;

{ main line code }
begin
	frontend;
	if command_line.direction = from_tape then
		read_tape (command_line.filespec [2].body)
	else if command_line.direction = to_tape then
		write_tape (command_line.filespec [1]);
end.