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