;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*- ;;; Patch file for System version 126.21 ;;; Reason: ;;; 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)))))))))) ))