Mercurial > emacs
annotate lisp/=ftp.el @ 37117:17b120bee51b
*** empty log message ***
author | Kenichi Handa <handa@m17n.org> |
---|---|
date | Sat, 31 Mar 2001 02:22:45 +0000 |
parents | 213978acbc1e |
children |
rev | line source |
---|---|
660
08eb386dd0f3
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
633
diff
changeset
|
1 ;;; ftp.el --- file input and output over Internet using FTP |
08eb386dd0f3
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
633
diff
changeset
|
2 |
845 | 3 ;; Copyright (C) 1987 Free Software Foundation, Inc. |
4 | |
793
6fb68a1460a6
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
660
diff
changeset
|
5 ;; Author: Richard Mlynarik <mly@prep.ai.mit.edu> |
64 | 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 | |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
793
diff
changeset
|
11 ;; the Free Software Foundation; either version 2, or (at your option) |
64 | 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 | |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
793
diff
changeset
|
23 ;;; Code: |
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
793
diff
changeset
|
24 |
64 | 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 | |
318 | 81 ;;;###autoload |
64 | 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 | |
318 | 95 ;;;###autoload |
64 | 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 | |
318 | 152 ;;;###autoload |
64 | 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 | |
318 | 158 last ftping from HOST (unless `password-remembering' is disabled). |
64 | 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) | |
318 | 186 "\\(150\\|125\\).*\n" |
64 | 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 | |
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))) | |
318 | 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)) | |
64 | 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) | |
318 | 257 ;; Ignore status messages whose codes indicate no problem. |
64 | 258 (forward-line 1)) |
633
379b94c9f29e
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
318
diff
changeset
|
259 ((looking-at "^[^0-9]") |
379b94c9f29e
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
318
diff
changeset
|
260 ;; Ignore any lines that don't have status codes. |
379b94c9f29e
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
318
diff
changeset
|
261 (forward-line 1)) |
64 | 262 ((not (search-forward "\n" nil t)) |
81
ef6cee0af549
*** empty log message ***
Robert J. Chassell <bob@rattlesnake.com>
parents:
64
diff
changeset
|
263 ;; the way asynchronous process-output works with (point) |
64 | 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.*$"))) | |
318 | 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)))) | |
64 | 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"))) | |
660
08eb386dd0f3
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
633
diff
changeset
|
391 |
08eb386dd0f3
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
633
diff
changeset
|
392 ;;; ftp.el ends here |