#-h- arcsym 928 asc 31-oct-80 17:11:08 [002,100] #definitions for the archiver # put on a file named 'arcsym' # Used by the archiver define(NAMESIZE,FILENAMESIZE) # Max number of characters in # file name (includes EOS) define(MAXFILES,25) # Max number of files allowed per archive call define(MAXCHARS,20) # Max number of characters allowed in header for # the size of the file define(TBL,LETT) # Command to print table of contents define(PRINT,LETP) # Command to print files define(EXTR,LETX) # Command to extract files from archive define(UPD,LETU) # Command to update archive define(DEL,LETD) # Command to delete files from archive define(SALVAGE,LETS) # command to salvage damaged archive define(VRBS,LETV) # Command to set "verbose" flag define(TWOCOLWIDTH,20) # fixed width of filename in header define(RIGHT_MARGIN,80) # right margin position for packed names #-h- carch 684 asc 31-oct-80 17:11:10 [002,100] # /carch/ common block holding file info for the archiver # put on a file named 'carch' # Used only by the archiver common / carch / fstat(MAXFILES), fcount, errcnt, verbos, packit, nxtcol, fname(NAMESIZE, MAXFILES), obuf(MAXLINE) integer fstat # YES if touched, NO otherwise; init = NO integer fcount # number of file args integer errcnt # error count; init = 0 integer verbos # verbose flag; init = NO integer packit # whether to pack table names in columns integer nxtcol # next column position for packing names character fname # file arguments character obuf # buffer for formatting packed names #-h- arhdr 415 asc 31-oct-80 17:11:10 [002,100] # /hdr/ - common block holding header info for archiver # put on a file called 'arhdr' # Used only by the archiver common /hdr/ new, hdr(5), asc(4), local(6), bin(4), user(USERSIZE) integer new #flag for new file character hdr #header flag character asc #flag for ascii files character local #flag for local character files character bin #flag for binary files character user # user's name #-h- ar.r 13361 asc 31-oct-80 17:11:13 [002,100] #-h- main 133 asc 31-oct-80 17:01:19 # include symbol definitions # include symbols include arcsym # main driver for archiver #call initr4 #call ar #call endr4 #end #-h- addfil 715 asc 31-oct-80 17:01:20 ## AddFil - Add file `name' to archive subroutine addfil(name, fd, errct) character head(MAXLINE), name(ARB) integer open, fsize # function(s) integer errct, fd, nfd, size, type include carch nfd = open(name, READ) if( nfd == ERR ) { call putlin("? ", ERROUT) call putlin(name, ERROUT) call remark(": can't add.") errct = errct + 1 return } call gettyp(nfd, type) call close(nfd) #need file space, so close for now if( errct == 0 ) { size = fsize (name) call makhdr (name, head, size, type) if( verbos == YES ) { call putlin (name, STDOUT) call putch (NEWLINE, STDOUT) } nfd = open(name,READ) call putlin(head, fd) call acopy (nfd, fd, size) call close(nfd) } return end #-h- ars 1083 asc 31-oct-80 17:01:22 ## ar - Driver subroutine for `ar' - file maintainer. #subroutine ar subroutine main character aname(NAMESIZE) integer getarg, ovride character comand(3) include carch include arhdr data errcnt /0/ data verbos /NO/ #Set up header format data hdr /SHARP, MINUS, LETH, MINUS, EOS/ data asc /LETA, LETS, LETC, EOS/ data local /LETL, LETO, LETC, LETA, LETL, EOS/ data bin /LETB, LETI, LETN, EOS/ if( getarg(1, comand, 3) == EOF | getarg(2, aname, NAMESIZE) == EOF | comand(1) == QMARK & comand(2) == EOS) call help call fold(comand) # Fold commands to lowercase. packit = YES if( comand(2) == VRBS ) verbos = YES else if (comand(2) == DIG1) packit = NO call initar # initialize common blocks call getfns # Put file names in array. 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 delet(aname) else if( comand(1) == SALVAGE ) call recovr(aname) else call help return end #-h- delet 689 asc 31-oct-80 17:01:23 ## delet - Delete file(s) from archive. subroutine delet (aname) character aname(NAMESIZE), in(MAXLINE), tfile(FILENAMESIZE) integer create, open # function(s) integer afd, tfd include carch string tname "arctemp" if( fcount <= 0 ) call error("? Delete by name only.") afd = open(aname, READ) # Open archive file. if( afd == ERR ) call cant(aname) call scratf(tname, tfile) # Open scratch file. tfd = create(tfile, WRITE) if( tfd == ERR ) call cant(tfile) call replac(afd, tfd, DEL, errcnt) call notfnd call close(afd) call close(tfd) if( errcnt == 0 ) call amove(tfile, aname) else call remark("? Fatal errors - archive not altered.") call remove(tfile) return end #-h- extrac 984 asc 31-oct-80 17:01:24 ## extrac - Extract files from archive. subroutine extrac(aname, cmd) character aname(NAMESIZE), ename(NAMESIZE), in(MAXLINE), cmd integer create, filarg, gethdr, open, equal # function(s) integer afd, efd, size, type include carch include arhdr afd = open(aname, READ) if( afd == ERR ) call cant(aname) if( cmd == PRINT ) efd = STDOUT else efd = ERR while( gethdr(afd, in, ename, size, type) != EOF ) { if( filarg(ename) == NO ) call arskip(afd, size) else { if( efd != STDOUT ) efd = create(ename, WRITE) if (efd == ERR) { call putlin("? ", ERROUT) call putlin(ename, ERROUT) call remark(": can't create.") errcnt = errcnt + 1 call arskip(afd, size) } else { if( verbos == YES ) { call putlin(ename, STDOUT) call putch(NEWLINE, STDOUT) } call acopy(afd, efd, size) if( efd != STDOUT ) call close(efd) } } } call notfnd return end #-h- filarg 365 asc 31-oct-80 17:01:25 ## FilArg - Test `name' against argument list. integer function filarg(name) character name(ARB) integer equal # function(s) integer i include carch if( fcount <= 0 ) { filarg = YES return } for( i = 1 ; i <= fcount ; i = i + 1 ) if( equal(name, fname(1, i) ) == YES) { fstat(i) = YES filarg = YES return } filarg = NO return end #-h- gethdr 811 asc 31-oct-80 17:01:26 ## GetHdr - Get header info from archive member `fd'. integer function gethdr(fd, buf, name, size, type) character buf(MAXLINE), c, name(NAMESIZE), temp(NAMESIZE) integer ctoi, equal, getlin, getwrd # function(s) integer fd, i, len, size, type include arhdr #***kludge since EOF isn't always sensed on an empty file if( new ) { gethdr = EOF return } if( getlin(buf, fd) == EOF ) { gethdr = EOF return } call fold(buf) 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) len = getwrd (buf, i+1, temp) if( len <= 0 | equal(temp,asc) ) type = ASCII else if( equal(temp, local) ) type = LOCAL else if( equal(temp, bin) ) type = BINARY else type = ASCII return end #-h- help 120 asc 31-oct-80 17:01:27 ## help - Print help message. subroutine help call error("? Usage: ar {dpstux}[v/1] arcname [files].") return end #-h- makhdr 1299 asc 31-oct-80 17:01:28 ## MakHdr - Make header line for archive member. subroutine makhdr(name, head, size, type) character head(MAXLINE), name(NAMESIZE), filsiz(MAXCHARS), temp(FILENAMESIZE) integer itoc, length, j, n # function(s) integer size, i, type include arhdr include carch string twoblk " " i = 1 call stcopy(hdr, 1, head, i) # Insert header flag. head(i) = BLANK i = i + 1 call stcopy(name, 1, head, i) # Insert file name. if( size == ERR ) { junk = 0 filsiz(1) = EOS errcnt = errcnt + 1 } else junk = itoc(size, filsiz, MAXCHARS) n = TWOCOLWIDTH - junk - length(name) j = 1 repeat { head(i) = BLANK i = i + 1 j = j + 1 } until (j > n) # padded blanks, at least one call stcopy(filsiz, 1, head, i) # Insert size of file. call stcopy(twoblk, 1, head, i) if( type == ASCII ) # Insert file type. call stcopy(asc, 1, head, i) else if( type == LOCAL ) call stcopy(local, 1, head, i) else if( type == BINARY ) call stcopy(bin, 1, head, i) call stcopy(twoblk, 1, head, i) call gdate (filsiz) # Insert date & time. call stcopy(filsiz, 1, head, i) head(i) = BLANK i = i + 1 call gtime(filsiz) call stcopy(filsiz, 1, head, i) call stcopy(twoblk, 1, head, i) call stcopy(user, 1, head, i) # insert username head(i) = NEWLINE head(i+1) = EOS call fold(head) return end #-h- notfnd 296 asc 31-oct-80 17:01:29 ## NotFnd - Print `not found' message. subroutine notfnd integer i include carch for( i = 1 ; i <= fcount ; i = i + 1 ) if (fstat(i) == NO ) { call putlin("? ", ERROUT) call putlin(fname(1, i), ERROUT) call remark(": not in archive.") errcnt = errcnt + 1 } return end #-h- nxtfl 893 asc 31-oct-80 17:01:30 ## NxtFl - Extract next file from damaged archive. integer function nxtfl(name, afd) character name(ARB), holdnm(FILENAMESIZE), buf(MAXLINE), temp(MAXLINE) integer create, getlin, equal # function(s) integer afd, i include arhdr data holdnm(1) /EOS/ i = afd if( holdnm(1) == EOS ) # Pick up first name. { if( getlin(buf, afd) == EOF ) { nxtfl = EOF return } i = 1 len = getwrd(buf, i, temp) if( equal(temp, hdr) == NO ) call error ("? Archive not in proper format.") len = getwrd(buf, i+len, holdnm) } call scopy(holdnm, 1, name, 1) holdnm(1) = EOS int = create(name, WRITE) # Open file specified. if( int == ERR ) call cant(name) while( getlin(buf, afd) != EOF ) { i = 1 len = getwrd(buf, i, temp) if( equal(temp, hdr) ) { len = getwrd(buf, i+len, holdnm) break } call putlin(buf, int) } call close(int) nxtfl = OK return end #-h- recovr 747 asc 31-oct-80 17:01:32 ## recovr - Recover archived file with incorrect byte counts. subroutine recovr (aname) integer create, open, nxtfl # function(s) integer afd, tfd character aname(ARB), tfile(FILENAMESIZE), name(FILENAMESIZE) include carch string tname "arctemp" afd = open(aname, READ) # Open archive. if( afd == ERR ) call cant(aname) call scratf (tname, tfile) # Open scratch file. tfd = create(tfile, WRITE) if( tfd == ERR ) call cant(tfile) while( nxtfl(name, afd) != EOF )# Loop through all files in archive. { call addfil(name, tfd, errcnt) call remove(name) } call close(afd) call close(tfd) if( errcnt == 0 ) call amove(tfile, aname) else call remark("? Fatal errors - archive not altered.") call remove (tfile) return end #-h- replac 635 asc 31-oct-80 17:01:33 ## replac - Replace or delete files. subroutine replac(afd, tfd, cmd, errct) character in(MAXLINE), uname(NAMESIZE) integer filarg, gethdr # function(s) integer afd, cmd, errct, size, tfd, type include carch while( gethdr(afd, in, uname, size, type) != EOF ) { if( filarg(uname) == YES ) { if( cmd == UPD ) # Add new one. call addfil(uname, tfd, errct) if( verbos == YES & cmd == DEL) { call putlin (uname, STDOUT) call putch (NEWLINE, STDOUT) } call arskip(afd, size) # Discard old one. } else { call putlin(in, tfd) call acopy(afd, tfd, size) } } return end #-h- table 572 asc 31-oct-80 17:01:34 ## table - Print table of archive contents. subroutine table(aname) character aname(NAMESIZE), in(MAXLINE), lname(NAMESIZE) integer filarg, gethdr, open # function(s) integer afd, size, type include carch afd = open(aname, READ) if( afd == ERR ) call cant(aname) if (packit == YES) call inpack(nxtcol, RIGHT_MARGIN, obuf, STDOUT) while( gethdr(afd, in, lname, size, type) != EOF ) { if( filarg(lname) == YES ) call tprint(in) call arskip( afd, size) } if (packit == YES) call flpack(nxtcol, RIGHT_MARGIN, obuf, STDOUT) call notfnd return end #-h- tprint 543 asc 31-oct-80 17:01:35 ## TPrint - Print table entry for one member. subroutine tprint(buf) integer i, j character buf(ARB), name(NAMESIZE) include carch for (i=1 ; buf(i) != BLANK ; i=i+1) # Skip initial header flag. ; j = 1 for( i=i+1 ; buf(i) != BLANK ; i=i+1 ) # Print filename. call chcopy(buf(i), name, j) name(j) = EOS if (packit == YES) call dopack(name, nxtcol, RIGHT_MARGIN, obuf, STDOUT) else { call putlin(name, STDOUT) if (verbos == YES) call putlin(buf(i), STDOUT) else call putch(NEWLINE, STDOUT) } return end #-h- update 1011 asc 31-oct-80 17:01:36 ## update - Update existing files, add new ones at end. subroutine update(aname) character aname(NAMESIZE), tfile(FILENAMESIZE) integer create, getarg, open # function(s) integer afd, i, tfd include carch include arhdr string tname "arctemp" afd = open(aname, READ) if( afd == ERR ) # Maybe it's a new one. ###kludge since EOF can't always be sensed on a new file. { afd = create(aname, WRITE) if( afd == ERR ) call cant(aname) new = YES } else new = NO call close(STDIN) # Save a file slot. call scratf(tname, tfile) # Open scratch file. tfd = create(tfile, WRITE) if( tfd == ERR ) call cant(tfile) call replac(afd, tfd, UPD, errcnt) # Update existing. for( i = 1 ; i <= fcount ; 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(tfile, aname) else call remark("? Fatal errors - archive not altered.") call remove(tfile) return end #-h- arskip 257 asc 31-oct-80 17:01:37 ## arskip - skip n characters on file fd via getlin calls subroutine arskip(fd, n) character buf(MAXLINE) integer fd, i, n, m integer getlin for (i=1; i <= n; ) { m = getlin(buf, fd) if (m == EOF) break i = i + m } return end #-h- initar 191 asc 31-oct-80 17:01:38 subroutine initar integer tty include arhdr include carch call mailid(user, fname(1,1)) if (packit == YES) packit = tty(STDOUT) if (verbos == YES) packit = NO return end #-h- getfns 1086 asc 31-oct-80 17:01:39 ## GetFNs - Get file names into fname, check for duplicates. subroutine getfns character junk(2) integer equal, getarg, getlin # function(s) integer i, j, usein include carch data usein /NO/ errcnt = 0 for( i = 1 ; i <= MAXFILES ; i = i + 1 ) { if( usein == NO ) # Read list of files files from arg list. { if( getarg(i+2, fname(1,i), NAMESIZE) == EOF ) break if( fname(1,i) == MINUS & fname(2,i) == EOS ) usein = YES } if( usein == YES ) # Read list of files from STDIN. { len = getlin(fname(1,i), STDIN) if( len == EOF ) break fname(len,i) = EOS } call fold(fname(1,i)) } fcount = i - 1 if( i > MAXFILES ) if( getarg(i+2, junk, 1) != EOF ) call error('too many file names.') for( i = 1 ; i <= fcount ; i = i + 1 ) { fstat(i) = NO } for( i = 1 ; i < fcount ; i = i + 1 ) for( j = i + 1 ; j <= fcount ; j = j + 1 ) if( equal( fname(1, i), fname(1, j)) == YES ) { call putlin("? ", ERROUT) call putlin(fname(1, i), ERROUT) call error(": duplicate file name.") } return end