;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 123.218 ;;; Reason: ;;; Fix the :delete-multiple-files method of the Local File System so that it ;;; returns a list of results, one per file, and doesn't give up partway through ;;; the list if it can't delete a file. ;;; Fix (dired-do-file-list) so that it properly deals with a result of this ;;; sort. (It purported to do so, but in fact treated a returned list as ;;; a successful result for all files.) Add optional argument that is a ;;; function to be called for each line where the operation failed. ;;; Fix (dired-process-files) to supply this argument when deleting ;;; multiple files. ;;; Net result: you can mark a bunch of files for deletion, and only the ;;; ones that REALLY got deleted will be marked "d" (or removed from the ;;; display if you asked to Expunge) ;;; Written 23-Mar-88 13:15:08 by pld at site Gigamos Cambridge ;;; while running on James Brown from band 2 ;;; with Experimental System 123.216, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental Tape 18.2, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.14, SDU ROM 102. ; From modified file DJ: L.FILE; FSACC.LISP#13 at 23-Mar-88 13:21:31 #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: FILE; FSACC  " (DEFMETHOD (LOCAL-FILE-ACCESS :DELETE-MULTIPLE-FILES) (ERROR-P PATHNAMES) (IDENTIFY-FILE-OPERATION :DELETE (LOOP FOR PATHNAME IN PATHNAMES WITH FILES-OF-DIRECTORY-TO-WRITE = NIL collect (HANDLING-ERRORS ERROR-P (OPEN-INPUT-FILE-OR-DIRECTORY (FILE PATHNAME) (LMFS-DELETE-FILE FILE NIL) (LOOP FOR ENTRY IN FILES-OF-DIRECTORY-TO-WRITE WHEN (EQUAL (FILE-DIRECTORY FILE) (FILE-DIRECTORY ENTRY)) RETURN NIL FINALLY (PUSH FILE FILES-OF-DIRECTORY-TO-WRITE)))) FINALLY (handling-errors error-p (DOLIST (FILE FILES-OF-DIRECTORY-TO-WRITE) (WRITE-DIRECTORY-OF-FILE FILE)))))) )) ; From modified file DJ: L.ZWEI; DIRED.LISP#328 at 23-Mar-88 13:15:09 #8R ZWEI#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI"))) (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; DIRED  " (DEFUN DIRED-PROCESS-FILES () "Perform all the operations requested on files in the DIRED buffer. Returns T if user typed E or Y or Q, NIL if user typed N." (DO ((LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)) (LINE-NEXT LINE)) (UNDELETEABLE (SEND (DIRED-BUFFER-DIRECTORY-PATHNAME *INTERVAL*) :UNDELETABLE-P)) DELETE-FILES UNDELETE-FILES FIND-FILES PRINT-FILES APPLY-FILES (LAST-LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*))) QUERY-RESULT) ((EQ LINE LAST-LINE) (SETQ DELETE-FILES (NREVERSE DELETE-FILES) UNDELETE-FILES (NREVERSE UNDELETE-FILES) FIND-FILES (NREVERSE FIND-FILES) PRINT-FILES (NREVERSE PRINT-FILES) APPLY-FILES (NREVERSE APPLY-FILES)) (CATCH 'RETURN-TO-DIRED (PROGN (COND ((OR DELETE-FILES UNDELETE-FILES FIND-FILES PRINT-FILES APPLY-FILES) (AND DELETE-FILES (DIRED-PRINT-FILE-LIST DELETE-FILES "deleted")) (AND UNDELETE-FILES (DIRED-PRINT-FILE-LIST UNDELETE-FILES "undeleted")) (AND FIND-FILES (DIRED-PRINT-FILE-LIST FIND-FILES "visited")) (AND PRINT-FILES (DIRED-PRINT-FILE-LIST PRINT-FILES "printed")) (AND APPLY-FILES (DIRED-PRINT-FILE-LIST APPLY-FILES "processed by function")) (COND ((SETQ QUERY-RESULT (DIRED-FILE-QUERY UNDELETEABLE (AND DELETE-FILES "Delete") (AND UNDELETE-FILES "Undelete") (AND FIND-FILES "Visit") (AND PRINT-FILES "Print") (AND APPLY-FILES "Apply function"))) (COND (APPLY-FILES ;This crock to fake out read-function-name. ;Mouse would not win particularily. (LET* ((*MINI-BUFFER-REPEATED-COMMAND* '()) *DIRED-FUNCTION-TO-APPLY*) (MULTIPLE-VALUE-BIND (FNSPEC STRING) (READ-FUNCTION-NAME "Function to apply:" 'COMPILE-FILE) (SETQ *DIRED-FUNCTION-TO-APPLY* (COND ((FDEFINEDP FNSPEC) FNSPEC) (T (CONDITION-CASE () (CLI:READ-FROM-STRING STRING) (SYS:END-OF-FILE (BARF))))))) (DIRED-DO-FILE-LIST APPLY-FILES 'DIRED-APPLY-FUNCTION NIL)))) (AND DELETE-FILES (DIRED-DO-FILE-LIST DELETE-FILES 'DIRED-DELETE-FILE "delete" :DELETE-MULTIPLE-FILES #'(LAMBDA (LINE) (SETF (GETF (LINE-PLIST LINE) ':DELETED) T)) #'(lambda (line) (setf (char line 0) #/SP)))) (AND UNDELETE-FILES (DIRED-DO-FILE-LIST UNDELETE-FILES 'DIRED-UNDELETE-FILE "undelete" :UNDELETE-MULTIPLE-FILES (LAMBDA (LINE) (SETF (GETF (LINE-PLIST LINE) ':DELETED) NIL)))) (AND FIND-FILES (DIRED-DO-FILE-LIST FIND-FILES 'DIRED-FIND-FILE "visit")) (AND PRINT-FILES (DIRED-DO-FILE-LIST PRINT-FILES 'DIRED-PRINT-FILE "print")) ;; Expunge if desired. (WHEN (EQ QUERY-RESULT :EXPUNGE) (LET ((BLOCKS-FREED 0)) ;; Expunge the directory we did DIRED on. (INCF BLOCKS-FREED (FS:EXPUNGE-DIRECTORY (DIRED-BUFFER-DIRECTORY-PATHNAME *INTERVAL*))) ;; Expunge any subdirectories whose contents are listed. (DO ((LINE (LINE-NEXT (LINE-NEXT (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)))) (LINE-NEXT LINE))) ((NULL (LINE-NEXT LINE))) (WHEN (AND (GETF (LINE-PLIST LINE) ':DIRECTORY) (GETF (LINE-PLIST LINE) 'CONTENTS-PRESENT)) (INCF BLOCKS-FREED (FS:EXPUNGE-DIRECTORY (SEND (DIRED-LINE-PATHNAME LINE) :PATHNAME-AS-DIRECTORY))))) (FORMAT *QUERY-IO* "~&~D blocks freed." BLOCKS-FREED))) ;; If the deleted files are now gone for good, ;; delete their lines from the buffer. ;; Also, flush any U's, A's, F's, or P's. (WITH-READ-ONLY-SUPPRESSED (*INTERVAL*) (DO ((LINE (LINE-NEXT (LINE-NEXT (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)))) (LINE-NEXT LINE))) ((NULL (LINE-NEXT LINE))) (COND ((= (LENGTH LINE) 0)) ((CHAR-EQUAL (CHAR LINE 0) #/D) (IF (OR (EQ QUERY-RESULT :EXPUNGE) (NOT UNDELETEABLE)) (DELETE-INTERVAL (BEG-OF-LINE LINE) (BEG-OF-LINE (LINE-NEXT LINE)) T) (MUNG-LINE LINE) (SETF (CHAR LINE 0) #/d))) ((CHAR (CHAR LINE 0) #/SP) (MUNG-LINE LINE) (SETF (CHAR LINE 0) #/SP))))))))) (RETURN-FROM DIRED-PROCESS-FILES T)))) (WHEN (DIRED-LINE-PATHNAME LINE) (CASE (CHAR LINE 0) (#/D (PUSH LINE DELETE-FILES)) (#/U (PUSH LINE UNDELETE-FILES)) (#/F (PUSH LINE FIND-FILES)) (#/P (PUSH LINE PRINT-FILES)) (#/A (PUSH LINE APPLY-FILES)))))) )) ; From modified file DJ: L.ZWEI; DIRED.LISP#328 at 23-Mar-88 13:19:38 #8R ZWEI#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI"))) (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; DIRED  " (DEFUN DIRED-DO-FILE-LIST (FILES FUNCTION NAME &OPTIONAL MULTIPLE-FILE-MESSAGE AUXILIARY-FUNCTION auxiliary-failure-function &AUX ERR PATHS) ;; Added AUXILIARY-FUNCTION which is called for each file in FILES when the multiple-file ;; path is used. This is so delete/undelete can pass in a function to update the plist ;; on each line. 1/2/85 KHS. ;; Added AUXILIARY-FAILURE-FUNCTION which is called for each file in FILES which failed when ;; the multiple-file path is used. Properly support a multiple-file-message that returns ;; a list of values, rather than assuming that all the values are successes. 3/23/88 PLD (COND ((AND MULTIPLE-FILE-MESSAGE (OPERATION-HANDLED-P (DIRED-LINE-PATHNAME (CAR FILES)) MULTIPLE-FILE-MESSAGE)) (SETQ PATHS (MAPCAR #'DIRED-LINE-PATHNAME FILES)) (SETQ ERR (SEND (CAR PATHS) MULTIPLE-FILE-MESSAGE NIL ;error-p PATHS)) ; (AND AUXILIARY-FUNCTION ; (NOT (ERRORP ERR)) ; (MAPC AUXILIARY-FUNCTION FILES)) ; (AND NAME (ERRORP ERR) ; (DIRED-REPORT-ERROR NAME "files" ERR)) ; (AND NAME (CONSP ERR) ; (MAPC (LAMBDA (PATHNAME ERROR) ; (AND (ERRORP ERROR) ; (DIRED-REPORT-ERROR NAME PATHNAME ERROR))) ; PATHS ERR))) (cond ((consp err) ;Individual error messages (mapc #'(lambda (pathname error line) (cond ((errorp error) (when name (dired-report-error name pathname error)) (when auxiliary-failure-function (funcall auxiliary-failure-function line))) (t (when auxiliary-function (funcall auxiliary-function line))))) paths err files)) ((errorp err) ;Complete failure (when name (dired-report-error name "files" err)) (when auxiliary-failure-function (mapc auxiliary-failure-function files))) (t ;Complete success (when auxiliary-function (mapc auxiliary-function files))))) (T (DOLIST (LINE FILES) (SETQ ERR (FUNCALL FUNCTION LINE)) (AND NAME (ERRORP ERR) (DIRED-REPORT-ERROR NAME (DIRED-LINE-PATHNAME LINE) ERR)))))) ))