;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 125.11 ;;; Reason: ;;; QFILE bug: (fs:host-chaos-interrupt-function) failed to match ;;; asynchronous marks with their file handles. One noticable ;;; example occured when the server got a Disk Full error and the ;;; user was simply left hanging. Now you are given the debugger ;;; with useful proceed options including: running Dired, calling ;;; (zwei:clean-directory), expunging the directory. ;;; Written 20-Jul-88 23:43:36 by pld (Peter L. DeWolf) at site Gigamos Cambridge ;;; while running on Azathoth from band 2 ;;; with System 125.10, ZWEI 125.2, ZMail 73.0, Local-File 75.0, File-Server 24.0, Unix-Interface 13.0, Tape 24.0, Lambda-Diag 17.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 8, the old ones. ; From modified file DJ: L.NETWORK.CHAOS; QFILE.LISP#383 at 20-Jul-88 23:43:57 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFUN HOST-CHAOS-INTERRUPT-FUNCTION (REASON CONN &REST IGNORE) (DECLARE (SPECIAL HOST-UNIT)) (CASE REASON (:INPUT (DO ((PKT (CHAOS:GET-NEXT-PKT CONN T) (CHAOS:GET-NEXT-PKT CONN T)) (STRING) (TEM)) ((NULL PKT)) (SETQ STRING (CHAOS:PKT-STRING PKT)) (SELECT (CHAOS:PKT-OPCODE PKT) (%QFILE-ASYNCHRONOUS-MARK-OPCODE (SETQ STRING (NSUBSTRING STRING (1+ (STRING-SEARCH-CHAR #/SPACE (CHAOS:PKT-STRING PKT))))) (DO ((DATA-CONNS (QFILE-HOST-UNIT-DATA-CONNECTIONS HOST-UNIT) (CDR DATA-CONNS)) (HANDLE-LEN (OR (STRING-SEARCH-CHAR #/SPACE STRING) (STRING-LENGTH STRING))) (STREAM)) ((NULL DATA-CONNS) (CHAOS:RETURN-PKT PKT)) (WHEN (STRING-EQUAL STRING (DATA-HANDLE (CAR DATA-CONNS) :OUTPUT) :END1 HANDLE-LEN) (SETQ STREAM (DATA-STREAM (CAR DATA-CONNS) :OUTPUT)) (SEND STREAM :ASYNC-MARK PKT) (RETURN NIL)))) (%QFILE-COMMAND-OPCODE (SETQ STRING (SUBSTRING STRING 0 (STRING-SEARCH-CHAR #/SPACE STRING))) (SETQ TEM (SYS:ASSOC-EQUAL STRING *QFILE-PENDING-TRANSACTIONS*)) (COND ((NULL TEM) (PROCESS-RUN-FUNCTION "QFILE Protocol Error" #'(LAMBDA (PKT) (UNWIND-PROTECT (FERROR NIL "QFILE protocol violated, unknown transaction id in ~S" (CHAOS:PKT-STRING PKT)) (CHAOS:RETURN-PKT PKT))) PKT)) ((QFILE-TRANSACTION-ID-SIMPLE-P TEM) ;;If simple transaction, make sure no error (LET ((STRING (NSUBSTRING (CHAOS:PKT-STRING PKT) (1+ (STRING-SEARCH-CHAR #/SPACE (CHAOS:PKT-STRING PKT))))) (FROM)) (SETQ FROM (1+ (STRING-SEARCH-SET '(#/SPACE #/NEWLINE) STRING))) ;; If simple transaction fails, barf in another process (OR (NOT (STRING-EQUAL "ERROR" STRING :START2 FROM :END2 (STRING-SEARCH-SET '(#/SPACE #/NEWLINE) STRING FROM))) (PROCESS-RUN-FUNCTION "QFILE Protocol Error" 'QFILE-PROCESS-ERROR-NEW (COPY-SEQ STRING)))) (SETQ *QFILE-PENDING-TRANSACTIONS* (DELQ TEM *QFILE-PENDING-TRANSACTIONS*)) (chaos:return-pkt pkt)) (T (SETF (QFILE-TRANSACTION-ID-PKT TEM) PKT)))) (%QFILE-NOTIFICATION-OPCODE (UNWIND-PROTECT (TV:NOTIFY NIL "File server ~A: ~A" (QFILE-HOST-UNIT-HOST HOST-UNIT) STRING) (CHAOS:RETURN-PKT PKT))) (OTHERWISE (CHAOS:RETURN-PKT PKT))))))) ;;; Allocate a new data connection )) ; From modified file DJ: L.NETWORK.CHAOS; QFILE.LISP#383 at 20-Jul-88 23:57:19 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFUN QFILE-PROCESS-ERROR-NEW (STRING &OPTIONAL PATHNAME-OR-STREAM PROCEEDABLE NOERROR &REST MAKE-CONDITION-ARGS &AUX S-P ERROR-CODE ERROR-SEVERITY ERROR-STRING WHO-FOR (DEFAULT-CONS-AREA SYS:BACKGROUND-CONS-AREA)) (TYPECASE PATHNAME-OR-STREAM (PATHNAME (SETQ WHO-FOR PATHNAME-OR-STREAM)) (SI:FILE-STREAM-MIXIN (SETQ WHO-FOR (SEND PATHNAME-OR-STREAM :PATHNAME))) (T (SETQ WHO-FOR PATHNAME-OR-STREAM))) (SETQ S-P (QFILE-CHECK-COMMAND "ERROR" STRING)) (SETQ ERROR-CODE (SUBSTRING STRING S-P (SETQ S-P (STRING-SEARCH-CHAR #/SPACE STRING S-P)))) (SETQ S-P (1+ S-P)) (SETQ ERROR-SEVERITY (SUBSTRING STRING S-P (SETQ S-P (STRING-SEARCH-CHAR #/SPACE STRING S-P)))) (SETQ ERROR-STRING (NSUBSTRING STRING (1+ S-P) (STRING-LENGTH STRING))) (APPLY 'FILE-PROCESS-ERROR (GET (INTERN ERROR-CODE (SYMBOL-PACKAGE 'FOO)) 'FS:FILE-ERROR) ERROR-STRING PATHNAME-OR-STREAM PROCEEDABLE NOERROR MAKE-CONDITION-ARGS)) )) ; From modified file DJ: L.NETWORK.CHAOS; QFILE.LISP#383 at 20-Jul-88 23:59:20 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFMETHOD (BASIC-QFILE-ACCESS :OPEN) (FILE PATHNAME &REST OPTIONS) (APPLY 'OPEN-CHAOS SELF FILE PATHNAME OPTIONS)) )) ; From modified file DJ: L.NETWORK.CHAOS; QFILE.LISP#383 at 20-Jul-88 23:59:33 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFMETHOD (BASIC-QFILE-ACCESS :REMOTE-CONNECT) (&REST ARGS) (DECLARE (ARGLIST FILE ERROR ACCESS-MODE &OPTIONAL UNIT)) (APPLY 'CWD-CHAOS SELF ARGS)) )) ; From modified file DJ: L.IO.FILE; OPEN.LISP#208 at 21-Jul-88 00:18:47 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FILE; OPEN  " (DEFMETHOD (FILE-OPERATION-FAILURE :CASE :PROCEED-ASKING-USER :DIRED) (&REST IGNORE) "Runs DIRED, then returns to the debugger when you type Control-Z." (DIRED (SEND (SEND SELF :PATHNAME) :NEW-PATHNAME :NAME :WILD :TYPE :WILD :VERSION :WILD)) NIL) )) ; From modified file DJ: L.IO.FILE; OPEN.LISP#208 at 21-Jul-88 00:18:49 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FILE; OPEN  " (DEFMETHOD (FILE-OPERATION-FAILURE :CASE :PROCEED-ASKING-USER :CLEAN-DIRECTORY) (&REST IGNORE) "Calls (ZWEI:CLEAN-DIRECTORY), then returns to debugger." (ZWEI:CLEAN-DIRECTORY (SEND (SEND SELF :PATHNAME) :NEW-PATHNAME :NAME :WILD :TYPE :WILD :VERSION :WILD)) NIL) )) ; From modified file DJ: L.IO.FILE; OPEN.LISP#208 at 21-Jul-88 00:19:03 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FILE; OPEN  " (DEFMETHOD (NO-MORE-ROOM-ERROR :USER-PROCEED-TYPES) (REAL-PROCEED-TYPES) (APPEND (INTERSECTION '(:NO-ACTION :RETRY-FILE-OPERATION) REAL-PROCEED-TYPES) '(:DIRED :CLEAN-DIRECTORY :expunge-directory) (REM-IF #'(LAMBDA (ELT) (MEMQ ELT '(:NO-ACTION :RETRY-FILE-OPERATION :DIRED :CLEAN-DIRECTORY :expunge-directory))) REAL-PROCEED-TYPES))) ))