(FILECREATED "26-Feb-84 09:35:54" {PHYLUM}<LISP>LIBRARY>WHEREIS.;1 12096
previous date: "24-Feb-84 17:55:37" {PHYLUM}<BURTON>WHEREIS.;9)
(* Copyright (c) 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT WHEREISCOMS)
(RPAQQ WHEREISCOMS [(* WHEREIS from a hashfile)
(E (RESETSAVE CLISPIFYPRETTYFLG NIL))
(FNS WHEREIS \REMOVEOLDVERSIONS)
(FNS WHEREISNOTICE WHEREISNOTICE1 WHEREISNOTICEFN)
[P (OR (BOUNDP (QUOTE WHEREIS.HASH))
(RPAQQ WHEREIS.HASH (<LISP>LIBRARY>WHEREIS.HASH]
(FILES HASH)
(BLOCKS (WHEREISNOTICEBLOCK WHEREISNOTICE1 WHEREISNOTICEFN WHEREISNOTICE
(ENTRIES WHEREISNOTICE1 WHEREISNOTICE WHEREISNOTICEFN)
(NOLINKFNS . T)
(GLOBALVARS WHEREIS.HASH))
(NIL WHEREIS (LOCALVARS . T)
(GLOBALVARS WHEREIS.HASH])
(* WHEREIS from a hashfile)
(DEFINEQ
(WHEREIS
[LAMBDA (NAME TYPE FILES FN) (* rrb "24-Feb-84 16:44")
(DECLARE (GLOBALVARS MSHASHFILENAME))
(PROG (VAL) (* if FN given, APPLY* to each element and return NIL)
(COND
((EQ NAME T) (* T as a NAME has a special meaning to INFILECOMS? so
don't pass through.)
(RETURN NIL)))
(SETQ TYPE (GETFILEPKGTYPE TYPE))
[for FILE in (OR (LISTP FILES)
FILELST)
do (COND
((INFILECOMS? NAME TYPE (FILECOMS FILE))
(COND
(FN (APPLY* FN NAME FILE)))
(SETQ VAL (CONS FILE VAL]
[AND
(EQ FILES T)
(EQ TYPE (QUOTE FNS))
(LITATOM NAME)
(for FILE
inside
[UNION
(AND MSHASHFILENAME (GETRELATION NAME (QUOTE CONTAINS)
T))
(PROGN
[COND
((AND WHEREIS.HASH (NLISTP WHEREIS.HASH))
(* make sure WHEREIS.HASH is a list.)
(SETQ WHEREIS.HASH (CONS WHEREIS.HASH]
(for WHISHSFILE on WHEREIS.HASH
join
(* WHEREIS.HASH is a list of hash file names off of which the hash file structure is linked into the system hash
array. The full file name is hashed.)
(APPEND
(MKLIST
(GETHASHFILE
NAME
(COND
((LISTP (CAR WHISHSFILE)) (* file already has an associated hashfile datatype)
(CDAR WHISHSFILE))
(T (PROG [(HSFILE (OPENHASHFILE (CAR WHISHSFILE]
(* if the data file is ever closed, break the link to
the hash file structure.)
(WHENCLOSE (HASHFILENAME HSFILE)
(QUOTE AFTER)
[FUNCTION (LAMBDA (FILE)
(MAP WHEREIS.HASH
(FUNCTION (LAMBDA (TAIL)
(COND
((EQ FILE (HASHFILENAME
(CDAR TAIL)))
(* remove the hashfile structure for this file's entry
on WHEREIS.HASH.)
(RPLACA TAIL (CAAR TAIL]
(QUOTE CLOSEALL)
(QUOTE NO))
(RPLACA WHISHSFILE (CONS (CAR WHISHSFILE)
HSFILE))
(RETURN HSFILE]
unless (FMEMB FILE VAL)
do (* Order of args to UNION means no extra consing when
MSHASH not present.)
(AND FN (APPLY* FN NAME FILE))
(SETQ VAL (CONS FILE VAL]
(RETURN (AND (NULL FN)
(DREVERSE VAL])
(\REMOVEOLDVERSIONS
[LAMBDA (FULLFILELST) (* rrb "22-Feb-84 18:12")
(* removes all but the newest version of any file on FULLFILELST. Slow version as temporary until DIRECTORY has a
way of asking for only the most recent version.)
(PROG ((EXPANDEDFILELST (for FILE in FULLFILELST collect (UNPACKFILENAME FILE)))
UNIQUELST FILE)
[for EXPTAIL on EXPANDEDFILELST
do (* skip deleted files.)
(AND (SETQ FILE (CAR EXPTAIL))
(PROG [(XDIRECTORY (LISTGET FILE (QUOTE DIRECTORY)))
(XNAME (LISTGET FILE (QUOTE NAME)))
(XEXTENSION (LISTGET FILE (QUOTE EXTENSION)))
(XVERSION (LISTGET FILE (QUOTE VERSION]
(* go thru the list of expanded files and see if there are any other files on the list with the same name.
If so and it is older, delete it. If so and it is newer, don't copy this guy onto the result list.)
(for EFLTAIL on (CDR EXPTAIL)
do (SETQ FILE (CAR EFLTAIL))
[COND
((AND (EQ (LISTGET FILE (QUOTE NAME))
XNAME)
(EQ (LISTGET FILE (QUOTE EXTENSION))
XEXTENSION)
(EQ (LISTGET FILE (QUOTE DIRECTORY))
XDIRECTORY))
(COND
((IGREATERP (LISTGET FILE (QUOTE VERSION))
XVERSION)
(* XFILE should be deleted)
(RETURN NIL))
(T (* mark it deleted. Don't want to play around with the
pointers because the enclosing FOR is using the same
list.)
(RPLACA EFLTAIL NIL]
finally (SETQ UNIQUELST (CONS (CAR EXPTAIL)
UNIQUELST]
(RETURN (for UFILE in UNIQUELST collect (PACKFILENAME UFILE])
)
(DEFINEQ
(WHEREISNOTICE
[LAMBDA (FILEGROUP NEWFLG DATABASEFILE) (* rrb "24-Feb-84 17:54")
(* Copies the current whereis hash-file into a scratch file, then notices the files in FILEGROUP The copy is so
that this function will execute even though someone else is reading the current database. The database is copied
to a scratch file, then renamed to be a newer version of the previous database, which is deleted.
This allows others to use the old database while the copying is going on. If an earlier version of the scratch
file exists, it means that someone else is currently updating (their version disappears when they complete
successfully or logout), so we wait for them to finish.)
(RESETLST (* ASSERT: ((REMOTE CALL) WHEREISNOTICEFN))
(PROG (SCRATCH HF (SCRATCHVAL (LIST NIL))
[DATABASEFILENAME (COND
(DATABASEFILE)
[WHEREIS.HASH
(* if there is a list of files, use the top one.)
(COND
((NLISTP WHEREIS.HASH)
WHEREIS.HASH)
((NLISTP (CAR WHEREIS.HASH))
(CAR WHEREIS.HASH))
(T (CADAR WHEREIS.HASH]
(T (QUOTE <LISPUSERS>WHEREIS.HASH]
OLDWH)
(SETQ OLDWH (INFILEP DATABASEFILENAME))
(DECLARE (SPECVARS HF)) (* HF is the hashfile used freely by WHEREISNOTICE1)
[RESETSAVE (PROGN SCRATCHVAL)
(QUOTE (PROGN (CLOSEF? (CAR OLDVALUE))
(AND RESETSTATE (DELFILE (CAR OLDVALUE]
(* creates a scratch file)
[SETQ HF (CAR (RPLACA SCRATCHVAL (CLOSEF (OPENFILE (SETQ SCRATCH
(PACKFILENAME
(QUOTE DIRECTORY)
(FILENAMEFIELD
DATABASEFILENAME
(QUOTE DIRECTORY))
(QUOTE NAME)
(QUOTE NEWWHEREISDATABASE)
(QUOTE EXTENSION)
(QUOTE SCRATCH)
(QUOTE TEMPORARY)
(QUOTE S)))
(QUOTE OUTPUT)
(QUOTE NEW]
(* Compensate for the fact that PACKFILENAME produces
version -1 for temporary ;S)
(AND (EQ (SYSTEMTYPE)
(QUOTE TOPS20))
(SETQ SCRATCH (PACKFILENAME (QUOTE VERSION)
NIL
(QUOTE BODY)
SCRATCH)))
(* If there is a version earlier than the one we got, someone else must have it, and we must wait until he gets
rid of it (by deleting it))
[bind OLDV (RPT ← 1) until [EQ HF (SETQ OLDV (FULLNAME SCRATCH (QUOTE OLDEST]
do (DISMISS 2000)
(COND
((NULL RPT))
((EQ RPT 5)
(printout T T (GETFILEINFO OLDV (QUOTE AUTHOR))
" seems to be updating the database right now." T
"I'm waiting for him to finish."
T T)
(SETQ RPT NIL))
(T (add RPT 1]
(COND
[(OR NEWFLG (NULL OLDWH))
(SETQ HF (CREATEHASHFILE HF (QUOTE SMALLEXPR)
NIL
(COND
((NUMBERP NEWFLG))
(T 20000]
(T (SETQ HF (COPYHASHFILE OLDWH HF NIL NIL T))
(CLOSEF? OLDWH))) (* Must leave the new file open--otherwise, the user
might lose access to it before he starts to do the
noticing.)
(for X in [\REMOVEOLDVERSIONS
(DIRECTORY (PROG ((FGFIELDS (UNPACKFILENAME FILEGROUP))
DIRPATTERN)
[SETQ DIRPATTERN (PACKFILENAME
(APPEND (UNPACKFILENAME FILEGROUP)
(QUOTE (NAME *]
(RETURN (COND
([AND (FMEMB (QUOTE EXTENSION)
FGFIELDS)
(NULL (LISTGET FGFIELDS
(QUOTE EXTENSION]
(* no extension, must put a dot on since <lisp>* gets all files not just those with no extension so <lisp>*.
is what we want.)
(PACK* DIRPATTERN "."))
(T DIRPATTERN]
do (WHEREISNOTICEFN X))
(SETQ HF (CLOSEHASHFILE HF))
(* This closes the file, but other updaters are still locked out cause they go for a new version and then trip
over our old one.)
(COND
((SETQ HF (RENAMEFILE HF (PACKFILENAME (QUOTE VERSION)
NIL
(QUOTE BODY)
DATABASEFILENAME)))
(DELFILE OLDWH))) (* Now others can get in to read or update.)
(RETURN HF])
(WHEREISNOTICE1
[LAMBDA (FILE TRYHARD) (* lmm "29-SEP-83 22:41")
(DECLARE (USEDFREE HF))
(RESETLST (PROG (NAME MAPPOS DATE VAL)
[RESETSAVE NIL (LIST (QUOTE CLOSEF?)
(SETQ FILE (OPENFILE FILE (QUOTE INPUT)
(QUOTE OLD)
NIL
(QUOTE (DON'T.CHANGE.READ.DATE
DON'T.CHANGE.DATE]
(SETFILEPTR FILE 0)
[OR [AND (EQ (RATOM FILE FILERDTBL)
(QUOTE %())
(EQ (RATOM FILE FILERDTBL)
(QUOTE FILECREATED))
(STRINGP (SETQ DATE (READ FILE FILERDTBL)))
(LITATOM (READ FILE FILERDTBL))
(FIXP (SETQ MAPPOS (READ FILE FILERDTBL]
(RETURN (COND
(MAPPOS "no filemap")
(T (QUOTE "not Lisp source file"]
(COND
((AND (NOT TRYHARD)
(EQUAL (GETHASHFILE FILE HF)
DATE))
(RETURN DATE)))
(SETQ NAME (NAMEFIELD FILE T))
[for X in (CDR (LOADFILEMAP FILE))
do (for Y in (CDDR X) do (OR [NULL (SETQ VAL (LOOKUPHASHFILE
(CAR Y)
NAME HF (QUOTE (INSERT RETRIEVE]
(EQ NAME VAL)
(AND (LISTP VAL)
(FMEMB NAME VAL))
(PUTHASHFILE (CAR Y)
(NCONC1 (OR (LISTP VAL)
(LIST VAL))
NAME)
HF]
(REMPROP NAME (QUOTE FILEMAP))
(PUTHASHFILE FILE DATE HF)
(RETURN FILE])
(WHEREISNOTICEFN
[LAMBDA (FILE TRYHARD) (* lmm "29-SEP-83 22:43")
(TAB 30 NIL T)
(ERSETQ (PRIN2 (WHEREISNOTICE1 FILE TRYHARD)
T T])
)
(OR (BOUNDP (QUOTE WHEREIS.HASH))
(RPAQQ WHEREIS.HASH (<LISP>LIBRARY>WHEREIS.HASH)))
(FILESLOAD HASH)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: WHEREISNOTICEBLOCK WHEREISNOTICE1 WHEREISNOTICEFN WHEREISNOTICE (ENTRIES WHEREISNOTICE1
WHEREISNOTICE
WHEREISNOTICEFN)
(NOLINKFNS . T)
(GLOBALVARS WHEREIS.HASH))
(BLOCK: NIL WHEREIS (LOCALVARS . T)
(GLOBALVARS WHEREIS.HASH))
]
(PUTPROPS WHEREIS COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (841 5422 (WHEREIS 851 . 3521) (\REMOVEOLDVERSIONS 3523 . 5420)) (5423 11597 (
WHEREISNOTICE 5433 . 10000) (WHEREISNOTICE1 10002 . 11399) (WHEREISNOTICEFN 11401 . 11595)))))
STOP