[inherit('sys$library:starlet', '[-]mcvlib', '[-]rtl', '[-.lister]listings'),
 ident('V2.0')]
program Precis (input, output);

{+++
	Dumps a tape, formatting the output to facilitate determining
	what's on the tape.

	Bob Langford
	Academic Computing
	Medical College of Virginia
	Nov 1982

Modification history:
	Feb. 1983	Modified for VAX-11 Pascal V2.0		(REL)
	7 March 83	"Raw" data width changed		(REL)
	23 March 83	Included references to RTL env. file	(REL)
	27 April 83	Shortened messages for HDR1/EOF1/EOV1   (REL)
	13 July 83	Increased block size to 65535 bytes	(REL)
	5 Oct 1983	Fixed interpretation of IBM labels.	(REL)
	Oct 1986	Heavily modified printing logic, added  (REL)
			part of /SUMMARY code.

Current functions:
	Handles /ASCII, /HEX, /EBCDIC, /OUTPUT= qualifiers.
	Handles /LABELS qualifier.
	Added /REWIND & fixed IBM label block attributes field.
	The /SUMMARY option (writes a one-line description
		of each file to a given file) works, but only for
		IBM labelled tapes.  Non-labeled and ANSI labelled
		tapes produce no summary data.
---}

label	1;	{ To start reading tape over. }

const
	BUFFER_SIZE = 65535;	{ Size of data buffer in bytes. }
	VERSION	 = '2.0';	{ String for version number. }

type
	str_sub = 1..255;
	sub120 = 1..120;
	iobuf_sub = 1..BUFFER_SIZE;
	io_buf_type = record
			data : packed array [iobuf_sub] of char
		      end;
	an_IOSB = [quad] record
			status  : $uword;
			count   : $uword;
			flags   : mt$type
		    end;

var
	buffer	: io_buf_type;			{ tape I/O buffer }
	length	: integer;
	stat	: integer;
	tape	: $word;			{ tape I/O channel # }
	device	: varying [63] of char; 	{ name of tape device }

	iosb : an_IOSB;
	density	: [volatile] integer;		{ Tape density in BPI }
	block_count	: integer;	{ Number of blocks in this file. }
	file_marks	: integer;	{ # of consecutive tape marks. }
	byte_count	: integer;	{ # of bytes in this file. }
	min_block, max_block : integer;		{ Range of block sizes. }
	mean_block	: real;		{ Mean block size }

	total_bytes	: real;		{ # of bytes on tape }
	total_blocks	: integer;	{ # of blocks on tape }
	total_files	: integer;	{ # of files on tape }

	first_to_do, last_to_do	: integer;	{ limits to block processing }
	display_limit	: integer;	{ # of dump blocks to print. }
	displayed	: integer;	{ # printed for current file. }
	page_num, page_position : integer;	{ for headers }
	page_size	: integer;
	out		: aListingControlBlock;		{ /OUTPUT file. }
	summ		: aListingControlBlock;		{ /SUMMARY file }

	dat, tim 	: [volatile] packed array [1..11] of char;  { date & time }

	persist,		{ Don't stop for parity errors. }
	rewind_tape,		{ Rewind tape before starting. }
	show_labels,
	show_hex,
	show_ascii,
	show_ebcdic	: [volatile] boolean;	{ Flags for various options. }

	even, first	: [volatile] boolean;
	tape_format : (UNLABELLED, IBM_LABELLED, ANSI_LABELLED);
	file_info : record		{ Data for /SUMMARY option. }
		file_seq : integer;
		dsname : packed array [1..17] of char;
		recfm : packed array [1..3] of char;
		lrecl : integer;
		blksize : integer;
		blkcnt : integer;
		est_length : real;
		credt,
		expdt : packed array [1..6] of char;
		job_id : packed array [1..17] of char
	    end;

[asynchronous]
function Header : integer;			{ Print new page header. }
var page_num : [static] integer := 0;
    line : varying [133] of char;
begin
   page_num := page_num + 1;
   writeln (out.OutFile, chr(12), '* * * MCV Tape Precis Version ', VERSION,
		' * * *                                                ',
		dat, ' ', tim,'          Page ', page_num:1);
   write (out.OutFile, 'Density =', density:5, ' BPI  ');
   if even then write (out.OutFile, 'EVEN parity   ');
   write (out.OutFile, '   Options in effect:  ');
   if show_hex then write (out.OutFile, '/HEX ')
   else write (out.OutFile, '/NOHEX ');
   if show_ascii then write (out.OutFile, '/ASCII ')
   else write (out.OutFile, '/NOASCII ');
   if show_ebcdic then write (out.OutFile, '/EBCDIC ')
   else write (out.OutFile, '/NOEBCDIC ');
   if show_labels then write (out.OutFile, '/LABELS ')
   else write (out.OutFile, '/NOLABELS ');
   if rewind_tape then write (out.OutFile, '/REWIND ')
   else write (out.OutFile, '/NOREWIND ');
   writeln (out.OutFile);
   writeln (out.OutFile, '        1........10........20........30........40........',
	'50........60........70........80........90........100.......',
	'110.......120');
   writeln (out.OutFile);
   Header := 4
end;	{ Header }

[asynchronous]
function SummaryHeader : integer;
begin
writeln (summ.OutFile, chr(12), 
'                                Record Block  Block   ----Dates----');
writeln (summ.OutFile, 
'Seq #  Data Set Name     Format Length Size   Count  Created Expires  Created by');
writeln (summ.OutFile);
SummaryHeader := 3
end;	{ SummaryHeader }

procedure get_options;	{ Read & process command line. }
var FileSpec : varying [255] of char;
begin
if not odd (cli$get_value('DEVICE', device)) then begin
   writeln (output, 'Error reading device name from command line.');
   halt
   end;

first_to_do := 1;
last_to_do := 5;

if odd (cli$present ('HEX')) then show_hex := TRUE	{ /[NO]HEX }
else show_hex := FALSE;
if odd (cli$present ('ASCII')) then show_ascii := TRUE	{ /[NO]ASCII }
else show_ascii := FALSE;
if odd (cli$present ('EBCDIC')) then show_ebcdic := TRUE  { /[NO]EBCDIC }
else show_ebcdic := FALSE;
if odd (cli$present ('LABELS')) then show_labels := TRUE  { /[NO]LABELS }
else show_labels := FALSE;
if odd (cli$present ('REWIND')) then rewind_tape := TRUE   { /[NO]REWIND }
else rewind_tape := FALSE;
                                     
display_limit := 10;

if odd (cli$get_value ('OUTPUT', FileSpec)) then
   OpenListing (out, FileSpec, iaddress(Header) )
else
   OpenListing (out, '', iaddress(Header) );

if odd (cli$get_value ('SUMMARY', FileSpec)) then
   OpenListing (summ, FileSpec, iaddress(SummaryHeader) )
else
   OpenListing (summ, '', iaddress(SummaryHeader) );

end;	{ get_options }

{**** Structures and procedures for interpreting tape labels. ****}

type	a_Kind = (NONE, VOL1, HDR1, HDR2, HDR3, EOF1, EOF2, EOF3,
		EOV1, EOV2, EOV3);

	ANS$LABEL = record case boolean of
		FALSE : (data : packed array [sub120] of char);
		TRUE  : (
			   prefix : packed array [1..4] of char;
				case a_Kind of
				VOL1 : (
					vol_id : packed array [1..6] of char;
					accessibility : char;
					filler_1: packed array [1..26] of char;
					owner_id: packed array [1..13] of char;
					dec_version : char;
					filler_2: packed array [1..28] of char;
					ansi_version : char);
				HDR1, EOF1, EOV1 : (
				   file_id : packed array [1..17] of char;
				   file_set_id  : 
					packed array [1..6] of char;
				   file_sect_num :
					packed array [1..4] of char;
				   file_seq_num :
					packed array [1..4] of char;
				   gen_num :
					packed array [1..4] of char;
				   gen_ver_num :
					packed array [1..2] of char;
				   cre_date ,
				   exp_date :
					packed array [1..6] of char;
				   f_accessibility : char;
				   block_count :
					packed array [1..6] of char;
				   system_code :
					packed array [1..13] of char);
				HDR2, EOF2, EOV2 : (
				   recfm : char;
				   blksize, lrecl :
					packed array [1..5] of char);
				HDR3, EOF3, EOV3 : (
				   rms_attributes :
					packed array [1..64] of char);
			)
	       end;


procedure display_ansi (var block : packed array [a..b:integer] of char);

var	i : integer;
	ansi : ANS$LABEL;
	line : varying [133] of char;
begin
{ get data into record }
for i := 1 to 80 do
   ansi.data[i] := block[i];
with ansi do
if prefix = 'VOL1' then begin
   writev (line, 'Ansi VOL1 record.  Vol. ID = "', vol_id, 
	'"   Access = "', accessibility, '"   Owner ID = "', owner_id,
	'"   DEC Vers. ', dec_version, '   ANSI Vers. ',
   	ansi_version);
   WriteListing (out, line);
   tape_format := ANSI_LABELLED
   end
else if prefix = 'HDR1' then begin
   writev (line, 'Ansi HDR1 record.  File ID = "', file_id,
	'"   File Set ID = "', file_set_id, '"   Sect. # = ',
	file_sect_num, '   Seq. # = ', file_seq_num);
   WriteListing (out, line);
   writev (line, '	Gen. # = ', gen_num,
	'   Gen. Vers. # = ', gen_ver_num, '   Created ',
	cre_date, '   Expires ', exp_date, '   Access = "',
	f_accessibility, '"  # Blocks = ', block_count, 
	'   System = "', system_code, '"');
   WriteListing (out, line);
   end
else if prefix = 'HDR2' then begin
   writev (line, 'Ansi HDR2 record.  Record format = ', recfm,
	'   Block length = ', blksize, '   Record length = ', lrecl);
   WriteListing (out, line)
   end
else if prefix = 'HDR3' then begin
   WriteListing (out, 'Ansi HDR3 record.')
   end
else if prefix = 'EOF1' then begin
   writev (line, 'Ansi EOF1 record.  File ID = "', file_id,
	'"   File Set ID = "', file_set_id, '"  File sect. # = ',
	file_sect_num, '   File Sequence # = ', file_seq_num);
   WriteListing (out, line);
   writev (line, '	Gen. # = ', gen_num,
	'   Gen. Vers. # = ', gen_ver_num, '   Created ',
	cre_date, '   Expires ', exp_date, '   Access = "',
	f_accessibility, '"  # Blocks = ', block_count, 
   	'   System = "', system_code, '"');
   WriteListing (out, line);
   end
else if prefix = 'EOF2' then begin
   writev (line, 'Ansi EOF2 record.  Record format = ', recfm,
	'   Block length = ', blksize, '   Record length = ', lrecl);
   WriteListing (out, line)
   end
else if prefix = 'EOF3' then begin
   writev (line, 'Ansi EOF3 record.');
   WriteListing (out, line)
   end
else if prefix = 'EOV1' then begin
   writev (line, 'Ansi EOV1 record.  File ID = "', file_id,
	'"   File Set ID = "', file_set_id, '"  File section # = ',
	file_sect_num, '   File Sequence # = ', file_seq_num);
   WriteListing (out, line);
   writev (line, '	Gen. # = ', gen_num,
	'   Gen. Vers. # = ', gen_ver_num, '   Created ',
	cre_date, '   Expires ', exp_date, '   Access = "',
	f_accessibility, '"  # Blocks = ', block_count, 
   	'   System = "', system_code, '"');
   WriteListing (out, line)
   end                                     
else if prefix = 'EOV2' then begin
   writev (line, 'Ansi EOV2 record.  Record format = ', recfm,
	'   Block length = ', blksize, '   Record length = ', lrecl);
   WriteListing (out, line)
   end
else if prefix = 'EOV3' then begin
   writev (line, 'Ansi EOV3 record.');
   WriteListing (out, line);
   end;
end;	{ display_ansi }

type	IBM$LABEL = record case boolean of
		FALSE : (data : packed array [sub120] of char);
		TRUE  : (
			   prefix : packed array [1..4] of char;
				case a_Kind of
				VOL1 : (
					vol_id : packed array [1..6] of char;
				      filler_1 : packed array [1..31] of char;
				      owner_id : packed array [1..10] of char;
					);
				HDR1, EOF1, EOV1 : (
				   file_id : packed array [1..17] of char;
				   file_set_id  : 
					packed array [1..6] of char;
				   file_sect_num :
					packed array [1..4] of char;
				   file_seq_num :
					packed array [1..4] of char;
				   gen_num :
					packed array [1..4] of char;
				   gen_ver_num :
					packed array [1..2] of char;
				   cre_date ,
				   exp_date :
					packed array [1..6] of char;
				   f_accessibility : char;
				   block_count :
					packed array [1..6] of char;
				   system_code :
					packed array [1..13] of char);
				HDR2, EOF2, EOV2 : (
				   recfm : char;
				   blksize, lrecl :
					packed array [1..5] of char;
				      filler_3 : packed array [1..2] of char;
					job_id : packed array [1..17] of char;
				      filler_4 : packed array [1..4] of char;
				      blk_attr : char
					);
			)
	       end;

procedure display_ibm (var block : packed array [a..b:integer] of char);

var
    i : integer;
    ibm : IBM$LABEL;
    line : varying [133] of char;
begin
{ get data into record }
for i := 1 to 80 do
   ibm.data[i] := block[i];
with ibm do
if prefix = 'VOL1' then begin
    writev (line, 'IBM VOL1 record.  Volume ID = "', vol_id, 
	'"   Owner = "', owner_id,'"');
    WriteListing (out, line);
    tape_format := IBM_LABELLED;
    end
else if prefix = 'HDR1' then begin
    writev (line, 'IBM HDR1 record.  Data Set Name = "', file_id,
	'"   Serial # = "', file_set_id, '"  Vol. Seq. # = ',
	file_sect_num, '   File Sequence # = ', file_seq_num);
    WriteListing (out, line);
    writev (line, '	Gen. # = ', gen_num,
    	'   Vers. # = ', gen_ver_num, '  Created ',
	cre_date, '  Expires ', exp_date, '  Security = "',
	f_accessibility, '"  Blk count = ', block_count, 
    	'   Sys. = "', system_code, '"');
    WriteListing (out, line);            
    end
else if prefix = 'HDR2' then begin
    writev (line, 'IBM HDR2 record.  Record format = ', recfm, blk_attr,
	'   Block length = ', blksize, '   Record length = ', lrecl,
	'   Created by ', job_id);
    WriteListing (out, line);
    end
else if prefix = 'EOF1' then begin
    writev (line, 'IBM EOF1 record.  Data Set Name = "', file_id,
	'"   Serial # = "', file_set_id, '"  Vol. Seq. # = ',
	file_sect_num, '   File Sequence # = ', file_seq_num);
    WriteListing (out, line);
    writev (line, '	Generation # = ', gen_num,
	'   Vers. # = ', gen_ver_num, '   Created ',
	cre_date, '   Expires ', exp_date, '   Security = "',
	f_accessibility, '"  Blk count = ', block_count, 
	'   Sys. = "', system_code, '"');
    WriteListing (out, line)
    end
else if prefix = 'EOF2' then begin
    writev (line, 'IBM EOF2 record.  Record format = ', recfm, blk_attr,
	'   Block length = ', blksize, '   Record length = ', lrecl,
	'   Created by ', job_id);
    WriteListing (out, line);
    end
else if prefix = 'EOV1' then begin
    writev (line, 'IBM EOV1 record.  Data Set Name = "', file_id,
	'"   Serial # = "', file_set_id, '"  Vol. Seq. # = ',
	file_sect_num, '   File Sequence # = ', file_seq_num);
    WriteListing (out, line);
    writev (line, '	Generation # = ', gen_num,
	'   Vers. # = ', gen_ver_num, '   Created ',
	cre_date, '   Expires ', exp_date, '   Security = "',
	f_accessibility, '"  Blk count = ', block_count, 
	'   Sys. = "', system_code, '"');
    WriteListing (out, line);
    end
else if prefix = 'EOV2' then begin
    writev (line, 'IBM EOV2 record.  Record format = ', recfm, blk_attr,
	'   Block length = ', blksize, '   Record length = ', lrecl,
	'   Created by ', job_id);
    WriteListing (out, line);
    end
end;	{ display_ibm }

procedure summ_ibm (var block : packed array [a..b:integer] of char);
var
    i : integer;
    ibm : IBM$LABEL;
    line : varying [133] of char;
begin
for i := 1 to 80 do
    ibm.data[i] := block[i];
with file_info do begin
    if ibm.prefix = 'EOF1' then begin
	readv (ibm.file_seq_num, file_seq);
	dsname := ibm.file_id;
	credt := ibm.cre_date;
	expdt := ibm.exp_date;
	readv (ibm.block_count, blkcnt)
	end
    else if ibm.prefix = 'EOF2' then begin
	recfm[1] := ibm.recfm;
	recfm[2] := ibm.blk_attr;
	recfm[3] := ibm.filler_4[3];
	readv (ibm.lrecl, lrecl);
	readv (ibm.blksize, blksize);
	job_id := ibm.job_id;
					{ Now write it. }
	writev (line, file_seq:5, ') ', dsname, '  ', recfm,
		lrecl:7, blksize:7, blkcnt:8, '  ', credt,
	  	'  ', expdt, '  ', job_id);
	WriteListing (summ, line);
	FlushListing (summ)
	end
    end

end;                             

procedure display_rec (first, last : integer);
{ Dump (in selected format) another "record" of block. }
var
    i, len : integer;
    hex : packed array [1..16] of char;
    hi, lo, ascii, ebcdic : packed array [1..120] of char;
    line : varying [133] of char;

begin
hex := '0123456789ABCDEF';
len := last - first + 1;
for i := 1 to len do begin
   ascii[i] := buffer.data[first + i - 1];	{ Get ASCII char. }
   hi[i] := hex[1 + (ord(ascii[i]) div 16)];	{ Convert to hex. }
   lo[i] := hex[1 + (ord(ascii[i]) mod 16)]
   end;

lib$tra_ebc_asc (ascii, ebcdic);	{ get EBCDIC version. }
for i := 1 to len do begin	{ substitute '.' for non-printing chars. }
    if ord(ascii[i]) > 127 then ascii[i] := chr(ord(ascii[i]) - 128);
    if ascii[i] < ' ' then ascii[i] := '.';
    if ord(ebcdic[i]) > 127 then ebcdic[i] := chr(ord(ebcdic[i]) - 128);
    if ebcdic[i] < ' ' then ebcdic[i] := '.'
    end;

if show_ebcdic then begin
    writev (line, 'EBCDIC: ', ebcdic:len);
    WriteListing (out, line)
    end;

if show_ascii then begin
    writev (line, 'ASCII : ', ascii:len);
    WriteListing (out, line)             
    end;

if show_hex then begin
    writev (line, 'HEX  H: ', hi:len);
    WriteListing (out, line);
    writev (line, '     L: ', lo:len);
    WriteListing (out, line);         
    end;
if len = 80 then begin
    if show_labels then begin
	display_ansi (ascii);
	display_ibm  (ebcdic)
	end;
    summ_ibm (ebcdic)			{ Need to add a piece here to }
    end;                                { handle /SUMMARY for other kinds }
                                        { of tapes. }
end;	{ display_rec }

procedure display_block;
{ Display selected amounts of the current block. }
var
    lrecl, last, blksize, i : integer;
    line : varying [133] of char;
begin
blksize := iosb.count;
if (blksize mod 80) = 0 then
    lrecl := 80
else 
    lrecl := 120;
if displayed < display_limit then begin
    writev (line, 'Block ', block_count:5);
    WriteListing (out, line);              
    end;

i := 1;
while (i <= blksize) and (displayed < display_limit) do begin
   last := i + lrecl - 1;
   if last > blksize then
      last := blksize;
   display_rec (i, last);
   WriteListing (out, '');
   FlushListing (out);
   displayed := displayed + 1;
   i := last + 1
   end
end;	{ display_block }

procedure Check (status : integer);	{ Check system service return code. }
begin
if status <> SS$_NORMAL then		{ Something was wrong. }
    if (status = SS$_PARITY) and (persist) then
	WriteListing (out, '***** ***** *****  PARITY ERROR  ***** ***** *****')
    else
	lib$signal (status)
end;	{ Check }

procedure set_tape (stat : integer);
var	iosb : an_IOSB;
begin
if not rewind_tape then check (stat);
if stat = SS$_PARITY then begin
    if even then lib$signal (SS$_VOLINV)
    else even := TRUE;
    goto 1		{ Go back and start over! }
    end;
{ Get tape's density. }
stat := $qiow (0, tape, IO$_SENSEMODE, iosb);
check (stat);
if iosb.flags.MT$V_DENSITY = MT$K_GCR_6250 then density := 6250
else if iosb.flags.MT$V_DENSITY = MT$K_PE_1600 then density := 1600
else if iosb.flags.MT$V_DENSITY = MT$K_NRZI_800 then density := 800
else density := 0;
first := FALSE
end;	{ set_tape }

{**********************  M A I N   P R O G R A M  **************************}
var
    line : varying [133] of char;
    precis_table: [external] cli_tableType;
begin	{ precis }
cli_parse_foreign(precis_table,'PRECIS');
date (dat);					{ Get current date ... }
time (tim);					{ ... and time. }
page_position := 9999;
page_size := 60;
tape_format := UNLABELLED;			{ Assume no format. }

page_num := 0;					{ Set the statistics counters. }
total_bytes := 0;
total_blocks := 0;
total_files := 0;
file_marks := 0;

even := FALSE;			{ Assume that the tape will be odd parity. }
persist := TRUE;				{ Ignore parity errors. }

get_options;					{ Check for any DCL qualifiers
						  on command line. }

stat := $assign (device, tape);			{ Open channel to tape drive. }
check (stat);

first := TRUE;

1:
if rewind_tape then begin
   stat := $qiow (0, tape, IO$_REWIND, iosb);		{ Rewind }
   check (stat)
   end;
if even then begin
   stat := $qiow (, tape, IO$_SENSEMODE, iosb);
   check (stat);
   iosb.flags.MT$V_PARITY := TRUE;		{ Flag for even parity. }
   stat := $qiow (, tape, IO$_SETMODE, iosb,,,iosb);	{ Set mode }
   check (stat);
   end;


repeat		{ for each file on tape. }
   { setup }
   block_count := 0;
   byte_count := 0;
   min_block := 100000;
   max_block := 0;
   displayed := 0;		{ # of dump sets produced }

   repeat		{ for each block in file. }
	{ Read next block from tape. }
      stat := $qiow (0, tape, IO$_READVBLK, iosb, , ,
   			buffer, BUFFER_SIZE);
      check (stat);
      if first then set_tape (iosb.status);
      if iosb.status = SS$_NORMAL then
         begin
	 file_marks := 0;
         block_count := block_count + 1;
	 total_blocks := total_blocks + 1;
	 byte_count := byte_count + iosb.count;
	 total_bytes := total_bytes + iosb.count;
	 if iosb.count < min_block then min_block := iosb.count;
	 if iosb.count > max_block then max_block := iosb.count;
         if (first_to_do <= block_count)
            and            (block_count <= last_to_do) then
            display_block;
         end                                 
      else if iosb.status <> SS$_ENDOFFILE then
         check (iosb.status)
      until iosb.status = SS$_ENDOFFILE;
   file_marks := file_marks + 1;
   total_files := total_files + 1;
   if block_count = 0 then begin
      WriteListing (out, '');
      writev (line, '*************************************************',
		'  TAPE MARK ', total_files:1,
      		'  *************************************************');
      WriteListing (out, line);
      WriteListing (out, '');
      FlushListing (out)
      end
   else begin
      mean_block := byte_count;
      mean_block := mean_block / block_count;
      if min_block = max_block then 
	 writev (line, block_count:1, ' blocks of ', min_block:1, ' bytes.')
      else
	 writev (line, block_count:1, ' blocks averaging ', mean_block:7:1,
		' bytes each.  Smallest = ', min_block:1, 
		'   Largest = ', max_block:1);
      WriteListing (out, line);
      WriteListing (out, '');
      writev (line, '*************************************************',
  		'  TAPE MARK ', total_files:1,
		'  *************************************************');
      WriteListing (out, line);
      WriteListing (out, '');
      FlushListing (out)
      end
   until file_marks >= 2;	{ Sign of End Of Volume }
WriteListing (out, 'End of volume reached.');
writev (line, total_files:1, ' files, ', total_blocks:1, ' blocks, ',
	total_bytes:12:0, ' bytes');
WriteListing (out, line);
FlushListing (out)
end.
