From 305c419b1d442cf762bf5f14d2acc643441d600d Mon Sep 17 00:00:00 2001 From: Matt Heffron Date: Mon, 11 Aug 2025 11:56:00 -0700 Subject: [PATCH] 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 --- library/WHERE-IS | 171 ++++++++++++++++++++++------------------- library/WHERE-IS.DFASL | Bin 9180 -> 9406 bytes 2 files changed, 90 insertions(+), 81 deletions(-) diff --git a/library/WHERE-IS b/library/WHERE-IS index 30f6fd09..2324fef4 100644 --- a/library/WHERE-IS +++ b/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}larry>il>medley>library>WHERE-IS.;2| 17396 +(IL:FILECREATED "30-Jul-2025 16:15:16" IL:|{DSK}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}larry>il>medley>library>WHERE-IS.;1|) + :PREVIOUS-DATE "30-Apr-2023 13:54:00" IL:|{DSK}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 diff --git a/library/WHERE-IS.DFASL b/library/WHERE-IS.DFASL index 8abe17d16c3849871eb2b573ec0c0cd07c645760..74605b1d37eff8cee6b69dab0a2016d6d47ba3ad 100644 GIT binary patch delta 1263 zcmZWpZ)h837{51{rEMx_I#`;WS$l5nCTt05Yg%mQG^A;IZJIYES;IsdN)x?EdpFty zDY9nNiGDbB*;%<;Kg@q$1kq&0X}h(DOdJkjA4ISs_+j`({NP7%;C!E_u0M#L2)YV&S;hSnWFS!X|^cM%onH2#e&oq z3XD}|1HGZ%u+-B(*b^S?>35GrGKv4E<%$KhxKNm0Ji#g?RT;Jcr7M4epvT*Zvh5 zFpl~{RcE{}6c(0Q>i6b5x+@z?r_wUeZyDXka54()nl%o?C+3RY^87FjrqVP%3Cgks z_u4sYtc>XIDOUIBh@6N8a%njm3k*lHu}LfOj3tM55{~0=&x?b2(`m&yCwP2q>PyLZ$Eq4cwv^2zSyxF{e!rb`|bs=K$P{ofb7r96J0KX;d(a}ZbI^^LWM5kK=ExVBpt-P>oG+(8P5y$1Yawi zSJ?KyRUOZJY$fkymycbdO+6n|Z-cu;JtXf(m#aq=d>ZxRZ1Np8^^b`gv;$2H+EIT@ zsrzsp)c@eHF?Gk#_a608@t}QyitIU5#4?MDXdY#cr5*>HMEy-FTousJOY!q zmGjE=#y`r-&k8o`9?s#$t=1hamTGuAJE|VwWQcFu(UI{U2S<>9VHyPfI_t5X0WYN9 zVa?Gx8A+UuWdaE~lLc*yY0g|EodohFR^9`6*_wvo6?7c|IKLN60F((dE_oW|y8xRJ z)&TMdFEYsewX1S>_uw~s&^B&&Rz_p2xtpPLCnM<$)ct`O+W>#E7Gb!(Gt@A!28wRY z;A%;NXOw(q>I23b(i0O)-BC>~l*%Pd9b~-APXGdZW_GhgEu%zQ)kk0d^8Kkv!XkbG#NAAKk^h`y?_5-J7Qq> delta 1057 zcmZWo-%ry}6z**Yj15PJ2|p^5LeLSV%NT;fkWgWa!C04djA$^EuwjRDT_#IdjDVBG z2WwaPFR5CI-8ws=RHjYmuIlIl?&bGC8cU`T`?ojdjgG3nn2^)@Q+@yu(^!Qs9((f@xICb+MMY#6){H>WQ7(djd)55X@GHo zAoj^}O(u144^Mgoet-)){Z|Ch$%z5KlOH94mY^z;12`yJlPU9&8#7cTMF5Qy#1WPpw9(di2Eei6~1wKNL*M`0c7KO!cJ;TD35Hii2J9tx&l zCa1Kh)r~FZP{QSuntnMI3&$<9@HWQ7?7Yazad^t`Vcft~zN|lL1mN11(v$|EMm0Ax hz^+!1Obuy9{rJWL@GkhoQX~cmf>bljUDVv+;cvWeCZPZT