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