Return to ftp.el CVS log

Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp

Annotation of 43BSDReno/contrib/emacs-18.55/lisp/ftp.el, revision 1.1

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

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.