;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*- ;;; Patch file for System version 123.129 ;;; Reason: ;;; Soup up User FTP's "mget" and "mdelete" commands: ask the remote host to expand ;;; wildcards in each of the arguments, using NLST command. Add a User FTP command ;;; to do an NLST, and set up our Server's NLST to return just the string-for-dired ;;; (which omits the host and directory) in lower case. The result is exactly what ;;; a Unix "mget" would like to see. ;;; Written 30-Nov-87 13:27:04 by pld at site Gigamos Cambridge ;;; while running on Jack Flanders from band 2 ;;; with Experimental System 123.126, Experimental Local-File 73.3, Experimental FILE-Server 22.1, 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.12, SDU ROM 8. ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#42 at 30-Nov-87 13:27:09 #10R FTP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  " (defun getreply-line (expecteof) (labels ((peekc () (or (and *control* (send *control* :tyipeek)) (if expecteof nil (lostpeer)))) (getc () (let ((c (and *control* (send *control* :tyi)))) (or expecteof c (lostpeer)) (or (not c) (= c (sym lf)) (history-record-char (if (= c (sym cr)) #\return c))) (cond ((or (not c) (not *verbose*))) ((= c (sym lf))) ((= c (sym cr)) (terpri)) ('else (write-char c))) c))) (prog (code j c weight continuationp) (when *verbose* (format t "~&")) (setq code 0 j 0) get-code (cond ((not (= j 3))) ((eq #\- (int-char (peekc))) (setq continuationp t) (getc) (go get-crlf)) ('else (go get-crlf))) (setq c (getc)) (cond ((null c) (return (values -1 nil))) ((null (setq weight (digit-char-p c))) (setq code nil) (go get-crlf)) ('else (setq code (+ (* code 10) weight)) (incf j) (go get-code))) get-crlf (setq c (getc)) (cond ((null c) (return (values code continuationp))) ((= c (sym cr)) (setq c (getc)) (or (eq c (sym lf)) (not *debug*) (error "expecting LF after CR but got: ~@C" c)) (return (values code continuationp))) ('else (go get-crlf)))))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#42 at 30-Nov-87 13:27:24 #10R FTP#: (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 (read_reply start stop bytes din fout) (setq bytes 0) (unwind-protect (progn (if (initconn :input) (go bad)) (setq read_reply t) (let ((x (if remote (command "~A ~A" cmd remote) (command cmd)))) (cond ((not (= x (sym prelim))) (setq read_reply nil) (go bad)))) (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)) (global:stream-copy-until-eof din fout) (setq stop (time:time)) (setq bytes (send din :bytes))) (unless stop (setq stop (time:time)) (when *data* (close *data*) (setq *data* nil)) (if din (setq bytes (send din :bytes)))) (when fout (unless (eq fout *standard-output*) (close fout)))) (getreply nil) done (if (and (> bytes 0) *verbose*) (ptransfer "received" bytes start stop)) (return nil) bad (if read_reply (getreply nil)) (go done))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#42 at 30-Nov-87 13:27:26 #10R FTP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  " (defun wildcard-multiple-command (prompt func-spec arg-list) (when (= 1 (length arg-list)) (setq arg-list (parse-line-into-list (car arg-list)))) (dolist (arg arg-list) (dolist (file (expand-remote-wildcard arg)) (when (or (not prompt) (y-or-n-p (format nil "~A ~A? " prompt file))) (funcall func-spec file))))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#42 at 30-Nov-87 13:27:27 #10R FTP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  " (defun expand-remote-wildcard (name) (with-input-from-string (string (with-output-to-string (s) (recvrequest "NLST" s name))) (do* ((result nil) (line (read-line string) (read-line string))) ((null line) (nreverse result)) (push line result)))) ;;; file transfer commands )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#42 at 30-Nov-87 13:27:31 #10R FTP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  " (defcmd (cmd-mget cmd-mrecv) (&rest remote-files) t "receive multiple files" (wildcard-multiple-command "get" #'cmd-get remote-files)) ;;; connection hacking commands )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#42 at 30-Nov-87 13:27:37 #10R FTP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  " (defcmd (cmd-nlst) (&optional remote-directory local-file) t "list contents of remote directory" (cmd-ascii) (recvrequest "NLST" local-file remote-directory)) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; FTP.LISP#42 at 30-Nov-87 13:27:53 #10R FTP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; FTP  " (defcmd cmd-mdelete (&rest remote-files) t "delete multiple remote files" (wildcard-multiple-command "delete" #'cmd-delete remote-files)) )) ; From modified file DJ: L.NETWORK.IP-TCP.SERVER; FTP.LISP#78 at 30-Nov-87 13:29:13 #10R FTP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "FTP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; FTP  " (defun ftp-send-data-function (state instream outstream directory-p) (let ((translating-outstream (case (ftpstate-transfer-type state) (:ascii (ftp:make-ascii-translating-output-stream outstream nil)) ((:image :logical-byte-size) (case (ftpstate-byte-size state) (8 outstream) (16 (make-16b-to-8b-translating-output-stream outstream)))) (t nil))) (completedp nil)) (unwind-protect (if (not translating-outstream) (ftp-reply state 504 "Unimplemented type ~A." (ftpstate-transfer-type state)) (global:condition-case-if ftp-catch-errors (err) (progn (cond ((not directory-p) (global:stream-copy-until-eof instream translating-outstream) (or (eq translating-outstream outstream) (send translating-outstream :force-output))) ((eq directory-p t) (do ((entry)) ((null (setq entry (send instream :line-in)))) (send translating-outstream :string-out entry) (terpri translating-outstream))) ((eq directory-p :directory-list) (do ((entry)) ((null (setq entry (send instream :entry)))) (prin1 entry translating-outstream) (terpri translating-outstream))) ((eq directory-p :name-list) (send instream :entry) ;; GET RID OF DISK-SPACE-DESCRIPTION (do ((entry)) ((null (setq entry (send instream :entry)))) ;;***want lower case filename.type#version with no host or directory (send translating-outstream :string-out (string-downcase (fs:enough-namestring (car entry) (ftpstate-pn-defaults state)))) (terpri translating-outstream)))) (setq completedp t)) (fs:file-error (ftp-file-error-reply state err)) (error (ftp-reply state 451 "Local error in processing: ~A." (send err :report-string)) nil))) (close instream) (if completedp (send outstream :force-output)) (ftp-cleanup-data-connection state nil) (setf (ftpstate-data-transfer-in-progress state) nil) (if completedp (ftp-reply state 226 "Transfer complete"))))) ))