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