(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