;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 124.40
;;; Reason:
;;;  If you run with fs:*ftp-access-record-history* set to NIL, you can no longer
;;;  tell exactly what the Server FTP didn't like about your access request.
;;; Written 8-Jun-88 18:30:33 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Azathoth from band 1
;;; with Experimental System 124.39, 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-ACCESS.LISP#53 at 8-Jun-88 18:30:34
#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#53 at 8-Jun-88 18:30:34
#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)))))

))