{+}
{	Program BRUREAD	: read BRU files	}
{						}
{	Written by Adrian Weiler 1986/87	}
{	Non-commercial use is OK.		}
{	Feel free to give this program to	}
{	anybody that can use it, as long as	}
{	you don't do that for profit. Please	}
{	don't remove this heading.		}
{						}
{	Sorry for the bad docs & for the lots	}
{	of hacks in this code. I didn't write	}
{	this program for profit either...	}
{						}
{	BRUREAD consists of:			}
{	BRUREAD.PAS 	( this file )		}
{	BRU.CLD		( Set Command BRU )	}
{	BRUMSG.MSG	( Message/OBJ )		}
{	BRU.TXT		( short doc )		}
{						}
{						}
{	If anybody makes improvements, please	}
{	let me know. My address (snail mail):	}
{	Adrian Weiler				}
{	Hennentalweg 12				}
{	7400 Tuebingen				}
{	W-Germany				}
{	Phone (49)(7071) 45054			}
{	Note: Decimal 45054 = Hex AFFE = Monkey	}
{	BITNET: MIWE001@DTUZDV5A (until Mar'89)	}
{	After Apr'89, I probably won't have	}
{	that account anymore, so you could	}
{	contact a friend: ZRKH001 (ZR?HK?)	}
{	or CFKS001 @ the same node.		}
{-----------------------------------------------}
{	G. Kums					}
{	AZN Nijmegen				}
{	P.O. Box 9101				}
{	6500 HB  Nijmegen			}
{	The Netherlands				}
{	Augustus 1990				}
{	Internet-address:			}
{		 "AO_FK@AZNVX1.AZN.KUN.NL"	}
{	Phone: (31)080-517067			}
{						}
{	Changes suggested:			}
{	(Marked by : "==============")		}
{	(file,,file): files concerned		}
{						}
{	1) Qualifier HELP for typing BRU.TXT	}
{	   on screen (BRUREAD.PAS,BRU.TXT and	}
{	   BRU.CLD)				}
{	2) Test BACKUP-controlblock for LABEL	}
{	   given in command, multi-labels,	}
{	   default for tapedevice MUA0:		}
{	   (BRUREAD.PAS, BRU.CLD, BRU.TXT)	}
{	3) Reinitialize: hdrflag,TotalFiles,	}
{	   FlagRewind and TotalBlocks in 	}
{	   Procedure Cleanup for processing next}
{	   LABEL in commandline. (BRUREAD.PAS)	}
{	4) Use I/O-funtion IO$_SKIPFILE for mo-	}
{	   ving to next TapeMark (less CPU-load	}
{	   (BRUREAD.PAS)			}
{	5) /NOREWIND default as is with RSX-BRU	}
{	   (BRUREAD.CLD)			}
{						}
{	Buiding en running BRUREAD:		}
{	PAS BRUREAD				}
{	Message/obj BRUMSG			}
{	Link BRUREAD,BRUMSG			}
{	Set Command BRU				}
{	BRU/HELP				}
{						}
{-----------------------------------------------}
{						}
{	T. R. Wyant				}
{	E. I. DuPont de Nemours			}
{	P. O. Box 27001				}
{	Richmond, VA 23261			}
{	USA					}
{	May 1991				}
{	Phone: (1)804-383-3452			}
{						}
{ More changes:					}
{						}
{   TRW001					}
{	Print name of file on			}
{	    "Illegal recordsize 0" error	}
{						}
{   TRW002					}
{	Have <collapse> return length of	}
{	collapsed string, since it knows it	}
{	anyway. Use this to shorten dynamic	}
{	strings where appropriate.		}
{						}
{   TRW003					}
{	Add /ZERO qualifier to disable forcing	}
{	of max. record size.			}
{						}
{   TRW004					}
{	Add /OCTAL qualifier to force file	}
{	versions to be represented in octal.	}
{	Be warned that large file versions	}
{	won't work with this switch asserted;	}
{	the trade-off is that the files can be	}
{	copied to an RSX system with octal	}
{	file numbers successfully.		}
{						}
{   TRW005					}
{	Collapse the backup_set name.		}
{						}
{   TRW006					}
{	Get rid of the default device name.	}
{						}
{   TRW007					}
{	Add second command parameter to		}
{	specify what directory to place the	}
{	files under.				}
{						}
{   TRW008					}
{	Add /BACKUP_SET qualifier.		}
{						}
{   TRW009					}
{	Fix up stack unwind.			}
{						}
{   TRW010					}
{	Have /BACKUP_SET=* process all backup	}
{	sets on the tape or TPC file.		}
{						}
{   TRW011					}
{	Add a /BRIEF qualifier to the /LIST	}
{	qualifier, causing only backup set	}
{	names to be listed.			}
{						}
{   TRW012					}
{	Add the date of the backup set to the	}
{	backup set header line.			}
{						}
{   TRW013					}
{	Full wildcard support for backup	}
{	set names.				}
{						}
{   Note that none of the foregoing has done	}
{   anything to decrease the hack quotient.	}
{						}
{-----------------------------------------------}

[inherit ('SYS$LIBRARY:STARLET')]
	program bruread (input,output,brudat,tfile,listfile);
Type
  V5000 = Varying [5000] of char;
  ufile = [unsafe] file of char;
  Fname = packed array [1..256] of char;
  String = varying [80] of char;
  FabPointer = ^Fab$type;
  RabPointer = ^Rab$type;
  XabPointer = ^Xab$type;
  NamPointer = ^Nam$type;
  TPointer   = ^FName;
  byte = [byte] 0..255;
  word = [word] 0..65535;

  item = packed record
	siz, typ : word;
	adr : integer;
  end;

{ Map RSX-11M File Header }
{ ----------------------- }

  RsxHeader = packed record
	idof,
	mpof : byte;
	fnum,
	fseq : word;
	flev,
	fstr : byte;
	uicmember,
	uicgroup : byte;
	prot : word;
	ucha,
	scha : byte;

	{ Settable by ATR$C_RECATTR (7 Words) }
	rtyp,
	ratt : byte;
        rsiz : word;
        hibh,
        hibk : word;
        efbh,
        efbk : word;
	ffby : word;

	ufat : packed array [1..9] of word;
	rest : packed array [1..466] of byte;
  end;

  hda  = packed array [1..512] of char;		{ Type cast for RsxHeader }


{ Internal representation of File Header }
{ -------------------------------------- }

  FileHeaderPointer = ^FileHeader;
  FileHeader = [unsafe] record
	bt : integer;				{ Total Blocks }
	name : packed array [1..5] of word;	{ File name in Rad50 }
	directory : packed array [1..6] of char;
	attributes : record			{ User settable attributes }
		artyp,
		aratt : byte;
	        arsiz : word;
	        ahibh,
	        ahibk : word;
	        aefbh,
	        aefbk : word;
		affby : word;
	end;
	dates : record				{ User settable dates }
		arvno : word;				{ revision number }
		arday : packed array [1..2] of char;	{ Revision date }
		armon : packed array [1..3] of char;
		aryea : packed array [1..2] of char;
		arhou : packed array [1..2] of char;
		armin : packed array [1..2] of char;
		arsec : packed array [1..2] of char;

		acday : packed array [1..2] of char;	{ creation date }
		acmon : packed array [1..3] of char;
		acyea : packed array [1..2] of char;
		achou : packed array [1..2] of char;
		acmin : packed array [1..2] of char;
		acsec : packed array [1..2] of char;
	end;
	aesqn : byte;			{ extension sequence number }
	aefnu : word;			{ next extension file number }
	back  : FileHeaderPointer;	{ Backpointer to file header
			  		  whose extension the current one is }
	ause : byte;			{ number of retrieval pointers in use }
	artrv : packed array [1..102] of packed record
		asize : byte;
		albn : integer;
	end;
  end;

  c3 = varying [3] of char;


  SigArr = Array [0..9] of Integer;	{ Signal Array }
  MchArr = Array [0..4] of Integer;	{ Mechanism Array }


  Lptr = ^ListItem;

  ListItem = Record
    Link : Lptr;
    Name : Varying [30] Of Char;
  End;


var

  BRUREAD$_CREATED	 : [external,value] Integer;
  BRUREAD$_FILEPURGED	 : [external,value] Integer;
  BRUREAD$_UPDATED	 : [external,value] Integer;
  BRUREAD$_WORKING	 : [external,value] Integer;
  BRUREAD$_TOTAL	 : [external,value] Integer;
  BRUREAD$_CREDIR	 : [external,value] Integer;
  BRUREAD$_FNF		 : [external,value] Integer;
  BRUREAD$_IVDEV	 : [external,value] Integer;
  BRUREAD$_NOTMOUNTED	 : [external,value] Integer;
  BRUREAD$_NOTFOREIGN	 : [external,value] Integer;

  HeaderPointer : Array [0..65535] Of FileHeaderPointer;

  listfile : text;
  tfile : [unsafe] text;
  fullname : string;
  TapeChannel,
  Channel : word;

  St1, St2,
  Context : integer := 0;
  NumMarks: integer := 0; { Number of tape marks in a row found. }	{TRW010}
  NumSets : integer := 0; { Number of backup sets found in a pass }	{TRW013}
  Listspec,
  Resultspec,
  Bannerspec,								{TRW010}
  Filespec : Varying [80] of char;
  Fab : FabPointer;
  DevInfo : Dev$type;

  FileOpen,
  Tape,
  FlagCopy,
  FlagDebug,
  FlagExclude,
  FlagFull,	{Opposite of /BRIEF}					{TRW011}
  FlagLog,
  FlagList,
  FlagOctal,								{TRW004}
  FlagOutput,								{TRW007}
  FlagSelect,
  FlagTotal,
  FlagZero,								{TRW003}
  FlagRewind : Boolean := False;

{Begin of change==================================}
  FlagHelp ,
  Labelfound : Boolean := False;
  Labelspec  : Varying [12] of char;
{End of change====================================}

  Select,
  Exclude : Lptr := Nil;

  openstat,
  stat: Integer;
  iosb: Packed Array [1..4] of word;

  atrlist : record
    att : packed array [1..2] of item;
    fin : integer
  end := zero;

  brudat : file of V5000;
  CurrentFileHeader : FileHeaderPointer := nil;
  buf : [unsafe,aligned(1)] v5000;
  backup_set : varying [12] of char;
  output_dir : varying [127] of char;					{TRW007}
  backup_date : varying [20] of char;					{TRW012}

  TotalFiles,
  TotalBlocks,
  curr_file,
  b,
  block_size,
  bufpos,
  pos,
  l : integer := 0;

  mode : (undefined,directory,header,data,end_of_file) := undefined;
  dirbuf : [unsafe] packed record
	fnum, fseq, fvol : word;
	fnam : packed array [1..3] of word;
	ftyp, fver : word;
  end;
  dirspec : varying [6] of char;

  fnambuf : [unsafe] packed record
	fnam : packed array [1..3] of word;
	ftyp, fver : word;
	rvno : word;
	rday : packed array [1..2] of char;
	rmon : packed array [1..3] of char;
	ryea : packed array [1..2] of char;
	rhou : packed array [1..2] of char;
	rmin : packed array [1..2] of char;
	rsec : packed array [1..2] of char;

	cday : packed array [1..2] of char;
	cmon : packed array [1..3] of char;
	cyea : packed array [1..2] of char;
	chou : packed array [1..2] of char;
	cmin : packed array [1..2] of char;
	csec : packed array [1..2] of char;

	eday : packed array [1..2] of char;
	emon : packed array [1..3] of char;
	eyea : packed array [1..2] of char;
  end;
  mapbuf : [unsafe] packed record
	esqn,
	ervn : byte;
	efnu,
	efsq : word;
	ctsz,
	lbsz,
	use,
	map : byte;
	rtrv : packed array [1..102] of packed record
		lbnh, Size : byte;
		lbnl : word;
	end;
  end;

  datbuf : [unsafe] packed array [1..8] of record
	fnum : Word;
	lbnh,Size : Byte;
	lbnl : word;
  end;
  Hdrbuf  : RsxHeader;
  hdrflag : boolean := false;
  eofflag : boolean := false;
  rad50 : [readonly] packed array [1..40] of char :=
	 ' ABCDEFGHIJKLMNOPQRSTUVWXYZ$./0123456789';

  line : varying[132] of char;


[External(Lib$Signal)] Function $Signal
      ( %Immed Cond : Integer;
	%Immed Arguments : [List,Unsafe] Integer
      ) : Integer; Extern;

[External(Lib$Stop)] Function $Stop					{TRW008}
      ( %Immed Cond : Integer;						{TRW008}
	%Immed Arguments : [List,Unsafe] Integer			{TRW008}
      ) : Integer; Extern;						{TRW008}

[Asynchronous, External(Lib$Sig_To_Stop)] Function $SigToStop		{TRW009}
      ( Var SigArgs : SigArr;						{TRW009}
	Var MchArgs : MchArr						{TRW009}
      ) : Integer; Extern;						{TRW009}

[Asynchronous] Function Handler
      ( Var SigArgs : SigArr;
	Var MchArgs : MchArr
      ) : Integer;

Begin
  If SigArgs[1] Div 65536 <> 0		{ Not a System Signal }
  Then SigArgs[0] := SigArgs[0]-2;	{ Remove PC, PSL }
  if sigargs[1] <> ss$_unwind then begin				{TRW009}

    Case SigArgs[1] Mod 8 Of
      0,  { Warning }
      1,  { Success }
      3 : { Information } begin						{TRW009}
		Handler := SS$_Continue;				{TRW009}
		$Putmsg ( SigArgs );					{TRW009}
		end;							{TRW009}
      2 : { Error }	begin						{TRW009}
		Handler := SS$_Continue;				{TRW009}
		$Putmsg ( SigArgs );					{TRW009}
		end;							{TRW009}
      Otherwise Begin
	MchArgs[3] := SigArgs[1];					{TRW009}
	$SigToStop (SigArgs, MchArgs);					{TRW009}
      End;
    End;
  End;									{TRW009}
End;

Function VDesc ( Var What : Varying[l] of Char ) : Integer;
Var
  VD : [static] Item; { ** Note: cannot be used twice in a single $signal call }
Begin
  With VD Do Begin
    Siz := What.Length;
    Typ := 0;
    Adr := IAddress (What.body);
  End;
  VDesc := IAddress (VD);
End;

procedure collapse ( a : varying [l1] of char; var b : varying [l2] of char;
	var lng : integer );						{TRW002}
var i : integer;
begin
  b := '';
  for i := 1 to l1 do if a[i] > ' ' then b := b+a[i];			{TRW002}
  lng := length(b);							{TRW002}
  b := pad (b,' ',length(a));
end;

function c5ta ( p : word ) : c3;
var a : c3;
    i : integer;
begin
a := '';
for i := 1 to 3 do begin
  a := rad50 [p mod 40 + 1] + a;
  p := p div 40;
end;
c5ta := a;
end;

Function FindHeader (num:word;FindBase:Boolean := False) : FileHeaderPointer;
Var
  Hd : FileHeaderPointer;
begin
  Hd := HeaderPointer[Num];
  If Hd = Nil Then Begin	{ Not found }
    If FindBase Then Begin	{ Called by open_file }
      Writeln ('*** Fatal, File ID ',oct(num,6,6),' not found');
    End Else Begin
      Hd^.directory := 'EXTEND';	{ Just in case of error }
      New (Hd);
      Hd^ := Zero;
      HeaderPointer[Num] := Hd;
    End;
  End;

{ If File ID refers to an extension file header, search base header }
{ ----------------------------------------------------------------- }

  If FindBase Then While Hd^.back <> nil do Hd := Hd^.Back;
  FindHeader := Hd;
end;

procedure total;
var
  i : integer;
  d,c,s1, s2 : string;
begin
  c := '';
  if FlagCopy then c := 'created ';
  writev (s1,TotalFiles);
  collapse (s1,s1,i);							{TRW002}
  s1.length := i;							{TRW002}
  writev (s2,TotalBlocks);
  collapse (s2,s2,i);							{TRW002}
  s2.length := i;							{TRW002}
  d := s1+' files '+c+'('+s2+' blocks)';
  if FlagList then							{TRW011}
    If FlagFull then							{TRW011}
      begin
      writeln (ListFile); writeln (ListFile,'Total of ',d);
      end								{TRW011}
    Else
      writeln (ListFile, '  Total of ',d)				{TRW011}
  Else begin								{TRW011}
{Begin of change======Bad stringdescriptor passing=======================}
{    writeln; $Signal (BRUREAD$_TOTAL,3,%Descr d );                      }
    writeln; $Signal (BRUREAD$_TOTAL,3,VDesc(d) );
{End of change===========================================================}
  end;
end;

procedure cleanup; { Forget all we have done... }
begin
TotalFiles := 0;
TotalBlocks := 0;
hdrflag := False;
{ FlagRewind := False; }						{TRW010}
end;

procedure rewind; { Rewind tape (or file for that matter ... }		{TRW010}
Begin
If FlagRewind then							{TRW010}
  If tape then begin							{TRW010}
    $qiow ( chan := TapeChannel, func := IO$_REWIND );			{TRW010}
    NumMarks := 0;							{TRW010}
    end									{TRW010}
  Else begin								{TRW010}
    reset (brudat);							{TRW010}
    eofflag := False;							{TRW010}
    end;								{TRW010}
End;

{ Removed the following from procedure Process }			{TRW010}
function check_tape (
	var fab : fab$type;
	var rab : rab$type;
	var f   : text ) : integer;
var
  status : integer;
  chan : [unsafe] packed array [1..2] of word;
begin {user_open}
  with fab do begin
    fab$v_nfs := tape;
    fab$v_ufo := tape;
    fab$v_nil := fab$v_ufo;
    end;
  status := $open (fab);
  if odd (status) then $connect (rab);
  check_tape := status;
  Chan := Fab.Fab$L_STV;
  TapeChannel := chan[1];
  If tape and FlagRewind then begin					{TRW010}
    $qiow ( chan := TapeChannel, func := IO$_REWIND );
    NumMarks := 0;							{TRW010}
    end;								{TRW010}
end;

[external(Lib$Create_Dir)] Function $Create_Dir (
	%DESCR dirspec : string ) : integer; extern;

[external(CLI$GET_VALUE)] function $GetValue
      (	entity_desc : [CLASS_S] packed array [l..u:integer] of char;
	VAR retdesc : [CLASS_S] packed array [l1..u1:integer] of char;
	Var Retlength : word ) : Integer; extern;

[external(CLI$PRESENT)] function $Present
      (	entity_desc : [CLASS_S] packed array [l..u:integer] of char )
      : Boolean; extern;

[external(LIB$FIND_FILE)] function $FindFile
      (	Filespec : [CLASS_S] packed array [l1..u1:integer] of char;
	%descr Resultspec : varying [l2] of char;
	Var Context : integer;
	DefaultSpec : [CLASS_S] packed array [l3..u3:integer] of char := %immed 0;
	RelatedSpec : [CLASS_S] packed array [l4..u4:integer] of char := %immed 0;
	Var StatusValue : integer := %immed 0;
	UserFlags   : integer := %immed 0
      ) : Integer; Extern;

[external(LIB$FIND_FILE_END)] function $FindFileEnd			{TRW007}
      (	Var Context : integer						{TRW007}
      ) : Integer; Extern;						{TRW007}

[external(STR$MATCH_WILD)] function $MatchWild
      (	%Descr CandidateString : varying [l1] of char;
	%Descr PatternString : varying [l2] of char
      ) : Integer; Extern;



procedure close_file;

begin
  If FileOpen Then Begin
    With CurrentFileHeader^ Do If FlagLog Then Begin
      if (openstat = rms$_created) then begin
        $Signal (BRUREAD$_CREATED,4,Vdesc(fullname),bt);
      end else if (openstat = rms$_filepurged) then begin
        $Signal (BRUREAD$_FILEPURGED,4,VDesc(fullname),bt);
      end else begin
        $Signal (BRUREAD$_UPDATED,4,Vdesc(fullname),bt);
      end;
    End;
    close (tfile); { Dummy, damit pascal OTS zufrieden ist }
    FileOpen := False;
    Stat := $qiow (
	chan := Channel,
	func := IO$_DEACCESS,
	iosb := iosb,
	p5   := IADDRESS (Atrlist)
	);
    if not (odd(stat) and odd(iosb[1])) then
      writeln ('Deaccess:',hex(stat),hex(iosb[1]));

    $dassgn (Channel);
  end{If File was open};
  curr_file := 0;
end;

procedure add_to_file ( fnum, b, lbn : integer );

  var
    filename : string;
  procedure open_file;
  var
    allocation : integer;
    function user_open (
	var fab : fab$type;
	var rab : rab$type;
	var f   : text ) : integer;
    var
      status : integer;
      nam : NamPointer;
      chan : [unsafe] packed array [1..2] of word;
      dir : string;
      retried : integer;
    begin {user_open}
      retried := 0;
      repeat
        with fab do begin
          fab$v_bio := true;
          fab$v_ufo := true;
          fab$v_upi := true;
          fab$l_alq := Allocation;
          Nam := fab$L_NAM :: NamPointer;
        end;
        status := $create (fab);
        if not odd(status) then begin
	  if status = rms$_dnf then begin {Directory not found}
	    retried := retried + 1; { Allow one retry after dir created }
	    Writev (Dir,Nam^.Nam$L_DEV :: TPOINTER^ : Nam^.Nam$B_DEV,
  		Nam^.Nam$L_DIR :: TPOINTER^ : Nam^.Nam$B_DIR);
            if $create_dir (Dir) = ss$_created then if FlagLog then
	      $Signal (BRUREAD$_CREDIR, 3, Vdesc(dir));
          end else retried := 2; { Other error - no retry }
        end;
      until odd(status) or (retried = 2);

      if odd (status) then $connect (rab);
      user_open := status;
      openstat := status;
  
      if odd (status) then Writev
	(fullname,Nam^.Nam$L_RSA :: TPOINTER^:Nam^.Nam$B_RSL)
      else fullname := '';
      Chan := Fab.Fab$L_STV;
      Channel := chan[1];
    end;

    Function InList ( List : Lptr; Empty : Boolean ) : Boolean;
    Var
      Found : Boolean;
      Candidate, Pattern : Varying [35] Of Char;
    Begin
      If List = Nil Then InList := Empty Else Begin
	Found := False;
	Candidate := '['+CurrentFileHeader^.directory+']'+FileName;
	Repeat
	  Pattern := List^.Name;
	  If Index (Pattern,'[') = 0 Then Pattern := '[*]'+Pattern;
	  If Index (Pattern,';') = 0 Then Pattern := Pattern+';*';
	  Found := odd ( $MatchWild (Candidate,Pattern) );
	  If Found And FlagDebug
	  Then Writeln ( 'Matched ',Candidate,' with ',List^.Name );
	  List := List^.Link;
	Until Found Or (List=Nil);
	InList := Found;
      End;
    End;

  var									{TRW002}
      i : Integer;							{TRW002}
  begin {open_file}
    if curr_file <> 0 then close_file;
    curr_file := fnum;
    CurrentFileHeader := FindHeader (curr_file,true);
    with CurrentFileHeader^ do begin
      if FlagOctal then							{TRW004}
	writev (filename, c5ta(name[1]), c5ta(name[2]),			{TRW004}
		c5ta(name[3]), '.', c5ta(name[4]), ';',			{TRW004}
		oct (name[5],5,1))					{TRW004}
	else								{TRW004}
	writev (filename,c5ta(name[1]),c5ta(name[2]),c5ta(name[3]),'.',
	  c5ta(name[4]),';',name[5]:5);
      collapse (filename,filename,i);					{TRW002}
      filename.length := i;						{TRW002}
      with attributes do allocation := ahibh * 65536 + ahibk;
      with attributes do if (arsiz = 0) And Not FlagZero then begin	{TRW003}
	Writeln ('*** Warning -- Illegal recordsize 0 encountered. ',	{TRW001}
		'Set to 512.',chr(7));					{TRW001}
	Writeln ('    File is ',output_dir,				{TRW007}
		directory,']',filename);				{TRW001}
	arsiz := 512;
      end;

      if FlagCopy then Begin
	If InList(Select,True) And Not InList(Exclude,False) Then begin
	  FileOpen := True;
	  TotalFiles := TotalFiles + 1;
	  TotalBlocks := TotalBlocks + Allocation;
	  open ( tfile, filename,unknown,
	    default := output_dir+directory+']',
	    user_action := user_open );
	  with atrlist.att[1] do begin
	    siz := 28;
	    typ := atr$c_ascdates;
	    adr := iaddress (DATES);
	  end;

	  with atrlist.att[2] do begin
	    siz := 14;
	    typ := atr$c_recattr;
	    adr := iaddress (attributes);
	  end;
	End;
      end{if copy} Else Begin{Listing}
	TotalFiles := TotalFiles + 1;
	TotalBlocks := TotalBlocks + Allocation;
      End;
    end;
  end;

{ * The BRU data blocks describe logical blocks.
  * Since we deal with files, we must remap the logical blocks
  * to virtual blocks of the current file. (Fortunately BRU has
  * the kindness to tell us to which file the block belongs }

  Function Vbn : Integer;	{ Lbn To Vbn conversion }
  Var
    I,
    Vb : Integer;
    Hd : FileHeaderPointer;
  Begin
    Hd := CurrentFileHeader;
    I := 1;				{ start mapping at 1st mapping pointer }
    Vb := 1;				{ it maps vbn 1 }
    While ( lbn < Hd^.Artrv[i].albn )
       Or ( lbn > Hd^.Artrv[i].albn+Hd^.Artrv[i].asize ) Do Begin
      Vb := Vb + Hd^.Artrv[i].asize + 1;{ calculate the vbn mapped by next ptr }
      i := i + 1;			{ advance index to mapping pointer }
      If i > Hd^.Ause Then Begin	{ if all mapping pointers done...}
	Hd := HeaderPointer[Hd^.aefnu];	{ step to extension file header }
	i := 1;				{ and restart mapping }
      End;
    End;
    Vbn := Vb + ( lbn - Hd^.Artrv[i].albn );
  End;

begin
  if curr_file <> fnum then open_file;
  if FileOpen then begin
    Stat := $qiow (
	chan := Channel,
	func := IO$_WRITEVBLK,
	iosb := iosb,
	p1   := %immed iaddress (buf.body) + bufpos,
	p2   := b*512,
	p3   := vbn
	);
    if not (odd(stat) and odd(iosb[1])) then
      writeln ('File write error: ',hex(stat),hex(iosb[1]),hex(iosb[2]),
		' vbn=',vbn);
  end;

  with CurrentFileHeader^ do bt := bt+b;
end;



Procedure Process;
Var
  ExtensionHeader : FileHeaderPointer;

  procedure ReadTape;
  begin
    if Tape then begin
      if NumMarks > 1 then						{TRW010}
	buf := ''							{TRW010}
      else begin							{TRW010}
	Stat := $qiow (
	  chan := TapeChannel,
	  func := IO$_READVBLK,
	  iosb := iosb,
	  p1   := %immed iaddress (buf.body),
	  p2   := 5000,
	  p3   := 0
	  );
	if odd (stat) and odd (iosb[1]) then				{TRW010}
	  NumMarks := 0							{TRW010}
	else if iosb[1] = SS$_ENDOFFILE then				{TRW010}
	    NumMarks := NumMarks + 1					{TRW010}
	else if iosb[1] = SS$_ENDOFVOLUME then				{TRW010}
	    NumMarks := NumMarks + 2					{TRW010}
	else								{TRW010}
	  writeln ('Tape read error: ',hex(stat),hex(iosb[1]),hex(iosb[2]));
	buf.length := iosb[2];
      end								{TRW010}
    end else begin
      if not eof (brudat) then						{TRW010}
	read (brudat,buf);
      eofflag := eof (brudat);						{TRW010}
    end;
  end;

{Begin of change===============================================================}

  procedure Skipfile;	{ skip to next Tape Mark }
  begin			{ IO$_SKIPFILE function for less CPU-load }
    if Tape then begin
      Stat := $qiow (
	chan := TapeChannel,
	func := IO$_SKIPFILE,
	iosb := iosb,
	p1   := %immed 1
	);
	if odd (stat) and odd (iosb[1]) then				{TRW010}
	  { NumMarks := 0 }						{TRW010}
	else if iosb[1] = SS$_ENDOFFILE then				{TRW010}
	  { NumMarks := NumMarks + 1 }					{TRW010}
	else if iosb[1] = SS$_ENDOFVOLUME then				{TRW010}
	  NumMarks := NumMarks + 2					{TRW010}
	else								{TRW010}
	  writeln ('Tape skipfile error: ',hex(stat),hex(iosb[1]),hex(iosb[2]));
    end
    else repeat Readtape until buf.length = 0 ;
  end;


  function search_label : Boolean;
begin
  Skipfile;
  ReadTape;
  search_label := buf.length <> 0 ;
end;


function read_label : Boolean ;
var
  res : Boolean;
  i : Integer;								{TRW005}
begin
  backup_set := '' ;
  res := search_label ;
  if INDEX(buf,'EOF') = 1 then res := search_label ;
  if INDEX(buf,'HDR') = 1 then res := search_label ;
  if res then								{TRW005}
    begin								{TRW005}
    backup_set := substr(buf,1,12);					{TRW005}
    collapse (backup_set, backup_set, i);				{TRW005}
    backup_set.length := i;						{TRW005}
    i := index (substr (buf, 71, 10), 'DECN') + 56;			{TRW012}
    if (i > 56) then							{TRW012}
      backup_date := substr (buf,i,2) + '-' + substr (buf,i+2,3) +	{TRW012}
	'-' + substr (buf,i+5,2) + ' ' + substr (buf,i+7,2) +		{TRW012}
	':' + substr (buf,i+9,2) + ':' + substr (buf,i+11,2)		{TRW012}
    else backup_date := '';						{TRW012}
    end;								{TRW005}
  if Not FlagOutput then						{TRW007}
    output_dir := '[.' + backup_set + '.';				{TRW007}
  read_label := res ;
end;

function test_label : Boolean ;
var
  i : integer;
  result : Boolean ;
begin
  if labelspec = '' then						{TRW013}
    result := read_label						{TRW013}
  else									{TRW013}
    repeat								{TRW013}
      result := read_label						{TRW013}
      until (not result) or odd ($MatchWild (backup_set, Labelspec));	{TRW013}
  test_label := result ;
end;

{End of change===============================================================}

var									{TRW002}
  i : integer;								{TRW002}
begin { process }

{Begin of change=============================================================}
{ Next lines have been replaced:          }
{  repeat ReadTape until buf.length = 0;  }
{  ReadTape;                              }
{  readv (substr (buf,1,12),backup_set);  }
{ By:                                     }
  Labelfound := test_label ;
  if Labelfound then begin     {Labelfound}

{End of change===============================================================}

  if tape then eofflag := False;					{TRW010}
  NumSets := NumSets + 1;						{TRW013}

  if FlagList then
    If FlagFull then							{TRW011}
      Writeln (listfile,'Directory of Backup Set ',Backup_set,		{TRW012}
		'       ', backup_date)					{TRW012}
    Else								{TRW011}
      Writeln (listfile,'Backup Set Name: ',Backup_set,			{TRW012}
		'       ', backup_date)					{TRW012}
  else
    writeln ('Backup Set Name: ',backup_set,				{TRW012}
		'       ', backup_date);				{TRW012}

  ReadTape; { Boot block }
  ReadTape; { Home block }
  while not eofflag do begin
    ReadTape;
    l := buf.length;
    if l = 80 then begin
      if curr_file <> 0 then close_file;
      mode::byte := (index ('UFDHEADATEOF',substr(buf,1,3)) + 2) div 3;
      case mode of
	header : begin
	  hdrflag := true;
	  if FlagDebug then writeln ('Starting File Headers Section.');
	end;

	directory : begin
	  dirbuf := substr (buf,5,16);
	  with dirbuf do dirspec := c5ta(fnam[1])+c5ta(fnam[2]);
	  if hdrflag then begin
	    mode := header; { Subsequent records are headers }
	    with dirbuf do if FlagFull then begin
		writeln (listfile);
		writeln (listfile,'[',c5ta(fnam[1]),',',c5ta(fnam[2]),']');
		writeln (listfile);
	    end;
	  end;
	end;

	data : if FlagDebug then writeln ('Starting File Data Section.');
	undefined : writeln ('*** Undefined mode ***');
	end_of_file : begin 
	  if FlagTotal then total;
	  eofflag := true;
	end;
      end{case};

    end else if l <> 0 then begin
      case mode of
	undefined : writeln ('*** Undefined mode ***');
	directory : begin {Directory entry}
		pos := 1;
		repeat
		  dirbuf := substr (buf,pos,16);
		  with dirbuf do
		  if fnum = 0 then pos := l + 1
		  else begin
		    pos := pos+16;
		    New (CurrentFileHeader);		{ Create new entry }
		    CurrentFileHeader^ := Zero;
		    HeaderPointer[fnum] := CurrentFileHeader;
		    with CurrentFileHeader^ do begin
			name[1] := fnam[1];
			name[2] := fnam[2];
			name[3] := fnam[3];
			name[4] := ftyp;
			name[5] := fver;
			directory := dirspec.body;
		    end;
		  end;
		until pos >= l;
		end;
	header : begin { File header }
		pos := 1;
		repeat
		  hdrbuf :: hda := substr (buf,pos,512);
		  b := hdrbuf.idof*2+1;		{ Identification area }
		  fnambuf := substr (hdrbuf::hda,b,45);
		  b := hdrbuf.mpof*2+1;		{ Map area }
		  mapbuf := substr (hdrbuf::hda,b,512+1-b);
		  with hdrbuf, fnambuf, mapbuf do begin
		    CurrentFileHeader := FindHeader (fnum);
		    with CurrentFileHeader^ do begin
		      with attributes do begin
			artyp := rtyp;
			aratt := ratt;
		        arsiz := rsiz;
		        ahibh := hibh;
		        ahibk := hibk;
		        aefbh := efbh;
		        aefbk := efbk;
			affby := ffby;
		      end;
		      with dates do begin
			arvno := rvno;
			arday := rday;
			armon := rmon;
			aryea := ryea;
			arhou := rhou;
			armin := rmin;
			arsec := rsec;

			acday := cday;
			acmon := cmon;
			acyea := cyea;
			achou := chou;
			acmin := cmin;
			acsec := csec;
		      end;
		      aesqn := esqn;	{ Ext. sequence number }
		      aefnu := efnu;	{ Ext. file number }
		      if efnu <> 0 Then Begin
			ExtensionHeader := FindHeader (efnu);
			ExtensionHeader^.Back := CurrentFileHeader;
		      End;
		      ause := use div 2;	{ Number of pointers in use }
		      For b := 1 To Ause Do With Artrv[b],rtrv[b] Do Begin
			asize := Size;
			albn := lbnh*65536+lbnl;
		      End;
		    End;

		    if FlagOctal then					{TRW004}
			writev (line, c5ta(fnam[1]), c5ta(fnam[2]),	{TRW004}
			c5ta(fnam[3]), '.', c5ta(ftyp), ';',		{TRW004}
			oct (fver,5,1))					{TRW004}
		    else						{TRW004}
		      writev (line, c5ta(fnam[1]), c5ta(fnam[2]),
			c5ta(fnam[3]), '.', c5ta(ftyp),';',fver:5);
		    collapse (line,line,i);				{TRW002}
		    If FlagFull then write (listfile,line,'  ');
		    block_size := hibh*65536+hibk;
		    writev (line,block_size:7,'. '); 
		    collapse (line,line,i);				{TRW002}
		    if FlagFull then writeln (listfile,line,
			cday,'-',cmon,'-',cyea,' ',chou,':',cmin,':',csec);
		  end;
		  pos := pos+512;
		until pos >= l;
		end;
	data : begin
		datbuf := substr (buf,1,48);
		pos := 0;
		bufpos := 48;
		repeat
		  pos := pos + 1;
		  with datbuf[pos] do
		  if fnum = 0 then pos := 8
		  else begin
		    add_to_file (fnum, size+1, lbnh*65536+lbnl);
		    bufpos := bufpos + (size+1)* 512;
		  end;
		until pos = 8;
		end;
      end{case};
  end;
  end;
  repeat
    ReadTape;
    if FlagDebug then writeln (buf:10,buf.length)
  until buf.length = 0;
  end; {Labelfound===========================================================}  

Cleanup; { Remove all 'CurrentFileHeader' entries }			{TRW010}

End{Process};

{Begin of change=========================================================}
Procedure Helplist ;             { Type HELP-text on screen              }
begin                                                                  { }
  $GetValue ('HELP',Listspec.body, Listspec.length);                   { }
  open (listfile,listspec,readonly);                                   { }
  reset (listfile);                                                    { }
  St1 := 0;                                                            { }
  while not eof (listfile) do begin                                    { }
    readln(listfile,line);                                             { }
    writeln(line);                                                     { }
    St1 := St1 + 1;                                                    { }  
    If St1 = 22 then begin                                             { }
      writeln; write('<CR> to continue.');                             { }   
      readln ;                                                         { }
      St1 := 0;                                                        { }
    end;                                                               { }
  end;                                                                 { }
close (listfile);                                                      { }
end;                                                                   { }
{End of change========================================================== }


Function GetList ( What : Packed Array [l..u:integer] Of Char; Var List : Lptr )
	: Boolean;
Var
  FileSpec : Varying [30] Of Char;
  Next : LPtr;
Begin
  GetList := False;
  If $Present ( What ) Then Begin
    GetList := True;
    List := Nil;
    While Odd ( $GetValue (What,FileSpec.body, FileSpec.length) ) Do Begin
      If List = Nil Then Begin
	New (List);
	Next := List;
      End Else Begin
	New (Next^.Link);
	Next := Next^.Link;
      End;
      With Next^ Do Begin
	Link := Nil;
	Name := FileSpec;
      End;
    End;
  End;
End;


Begin {Main}
  Establish ( Handler );
  FlagExclude := GetList  ('EXCLUDE',Exclude);
  FlagCopy    := $Present ('COPY');
  FlagDebug   := $Present ('DEBUG');
  FlagFull    := not $Present ('BRIEF');				{TRW011}
  FlagLog     := $Present ('LOG');
  FlagList    := $Present ('LIST');
  If not FlagList then FlagFull := False;				{TRW011}
  FlagOctal   := $Present ('OCTAL');					{TRW004}
  FlagRewind  := $Present ('REWIND');
  St1         := $GetValue ('OUTPUT', output_dir.body,			{TRW007}
			output_dir.length);				{TRW007}
  if odd (St1) then begin						{TRW007}
    FlagOutput := True;							{TRW007}
    St1 := $FindFile (output_dir, Resultspec, Context, UserFlags := 2);	{TRW007}
    if odd (St1) then							{TRW007}
	output_dir := substr (Resultspec, 1,				{TRW007}
		INDEX (Resultspec, ']') - 1) + '.'			{TRW007}
      else if ((St1 = rms$_fnf) or (St1 = rms$_dnf)) and		{TRW007}
		(substr (Resultspec, Resultspec.length-2, 3) = '].;')	{TRW007}
		then							{TRW007}
	output_dir := substr (Resultspec, 1,				{TRW007}
		INDEX (Resultspec, ']') - 1) + '.'			{TRW007}
      else begin							{TRW007}
	writeln ('*** Warning -- Directory ', output_dir,		{TRW007}
		' not found. Using default.');				{TRW007}
	FlagOutput := False;						{TRW007}
        end;								{TRW007}
    St1 := $FindFileEnd (Context);					{TRW007}
    end;								{TRW007}
  FlagSelect  := GetList  ('SELECT',Select);
  St1         := $GetValue ('TAPE', Filespec.body, Filespec.length);	{TRW008}
  FlagTotal   := $Present ('TOTAL');
  FlagZero    := $Present ('ZERO');					{TRW003}
  FlagHelp    := $Present ('HELP');   { HELP-qualifier added ============}
  If FlagList then FlagCopy := False; { Remove default }

{Begin of change=========================================================}
  If FlagHelp then HelpList                                            { }
  else begin                                         { not command /HELP }
{End of change===========================================================} 

    St1 := $FindFile (Filespec, Resultspec, Context, '.TPC',		{TRW008}
		UserFlags := 2);					{TRW008}
    if not odd (St1) then begin						{TRW008}
      $Signal (BRUREAD$_FNF, 1, VDesc(ResultSpec));			{TRW008}
      $Stop (St1);							{TRW008}
      end;								{TRW008}

    fab := Context :: FabPointer;
    DevInfo := fab^.fab$L_DEV :: Dev$Type;
    with devinfo do begin
      if not DEV$V_FOD then $Stop (BRUREAD$_IVDEV)			{TRW010}
      else if not DEV$V_MNT then $Stop (BRUREAD$_NOTMOUNTED)		{TRW010}
      else if dev$v_sqd and not dev$v_for then				{TRW010}
		$Stop (BRUREAD$_NOTFOREIGN);				{TRW010}
      Tape := dev$v_sqd;						{TRW010}
      end;								{TRW010}

    if tape then							{TRW010}
      BannerSpec := substr (Resultspec, 1, INDEX (Resultspec, ':'))	{TRW010}
      else								{TRW010}
      BannerSpec := Resultspec;						{TRW010}
    $Signal (BRUREAD$_WORKING, 1, VDesc(BannerSpec));			{TRW010}
    eofflag := false;							{TRW010}
    open (brudat, ResultSpec, old, user_action := check_tape );		{TRW010}
    If not tape then reset (brudat);					{TRW010}

    If FlagList then begin
      $GetValue ('LIST', Listspec.body, Listspec.length);
      open (listfile, listspec, new, default := '.LIS');
      rewrite (listfile);
      end;

    St1 := $GetValue ('BACKUP_SET', Labelspec.body, Labelspec.length);	{TRW008}
    if not odd (St1) then Labelspec := '';				{TRW008}
    St1 := 1;								{TRW008}
    while odd (St1) do begin						{TRW008}

      Rewind;	{ Rewind tape or file if /REWIND specified. }		{TRW010}

      NumSets := 0;	{ Reset number of backup sets found }		{TRW013}

      If (index (Labelspec, '*') > 0) or				{TRW013}
	 (index (Labelspec, '%') > 0) then				{TRW013}
	Repeat								{TRW010}
	  Process							{TRW010}
	  Until not LabelFound						{TRW010}
      Else								{TRW010}
	Process;							{TRW010}

      if NumSets <= 0 then						{TRW013}
	writeln('Label: ',Labelspec,' not found!');			{TRW010}

      St1 := $GetValue ('BACKUP_SET', Labelspec.body, Labelspec.length);{TRW008}
      end;								{TRW008}

    close (Brudat);							{TRW010}
    If tape then $dassgn (TapeChannel);					{TRW010}

    St1 := $FindFileEnd (Context);					{TRW008}
  end;  {===command not /HELP================================================}
end.