;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 124.12
;;; Reason:
;;;  Make use of new TCP whostate feature in User FTP and FTP-ACCESS.
;;; Written 27-May-88 18:47:19 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Cthulhu from band 2
;;; with Experimental System 124.10, Experimental Local-File 74.0, Experimental File-Server 23.0, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.0, Experimental Lambda-Diag 16.0, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8.



; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#45 at 27-May-88 18:48:18
#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)
		   (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")))
	       (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 ((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))))))))))


))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#45 at 27-May-88 18:48: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 :rename) (file new-pathname error-p)
  (command-using-unit (unit error-p)
    (let ((tcp:*tcp-stream-whostate* "Rename"))
      (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#45 at 27-May-88 18:48:21
#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)
    (let ((tcp:*tcp-stream-whostate* "Delete"))
      (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#45 at 27-May-88 18:48:23
#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)
	(let ((tcp:*tcp-stream-whostate* "Undelete"))
	  (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#45 at 27-May-88 18:48:25
#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)
    (let ((tcp:*tcp-stream-whostate* "Expunge"))
      (ftp-access-operation pathname unit :expunge (send pathname :string-for-host)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#45 at 27-May-88 18:48:29
#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)
    (let ((tcp:*tcp-stream-whostate* "Create Directory"))
      (ftp-access-operation file unit :makedir (send file :string-for-host)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#45 at 27-May-88 18:48:52
#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 :multiple-file-plists) (files options)
  (do* ((list files (cdr list))
	(file (car list) (car list))
	(error-p (not (memq :noerror options)))
	(result nil))
       ((null list)
	(nreverse result))
    (let* ((pathname (normalize-ftp-directory-list-pathname file host))
	   (tcp:*tcp-stream-whostate* "File Properties")
	   (plist (with-open-file (s pathname :raw-directory-list t :error error-p)
		    (if (errorp s)
			s
		      (ftp-access-canonicalize-directory-list
			(cons
			  `(nil :pathname ,pathname)
			  (do ((line) (eofp) (list))
			      (eofp (nreverse list))
			    (multiple-value (line eofp) (send s :line-in))
			    (when line
			      (let* ((plist (ftp-parse-directory-list-line line host pathname)))
				(when (and plist (car plist))
				  (push plist list)))))))))))
      (if (errorp plist)
	  (push plist result)
	(dolist (elt plist)
	  (push elt result))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#45 at 27-May-88 18:48: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-file-stream-mixin :after :close) (&optional abortp)
  (unless (eq status :closed)
    (let ((tcp:*tcp-stream-whostate* "Close"))
      (send actual :close abortp))
    (send host-unit :remove-file-stream self)
    (send host-unit :close-dataconn)
    (send host-unit :free)
    (setq status :closed)))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#45 at 27-May-88 18:48:59
#10R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  "


(defmethod (ftp-input-raw-stream :next-input-buffer) (&optional no-hang-p)
  (let ((tcp:*tcp-stream-whostate* "Net File Input"))
    (send actual :next-input-buffer no-hang-p)))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#45 at 27-May-88 18:49:00
#10R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  "


(defmethod (ftp-input-binary-stream :next-input-buffer) (&optional no-hang-p)
  ;; maybe change this in the future to call :next-input-buffer
  ;; copy the contents, then call :discard-input-buffer on actual.
  (let ((tcp:*tcp-stream-whostate* "Net File Input"))
    (ecase byte-size
      (8
       (send actual :next-input-buffer no-hang-p))
      (16
       (multiple-value-bind (array start end)
	   (send actual :next-input-buffer no-hang-p)
	 (when array
	   (when (oddp (- end start))
	     (error "16 bit stream, but odd byte count in input buffer"))
	   (let ((length (ceiling (- end start) 2)))
	     (values (make-array length
				 :element-type '(unsigned-byte 16)
				 :displaced-to array
				 :displaced-index-offset start)
		     0
		     length))))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#45 at 27-May-88 18:49:02
#10R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  "


(defmethod (ftp-input-character-stream :next-input-buffer) (&OPTIONAL NO-HANG-P)
  (multiple-value-bind (ARRAY START END)
      (let ((tcp:*tcp-stream-whostate* "Net File Input"))
	(send actual :next-input-buffer no-hang-p))
    (cond ((null array)
	   nil)
	  ('else
	   ;; we know that the array-cache makes things faster
	   ;; when we are concentrating on a single array at a time
	   ;; so we preallocate a big enough buffer and do an in-place
	   ;; translation.
	   (let* ((size (- end start))
		  (string (allocate-resource 'simple-string-buffer size)))
	     (copy-array-portion array start end string 0 size)
	     ;; might as well free up the dma resource now in the
	     ;; actual stream.
	     (send actual :discard-input-buffer array)
	     ;; the VAX instruction MOVTUC would be useful here.
	     ;; (move translated until character)
	     (do ((j 0 (1+ j))
		  (i 0)
		  (c))
		 ((= j size)
		  (values string 0 i))
	       (cond ((= 13 (setq c (aref string j))))
		     ((= c 10)
		      (aset #\return string i)
		      (incf i))
		     ((or (= c 8) (= c 9) (= c 12) (= c 13))
		      (aset (+ c #o200) string i)
		      (incf i))
		     ('else
		      (aset c string i)
		      (incf i)))))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#45 at 27-May-88 18:49: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-output-raw-stream :new-output-buffer) ()
  (declare (values array start end))
  (let ((tcp:*tcp-stream-whostate* "Net File Output"))
    (send actual :new-output-buffer)))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#45 at 27-May-88 18:49: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-output-binary-stream :new-output-buffer) ()
  (declare (values array start end))
  (let ((tcp:*tcp-stream-whostate* "Net File Output"))
    (ecase byte-size
      (8
       (send actual :new-output-buffer))
      (16
       (let* ((array (send actual :new-output-buffer))
	      (length (floor (array-length array) 2)))
	 (values (make-array length
			     :element-type '(unsigned-byte 16)
			     :displaced-to array)
		 0
		 length))))))


))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#45 at 27-May-88 18:49:06
#10R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  "


(defmethod (ftp-output-character-stream :send-output-buffer) (buff limit)
  (let ((offset 0)
	(actual-stream actual)
	(tcp:*tcp-stream-whostate* "Net File Output"))
    (labels ((outbuff (end)
		      (do ((j offset (1+ j))
			   (s buff)
			   (c))
			  ((= j end)
			   (send actual-stream :string-out s offset end))
			(if (> (setq c (aref s j)) #o200)
			    (aset (- c #o200) s j))))
	     (outc (c) (send actual-stream :tyo c)))
      (do ((n))
	  ((null (setq n (string-search-char #\return buff offset limit)))
	   (outbuff limit))
	(outbuff n)
	(outc (tcp-application:sym ftp:CR))
	(outc (tcp-application:sym ftp:LF))
	(setq offset (1+ n)))))
  (deallocate-resource 'simple-string-buffer BUFF))
  

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#45 at 27-May-88 18:50:17
#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 :directory-list) (given-pathname options)
  (let ((pathname (normalize-ftp-directory-list-pathname given-pathname host))
	(no-error-p nil)			;T to not generate errors
	(deleted-p nil)				;T to include deleted files
	(sorted-p nil)				;T to sort generated list
	(tcp:*tcp-stream-whostate* "Directory List"))
    (do ((l options (cdr l)))
	((null l))
      (case (car l)
	(:noerror (setq no-error-p t))
	(:sorted (setq sorted-p t))
	(:deleted (setq deleted-p t))
	(otherwise (ferror nil "~S is not a known DIRECTORY option" (car l)))))
    (with-open-file (s pathname :raw-directory-list t :error (not no-error-p))
      (if (errorp s)
	  s
	(let ((dir-list (ftp-access-canonicalize-directory-list
			  (cons
			    `(nil :pathname ,pathname)
			    (do ((line) (eofp) (list))
				(eofp (nreverse list))
			      (multiple-value (line eofp) (send s :line-in))
			      (when line
				(let ((plist (ftp-parse-directory-list-line line host pathname)))
				  (when plist
				    (let ((truename (getf (cdr plist) :truename))
					  (deleted (getf (cdr plist) :deleted)))
				      (when (or (not deleted) deleted-p)
					(when truename
					  (setf (car plist) truename))
					(push plist list)))))))))))
	  (when sorted-p
	    (let ((null-elem (assq nil dir-list)))
	      (and null-elem (setq dir-list (delq null-elem dir-list)))
	      (setq dir-list (sortcar dir-list #'pathname-lessp))
	      (and null-elem (push null-elem dir-list))))
	  dir-list)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#47 at 31-May-88 13:30:29
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun hookup (host port &optional (keyword "FTP Control Connection"))
  (setq *remote-hostname* (if (numberp host)
			      (format nil "~X" host)
			    (string host)))
  (let ((tcp:*tcp-stream-whostate* "Open Control Connection"))
    (setq *control* (open (string-append "TCP-HOST:" host "." port)
			  :keyword keyword))
    (setq *connected* t)
    (if *verbose* (format t "~&Connected to ~S~%" host))
    (getreply nil)))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#47 at 31-May-88 13:30:32
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun ftp-getreply (expecteof)
  (let ((tcp:*tcp-stream-whostate* "Reply"))
    (getreply expecteof)))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#47 at 31-May-88 13:30:44
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun close-control-connection ()
  (when *control*
    (let ((tcp:*tcp-stream-whostate* "Close Control Connection"))
      (unwind-protect
	  (close *control*)
	(setq *control* nil)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#47 at 31-May-88 13:30:45
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun close-data-connection ()
  (when *data*
    (let ((tcp:*tcp-stream-whostate* "Close Data Connection"))
      (unwind-protect
	  (close *data*)
	(setq *data* nil)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#47 at 31-May-88 13:30:46
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun lostpeer ()
  (when *connected*
    (setq *type* 'ascii)
    (setq *struct* 'file)
    (setq *form* 'non-print)
    (setq *mode* 'stream)
    (setq *bytesize* 8.)
    (close-control-connection)
    (close-data-connection)
    (setq *connected* nil)
    (let ((s (last-reply))
	  (bogo "599 server randomly died, lost connection, did not print this"))
      (when s
	(setf (fill-pointer s) (length bogo))
	(copy-array-contents bogo s)))
    (throw 'lostpeer (values (sym error) 599))))


))

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


(defun ftp-command (fmt &rest args)
  "Send an FTP command to the control connection.  For use within (ftp:ftp)"
  (let ((tcp:*tcp-stream-whostate* "Command"))
    (command-1 (apply #'format nil fmt args))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#47 at 31-May-88 13:30:57
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun recvrequest (cmd local remote)
  "local is a string describing the local place to put the
requested data. remote is a remote description."
  (prog (start stop bytes din fout)
	(setq bytes 0)
	(unwind-protect
	    (progn (when (initconn :input)
		     (go done))
		   (let ((x (if remote
				(ftp-command "~A ~A" cmd remote)
			      (ftp-command cmd))))
		     (unless (= x (sym prelim))
		       (go done)))
		   (setq din (dataconn :input))
		   (if (not din) (go bad))
		   (setq fout (cond ((null local) *standard-output*)
				    ((streamp local) local)
				    ((stringp local)
				     (if (eq *type* '16bit)
					 (make-8b-to-16b-translating-output-stream
					   (open local :direction :output :byte-size 16 :characters nil))
				       (open local :direction :output)))))
		   (setq start (time:time))
		   (let ((tcp:*tcp-stream-whostate* "Net File Input"))
		     (global:stream-copy-until-eof din fout))
		   (setq stop (time:time))
		   (setq bytes (send din :bytes)))
	  (unless stop
	    (setq stop (time:time))
	    (if din (setq bytes (send din :bytes))))
	  (close-data-connection)
	  (when fout
	    (unless (eq fout *standard-output*)
	      (close fout))))
     bad
	(ftp-getreply nil)
     done
	(if (and (> bytes 0) *verbose*)
	    (ptransfer "received" bytes start stop))
	(return nil)))


))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#47 at 31-May-88 13:30:58
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun sendrequest (cmd local remote)
  (prog (start stop bytes dout)
	(setq bytes 0)
	(unwind-protect
	    (progn (if (initconn :output) (go bad))
		   (unless (= (ftp-command "~A ~A" cmd remote) (sym prelim))
		     (go done))
		   (setq dout (dataconn :output))
		   (if (null dout) (go bad))
		   (when (eq *type* '16bit)
		     (setq dout (make-16b-to-8b-translating-output-stream dout)))
		   (with-open-stream (fin (if (eq *type* '16bit)
					      (open local :byte-size 16 :characters nil)
					    (open local)))
		     (setq start (time:time))
		     (let ((tcp:*tcp-stream-whostate* "Net File Output"))
		       (global:stream-copy-until-eof fin dout))
		     (send dout :force-output)
		     (setq stop (time:time))
		     (setq bytes (send dout :bytes))))
	  (unless stop
	    (setq stop (time:time))
	    (if dout (setq bytes (send dout :bytes))))
	  (close-data-connection))
	(close dout)
     bad
	(ftp-getreply nil)
     done
	(if (and (> bytes 0) *verbose*)
	    (ptransfer "sent" bytes start stop))
	(return nil)))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#47 at 31-May-88 13:31:03
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun initconn (direction &optional buffers optimistic)
  (unless (numberp buffers)
    (setq buffers *ftp-buffers*))
  (close-data-connection)
  (let ((addr nil)
	(port nil)
	(result nil)
	(tcp:*tcp-stream-whostate* "Open Data Connection"))
    (setq *data* (tcpa:open-easy-tcp-stream (send *control* :remote-address)
					    (sym-value 'tcpa:ipport-ftp-data)
					    (unless *sendport*
					      (send *control* :local-port))
					    :direction direction
					    :input-buffers (ecase direction
							     (:input buffers)
							     (:output 0))
					    :output-buffers (ecase direction
							      (:output buffers)
							      (:input 0))
					    :optimistic optimistic
					    :keyword "FTP Data Connection"
					    :connect nil))
    (when *sendport*
      (setq addr (send *data* :local-address))
      (setq port (send *data* :local-port))
      (setq result (command "PORT ~D,~D,~D,~D,~D,~D"
			    (ldb (byte 8 24) addr)
			    (ldb (byte 8 16) addr)
			    (ldb (byte 8 8) addr)
			    (ldb (byte 8 0) addr)
			    (ldb (byte 8 8) port)
			    (ldb (byte 8 0) port)))
	(if (= result (sym error))
	    (let ((*sendport* nil))
	      (initconn direction))
	  (not (= result (sym complete)))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#47 at 31-May-88 13:31:06
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun close-dataconn (&optional (getreply t))
  (close-data-connection)
  (and getreply *connected* (ftp-getreply nil)))

#|
Character translation hair. The operations provided by the
stream-default-handler are:
 :tyipeek :listen
 :any-tyi :tyi-no-hang
 :any-tyi-no-hang
 :read-char
 :any-read-char :read-char-no-hang
 :any-read-char-no-hang
 :read-byte
 :unread-char
 :write-char
 :write-byte
 :clear-output :clear-input :force-output :finish :close :eof
 :fresh-line
 :string-out :line-out
 :line-in
 :string-in
 :string-line-in
 :operation-handled-p
 :characters
 :element-type
 :direction
 :send-if-handles

Although we are only concerned with what stream-copy-until-eof will
send, which is :read-input-buffer on :input, and :string-out on :output.

|#

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#47 at 31-May-88 13:31:09
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defun try-login (u p a)
  (let ((logged-in nil)
	(tcp:*tcp-stream-whostate* "Login"))
    (multiple-value-setq (u logged-in)
      (send-user-info "(username) " "USER" u))
    (cond ((null u)
	   (return-from try-login))
	  (logged-in
	   (return-from try-login (values u p a))))

    (multiple-value-setq (p logged-in)
      (send-user-info "(password) " "PASS" p nil))
    (cond ((null p)
	   (return-from try-login))
	  (logged-in
	   (return-from try-login (values u p a))))

    (multiple-value-setq (a logged-in)
      (send-user-info "(account) " "ACCT" a))
    (cond ((null a)
	   (return-from try-login))
	  (logged-in
	   (return-from try-login (values u p a))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#47 at 31-May-88 13:31:12
#10R FTP#: #!:CL
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  "


(defcmd cmd-close () t
  "terminate ftp session"
  (when *connected*
    (setq *type* 'ascii)
    (setq *struct* 'file)
    (setq *form* 'non-print)
    (setq *mode* 'stream)
    (setq *bytesize* 8.)
    (command "QUIT")
    (close-control-connection)
    (close-data-connection)
    (setq *connected* nil)))

))