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