Category : Pascal Source Code
Archive   : SOFTOOLS.ZIP
Filename : CHAPTER3.PAS

{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;