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
/
ENTERPRS
/
CPM
/
UTILS
/
S
/
TURBTOOL.ARC
/
CHAPTER3.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-09-27
|
12KB
|
586 lines
{chapter3.pas}
{
copyright (c) 1981
by: bell telephone laboratories, inc. and
whitesmith's ltd.,
this software is derived from the book
"software tools in pascal", by
brian w. kernighan and p. j. plauger
addison-wesley, 1981
isbn 0-201-10342-7
right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}
procedure compare;forward;
procedure include;forward;
procedure concat;forward;
procedure makecopy;
var
inname,outname:xstring;
fin,fout:filedesc;
begin
if(not getarg(2,inname,maxstr))
or (not getarg(3,outname,maxstr))then
error('usage:makecopy old new');
fin:=mustopen(inname,ioread);
fout:=mustcreate(outname,iowrite);
fcopy(fin,fout);
xclose(fin);
xclose(fout)
end;
procedure print;
var
name:xstring;
null:xstring;
i:integer;
fin:filedesc;
junk:boolean;
procedure fprint(var name:xstring;fin:filedesc);
const
margin1=2;
margin2=2;
bottom=64;
pagelen=66;
var
line:xstring;
lineno,pageno:integer;
procedure skip(n:integer);
var
i:integer;
begin
for i:=1 to n do
putc(newline)
end;
procedure head(var name:xstring;pageno:integer);
var
page:xstring;
begin
page[1]:=ord(' ');
page[2]:=ord('p');
page[3]:=ord('a');
page[4]:=ord('g');
page[5]:=ord('e');
page[6]:=ord(' ');
page[7]:=endstr;
putstr(name,stdout);
putstr(page,stdout);
putdec(pageno,1);
putc(newline)
end;
begin(*fprint*)
pageno:=1;
skip(margin1);
head(name,pageno);
skip(margin2);
lineno:=margin1+margin2+1;
while(getline(line,fin,maxstr))do begin
if(lineno=0)then begin
skip(margin1);;
pageno:=pageno+1;
head(name,pageno);
skip(margin2);
lineno:=margin1+margin2+1
end;
putstr(line,stdout);
lineno:=lineno+1;
if(lineno>=bottom)then begin
skip(pagelen-lineno);
lineno:=0
end
end;
if(lineno>0)then
skip(pagelen-lineno)
end;
begin(*print*)
null[1]:=endstr;
if(nargs=1)then
fprint(null,stdin)
else
for i:=2 to nargs do begin
junk:=getarg(i,name,maxstr);
fin:=mustopen(name,ioread);
fprint(name,fin);
xclose(fin)
end
end;
procedure compare;
var
line1,line2:xstring;
arg1,arg2:xstring;
lineno:integer;
infile1,infile2:filedesc;
f1,f2:boolean;
procedure diffmsg (n:integer; var line1,line2:xstring);
begin
putdec(n,1);
putc(colon);
putc(newline);
putstr(line1,stdout);
putstr(line2,stdout)
end;
begin(*compare*)
if (not getarg(2,arg1,maxstr))
or (not getarg(3,arg2,maxstr)) then
error('usage:compare file1 file2');
infile1:=mustopen(arg1,ioread);
infile2:=mustopen(arg2,ioread);
lineno:=0;
repeat
lineno:=lineno+1;
f1:=getline(line1,infile1,maxstr);
f2:=getline(line2,infile2,maxstr);
if (f1 and f2) then
if (not equal(line1,line2)) then
diffmsg(lineno,line1,line2)
until (f1=false) or (f2=false);
if(f2 and not f1) then
writeln('compare:end of file on file 1')
else if (f1 and not f2) then
writeln('compare:end of file on file2')
end;
procedure include;
var
incl:xstring;
procedure finclude(f:filedesc);
var
line,str:xstring;
loc,i:integer;
f1:filedesc;
function getword(var s:xstring;i:integer;
var out:xstring):integer;
var
j:integer;
begin
while(s[i] in [blank,tab,newline]) do
i:=i+1;
j:=1;
while(not (s[i] in [endstr,blank,tab,newline])) do begin
out[j]:=s[i];
i:=i+1;
j:=j+1
end;
out[j]:=endstr;
if(s[i]=endstr) then
getword:=0
else
getword:=i
end;
begin
while (getline(line,f,maxstr))do begin
loc:=getword(line,1,str);
if (not equal(str,incl)) then
putstr(line,stdout)
else begin
loc:=getword(line,loc,str);
str[xlength(str)]:=endstr;
for i:= 1 to xlength(str)do
str[i]:=str[i+1];
f1:=mustopen(str,ioread);
finclude(f1);
xclose(f1)
end
end
end;
begin
incl[1]:=ord('#');
incl[2]:=ord('i');
incl[3]:=ord('n');
incl[4]:=ord('c');
incl[5]:=ord('l');
incl[6]:=ord('u');
incl[7]:=ord('d');
incl[8]:=ord('e');
incl[9]:=endstr;
finclude(stdin)
end;
procedure concat;
var
i:integer;
junk:boolean;
fd:filedesc;
s:xstring;
begin
for i:=2 to nargs do begin
junk:=getarg(i,s,maxstr);
fd:=mustopen(s,ioread);
fcopy(fd,stdout);
xclose(fd)
end
end;
procedure archive;
const
maxfiles=10;
var
aname:xstring;
cmd:xstring;
fname:array[1..maxfiles]of xstring;
fstat:array[1..maxfiles] of boolean;
nfiles:integer;
errcount:integer;
archtemp:xstring;
archhdr:xstring;
function getword(var s:xstring;i:integer;var out:xstring):integer;
var
j:integer;
begin
while (s[i] in [blank,tab,newline]) do
i:=i+1;
j:=1;
while(not (s[i] in [endstr,blank,tab,newline])) do begin
out[j]:=s[i];
i:=i+1;
j:=j+1
end;
out[j]:=endstr;
if(s[i]=endstr) then
getword:=0
else
getword:=i
end;
function gethdr(fd:filedesc;var buf,name:xstring;
var size:integer):boolean;
var
temp:xstring;
i:integer;
begin
if(getline(buf,fd,maxstr)=false)then
gethdr:=false
else begin
i:=getword(buf,1,temp);
if(not equal(temp,archhdr))then
error('archive not in proper format');
i:=getword(buf,i,name);
size:=ctoi(buf,i);
gethdr:=true
end
end;
function filearg (var name:xstring):boolean;
var
i:integer;
found:boolean;
begin
if(nfiles<=0)then
filearg:=true
else begin
found:=false;
i:=1;
while(not found) and (i<=nfiles)do begin
if(equal(name,fname[i])) then begin
fstat[i]:=true;
found:=true
end;
i:=i+1
end;
filearg:=found
end
end;
procedure fskip(fd:filedesc;n:integer);
var
c:character;
i:integer;
begin
for i:=1 to n do
if(getcf(c,fd)=endfile)then
error('archive:end of file in fskip')
end;
procedure fmove(var name1,name2:xstring);
var
fd1,fd2:filedesc;
begin
fd1:=mustopen(name1,ioread);
fd2:=mustcreate(name2,iowrite);
fcopy(fd1,fd2);
xclose(fd1);
xclose(fd2)
end;
procedure acopy(fdi,fdo:filedesc;n:integer);
var
c:character;
i:integer;
begin
for i:=1 to n do
if (getcf(c,fdi)=endfile)then
error('archive: end of file in acopy')
else
putcf(c,fdo)
end;
procedure notfound;
var
i:integer;
begin
for i := 1 to nfiles do
if(fstat[i]=false)then begin
putstr(fname[i],stderr);
writeln(':not in archive');
errcount:=errcount + 1
end
end;
procedure addfile(var name:xstring;fd:filedesc);
var
head:xstring;
nfd:filedesc;
procedure makehdr(var name,head:xstring);
var
i:integer;
function fsize(var name:xstring):integer;
var
c:character;
fd:filedesc;
n:integer;
begin
n:=0;
fd:=mustopen(name,ioread);
while(getcf(c,fd)<>endfile)do
n:=n+1;
xclose(fd);
fsize:=n
end;
begin
scopy(archhdr,1,head,1);
i:=xlength(head)+1;
head[i]:=blank;
scopy(name,1,head,i+1);
i:=xlength(head)+1;
head[i]:=blank;
i:=itoc(fsize(name),head,i+1);
head[i]:=newline;
head[i+1]:=endstr
end;
begin
nfd:=open(name,ioread);
if(nfd=ioerror)then begin
putstr(name,stderr);
writeln(':can''t add');
errcount:=errcount+1
end;
if(errcount=0)then begin
makehdr(name,head);
putstr(head,fd);
fcopy(nfd,fd);
xclose(nfd)
end
end;
procedure replace(afd,tfd:filedesc;cmd:integer);
var
pinline,uname:xstring;
size:integer;
begin
while(gethdr(afd,pinline,uname,size))do
if(filearg(uname))then begin
if(cmd=ord('u'))then
addfile(uname,tfd);
fskip(afd,size)
end
else begin
putstr(pinline,tfd);
acopy(afd,tfd,size)
end
end;
procedure help;
begin
error('usage:archive -[cdptux] archname [files...]')
end;
procedure getfns;
var
i,j:integer;
junk:boolean;
begin
errcount:=0;
nfiles:=nargs-3;
if(nfiles>maxfiles)then
error('archive:to many file names');
for i:=1 to nfiles do
junk:=getarg(i+3,fname[i],maxstr);
for i:=1 to nfiles do
fstat[i]:=false;
for i:=1 to nfiles-1 do
for j:=i+1 to nfiles do
if(equal(fname[i],fname[j]))then begin
putstr(fname[i],stderr);
error(':duplicate filename')
end
end;
procedure update(var aname:xstring;cmd:character);
var
i:integer;
afd,tfd:filedesc;
begin
tfd:=mustcreate(archtemp,iowrite);
if(cmd=ord('u')) then begin
afd:=mustopen(aname,ioread);
replace(afd,tfd,ord('u'));(*update existing*)
xclose(afd)
end;
for i:=1 to nfiles do
if(fstat[i]=false)then begin
addfile(fname[i],tfd);
fstat[i]:=true
end;
xclose(tfd);
if(errcount=0)then
fmove(archtemp,aname)
else
writeln('fatal errors - archive not altered');
remove (archtemp)
end;
procedure table(var aname:xstring);
var
head,name:xstring;
size:integer;
afd:filedesc;
procedure tprint(var buf:xstring);
var
i:integer;
temp:xstring;
begin
i:=getword(buf,1,temp);
i:=getword(buf,i,temp);
putstr(temp,stdout);
putc(blank);
i:=getword(buf,i,temp);(*size*)
putstr(temp,stdout);
putc(newline)
end;
begin
afd:=mustopen(aname,ioread);
while(gethdr(afd,head,name,size))do begin
if(filearg(name))then
tprint(head);
fskip(afd,size)
end;
notfound
end;
procedure extract (var aname:xstring;cmd:character);
var
ename,pinline:xstring;
afd,efd:filedesc;
size : integer;
begin
afd:=mustopen(aname,ioread);
if (cmd=ord('p')) then
efd:=stdout
else
efd:=ioerror;
while (gethdr(afd,pinline,ename,size)) do
if (not filearg(ename))then
fskip(afd,size)
else
begin
if (efd<> stdout) then
efd:=create(ename,iowrite);
if(efd=ioerror) then begin
putstr(ename,stderr);
writeln(': cant''t create');
errcount:=errcount+1;
fskip(afd,size)
end
else begin
acopy(afd,efd,size);
if(efd<>stdout)then
xclose(efd)
end
end;
notfound
end;
procedure delete(var aname:xstring);
var
afd,tfd:filedesc;
begin
if(nfiles<=0)then(*protect innocent*)
error('archive:-d requires explicit file names');
afd:=mustopen(aname,ioread);
tfd:=mustcreate(archtemp,iowrite);
replace(afd,tfd,ord('d'));
notfound;
xclose(afd);
xclose(tfd);
if(errcount=0)then
fmove(archtemp,aname)
else
writeln('fatal errors - archive not altered');
remove(archtemp)
end;
procedure initarch;
begin
archtemp[1]:=ord('a');
archtemp[2]:=ord('r');
archtemp[3]:=ord('t');
archtemp[4]:=ord('e');
archtemp[5]:=ord('m');
archtemp[6]:=ord('p');
archtemp[7]:=endstr;
archhdr[1]:=ord('-');
archhdr[2]:=ord('h');
archhdr[3]:=ord('-');
archhdr[4]:=endstr;
end;
begin
initarch;
if (not getarg(2,cmd,maxstr))
or(not getarg(3,aname,maxstr)) then
help;
getfns;
if(xlength(cmd)<>2) or(cmd[1]<>ord('-')) then
help
else if (cmd[2]=ord('c'))or(cmd[2]=ord('u'))then
update(aname,cmd[2])
else if (cmd[2]=ord('t'))then
table(aname)
else if (cmd[2]=ord('x'))or(cmd[2]=ord('p'))then
extract(aname,cmd[2])
else if (cmd[2]=ord('d'))then
delete(aname)
else
help
end;