lisp/ftp.el

   1 ;;; ftp.el --- file input and output over Internet using FTP
   2
   3 ;; Author: Richard Mlynarik <mly@prep.ai.mit.edu>
   4 ;; Last-Modified: 05 May 1992
   5
   6 ;; Copyright (C) 1987 Free Software Foundation, Inc.
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Code:
  25
  26 ;; Prevent changes in major modes from altering these variables.
  27 (put 'ftp-temp-file-name 'permanent-local t)
  28 (put 'ftp-file 'permanent-local t)
  29 (put 'ftp-host 'permanent-local t)
  30
  31 ;; you can turn this off by doing
  32 ;;  (setq ftp-password-alist 'compulsory-urinalysis)
  33 (defvar ftp-password-alist () "Security sucks")
  34
  35 (defun read-ftp-user-password (host user new)
  36   (let (tem)
  37     (if (and (not new)
  38              (listp ftp-password-alist)
  39              (setq tem (cdr (assoc host ftp-password-alist)))
  40              (or (null user)
  41                  (string= user (car tem))))
  42         tem
  43       (or user
  44           (progn
  45             (setq tem (or (and (listp ftp-password-alist)
  46                                (car (cdr (assoc host ftp-password-alist))))
  47                           (user-login-name)))
  48             (setq user (read-string (format
  49                                       "User-name for %s (default \"%s\"): "
  50                                       host tem)))
  51             (if (equal user "") (setq user tem))))
  52       (setq tem (cons user
  53                       ;; If you want to use some non-echoing string-reader,
  54                       ;; feel free to write it yourself.  I don't care enough.
  55                       (read-string (format "Password for %s@%s: " user host)
  56                         (if (not (listp ftp-password-alist))
  57                             ""
  58                           (or (cdr (cdr (assoc host ftp-password-alist)))
  59                               (let ((l ftp-password-alist))
  60                                 (catch 'foo
  61                                   (while l
  62                                     (if (string= (car (cdr (car l))) user)
  63                                         (throw 'foo (cdr (cdr (car l))))
  64                                       (setq l (cdr l))))
  65                                   nil))
  66                               "")))))
  67       (message "")
  68       (if (and (listp ftp-password-alist)
  69                (not (string= (cdr tem) "")))
  70           (setq ftp-password-alist (cons (cons host tem)
  71                                          ftp-password-alist)))
  72       tem)))
  73
  74 (defun ftp-read-file-name (prompt)
  75   (let ((s ""))
  76     (while (not (string-match "\\`[ \t]*\\([^ \t:]+\\)[ \t]*:\\(.+\\)\\'" s))
  77       (setq s (read-string prompt s)))
  78     (list (substring s (match-beginning 1) (match-end 1))
  79           (substring s (match-beginning 2) (match-end 2)))))
  80
  81
  82 ;;;###autoload
  83 (defun ftp-find-file (host file &optional user password)
  84   "FTP to HOST to get FILE, logging in as USER with password PASSWORD.
  85 Interactively, HOST and FILE are specified by reading a string with
  86  a colon character separating the host from the filename.
  87 USER and PASSWORD are defaulted from the values used when
  88  last ftping from HOST (unless password-remembering is disabled).
  89  Supply a password of the symbol `t' to override this default
  90  (interactively, this is done by giving a prefix arg)"
  91   (interactive
  92         (append (ftp-read-file-name "FTP get host:file: ")
  93                 (list nil (not (null current-prefix-arg)))))
  94   (ftp-find-file-or-directory host file t user password))
  95
  96 ;;;###autoload
  97 (defun ftp-list-directory (host file &optional user password)
  98   "FTP to HOST to list DIRECTORY, logging in as USER with password PASSWORD.
  99 Interactively, HOST and FILE are specified by reading a string with
 100  a colon character separating the host from the filename.
 101 USER and PASSWORD are defaulted from the values used when
 102  last ftping from HOST (unless password-remembering is disabled).
 103  Supply a password of the symbol `t' to override this default
 104  (interactively, this is done by giving a prefix arg)"
 105   (interactive
 106         (append (ftp-read-file-name "FTP get host:directory: ")
 107                 (list nil (not (null current-prefix-arg)))))
 108   (ftp-find-file-or-directory host file nil user password))
 109
 110 (defun ftp-find-file-or-directory (host file filep &optional user password)
 111   "FTP to HOST to get FILE.  Third arg is t for file, nil for directory.
 112 Log in as USER with PASSWORD.  If USER is nil or PASSWORD is nil or t,
 113 we prompt for the user name and password."
 114   (or (and user password (not (eq password t)))
 115       (progn (setq user (read-ftp-user-password host user (eq password t))
 116                    password (cdr user)
 117                    user (car user))))
 118   (let ((buffer (get-buffer-create (format "*ftp%s %s:%s*"
 119                                            (if filep "" "-directory")
 120                                            host file))))
 121     (set-buffer buffer)
 122     (let ((process nil)
 123           (case-fold-search nil))
 124       (let ((win nil))
 125         (unwind-protect
 126             (progn
 127               (setq process (ftp-setup-buffer host file))
 128               (if (setq win (ftp-login process host user password))
 129                   (message "Logged in")
 130                 (error "Ftp login failed")))
 131           (or win (and process (delete-process process)))))
 132       (message "Opening %s %s:%s..." (if filep "file" "directory")
 133                host file)
 134       (if (ftp-command process
 135                        (format "%s \"%s\" -\nquit\n" (if filep "get" "dir")
 136                                file)
 137                        "\\(150\\|125\\).*\n"
 138                        "200.*\n")
 139           (progn (forward-line 1)
 140                  (let ((buffer-read-only nil))
 141                    (delete-region (point-min) (point)))
 142                  (message "Retrieving %s:%s in background.  Bye!" host file)
 143                  (set-process-sentinel process
 144                                        'ftp-asynchronous-input-sentinel)
 145                  process)
 146         (switch-to-buffer buffer)
 147         (let ((buffer-read-only nil))
 148           (insert-before-markers "<<<Ftp lost>>>"))
 149         (delete-process process)
 150         (error "Ftp %s:%s lost" host file)))))
 151
 152 \f
 153 ;;;###autoload
 154 (defun ftp-write-file (host file &optional user password)
 155   "FTP to HOST to write FILE, logging in as USER with password PASSWORD.
 156 Interactively, HOST and FILE are specified by reading a string with colon
 157 separating the host from the filename.
 158 USER and PASSWORD are defaulted from the values used when
 159  last ftping from HOST (unless `password-remembering' is disabled).
 160  Supply a password of the symbol `t' to override this default
 161  (interactively, this is done by giving a prefix arg)"
 162   (interactive
 163     (append (ftp-read-file-name "FTP write host:file: ")
 164             (list nil (not (null current-prefix-arg)))))
 165   (or (and user password (not (eq password t)))
 166       (progn (setq user (read-ftp-user-password host user (eq password t))
 167                    password (cdr user)
 168                    user (car user))))
 169   (let ((buffer (get-buffer-create (format "*ftp %s:%s*" host file)))
 170         (tmp (make-temp-name "/tmp/emacsftp")))
 171     (write-region (point-min) (point-max) tmp)
 172     (save-excursion
 173       (set-buffer buffer)
 174       (make-local-variable 'ftp-temp-file-name)
 175       (setq ftp-temp-file-name tmp)
 176       (let ((process (ftp-setup-buffer host file))
 177             (case-fold-search nil))
 178         (let ((win nil))
 179           (unwind-protect
 180               (if (setq win (ftp-login process host user password))
 181                   (message "Logged in")
 182                 (error "Ftp login lost"))
 183             (or win (delete-process process))))
 184         (message "Opening file %s:%s..." host file)
 185         (if (ftp-command process
 186                          (format "send \"%s\" \"%s\"\nquit\n" tmp file)
 187                          "\\(150\\|125\\).*\n"
 188                          "200.*\n")
 189             (progn (forward-line 1)
 190                    (setq foo1 (current-buffer))
 191                    (let ((buffer-read-only nil))
 192                      (delete-region (point-min) (point)))
 193                    (message "Saving %s:%s in background.  Bye!" host file)
 194                    (set-process-sentinel process
 195                                          'ftp-asynchronous-output-sentinel)
 196                    process)
 197           (switch-to-buffer buffer)
 198           (setq foo2 (current-buffer))
 199           (let ((buffer-read-only nil))
 200             (insert-before-markers "<<<Ftp lost>>>"))
 201           (delete-process process)
 202           (error "Ftp write %s:%s lost" host file))))))
 203
 204 \f
 205 (defun ftp-setup-buffer (host file)
 206   (fundamental-mode)
 207   (and (get-buffer-process (current-buffer))
 208        (progn (discard-input)
 209               (if (y-or-n-p (format "Kill process \"%s\" in %s? "
 210                                     (process-name (get-buffer-process
 211                                                     (current-buffer)))
 212                                     (buffer-name (current-buffer))))
 213                   (while (get-buffer-process (current-buffer))
 214                     (kill-process (get-buffer-process (current-buffer))))
 215                 (error "Foo"))))
 216   ;(buffer-disable-undo (current-buffer))
 217   (setq buffer-read-only nil)
 218   (erase-buffer)
 219   (make-local-variable 'ftp-host)
 220   (setq ftp-host host)
 221   (make-local-variable 'ftp-file)
 222   (setq ftp-file file)
 223   (setq foo3 (current-buffer))
 224   (setq buffer-read-only t)
 225   (start-process "ftp" (current-buffer) "ftp" "-i" "-n" "-g"))
 226
 227
 228 (defun ftp-login (process host user password)
 229   (message "FTP logging in as %s@%s..." user host)
 230   (if (ftp-command process
 231                    (format "open %s\nuser %s %s\n" host user password)
 232                    "230.*\n"
 233                    "\\(Connected to \\|220\\|331\\|Remote system type\\|Using.*mode\\|Remember to set\\).*\n")
 234       t
 235     (switch-to-buffer (process-buffer process))
 236     (delete-process process)
 237     (if (listp ftp-password-alist)
 238         (setq ftp-password-alist (delq (assoc host ftp-password-alist)
 239                                        ftp-password-alist)))
 240     nil))
 241
 242 (defun ftp-command (process command win ignore)
 243   (process-send-string process command)
 244   (let ((p 1))
 245     (while (numberp p)
 246       (cond ;((not (bolp)))
 247             ((looking-at "^[0-9]+-")
 248              (while (not (re-search-forward "^[0-9]+ " nil t))
 249                (save-excursion
 250                  (accept-process-output process)))
 251              (beginning-of-line))
 252             ((looking-at win)
 253              (goto-char (point-max))
 254              (setq p t))
 255             ((looking-at "^ftp> \\|^\n")
 256              (goto-char (match-end 0)))
 257             ((looking-at ignore)
 258              ;; Ignore status messages whose codes indicate no problem.
 259              (forward-line 1))
 260             ((looking-at "^[^0-9]")
 261              ;; Ignore any lines that don't have status codes.
 262              (forward-line 1))
 263             ((not (search-forward "\n" nil t))
 264              ;; the way asynchronous process-output works with (point)
 265              ;;  is really really disgusting.
 266              (setq p (point))
 267              (condition-case ()
 268                  (accept-process-output process)
 269                (error nil))
 270              (goto-char p))
 271             (t
 272              (setq p nil))))
 273     p))
 274
 275
 276 (defun ftp-asynchronous-input-sentinel (process msg)
 277   (ftp-sentinel process msg t t))
 278 (defun ftp-synchronous-input-sentinel (process msg)
 279   (ftp-sentinel process msg nil t))
 280 (defun ftp-asynchronous-output-sentinel (process msg)
 281   (ftp-sentinel process msg t nil))
 282 (defun ftp-synchronous-output-sentinel (process msg)
 283   (ftp-sentinel process msg nil nil))
 284
 285 (defun ftp-sentinel (process msg asynchronous input)
 286   (cond ((null (buffer-name (process-buffer process)))
 287          ;; deleted buffer
 288          (set-process-buffer process nil))
 289         ((and (eq (process-status process) 'exit)
 290               (= (process-exit-status process) 0))
 291          (save-excursion
 292            (set-buffer (process-buffer process))
 293            (let (msg
 294                  (r (if input "[0-9]+ bytes received in [0-9]+\\.[0-9]+ seconds.*$" "[0-9]+ bytes sent in [0-9]+\\.[0-9]+ seconds.*$")))
 295              (goto-char (point-max))
 296              (search-backward "226 ")
 297              (if (looking-at r)
 298                  (search-backward "226 "))
 299              (let ((p (point)))
 300                (setq msg (concat (format "ftp %s %s:%s done"
 301                                          (if input "read" "write")
 302                                          ftp-host ftp-file)
 303                                  (if (re-search-forward r nil t)
 304                                      (concat ": " (buffer-substring
 305                                                    (match-beginning 0)
 306                                                    (match-end 0)))
 307                                    "")))
 308                (delete-region p (point-max))
 309                (save-excursion
 310                  (set-buffer (get-buffer-create "*ftp log*"))
 311                  (let ((buffer-read-only nil))
 312                    (insert msg ?\n))))
 313              ;; Note the preceding let must end here
 314              ;; so it doesn't cross the (kill-buffer (current-buffer)).
 315              (if (not input)
 316                  (progn
 317                    (condition-case ()
 318                        (and (boundp 'ftp-temp-file-name)
 319                             ftp-temp-file-name
 320                             (delete-file ftp-temp-file-name))
 321                      (error nil))
 322                    ;; Kill the temporary buffer which the ftp process
 323                    ;; puts its output in.
 324                    (kill-buffer (current-buffer)))
 325                ;; You don't want to look at this.
 326                (let ((kludge (generate-new-buffer (format "%s:%s (ftp)"
 327                                                           ftp-host ftp-file))))
 328                  (setq kludge (prog1 (buffer-name kludge) (kill-buffer kludge)))
 329                  (rename-buffer kludge)
 330                  ;; ok, you can look again now.
 331                  (set-buffer-modified-p nil)
 332                  (ftp-setup-write-file-hooks)))
 333              (if (and asynchronous
 334                       ;(waiting-for-user-input-p)
 335                       )
 336                  (progn (message "%s" msg)
 337                         (sleep-for 2))))))
 338         ((memq (process-status process) '(exit signal))
 339          (save-excursion
 340            (set-buffer (process-buffer process))
 341            (setq msg (format "Ftp died (buffer %s): %s"
 342                              (buffer-name (current-buffer))
 343                              msg))
 344            (let ((buffer-read-only nil))
 345              (goto-char (point-max))
 346              (insert ?\n ?\n msg))
 347            (delete-process proc)
 348            (set-buffer (get-buffer-create "*ftp log*"))
 349            (let ((buffer-read-only nil))
 350              (goto-char (point-max))
 351              (insert msg))
 352            (if (waiting-for-user-input-p)
 353                (error "%s" msg))))))
 354
 355 (defun ftp-setup-write-file-hooks ()
 356   (let ((hooks write-file-hooks))
 357     (make-local-variable 'write-file-hooks)
 358     (setq write-file-hooks (append write-file-hooks
 359                                    '(ftp-write-file-hook))))
 360   (make-local-variable 'revert-buffer-function)
 361   (setq revert-buffer-function 'ftp-revert-buffer)
 362   (setq default-directory "/tmp/")
 363   (setq buffer-file-name (concat default-directory
 364                                  (make-temp-name
 365                                   (buffer-name (current-buffer)))))
 366   (setq buffer-read-only nil))
 367
 368 (defun ftp-write-file-hook ()
 369   (let ((process (ftp-write-file ftp-host ftp-file)))
 370     (set-process-sentinel process 'ftp-synchronous-output-sentinel)
 371     (message "FTP writing %s:%s..." ftp-host ftp-file)
 372     (while (eq (process-status process) 'run)
 373       (condition-case ()
 374           (accept-process-output process)
 375         (error nil)))
 376     (set-buffer-modified-p nil)
 377     (message "FTP writing %s:%s...done" ftp-host ftp-file))
 378   t)
 379
 380 (defun ftp-revert-buffer (&rest ignore)
 381   (let ((process (ftp-find-file ftp-host ftp-file)))
 382     (set-process-sentinel process 'ftp-synchronous-input-sentinel)
 383     (message "FTP reverting %s:%s" ftp-host ftp-file)
 384     (while (eq (process-status process) 'run)
 385       (condition-case ()
 386           (accept-process-output process)
 387         (error nil)))
 388     (and (eq (process-status process) 'exit)
 389          (= (process-exit-status process) 0)
 390          (set-buffer-modified-p nil))
 391     (message "Reverted")))
 392
 393 ;;; ftp.el ends here