WHERE-IS error handling improvement (#2235)
For loadup --aux reporting of errors during building whereis.hash: Just ignore pathnames that are just a directory. For other errors, report the condition that caused the error, instead of just generic Warning message
This commit is contained in:
Matt Heffron
GitHub
parent
37aef55990
commit
305c419b1d
171
library/WHERE-IS
171
library/WHERE-IS
@ -1,12 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "XEROX-COMMON-LISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(IL:FILECREATED "30-Apr-2023 13:54:00" IL:|{DSK}<home>larry>il>medley>library>WHERE-IS.;2| 17396
|
||||
(IL:FILECREATED "30-Jul-2025 16:15:16" IL:|{DSK}<home>matt>Interlisp>medley>library>WHERE-IS.;5| 17827
|
||||
|
||||
:EDIT-BY "lmm"
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (IL:FUNCTIONS ADD-WHERE-IS-DATABASE)
|
||||
:CHANGES-TO (IL:FUNCTIONS WHERE-IS-READ-COMS WHERE-IS-NOTICE)
|
||||
|
||||
:PREVIOUS-DATE "11-Mar-2022 22:40:32" IL:|{DSK}<home>larry>il>medley>library>WHERE-IS.;1|)
|
||||
:PREVIOUS-DATE "30-Apr-2023 13:54:00" IL:|{DSK}<home>matt>Interlisp>medley>library>WHERE-IS.;1|
|
||||
)
|
||||
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:WHERE-ISCOMS)
|
||||
@ -204,60 +205,62 @@
|
||||
(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
|
||||
(TEMP-FILE NIL)) (IL:* IL:\; "Edited 29-Jul-2025 23:55 by mth")
|
||||
(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))
|
||||
(WHEN (PATHNAME-NAME PATHNAME) (IL:* IL:\; "Skip directory entries")
|
||||
(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")
|
||||
(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)
|
||||
(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.")
|
||||
(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)))))
|
||||
(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)
|
||||
|
||||
@ -318,7 +321,7 @@
|
||||
NIL
|
||||
(PATHNAME-TYPE PATHNAME)))))
|
||||
|
||||
(DEFUN WHERE-IS-READ-COMS (PATHNAME)
|
||||
(DEFUN WHERE-IS-READ-COMS (PATHNAME) (IL:* IL:\; "Edited 30-Jul-2025 16:13 by mth")
|
||||
|
||||
(IL:* IL:|;;;| "returns as first value a list of the filevars on PATHNAME, as second value a list of the values for these filevars.")
|
||||
|
||||
@ -330,23 +333,28 @@
|
||||
(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))))
|
||||
(MULTIPLE-VALUE-BIND
|
||||
(LV-RESULT ERROR-CONDITION)
|
||||
(IGNORE-ERRORS (IL:LOADVARS QUEUE PATHNAME NIL))
|
||||
(COND
|
||||
((CONSP LV-RESULT)
|
||||
(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))
|
||||
(ERROR-CONDITION (WARN
|
||||
"Error attempting to LOADVARS ~S from ~A.~%Condition: ~A"
|
||||
QUEUE (NAMESTRING PATHNAME)
|
||||
ERROR-CONDITION)
|
||||
'NIL)
|
||||
(T NIL)))))
|
||||
((NULL QUEUE)
|
||||
(SETQ ALL-FILE-VARS (NREVERSE ALL-FILE-VARS))
|
||||
(VALUES ALL-FILE-VARS (MAPCAR #'SYMBOL-VALUE ALL-FILE-VARS)))
|
||||
@ -379,14 +387,15 @@
|
||||
(IL:PUTPROPS IL:WHERE-IS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL"))
|
||||
|
||||
(IL:PUTPROPS IL:WHERE-IS IL:FILETYPE :COMPILE-FILE)
|
||||
(IL:PUTPROPS IL:WHERE-IS IL:COPYRIGHT (IL:NONE))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (1737 2069 (HASH-FILE-WHERE-IS 1737 . 2069)) (2071 2464 (HASH-FILE-TYPES-OF 2071 .
|
||||
2464)) (2466 4631 (GET-WHERE-IS-ENTRIES 2466 . 4631)) (4633 5148 (WHERE-IS-READ-FN 4633 . 5148)) (5150
|
||||
5306 (ADD-WHERE-IS-DATABASES 5150 . 5306)) (5308 5695 (ADD-WHERE-IS-DATABASE 5308 . 5695)) (5697 6176
|
||||
(DEL-WHERE-IS-DATABASE 5697 . 6176)) (6178 7330 (SAME-WHERE-IS-DATABASE 6178 . 7330)) (7332 8539 (
|
||||
CLOSE-WHERE-IS-FILES 7332 . 8539)) (8797 12214 (WHERE-IS-NOTICE 8797 . 12214)) (12216 12960 (
|
||||
WHERE-IS-NOTICE-INTERNAL 12216 . 12960)) (12962 13698 (WHERE-IS-FILES 12962 . 13698)) (13700 14065 (
|
||||
WHERE-IS-DEFAULT-DEFINE-TYPES 13700 . 14065)) (14067 14486 (WHERE-IS-NAMESTRING 14067 . 14486)) (14488
|
||||
16500 (WHERE-IS-READ-COMS 14488 . 16500)) (16502 16773 (WHERE-IS-SET-WRITE-DATE 16502 . 16773)) (
|
||||
16775 17025 (WHERE-IS-GET-WRITE-DATE 16775 . 17025)))))
|
||||
(IL:FILEMAP (NIL (1763 2095 (HASH-FILE-WHERE-IS 1763 . 2095)) (2097 2490 (HASH-FILE-TYPES-OF 2097 .
|
||||
2490)) (2492 4657 (GET-WHERE-IS-ENTRIES 2492 . 4657)) (4659 5174 (WHERE-IS-READ-FN 4659 . 5174)) (5176
|
||||
5332 (ADD-WHERE-IS-DATABASES 5176 . 5332)) (5334 5721 (ADD-WHERE-IS-DATABASE 5334 . 5721)) (5723 6202
|
||||
(DEL-WHERE-IS-DATABASE 5723 . 6202)) (6204 7356 (SAME-WHERE-IS-DATABASE 6204 . 7356)) (7358 8565 (
|
||||
CLOSE-WHERE-IS-FILES 7358 . 8565)) (8823 12278 (WHERE-IS-NOTICE 8823 . 12278)) (12280 13024 (
|
||||
WHERE-IS-NOTICE-INTERNAL 12280 . 13024)) (13026 13762 (WHERE-IS-FILES 13026 . 13762)) (13764 14129 (
|
||||
WHERE-IS-DEFAULT-DEFINE-TYPES 13764 . 14129)) (14131 14550 (WHERE-IS-NAMESTRING 14131 . 14550)) (14552
|
||||
16882 (WHERE-IS-READ-COMS 14552 . 16882)) (16884 17155 (WHERE-IS-SET-WRITE-DATE 16884 . 17155)) (
|
||||
17157 17407 (WHERE-IS-GET-WRITE-DATE 17157 . 17407)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user