Initial revision

1 files changed, 375 insertions, 0 deletions

diff --git a/lisp/ftp.el b/lisp/ftp.el
new file mode 100644
index 00000000000..402ef12c371
--- /dev/null
+++ b/lisp/ftp.el
@@ -0,0 +1,375 @@
+;; File input and output over Internet using FTP
+;; Copyright (C) 1987 Free Software Foundation, Inc.
+;; Author mly@prep.ai.mit.edu.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;; Prevent changes in major modes from altering these variables.
+(put 'ftp-temp-file-name 'permanent-local t)
+(put 'ftp-file 'permanent-local t)
+(put 'ftp-host 'permanent-local t)
+
+;; you can turn this off by doing
+;;  (setq ftp-password-alist 'compulsory-urinalysis)
+(defvar ftp-password-alist () "Security sucks")
+
+(defun read-ftp-user-password (host user new)
+  (let (tem)
+    (if (and (not new)
+             (listp ftp-password-alist)
+             (setq tem (cdr (assoc host ftp-password-alist)))
+             (or (null user)
+                 (string= user (car tem))))
+        tem
+      (or user
+          (progn
+            (setq tem (or (and (listp ftp-password-alist)
+                               (car (cdr (assoc host ftp-password-alist))))
+                          (user-login-name)))
+            (setq user (read-string (format
+                                      "User-name for %s (default \"%s\"): "
+                                      host tem)))
+            (if (equal user "") (setq user tem))))
+      (setq tem (cons user
+                      ;; If you want to use some non-echoing string-reader,
+                      ;; feel free to write it yourself.  I don't care enough.
+                      (read-string (format "Password for %s@%s: " user host)
+                        (if (not (listp ftp-password-alist))
+                            ""
+                          (or (cdr (cdr (assoc host ftp-password-alist)))
+                              (let ((l ftp-password-alist))
+                                (catch 'foo
+                                  (while l
+                                    (if (string= (car (cdr (car l))) user)
+                                        (throw 'foo (cdr (cdr (car l))))
+                                      (setq l (cdr l))))
+                                  nil))
+                              "")))))
+      (message "")
+      (if (and (listp ftp-password-alist)
+               (not (string= (cdr tem) "")))
+          (setq ftp-password-alist (cons (cons host tem)
+                                         ftp-password-alist)))
+      tem)))
+
+(defun ftp-read-file-name (prompt)
+  (let ((s ""))
+    (while (not (string-match "\\`[ \t]*\\([^ \t:]+\\)[ \t]*:\\(.+\\)\\'" s))
+      (setq s (read-string prompt s)))
+    (list (substring s (match-beginning 1) (match-end 1))
+          (substring s (match-beginning 2) (match-end 2)))))
+
+
+(defun ftp-find-file (host file &optional user password)
+  "FTP to HOST to get FILE, logging in as USER with password PASSWORD.
+Interactively, HOST and FILE are specified by reading a string with
+ a colon character separating the host from the filename.
+USER and PASSWORD are defaulted from the values used when
+ last ftping from HOST (unless password-remembering is disabled).
+ Supply a password of the symbol `t' to override this default
+ (interactively, this is done by giving a prefix arg)"
+  (interactive
+        (append (ftp-read-file-name "FTP get host:file: ")
+                (list nil (not (null current-prefix-arg)))))
+  (ftp-find-file-or-directory host file t user password))
+
+(defun ftp-list-directory (host file &optional user password)
+  "FTP to HOST to list DIRECTORY, logging in as USER with password PASSWORD.
+Interactively, HOST and FILE are specified by reading a string with
+ a colon character separating the host from the filename.
+USER and PASSWORD are defaulted from the values used when
+ last ftping from HOST (unless password-remembering is disabled).
+ Supply a password of the symbol `t' to override this default
+ (interactively, this is done by giving a prefix arg)"
+  (interactive
+        (append (ftp-read-file-name "FTP get host:directory: ")
+                (list nil (not (null current-prefix-arg)))))
+  (ftp-find-file-or-directory host file nil user password))
+
+(defun ftp-find-file-or-directory (host file filep &optional user password)
+  "FTP to HOST to get FILE.  Third arg is t for file, nil for directory.
+Log in as USER with PASSWORD.  If USER is nil or PASSWORD is nil or t,
+we prompt for the user name and password."
+  (or (and user password (not (eq password t)))
+      (progn (setq user (read-ftp-user-password host user (eq password t))
+                   password (cdr user)
+                   user (car user))))
+  (let ((buffer (get-buffer-create (format "*ftp%s %s:%s*"
+                                           (if filep "" "-directory")
+                                           host file))))
+    (set-buffer buffer)
+    (let ((process nil)
+          (case-fold-search nil))
+      (let ((win nil))
+        (unwind-protect
+            (progn
+              (setq process (ftp-setup-buffer host file))
+              (if (setq win (ftp-login process host user password))
+                  (message "Logged in")
+                (error "Ftp login failed")))
+          (or win (and process (delete-process process)))))
+      (message "Opening %s %s:%s..." (if filep "file" "directory")
+               host file)
+      (if (ftp-command process
+                       (format "%s \"%s\" -\nquit\n" (if filep "get" "dir")
+                               file)
+                       "\\(150\\|125\\).*\n"
+                       "200.*\n")
+          (progn (forward-line 1)
+                 (let ((buffer-read-only nil))
+                   (delete-region (point-min) (point)))
+                 (message "Retrieving %s:%s in background.  Bye!" host file)
+                 (set-process-sentinel process
+                                       'ftp-asynchronous-input-sentinel)
+                 process)
+        (switch-to-buffer buffer)
+        (let ((buffer-read-only nil))
+          (insert-before-markers "<<<Ftp lost>>>"))
+        (delete-process process)
+        (error "Ftp %s:%s lost" host file)))))
+
+
+(defun ftp-write-file (host file &optional user password)
+  "FTP to HOST to write FILE, logging in as USER with password PASSWORD.
+Interactively, HOST and FILE are specified by reading a string with colon
+separating the host from the filename.
+USER and PASSWORD are defaulted from the values used when
+ last ftping from HOST (unless password-remembering is disabled).
+ Supply a password of the symbol `t' to override this default
+ (interactively, this is done by giving a prefix arg)"
+  (interactive
+    (append (ftp-read-file-name "FTP write host:file: ")
+            (list nil (not (null current-prefix-arg)))))
+  (or (and user password (not (eq password t)))
+      (progn (setq user (read-ftp-user-password host user (eq password t))
+                   password (cdr user)
+                   user (car user))))
+  (let ((buffer (get-buffer-create (format "*ftp %s:%s*" host file)))
+        (tmp (make-temp-name "/tmp/emacsftp")))
+    (write-region (point-min) (point-max) tmp)
+    (save-excursion
+      (set-buffer buffer)
+      (make-local-variable 'ftp-temp-file-name)
+      (setq ftp-temp-file-name tmp)
+      (let ((process (ftp-setup-buffer host file))
+            (case-fold-search nil))
+        (let ((win nil))
+          (unwind-protect
+              (if (setq win (ftp-login process host user password))
+                  (message "Logged in")
+                (error "Ftp login lost"))
+            (or win (delete-process process))))
+        (message "Opening file %s:%s..." host file)
+        (if (ftp-command process
+                         (format "send \"%s\" \"%s\"\nquit\n" tmp file)
+                         "150.*\n"
+                         "200.*\n")
+            (progn (forward-line 1)
+                   (setq foo1 (current-buffer))
+                   (let ((buffer-read-only nil))
+                     (delete-region (point-min) (point)))
+                   (message "Saving %s:%s in background.  Bye!" host file)
+                   (set-process-sentinel process
+                                         'ftp-asynchronous-output-sentinel)
+                   process)
+          (switch-to-buffer buffer)
+          (setq foo2 (current-buffer))
+          (let ((buffer-read-only nil))
+            (insert-before-markers "<<<Ftp lost>>>"))
+          (delete-process process)
+          (error "Ftp write %s:%s lost" host file))))))
+
+
+(defun ftp-setup-buffer (host file)
+  (fundamental-mode)
+  (and (get-buffer-process (current-buffer))
+       (progn (discard-input)
+              (if (y-or-n-p (format "Kill process \"%s\" in %s? "
+                                    (process-name (get-buffer-process
+                                                    (current-buffer)))
+                                    (buffer-name (current-buffer))))
+                  (while (get-buffer-process (current-buffer))
+                    (kill-process (get-buffer-process (current-buffer))))
+                (error "Foo"))))
+  ;(buffer-disable-undo (current-buffer))
+  (setq buffer-read-only nil)
+  (erase-buffer)
+  (make-local-variable 'ftp-host)
+  (setq ftp-host host)
+  (make-local-variable 'ftp-file)
+  (setq ftp-file file)
+  (setq foo3 (current-buffer))
+  (setq buffer-read-only t)
+  (start-process "ftp" (current-buffer) "ftp" "-i" "-n" "-g"))
+
+
+(defun ftp-login (process host user password)
+  (message "FTP logging in as %s@%s..." user host)
+  (if (ftp-command process
+                   (format "open %s\nuser %s %s\n" host user password)
+                   "230.*\n"
+                   "\\(Connected to \\|220\\|331\\|Remote system type\\|Using.*mode\\|Remember to set\\).*\n")
+      t
+    (switch-to-buffer (process-buffer process))
+    (delete-process process)
+    (if (listp ftp-password-alist)
+        (setq ftp-password-alist (delq (assoc host ftp-password-alist)
+                                       ftp-password-alist)))
+    nil))
+
+(defun ftp-command (process command win ignore)
+  (process-send-string process command)
+  (let ((p 1))
+    (while (numberp p)
+      (cond ;((not (bolp)))
+            ((looking-at win)
+             (goto-char (point-max))
+             (setq p t))
+            ((looking-at "^ftp> \\|^\n")
+             (goto-char (match-end 0)))
+            ((looking-at ignore)
+             (forward-line 1))
+            ((not (search-forward "\n" nil t))
+             ;; the way asynchronous process-output fucks with (point)
+             ;;  is really really disgusting.
+             (setq p (point))
+             (condition-case ()
+                 (accept-process-output process)
+               (error nil))
+             (goto-char p))
+            (t
+             (setq p nil))))
+    p))
+
+
+(defun ftp-asynchronous-input-sentinel (process msg)
+  (ftp-sentinel process msg t t))
+(defun ftp-synchronous-input-sentinel (process msg)
+  (ftp-sentinel process msg nil t))
+(defun ftp-asynchronous-output-sentinel (process msg)
+  (ftp-sentinel process msg t nil))
+(defun ftp-synchronous-output-sentinel (process msg)
+  (ftp-sentinel process msg nil nil))
+
+(defun ftp-sentinel (process msg asynchronous input)
+  (cond ((null (buffer-name (process-buffer process)))
+         ;; deleted buffer
+         (set-process-buffer process nil))
+        ((and (eq (process-status process) 'exit)
+              (= (process-exit-status process) 0))
+         (save-excursion
+           (set-buffer (process-buffer process))
+           (let (msg
+                 (r (if input "[0-9]+ bytes received in [0-9]+\\.[0-9]+ seconds.*$" "[0-9]+ bytes sent in [0-9]+\\.[0-9]+ seconds.*$")))
+             (let ((buffer-read-only nil))
+               (goto-char (point-max))
+               (search-backward "226 ")
+               (if (looking-at r)
+                   (search-backward "226 "))
+               (let ((p (point)))
+                 (setq msg (concat (format "ftp %s %s:%s done"
+                                           (if input "read" "write")
+                                           ftp-host ftp-file)
+                                   (if (re-search-forward r nil t)
+                                       (concat ": " (buffer-substring
+                                                      (match-beginning 0)
+                                                      (match-end 0)))
+                                       "")))
+                 (delete-region p (point-max))
+                 (save-excursion
+                   (set-buffer (get-buffer-create "*ftp log*"))
+                   (let ((buffer-read-only nil))
+                     (insert msg ?\n)))))
+             ;; Note the preceding let must end here
+             ;; so it doesn't cross the (kill-buffer (current-buffer)).
+             (if (not input)
+                 (progn
+                   (condition-case ()
+                       (and (boundp 'ftp-temp-file-name)
+                            ftp-temp-file-name
+                            (delete-file ftp-temp-file-name))
+                     (error nil))
+                   ;; Kill the temporary buffer which the ftp process
+                   ;; puts its output in.
+                   (kill-buffer (current-buffer)))
+               ;; You don't want to look at this.
+               (let ((kludge (generate-new-buffer (format "%s:%s (ftp)"
+                                                          ftp-host ftp-file))))
+                 (setq kludge (prog1 (buffer-name kludge) (kill-buffer kludge)))
+                 (rename-buffer kludge)
+                 ;; ok, you can look again now.
+                 (set-buffer-modified-p nil)
+                 (ftp-setup-write-file-hooks)))
+             (if (and asynchronous
+                      ;(waiting-for-user-input-p)
+                      )
+                 (progn (message "%s" msg)
+                        (sleep-for 2))))))
+        ((memq (process-status process) '(exit signal))
+         (save-excursion
+           (set-buffer (process-buffer process))
+           (setq msg (format "Ftp died (buffer %s): %s"
+                             (buffer-name (current-buffer))
+                             msg))
+           (let ((buffer-read-only nil))
+             (goto-char (point-max))
+             (insert ?\n ?\n msg))
+           (delete-process proc)
+           (set-buffer (get-buffer-create "*ftp log*"))
+           (let ((buffer-read-only nil))
+             (goto-char (point-max))
+             (insert msg))
+           (if (waiting-for-user-input-p)
+               (error "%s" msg))))))
+
+(defun ftp-setup-write-file-hooks ()
+  (let ((hooks write-file-hooks))
+    (make-local-variable 'write-file-hooks)
+    (setq write-file-hooks (append write-file-hooks
+                                   '(ftp-write-file-hook))))
+  (make-local-variable 'revert-buffer-function)
+  (setq revert-buffer-function 'ftp-revert-buffer)
+  (setq default-directory "/tmp/")
+  (setq buffer-file-name (concat default-directory
+                                 (make-temp-name
+                                  (buffer-name (current-buffer)))))
+  (setq buffer-read-only nil))
+
+(defun ftp-write-file-hook ()
+  (let ((process (ftp-write-file ftp-host ftp-file)))
+    (set-process-sentinel process 'ftp-synchronous-output-sentinel)
+    (message "FTP writing %s:%s..." ftp-host ftp-file)
+    (while (eq (process-status process) 'run)
+      (condition-case ()
+          (accept-process-output process)
+        (error nil)))
+    (set-buffer-modified-p nil)
+    (message "FTP writing %s:%s...done" ftp-host ftp-file))
+  t)
+
+(defun ftp-revert-buffer (&rest ignore)
+  (let ((process (ftp-find-file ftp-host ftp-file)))
+    (set-process-sentinel process 'ftp-synchronous-input-sentinel)
+    (message "FTP reverting %s:%s" ftp-host ftp-file)
+    (while (eq (process-status process) 'run)
+      (condition-case ()
+          (accept-process-output process)
+        (error nil)))
+    (and (eq (process-status process) 'exit)
+         (= (process-exit-status process) 0)
+         (set-buffer-modified-p nil))
+    (message "Reverted")))