;;; -*- 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 <always> 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))))))))))

))