;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*- ;;; Patch file for System version 124.30 ;;; Reason: ;;; When you Abort out of Opening a file with FTP-ACCESS, you have to reset the ;;; host unit -- control/data connection can be in weird states. ;;; Written 6-Jun-88 18:08:35 by pld (Peter L. DeWolf) at site Gigamos Cambridge ;;; while running on Cthulhu from band 1 ;;; with Experimental System 124.28, Experimental Local-File 74.1, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.1, Experimental Tape 23.6, Experimental Lambda-Diag 16.1, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8, the old ones. ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#50 at 6-Jun-88 18:08:45 #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  " (defmethod (ftp-host-unit :reset) (&optional dont-unlock-lock-p) ;; Close all data streams in abort mode, close control connection dont-unlock-lock-p ;; we think we can ignore this. (when file-stream (send file-stream :close :abort)) (unwind-protect (let ((tcp:*tcp-stream-whostate* "Reset Host Unit")) (send self :close-control-connection)) (send self :free))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#49 at 6-Jun-88 18:09:01 #10R FTP#: #!:CL (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  " (defcmd cmd-close () t "terminate ftp session" (when *connected* (setq *type* 'ascii) (setq *struct* 'file) (setq *form* 'non-print) (setq *mode* 'stream) (setq *bytesize* 8.) (close-data-connection) (command "QUIT") (close-control-connection) (setq *connected* nil))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#50 at 6-Jun-88 18:14:01 #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  " (defmacro allocating-host-unit ((unit) &body body &aux (temp (gentemp unit)) (normalp (gentemp 'normalp))) "use this to get a host unit, which is deallocated if exited abnormally" `(let (,temp ,normalp) (unwind-protect (let ((,unit (setq ,temp (send self :get-host-unit)))) (multiple-value-prog1 (progn ,@body) (setq ,normalp t))) (and ,temp ;We got a host unit... (not ,normalp) ;Body did not complete normally... (send ,temp :reset))))) ;We must reset it. control connection in unknown state. )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#50 at 6-Jun-88 18:14:08 #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  " (defmethod (ftp-access :open) (file pathname &key &optional (direction :input) (characters t) (byte-size :default) (error t) if-exists ; if-does-not-exist raw-directory-list probe-directory-list &allow-other-keys &aux probe-stream) (cond ((memq direction '(nil :probe)) (make-instance 'ftp-probe-stream :truename nil :pathname pathname :host host :raw-data (and (ftp-directory-line-parserp host t) (with-output-to-string (s) (with-open-file (d file :raw-directory-list t :probe-directory-list t :error error) (when (streamp d) (stream-copy-until-eof d s))))))) ('else (when (and (memq direction *ftp-probe-before-open-directions*) (not raw-directory-list) (or (eq *ftp-probe-before-open-p* t) (memq (send host :system-type) *ftp-probe-before-open-p*) (get host :ftp-probe-before-open-p))) (setq probe-stream (open file :direction nil :error error)) (when (and (eq direction :output) (memq (send file :version) '(nil :newest))) (cond ((not (send probe-stream :truename)) (send probe-stream :set-truename (send file :new-version 1))) ((numberp (send (send probe-stream :truename) :version)) ;; kludge-a-rama. The *FTP-PROBE-BEFORE-OPEN-P* is useful ;; if the host cant take so many simultaneous servers ;; as would be created if we probe *after* the opening of ;; the file data connection. The most sensible solution to ;; all of this is to use another file protocol. (send probe-stream :set-truename (send (send probe-stream :truename) :new-version (1+ (send (send probe-stream :truename) :version)))))) (when (not (plist probe-stream)) (setf (plist probe-stream) `(:creation-date ,(time:get-universal-time)))))) (handling-file-errors (error) (allocating-host-unit (unit) (let ((command nil) (buffers nil) (optimistic nil) (tcp:*tcp-stream-whostate* (cond (probe-directory-list "Probe") (raw-directory-list "Directory") (t "Open")))) (when probe-directory-list (setq buffers 1) (setq optimistic t)) (cond (raw-directory-list (setq command "LIST ~A")) ((eq direction :output) (setq command (caseq if-exists (:append "APPE ~A") (t "STOR ~A")))) ((eq direction :input) (setq command "RETR ~A"))) (and (eq byte-size :DEFAULT) (eq characters t) (setq byte-size 8)) (cond ((and (eq characters :DEFAULT) (eq byte-size :DEFAULT)) ;; almost no way of getting this information ;; unix uses magic numbers, on VMS maybe character if ;; record format variable length CR. ;; for now kludge it so that at least load works on ;; qfasl files. (multiple-value (characters byte-size) (kludge-ftp-characterp file pathname))) ((eq byte-size :default) (setq byte-size 8))) (cond ((not characters) (send unit :setbinary byte-size)) ((eq (send host :system-type) :lispm) (send unit :setbinary 8)) ('else ;; in fact if the host is a unix host then ;; binary mode with our own easier-to-do translation ;; would be better than forcing kludgy ascii ;; translation to happen on both hosts. (send unit :setascii))) (ftp-access-operation file unit :initconn direction buffers optimistic) (multiple-value-bind (c code) (send unit :command command (fixup-ftp-string-for-host (send file :string-for-host) file)) (cond ((= c (tcp-application:sym ftp:PRELIM)) (ftp-access-operation file unit :dataconn file pathname direction byte-size raw-directory-list probe-stream)) ((and (= code 530.) (progn (send unit :login unit t host) ;; some hosts forget about the PORT ;; command after a USER command is ;; given, so give it again. (ftp-access-operation file unit :initconn direction buffers optimistic) (= (tcp-application:sym ftp:PRELIM) (send unit :command command (send file :string-for-host))))) (ftp-access-operation file unit :dataconn file pathname direction byte-size raw-directory-list probe-stream)) ('else (send unit :close-dataconn nil) (send unit :ftp-error "Access error" file)))))))))) ))