(FILECREATED "29-Nov-84 17:30:12" {ERIS}<LISPCORE>LIBRARY>WHEREIS.;16 14903
changes to: (FNS WHEREIS)
previous date: "17-Nov-84 01:27:09" {ERIS}<LISPCORE>LIBRARY>WHEREIS.;12)
(* Copyright (c) 1983, 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT WHEREISCOMS)
(RPAQQ WHEREISCOMS ((* "WHEREIS from a hashfile")
(FILES HASH)
(COMS (* "This stuff is probably outdated")
(E (RESETSAVE CLISPIFYPRETTYFLG NIL))
(FNS WHEREISNOTICEFN))
(COMS (* "This probably should go into the system somewhere")
(FNS \REMOVEOLDVERSIONS))
(FNS WHEREIS WHEREISNOTICE WHEREISNOTICE1)
(BLOCKS (WHEREISNOTICEBLOCK WHEREISNOTICE WHEREISNOTICE1 WHEREISNOTICEFN
(ENTRIES WHEREISNOTICE WHEREISNOTICE1 WHEREISNOTICEFN)
(NOLINKFNS . T)
(GLOBALVARS WHEREIS.HASH))
(NIL WHEREIS (LOCALVARS . T)
(GLOBALVARS WHEREIS.HASH)))
(ADDVARS (WHEREIS.HASH))))
(* "WHEREIS from a hashfile")
(FILESLOAD HASH)
(* "This stuff is probably outdated")
(DEFINEQ
(WHEREISNOTICEFN
(LAMBDA (FILE TRYHARD) (* JonL "16-Nov-84 23:57")
(if (LISPSOURCEFILEP FILE)
then (ERSETQ (PRIN2 (WHEREISNOTICE1 FILE TRYHARD)
T T)))))
)
(* "This probably should go into the system somewhere")
(DEFINEQ
(\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
(WHEREIS
(LAMBDA (NAME TYPE FILES FN) (* JonL "29-Nov-84 00:13")
(DECLARE (GLOBALVARS MSHASHFILENAME))
(PROG (VAL) (* if FN given, APPLY* to each element and return NIL)
(if (EQ NAME T)
then (* 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 (if (INFILECOMS? NAME TYPE (FILECOMS FILE))
then (if FN
then (APPLY* FN NAME FILE))
(SETQ VAL (CONS FILE VAL))))
(AND (EQ FILES T)
(EQ TYPE (QUOTE FNS))
(LITATOM NAME)
(PROGN (if (AND WHEREIS.HASH (NLISTP WHEREIS.HASH))
then (* make sure WHEREIS.HASH is a list.)
(SETQ WHEREIS.HASH (LIST WHEREIS.HASH)))
(for WHISHSFILE HNAME HSFILE DELP on WHEREIS.HASH
do
(* 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.)
(if (LISTP (SETQ HNAME (CAR WHISHSFILE)))
then (* file already has an associated hashfile datatype)
(SETQ HSFILE (CDR HNAME))
elseif (SETQ HSFILE (FINDFILE HNAME T))
then (if (find X in WHEREIS.HASH
suchthat (AND (LISTP X)
(EQ HSFILE (HASHFILEPROP (CDR X)
(QUOTE NAME)))))
then (* Looks like a duplicate entry)
(RPLACA WHISHSFILE (SETQ HSFILE NIL))
(SETQ DELP T)
else (SETQ HSFILE (OPENHASHFILE HSFILE))
(* if the data file is ever closed, break the link to
the hash file structure.)
(WHENCLOSE (HASHFILEPROP HSFILE (QUOTE NAME))
(QUOTE BEFORE)
(FUNCTION (LAMBDA (FILE)
(SETQ FILE (FULLNAME FILE))
(for TAIL on WHEREIS.HASH
when (AND (LISTP (CAR TAIL))
(EQ FILE (HASHFILEPROP
(CDAR TAIL)
(QUOTE NAME))))
do
(* remove the hashfile structure for this file's entry
on WHEREIS.HASH.)
(RPLACA TAIL (CAAR TAIL)))))
(QUOTE CLOSEALL)
(QUOTE NO))
(RPLACA WHISHSFILE (CONS HNAME HSFILE)))
else (OR (EQ (QUOTE Y)
(ASKUSER 120 (QUOTE Y)
(CONCAT HNAME
", a file on WHEREIS.HASH, not found -- do you want to delete and continue?")
(QUOTE ((Y "es")
(N "o")))))
(ERRORX (LIST 23 HNAME)))
(RPLACA WHISHSFILE (SETQ HSFILE NIL))
(SETQ DELP T))
(if HSFILE
then (for FILE inside (GETHASHFILE NAME HSFILE)
when (NOT (FMEMB FILE VAL))
do (AND FN (APPLY* FN NAME FILE))
(push VAL FILE)))
finally (if DELP
then (SETQ WHEREIS.HASH (DREMOVE NIL WHEREIS.HASH))))))
(RETURN (AND (NULL FN)
(DREVERSE VAL))))))
(WHEREISNOTICE
(LAMBDA (FILEGROUP NEWFLG DATABASEFILE) (* JonL "17-Nov-84 00:55")
(* 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
(PROG (SCRATCH HF (SCRATCHVAL (LIST NIL))
(DATABASEFILENAME (OR DATABASEFILE (if WHEREIS.HASH
then
(* if there is a list of files, use the top one.)
(if (NLISTP WHEREIS.HASH)
then WHEREIS.HASH
elseif (NLISTP (CAR WHEREIS.HASH))
then (CAR WHEREIS.HASH)
else (CAAR WHEREIS.HASH))
else (QUOTE WHEREIS.HASH))))
OLDWH)
(DECLARE (SPECVARS HF)) (* HF is the hashfile used freely by WHEREISNOTICE1)
(SETQ OLDWH (INFILEP DATABASEFILENAME))
(RESETSAVE NIL (LIST (FUNCTION (LAMBDA (X)
(if (CAR X)
then (CLOSEF? (CAR X))
(AND RESETSTATE (DELFILE (CAR X))))))
SCRATCHVAL)) (* creates a scratch file)
(if (AND OLDWH (NOT NEWFLG))
then (* copy old one)
(RPLACA SCRATCHVAL (SETQ HF (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)
(OR (NULL RPT)
(if (EQ RPT 5)
then (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)
else (add RPT 1))))
(SETQ HF (COPYHASHFILE OLDWH HF NIL NIL T))
(CLOSEF? OLDWH)
elseif (AND OLDWH (EQ NEWFLG (QUOTE NOCOPY)))
then (SETQ HF (OPENHASHFILE OLDWH (QUOTE BOTH)
NIL))
else (SETQ HF (CREATEHASHFILE DATABASEFILENAME (QUOTE SMALLEXPR)
NIL
(OR (NUMBERP NEWFLG)
20000)))
(SETQ NEWFLG T)) (* 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
(for FILESPEC TEM inside FILEGROUP
join (if (SETQ TEM (INFILEP FILESPEC))
then (* an individual file)
(LIST TEM)
else (* a specification for a group of files, expand it.)
(DIRECTORY (PROG ((FGFIELDS (UNPACKFILENAME FILESPEC))
DIRPATTERN)
(SETQ DIRPATTERN
(PACKFILENAME (APPEND (UNPACKFILENAME FILESPEC)
(QUOTE (NAME *)))))
(if (AND (FMEMB (QUOTE EXTENSION)
FGFIELDS)
(NULL (LISTGET FGFIELDS (QUOTE EXTENSION)
)))
then
(* no extension, must put a dot on since <lisp>* gets all files not just those with no extension so <lisp>*.
is what we want.)
(SETQ DIRPATTERN (PACK* DIRPATTERN ".")))
(RETURN (if (NULL (FMEMB (QUOTE VERSION)
FGFIELDS))
then
(* pass in a pattern that only gets the most recent
version unless one is specified.)
(PACK* DIRPATTERN ";")
else DIRPATTERN)))))))
do (if (LISPSOURCEFILEP X)
then (ERSETQ (printout T .P2 (WHEREISNOTICE1 X)
-2))))
(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.)
(OR NEWFLG (if (SETQ HF (RENAMEFILE HF (PACKFILENAME (QUOTE VERSION)
NIL
(QUOTE BODY)
DATABASEFILENAME)))
then (DELFILE OLDWH))) (* Now others can get in to read or update.)
(RETURN HF)))))
(WHEREISNOTICE1
(LAMBDA (FILE TRYHARD) (* JonL "17-Nov-84 00:38")
(DECLARE (USEDFREE HF))
(* * Note that we won't even be coming here unless FILE is LISPSOURCEFILEP)
(RESETLST (PROG (NAME MAP MAPPOS DATE VAL)
(RESETSAVE (SETQ FILE (OPENFILE FILE (QUOTE INPUT)
(QUOTE OLD)
NIL
(QUOTE (DON'T.CHANGE.READ.DATE DON'T.CHANGE.DATE))
))
(QUOTE (PROGN (CLOSEF? OLDVALUE))))
(SETFILEPTR FILE 0)
(SETQ MAP (OR (GETFILEMAP FILE)
(GETFILEMAP FILE T)
(RETURN "Can't find filemap")))
(if (AND (NOT TRYHARD)
(EQUAL (SETQ DATE (FILEDATE FILE))
(GETHASHFILE FILE HF))
DATE)
then (RETURN (LIST FILE DATE)))
(SETQ NAME (NAMEFIELD FILE T))
(for X in (CDR MAP) 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)))))
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: WHEREISNOTICEBLOCK WHEREISNOTICE WHEREISNOTICE1 WHEREISNOTICEFN (ENTRIES WHEREISNOTICE
WHEREISNOTICE1
WHEREISNOTICEFN)
(NOLINKFNS . T)
(GLOBALVARS WHEREIS.HASH))
(BLOCK: NIL WHEREIS (LOCALVARS . T)
(GLOBALVARS WHEREIS.HASH))
]
(ADDTOVAR WHEREIS.HASH )
(PUTPROPS WHEREIS COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1043 1289 (WHEREISNOTICEFN 1053 . 1287)) (1354 3263 (\REMOVEOLDVERSIONS 1364 . 3261)) (
3264 14480 (WHEREIS 3274 . 6991) (WHEREISNOTICE 6993 . 12959) (WHEREISNOTICE1 12961 . 14478)))))
STOP