;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.86
;;; Reason:
;;;  FTP File Access operations that result in errors now give you the option of
;;;  retrying the file operation.
;;; Written 29-Oct-87 17:56:20 by pld at site LMI Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.84, 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-ACCESS.LISP#32 at 29-Oct-87 17:56:33
#10R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  "

(defmacro handling-file-errors ((error-p) &body body)
  (let ((tag (gensym))
	(error (gensym)))
    `(condition-case-if (not ,error-p) (,error)
	 (condition-resume-if ,error-p '(file-error :retry-file-operation t
						    ("Retry the file operation.")
						    (lambda (ignore) (throw ',tag nil)))
	   (block ,tag
	     (loop
	       (catch ',tag
		 (return-from ,tag
		   (progn ,@body))))))
       (file-error ,error))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#32 at 29-Oct-87 17:56:49
#10R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  "

(defmacro command-using-unit ((unit error-p) &body body)
  `(handling-file-errors (,error-p)
     (with-host-unit (,unit)
       ,@body)))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#32 at 29-Oct-87 17:58:04
#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 (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))))))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#32 at 29-Oct-87 17:58: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-access :rename) (file new-pathname error-p)
  (command-using-unit (unit error-p)
    (ftp-access-operation file unit :renamefile
			  (send file :string-for-host)
			  (send new-pathname :string-for-host)))
  ;; should be real truename here...
  new-pathname)

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#32 at 29-Oct-87 17:58:57
#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 :delete) (file error-p)
  (command-using-unit (unit error-p)
    (ftp-access-operation file unit :delete (send file :string-for-host)))
  ;; should be real truename here
  file)

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#32 at 29-Oct-87 17:59:05
#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 :change-properties) (file error-p &rest properties)
  (if (change-properties-is-undelete properties)
      (command-using-unit (unit error-p)
	(ftp-access-operation file unit :undelete (send file :string-for-host)))
    (handling-file-errors (error-p)
      (ftp-lose file :change-properties))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#32 at 29-Oct-87 17:59:15
#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 :homedir) (user)
  (command-using-unit (unit t)
    (send unit :homedir user)))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#32 at 29-Oct-87 17:59:20
#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 :create-link) (file link-to error)
  link-to
  (handling-file-errors (error)
    (ftp-lose file :create-link)))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#32 at 29-Oct-87 17:59: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-access :expunge) (pathname error)
  (command-using-unit (unit error)
    (ftp-access-operation pathname unit :expunge (send pathname :string-for-host))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#32 at 29-Oct-87 17:59:33
#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 :remote-connect) (file error access-mode &optional unit)
  ;; Connect to the directory named by FILE.  If ACCESS-MODE is T, then do TOPS-20
  ;; access.  If UNIT is given, connect for just that unit.  (This argument should be
  ;; be ignored if it does not make sense the access object.
  ;; some file servers dont support CWD. A fairly useless operation in
  ;; lispmachine usage anyway.
  access-mode unit
  (handling-file-errors (error)
    (ftp-lose file :remote-connect)))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#32 at 29-Oct-87 17:59:40
#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 :create-directory) (file error)
  (command-using-unit (unit error)
    (ftp-access-operation file unit :makedir (send file :string-for-host))))

))