(FILECREATED "28-Apr-86 14:00:59" {ERIS}<LISPCORE>LIBRARY>WHEREIS.;3 21400
changes to: (VARS WHEREISCOMS)
(FNS WHEREIS CLOSEWHEREIS)
previous date: "29-Nov-84 17:30:12" {ERIS}<LISPCORE>LIBRARY>WHEREIS.;1)
(* 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 WHEREIS CLOSEWHEREIS WHEREISNOTICE WHEREISNOTICE1)
(ADDVARS (WHEREIS.HASH))
(GLOBALVARS WHEREIS.HASH)
(DECLARE: DONTEVAL@LOAD DOCOPY (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
(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) (* 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])
)
(ADDTOVAR WHEREIS.HASH )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS WHEREIS.HASH)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(ADDTOVAR AROUNDEXITFNS CLOSEWHEREIS)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTPROPS WHEREIS COPYRIGHT ("Xerox Corporation" 1983 1984 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (994 3712 (\REMOVEOLDVERSIONS 1004 . 3710)) (3713 21089 (WHEREIS 3723 . 8911) (
CLOSEWHEREIS 8913 . 9600) (WHEREISNOTICE 9602 . 18873) (WHEREISNOTICE1 18875 . 21087)))))
STOP