(FILECREATED "15-Jun-84 14:08:42" {ERIS}<LISPCORE>LIBRARY>ARCHIVEDIR.;1 8853
changes to: (FNS ARCHIVEDIR RECOVERDIR RECOVERDIR.FILL.PATTERN)
(VARS ARCHIVEDIRCOMS)
previous date: "14-Jun-84 19:17:55" {ERIS}<SYBALSKY>ARCHIVEDIR.;2)
(* Copyright (c) 1984 by John Sybalsky. All rights reserved.)
(PRETTYCOMPRINT ARCHIVEDIRCOMS)
(RPAQQ ARCHIVEDIRCOMS ((FILES LOADDM)
(MACROS \FIXPOUT \WOUT \WIN \WORDIN \FIXPIN CONVERTDATE)
(FNS ARCHIVEDIR ARCHIVELIST DUMPDM LISTDM RECOVERDIR RECOVERDIR.FILL.PATTERN)))
(FILESLOAD LOADDM)
(DECLARE: EVAL@COMPILE
(PUTPROPS \FIXPOUT MACRO (OPENLAMBDA (OFD FIXP)
(\WOUT OFD (LOGAND 65535 (LRSH FIXP 16)))
(\WOUT OFD (LOGAND 65535 FIXP))))
(PUTPROPS \WOUT MACRO (OPENLAMBDA (STREAM W)
(\BOUT STREAM (fetch HIBYTE of W))
(\BOUT STREAM (fetch LOBYTE of W))))
(PUTPROPS \WIN MACRO (OPENLAMBDA (STREAM)
(create WORD
HIBYTE ←(\BIN STREAM)
LOBYTE ←(\BIN STREAM))))
(PUTPROPS \WORDIN MACRO (OPENLAMBDA (OFD)
(LOGOR (LLSH (\BIN OFD)
8)
(\BIN OFD))))
(PUTPROPS \FIXPIN MACRO (OPENLAMBDA (OFD)
(LOGOR (LLSH (\WORDIN OFD)
16)
(\WORDIN OFD))))
(PUTPROPS CONVERTDATE 10MACRO ((X)
(ALTO.TO.TENEX.DATE X)))
(PUTPROPS CONVERTDATE MACRO ((X)
X))
)
(DEFINEQ
(ARCHIVEDIR
[LAMBDA (DIRECT FILE) (* jds "15-Jun-84 14:02")
(* Archive the files in a directory onto MAXC)
(PROG ([FILES (DIRECTORY (PACK* DIRECT (QUOTE *]
[OUTFILE (PACK* (QUOTE {MAXC}IFS-ARCHIVE.)
(LISTGET (UNPACKFILENAME DIRECT)
(QUOTE DIRECTORY]
WASOPEN)
[COND
(FILE (COND
((OPENP FILE)
(SETQ WASOPEN T))
(T (SETQ FILE (OPENSTREAM FILE (QUOTE OUTPUT)
(QUOTE NEW]
(DUMPDM OUTFILE FILES (OR FILE T))
(OR WASOPEN (AND FILE (CLOSEF? FILE])
(ARCHIVELIST
[LAMBDA (DIRS) (* jds "17-NOV-83 14:03")
(PROG [(LIST (OPENSTREAM (QUOTE {LPT})
(QUOTE OUTPUT]
(for DIR in DIRS
do (printout LIST T T 30 "-----Archive of directory " DIR "-----" T T T)
(ARCHIVEDIR DIR LIST)
(BOUT LIST (CHARCODE ↑L])
(DUMPDM
[LAMBDA (FILE DUMPLIST PRINTFLG) (* jds "17-NOV-83 14:07")
(* Dumps a list of files into a DM-format file that can
be re-read with LOADDM (only?))
(RESETLST (PROG (OUTOFD BT N OFD (OUTFILE (CONS))
FILESIZE)
[RESETSAVE [SETQ FILE (OPENFILE FILE (QUOTE OUTPUT)
(QUOTE NEW)
8
(QUOTE ((TYPE BINARY]
(QUOTE (PROGN (CLOSEF? OLDVALUE]
(SETQ OFD (GETSTREAM FILE))
(for FNAME in DUMPLIST
do (* For each file to be dumped,)
(SETQ IFILE (OPENSTREAM FNAME (QUOTE INPUT)
(QUOTE OLD)
8)) (* Name block)
(\BOUT OFD 255)
(\WOUT OFD 0)
(for CH in (CHCON (fetch FULLNAME of IFILE)) do (\BOUT OFD CH)
finally (\BOUT OFD 0))
[COND
(PRINTFLG (printout PRINTFLG T (fetch FULLNAME of IFILE]
(* Creation date block)
(\BOUT OFD 251)
(\FIXPOUT OFD (GETFILEINFO IFILE (QUOTE ICREATIONDATE)))
(\WOUT OFD 0) (* Data block)
[for BP from 0 to (SUB1 (GETEOFPTR IFILE)) by 32767
do (* Put it out in blocks of 32767 bytes max)
(\BOUT OFD 254) (* Mark this data block)
(\WOUT OFD (IMIN 32767 (IDIFFERENCE (GETEOFPTR IFILE)
BP)))
(\WOUT OFD 0)
(COPYBYTES IFILE OFD BP (IMIN (GETEOFPTR IFILE)
(IPLUS BP 32767]
(AND PRINTFLG (printout PRINTFLG " " (SUB1 (GETEOFPTR IFILE))
" bytes."))
(CLOSEF? IFILE)
finally (* End block)
(\BOUT OFD 252])
(LISTDM
[LAMBDA (FILE ASK ALLMODE) (* jds "16-NOV-83 18:46")
(* List the files (and their lengths) from a DM-type
archive file)
(RESETLST (PROG (OUTOFD BT N OFD (OUTFILE (CONS))
FILESIZE)
[RESETSAVE [SETQ FILE (OPENFILE FILE (QUOTE INPUT)
(QUOTE OLD)
8
(QUOTE ((TYPE BINARY]
(QUOTE (PROGN (CLOSEF? OLDVALUE]
(SETQ OFD (GETSTREAM FILE))
(do (SELECTQ (SETQ BT (\BIN OFD))
(255 (* name block)
(AND FILESIZE (printout T FILESIZE " bytes." T))
(\BIN OFD)
(\BIN OFD) (* ignore checksum)
(printout T (READNAME OFD)
" ")
(SETQ FILESIZE 0))
(254 (* data block)
(SETQ N (IPLUS (LLSH (\BIN OFD)
8)
(\BIN OFD)))
(\BIN OFD)
(\BIN OFD)
(FRPTQ N (\BIN OFD))
(add FILESIZE N))
(251 (* creation date)
(\FIXPIN OFD)
(\WORDIN OFD))
(252 (* END BLOCK)
(printout T FILESIZE " bytes." T)
(RETURN))
(ERROR BT "ILLEGAL BLOCK TYPE"])
(RECOVERDIR
[LAMBDA (FILE PATTERN) (* jds "15-Jun-84 14:08")
(* Recover files from a Phylum backup file)
(RESETLST (PROG ([FILEPATTERNS (for PAT in PATTERN collect (CHCON (RECOVERDIR.FILL.PATTERN PAT]
OUTOFD BT N OFD (OUTFILE (CONS)))
[RESETSAVE (SETQ FILE (OPENFILE FILE (QUOTE INPUT)
(QUOTE OLD)
8))
(QUOTE (PROGN (CLOSEF? OLDVALUE]
(SETQ OFD (GETSTREAM FILE))
[RESETSAVE NIL (LIST (FUNCTION (LAMBDA (X)
(COND
((CAR X)
(CLOSEF? (CAR X))
(AND RESETSTATE (DELFILE (CAR X]
(do (SELECTQ (SETQ BT (\BIN OFD))
(255 (* name block)
(\BIN OFD)
(\BIN OFD) (* ignore checksum)
(PRIN2 (SETQ N (READNAME OFD))
T T)
[AND (CAR OUTFILE)
(CLOSEF (PROG1 (CAR OUTFILE)
(RPLACA OUTFILE]
(SETQ OUTOFD NIL)
(COND
((for PAT in FILEPATTERNS thereis (DIRECTORY.MATCH PAT N))
(* This file matches one of the requested patterns)
(SETQ OUTOFD (GETSTREAM (CAR (RPLACA OUTFILE
(OPENFILE
N
(QUOTE OUTPUT)
(QUOTE NEW)
8)))
(QUOTE OUTPUT)))
(PRIN1 "--Restoring...")))
(TERPRI T))
[254 (* data block)
(SETQ N (IPLUS (LLSH (\BIN OFD)
8)
(\BIN OFD)))
(\BIN OFD)
(\BIN OFD)
(COND
[OUTOFD (FRPTQ N (\BOUT OUTOFD (\BIN OFD]
(T (SETFILEPTR OFD (IPLUS N (GETFILEPTR OFD]
(251 (* creation date)
[SETQ N (CONVERTDATE (PROG1 (\FIXPIN OFD)
(\WORDIN OFD]
(AND OUTOFD (SETFILEINFO OUTOFD (QUOTE ICREATIONDATE)
N)))
(252 (* END BLOCK)
(RETURN))
(ERROR BT "ILLEGAL BLOCK TYPE"])
(RECOVERDIR.FILL.PATTERN
[LAMBDA (PATTERN DEFAULTEXT DEFAULTVERS) (* jds "15-Jun-84 10:52")
(* Fill in the pattern for a file specifier with default
name, version, and extension)
(for TAIL on (SETQ PATTERN (UNPACKFILENAME.STRING (CONCAT "<*>" PATTERN))) by (CDDR TAIL)
bind SAWNAME SAWVERSION SAWEXT
do (SELECTQ (CAR TAIL)
(NAME (SETQ SAWNAME T))
(VERSION (SETQ SAWVERSION T))
(EXTENSION (SETQ SAWEXT T))
NIL)
(OR (CADR TAIL)
(RPLACA (CDR TAIL)
"")) (* To get around bug in PACKFILENAME where it leaves out
punctuation when field is NIL)
finally (OR SAWNAME (push PATTERN (QUOTE NAME)
(QUOTE *)))
[OR SAWVERSION (push PATTERN (QUOTE VERSION)
(OR DEFAULTVERS (QUOTE *]
[OR SAWEXT (push PATTERN (QUOTE EXTENSION)
(OR DEFAULTEXT (QUOTE *]
(RETURN (PACKFILENAME PATTERN])
)
(PUTPROPS ARCHIVEDIR COPYRIGHT ("John Sybalsky" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1376 8776 (ARCHIVEDIR 1386 . 2033) (ARCHIVELIST 2035 . 2386) (DUMPDM 2388 . 4256) (
LISTDM 4258 . 5596) (RECOVERDIR 5598 . 7698) (RECOVERDIR.FILL.PATTERN 7700 . 8774)))))
STOP