;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 124.44
;;; Reason:
;;;  FTP-ACCESS no longer requires fs:*ftp-access-record-history* to be T
;;;  to correctly get the last Server FTP reply.
;;; Written 9-Jun-88 14:35:14 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Cthulhu from band 1
;;; with Experimental System 124.41, Experimental Local-File 74.1, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.1, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#50 at 9-Jun-88 14:36:15
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "

(defvar *last-reply*)

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#50 at 9-Jun-88 14:36:29
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun command-1 (command-string)
  (catch 'lostpeer
    (unless *control*
      (and *debug* (format *error-output* "~&No control connection for command~%"))
      (return-from command-1 0))

    (do ()
	((not (send *control* :listen)))
      ;;Server has a bug -- shouldn't be extra replies here!
      (push-history)
      (let ((string *last-reply*))
	(copy-array-contents "BUG: " string)
	(setf (fill-pointer string) 5)
	(do ((c nil))
	    ((eq c #\return))
	  (setq c (send *control* :tyi))
	  (when (null c) (lostpeer))
	  (unless (eq c (sym cr))
	    (when (eq c (sym lf))
	      (setq c #\return))
	    (history-record-char c)))
	(when *verbose*
	  (format t "~&~A" string))))
    
    (if *debug* (format t "~&---> ~A~%" command-string))
    (unless (eq *history* :dont-record)
      (push (string-append "" command-string) *history*))
    (send *control* :string-out command-string)
    (send *control* :tyo (sym cr))
    (send *control* :tyo (sym lf))
    (send *control* :force-output)
    (getreply (if (string-equal command-string "QUIT")
		  (if *ignore-reply-from-quit*
		      (return-from command-1 nil)
		    t)))
    ))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#50 at 9-Jun-88 14:36:41
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun push-history ()
  (cond ((eq *history* :dont-record)
	 (if *last-reply*
	     (setf (fill-pointer *last-reply*) 0)
	   (setq *last-reply* (make-history-element))))
	(t
	 (push (setq *last-reply* (make-history-element)) *history*))))

(defun make-history-element ()
  (make-array 80. :element-type 'string-char :fill-pointer 0 :adjustable t))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#50 at 9-Jun-88 14:36:44
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun history-record-char (c)
  (vector-push-extend c *last-reply*))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#50 at 9-Jun-88 14:36:45
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun last-reply ()
  *last-reply*)

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#50 at 9-Jun-88 14:37:10
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "

(defun ftp (&optional remote-hostname
	    &key
	    (auto-login t)
	    (trace t)
	    (hash nil)
	    (sendport t)
	    (verbose t)
	    (debug nil)
	    (bell nil)
	    (glob t)
	    (prompt t)
	    user pass acct)

  (let ((*print-radix* nil)			;prevent garbage in numbers printed by princ and prin1
	(*history* nil)
	(*last-reply* nil)
	(*connected* nil)
	(*control* nil)
	(*data* nil)
	(*remote-hostname* remote-hostname)
	(*auto-login* auto-login)
	(*trace* trace)
	(*hash* hash)
	(*sendport* sendport)
	(*verbose* verbose)
	(*debug* debug)
	(*bell* bell)
	(*glob* glob)
	(*prompt* prompt)
	(*type* 'ascii)
	(*struct* 'file)
	(*form* 'non-print)
	(*mode* 'stream)
	(*bytesize* 8.)
	(*user* user)
	(*pass* pass)
	(*acct* acct))

    (when *remote-hostname*
      (cmd-open *remote-hostname*))
    (catch 'quit
      (unwind-protect
	  (global:error-restart ((error) "Return to FTP Command Loop.")
	    (loop
	      (execute-ftp-command-list
		(parse-line-into-list
		  (global:prompt-and-read :string-or-nil "~&ftp> ")))))
	(cmd-close)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#55 at 9-Jun-88 14:37:17
#10R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  "


(defflavor ftp-host-unit
	   ((ftp:*auto-login* nil)
	    (ftp:*trace* *ftp-host-unit-debug*)
	    (ftp:*hash* *ftp-host-unit-debug*)
	    (ftp:*sendport* t)
	    (ftp:*verbose* *ftp-host-unit-debug*)
	    (ftp:*debug* *ftp-host-unit-debug*)
	    (ftp:*bell* nil)
	    (ftp:*glob* t)
	    (ftp:*prompt* nil)
	    (ftp:*type* 'ftp:ascii)
	    (ftp:*struct* 'ftp:file)
	    (ftp:*form* 'ftp:non-print)
	    (ftp:*mode* 'ftp:stream)
	    (ftp:*bytesize* 8.)
	    (ftp:*user* nil)
	    (ftp:*pass* nil)
	    (ftp:*acct* nil)
	    (ftp:*history* nil)
	    (ftp:*last-reply* nil)
	    (ftp:*connected* nil)
	    (ftp:*remote-hostname* nil)
	    (ftp:*control* nil)
	    (ftp:*data* nil)
	    (reserve-lock (LIST NIL))
	    (file-stream nil)
	    (working-directory))
	   (basic-host-unit)
  :special-instance-variables)

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#55 at 9-Jun-88 14:37:35
#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 :close-control-connection) ()
  ;; Close connection, for logging out
  (ftp:cmd-close)
  (setq working-directory nil)
  (setq ftp:*last-reply* nil)
  (setq ftp:*history* nil))


))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#55 at 9-Jun-88 14:37:47
#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 :ftp-error) (how on-what)
  (let* ((reply ftp:*last-reply*)
	 (end (and reply (string-search-char #\return reply))))
    (file-process-error (if reply
			    (cadr (assq (parse-number reply 0 3 10 t) ftp-error-code-condition-alist))
			  'network-lossage)
			(string-append (if (keywordp how)
					   (or (get how 'english)
					       (string how))
					 how)
				       " /""
				       (cond (end (substring reply 0 (1- end)))
					     (reply)
					     (t ""))
				       "/"")
			on-what
			nil
			nil)))


))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#55 at 9-Jun-88 14:37: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-host-unit :homedir) (user &aux s start end homepath)
  (setq working-directory
	(cond (working-directory)
	      ((and (ftp:cmd-pwd)
		    (setq s ftp:*last-reply*)
		    (setq start (string-search-char #/" s))
		    (setq end (string-search-char #/" s (1+ start)))
		    (setq homepath (fs:parse-pathname s
						      host
						      *default-pathname-defaults*
						      (1+ start)
						      end
						      t)))
	       homepath)
	      ('else
	       (send (send host :sample-pathname) :new-directory user)))))


))