# ========== archive program from chapter 3 ========== define(NAMESIZE,20) define(MAXFILES,5) define(TBL,LETT) define(PRINT,LETP) define(EXTR,LETX) define(UPD,LETU) define(DEL,LETD) common /carch/ fname(NAMESIZE,MAXFILES),fstat(MAXFILES),nfiles,errcnt character fname # file arguments integer fstat # YES if touched, NO otherwise; init = NO integer nfiles # number of file args integer errcnt # error count; init = 0 # acopy - copy size characters from fdi to fdo subroutine acopy(fdi, fdo, size) character getch character c integer fdi, fdo, i, size for (i = 1; i <= size; i = i + 1) { if (getch(c, fdi) == EOF) break call putch(c, fdo) } return end # addfil - add file "name" to archive subroutine addfil(name, fd, errcnt) character head(MAXLINE), name(ARB) integer open integer errcnt, fd, nfd nfd = open(name, READ) if (nfd == ERR) { call putlin(name, ERROUT) call remark(": can't add.") errcnt = errcnt + 1 } if (errcnt == 0) { call makhdr(name, head) call putlin(head, fd) call fcopy(nfd, fd) call close(nfd) } return end # amove - move name1 to name2 subroutine amove(name1, name2) character name1(ARB), name2(ARB) integer create, open integer fd1, fd2 fd1 = open(name1, READ) if (fd1 == ERR) call cant(name1) fd2 = create(name2, WRITE) if (fd2 == ERR) call cant(name2) call fcopy(fd1, fd2) return end # archive - file maintainer character aname(NAMESIZE) integer getarg integer comand(2) if (getarg(1, comand, 2) == EOF | getarg(2, aname, NAMESIZE) == EOF) call help call getfns if (comand(1) == UPD) call update(aname) else if (comand(1) == TBL) call table(aname) else if (comand(1) == EXTR | comand(1) == PRINT) call extrac(aname, comand(1)) else if (comand(1) == DEL) call delete(aname) else call help stop end # block data for archive block data include carch data errcnt /0/ end # delete - delete files from archive subroutine delete(aname) character aname(NAMESIZE), in(MAXLINE) integer create, open integer afd, tfd include carch # string tname "archtemp" integer tname(9) data tname(1), tname(2), tname(3), tname(4)/LETA, LETR, LETC, LETH/ data tname(5), tname(6), tname(7), tname(8)/LETT, LETE, LETM, LETP/ data tname(9)/EOS/ if (nfiles <= 0) # protect innocents call error("delete by name only.") afd = open(aname, READWRITE) if (afd == ERR) call cant(aname) tfd = create(tname, READWRITE) if (tfd == ERR) call cant(tname) call replac(afd, tfd, DEL, errcnt) call notfnd call close(afd) call close(tfd) if (errcnt == 0) call amove(tname, aname) else call remark("fatal errors - archive not altered.") call remove(tname) return end # extrac - extract files from archive subroutine extrac(aname, cmd) character aname(NAMESIZE), ename(NAMESIZE), in(MAXLINE) integer create, filarg, gethdr, open integer afd, cmd, efd, size include carch afd = open(aname, READ) if (afd == ERR) call cant(aname) if (cmd == PRINT) efd = STDOUT else efd = ERR while (gethdr(afd, in, ename, size) ^= EOF) if (filarg(ename) == NO) call fskip(afd, size) else { if (efd ^= STDOUT) efd = create(ename, WRITE) if (efd == ERR) { call putlin(ename, ERROUT) call remark(": can't create.") errcnt = errcnt + 1 call fskip(afd, size) } else { call acopy(afd, efd, size) if (efd ^= STDOUT) call close(efd) } } call notfnd return end # filarg - check if name matches argument list integer function filarg(name) character name(ARB) integer equal, getarg integer i include carch if (nfiles <= 0) { filarg = YES return } for (i = 1; i <= nfiles; i = i + 1) if (equal(name, fname(1, i)) == YES) { fstat(i) = YES filarg = YES return } filarg = NO return end # fsize - size of file in characters integer function fsize(name) character getch character c, name(ARB) integer open integer fd fd = open(name, READ) if (fd == ERR) fsize = ERR else { for (fsize = 0; getch(c, fd) ^= EOF; fsize = fsize + 1) ; call close(fd) } return end # fskip - skip n characters on file fd subroutine fskip(fd, n) character getch character c integer fd, i, n for (i = 1; i <= n; i = i + 1) if (getch(c, fd) == EOF) break return end # getfns - get file names into fname, check for duplicates subroutine getfns integer equal, getarg integer i, j include carch errcnt = 0 for (i = 1; i <= MAXFILES; i = i + 1) if (getarg(i+2, fname(1, i), NAMESIZE) == EOF) break nfiles = i - 1 if (i > MAXFILES) if (getarg(i+2, j, 1) ^= EOF) call error("too many file names.") for (i = 1; i <= nfiles; i = i + 1) fstat(i) = NO for (i = 1; i < nfiles; i = i + 1) for (j = i + 1; j <= nfiles; j = j + 1) if (equal(fname(1, i), fname(1, j)) == YES) { call putlin(fname(1, i), ERROUT) call error(": duplicate file name.") } return end # gethdr - get header info from fd integer function gethdr(fd, buf, name, size) character buf(MAXLINE), c, name(NAMESIZE), temp(NAMESIZE) integer ctoi, equal, getlin, getwrd integer fd, i, len, size # string hdr "-h-" integer hdr(4) data hdr(1),hdr(2),hdr(3),hdr(4)/MINUS,LETH,MINUS,EOS/ if (getlin(buf, fd) == EOF) { gethdr = EOF return } i = 1 len = getwrd(buf, i, temp) if (equal(temp, hdr) == NO) call error("archive not in proper format.") gethdr = YES len = getwrd(buf, i, name) size = ctoi(buf, i) return end # getwrd - get non-blank word from in(i) into out, increment i integer function getwrd(in, i, out) integer in(ARB), out(ARB) integer i, j while (in(i) == BLANK | in(i) == TAB) i = i + 1 j = 1 while (in(i)^=EOS & in(i)^=BLANK & in(i)^=TAB & in(i)^=NEWLINE) { out(j) = in(i) i = i + 1 j = j + 1 } out(j) = EOS getwrd = j - 1 return end # help - diagnostic printout subroutine help call error("usage: archive {dptux} archname Õfileså.") return end define(MAXCHARS,10) # makhdr - make header line for archive member subroutine makhdr(name, head) character head(MAXLINE), name(NAMESIZE) integer fsize, itoc, length integer i # string hdr "-h-" integer hdr(4) data hdr(1),hdr(2),hdr(3),hdr(4)/MINUS,LETH,MINUS,EOS/ call scopy(hdr, 1, head, 1) i = length(hdr) + 1 head(i) = BLANK call scopy(name, 1, head, i+1) i = length(head) + 1 head(i) = BLANK i = i + 1 + itoc(fsize(name), head(i+1), MAXCHARS) head(i) = NEWLINE head(i+1) = EOS return end # notfnd - print "not found" message subroutine notfnd integer i include carch for (i = 1; i <= nfiles; i = i + 1) if (fstat(i) == NO) { call putlin(fname(1, i), ERROUT) call remark(": not in archive.") errcnt = errcnt + 1 } return end # replac - replace or delete files subroutine replac(afd, tfd, cmd, errcnt) character in(MAXLINE), uname(NAMESIZE) integer filarg, gethdr integer afd, cmd, errcnt, size, tfd while (gethdr(afd, in, uname, size) ^= EOF) if (filarg(uname) == YES) { if (cmd == UPD) # add new one call addfil(uname, tfd, errcnt) call fskip(afd, size) # discard old one } else { call putlin(in, tfd) call acopy(afd, tfd, size) } return end # table - print table of archive contents subroutine table(aname) character aname(NAMESIZE), in(MAXLINE), lname(NAMESIZE) integer filarg, gethdr, open integer afd, size afd = open(aname, READ) if (afd == ERR) call cant(aname) while (gethdr(afd, in, lname, size) ^= EOF) { if (filarg(lname) == YES) call tprint(in) call fskip(afd, size) } call notfnd return end # tprint - print table entry for one member subroutine tprint(buf) character buf(ARB) call putlin(buf, STDOUT) return end # update - update existing files, add new ones at end subroutine update(aname) character aname(NAMESIZE) integer create, getarg, open integer afd, i, tfd include carch # string tname "archtemp" integer tname(9) data tname(1), tname(2), tname(3), tname(4)/LETA, LETR, LETC, LETH/ data tname(5), tname(6), tname(7), tname(8)/LETT, LETE, LETM, LETP/ data tname(9)/EOS/ afd = open(aname, READWRITE) if (afd == ERR) # maybe it's a new one afd = create(aname, READWRITE) if (afd == ERR) call cant(aname) tfd = create(tname, READWRITE) if (tfd == ERR) call cant(tname) call replac(afd, tfd, UPD, errcnt) # update existing for (i = 1; i <= nfiles; i = i + 1) # add new ones if (fstat(i) == NO) { call addfil(fname(1, i), tfd, errcnt) fstat(i) = YES } call close(afd) call close(tfd) if (errcnt == 0) call amove(tname, aname) else call remark("fatal errors - archive not altered.") call remove(tname) return end