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