(FILECREATED "31-Aug-86 17:00:57" {ERIS}<LISPCORE>LIBRARY>WHEREIS.;4 21680
changes to: (FNS HASHFILE-WHEREIS WHEREISNOTICE WHEREISNOTICE1)
(VARS WHEREISCOMS)
previous date: "28-Apr-86 14:00:59" {ERIS}<LISPCORE>LIBRARY>WHEREIS.;3)
(* Copyright (c) 1983, 1984, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT WHEREISCOMS)
(RPAQQ WHEREISCOMS ((* "WHEREIS from a hashfile")
(FILES HASH)
(COMS (* "This probably should go into the system somewhere")
(FNS \REMOVEOLDVERSIONS))
(FNS HASHFILE-WHEREIS CLOSEWHEREIS WHEREISNOTICE WHEREISNOTICE1)
(ADDVARS (WHEREIS.HASH))
(GLOBALVARS WHEREIS.HASH)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD (QUOTE HASHFILE-WHEREIS)
(QUOTE WHEREIS)))
(ADDVARS (AROUNDEXITFNS CLOSEWHEREIS)))
(LOCALVARS . T)))
(* "WHEREIS from a hashfile")
(FILESLOAD HASH)
(* "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
(HASHFILE-WHEREIS
[LAMBDA (NAME TYPE FILES FN) (* bvm: "28-Apr-86 12:24")
(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)
(PROGN [COND
((AND WHEREIS.HASH (NLISTP WHEREIS.HASH))
(* 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.)
(COND
((LISTP (SETQ HNAME (CAR WHISHSFILE)))
(* file already has an associated
hashfile datatype)
(SETQ HSFILE (CDR HNAME)))
[(SETQ HSFILE (FINDFILE HNAME T))
(COND
([find X in WHEREIS.HASH
suchthat (AND (LISTP X)
(EQ HSFILE (HASHFILEPROP (CDR X)
(QUOTE NAME]
(* Looks like a duplicate entry)
(RPLACA WHISHSFILE (SETQ HSFILE NIL))
(SETQ DELP T))
(T (SETQ HSFILE (OPENHASHFILE HSFILE))
(* if the data file is ever closed,
break the link to the hash file
structure.)
(WHENCLOSE (HASHFILEPROP HSFILE (QUOTE STREAM))
(QUOTE BEFORE)
[FUNCTION (LAMBDA (STRM)
(for TAIL on WHEREIS.HASH
when [AND (LISTP (CAR TAIL))
(EQ STRM (HASHFILEPROP (CDAR TAIL)
(QUOTE STREAM]
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]
(T (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)))
[COND
(HSFILE (for FILE inside (GETHASHFILE NAME HSFILE)
when (NOT (FMEMB FILE VAL))
do (AND FN (APPLY* FN NAME FILE))
(push VAL FILE] finally (COND
(DELP (SETQ WHEREIS.HASH
(DREMOVE NIL WHEREIS.HASH]
(RETURN (AND (NULL FN)
(DREVERSE VAL])
(CLOSEWHEREIS
[LAMBDA (FLG) (* bvm: "28-Apr-86 12:33")
(* * Close the whereis file over logout, since there's no point in paying to
keep it open)
(AND WHEREIS.HASH (SELECTQ FLG
((NIL BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS)
(for HF in (for WH in WHEREIS.HASH when (LISTP WH)
collect (* Gather the hashfile handles)
(CDR WH)) do (NLSETQ (CLOSEHASHFILE HF))))
NIL])
(WHEREISNOTICE
[LAMBDA (FILEGROUP NEWFLG DATABASEFILE) (* bvm: "30-Aug-86 18:05")
(* 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 ([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]
(SCRATCHVAL (LIST NIL))
HF SCRATCH OLDWH)
(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 (ERSETQ (printout T (WHEREISNOTICE1 X HF)
-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 HF TRYHARD) (* bvm: "30-Aug-86 15:54")
(RESETLST (PROG (NAME MAP DATE VAL ENV STREAM)
[RESETSAVE NIL (LIST (QUOTE CLOSEF)
(SETQ STREAM (OPENSTREAM FILE (QUOTE INPUT)
(QUOTE OLD)
NIL
(QUOTE (DON'T.CHANGE.READ.DATE
DON'T.CHANGE.DATE]
(SETQ FILE (FULLNAME STREAM))
(SETFILEPTR STREAM 0)
(MULTPLE-VALUE-SETQ (ENV MAP)
(GET-ENVIRONMENT-AND-FILEMAP STREAM T))
(OR MAP (RETURN (LIST FILE "--can't find filemap")))
(if (AND (NOT TRYHARD)
(EQUAL (SETQ DATE (FILEDATE STREAM))
(GETHASHFILE FILE HF))
DATE)
then (* ; " already analyzed")
(RETURN (LIST FILE DATE)))
(SETQ NAME (NAMEFIELD FILE T))
(for X in (CDR MAP)
do (for Y in (CDDR X) unless (OR [NULL (SETQ VAL (LOOKUPHASHFILE
(CAR Y)
NAME HF (QUOTE (INSERT
RETRIEVE]
(EQ NAME VAL)
(AND (LISTP VAL)
(FMEMB NAME VAL)))
do (* ;; "the first LOOKUPHASHFILE stores NAME as value if there was no previous value, else returns previous value. If that value was non-null and did not contain NAME, now have to store union of NAME and what was there.")
(PUTHASHFILE (CAR Y)
(NCONC1 (OR (LISTP VAL)
(LIST VAL))
NAME)
HF)))
(PUTHASHFILE FILE DATE HF)
(RETURN FILE])
)
(ADDTOVAR WHEREIS.HASH )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS WHEREIS.HASH)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD (QUOTE HASHFILE-WHEREIS)
(QUOTE WHEREIS))
(ADDTOVAR AROUNDEXITFNS CLOSEWHEREIS)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTPROPS WHEREIS COPYRIGHT ("Xerox Corporation" 1983 1984 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1167 3885 (\REMOVEOLDVERSIONS 1177 . 3883)) (3886 21314 (HASHFILE-WHEREIS 3896 . 9093)
(CLOSEWHEREIS 9095 . 9782) (WHEREISNOTICE 9784 . 18690) (WHEREISNOTICE1 18692 . 21312)))))
STOP