;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*- ;;; Patch file for System version 123.72 ;;; Reason: ;;; FTP-ACCESS: probe streams request 1 input buffer and an optimistic window.. ;;; Input, Output, and raw-directory-list streams NOT used simply for probe ;;; request default number of buffers and pessimistic window. ;;; Written 25-Oct-87 12:58:12 by pld at site LMI Cambridge ;;; while running on Jack Flanders from band 2 ;;; with Experimental System 123.71, 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, microcode 1754, SDU Boot Tape 3.12, SDU ROM 8. ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#29 at 25-Oct-87 12:58:16 #10R FTP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  " (defun initconn (direction &optional buffers optimistic) (unless (numberp buffers) (setq buffers 16.)) (when *data* (close *data*) (setq *data* nil)) (let ((addr nil) (port nil) (result nil)) (setq *data* (open (format nil "TCP-HOST:~D.FTP-DATA~:[#~D~;~]" (send *control* :remote-address) *sendport* (send *control* :local-port)) :direction direction :input-buffers buffers :output-buffers buffers :optimistic optimistic :keyword "FTP Data Connection" :connect nil)) (when *sendport* (setq addr (send *data* :local-address)) (setq port (send *data* :local-port)) (setq result (command "PORT ~D,~D,~D,~D,~D,~D" (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr) (ldb (byte 8 8) port) (ldb (byte 8 0) port))) (if (= result (sym error)) (let ((*sendport* nil)) (initconn direction)) (not (= result (sym complete))))))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#30 at 25-Oct-87 12:59:00 #10R FILE-SYSTEM#: #!:ZL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  " (defmethod (ftp-host-unit :initconn) (direction &optional buffers optimistic) (not (ftp:initconn direction buffers optimistic))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#30 at 25-Oct-87 13:08:20 #10R FILE-SYSTEM#: #!:ZL (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) (stream-copy-until-eof d s)))))) ('else (when (and (memq direction *ftp-probe-before-open-directions*) ;; :output is bogus for two reasons here. ;; (1) file might not already exist. ;; (2) creation date is a screw. ;; but we expect to have probe-before-open set to T ;; and directions be '(:INPUT) in release version ;; because that is safe and efficient. (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)) (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)) (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 (characters ;; 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)) ('else (send unit :setbinary byte-size))) (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 :ftp-error "Access error" file)))))))))) ))