;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 124.14
;;; Reason:
;;;  User FTP shouldn't bomb trying to send a QUIT command on a connection
;;;  that is already closed.
;;; Written 31-May-88 15:11:24 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.LISP#48 at 31-May-88 15:11:43
#10R FTP#: 
(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!
      (let ((string (make-array 75 :element-type 'string-char :fill-pointer 0 :adjustable t)))
	(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))
	    (vector-push c string)))
	(when *verbose*
	  (format t "~&~A" string))
	(unless (eq *history* :dont-record)
	  (push string *history*))))
    
    (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)))
    ))

))