Trailing-Edge
-
PDP-10 Archives
-
decuslib20-09
-
decus/20-183/ansimt.pas
There are no other files named ansimt.pas in the archive.
{ }
{ A N S I M T . P A S L O G - }
{ }
{ }
{ Revision 85/07/85 10:00:00 Nelson Kanemoto }
{ Modified to run with new version of Rutgers Pascal. Modifications }
{ were passing constants by value by removing the 'var' off the fol- }
{ lowing procedures: scopy, ctoi, GarbageErr, and WarnMess. }
{ }
{ Installation 85/03/08 12:45:00 Nelson Kanemoto }
{ Latest version installed in PS:<UHCCSYS-SUBSYS> }
{ }
{ Revision 85/02/15 12:00:00 Nelson Kanemoto }
{ Added warning messages for EBCDIC and DEC-20 labelled tapes for }
{ the TAPE command. }
{ }
{ Installation 85/01/17 10:45:00 Nelson Kanemoto }
{ Latest version installed in PS:<UHCCSYS-SUBSYS> }
{ }
{ Revision 85/01/15 16:00:00 Nelson Kanemoto }
{ Installed a modified ansimt.doc into doc:, with modifications on }
{ wildcards for the STORE and RESTORE commands }
{ }
{ Revision 85/01/09 12:00:00 Nelson Kanemoto }
{ Restore command with wildcards is now working, but changed bits }
{ in gjgen in ParseRestore1. }
{ }
{ Revision 84/12/26 14:00:00 Nelson Kanemoto }
{ Started working on procedure RestoreFile by extracting from }
{ ProcessRestore. }
{ }
{ Revision 84/12/26 13:00:00 Nelson Kanemoto }
{ Working on wildcards for the restore command, modifying procedures }
{ ParseRestore1 and ParseDiskOutput2, and adding in procedure }
{ ParseDirOutput2. }
{ }
{ Revision 84/11/29 15:00:00 Nelson Kanemoto }
{ Wildcards are working for the store command, doing simple testing }
{ }
{ Revision 84/10/29 15:00:00 Nelson Kanemoto }
{ Moved the storing part of ProcessStore to StoreFile to make way }
{ for handling wildcards. Compiled and executed new version, but }
{ didn't test it on storing files. }
{ }
{ Installation 84/10/29 14:40:00 Nelson Kanemoto }
{ Updated ANSIMT.DOC, ANSIMT.HLP, and ANSIMT.EXE then installed them }
{ to their proper locations (DOC:, HLP:, PS:<UHCCSYS-SUBSYS>). }
{ }
{ Revision 84/10/25 13:45:00 Nelson Kanemoto }
{ Fixed bug in procedure ParseDiskOutput2. If someone added tape }
{ parameters to the tape file spec, it wouldn't return the intended }
{ error message. That's fixed now. }
{ }
{ Revision 84/09/25 15:30:00 Nelson Kanemoto }
{ Added in an option to turn warning messages off and on in the }
{ default command. Also added a no option in the default command }
{ instead of "no-". }
{ }
{ Revision 84/09/25 14:00:00 Nelson Kanemoto }
{ Program now automatically sets the default data mode to industry }
{ compatible and returns to original data mode when it exits }
{ }
{ Revision 84/09/24 14:30:00 Nelson Kanemoto }
{ Got rid of ^A in ANSIMT heading. }
{ }
{ Installation 84/09/20 16:00:00 Nelson Kanemoto }
{ Latest version installed in PS:<UHCCSYS-SUBSYS> }
{ }
{ Revision 84/09/20 14:00:00 Nelson Kanemoto }
{ Added in procedure to print ANSIMT heading. }
{ }
{ Revision 84/09/19 15:00:00 Nelson Kanemoto }
{ corrected directory command to handle files w/ incorrect record }
{ lengths and modified /FULL directory listing for 'U' format tape }
{ files. }
{ }
program ANSIMT_TapeUtility;
include 'sys:pascmd.pas';
const
DEFBLKFAC = '1 ';
DEFRECLEN = '80';
DEFTABNO = '8 ';
MAXFNAME = 39;
MAXBLKLEN = 32760; {IBM max}
MAXRECLEN = 2048; {ANSI standard}
MAXSTR = 80;
MINRECLEN = 18; {ANSI standard}
{pascmd parsing}
{-CmdTable}
DIR = 1;
DEF = 2;
EOT = 3;
XIT = 4;
SKIP = 5;
STORE = 6;
RESTORE = 7;
REWIND = 8;
TAPE = 9;
HELP = 11;
LASTCMD = 11;
{-Sw1Table}
S1BLOCK = 1;
S1NOPAD = 2;
S1RECLN = 3;
S1TABEV = 4;
LASTSW1 = 4;
{-Sw2Table}
S2NOSTR = 5;
S2STRIP = 6;
LASTSW2 = 2;
{-Sw3Table, switches for directory command}
S3FULL = 1;
S3SHORT = 2;
LASTSW3 = 2;
{-DefTable, uses above switches}
DFWARN = 1;
DFTABEV = 2;
DFSTRIP = 3;
DFRECLN = 4;
DFNOSWI = 5;
DFBLOCK = 6;
LASTDEF = 6;
LASTNO = 3; {no options}
{JSYS monitor calls}
GETER = 12B; {returns most recent error condition}
OPENF = 21B;
CLOSEF = 22B;
JFNS = 30B;
MTOPR = 77B;
{ASCII in decimal}
NULL = 0;
TAB = 9;
LF = 10; {linefeed}
CR = 13; {carriage return}
BLANK = 32;
type
DevicesType = (DiskDev, TapeDev, TTYDev, ErrDev);
DesigType = (JFNDes, DevDes);
DirectoryType = (FullDir, ShortDir);
WordSetType = set of 0..35; {represents a 36bit word}
DateStrType = packed array [1..9] of char;
StrType = packed array [1..MAXSTR] of char;
FNameType = packed array [1..MAXFNAME] of char;
var
device : integer;
command : integer;
FilesToSkip : integer;
OriginalDataMode : integer;
DefaultRecLen, DefaultBlkFac, DefaultTabNo : integer;
GlobalRecLen, GlobalBlkFac, GlobalTabNo : integer;
HoldRecLen, HoldBlkFac, HoldTabNo : integer;
ThatsIt : boolean;
GlobalPadTabs, DefaultPadTabs, HoldPadTabs : boolean;
GlobalWarning, DefaultWarning, HoldWarning : boolean;
GlobalStripBlanks, DefaultStripBlanks, HoldStripBlanks : boolean;
GlobalDirectory, DefaultDirectory, HoldDirectory : DirectoryType;
GlobalTapeFile, GlobalTape, HoldTape : FNameType;
GlobalDiskFile, GlobalDirStr : StrType;
CmdTable, DefTable, NoTable, Sw1Table, Sw2Table, Sw3Table: table;
function curjfn(var f : file) : integer; extern;
function erstat(var f : file) : integer; extern;
procedure analysis(var f : file); extern;
procedure clreof(var f : file); extern;
procedure quit; extern;
{ StrEnd -- marks the end of string w/ a null character. If end }
{ position, SEnd, is out of bounds then the end is not marked. }
procedure StrEnd(var s : packed array [i..j:integer] of char;SEnd : integer);
var
pos : integer;
begin
pos := SEnd - (i - 1); {actual index in string}
if (pos >= i) and (pos <= j) then
s[pos] := chr(NULL);
end; {of procedure StrEnd}
{ StrPos -- returns the position of a character in a string. 0 is }
{ returned if the character is not found. }
function StrPos(var s : packed array [i..j:integer] of char;c : char) : integer;
var
pos : integer;
found : boolean;
begin
pos := i - 1;
StrPos := 0; found := false;
while (pos < j) and not found do begin
pos := pos + 1;
if (s[pos] = c) then begin
StrPos := pos;
found := true;
end; {of if}
end; {of while}
end; {of function StrPos}
{ StrLen -- returns the length of string s which is marked by the }
{ null character }
function StrLen(var s : packed array [i..j:integer] of char) : integer;
var
pos : integer;
begin
pos := StrPos(s,chr(NULL));
if (pos <> 0) then
StrLen := pos - 1
else
StrLen := j - (i - 1); {length of array, s}
end; {of function StrLen}
{ itoc -- converts integer n to char string in s[i]... }
function itoc(n : integer; var s : StrType ; i : integer) : integer;
begin
if (n < 0) then begin
s[i] := '-';
itoc := itoc(-n,s,i+1);
end {of if}
else begin
if (n >= 10) then
i := itoc(n div 10,s,i);
s[i] := chr(n mod 10 + ord('0'));
StrEnd(s,i+1);
itoc := i + 1;
end; {else}
end; {of function itoc}
{ ctoi -- convert char string at s[i] to integer }
function ctoi(s : packed array [SMin..SMax : integer] of char;
i : integer) : integer;
var
n, sign : integer;
begin
while (s[i] = ' ') or (s[i] = chr(TAB)) do
i := i + 1;
if (s[i] = '-') then {minus sign}
sign := -1
else
sign := 1;
if (s[i] = chr(ord('+'))) or (s[i] = chr(ord('-'))) then
i := i + 1;
n := 0;
while (i <= SMax) do
if (s[i] in ['0'..'9']) then begin
n := 10 * n + (ord(s[i]) - ord('0'));
i := i + 1;
end {of if}
else
i := SMax + 1; {force out}
ctoi := sign * n;
end; {of function ctoi}
{ scopy -- copy string at src[i] to dest[j] }
procedure scopy( src : packed array [SMin..SMax : integer] of char;
i : integer;
var dest : packed array [DMin..DMax : integer] of char;
j : integer);
begin
while (i <= SMax) and (j <= DMax) do
if (src[i] <> chr(NULL)) then begin
dest[j] := src[i];
i := i + 1;
j := j + 1;
end
else {force it to stop if hits the end of string}
i := SMax + 1; {end the while loop}
if (j <= DMax) then
StrEnd(dest,j);
end; {of procedure scopy}
{ InToStrDate -- converts a date i in internal format to a string }
{ of 9 chars in DD-Mmm-YY format }
procedure InToStrDate(i : integer;var str : DateStrType);
const
ODTIM = 220B;
begin
jsys(ODTIM;str,i,000400000000B);
end; {of procedure InToStrDate}
{ TabPos -- return true if col is a tab stop }
function TabPos(col : integer) : boolean;
begin
if (col > MAXRECLEN) then
TabPos := true
else
TabPos := (col mod GlobalTabNo = 1);
end; {of function TabPos}
{ ErrorMess -- prints the last error in the buffer than goes back }
{ for a reparse }
procedure ErrorMess;
begin
cmerrmsg; {print official error message}
cmagain; {reissue prompt}
end; {of procedure ErrorMess}
{ WarnMess -- prints the given string as an official warning message }
{ (beginning w/ an '%') }
procedure WarnMess(s : packed array [i..j : integer] of char);
begin
if DefaultWarning then
writeln(tty,'%',s:StrLen(s));
end; {of procedure WarnMess}
{ ClearDataError -- if the device has a data error it is cleared }
procedure ClearDataError(var f : file);
const
GDSTS = 145B; {device status}
SDSTS = 146B; {sets device status}
INCORRECT_RECLN = 23;
var
StatusBits, DummyBits : WordSetType;
i : integer;
begin
jsys(GDSTS;0:f;DummyBits,StatusBits);
if (INCORRECT_RECLN in StatusBits) then begin {data error}
StatusBits := StatusBits - [INCORRECT_RECLN];
jsys(SDSTS;0:f,StatusBits);
end; {of if}
end; {of procedure ClearDataError}
{ FileOpen -- returns true if file is open }
function FileOpen(var f : file) : boolean;
const
GTSTS = 24B; {file status}
FILE_IS_OPEN = 0;
var
StatusBits, DummyBits : WordSetType;
begin
jsys(GTSTS;0:f;DummyBits,StatusBits);
if (FILE_IS_OPEN in StatusBits) then
FileOpen := true
else
FileOpen := false;
end; {of function FileOpen}
function OpenInputFile(dev : DevicesType) : boolean;
var
FileSpec : StrType;
begin
if (dev = DiskDev) then
reset(input,'','/e/o')
else if (dev = TTYDev) then begin
jsys(JFNS;FileSpec,0:input,0);
reset(input,'','/e/o/i');
end; {of else if}
if (erstat(input) <> 0) then begin
analysis(input);
if (dev = TapeDev) then
if FileOpen(input) then
ClearDataError(input);
if FileOpen(input) then
close(input);
OpenInputFile := false;
end {of if}
else
OpenInputFile := true;
end; {of function OpenInputFile}
function OpenInputTape : boolean;
const
DATAERR = 600221B;
BIGREC = 601240B;
var
message : StrType;
begin
reset(input,'','/d/o/m:7');
if (erstat(input) <> 0) then begin
if (erstat(input) = DATAERR) or (erstat(input) = BIGREC) then begin
jsys(JFNs;message,0:input,0);
scopy(' not able to be restored',1,message,StrLen(message)+1);
WarnMess(message);
if FileOpen(input) then
ClearDataError(input);
if FileOpen(input) then {if it is still open}
close(input);
OpenInputTape := False;
end {of if}
else begin
analysis(input);
if FileOpen(input) then
ClearDataError(input);
if FileOpen(input) then {if it is still open}
close(input);
OpenInputTape := False;
cmagain;
end {of else}
end {of if}
else
OpenInputTape := True;
end; {of procedure OpenInputTape}
function OpenOutputDisk : boolean;
begin
rewrite(output,GlobalDiskFile,'/o');
if (erstat(output) <> 0) then begin
analysis(output);
OpenOutputDisk := false;
end {of if}
else
OpenOutputDisk := true;
end; {of function OpenOutputDisk}
function OpenOutputTape(var TapeFile : FNameType) : boolean;
const
TFORM = ';FOR:F'; {tape format, always fixed}
TRECL = ';REC:'; {tape rec length}
TBLKS = ';BLO:'; {tape block size}
TOPTIONS = '/B:8/O';
var
i : integer;
FileSpec : StrType;
begin
scopy(TapeFile,1,FileSpec,1);
scopy(TFORM,1,FileSpec,StrLen(FileSpec)+1);
scopy(TRECL,1,FileSpec,StrLen(FileSpec)+1);
i := itoc(GlobalRecLen,FileSpec,StrLen(FileSpec)+1);
scopy(TBLKS,1,FileSpec,StrLen(FileSpec)+1);
i := itoc(GlobalBlkFac*GlobalRecLen,FileSpec,StrLen(FileSpec)+1);
rewrite(output,FileSpec,TOPTIONS);
if (erstat(output) <> 0) then begin
analysis(output);
write(tty,' - "',FileSpec:StrLen(FileSpec),'"');
OpenOutputTape := false;
end {of if}
else
OpenOutputTape := true;
end; {of function OpenOutputTape}
{ KindOfDevice -- returns the what kind of device is associated w/ }
{ the file. }
function KindOfDevice(des : integer;TypeOfCall : DesigType) : DevicesType;
const
DVCHR = 117B;
var
ac1, ac2, TypeOfDev : WordSetType;
begin
case TypeOfCall of
JFNDes : jsys(DVCHR;0:des;ac1,ac2); {call using file JFN}
DevDes : jsys(DVCHR;des;ac1,ac2); {call using dev designator}
end; {of case des}
TypeOfDev := ac2 and [9..17]; {mask the dev type bits}
if (TypeOfDev = []) then {disk file}
KindOfDevice := DiskDev
else if (TypeOfDev = [14,16]) then {tty}
KindOfDevice := TTYDev
else if (TypeOfDev = [16]) then {tape file}
KindOfDevice := TapeDev
else
KindOfDevice := ErrDev;
end; {of function KindOfDevice}
{ space -- spaces n number of blanks to the terminal. }
procedure space(n : integer);
begin
for n := n downto 1 do
write(tty,' ');
end; {of procedure space}
{ GarbageErr -- outputs to dev tty: garbage that was entered as }
{ part of the command. }
procedure GarbageErr(mess : packed array [i..j:integer] of char;
garb : packed array [k..l:integer] of char);
var
MessLen : integer;
begin
writeln(tty);
write(tty,'? ',mess:StrLen(mess));
write(tty,' - ');
write(tty,garb:StrLen(garb));
writeln(tty);
cmagain;
end; {of procedure GarbageErr}
{ GetJobDataMode -- uses jsys GETJI and returns the default magtape }
{ data mode of the current job }
function GetJobDataMode : integer;
const
GETJI = 507B;
var
return : integer;
p : ^integer;
begin
new(p);
jsys(GETJI,2,return;-1,-1:p,14B);
if (return = 1) then
ErrorMess
else
GetJobDataMode := p^;
end; {of function GetJobDataMode}
{ SetJobDataMode -- sets data mode of the current job }
procedure SetJobDataMode(DataMode : integer);
const
SETJB = 541B; {sets job para for the specified job}
SJDM = 2B; {func of SETJB to set def mt data mode}
CURRENT_JOB = -1;
begin
jsys(SETJB;CURRENT_JOB,SJDM,DataMode);
end; {of procedure SetJobDataMode}
{ DirHeading -- prints the heading for the tape directory }
procedure DirHeading;
begin
{1st line}
space(33);
write(tty,'RECORD');
space(1);
write(tty,'BLOCK');
space(3);
if (GlobalDirectory = FullDir) then begin
space(1);
write(tty,'# OF');
space(2);
write(tty,'EST.');
space(2);
end; {of if}
space(1);
write(tty,'CREATE');
space(4);
write(tty,'EXPIRE');
writeln(tty);
{2nd line}
write(tty,'SEQ#');
space(6);
write(tty,'FILE NAME');
space(5);
write(tty,'VOLID');
space(2);
write(tty,'F');
space(1);
write(tty,'LENGTH');
space(1);
write(tty,'FACTOR');
space(2);
if (GlobalDirectory = FullDir) then begin
space(1);
write(tty,'RECS.');
space(1);
write(tty,'PAGES');
space(1);
end; {of if}
space(2);
write(tty,'DATE');
space(6);
write(tty,'DATE');
writeln(tty);
{3rd line}
writeln(tty);
end; {of procedure DirHeading}
{ GetDeviceJFN -- gets the jfn for the defined tape divice }
procedure GetDeviceJFN;
const
SGTJFN = 20B; {short form GTJFN}
var
DevStore, return : integer;
DevStr : FNameType;
begin
DevStr := GlobalTape;
DevStr[StrLen(DevStr)+1] := ':'; {put a ':' at the end of string}
StrEnd(DevStr,StrPos(DevStr,':')+1);
jsys(SGTJFN, 3, return;100001b:0, DevStr;DevStore);
if (return = 1) then
ErrorMess;
device := DevStore;
end; {of procedure GetDeviceJFN}
{ TapeInfo -- calls MTOPR to find information about the current }
{ tape device }
function TapeInfo(InfoNo : integer) : integer;
const
MOINF = 25B;
MAXINFO = 15B;
type
ArgBlkType = packed array [0..MAXINFO] of integer;
var
ArgPtr : ^ArgBlkType;
begin
new(ArgPtr);
ArgPtr^[0] := MAXINFO;
GetDeviceJFN;
jsys(MTOPR;0:device, MOINF, ArgPtr);
TapeInfo := ArgPtr^[InfoNo];
end; {of function TapeInfo}
{ TapeStatus -- returns status bits for user io }
procedure TapeStatus(var accum2 : WordSetType);
const
GDSTS = 145B;
var
accum1, return : integer;
begin
GetDeviceJFN;
jsys(OPENF, 2, return;0:device, 100000200000B); {8bit, w/ read access}
if (return = 1) then
ErrorMess;
jsys(GDSTS;0:device;accum1, accum2);
jsys(CLOSEF, 2, return;001000:device);
if (return = 1) then
ErrorMess;
end; {of procedure TapeStatus}
{ BeginningOfTape -- returns true if tape is at bot }
function BeginningOfTape : boolean;
const
BOTBIT = 24;
var
StatBits : WordSetType;
begin
TapeStatus(StatBits);
if (BOTBIT in StatBits) then
BeginningOfTape := true
else
BeginningOfTape := false;
end; {of function BeginningOfTape}
{ TapeFileInfo -- prints out tape file info. If the SeqNo passed }
{ is negative then the no. of records and the estimated pages are }
{ suppressed in the /FULL switch }
procedure TapeFileInfo(SeqNo : integer);
const
MORLI = 50B;
ARGS = 15B;
UNDEFINED = 'U'; {undefined record format}
type
BitsAndPtrType = record
case boolean of
true : (ptr : ^FNameType);
false: (bits : WordSetType)
end;
ArgBlkType = record
ArgWords : integer;
TypeOfLabel : integer;
p1 : ^FNameType;
p2 : ^FNameType;
TapeFormat : integer;
RecLen : integer;
BlkLen : integer;
CreateDate : integer;
ExpireDate : integer;
p3 : ^FNameType;
generation : integer;
version : integer;
ModeVal : integer;
end; {of record}
var
i : integer;
BadRead : boolean; {record is unreadable}
VolName, OwnName, FilName : BitsAndPtrType;
DateStr : DateStrType;
ArgBlkPtr : ^ArgBlkType;
{ FullInformation -- prints the record length and est. pages info }
{ for tape files }
procedure FullInformation(RecLen : integer);
var
nl, EstPages : integer;
begin
nl := 0;
while not eof do begin {count # of lines}
readln;
nl := nl + 1;
end; {of while}
{calculate estimated pages}
if ((RecLen * nl) mod (512 * 5) = 0) then
EstPages := (RecLen * nl) div (512 * 5)
else
EstPages := ((RecLen * nl) div (512 * 5)) + 1; {add a page}
write(tty,nl:6);
space(1);
write(tty,EstPages:5);
space(1);
end; {of procedure FullInformation}
begin
if (SeqNo < 0) then begin
BadRead := true;
SeqNo := -SeqNo; {set back to positive}
end
else
BadRead := false;
new(ArgBlkPtr);
with ArgBlkPtr^ do begin
ArgWords := ARGS;
new(VolName.ptr);
VolName.bits := VolName.bits or [0..17];
p1 := VolName.ptr;
new(OwnName.ptr);
OwnName.bits := OwnName.bits or [0..17];
p2 := OwnName.ptr;
new(FilName.ptr);
FilName.bits := FilName.bits or [0..17];
p3 := FilName.ptr;
jsys(MTOPR;0:input,MORLI,ArgBlkPtr);
{formatted output to tty}
write(tty,SeqNo:4);
space(2);
write(tty,FilName.ptr^:StrLen(FilName.ptr^));
space(17-StrLen(FilName.ptr^));
space(1);
write(tty,VolName.ptr^:StrLen(VolName.ptr^));
space(6-StrLen(VolName.ptr^));
space(1);
write(tty,chr(TapeFormat):1);
space(2);
if (chr(TapeFormat) = UNDEFINED) then begin
if (RecLen = 0) then {no such thing as rec len 0}
RecLen := 1;
write(tty,BlkLen:5); {actually prints as Rec Len}
space(2);
write(tty,RecLen:5);
end {of if}
else begin
write(tty,RecLen:5);
space(2);
write(tty,(BlkLen div RecLen):5);
end; {of else}
space(2);
if (GlobalDirectory = FullDir) then
if BadRead then {cannot read records}
write(tty,' -- -- ') {fill in info}
else
FullInformation(RecLen);
InToStrDate(CreateDate,DateStr);
write(tty,DateStr:9);
space(1);
if (ExpireDate = -1) then
write(tty,' Invalid ')
else begin
InToStrDate(ExpireDate,DateStr);
write(tty,DateStr:9);
end; {of else}
writeln(tty);
end; {of with}
{get rid of junk}
dispose(ArgBlkPtr);
dispose(VolName.ptr);
dispose(OwnName.ptr);
dispose(FilName.ptr);
end; {of procedure TapeFileInfo}
{ TrapEOT -- returns true if defined device is at end of tape }
function TrapEOT : boolean;
const
LOGEOT = 602240B; {logical eot encountered}
type
IOrBType = record
case boolean of
true : (int : integer);
false: (bits : WordSetType)
end; {of record}
var
ac1, ac2 : integer;
Ac2Store : IOrBType;
begin
jsys(GETER;400000B;ac1,ac2);
with Ac2Store do begin
int := ac2;
bits := (bits and [18..35]); {clear 1st half}
if (int = LOGEOT) then
TrapEOT := true
else
TrapEOT := false;
end; {of with}
end; {of function TrapEOT}
{ ForwardFile -- calls mtopr to skip forward 1 logical file }
procedure ForwardFile;
const
MOFWF = 16B;
var
return : integer;
begin
GetDeviceJFN;
jsys(OPENF, 2, return;0:device, 100000200000B); {8bit, w/ read access}
if (return = 1) then
ErrorMess;
jsys(MTOPR,-2,return;0:device, MOFWF);
if (return = 3) then begin
cmerrmsg; {print official error message}
jsys(CLOSEF, 2, return;001000:device);
if (return = 1) then
cmerrmsg;
cmagain;
end {of begin}
else begin
jsys(CLOSEF,2,return;001000:device);
if (return = 1) then
ErrorMess;
end; {of begin}
end; {of procedure ForwardFile}
{ BackwardFile -- calls mtopr to skip backward 1 logical file }
procedure BackwardFile;
const
MOBKF = 17B;
var
return : integer;
begin
GetDeviceJFN;
jsys(OPENF, 2, return;0:device, 100000200000B); {8bit, w/ read access}
if (return = 1) then
ErrorMess;
jsys(MTOPR;0:device, MOBKF);
jsys(CLOSEF,2,return;001000:device);
if (return = 1) then
ErrorMess;
end; {of procedure BackwardFile}
{ RewindTape -- rewinds tape to bot }
procedure RewindTape;
const
MOREW = 1;
var
return : integer;
begin
GetDeviceJFN;
jsys(OPENF, 2, return;0:device, 100000200000B); {8bit, w/ read access}
if (return = 1) then
ErrorMess;
jsys(MTOPR;0:device, MOREW);
jsys(CLOSEF, 2, return;001000:device);
if (return = 1) then
ErrorMess;
end; {of procedure RewindTape}
{ CheckIfTapeAssigned -- check if user issued tape command to }
{ define a tape device, if not reparse }
procedure CheckIfTapeAssigned;
begin
if (StrLen(GlobalTape) = 0) then
cmuerr('Tape device not defined, use TAPE command to define device')
end; {of CheckIfTapeAssigned}
{ InitTables -- initializes pascmd tables to be used for parsing }
procedure InitTables;
begin
CmdTable := tbmak(LASTCMD);
tbadd(CmdTable,TAPE,'TAPE',0);
tbadd(CmdTable,REWIND,'REWIND',0);
tbadd(CmdTable,RESTORE,'RESTORE',0);
tbadd(CmdTable,STORE,'STORE',0);
tbadd(CmdTable,SKIP,'SKIP',0);
tbadd(CmdTable,HELP,'HELP',0);
tbadd(CmdTable,XIT,'EXIT',0);
tbadd(CmdTable,EOT,'EOT',0);
tbadd(CmdTable,DIR,'DIRECTORY',0);
tbadd(CmdTable,DEF,'DEFAULT',0);
Sw1Table := tbmak(LASTSW1);
tbadd(Sw1Table,S1BLOCK,'BLOCKING-FACTOR:',0);
tbadd(Sw1Table,S1NOPAD,'NO-PAD-TABS',0);
tbadd(Sw1Table,S1TABEV,'PAD-TABS:',0);
tbadd(Sw1Table,S1RECLN,'RECORD-LENGTH:',0);
Sw2Table := tbmak(LASTSW2);
tbadd(Sw2Table,S2STRIP,'STRIP-BLANKS',0);
tbadd(Sw2Table,S2NOSTR,'NO-STRIP-BLANKS',0);
Sw3Table := tbmak(LASTSW3);
tbadd(Sw3Table,S3SHORT,'SHORT',0);
tbadd(Sw3Table,S3FULL,'FULL',0);
DefTable := tbmak(LASTDEF);
tbadd(DefTable,DFWARN,'WARNING-MESSAGES',0);
tbadd(DefTable,DFTABEV,'TABS-EVERY',0);
tbadd(DefTable,DFSTRIP,'STRIP-BLANKS',0);
tbadd(DefTable,DFRECLN,'RECORD-LENGTH',0);
tbadd(DefTable,DFNOSWI,'NO',0);
tbadd(DefTable,DFBLOCK,'BLOCKING-FACTOR',0);
NoTable := tbmak(LASTNO);
tbadd(NoTable,DFWARN,'WARNING-MESSAGES',0);
tbadd(NoTable,DFTABEV,'TABS-EVERY',0);
tbadd(NoTable,DFSTRIP,'STRIP-BLANKS',0);
end; {of procedure InitTables}
{ DefaultTapeName -- returns the default name and extent from the }
{ inputted disk name. Tape file names must be 17 chars or less }
{ including the '.' so in certain cases it must be shortened }
procedure DefaultTapeName(var name,ext : FNameType);
const
MAXTNAME = 17;
var
NameLen, ExtLen : integer;
begin
jsys(JFNS;name,0:input,001000000000B);
NameLen := StrLen(name);
jsys(JFNS;ext,0:input,000100000000B);
ExtLen := StrLen(ext);
{check if name is too long}
if (ExtLen > 0) and (NameLen + 1 + ExtLen > MAXTNAME) then begin
if (ExtLen > 10) then
ExtLen := 10; {leave at least 6 chars for name}
NameLen := MAXTNAME - ExtLen - 1;
end; {of if}
StrEnd(name,NameLen+1);
StrEnd(ext,ExtLen+1);
end; {of procedure DefaultTapeName}
{ ListFiles -- prints the source and destination filenames }
procedure ListFiles;
var
source, dest : FNameType;
begin
jsys(JFNS;source,0:input,221110000001B);
jsys(JFNS;dest,0:output,221110000001B);
space(2);
writeln(tty,source:StrLen(source),' => ',dest:StrLen(dest));
end; {of procedure ListFile}
{ DefaultDiskFile -- Creates a diskfile name depending on the name }
{ of the input tape name and the directory to output to }
procedure DefaultDiskFile;
var
FileName : FNameType;
begin
GlobalDiskFile := GlobalDirStr;
jsys(JFNS;FileName,0:input,001100000001B);
scopy(FileName,1,GlobalDiskFile,StrLen(GlobalDiskFile)+1);
end; {procedure DefaultDiskFile}
{ DefaultTapeFile -- Takes the disk source file and turns it into }
{ a valid tape file and stores it into GlobalTapeFile. }
procedure DefaultTapeFile;
var
Tname,Text : FNameType;
begin
DefaultTapeName(Tname,Text);
GlobalTapeFile := GlobalTape;
GlobalTapeFile[StrLen(GlobalTapeFile)+1] := ':';
StrEnd(GlobalTapeFile,StrPos(GlobalTapeFile,':')+1);
scopy(Tname,1,GlobalTapeFile,StrLen(GlobalTapeFile)+1);
GlobalTapeFile[StrLen(GlobalTapeFile)+1] := '.';
StrEnd(GlobalTapeFile,StrPos(GlobalTapeFile,'.')+1);
scopy(Text,1,GlobalTapeFile,StrLen(GlobalTapeFile)+1);
end; {of procedure DefaultTapeFile}
{ ListRecordCount -- lists the number of records read or written }
{ from or into a file }
procedure ListRecordCount(n : integer);
begin
space(4);
writeln(tty,'[',n:1,' records]');
end; {of procedure ListRecordCount}
{ TruncMess -- prints a message saying what line was truncated and }
{ by how much }
procedure TruncMess(line, col : integer);
begin
jsys(JFNS;101B, 0:input, 0);
write(tty, ' - line ', line:1, ' : ', col:1,
' characters long, truncated to ', GlobalRecLen:1);
writeln(tty);
end; {of procedure TruncMess}
{ SwitchRecLenSw1 -- parses the record-length switch option for the }
{ store command }
procedure SwitchRecLenSw1;
var
i, RecLen : integer;
HelpMess, ErrMess : StrType;
begin
scopy('integer between 1 and ',1,HelpMess,1);
i := itoc(MAXRECLEN,HelpMess,StrLen(HelpMess)+1);
cmhlp(HelpMess);
cmdef(DEFRECLEN);
RecLen := cmnum; {get an integer}
if (RecLen < MINRECLEN) or (RecLen > MAXRECLEN) then begin
scopy('Record length must be between ',1,ErrMess,1);
i := itoc(MINRECLEN,ErrMess,StrLen(ErrMess)+1);
scopy(' and ',1,Errmess,StrLen(ErrMess)+1);
i := itoc(MAXRECLEN,ErrMess,StrLen(ErrMess)+1);
cmuerr(ErrMess);
end; {of if}
if ((RecLen * HoldBlkFac) > MAXBLKLEN) then begin
scopy
('Record length too large with blocking factor of ',1,ErrMess,1);
i := itoc(HoldBlkFac,ErrMess,StrLen(ErrMess)+1);
cmuerr(ErrMess);
end; {of if}
HoldRecLen := RecLen; {set global variable}
end; {of procedure SwitchRecLenSw1}
{ SwitchNoPadSw1 -- parses the no-pad-tabs switch option for the }
{ store command }
procedure SwitchNoPadSw1;
begin
HoldPadTabs := false;
end; {of procedure SwitchNoPadSw1}
{ SwitchBlockSw1 -- parses the records-per-block switch option for }
{ the store command }
procedure SwitchBlockSw1;
var
i, BlkFac : integer;
HelpMess, ErrMess : StrType;
begin
cmhlp('number of records per block');
cmdef(DEFBLKFAC);
BlkFac := cmnum; {get and integer}
if (BlkFac = 0) then {0 same as 1}
BlkFac := 1;
if (BlkFac < 1) or (BlkFac > MAXBLKLEN) then begin
scopy('Blocking factor must be between 1 and ',1,ErrMess,1);
i := itoc(MAXBLKLEN,ErrMess,StrLen(ErrMess)+1);
cmuerr(ErrMess);
end; {of if}
if ((BlkFac * HoldRecLen) > MAXBLKLEN) then begin
scopy
('Blocking factor too large with record length of ',1,ErrMess,1);
i := itoc(HoldRecLen,ErrMess,StrLen(ErrMess)+1);
cmuerr(ErrMess);
end; {of if}
HoldBlkFac := BlkFac; {set global variable}
end; {of procedure SwitchBlockSw1}
{ SwitchSetTabsSw1 -- parses the tabs-every switch option for the }
{ store command }
procedure SwitchSetTabsSw1;
var
i, TabNo : integer;
HelpMess, ErrMess : StrType;
begin
scopy('integer between 1 and ',1,HelpMess,1);
i := itoc(MAXRECLEN,HelpMess,StrLen(HelpMess)+1);
cmhlp(HelpMess);
cmdef(DEFTABNO);
TabNo := cmnum; {get an integer}
if (TabNo < 1) or (TabNo > MAXRECLEN) then begin
scopy('Argument must be between 1 and ',1,ErrMess,1);
i := itoc(MAXRECLEN,ErrMess,StrLen(ErrMess)+1);
cmuerr(ErrMess);
end; {of if}
HoldTabNo := TabNo; {set global variable}
HoldPadTabs := true; {set global variable}
end; {of procedure SwitchSetTabsSw1}
{ SwitchNoStripSw2 -- handles the no-strip switch for the restore }
{ command }
procedure SwitchNoStripSw2;
begin
HoldStripBlanks := false;
end; {of procedure SwitchNoStripSw2}
{ SwitchStripSw2 -- handles the strip-blanks switch for the restore }
{ command }
procedure SwitchStripSw2;
begin
HoldStripBlanks := true;
end; {of procedure SwitchStripSw2}
{ SwitchFullDirSw3 -- handles the full switch for the directory }
{ command }
procedure SwitchFullDirSw3;
begin
HoldDirectory := FullDir;
end; {of procedure SwitchFullDirSw3}
{ SwitchShortDirSw3 -- handles the short switch for the directory }
{ command }
procedure SwitchShortDirSw3;
begin
HoldDirectory := ShortDir;
end; {of procedure SwitchShortDirSw3}
{ SwitchWarnMessDf -- handles the Warning Messages option }
procedure SwitchWarnMessDf;
begin
HoldWarning := true;
end; {of procedure SwitchWarnMessDf}
{ SwitchNoWarnDf -- turns off the warning messages }
procedure SwitchNoWarnDf;
begin
HoldWarning := false;
end; {of procedure SwitchNoWarnDf}
{ SwitchNoSwitchDf -- handles the no option for the default command }
procedure SwitchNoSwitchDf;
var
NoCommand : integer;
begin
NoCommand := cmkey(NoTable);
case NoCommand of
DFSTRIP : SwitchNoStripSw2;
DFTABEV : SwitchNoPadSw1;
DFWARN : SwitchNoWarnDf;
others : cmuerr('Invalid switch');
end; {of case}
end; {of procedure SwitchNoSwitchDf}
{ SaveStoreSwitchesSw1 -- assigns variables storing store switches }
{ information to global variable. }
procedure SaveStoreSwitchesSw1;
begin
GlobalRecLen := HoldRecLen;
GlobalBlkFac := HoldBlkFac;
GlobalTabNo := HoldTabNo;
GlobalPadTabs := HoldPadTabs;
end; {of procedure SaveStoreSwitchesSw1}
{ SaveRestoreSwitchesSw2 -- assigns vriables storing restore }
{ switches information to global variables }
procedure SaveRestoreSwitchesSw2;
begin
GlobalStripBlanks := HoldStripBlanks;
end; {of procedure SaveRestoreSwitchesSw2}
{ SaveDirectorySwitchesSw3 -- assigns vriables storing directory }
{ switches information to global variables }
procedure SaveDirectorySwitchesSw3;
begin
GlobalDirectory := HoldDirectory;
end; {of procedure SaveDirectorySwitchesSw3}
{ SaveDefaults -- saves default settings }
procedure SaveDefaults;
begin
DefaultRecLen := HoldRecLen;
DefaultBlkFac := HoldBlkFac;
DefaultTabNo := HoldTabNo;
DefaultPadTabs := HoldPadTabs;
DefaultWarning := HoldWarning;
DefaultStripBlanks := HoldStripBlanks;
end; {of procedure SaveDefaults}
{ StoreSwitchesSw1 -- parses multiple choices for the store }
{ command }
procedure StoreSwitchesSw1;
var
switch : integer;
begin
loop
cmmult; {multiple mode}
cmcfm; {carriage return}
switch := cmswi(Sw1Table);
switch := cmdo;
exit if (switch = 1);
switch := cmint; {get real value from cmswi}
if (switch > 0) then
case switch of
S1NOPAD : SwitchNoPadSw1;
others : cmuerr('Argument not specified');
end {of case}
else if (switch < 0) then {users gave argument, indicated by - }
case -switch of
S1BLOCK : SwitchBlockSw1;
S1RECLN : SwitchRecLenSw1;
S1TABEV : SwitchSetTabsSw1;
others : cmuerr('Does not take an argument');
end; {of case -switch}
end; {of loop}
end; {of procedure StoreSwitchesSw1}
{ RestoreSwitchesSw2 -- parses multiple choice switches for the }
{ store command }
procedure RestoreSwitchesSw2;
var
switch : integer;
begin
cmmult; {multiple mode}
cmdef('/STRIP-BLANKS');
cmcfm; {cr}
switch := cmswi(Sw2Table);
switch := cmdo;
if (switch <> 1) then begin
switch := cmint; {get real value form cmswi}
if (switch < 0) then
cmuerr('Does not take an argument')
else
case switch of
S2NOSTR : SwitchNoStripSw2;
S2STRIP : SwitchStripSw2;
others : cmuerr('Invalid switch')
end; {of case switch}
cmcfm; {cr}
end; {of if}
end; {of procedure RestoreSwitchesSw2}
{ DirectorySwitchesSw3 -- parses multiple choice switches for the }
{ Directory command }
procedure DirectorySwitchesSw3;
var
switch : integer;
begin
cmmult; {multiple mode}
cmdef('/SHORT');
cmcfm; {carriage return}
switch := cmswi(Sw3Table);
switch := cmdo;
if (switch <> 1) then begin
switch := cmint; {get real value form cmswi}
if (switch < 0) then
cmuerr('Does not take an argument')
else
case switch of
S3FULL : SwitchFullDirSw3;
S3SHORT : SwitchShortDirSw3;
others : cmuerr('Invalid switch')
end; {of case switch}
cmcfm; {cr}
end; {of if}
end; {of procedure DirectorySwitchesSw3}
{ ParseTapeOutput2 -- parses next field as output to tape }
procedure ParseTapeOutput2;
var
Tname,Text : FNameType;
TapeFileStr : StrType;
TFStrLen : integer;
begin
cmnoi('AS');
CheckIfTapeAssigned;
gjgen(600020000000B);
DefaultTapeName(Tname,Text);
gjdev(GlobalTape);
gjnam(Tname);
gjext(Text);
cmfil(output);
TFStrLen := cmatom(TapeFileStr);
StrEnd(TapeFileStr,TFStrLen+1);
if (StrPos(TapeFileStr,';') <> 0) then {user enters extra junk}
GarbageErr
('Invalid attribute for this device',TapeFileStr);
if (KindOfDevice(curjfn(output),JFNDes) <> TapeDev) then
cmuerr('Use COPY command to copy from disk to disk');
end; {of procedure ParseTapeOutput2}
{ ParseDiskOutput2 -- parses next field as output to disk }
procedure ParseDiskOutput2;
var
name, ext : FNameType;
begin
cmnoi('TO');
jsys(JFNS;name,0:input,001000000000B);
jsys(JFNS;ext,0:input,000100000000B);
gjgen(600020000000B);
gjnam(name);
gjext(ext);
cmfil(output);
if not (KindOfDevice(curjfn(output),JFNDes) in [DiskDev,TTYDev]) then
cmuerr('This utility does not support tape to tape copying');
end; {of procedure ParseDiskOutput2}
{ ParseDirOutput2 -- parses next field as a directory name }
procedure ParseDirOutput2;
const
DIRST = 41B;
GJINF = 13B;
var
ac1, ac2, DirNo, DirLen : integer;
DefaultDir : StrType;
begin
jsys(GJINF;;ac1, ac2); {get def dir no}
jsys(DIRST;DefaultDir, ac2); {turn it into a string}
cmdef(DefaultDir);
DirNo := cmdir;
DirLen := cmatom(GlobalDirStr);
StrEnd(GlobalDirStr,DirLen+1);
if (DirLen = 0) then
GlobalDirStr := DefaultDir;
end; {of procedure ParseDirOutput2}
procedure RestoreFile;
var
line, RecLen : integer;
next : boolean;
buffer : packed array [1..MAXRECLEN] of char;
begin
line := 0;
while not eof do begin
next := true;
readln(buffer:RecLen);
line := line + 1;
RecLen := RecLen - 2; {disregard crlf}
if GlobalStripBlanks then
while (RecLen >= 1) and next do
if (buffer[RecLen] = chr(BLANK)) then
RecLen := RecLen - 1
else
next := false;
if (RecLen = 0) then
writeln
else
writeln(buffer:RecLen);
end; {of while}
ListRecordCount(line);
end; {of procedure RestoreFile}
{ StoreFile -- processes the store command }
procedure StoreFile;
var
col, line : integer;
mess : StrType;
{ NewLine -- handles end of line delimiter and sets up for the next }
{ line }
procedure NewLine;
begin
if ((col - 1) > GlobalRecLen) then
TruncMess(line,col-1);
readln;
writeln;
col := 1;
line := line + 1;
end; {of procedure NewLine}
{ CopyChar -- copies a single char from input to output and takes }
{ into account tabs }
procedure CopyChar;
begin
if GlobalPadTabs and (input^ = chr(TAB)) then
repeat {pad tabs}
if (col <= GlobalRecLen) then begin
output^ := chr(BLANK);
put(output);
end; {of if}
col := col + 1;
until (TabPos(col))
else begin
if (col <= GlobalRecLen) then begin
output^ := input^;
put(output);
end; {of if}
col := col + 1;
end; {of else}
get(input);
end; {of procedure CopyChar}
begin {StoreFile}
col := 1; line := 1;
while not eof do begin {store to tape}
if (input^ = chr(CR)) then begin
get(input); {check if crlf}
if eof then begin {cr eof}
if ((col - 1) > GlobalRecLen) then
TruncMess(line,col-1);
writeln;
line := line + 1;
end {of if}
else if (input^ = chr(LF)) then {crlf}
NewLine
else begin {treat both cr and next char as normal char's}
if (col <= GlobalRecLen) then begin
output^ := chr(CR); {add in already read cr}
put(output);
end; {of if}
col := col + 1;
CopyChar;
end {of else}
end {of if}
else if (input^ = chr(LF)) then {same as crlf}
NewLine
else
CopyChar;
end; {of while not eof}
ListRecordCount(line-1);
end; {of procedure StoreFile}
{ initialization -- does the initializing }
procedure initialization;
const
INDUSTRY_COMPATIBLE = 4B;
begin
OriginalDataMode := GetJobDataMode;
if (OriginalDataMode <> INDUSTRY_COMPATIBLE) then
SetJobDataMode(INDUSTRY_COMPATIBLE);
ThatsIt := false;
StrEnd(GlobalTape,1); {null string}
InitTables;
DefaultRecLen := ctoi(DEFRECLEN,1);
DefaultBlkFac := ctoi(DEFBLKFAC,1);
DefaultTabNo := ctoi(DEFTABNO,1);
DefaultWarning := true;
DefaultPadTabs := true;
DefaultStripBlanks := true;
DefaultDirectory := ShortDir;
end; {of procedure initialization}
{ PrintHeading -- prints heading when ANSIMT starts up. Prints }
{ title, version numbers, edit numbers, and date. }
procedure PrintHeading;
const
WHO_EDITED = 2B;
MAJOR_VERSION_NUMBER = 001B;
MINOR_VERSION_NUMBER = 02B;
EDIT_NUMBER = 000001B;
ODTIM = 220B;
var
ProgramStartTime : packed array [1..40] of char; {date field}
{$V:200102000001b} {system version number}
begin
writeln(tty,'UHCC DEC-20 ANSI Labelled Tape Utility version ',
MAJOR_VERSION_NUMBER:3:O,'.',MINOR_VERSION_NUMBER:2:O,
'(',EDIT_NUMBER:6:O,')-',WHO_EDITED:1:O);
jsys(ODTIM,1;ProgramStartTime,-1,336321000000B);
writeln(tty,ProgramStartTime:StrLen(ProgramStartTime));
writeln(tty);
end; {of procedure PrintHeading}
{ InitParameters -- initializes the global and dummy variables to }
{ their default values }
procedure InitParameters;
begin
HoldRecLen := DefaultRecLen;
HoldBlkFac := DefaultBlkFac;
HoldTabNo := DefaultTabno;
HoldPadTabs := DefaultPadTabs;
HoldWarning := DefaultWarning;
HoldStripBlanks := DefaultStripBlanks;
HoldDirectory := DefaultDirectory;
GlobalRecLen := DefaultRecLen;
GlobalBlkFac := DefaultBlkFac;
GlobalTabNo := DefaultTabno;
GlobalPadTabs := DefaultPadTabs;
GlobalWarning := DefaultWarning;
GlobalStripBlanks := DefaultStripBlanks;
GlobalDirectory := DefaultDirectory;
end; {of procedure InitParameters}
{ ParseDefault1 -- parses the default command }
procedure ParseDefault1;
var
DefCommand : integer;
begin
cmnoi('FOR');
DefCommand := cmkey(DefTable);
case DefCommand of
DFBLOCK : SwitchBlockSw1;
DFNOSWI : SwitchNoSwitchDf;
DFRECLN : SwitchRecLenSw1;
DFSTRIP : SwitchStripSw2;
DFTABEV : SwitchSetTabsSw1;
DFWARN : SwitchWarnMessDf;
others : cmuerr('Invalid switch');
end; {of case}
cmcfm; {cr}
end; {of ParseDefault}
{ ParseDirectory -- parses the directory command }
procedure ParseDirectory1;
begin
cmnoi('OF TAPE');
DirectorySwitchesSw3;
end; {of procedure ParseDirectory1}
{ ParseEOT1 -- parses the eot command }
procedure ParseEOT1;
begin
cmnoi('END OF TAPE');
cmcfm;
end; {of procedure ParseEOT1}
{ ParseExit1 -- parses the exit command }
procedure ParseExit1;
begin
cmnoi('TO MONITOR');
cmcfm;
end; {of procedure ParseExit1}
{ ParseHelp1 -- parses the help command }
procedure ParseHelp1;
begin
cmnoi('ON ANSIMT COMMANDS');
cmcfm; {carriage return}
end; {of procedure ParseHelp1}
{ ParseRestore1 -- parses the restore command }
procedure ParseRestore1;
var
FileStrLen : integer;
FileStr : StrType;
begin
cmnoi('TAPE FILES');
CheckIfTapeAssigned;
gjgen(000120777775B);
gjdev(GlobalTape);
cmfil(input);
FileStrLen := cmatom(FileStr);
StrEnd(FileStr,FileStrLen+1);
if (KindOfDevice(curjfn(input),JFNDes) <> TapeDev) then
cmuerr('Device must be TAPE');
if (StrPos(FileStr,'*') = 0) and
(StrPos(FileStr,'%') = 0) then begin
ParseDiskOutput2;
jsys(JFNS;GlobalDiskFile,0:output,0);
end {of if}
else begin
ParseDirOutput2;
GlobalDiskFile[1] := chr(NULL);
end; {of else}
RestoreSwitchesSw2;
end; {of procedure ParseRestore1}
{ ParseRewind1 -- parses the rewind command }
procedure ParseRewind1;
begin
cmnoi('TO THE BEGINNING OF TAPE');
cmcfm;
end; {of procedure ParseRewind1}
{ ParseSkip1 -- parses the skip command }
procedure ParseSkip1;
const
DEFNFIL = '1 ';
begin
cmnoi('NUMBER OF FILES');
cmhlp('positive integer for forward, negative for backward');
cmdef(DEFNFIL);
FilesToSkip := cmnum; {global variable}
cmcfm; {carriage return}
end; {of procedure ParseSkip1}
{ ParseStore1 -- parses the store command }
procedure ParseStore1;
var
i, FileStrLen : integer;
FileStr : StrType;
begin
cmnoi('DISK FILES');
gjgen(100120000000B);
cmfil(input);
FileStrLen := cmatom(FileStr);
StrEnd(FileStr,FileStrLen + 1);
if (StrPos(FileStr,'*') = 0) and {wild card?}
(StrPos(FileStr,'%') = 0) then begin
ParseTapeOutput2;
jsys(JFNS;GlobalTapeFile,0:output,0);
end {if end}
else begin {it is a wild card}
DefaultTapeFile;
end; {of else}
StoreSwitchesSw1;
end; {of procedure ParseStore1}
{ ParseTape1 -- parses the tape command }
procedure ParseTape1;
const
ASND = 70B;
var
DevNo, DevStrLen, return : integer;
DevStr : FNameType;
begin
cmnoi('DEVICE');
cmhlp('magtape device');
DevNo := cmdev;
DevStrLen := cmatom(DevStr);
StrEnd(DevStr,DevStrLen+1);
if (KindOfDevice(DevNo,DevDes) <> TapeDev) then
GarbageErr('Not a magtape device',DevStr);
jsys(ASND, 3, return;DevNo); {try to assign the device}
if (return = 1) then {error}
ErrorMess;
cmcfm;
HoldTape := DevStr;
end; {of procedure ParseTape1}
{ ProcessDefault -- process the default command }
procedure ProcessDefault;
begin
SaveDefaults;
end; {of procedure ProcessDefault}
{ ProcessDirectory -- process the directory command }
procedure ProcessDirectory;
const
WILDCARD = ':*.*.*';
DATAERR = 600221B; {data error}
BIGREC = 601240B;
var
i : integer;
WildFile : FNameType;
begin
SaveDirectorySwitchesSw3;
CheckIfTapeAssigned;
RewindTape;
WildFile := GlobalTape;
scopy(WILDCARD,1,WildFile,StrLen(WildFile)+1);
i := 1;
repeat
reset(input,WildFile,'/d/o/m:7',[11]{allow wildcards});
if (erstat(input) <> 0) and
(erstat(input) <> DATAERR) and (erstat(input) <> BIGREC) then
analysis(input)
else begin
if (i = 1) then
DirHeading;
if (erstat(input) = DATAERR) or (erstat(input) = BIGREC) then
TapeFileInfo(-i)
else
TapeFileInfo(i);
i := i + 1;
end;
ClearDataError(input);
if FileOpen(input) then
close(input);
until (nextfile(input) = 0);
end; {of procedure ProcessDirectory}
{ ProcessEOT -- processes the eot command }
procedure ProcessEOT;
const
MOEOT = 10B;
var
return : integer;
begin
CheckIfTapeAssigned;
GetDeviceJFN;
jsys(OPENF, 2, return;0:device, 100000200000B); {8bit, w/ read access}
if (return = 1) then
ErrorMess;
jsys(MTOPR,-2,return;0:device, MOEOT);
if (return = 3) then begin
if TrapEOT then
WarnMess('Already at end of tape')
else
cmerrmsg; {print official error message}
jsys(CLOSEF, 2, return;001000:device);
if (return = 1) then
cmerrmsg;
cmagain;
end {of if}
else begin
jsys(CLOSEF,2,return;001000:device);
if (return = 1) then
ErrorMess;
end; {of begin}
end; {of procedure ProcessEOT}
{ ProcessExit -- processes the exit command }
procedure ProcessExit;
begin
ThatsIt := true; {terminates program in major loop}
end; {of procedure ProcessExit}
{ ProcessHelp -- processes the help command }
procedure ProcessHelp;
var
rl : integer;
buffer : StrType;
begin
reset(input,'HLP:ANSIMT.HLP','/o');
if (erstat(input) <> 0) then
analysis(input);
rewrite(output,'TTY:','/o/i');
if (erstat(output) <> 0) then
analysis(output);
while not eof do begin
readln(buffer:rl);
writeln(buffer:rl);
end; {of while}
close(input);
close(output);
end; {of procedure ProcessHelp}
{ ProcessRestore -- processes the restore command }
procedure ProcessRestore;
begin
SaveRestoreSwitchesSw2;
loop
if OpenInputTape then begin
if (GlobalDiskFile[1] = chr(NULL)) then
DefaultDiskFile;
if not OpenOutputDisk then
cmagain;
ListFiles;
RestoreFile;
close(input);
close(output);
end; {of if}
exit if (nextfile(input) = 0);
GlobalDiskFile[1] := chr(NULL);
end; {of loop}
end; {of procedure ProcessRestore}
{ ProcessRewind -- processes the rewind command }
procedure ProcessRewind;
begin
CheckIfTapeAssigned;
RewindTape;
if BeginningOfTape then
WarnMess('Already at beginning of tape');
end; {of procedure ProcessRewind}
{ ProcessSkip -- processes the skip command }
procedure ProcessSkip;
var
i : integer;
begin
CheckIfTapeAssigned;
if (FilesToSkip > 0) then
for i := 1 to FilesToSkip do
ForwardFile
else if (FilesToSkip < 0) then
for i := 1 to -FilesToSkip do begin
BackwardFile;
if BeginningOfTape then
cmuerr('Beginning of tape encountered');
end; {of for}
end; {of procedure ProcessSkip}
{ ProcessStore -- processes the store command }
procedure ProcessStore;
var
i : integer;
mess : StrType;
begin {ProcessStore}
SaveStoreSwitchesSw1;
if (KindOfDevice(curjfn(input),JFNDes) = DiskDev) then begin
if not OpenInputFile(DiskDev) then
cmagain;
end {of if}
else if (KindOfDevice(curjfn(input),JFNDes) = TTYDev) then begin
if not OpenInputFile(TTYDev) then
cmagain;
end {of else if}
else
cmuerr('Source device must be DISK');
loop
if not OpenOutputTape(GlobalTapeFile) then
cmagain;
if (GlobalRecLen * GlobalBlkFac > MAXRECLEN) then begin
scopy('Block size greater than the ANSI standard of ',1,mess,1);
i := itoc(MAXRECLEN,mess,StrLen(mess)+1);
WarnMess(mess);
end; {of if}
ListFiles;
StoreFile;
close(input);
close(output);
exit if (nextfile(input) = 0);
if not OpenInputFile(DiskDev) then
cmagain;
DefaultTapeFile;
end; {of loop}
end; {of procedure ProcessStore}
{ ProcessTape -- processes the tape command }
procedure ProcessTape;
const
MORLI = 50B;
MOSDM = 4B; {set hardware data mode}
ARGS = 2B;
UNLABELED = 1;
ANSILABEL = 2;
EBCDICLABEL = 3;
TOPS20LABEL = 4;
type
ArgBlkType = record
ArgWords : integer;
TypeOfLabel : integer;
end; {of record}
var
DummyTape : FNameType;
ArgBlkPtr : ^ArgBlkType;
begin
new(ArgBlkPtr);
DummyTape := GlobalTape;
GlobalTape := HoldTape; {set to global variable}
with ArgBlkPtr^ do begin
ArgWords := ARGS;
GetDeviceJFN;
jsys(MTOPR;0:device,MORLI,ArgBlkPtr);
if (TypeOfLabel = UNLABELED) then begin
GlobalTape := DummyTape; {get back old value}
cmuerr('Tape cannot be unlabelled');
end {of if}
else if (TypeOfLabel = EBCDICLABEL) then
WarnMess('EBCDIC tape, read only')
else if (TypeOfLabel = TOPS20LABEL) then
WarnMess('TOPS-20 tape');
end; {of with}
{get rid of junk}
dispose(ArgBlkPtr);
end; {of procedure ProcessTape}
{ termination -- cleans up before exiting }
procedure termination;
const
INDUSTRY_COMPATIBLE = 4B;
begin
if (OriginalDataMode <> INDUSTRY_COMPATIBLE) then
SetJobDataMode(OriginalDataMode);
end; {of procedure termination}
begin {main program}
initialization;
PrintHeading;
repeat
cminir('ANSIMT>');
InitParameters;
command := cmkey(CmdTable);
case command of {parse the command}
DEF : ParseDefault1;
DIR : ParseDirectory1;
EOT : ParseEOT1;
XIT : ParseExit1;
HELP : ParseHelp1;
RESTORE : ParseRestore1;
REWIND : ParseRewind1;
SKIP : ParseSkip1;
STORE : ParseStore1;
TAPE : ParseTape1;
end; {of case}
case command of {now process the command}
DEF : ProcessDefault;
DIR : ProcessDirectory;
EOT : ProcessEOT;
XIT : ProcessExit;
HELP : ProcessHelp;
RESTORE : ProcessRestore;
REWIND : ProcessRewind;
SKIP : ProcessSkip;
STORE : ProcessStore;
TAPE : ProcessTape;
end; {of case}
until ThatsIt;
termination;
end. {of program ANSIMT_TapeUtility}