;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.46
;;; Reason:
;;;  Define the various ftp-access debugging functions (fs:with-ftp-access-only, etc.)
;;; Written 9-Oct-87 12:13:57 by naha at site LMI Cambridge
;;; while running on Love from band 2
;;; with Experimental System 123.41, 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.13, SDU ROM 102.



; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP-ACCESS.LISP#15 at 9-Oct-87 12:13:58
#10R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP-ACCESS  "


#||

These are debugging hacks. The present mechanisms dont seem good
enough to tell what access method to use on a per host basis.
Chaos is getting used by default. But if the desirability of FTP is
made higher than chaos then connections to lambdas with internet address
also uses ftp. To win during debugging just use this macro around
your first call to open on the pathname in particular.

||#

(defmacro with-ftp-access-only (&rest body)
  `(let ((fs:*FILE-ACCESS-PATHS* (list (assq 'ftp-access *FILE-ACCESS-PATHS*))))
     ,@body))

(defun get-host-unit (x)
  (if (typep x 'basic-host-unit)
      x
    (let* ((pathname (parse-pathname x))
	   (host (and pathname (send pathname :host)))
	   (access (and host (send host :access))))
      (when access
	(values-list (send access :host-units))))))

(defun ftp-unit-quit (u)
  (setq u (get-host-unit u))
  (when u
    (send u :close-control-connection)
    (set-in-instance u 'fs:file-stream nil)))

(defun ftp-history (u)
  (setq u (get-host-unit u))
  (when u
    (send u :funcall-inside-yourself 'ftp:cmd-history)))


(defun ftp-listf (p)
  (with-open-file (s p :raw-directory-list t)
    (format t "~&For directory ~S~%" p)
    (stream-copy-until-eof s standard-output)))

))