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