;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*- ;;; Patch file for System version 123.115 ;;; Reason: ;;; When using FTP to read and write files to a Lisp Machine, use Image transfer ;;; type, as no character translation is needed. ;;; Written 18-Nov-87 14:45:41 by pld at site Gigamos Cambridge ;;; while running on Jack Flanders from band 2 ;;; with Experimental System 123.114, Experimental Local-File 73.2, Experimental FILE-Server 22.1, 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-ACCESS.LISP#38 at 18-Nov-87 14:46:10 #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)) (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 :ftp-error "Access error" file)))))))))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#38 at 18-Nov-87 14:46:18 #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 :dataconn) (file pathname direction byte-size rawp ps) ;; in fact the only real way to get the truename ;; would be to do a directory listing. ;; We will in fact do that someday in order to get all the ;; info the lispm wants, such as the length, byte size, creation date. ;; Info about the protection could also be useful in interpreting ;; error messages. For now we keep around the string for host ;; just to have a pathname for printing the file stream. (let* ((host-unit self) (fs (ftp:dataconn direction #'(lambda (raw-stream dir typearg) ;; type can be NIL, :ASCII, :EBCDIC (make-instance (ecase dir (:input (cond ((eq typearg :ascii) 'ftp-input-character-stream) ((= byte-size 8) 'ftp-input-raw-stream) (t 'ftp-input-binary-stream))) (:output (cond ((eq typearg :ascii) 'ftp-output-character-stream) ((= byte-size 8) 'ftp-output-raw-stream) (t 'ftp-output-binary-stream)))) :byte-size byte-size :actual raw-stream :host-unit host-unit :truename file :pathname pathname :support-plistp (not rawp) :probe-stream ps ))))) (if fs (send self :add-file-stream fs)) fs)) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#38 at 18-Nov-87 14:46:23 #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  " (defflavor ftp-input-raw-stream () (si:buffered-input-character-stream si:input-file-stream-mixin ftp-file-stream-mixin)) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#38 at 18-Nov-87 14:46:24 #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  " (defmethod (ftp-input-raw-stream :next-input-buffer) (&optional no-hang-p) (send actual :next-input-buffer no-hang-p)) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#38 at 18-Nov-87 14:46:27 #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  " (defmethod (ftp-input-raw-stream :discard-input-buffer) (array) (send actual :discard-input-buffer array)) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#38 at 18-Nov-87 14:46:38 #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  " (defflavor ftp-output-raw-stream () (si:buffered-output-character-stream si:output-file-stream-mixin ftp-file-stream-mixin)) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#38 at 18-Nov-87 14:46:41 #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  " (defmethod (ftp-output-raw-stream :new-output-buffer) () (declare (values array start end)) (send actual :new-output-buffer)) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#38 at 18-Nov-87 14:46:43 #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  " (defmethod (ftp-output-raw-stream :send-output-buffer) (array end) (send actual :send-output-buffer array end)) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#38 at 18-Nov-87 14:46:49 #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  " (defmethod (ftp-output-raw-stream :discard-output-buffer) (array) (send actual :discard-output-buffer array)) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#38 at 18-Nov-87 14:46:49 #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  " (compile-flavor-methods ftp-input-raw-stream ftp-output-raw-stream) ))