;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*- ;;; Patch file for System version 126.21 ;;; Reason: ;;; This space for rent. ;;; I am withdrawing this patch temporarily -- some code may be depending on ;;; totally broken FTP behavior... ;;; Fix FTP-ACCESS paths :OPEN method so that probe calls return NIL when ;;; file does not exist. Most straight-forward way is to return stream iff ;;; probe stream finds a TRUENAME for file from the PROBE-DIRECTORY-LIST. ;;; Now, things like this work: ;;; ;;; (open "angel:/usr/spool/mail/keith" :direction :probe) ;;; Written 8-Aug-88 22:27:06 by keith (Keith Corbett) at site Gigamos Cambridge ;;; while running on Breaking Glass from band 2 ;;; with Experimental System 126.14, ZWEI 125.11, ZMail 73.2, Local-File 75.2, File-Server 24.1, Unix-Interface 13.0, Tape 24.2, Lambda-Diag 17.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103. ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#59 at 8-Aug-88 22:27:07 #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)) ; ;;This was returning the probe-stream before -- and that meant ; ;;that a user-level probe was useless. Now, process :error and ; ;;:if-does-not-exist values. Callers (including this, ; ;;recursively, below!) that want the old behavior should use ; ;;the keyword :IF-DOES-NOT-EXIST :STREAM. ; (let ((probe-stream ; (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)))))))) ; (if (send probe-stream :truename) ; probe-stream ;;File exists. ; ;;File does not exist. Result depends on :IF-DOES-NOT-EXIST. ; ;;Note new value, :STREAM, used below to setup recursive call to here. ; (progn ; ;;Unify :error and :if-does-not-exist keywords ; (when (and error (null if-does-not-exist) ; (setq if-does-not-exist :error))) ; (case if-does-not-exist ; (:stream probe-stream) ; ;;A "standard" value ; (:create ; (error "Cannot create ~A on OPEN for ~A" pathname direction)) ; (:error ; (file-process-error 'file-not-found ; (format nil "File not found for ~A" pathname) ; pathname ; nil (null error) :open)) ; (t nil)))))) ; ('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 :if-does-not-exist :stream)) ; (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"))) ; (when (eq byte-size :default) ; (cond ((eq characters t) ; (setq byte-size 8)) ; ((eq characters nil) ; (setq byte-size 16.)) ; ((eq characters :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-setq (characters byte-size) ; (kludge-ftp-characterp file pathname))))) ; (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)))))))))) ))