(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
(il:filecreated " 2-Nov-87 15:12:49" il:|{POGO:AISNORTH:XEROX}<CUTTING>LISP>NEW-WHERE-IS.;4| 18589
il:|changes| il:|to:| (il:functions get-where-is-entries del-where-is-database)
il:|previous| il:|date:| "26-Oct-87 12:42:24"
il:|{POGO:AISNORTH:XEROX}<CUTTING>LISP>NEW-WHERE-IS.;3|)
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:new-where-iscoms)
(il:rpaqq il:new-where-iscoms ((il:prop (il:makefile-environment il:filetype)
il:new-where-is)
(il:p (provide "WHERE-IS")
(require "HASH-FILE" "HASH-FILE.DFASL")
(require "CASH-FILE" "CASH-FILE.DFASL")
(case il:makesysname (:lyric (il:filesload (il:sysload)
il:filepkg-patch))))
(il:coms
(il:* il:|;;| "run time code")
(il:functions hash-file-where-is hash-file-types-of
get-where-is-entries add-where-is-databases
add-where-is-database del-where-is-database
same-where-is-database close-where-is-files)
(il:addvars (il:aroundexitfns close-where-is-files))
(il:variables *where-is-cash-files* *where-is-cash-size*))
(il:coms
(il:* il:|;;| "notice time code")
(il:functions where-is-notice where-is-notice-internal
where-is-files where-is-default-define-types
where-is-namestring where-is-read-coms
where-is-set-write-date where-is-get-write-date)
(il:variables *where-is-hash-file-size*
*where-is-ignore-define-types*)
(il:prop il:argnames where-is-notice))))
(il:putprops il:new-where-is il:makefile-environment (:readtable "XCL" :package "XCL"))
(il:putprops il:new-where-is il:filetype :compile-file)
(provide "WHERE-IS")
(require "HASH-FILE" "HASH-FILE.DFASL")
(require "CASH-FILE" "CASH-FILE.DFASL")
(case il:makesysname (:lyric (il:filesload (il:sysload)
il:filepkg-patch)))
(il:* il:|;;| "run time code")
(defun hash-file-where-is (name type)
(il:* il:|;;| "return a list of file names containing NAME of TYPE ")
(remove-duplicates (mapcan #'(lambda (entry)
(cdr (assoc type entry))) (get-where-is-entries name))
:test
'string=))
(defun hash-file-types-of (name &optional (possible-types (where-is-default-define-types)))
(let ((entries (get-where-is-entries name))
(types nil))
(dolist (type possible-types)
(dolist (entry entries)
(when (assoc type entry)
(push type types)
(return))))
(remove-duplicates types)))
(defun get-where-is-entries (name)
(il:* il:|;;|
"return a list of all entries for name in *WHERE-IS-CASH-FILES*")
(maplist #'(lambda (tail)
(let ((database (car tail)))
(proceed-case (cash-file:get-cash-file name (if (cash-file:cash-file-p
database)
database
(setf (car tail)
(
cash-file:open-cash-file
database
*where-is-cash-size*))
))
(nil nil :report "Delete from the databases known to WHERE-IS?"
(del-where-is-database database)
nil)))) *where-is-cash-files*))
(defun add-where-is-databases (&rest pathnames)
"add each PATHNAME to the databases known to WHERE-IS"
(mapcar #'add-where-is-database pathnames))
(defun add-where-is-database (pathname) "add PATHNAME to the databases known to WHERE-IS"
(let ((new-pathname (pathname pathname)))
(il:* il:|;;| "first delete & close the old one (if any)")
(del-where-is-database new-pathname)
(il:* il:|;;| "now add the new one")
(push new-pathname *where-is-cash-files*)
new-pathname))
(defun del-where-is-database (database) (let ((found (find-if #'(lambda (element)
(same-where-is-database
database element))
*where-is-cash-files*)))
(when found (setq *where-is-cash-files*
(delete found *where-is-cash-files*
:test 'eq))
(if (cash-file:cash-file-p found)
(hash-file:close-hash-file (
cash-file:cash-file-hash-file
found))
found))))
(defun same-where-is-database (x y) (flet ((coerce-to-pathame (cash-file-or-file-name)
(pathname (if (cash-file:cash-file-p
cash-file-or-file-name)
(hash-file::hash-file-stream
(cash-file:cash-file-hash-file
cash-file-or-file-name))
cash-file-or-file-name))))
(let ((pathname-x (coerce-to-pathame x))
(pathname-y (coerce-to-pathame y)))
(il:* il:|;;| "do a case & version insensitive comparison")
(and (equalp (pathname-host pathname-x)
(pathname-host pathname-y))
(equalp (pathname-device pathname-x)
(pathname-device pathname-y))
(equalp (pathname-directory pathname-x)
(pathname-directory pathname-y))
(equalp (pathname-name pathname-x)
(pathname-name pathname-y))
(equalp (pathname-type pathname-x)
(pathname-type pathname-y))))))
(defun close-where-is-files (event) (case event
((nil il:beforelogout il:beforesysout il:beforemakesys)
(il:nlsetq (mapc #'(lambda (cash-file:cash-file)
(if (cash-file:cash-file-p
cash-file:cash-file)
(hash-file:close-hash-file
(
cash-file:cash-file-hash-file
cash-file:cash-file))))
*where-is-cash-files*)))))
(il:addtovar il:aroundexitfns close-where-is-files)
(defvar *where-is-cash-files* nil "list of pathnames or CASH-FILEs")
(defvar *where-is-cash-size* 100 "size of the CACHE-FILE cache to use")
(il:* il:|;;| "notice time code")
(defun where-is-notice (database-file &key (files "*.;")
(new nil)
(define-types (where-is-default-define-types))
(hash-file-size *where-is-hash-file-size*)
(quiet nil)
(temp-file nil))
(let* ((file (if temp-file (if new temp-file (il:copyfile database-file temp-file))
database-file))
(hash-file:hash-file (if new (hash-file:make-hash-file file hash-file-size)
(hash-file:open-hash-file file :direction :io)))
(hash-file::*delete-old-version-on-rehash* t))
(unwind-protect
(dolist (pathname (where-is-files files))
(unless quiet (format t ";;; ~A ." (namestring pathname)))
(let ((namestring (where-is-namestring pathname)))
(if (and (not new)
(let ((old-write-date (where-is-get-write-date namestring
hash-file:hash-file)))
(and old-write-date (= (file-write-date pathname)
old-write-date))))
(unless quiet (format t " up to date.~%"))
(multiple-value-bind
(file-vars values)
(where-is-read-coms pathname)
(when file-vars
(il:* il:|;;| "bind the filevars s.t. IL:INFILECOMS? will find them")
(progv file-vars values (unless quiet (princ "."))
(dolist (type define-types)
(let ((names (il:infilecoms? nil type (first file-vars
))))
(when (consp names)
(il:* il:|;;| "IL:INFILECOMS? sometimes returns T.")
(dolist (name names)
(where-is-notice-internal name type
namestring
hash-file:hash-file))))))
(where-is-set-write-date namestring pathname hash-file:hash-file)
(unless quiet (princ ". done.")
(terpri)))))))
(hash-file:close-hash-file hash-file:hash-file))
(let ((pathname (pathname (hash-file::hash-file-stream hash-file:hash-file))))
(cond
(temp-file (unless quiet (format t ";;; Renaming ~A ... " (namestring pathname)))
(multiple-value-bind (merged true-name real-true-name)
(rename-file pathname database-file)
(unless quiet (format t "~A~%" (namestring real-true-name)))
real-true-name))
(t pathname)))))
(defun where-is-notice-internal (name type file-name hash-file:hash-file)
(il:* il:|;;|
"note that NAME is defined as TYPE on FILE-NAME in HASH-FILE ")
(il:* il:|;;| "we keep an ALIST for each name, indexed by type")
(let* ((alist (hash-file:get-hash-file name hash-file:hash-file))
(old-entry (assoc type alist :test 'equal))
(old-files (cdr old-entry)))
(unless (member file-name old-files)
(il:* il:|;;| "this optimization helps a lot when re-noticing a file ")
(setf (hash-file:get-hash-file name hash-file:hash-file)
(cons (cons type (cons file-name old-files))
(delete old-entry alist :test 'eq :count 1))))))
(defun where-is-files (files)
(il:* il:|;;| "expand the FILES argument to WHERE-IS-NOTICE")
(il:* il:|;;| "allow: non-LIST, file names & file patterns")
(mapcan #'(lambda (pattern)
(let ((pathname (probe-file pattern)))
(if pathname (list pathname)
(case il:makesysname (:lyric
(il:* il:|;;| "CL:DIRECTORY is broken in Lyric")
(il:directory pattern))
(otherwise (directory pattern)))))) (if (listp files)
files
(list files))))
(defun where-is-default-define-types nil (mapcan #'(lambda (type)
(il:* il:|;;|
"ignore aliases and types on *WHERE-IS-IGNORE-DEFINE-TYPES*")
(unless (or (consp type)
(member type
*where-is-ignore-define-types*
))
(list type))) il:filepkgtypes))
(defun where-is-namestring (pathname)
(il:* il:|;;|
"return a namestring for PATHNAME containing only the NAME & TYPE fields ")
(namestring (make-pathname :host nil :name (pathname-name pathname)
:type
(if (equal (pathname-type pathname)
"")
nil
(pathname-type pathname)))))
(defun where-is-read-coms (pathname)
(il:* il:|;;;| "returns as first value a list of the filevars on PATHNAME, as second value a list of the values for these filevars.")
(il:resetlst
(il:* il:|;;| "make sure all IL:LOADVARS get undone")
(il:resetsave (il:resetundo))
(do ((il:load-verbose-stream 'nil)
(all-file-vars)
(queue (list (il:filecoms (string-upcase (pathname-name pathname))))
(cond
((consp (il:nlsetq (il:loadvars queue pathname nil)))
(mapcan #'(lambda (file-var)
(if (boundp file-var)
(let ((file-vars (il:infilecoms? nil 'il:filevars
file-var)))
(push file-var all-file-vars)
(when (consp file-vars)
file-vars))
(prog1 nil (warn "Couldn't find ~S on ~A." file-var
(namestring pathname))))) queue))
(t (warn "Error attempting to LOADVARS ~S from ~A." queue (namestring pathname
))
'nil))))
((null queue)
(setq all-file-vars (nreverse all-file-vars))
(values all-file-vars (mapcar #'symbol-value all-file-vars)))
(declare (special il:load-verbose-stream))
(dolist (file-var queue)
(if (member file-var all-file-vars :test 'eq)
(il:* il:|;;| "don't want to load any twice")
(setf queue (delete file-var queue :test 'eq)))))))
(defun where-is-set-write-date (namestring pathname hash-file:hash-file)
(il:* il:|;;| "store the write date as a bogus entry on the file")
(where-is-notice-internal namestring 'si::write-date (file-write-date pathname)
hash-file:hash-file))
(defun where-is-get-write-date (namestring hash-file:hash-file)
(il:* il:|;;|
"retrieve write date stored for NAMESTRING in HASH-FILE:HASH-FILE")
(cadr (assoc 'si::write-date (hash-file:get-hash-file namestring hash-file:hash-file))))
(defvar *where-is-hash-file-size* 10000 "initial size to create WHERE-IS hash files")
(defvar *where-is-ignore-define-types* '(il:files il:expressions il:filevars il:alists) )
(il:putprops where-is-notice il:argnames (il:database-file &key il:files il:new il:define-types
il:hash-file-size il:quiet il:temp-file))
(il:putprops il:new-where-is il:copyright ("Xerox Corporation" 1987))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop