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