;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 123.12 ;;; Reason: ;;; QFILE not universally good at returning Chaos packets it allocated. Ever seen a ;;; system with chaos:made-pkts = 7000? ;;; Written 3-Sep-87 12:23:50 by pld (Peter L. DeWolf) at site LMI Cambridge ;;; while running on Azathoth from band 2 ;;; with Experimental System 123.10, Experimental Local-File 73.0, Experimental FILE-Server 22.0, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.0, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, Experimental Site Data Editor 6.0, microcode 1754, SDU Boot Tape 3.12, SDU ROM 102. ; From modified file DJ: L.NETWORK.CHAOS; QFILE.LISP#377 at 3-Sep-87 12:24:35 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFUN OPEN-CHAOS (ACCESS FILE PATHNAME &REST OPTIONS &KEY (DIRECTION :INPUT) (CHARACTERS T) (ERROR T) (ELEMENT-TYPE 'STRING-CHAR ELEMENT-TYPE-P) (IF-EXISTS nil if-exists-p) (IF-DOES-NOT-EXIST nil if-does-not-exist-p) (BYTE-SIZE :DEFAULT) MOBY-MAPPED &ALLOW-OTHER-KEYS &AUX HOST-UNIT DATA-CONN PKT NOT-ABORTED PHONY-CHARACTERS SIGN-EXTEND-BYTES (DEFAULT-CONS-AREA SYS:BACKGROUND-CONS-AREA)) (SETQ PATHNAME (FS:PARSE-PATHNAME PATHNAME)) (IF IF-EXISTS-P (CHECK-TYPE IF-EXISTS (MEMBER :ERROR :NEW-VERSION :RENAME :RENAME-AND-DELETE :OVERWRITE :APPEND :TRUNCATE :SUPERSEDE NIL)) (SETQ IF-EXISTS (IF (MEMQ (PATHNAME-VERSION PATHNAME) ;; :UNSPECIFIC here is to prevent lossage ;; writing ITS files with no version numbers. '(:NEWEST :UNSPECIFIC)) :NEW-VERSION :ERROR))) (IF IF-DOES-NOT-EXIST-P (CHECK-TYPE IF-DOES-NOT-EXIST (MEMBER :ERROR :CREATE NIL)) (SETQ IF-DOES-NOT-EXIST (COND ((MEMQ DIRECTION '(:PROBE :PROBE-LINK :PROBE-DIRECTORY)) NIL) ((AND (EQ DIRECTION :OUTPUT) (NOT (MEMQ IF-EXISTS '(:OVERWRITE :TRUNCATE :APPEND)))) :CREATE) ;; Note: if DIRECTION is NIL, this defaults to :ERROR ;; for compatibility with the past. ;; A Common-Lisp program would use :PROBE ;; and get NIL as the default for this. (T :ERROR)))) (ECASE DIRECTION ((:INPUT :OUTPUT :PROBE-DIRECTORY :PROBE-LINK)) (:IO (FERROR "Bidirectional file streams are not yet supported.")) ((NIL :PROBE) (SETQ DIRECTION NIL))) ;; IF-EXISTS-P is T if we need to give the IF-EXISTS to the server. (SETQ IF-EXISTS-P (NOT (MEMQ IF-EXISTS (CASE (PATHNAME-VERSION PATHNAME) (:NEWEST '(:NEW-VERSION)) (:UNSPECIFIC '(:NEW-VERSION :SUPERSEDE)))))) (WHEN ELEMENT-TYPE-P (SETF (VALUES CHARACTERS BYTE-SIZE PHONY-CHARACTERS SIGN-EXTEND-BYTES) (DECODE-ELEMENT-TYPE ELEMENT-TYPE BYTE-SIZE))) (flet ((make-stream (string) (LET ((PROPERTIES (READ-FILE-PROPERTY-LIST-STRING STRING "OPEN" PATHNAME))) (AND (EQ CHARACTERS :DEFAULT) (SETQ CHARACTERS (GETF PROPERTIES :CHARACTERS))) (UNLESS (OR (EQ BYTE-SIZE :DEFAULT) (GETF PROPERTIES :BYTE-SIZE)) (SETF (GETF PROPERTIES :BYTE-SIZE) BYTE-SIZE)) (PROG1 (cond (moby-mapped (open-chaos-moby-mapped host-unit properties string)) ;defined in moby stuff. (t (MAKE-INSTANCE (CASE DIRECTION (:INPUT (IF CHARACTERS 'QFILE-INPUT-CHARACTER-STREAM (COND (SIGN-EXTEND-BYTES 'QFILE-INPUT-SIGNED-BINARY-STREAM) (PHONY-CHARACTERS 'QFILE-INPUT-PHONY-CHARACTER-STREAM) (T 'QFILE-INPUT-BINARY-STREAM)))) (:OUTPUT (IF CHARACTERS 'QFILE-OUTPUT-CHARACTER-STREAM (IF PHONY-CHARACTERS 'QFILE-OUTPUT-PHONY-CHARACTER-STREAM 'QFILE-OUTPUT-BINARY-STREAM))) (T 'QFILE-PROBE-STREAM)) :HOST-UNIT HOST-UNIT :DATA-CONNECTION DATA-CONN :PROPERTY-LIST PROPERTIES :PATHNAME PATHNAME))) (SETQ NOT-ABORTED T)))) (data-connection-handle () (CASE DIRECTION (:INPUT (DATA-INPUT-HANDLE DATA-CONN)) (:OUTPUT (DATA-OUTPUT-HANDLE DATA-CONN))))) (FILE-OPERATION-RETRY (CONDITION-CASE-IF (not ERROR) (ERROR-OBJECT) (PROGN (IF (or moby-mapped (MEMQ DIRECTION '(NIL :PROBE-DIRECTORY :PROBE-LINK))) ;; PROBE mode implies no need for data connection (SETQ HOST-UNIT (SEND ACCESS :GET-HOST-UNIT)) (MULTIPLE-VALUE (DATA-CONN HOST-UNIT) (SEND ACCESS :GET-DATA-CONNECTION DIRECTION)))) (REMOTE-NETWORK-ERROR ERROR-OBJECT) (:NO-ERROR (UNWIND-PROTECT (let ((success nil) (string nil)) (MULTIPLE-VALUE (PKT SUCCESS STRING) (lexpr-send access :open-command host-unit (data-connection-handle) file characters byte-size direction if-exists if-exists-p if-does-not-exist options)) (SETQ STRING (STRING-APPEND STRING)) (AND PKT (CHAOS:RETURN-PKT PKT)) (COND ((NOT SUCCESS) (SETQ NOT-ABORTED T) (OR (NULL DATA-CONN) (SETF (DATA-STREAM DATA-CONN DIRECTION) NIL)) (CONDITION-CASE-IF (NOT IF-DOES-NOT-EXIST) () (CONDITION-CASE-IF (NOT IF-EXISTS) () (QFILE-PROCESS-ERROR-NEW STRING PATHNAME NIL (NOT ERROR) :OPEN) (FILE-ALREADY-EXISTS NIL)) (FILE-NOT-FOUND NIL))) (T (make-stream string)))) ;; cleanup forms of the unwind-protect (UNLESS (OR NOT-ABORTED (NULL DATA-CONN) (NULL (SEND HOST-UNIT :CONTROL-CONNECTION))) ;; Here if aborted out of it and server may have file open. (CONDITION-CASE () (PROGN (when (EQ DIRECTION :OUTPUT) (let ((pkt (SEND HOST-UNIT :COMMAND NIL (DATA-OUTPUT-HANDLE DATA-CONN) NIL "Delete" "DELETE"))) (and pkt (chaos:return-pkt pkt)))) (multiple-value-bind (pkt success ignore) (SEND HOST-UNIT :COMMAND NIL (data-connection-handle) NIL "Close" "CLOSE") (and pkt (chaos:return-pkt pkt)) (WHEN success (CASE DIRECTION (:INPUT (READ-UNTIL-SYNCHRONOUS-MARK (DATA-CONNECTION DATA-CONN))) (:OUTPUT (CHAOS:SEND-PKT (DATA-CONNECTION DATA-CONN) (CHAOS:GET-PKT) %QFILE-SYNCHRONOUS-MARK-OPCODE))))) (SEND HOST-UNIT :FREE-DATA-CONNECTION DATA-CONN DIRECTION)) (SYS:HOST-STOPPED-RESPONDING NIL))))))))) )) ; From modified file DJ: L.NETWORK.CHAOS; QFILE.LISP#377 at 3-Sep-87 12:24:47 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFUN MAKE-FILE-PROPERTY-LIST-STREAM-CHAOS (ACCESS COMMAND WHOSTATE STRING-ARG TOKEN-ARGS PATHNAME NO-ERROR-P &AUX DATA-CONN HOST-UNIT PKT SUCCESS NOT-ABORTED STRING (DEFAULT-CONS-AREA SYS:BACKGROUND-CONS-AREA)) (MULTIPLE-VALUE (DATA-CONN HOST-UNIT) (SEND ACCESS :GET-DATA-CONNECTION :INPUT)) (UNWIND-PROTECT (PROGN (MULTIPLE-VALUE-SETQ (PKT SUCCESS STRING) (SEND HOST-UNIT :COMMAND NIL (DATA-INPUT-HANDLE DATA-CONN) NIL WHOSTATE COMMAND TOKEN-ARGS #/NEWLINE STRING-ARG #/NEWLINE)) (COND ((NOT SUCCESS) (SETQ NOT-ABORTED T) (SETQ STRING (STRING-APPEND STRING)) (SETF (DATA-STREAM DATA-CONN :INPUT) NIL) (QFILE-PROCESS-ERROR-NEW STRING PATHNAME NIL NO-ERROR-P :DIRECTORY-STREAM)) (T (QFILE-CHECK-COMMAND COMMAND STRING) (PROG1 (MAKE-INSTANCE 'QFILE-DIRECTORY-STREAM :HOST-UNIT HOST-UNIT :DATA-CONNECTION DATA-CONN :PATHNAME PATHNAME) (SETQ NOT-ABORTED T))))) (AND PKT (CHAOS:RETURN-PKT PKT)) ;; Both success and failure set NOT-ABORTED once they get past critical section. (UNLESS (OR NOT-ABORTED (NULL DATA-CONN) (NULL (SEND HOST-UNIT :CONTROL-CONNECTION))) ;; Here if aborted out of it and server may have directory stream open. (CONDITION-CASE () (MULTIPLE-VALUE-BIND (pkt CLOSE-SUCCESS) (SEND HOST-UNIT :COMMAND NIL (DATA-INPUT-HANDLE DATA-CONN) NIL "Close" "CLOSE") (and pkt (chaos:return-pkt pkt)) (WHEN CLOSE-SUCCESS (READ-UNTIL-SYNCHRONOUS-MARK (DATA-CONNECTION DATA-CONN))) (SEND HOST-UNIT :FREE-DATA-CONNECTION DATA-CONN :INPUT)) (SYS:HOST-STOPPED-RESPONDING NIL))))) ;; Copied from LAD: RELEASE-3.NETWORK.CHAOS; QFILE.LISP#379 on 2-Oct-86 23:54:10 )) ; From modified file DJ: L.NETWORK.CHAOS; QFILE.LISP#377 at 3-Sep-87 12:24:56 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFMETHOD (QFILE-HOST-UNIT :CLOSE-DORMANT-DATA-CONNECTIONS) () (LOCK-HOST-UNIT (SELF) (DOLIST (DATA-CONNECTION (CDR DATA-CONNECTIONS)) (WHEN (DATA-CONNECTION-DORMANT DATA-CONNECTION) (let ((pkt (SEND SELF :COMMAND NIL (DATA-INPUT-HANDLE DATA-CONNECTION) NIL "Undata" "UNDATA-CONNECTION"))) (and pkt (chaos:return-pkt pkt))) (LET ((CONN (DATA-CONNECTION DATA-CONNECTION))) (CHAOS:CLOSE-CONN CONN "Done") (CHAOS:REMOVE-CONN CONN)) (SETQ DATA-CONNECTIONS (DELQ DATA-CONNECTION DATA-CONNECTIONS)))))) ))