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