home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
CPM
/
ZCPR33
/
A-R
/
FOR-SUPP.LBR
/
CLEANFOR.PZS
/
CLEANFOR.PAS
Wrap
Pascal/Delphi Source File
|
2000-06-30
|
11KB
|
390 lines
program CleanFOR; { Cleans up FOR. files }
{ compiles with ending address of $A400 }
const
debug = false;
version = '1.0';
date = '05 Aug 87';
authors = 'C. Wilson';
BufSize = 1800; { Max. size of buffer for FOR names }
User = 32; { CP/M function numbers }
DefDrv = 25;
SelDsk = 14;
Res = 13;
{ values patchable with DDT, starting at 2100 hex: }
FORLabel : array[1..9] of char = '[[CONFIG>'; { pointer }
FORdrv : char = 'A';
FORusr : byte = 14;
SrchLabel : array[1..8] of char = '[DRIVES>'; { pointer }
ListLen : byte = 5; { length of drive list }
DriveLst : array[1..16] of char = 'ABCDE'^@^@^@^@^@^@^@^@^@^@^@;
SpecLength = 12;
type
SpecType = string[SpecLength];
BufType = array[1..11] of string[76];
SpecBuf = array[1..BufSize] of SpecType;
var
FORBuf : SpecBuf;
Match : array[1..BufSize] of boolean;
Buffer : BufType;
NEWFile,
FORFile,
FORFil2 : text;
UnTypedFil : file;
Total,
Unmatched,
DiskBlock,
FilsDone,
Desc,
DefDrvVal,
DefUsr : integer;
line,
MatchUsr,
SrchDrv : byte;
SearchSpec : SpecType;
BufFull,
AllMatch,
AllDone : boolean;
function Exist(Spec : SpecType) : boolean;
{ Searches for standard Turbo filespec at current user, current
drive, or on alternate drive if included in the filespec }
var
fil : file;
begin
assign(fil, Spec);
{$I-} reset(fil) {$I+} ;
exist := (IOresult = 0);
close(fil);
end; { of procedure Exist }
function Search(SearchName : SpecType) : boolean;
{ Detects match on current drive, all users }
const
DMA = $80; { default address }
SetDMA = 26; { CP/M function numbers }
FindFirst = 17;
FindNext = 18;
type
FileRec = record { adapted from P.D. DIR.PAS }
case boolean of
true:
(drv : byte;
FName : array[1..11] of char;
extent, s1, s2, RecCount : byte;
dn : array[16..31] of byte);
false:
(init : array[1..32] of byte);
end;
var
found : boolean;
off, Ch : integer;
SearchBlk : FileRec;
AnswerBlk : array[0..3] of FileRec;
begin
fillchar(SearchBlk.init,32,0); { initialize search FCB }
SearchBlk.drv := ord('?'); { match all user areas & erased files }
for Ch := 1 to 11 do
SearchBlk.FName[Ch] := SearchName[Ch]; { fill in file name }
BDOS(SetDMA,addr(AnswerBlk)); { set DMA to our buffer }
off := bdos(FindFirst,addr(SearchBlk));
found := false;
while (off <> 255) and (found = false) do
with AnswerBlk[off] do
begin
for Ch := 1 to 11 do
FName[Ch] := char(ord(FName[Ch]) and $7F); { kill R/O, etc. flags }
if (drv <> $E5) and (FName = SearchBlk.Fname)
then
begin
found := true; { else erased file }
MatchUsr := drv;
end;
off := bdos(FindNext,addr(SearchBlk));
end;
Search := found;
BDOS(SetDMA,DMA); { restore default DMA }
if debug then
writeln('DEBUG: Search for ',searchname,' was ',found);
end; { of procedure Search }
function Yes : boolean; { returns false if answer <> 'Y','y' }
var
response : char;
begin
write(' (Y/N)? N',^H);
read(kbd,response);
response := upcase(response);
write(response);
if response = 'Y' then Yes := true
else Yes := false;
end; { of function Yes }
procedure Parse(var arg : SpecType);
{ Parses the first word of a capitalized string of up to 12
characters into CP/M FCB's filespec format. NO DRIVESPEC
ALLOWED, but accepts a period as delimiter between filename
and type. }
var
name : string[8];
tail : string[3];
lett,
DotPos,
SpcPos : integer;
begin
SpcPos := pos(' ', arg);
if SpcPos <> 0 then
arg := copy(arg, 1, SpcPos - 1); { kill trailing spaces }
DotPos := pos('.', arg);
if DotPos <> 0 then { file type detected }
begin
tail := copy(arg, DotPos + 1, 255); { all after '.' }
name := copy(arg, 1, DotPos - 1); { all before '.' }
for lett := DotPos to 8 do
name := name + ' '; { pad }
for lett := length(tail) to 3 do
tail := tail + ' ';
arg := name + tail;
end
else arg := copy(arg, 1, 8); { chars 1-8 only }
end; { of procedure Parse }
procedure GoToDef; { set to default drive/user }
begin
BDOS(SelDsk, DefDrvVal);
BDOS(User, DefUsr);
end;
procedure GoToFOR; { set to FOR drive/user }
begin
BDOS(SelDsk, ord(FORDrv) - ord('A'));
BDOS(User, FORUsr);
end;
procedure Finish;
begin
GoToDef;
writeln;
writeln(^I'Done.');
halt;
end;
{$I CPMSTATS.INC }
function KSize(FilSiz : integer) : integer;
{ convert Turbo filesize to Kb's, using block size DiskBlock }
var
size, { in records or blocks }
extra : integer;
begin
size := FilSiz div 8;
if FilSiz mod 8 > 0 then size := size + 1;
extra := size mod DiskBlock;
if extra > 0 then size := size + (DiskBlock - extra);
KSize := size;
end; { of function KSize }
BEGIN (* MAIN PROGRAM *)
writeln;
writeln('CLEANFOR ',version,' (c) ',date,' by ',authors,'.');
if ParamStr(1) = 'INSTALL' then
begin
assign(UntypedFil,'PDTINS.CHN');
Chain(UntypedFil);
end
else if ParamCount <> 0 then { display ZCPR-style help }
begin
writeln(^I, 'Removes unmatched entries from FOR. files.');
writeln('Usage:'^J^M^I'CLEANFOR');
halt;
end;
DefDrvVal := BDOS(DefDrv); { get current drive }
DefUsr := BDOS(User,$FF); { " " user }
writeln;
writeln(^I'Reset');
BDOS(Res); { reset disk system }
GoToFOR; { to FOR DU: }
if not Exist('FOR') then
begin
write(^I^G,FORDrv, FORUsr, ':FOR. -- not found. ABORT.');
Finish;
end
else
begin
assign (FORFile, 'FOR');
reset (FORFile);
assign (FORFil2, 'FOR');
reset (FORFil2);
assign (UntypedFil, 'FOR');
reset (UntypedFil);
end;
DiskBlock := CPMStats(FORDrv, size); { get block size - 2k, 4k, etc. }
if CPMStats(FORDrv, space) < KSize(filesize(UnTypedFil))
then { no room for FOR.NEW }
begin
close(FORFile);
close(FORFil2);
close(UntypedFil);
write(^I^G'Not enough room on drive ',FORDrv,':. ABORT.');
Finish;
end
else
begin
close(UntypedFil);
assign (NEWFile, 'FOR.NEW');
rewrite(NEWFile);
end;
AllMatch := true; { default to all FOR entries matched }
Total := 0;
Unmatched := 0;
write(^I'Checking ', FORDrv, FORUsr, ':FOR. against drives -->');
for SrchDrv := 1 to ListLen do write(' ', DriveLst[SrchDrv]);
writeln('....');
writeln;
WHILE NOT EOF(FORFile) DO { loop to process FOR file }
begin
Desc := 1;
while not (EOF(FORFile) or (Desc > BufSize)) do
begin { Fill buffer or read to EOF }
line := 1;
readln(FORFile,Buffer[line]); { kill initial '----' }
readln(FORFile,FORBuf[Desc]); { get file spec }
repeat
line := succ(line); { get end of this desc.}
readln(FORFile,Buffer[line]);
until (Buffer[line] = ' ') or (Buffer[line] = '') or EOF(FORFile);
Desc := succ(Desc);
end;
FilsDone := Desc - 1;
for Desc := 1 to FilsDone do
begin
Parse(FORBuf[Desc]); { to CP/M filespec }
Match[Desc] := false; { no matches found yet }
end;
AllDone := false; { All entries not matched }
for SrchDrv := 1 to ListLen do { Search for matches on all drives in list }
if not AllDone then { Quit searching when all entries matched }
begin
AllDone := true;
BDOS(SelDsk, ord(DriveLst[SrchDrv]) - ord('A'));
for Desc := 1 to FilsDone do { go thru whole buffer }
if Match[Desc] = false then { search only remaining unmatched }
begin
Match[Desc] := Search(FORBuf[Desc]);
if Match[Desc] then
begin
insert('.', ForBuf[Desc], 9);
write(FORBuf[Desc]);
lowvideo;
write(' matched on ');
normvideo;
writeln(DriveLst[SrchDrv],MatchUsr,':');
end;
end;
for Desc := 1 to FilsDone do
if Match[Desc] = false then AllDone := false; { test for remaining }
end;
GoToFOR;
for Desc := 1 to FilsDone do { Copy matched entries to FOR.NEW }
begin
Total := succ(Total);
line := 1;
if Match[Desc] = true then { copy this entry }
repeat
line := succ(line);
readln(FORFil2, Buffer[line]);
writeln(NEWFile, Buffer[line]);
until (Buffer[line] = ' ') or
(Buffer[line] = '') or
EOF(FORFil2)
else { display this entry, and skip over it }
begin
Unmatched := succ(Unmatched);
writeln('Deleting:');
lowvideo;
repeat
readln(FORFil2, Buffer[line]);
writeln(Buffer[line]);
until (Buffer[line] = ' ') or
(Buffer[line] = '') or
EOF(FORFil2);
delay(1000);
normvideo;
AllMatch := false;
end;
end;
END; { of WHILE NOT EOF }
close(FORFile);
close(FORFil2);
close(NEWFile);
writeln;
writeln(^I,Total,' total entries in ',FORDrv, FORUsr,':FOR.');
if AllMatch then
begin
write(^I'All entries matched.');
erase(NEWFile);
end
else
begin
writeln(^I,Total - UnMatched,' entries matched.');
writeln(^I,UnMatched,' entries deleted.');
writeln;
write(^I'Keep changes');
if Yes then
begin
if exist('FOR.BAK') then { Remove previous FOR.BAKs, since }
begin { Turbo Rename will create new ones }
assign(UntypedFil,'FOR.BAK');
erase(UntypedFil);
end;
rename(FORFile,'FOR.BAK');
rename(NEWFile,'FOR');
end
else erase(NEWFile);
end;
Finish;
END.