Line data Source code
1 : ;;; ange-ftp.el --- transparent FTP support for GNU Emacs
2 :
3 : ;; Copyright (C) 1989-1996, 1998, 2000-2017 Free Software Foundation,
4 : ;; Inc.
5 :
6 : ;; Author: Andy Norman (ange@hplb.hpl.hp.com)
7 : ;; Maintainer: emacs-devel@gnu.org
8 : ;; Keywords: comm
9 :
10 : ;; This file is part of GNU Emacs.
11 :
12 : ;; GNU Emacs is free software: you can redistribute it and/or modify
13 : ;; it under the terms of the GNU General Public License as published by
14 : ;; the Free Software Foundation, either version 3 of the License, or
15 : ;; (at your option) any later version.
16 :
17 : ;; GNU Emacs is distributed in the hope that it will be useful,
18 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 : ;; GNU General Public License for more details.
21 :
22 : ;; You should have received a copy of the GNU General Public License
23 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 :
25 : ;;; Commentary:
26 :
27 : ;; This package attempts to make accessing files and directories using FTP
28 : ;; from within GNU Emacs as simple and transparent as possible. A subset of
29 : ;; the common file-handling routines are extended to interact with FTP.
30 :
31 : ;; Usage:
32 : ;;
33 : ;; Some of the common GNU Emacs file-handling operations have been made
34 : ;; FTP-smart. If one of these routines is given a filename that matches
35 : ;; '/user@host:name' then it will spawn an FTP process connecting to machine
36 : ;; 'host' as account 'user' and perform its operation on the file 'name'.
37 : ;;
38 : ;; For example: if find-file is given a filename of:
39 : ;;
40 : ;; /ange@anorman:/tmp/notes
41 : ;;
42 : ;; then ange-ftp spawns an FTP process, connect to the host 'anorman' as
43 : ;; user 'ange', get the file '/tmp/notes' and pop up a buffer containing the
44 : ;; contents of that file as if it were on the local filesystem. If ange-ftp
45 : ;; needs a password to connect then it reads one in the echo area.
46 :
47 : ;; Extended filename syntax:
48 : ;;
49 : ;; The default extended filename syntax is '/user@host:name', where the
50 : ;; 'user@' part may be omitted. This syntax can be customized to a certain
51 : ;; extent by changing ange-ftp-name-format. There are limitations.
52 : ;; The `host' part has an optional suffix `#port' which may be used to
53 : ;; specify a non-default port number for the connection.
54 : ;;
55 : ;; If the user part is omitted then ange-ftp generates a default user
56 : ;; instead whose value depends on the variable ange-ftp-default-user.
57 :
58 : ;; Passwords:
59 : ;;
60 : ;; A password is required for each host/user pair. Ange-ftp reads passwords
61 : ;; as needed. You can also specify a password with ange-ftp-set-passwd, or
62 : ;; in a *valid* ~/.netrc file.
63 :
64 : ;; Passwords for user "anonymous":
65 : ;;
66 : ;; Passwords for the user "anonymous" (or "ftp") are handled
67 : ;; specially. The variable `ange-ftp-generate-anonymous-password'
68 : ;; controls what happens: if the value of this variable is a string,
69 : ;; then this is used as the password; if non-nil (the default), then
70 : ;; the value of `user-mail-address' is used; if nil then the user
71 : ;; is prompted for a password as normal.
72 :
73 : ;; "Dumb" UNIX hosts:
74 : ;;
75 : ;; The FTP servers on some UNIX machines have problems if the 'ls' command is
76 : ;; used.
77 : ;;
78 : ;; The routine ange-ftp-add-dumb-unix-host can be called to tell ange-ftp to
79 : ;; limit itself to the DIR command and not 'ls' for a given UNIX host. Note
80 : ;; that this change will take effect for the current GNU Emacs session only.
81 : ;; See below for a discussion of non-UNIX hosts. If a large number of
82 : ;; machines with similar hostnames have this problem then it is easier to set
83 : ;; the value of ange-ftp-dumb-unix-host-regexp in your init file. ange-ftp
84 : ;; is unable to automatically recognize dumb unix hosts.
85 :
86 : ;; File name completion:
87 : ;;
88 : ;; Full file-name completion is supported on UNIX, VMS, CMS, and MTS hosts.
89 : ;; To do filename completion, ange-ftp needs a listing from the remote host.
90 : ;; Therefore, for very slow connections, it might not save any time.
91 :
92 : ;; FTP processes:
93 : ;;
94 : ;; When ange-ftp starts up an FTP process, it leaves it running for speed
95 : ;; purposes. Some FTP servers will close the connection after a period of
96 : ;; time, but ange-ftp should be able to quietly reconnect the next time that
97 : ;; the process is needed.
98 : ;;
99 : ;; Killing the "*ftp user@host*" buffer also kills the ftp process.
100 : ;; This should not cause ange-ftp any grief.
101 :
102 : ;; Binary file transfers:
103 : ;;
104 : ;; By default ange-ftp transfers files in ASCII mode. If a file being
105 : ;; transferred matches the value of ange-ftp-binary-file-name-regexp then
106 : ;; binary mode is used for that transfer.
107 :
108 : ;; Account passwords:
109 : ;;
110 : ;; Some FTP servers require an additional password which is sent by the
111 : ;; ACCOUNT command. ange-ftp partially supports this by allowing the user to
112 : ;; specify an account password by either calling ange-ftp-set-account, or by
113 : ;; specifying an account token in the .netrc file. If the account password
114 : ;; is set by either of these methods then ange-ftp will issue an ACCOUNT
115 : ;; command upon starting the FTP process.
116 :
117 : ;; Preloading:
118 : ;;
119 : ;; ange-ftp can be preloaded, but must be put in the site-init.el file and
120 : ;; not the site-load.el file in order for the documentation strings for the
121 : ;; functions being overloaded to be available.
122 :
123 : ;; Status reports:
124 : ;;
125 : ;; Most ange-ftp commands that talk to the FTP process output a status
126 : ;; message on what they are doing. In addition, ange-ftp can take advantage
127 : ;; of the FTP client's HASH command to display the status of transferring
128 : ;; files and listing directories. See the documentation for the variables
129 : ;; ange-ftp-{ascii,binary}-hash-mark-size, ange-ftp-send-hash and
130 : ;; ange-ftp-process-verbose for more details.
131 :
132 : ;; Gateways:
133 : ;;
134 : ;; Sometimes it is necessary for the FTP process to be run on a different
135 : ;; machine than the machine running GNU Emacs. This can happen when the
136 : ;; local machine has restrictions on what hosts it can access.
137 : ;;
138 : ;; ange-ftp has support for running the ftp process on a different (gateway)
139 : ;; machine. The way it works is as follows:
140 : ;;
141 : ;; 1) Set the variable 'ange-ftp-gateway-host' to the name of a machine
142 : ;; that doesn't have the access restrictions.
143 : ;;
144 : ;; 2) Set the variable 'ange-ftp-local-host-regexp' to a regular expression
145 : ;; that matches hosts that can be contacted from running a local ftp
146 : ;; process, but fails to match hosts that can't be accessed locally. For
147 : ;; example:
148 : ;;
149 : ;; "\\.hp\\.com$\\|^[^.]*$"
150 : ;;
151 : ;; will match all hosts that are in the .hp.com domain, or don't have an
152 : ;; explicit domain in their name, but will fail to match hosts with
153 : ;; explicit domains or that are specified by their ip address.
154 : ;;
155 : ;; 3) Using NFS and symlinks, make sure that there is a shared directory with
156 : ;; the *same* name between the local machine and the gateway machine.
157 : ;; This directory is necessary for temporary files created by ange-ftp.
158 : ;;
159 : ;; 4) Set the variable 'ange-ftp-gateway-tmp-name-template' to the name of
160 : ;; this directory plus an identifying filename prefix. For example:
161 : ;;
162 : ;; "/nfs/hplose/ange/ange-ftp"
163 : ;;
164 : ;; where /nfs/hplose/ange is a directory that is shared between the
165 : ;; gateway machine and the local machine.
166 : ;;
167 : ;; The simplest way of getting a ftp process running on the gateway machine
168 : ;; is if you can spawn a remote shell using either 'rsh' or 'remsh'. If you
169 : ;; can't do this for some reason such as security then points 7 onwards will
170 : ;; discuss an alternative approach.
171 : ;;
172 : ;; 5) Set the variable ange-ftp-gateway-program to the name of the remote
173 : ;; shell process such as 'remsh' or 'rsh' if the default isn't correct.
174 : ;;
175 : ;; 6) Set the variable ange-ftp-gateway-program-interactive to nil if it
176 : ;; isn't already. This tells ange-ftp that you are using a remote shell
177 : ;; rather than logging in using telnet or rlogin.
178 : ;;
179 : ;; That should be all you need to allow ange-ftp to spawn a ftp process on
180 : ;; the gateway machine. If you have to use telnet or rlogin to get to the
181 : ;; gateway machine then follow the instructions below.
182 : ;;
183 : ;; 7) Set the variable ange-ftp-gateway-program to the name of the program
184 : ;; that lets you log onto the gateway machine. This may be something like
185 : ;; telnet or rlogin.
186 : ;;
187 : ;; 8) Set the variable ange-ftp-gateway-prompt-pattern to a regular
188 : ;; expression that matches the prompt you get when you login to the
189 : ;; gateway machine. Be very specific here; this regexp must not match
190 : ;; *anything* in your login banner except this prompt.
191 : ;; shell-prompt-pattern is far too general as it appears to match some
192 : ;; login banners from Sun machines. For example:
193 : ;;
194 : ;; "^$*$ *"
195 : ;;
196 : ;; 9) Set the variable ange-ftp-gateway-program-interactive to t to let
197 : ;; ange-ftp know that it has to "hand-hold" the login to the gateway
198 : ;; machine.
199 : ;;
200 : ;; 10) Set the variable ange-ftp-gateway-setup-term-command to a UNIX command
201 : ;; that will put the pty connected to the gateway machine into a
202 : ;; no-echoing mode, and will strip off carriage-returns from output from
203 : ;; the gateway machine. For example:
204 : ;;
205 : ;; "stty -onlcr -echo"
206 : ;;
207 : ;; will work on HP-UX machines, whereas:
208 : ;;
209 : ;; "stty -echo nl"
210 : ;;
211 : ;; appears to work for some Sun machines.
212 : ;;
213 : ;; That's all there is to it.
214 :
215 : ;; Smart gateways:
216 : ;;
217 : ;; If you have a "smart" ftp program that allows you to issue commands like
218 : ;; "USER foo@bar" which do nice proxy things, then look at the variables
219 : ;; ange-ftp-smart-gateway and ange-ftp-smart-gateway-port.
220 : ;;
221 : ;; Otherwise, if there is an alternate ftp program that implements proxy in
222 : ;; a transparent way (i.e. w/o specifying the proxy host), that will
223 : ;; connect you directly to the desired destination host:
224 : ;; Set ange-ftp-gateway-ftp-program-name to that program's name.
225 : ;; Set ange-ftp-local-host-regexp to a value as stated earlier on.
226 : ;; Leave ange-ftp-gateway-host set to nil.
227 : ;; Set ange-ftp-smart-gateway to t.
228 :
229 : ;; Tips for using ange-ftp:
230 : ;;
231 : ;; 1. For dired to work on a host which marks symlinks with a trailing @ in
232 : ;; an ls -alF listing, you need to (setq dired-ls-F-marks-symlinks t).
233 : ;; Most UNIX systems do not do this, but ULTRIX does. If you think that
234 : ;; there is a chance you might connect to an ULTRIX machine (such as
235 : ;; prep.ai.mit.edu), then set this variable accordingly. This will have
236 : ;; the side effect that dired will have problems with symlinks whose names
237 : ;; end in an @. If you get yourself into this situation then editing
238 : ;; dired's ls-switches to remove "F", will temporarily fix things.
239 : ;;
240 : ;; 2. If you know that you are connecting to a certain non-UNIX machine
241 : ;; frequently, and ange-ftp seems to be unable to guess its host-type,
242 : ;; then setting the appropriate host-type regexp
243 : ;; (ange-ftp-vms-host-regexp, ange-ftp-mts-host-regexp, or
244 : ;; ange-ftp-cms-host-regexp) accordingly should help. Also, please report
245 : ;; ange-ftp's inability to recognize the host-type as a bug.
246 : ;;
247 : ;; 3. For slow connections, you might get "listing unreadable" error
248 : ;; messages, or get an empty buffer for a file that you know has something
249 : ;; in it. The solution is to increase the value of ange-ftp-retry-time.
250 : ;; Its default value is 5 which is plenty for reasonable connections.
251 : ;; However, for some transatlantic connections I set this to 20.
252 : ;;
253 : ;; 4. Beware of compressing files on non-UNIX hosts. Ange-ftp will do it by
254 : ;; copying the file to the local machine, compressing it there, and then
255 : ;; sending it back. Binary file transfers between machines of different
256 : ;; architectures can be a risky business. Test things out first on some
257 : ;; test files. See "Bugs" below. Also, note that ange-ftp copies files by
258 : ;; moving them through the local machine. Again, be careful when doing
259 : ;; this with binary files on non-Unix machines.
260 : ;;
261 : ;; 5. Beware that dired over ftp will use your setting of dired-no-confirm
262 : ;; (list of dired commands for which confirmation is not asked). You
263 : ;; might want to reconsider your setting of this variable, because you
264 : ;; might want confirmation for more commands on remote direds than on
265 : ;; local direds. For example, I strongly recommend that you not include
266 : ;; compress and uncompress in this list. If there is enough demand it
267 : ;; might be a good idea to have an alist ange-ftp-dired-no-confirm of
268 : ;; pairs ( TYPE . LIST ), where TYPE is an operating system type and LIST
269 : ;; is a list of commands for which confirmation would be suppressed. Then
270 : ;; remote dired listings would take their (buffer-local) value of
271 : ;; dired-no-confirm from this alist. Who votes for this?
272 :
273 : ;; ---------------------------------------------------------------------
274 : ;; Non-UNIX support:
275 : ;; ---------------------------------------------------------------------
276 :
277 : ;; VMS support:
278 : ;;
279 : ;; Ange-ftp has full support for VMS hosts. It should be able to
280 : ;; automatically recognize any VMS machine. However, if it fails to do
281 : ;; this, you can use the command ange-ftp-add-vms-host. Also, you can
282 : ;; set the variable ange-ftp-vms-host-regexp in your init file. We
283 : ;; would be grateful if you would report any failures to automatically
284 : ;; recognize a VMS host as a bug.
285 : ;;
286 : ;; Filename Syntax:
287 : ;;
288 : ;; For ease of *implementation*, the user enters the VMS filename syntax in a
289 : ;; UNIX-y way. For example:
290 : ;; PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1
291 : ;; would be entered as:
292 : ;; /PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1
293 : ;; i.e. to log in as anonymous on ymir.claremont.edu and grab the file:
294 : ;; [.CSV.POLICY]RULES.MEM
295 : ;; you would type:
296 : ;; C-x C-f /anonymous@ymir.claremont.edu:CSV/POLICY/RULES.MEM
297 : ;;
298 : ;; A valid VMS filename is of the form: FILE.TYPE;##
299 : ;; where FILE can be up to 39 characters
300 : ;; TYPE can be up to 39 characters
301 : ;; ## is a version number (an integer between 1 and 32,767)
302 : ;; Valid characters in FILE and TYPE are A-Z 0-9 _ - $
303 : ;; $ cannot begin a filename, and - cannot be used as the first or last
304 : ;; character.
305 : ;;
306 : ;; Tips:
307 : ;; 1. Although VMS is not case sensitive, EMACS running under UNIX is.
308 : ;; Therefore, to access a VMS file, you must enter the filename with upper
309 : ;; case letters.
310 : ;; 2. To access the latest version of file under VMS, you use the filename
311 : ;; without the ";" and version number. You should always edit the latest
312 : ;; version of a file. If you want to edit an earlier version, copy it to a
313 : ;; new file first. This has nothing to do with ange-ftp, but is simply
314 : ;; good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is
315 : ;; latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you
316 : ;; inadvertently do C-x C-f /ymir.claremont.edu:FILE.TXT;3, you will find
317 : ;; that VMS will not allow you to save the file because it will refuse to
318 : ;; overwrite FILE.TXT;3, but instead will want to create FILE.TXT;4, and
319 : ;; attach the buffer to this file. To get out of this situation, M-x
320 : ;; write-file /ymir.claremont.edu:FILE.TXT will attach the buffer to
321 : ;; latest version of the file. For this reason, in dired "f"
322 : ;; (dired-find-file), always loads the file sans version, whereas "v",
323 : ;; (dired-view-file), always loads the explicit version number. The
324 : ;; reasoning being that it reasonable to view old versions of a file, but
325 : ;; not to edit them.
326 : ;; 3. EMACS has a feature in which it does environment variable substitution
327 : ;; in filenames. Therefore, to enter a $ in a filename, you must quote it
328 : ;; by typing $$.
329 :
330 : ;; MTS support:
331 : ;;
332 : ;; Ange-ftp has full support for hosts running
333 : ;; the Michigan terminal system. It should be able to automatically
334 : ;; recognize any MTS machine. However, if it fails to do this, you can use
335 : ;; the command ange-ftp-add-mts-host. As well, you can set the variable
336 : ;; ange-ftp-mts-host-regexp in your init file. We would be grateful if you
337 : ;; would report any failures to automatically recognize a MTS host as a bug.
338 : ;;
339 : ;; Filename syntax:
340 : ;;
341 : ;; MTS filenames are entered in a UNIX-y way. For example, if your account
342 : ;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be
343 : ;; entered as
344 : ;; /YYYY@mtsg.ubc.ca:/XXXX:/FILE
345 : ;; In other words, MTS accounts are treated as UNIX directories. Of course,
346 : ;; to access a file in another account, you must have access permission for
347 : ;; it. If FILE were in your own account, then you could enter it in a
348 : ;; relative name fashion as
349 : ;; /YYYY@mtsg.ubc.ca:FILE
350 : ;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the
351 : ;; filename does not contain a TYPE (i.e. it can have as many "."'s as you
352 : ;; like.) MTS filenames are always in upper case, and hence be sure to enter
353 : ;; them as such! MTS is not case sensitive, but an EMACS running under UNIX
354 : ;; is.
355 :
356 : ;; CMS support:
357 : ;;
358 : ;; Ange-ftp has full support for hosts running
359 : ;; CMS. It should be able to automatically recognize any CMS machine.
360 : ;; However, if it fails to do this, you can use the command
361 : ;; ange-ftp-add-cms-host. As well, you can set the variable
362 : ;; ange-ftp-cms-host-regexp in your init file. We would be grateful if you
363 : ;; would report any failures to automatically recognize a CMS host as a bug.
364 : ;;
365 : ;; Filename syntax:
366 : ;;
367 : ;; CMS filenames are entered in a UNIX-y way. In other words, minidisks are
368 : ;; treated as UNIX directories. For example to access the file READ.ME in
369 : ;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter
370 : ;; /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME
371 : ;; If *.301 is the default minidisk for this account, you could access
372 : ;; FOO.BAR on this minidisk as
373 : ;; /anonymous@cuvmb.cc.columbia.edu:FOO.BAR
374 : ;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be
375 : ;; up to 8 characters. Again, beware that CMS filenames are always upper
376 : ;; case, and hence must be entered as such.
377 : ;;
378 : ;; Tips:
379 : ;; 1. CMS machines, with the exception of anonymous accounts, nearly always
380 : ;; need an account password. To have ange-ftp send an account password,
381 : ;; you can either include it in your .netrc file, or use
382 : ;; ange-ftp-set-account.
383 : ;; 2. Ange-ftp cannot send "write passwords" for a minidisk. Hopefully, we
384 : ;; can fix this.
385 : ;;
386 : ;; BS2000 support:
387 : ;;
388 : ;; Ange-ftp has full support for BS2000 hosts. It should be able to
389 : ;; automatically recognize any BS2000 machine. However, if it fails to
390 : ;; do this, you can use the command ange-ftp-add-bs2000-host. As well,
391 : ;; you can set the variable ange-ftp-bs2000-host-regexp in your .emacs
392 : ;; file. We would be grateful if you would report any failures to auto-
393 : ;; matically recognize a BS2000 host as a bug.
394 : ;;
395 : ;; If you want to access the POSIX subsystem on BS2000 you MUST use
396 : ;; command ange-ftp-add-bs2000-posix-host for that particular
397 : ;; hostname. ange-ftp can't decide if you want to access the native
398 : ;; filesystem or the POSIX filesystem, so it accesses the native
399 : ;; filesystem by default. And if you have an ASCII filesystem in
400 : ;; your BS2000 POSIX subsystem you must use
401 : ;; ange-ftp-binary-file-name-regexp to access its files.
402 : ;;
403 : ;; Filename Syntax:
404 : ;;
405 : ;; For ease of *implementation*, the user enters the BS2000 filename
406 : ;; syntax in a UNIX-y way. For example:
407 : ;; :PUB:$PUBLIC.ANONYMOUS.SDSCPUB.NEXT.README.TXT
408 : ;; would be entered as:
409 : ;; /:PUB:/$$PUBLIC/ANONYMOUS.SDSCPUB.NEXT.README.TXT
410 : ;; You don't have to type pubset and account, if they have default values,
411 : ;; i.e. to log in as anonymous on bs2000.anywhere.com and grab the file
412 : ;; IMPORTANT.TEXT.ON.BS2000 on the default pubset X on userid PUBLIC
413 : ;; (there are only 8 characters in a valid username), you could type:
414 : ;; C-x C-f /public@bs2000.anywhere.com:/IMPORTANT.TEXT.ON.BS2000
415 : ;; or
416 : ;; C-x C-f /anonym@bs2000.anywhere.com:/:X:/$$PUBLIC/IMPORTANT.TEXT.ON.BS2000
417 : ;;
418 : ;; If X is not your default pubset, you could add it as 'subdirectory' (BS2000
419 : ;; has a flat architecture) with the command
420 : ;; (setq ange-ftp-bs2000-additional-pubsets '(":X:"))
421 : ;; and then you could type:
422 : ;; C-x C-f /anonym@bs2000.anywhere.com:/:X:/IMPORTANT.TEXT.ON.BS2000
423 : ;;
424 : ;; Valid characters in an BS2000 filename are A-Z 0-9 $ # @ . -
425 : ;; If the first character in a filename is # or @, this is replaced with
426 : ;; ange-ftp-bs2000-special-prefix because names starting with # or @
427 : ;; are reserved for temporary files.
428 : ;; This is especially important for auto-save files.
429 : ;; Valid file generations are ending with ([+|-|*]0-9...) .
430 : ;; File generations are not supported yet!
431 : ;; A filename must at least contain one character (A-Z) and cannot be longer
432 : ;; than 41 characters.
433 : ;;
434 : ;; Tips:
435 : ;; 1. Although BS2000 is not case sensitive, EMACS running under UNIX is.
436 : ;; Therefore, to access a BS2000 file, you must enter the filename with
437 : ;; upper case letters.
438 : ;; 2. EMACS has a feature in which it does environment variable substitution
439 : ;; in filenames. Therefore, to enter a $ in a filename, you must quote it
440 : ;; by typing $$.
441 : ;; 3. BS2000 machines, with the exception of anonymous accounts, nearly
442 : ;; always need an account password. To have ange-ftp send an account
443 : ;; password, you can either include it in your .netrc file, or use
444 : ;; ange-ftp-set-account.
445 : ;;
446 : ;; ------------------------------------------------------------------
447 : ;; Bugs:
448 : ;; ------------------------------------------------------------------
449 : ;;
450 : ;; 1. Umask problems:
451 : ;; Be warned that files created by using ange-ftp will take account of the
452 : ;; umask of the ftp daemon process rather than the umask of the creating
453 : ;; user. This is particularly important when logging in as the root user.
454 : ;; The way that I tighten up the ftp daemon's umask under HP-UX is to make
455 : ;; sure that the umask is changed to 027 before I spawn /etc/inetd. I
456 : ;; suspect that there is something similar on other systems.
457 : ;;
458 : ;; 2. Some combinations of FTP clients and servers break and get out of sync
459 : ;; when asked to list a non-existent directory. Some of the ai.mit.edu
460 : ;; machines cause this problem for some FTP clients. Using
461 : ;; ange-ftp-kill-ftp-process can restart the ftp process, which
462 : ;; should get things back in sync.
463 : ;;
464 : ;; 3. Ange-ftp does not check to make sure that when creating a new file,
465 : ;; you provide a valid filename for the remote operating system.
466 : ;; If you do not, then the remote FTP server will most likely
467 : ;; translate your filename in some way. This may cause ange-ftp to
468 : ;; get confused about what exactly is the name of the file. The
469 : ;; most common causes of this are using lower case filenames on systems
470 : ;; which support only upper case, and using filenames which are too
471 : ;; long.
472 : ;;
473 : ;; 4. Null (blank) passwords confuse both ange-ftp and some FTP daemons.
474 : ;;
475 : ;; 5. Ange-ftp likes to use pty's to talk to its FTP processes. If GNU Emacs
476 : ;; for some reason creates a FTP process that only talks via pipes then
477 : ;; ange-ftp won't be getting the information it requires at the time that
478 : ;; it wants it since pipes flush at different times to pty's. One
479 : ;; disgusting way around this problem is to talk to the FTP process via
480 : ;; rlogin which does the 'right' things with pty's.
481 : ;;
482 : ;; 6. For CMS support, we send too many cd's. Since cd's are cheap, I haven't
483 : ;; worried about this too much. Eventually, we should have some caching
484 : ;; of the current minidisk.
485 : ;;
486 : ;; 7. Some CMS machines do not assign a default minidisk when you ftp them as
487 : ;; anonymous. It is then necessary to guess a valid minidisk name, and cd
488 : ;; to it. This is (understandably) beyond ange-ftp.
489 : ;;
490 : ;; 8. Remote to remote copying of files on non-Unix machines can be risky.
491 : ;; Depending on the variable ange-ftp-binary-file-name-regexp, ange-ftp
492 : ;; will use binary mode for the copy. Between systems of different
493 : ;; architecture, this still may not be enough to guarantee the integrity
494 : ;; of binary files. Binary file transfers from VMS machines are
495 : ;; particularly problematical. Should ange-ftp-binary-file-name-regexp be
496 : ;; an alist of OS type, regexp pairs?
497 : ;;
498 : ;; 9. The code to do compression of files over ftp is not as careful as it
499 : ;; should be. It deletes the old remote version of the file, before
500 : ;; actually checking if the local to remote transfer of the compressed
501 : ;; file succeeds. Of course to delete the original version of the file
502 : ;; after transferring the compressed version back is also dangerous,
503 : ;; because some OS's have severe restrictions on the length of filenames,
504 : ;; and when the compressed version is copied back the "-Z" or ".Z" may be
505 : ;; truncated. Then, ange-ftp would delete the only remaining version of
506 : ;; the file. Maybe ange-ftp should make backups when it compresses files
507 : ;; (of course, the backup "~" could also be truncated off, sigh...).
508 : ;; Suggestions?
509 : ;;
510 : ;; 10. If a dir listing is attempted for an empty directory on (at least
511 : ;; some) VMS hosts, an ftp error is given. This is really an ftp bug, and
512 : ;; I don't know how to get ange-ftp work to around it.
513 : ;;
514 : ;; 11. Bombs on filenames that start with a space. Deals well with filenames
515 : ;; containing spaces, but beware that the remote ftpd may not like them
516 : ;; much.
517 : ;;
518 : ;; 12. The dired support for non-Unix-like systems does not currently work.
519 : ;; It needs to be reimplemented by modifying the parse-...-listing
520 : ;; functions to convert the directory listing to ls -l format.
521 : ;;
522 : ;; 13. The famous @ bug. As mentioned above in TIPS, ULTRIX marks symlinks
523 : ;; with a trailing @ in a ls -alF listing. In order to account for this
524 : ;; ange-ftp looks to chop trailing @'s off of symlink names when it is
525 : ;; parsing a listing with the F switch. This will cause ange-ftp to
526 : ;; incorrectly get the name of a symlink on a non-ULTRIX host if its name
527 : ;; ends in an @. ange-ftp will correct itself if you take F out of the
528 : ;; dired ls switches (C-u s will allow you to edit the switches). The
529 : ;; dired buffer will be automatically reverted, which will allow ange-ftp
530 : ;; to fix its files hashtable. A cookie to anyone who can think of a
531 : ;; fast, sure-fire way to recognize ULTRIX over ftp.
532 :
533 : ;; If you find any bugs or problems with this package, PLEASE report a
534 : ;; bug to the Emacs maintainers via M-x report-emacs-bug.
535 :
536 : ;; -----------------------------------------------------------
537 : ;; Technical information on this package:
538 : ;; -----------------------------------------------------------
539 :
540 : ;; ange-ftp works by putting a handler on file-name-handler-alist
541 : ;; which is called by many primitives, and a few non-primitives,
542 : ;; whenever they see a file name of the appropriate sort.
543 :
544 : ;; Checklist for adding non-UNIX support for TYPE
545 : ;;
546 : ;; The following functions may need TYPE versions:
547 : ;; (not all functions will be needed for every OS)
548 : ;;
549 : ;; ange-ftp-fix-name-for-TYPE
550 : ;; ange-ftp-fix-dir-name-for-TYPE
551 : ;; ange-ftp-TYPE-host
552 : ;; ange-ftp-TYPE-add-host
553 : ;; ange-ftp-parse-TYPE-listing
554 : ;; ange-ftp-TYPE-delete-file-entry
555 : ;; ange-ftp-TYPE-add-file-entry
556 : ;; ange-ftp-TYPE-file-name-as-directory
557 : ;; ange-ftp-TYPE-make-compressed-filename
558 : ;; ange-ftp-TYPE-file-name-sans-versions
559 : ;;
560 : ;; Variables:
561 : ;;
562 : ;; ange-ftp-TYPE-host-regexp
563 : ;; May need to add TYPE to ange-ftp-dumb-host-types
564 : ;;
565 : ;; Check the following functions for OS dependent coding:
566 : ;;
567 : ;; ange-ftp-host-type
568 : ;; ange-ftp-guess-host-type
569 : ;; ange-ftp-allow-child-lookup
570 :
571 : ;; Host type conventions:
572 : ;;
573 : ;; The function ange-ftp-host-type and the variable ange-ftp-dired-host-type
574 : ;; (mostly) follow the following conventions for remote host types. At
575 : ;; least, I think that future code should try to follow these conventions,
576 : ;; and the current code should eventually be made compliant.
577 : ;;
578 : ;; nil = local host type, whatever that is (probably unix).
579 : ;; Think nil as in "not a remote host". This value is used by
580 : ;; ange-ftp-dired-host-type for local buffers.
581 : ;;
582 : ;; t = a remote host of unknown type. Think t as in true, it's remote.
583 : ;; Currently, `unix' is used as the default remote host type.
584 : ;; Maybe we should use t.
585 : ;;
586 : ;; TYPE = a remote host of TYPE type.
587 : ;;
588 : ;; TYPE:LIST = a remote host of TYPE type, using a specialized ftp listing
589 : ;; program called list. This is currently only used for Unix
590 : ;; dl (descriptive listings), when ange-ftp-dired-host-type
591 : ;; is set to `unix:dl'.
592 :
593 : ;; Bug report codes:
594 : ;;
595 : ;; Because of their naive faith in this code, there are certain situations
596 : ;; which the writers of this program believe could never happen. However,
597 : ;; being realists they have put calls to `error' in the program at these
598 : ;; points. These errors provide a code, which is an integer, greater than 1.
599 : ;; To aid debugging. the error codes, and the functions in which they reside
600 : ;; are listed below.
601 : ;;
602 : ;; 1: See ange-ftp-ls
603 : ;;
604 :
605 : ;; -----------------------------------------------------------
606 : ;; Hall of fame:
607 : ;; -----------------------------------------------------------
608 : ;;
609 : ;; Thanks to Roland McGrath for improving the filename syntax handling,
610 : ;; for suggesting many enhancements and for numerous cleanups to the code.
611 : ;;
612 : ;; Thanks to Jamie Zawinski for bugfixes and for ideas such as gateways.
613 : ;;
614 : ;; Thanks to Ken Laprade for improved .netrc parsing, password reading, and
615 : ;; dired / shell auto-loading.
616 : ;;
617 : ;; Thanks to Sebastian Kremer for dired support and for many ideas and
618 : ;; bugfixes.
619 : ;;
620 : ;; Thanks to Joe Wells for bugfixes, the original non-UNIX system support,
621 : ;; VOS support, and hostname completion.
622 : ;;
623 : ;; Thanks to Nakagawa Takayuki for many good ideas, filename-completion, help
624 : ;; with file-name expansion, efficiency worries, stylistic concerns and many
625 : ;; bugfixes.
626 : ;;
627 : ;; Thanks to Sandy Rutherford who re-wrote most of ange-ftp to support VMS,
628 : ;; MTS, CMS and UNIX-dls. Sandy also added dired-support for non-UNIX OS and
629 : ;; auto-recognition of the host type.
630 : ;;
631 : ;; Thanks to Dave Smith who wrote the info file for ange-ftp.
632 : ;;
633 : ;; Finally, thanks to Keith Waclena, Mark D. Baushke, Terence Kelleher, Ping
634 : ;; Zhou, Edward Vielmetti, Jack Repenning, Mike Balenger, Todd Kaufmann,
635 : ;; Kjetil Svarstad, Tom Wurgler, Linus Tolke, Niko Makila, Carl Edman, Bill
636 : ;; Trost, Dave Brennan, Dan Jacobson, Andy Scott, Steve Anderson, Sanjay
637 : ;; Mathur, the folks on the ange-ftp-lovers mailing list and many others
638 : ;; whose names I've forgotten who have helped to debug and fix problems with
639 : ;; ange-ftp.el.
640 :
641 : ;;; Code:
642 :
643 : (require 'comint)
644 :
645 : ;;;; ------------------------------------------------------------
646 : ;;;; User customization variables.
647 : ;;;; ------------------------------------------------------------
648 :
649 : (defgroup ange-ftp nil
650 : "Accessing remote files and directories using FTP."
651 : :group 'files
652 : :group 'comm
653 : :prefix "ange-ftp-")
654 :
655 : (defcustom ange-ftp-name-format
656 : '("\\`/\\(\\([^/:]*\\)@\\)?\\([^@/:]*[^@/:.]\\):\\(.*\\)" . (3 2 4))
657 : "Format of a fully expanded remote file name.
658 :
659 : This is a list of the form \(REGEXP HOST USER NAME),
660 : where REGEXP is a regular expression matching
661 : the full remote name, and HOST, USER, and NAME are the numbers of
662 : parenthesized expressions in REGEXP for the components (in that order)."
663 : :group 'ange-ftp
664 : :type '(list (regexp :tag "Name regexp")
665 : (integer :tag "Host group")
666 : (integer :tag "User group")
667 : (integer :tag "Name group")))
668 :
669 : ;; ange-ftp-multi-skip-msgs should only match ###-, where ### is one of
670 : ;; the number codes corresponding to ange-ftp-good-msgs or ange-ftp-fatal-msgs.
671 : ;; Otherwise, ange-ftp will go into multi-skip mode, and never come out.
672 :
673 : (defvar ange-ftp-multi-msgs
674 : "^150-\\|^220-\\|^230-\\|^226\\|^25.-\\|^221-\\|^200-\\|^331-\\|^4[25]1-\\|^530-"
675 : "Regular expression matching the start of a multiline FTP reply.")
676 :
677 : (defvar ange-ftp-good-msgs
678 : "^220 \\|^230 \\|^226 \\|^25. \\|^221 \\|^200 \\|^[Hh]ash mark\\|^Remote directory:"
679 : "Regular expression matching FTP \"success\" messages.")
680 :
681 : ;; CMS and the odd VMS machine say 200 Port rather than 200 PORT.
682 : ;; Also CMS machines use a multiline 550- reply to say that you
683 : ;; don't have write permission. ange-ftp gets into multi-line skip
684 : ;; mode and hangs. Have it ignore 550- instead. It will then barf
685 : ;; when it gets the 550 line, as it should.
686 :
687 : ;; RFC2228 "FTP Security Extensions" defines extensions to the FTP
688 : ;; protocol which involve the client requesting particular
689 : ;; authentication methods (typically) at connection establishment. Non
690 : ;; security-aware FTP servers should respond to this with a 500 code,
691 : ;; which we ignore.
692 :
693 : ;; Further messages are needed to support ftp-ssl.
694 : (defcustom ange-ftp-skip-msgs
695 : (concat "^200 \\(PORT\\|Port\\) \\|^331 \\|^150 \\|^350 \\|^[0-9]+ bytes \\|"
696 : "^Connected \\|^$\\|^Remote system\\|^Using\\|^ \\|Password:\\|"
697 : "^Data connection \\|"
698 : "^200 PBSZ\\|" "^200 Protection set to Private\\|"
699 : "^234 AUTH TLS successful\\|"
700 : "^SSL not available\\|"
701 : "^\\[SSL Cipher .+\\]\\|"
702 : "^\\[Encrypted data transfer\\.\\]\\|"
703 : "^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye\\|"
704 : "^500 .*AUTH\\|^KERBEROS\\|"
705 : "^500 This security scheme is not implemented\\|"
706 : "^504 Unknown security mechanism\\|"
707 : "^530 Please login with USER and PASS\\|" ; non kerberized vsFTPd
708 : "^534 Kerberos Authentication not enabled\\|"
709 : "^22[789] .*[Pp]assive\\|^200 EPRT\\|^500 .*EPRT\\|^500 .*EPSV")
710 : "Regular expression matching FTP messages that can be ignored."
711 : :group 'ange-ftp
712 : :version "26.1"
713 : :type 'regexp)
714 :
715 : (defcustom ange-ftp-fatal-msgs
716 : (concat "^ftp: \\|^Not connected\\|^530 \\|^4[25]1 \\|rcmd: \\|"
717 : "^No control connection\\|unknown host\\|^lost connection")
718 : "Regular expression matching FTP messages that indicate serious errors.
719 :
720 : These mean that the FTP process should be (or already has been) killed."
721 : :group 'ange-ftp
722 : :type 'regexp)
723 :
724 : (defcustom ange-ftp-potential-error-msgs
725 : ;; On macOS we sometimes get things like:
726 : ;;
727 : ;; ftp> open ftp.nluug.nl
728 : ;; Trying 2001:610:1:80aa:192:87:102:36...
729 : ;; ftp: connect to address 2001:610:1:80aa:192:87:102:36: No route to host
730 : ;; Trying 192.87.102.36...
731 : ;; Connected to ftp.nluug.nl.
732 : "^ftp: connect to address .*: No route to host"
733 : "Regular expression matching FTP messages that can indicate serious errors.
734 : These mean that something went wrong, but they may be followed by more
735 : messages indicating that the error was somehow corrected."
736 : :group 'ange-ftp
737 : :type 'regexp)
738 :
739 : (defcustom ange-ftp-gateway-fatal-msgs
740 : "No route to host\\|Connection closed\\|No such host\\|Login incorrect"
741 : "Regular expression matching login failure messages from rlogin/telnet."
742 : :group 'ange-ftp
743 : :type 'regexp)
744 :
745 : (defcustom ange-ftp-xfer-size-msgs
746 : "^150 .* connection for .* (\\([0-9]+\\) bytes)"
747 : "Regular expression used to determine the number of bytes in a FTP transfer."
748 : :group 'ange-ftp
749 : :type 'regexp)
750 :
751 : (defcustom ange-ftp-tmp-name-template
752 : (expand-file-name "ange-ftp" temporary-file-directory)
753 : "Template used to create temporary files."
754 : :group 'ange-ftp
755 : :type 'directory)
756 :
757 : (defcustom ange-ftp-gateway-tmp-name-template "/tmp/ange-ftp"
758 : "Template used to create temporary files when FTP-ing through a gateway.
759 :
760 : Files starting with this prefix need to be accessible from BOTH the local
761 : machine and the gateway machine, and need to have the SAME name on both
762 : machines, that is, /tmp is probably NOT what you want, since that is rarely
763 : cross-mounted."
764 : :group 'ange-ftp
765 : :type 'directory)
766 :
767 : (defcustom ange-ftp-netrc-filename "~/.netrc"
768 : "File in .netrc format to search for passwords."
769 : :group 'ange-ftp
770 : :type 'file)
771 :
772 : (defcustom ange-ftp-disable-netrc-security-check (eq system-type 'windows-nt)
773 : "If non-nil avoid checking permissions on the .netrc file."
774 : :group 'ange-ftp
775 : :type 'boolean)
776 :
777 : (defcustom ange-ftp-default-user nil
778 : "User name to use when none is specified in a file name.
779 :
780 : If non-nil but not a string, you are prompted for the name.
781 : If nil, the value of `ange-ftp-netrc-default-user' is used.
782 : If that is nil too, then your login name is used.
783 :
784 : Once a connection to a given host has been initiated, the user name
785 : and password information for that host are cached and re-used by
786 : ange-ftp. Use \\[ange-ftp-set-user] to change the cached values,
787 : since setting `ange-ftp-default-user' directly does not affect
788 : the cached information."
789 : :group 'ange-ftp
790 : :type '(choice (const :tag "Default" nil)
791 : string
792 : (other :tag "Prompt" t)))
793 :
794 : (defcustom ange-ftp-netrc-default-user nil
795 : "Alternate default user name to use when none is specified.
796 :
797 : This variable is set from the `default' command in your `.netrc' file,
798 : if there is one."
799 : :group 'ange-ftp
800 : :type '(choice (const :tag "Default" nil)
801 : string))
802 :
803 : (defcustom ange-ftp-default-password nil
804 : "Password to use when the user name equals `ange-ftp-default-user'."
805 : :group 'ange-ftp
806 : :type '(choice (const :tag "Default" nil)
807 : string))
808 :
809 : (defcustom ange-ftp-default-account nil
810 : "Account to use when the user name equals `ange-ftp-default-user'."
811 : :group 'ange-ftp
812 : :type '(choice (const :tag "Default" nil)
813 : string))
814 :
815 : (defcustom ange-ftp-netrc-default-password nil
816 : "Password to use when the user name equals `ange-ftp-netrc-default-user'."
817 : :group 'ange-ftp
818 : :type '(choice (const :tag "Default" nil)
819 : string))
820 :
821 : (defcustom ange-ftp-netrc-default-account nil
822 : "Account to use when the user name equals `ange-ftp-netrc-default-user'."
823 : :group 'ange-ftp
824 : :type '(choice (const :tag "Default" nil)
825 : string))
826 :
827 : (defcustom ange-ftp-generate-anonymous-password t
828 : "If t, use value of `user-mail-address' as password for anonymous FTP.
829 :
830 : If a string, then use that string as the password.
831 : If nil, prompt the user for a password."
832 : :group 'ange-ftp
833 : :type '(choice (const :tag "Prompt" nil)
834 : string
835 : (other :tag "User address" t)))
836 :
837 : (defcustom ange-ftp-dumb-unix-host-regexp nil
838 : "If non-nil, regexp matching hosts on which `dir' command lists directory."
839 : :group 'ange-ftp
840 : :type '(choice (const :tag "Default" nil)
841 : string))
842 :
843 : (defcustom ange-ftp-binary-file-name-regexp ""
844 : "If a file matches this regexp then it is transferred in binary mode."
845 : :group 'ange-ftp
846 : :type 'regexp
847 : :version "24.1")
848 :
849 : (defcustom ange-ftp-gateway-host nil
850 : "Name of host to use as gateway machine when local FTP isn't possible."
851 : :group 'ange-ftp
852 : :type '(choice (const :tag "Default" nil)
853 : string))
854 :
855 : (defcustom ange-ftp-local-host-regexp ".*"
856 : "Regexp selecting hosts which can be reached directly with FTP.
857 :
858 : For other hosts the FTP process is started on `ange-ftp-gateway-host'
859 : instead, and/or reached via `ange-ftp-gateway-ftp-program-name'."
860 : :group 'ange-ftp
861 : :type 'regexp)
862 :
863 : (defcustom ange-ftp-gateway-program-interactive nil
864 : "If non-nil then the gateway program should give a shell prompt.
865 :
866 : Both telnet and rlogin do something like this."
867 : :group 'ange-ftp
868 : :type 'boolean)
869 :
870 : (defcustom ange-ftp-gateway-program remote-shell-program
871 : "Name of program to spawn a shell on the gateway machine.
872 :
873 : Valid candidates are rsh (remsh on some systems), telnet and rlogin.
874 : See also the gateway variable above."
875 : :group 'ange-ftp
876 : :type '(choice (const "rsh")
877 : (const "telnet")
878 : (const "rlogin")
879 : string))
880 :
881 : (defcustom ange-ftp-gateway-prompt-pattern "^[^#$%>;\n]*[#$%>;] *"
882 : "Regexp matching prompt after complete login sequence on gateway machine.
883 :
884 : A match for this means the shell is now awaiting input. Make this regexp as
885 : strict as possible; it shouldn't match *anything* at all except the user's
886 : initial prompt. The above string will fail under most SUN-3's since it
887 : matches the login banner."
888 : :group 'ange-ftp
889 : :type 'regexp)
890 :
891 : (defvar ange-ftp-gateway-setup-term-command
892 : (if (eq system-type 'hpux)
893 : "stty -onlcr -echo\n"
894 : "stty -echo nl\n")
895 : "Set up terminal after logging in to the gateway machine.
896 : This command should stop the terminal from echoing each command, and
897 : arrange to strip out trailing ^M characters.")
898 :
899 : (defcustom ange-ftp-smart-gateway nil
900 : "Non-nil says the FTP gateway (proxy) or gateway FTP program is smart.
901 :
902 : Don't bother telnetting, etc., already connected to desired host transparently,
903 : or just issue a user@host command in case `ange-ftp-gateway-host' is non-nil.
904 : See also `ange-ftp-smart-gateway-port'."
905 : :group 'ange-ftp
906 : :type 'boolean)
907 :
908 : (defcustom ange-ftp-smart-gateway-port "21"
909 : "Port on gateway machine to use when smart gateway is in operation."
910 : :group 'ange-ftp
911 : :type 'string)
912 :
913 : (defcustom ange-ftp-send-hash t
914 : "If non-nil, send the HASH command to the FTP client."
915 : :group 'ange-ftp
916 : :type 'boolean)
917 :
918 : (defcustom ange-ftp-binary-hash-mark-size nil
919 : "Default size, in bytes, between hash-marks when transferring a binary file.
920 : If nil, this variable will be locally overridden if the FTP client outputs a
921 : suitable response to the HASH command. If non-nil, this value takes
922 : precedence over the local value."
923 : :group 'ange-ftp
924 : :type '(choice (const :tag "Overridden" nil)
925 : integer))
926 :
927 : (defcustom ange-ftp-ascii-hash-mark-size 1024
928 : "Default size, in bytes, between hash-marks when transferring an ASCII file.
929 : This variable is buffer-local and will be locally overridden if the FTP client
930 : outputs a suitable response to the HASH command."
931 : :group 'ange-ftp
932 : :type 'integer)
933 :
934 : (defcustom ange-ftp-process-verbose t
935 : "If non-nil then be chatty about interaction with the FTP process."
936 : :group 'ange-ftp
937 : :type 'boolean)
938 :
939 : (defcustom ange-ftp-ftp-program-name "ftp"
940 : "Name of FTP program to run."
941 : :group 'ange-ftp
942 : :type 'string)
943 :
944 : (defcustom ange-ftp-gateway-ftp-program-name "ftp"
945 : "Name of FTP program to run when accessing non-local hosts.
946 :
947 : Some AT&T folks claim to use something called `pftp' here."
948 : :group 'ange-ftp
949 : :type 'string)
950 :
951 : (defcustom ange-ftp-ftp-program-args '("-i" "-n" "-g" "-v")
952 : "A list of arguments passed to the FTP program when started."
953 : :group 'ange-ftp
954 : :type '(repeat string))
955 :
956 : (defcustom ange-ftp-nslookup-program nil
957 : "If non-nil, this is a string naming the nslookup program."
958 : :group 'ange-ftp
959 : :type '(choice (const :tag "None" nil)
960 : string))
961 :
962 : (defcustom ange-ftp-make-backup-files ()
963 : "Non-nil means make backup files for \"magic\" remote files."
964 : :group 'ange-ftp
965 : :type 'boolean)
966 :
967 : (defcustom ange-ftp-retry-time 5
968 : "Number of seconds to wait before retry if file or listing doesn't arrive.
969 : This might need to be increased for very slow connections."
970 : :group 'ange-ftp
971 : :type 'integer)
972 :
973 : (defcustom ange-ftp-auto-save 0
974 : "If 1, allow ange-ftp files to be auto-saved.
975 : If 0, inhibit auto-saving of ange-ftp files.
976 : Don't use any other value."
977 : :group 'ange-ftp
978 : :type '(choice (const :tag "Suppress" 0)
979 : (const :tag "Allow" 1)))
980 :
981 : (defcustom ange-ftp-try-passive-mode nil
982 : "If t, try to use passive mode in FTP, if the client program supports it."
983 : :group 'ange-ftp
984 : :type 'boolean
985 : :version "21.1")
986 :
987 : (defcustom ange-ftp-passive-host-alist nil
988 : "Alist of FTP servers that need \"passive\" mode.
989 : Each element is of the form (HOSTNAME . SETTING).
990 : HOSTNAME is a regular expression to match the FTP server host name(s).
991 : SETTING is \"on\" to turn passive mode on, \"off\" to turn it off,
992 : or nil meaning don't change it."
993 : :group 'ange-ftp
994 : :type '(repeat (cons regexp (choice (const :tag "On" "on")
995 : (const :tag "Off" "off")
996 : (const :tag "Don't change" nil))))
997 : :version "22.1")
998 :
999 : ;;;; ------------------------------------------------------------
1000 : ;;;; Hash table support.
1001 : ;;;; ------------------------------------------------------------
1002 :
1003 : (require 'backquote)
1004 :
1005 : (defun ange-ftp-hash-entry-exists-p (key tbl)
1006 : "Return whether there is an association for KEY in table TBL."
1007 0 : (and tbl (not (eq (gethash key tbl 'unknown) 'unknown))))
1008 :
1009 : (defun ange-ftp-hash-table-keys (tbl)
1010 : "Return a sorted list of all the active keys in table TBL, as strings."
1011 : ;; (let ((keys nil))
1012 : ;; (maphash (lambda (k v) (push k keys)) tbl)
1013 : ;; (sort keys 'string-lessp))
1014 0 : (sort (all-completions "" tbl) 'string-lessp))
1015 :
1016 : ;;;; ------------------------------------------------------------
1017 : ;;;; Internal variables.
1018 : ;;;; ------------------------------------------------------------
1019 :
1020 : (defvar ange-ftp-data-buffer-name " *ftp data*"
1021 : "Buffer name to hold directory listing data received from FTP process.")
1022 :
1023 : (defvar ange-ftp-netrc-modtime nil
1024 : "Last modified time of the netrc file from file-attributes.")
1025 :
1026 : (defvar ange-ftp-user-hashtable (make-hash-table :test 'equal)
1027 : "Hash table holding associations between HOST, USER pairs.")
1028 :
1029 : (defvar ange-ftp-passwd-hashtable (make-hash-table :test 'equal)
1030 : "Mapping between a HOST, USER pair and a PASSWORD for them.
1031 : All HOST values should be in lower case.")
1032 :
1033 : (defvar ange-ftp-account-hashtable (make-hash-table :test 'equal)
1034 : "Mapping between a HOST, USER pair and an ACCOUNT password for them.")
1035 :
1036 : (defvar ange-ftp-files-hashtable (make-hash-table :test 'equal :size 97)
1037 : "Hash table for storing directories and their respective files.")
1038 :
1039 : (defvar ange-ftp-inodes-hashtable (make-hash-table :test 'equal :size 97)
1040 : "Hash table for storing file names and their \"inode numbers\".")
1041 :
1042 : (defvar ange-ftp-next-inode-number 1
1043 : "Next \"inode number\" value. We give each file name a unique number.")
1044 :
1045 : (defvar ange-ftp-ls-cache-lsargs nil
1046 : "Last set of args used by `ange-ftp-ls'.")
1047 :
1048 : (defvar ange-ftp-ls-cache-file nil
1049 : "Last file passed to `ange-ftp-ls'.")
1050 :
1051 : (defvar ange-ftp-ls-cache-res nil
1052 : "Last result returned from `ange-ftp-ls'.")
1053 :
1054 : (defconst ange-ftp-expand-dir-hashtable (make-hash-table :test 'equal))
1055 :
1056 : (defconst ange-ftp-expand-dir-regexp "^5.0 \\([^: ]+\\):")
1057 :
1058 : ;; These are local variables in each FTP process buffer.
1059 : (defvar ange-ftp-hash-mark-unit nil)
1060 : (defvar ange-ftp-hash-mark-count nil)
1061 : (defvar ange-ftp-xfer-size nil)
1062 : (defvar ange-ftp-process-string nil)
1063 : (defvar ange-ftp-process-result-line nil)
1064 : (defvar ange-ftp-pending-error-line nil)
1065 : (defvar ange-ftp-process-busy nil)
1066 : (defvar ange-ftp-process-result nil)
1067 : (defvar ange-ftp-process-multi-skip nil)
1068 : (defvar ange-ftp-process-msg nil)
1069 : (defvar ange-ftp-process-continue nil)
1070 : (defvar ange-ftp-last-percent nil)
1071 :
1072 : ;; These variables are bound by one function and examined by another.
1073 : ;; Leave them void globally for error checking.
1074 : (defvar ange-ftp-this-file)
1075 : (defvar ange-ftp-this-dir)
1076 : (defvar ange-ftp-this-user)
1077 : (defvar ange-ftp-this-host)
1078 : (defvar ange-ftp-this-msg)
1079 : (defvar ange-ftp-completion-ignored-pattern)
1080 : (defvar ange-ftp-trample-marker)
1081 :
1082 : ;; New error symbols.
1083 : (define-error 'ftp-error nil 'file-error) ;"FTP error"
1084 :
1085 : ;;; ------------------------------------------------------------
1086 : ;;; Enhanced message support.
1087 : ;;; ------------------------------------------------------------
1088 :
1089 : (defun ange-ftp-message (fmt &rest args)
1090 : "Display message in echo area, but indicate if truncated.
1091 : Args are as in `message': a format string, plus arguments to be formatted."
1092 0 : (let ((msg (apply #'format-message fmt args))
1093 0 : (max (window-width (minibuffer-window))))
1094 0 : (if noninteractive
1095 0 : msg
1096 0 : (if (>= (length msg) max)
1097 : ;; Take just the last MAX - 3 chars of the string.
1098 0 : (setq msg (concat "> " (substring msg (- 3 max)))))
1099 0 : (message "%s" msg))))
1100 :
1101 : (defun ange-ftp-abbreviate-filename (file &optional new)
1102 : "Abbreviate the file name FILE relative to the `default-directory'.
1103 : If the optional parameter NEW is given and the non-directory parts match,
1104 : only return the directory part of FILE."
1105 0 : (save-match-data
1106 0 : (if (and default-directory
1107 0 : (string-match (concat "\\`"
1108 0 : (regexp-quote default-directory)
1109 0 : ".") file))
1110 0 : (setq file (substring file (1- (match-end 0)))))
1111 0 : (if (and new
1112 0 : (string-equal (file-name-nondirectory file)
1113 0 : (file-name-nondirectory new)))
1114 0 : (setq file (file-name-directory file)))
1115 0 : (or file "./")))
1116 :
1117 : ;;;; ------------------------------------------------------------
1118 : ;;;; User / Host mapping support.
1119 : ;;;; ------------------------------------------------------------
1120 :
1121 : (defun ange-ftp-set-user (host user)
1122 : "For a given HOST, set or change the default USER."
1123 : (interactive "sHost: \nsUser: ")
1124 1 : (puthash host user ange-ftp-user-hashtable))
1125 :
1126 : (defun ange-ftp-get-user (host)
1127 : "Given a HOST, return the default user."
1128 1 : (ange-ftp-parse-netrc)
1129 1 : (let ((user (gethash host ange-ftp-user-hashtable)))
1130 1 : (or user
1131 1 : (prog1
1132 1 : (setq user
1133 1 : (cond ((stringp ange-ftp-default-user)
1134 : ;; We have a default name. Use it.
1135 0 : ange-ftp-default-user)
1136 1 : (ange-ftp-default-user
1137 : ;; Ask the user.
1138 0 : (let ((enable-recursive-minibuffers t))
1139 0 : (read-string (format "User for %s: " host)
1140 0 : (user-login-name))))
1141 1 : (ange-ftp-netrc-default-user)
1142 : ;; Default to the user's login name.
1143 : (t
1144 1 : (user-login-name))))
1145 1 : (ange-ftp-set-user host user)))))
1146 :
1147 : ;;;; ------------------------------------------------------------
1148 : ;;;; Password support.
1149 : ;;;; ------------------------------------------------------------
1150 :
1151 : (defmacro ange-ftp-generate-passwd-key (host user)
1152 6 : `(and (stringp ,host) (stringp ,user) (concat (downcase ,host) "/" ,user)))
1153 :
1154 : (defmacro ange-ftp-lookup-passwd (host user)
1155 3 : `(gethash (ange-ftp-generate-passwd-key ,host ,user)
1156 3 : ange-ftp-passwd-hashtable))
1157 :
1158 : (defun ange-ftp-set-passwd (host user password)
1159 : "For a given HOST and USER, set or change the associated PASSWORD."
1160 0 : (interactive (list (read-string "Host: ")
1161 0 : (read-string "User: ")
1162 0 : (read-passwd "Password: ")))
1163 0 : (puthash (ange-ftp-generate-passwd-key host user)
1164 0 : password ange-ftp-passwd-hashtable))
1165 :
1166 : (defun ange-ftp-get-host-with-passwd (user)
1167 : "Given a USER, return a host we know the password for."
1168 0 : (ange-ftp-parse-netrc)
1169 0 : (catch 'found-one
1170 0 : (maphash
1171 : (lambda (host val)
1172 0 : (if (ange-ftp-lookup-passwd host user) (throw 'found-one host)))
1173 0 : ange-ftp-user-hashtable)
1174 0 : (save-match-data
1175 0 : (maphash
1176 : (lambda (key value)
1177 0 : (if (string-match "\\`[^/]*\\(/\\).*\\'" key)
1178 0 : (let ((host (substring key 0 (match-beginning 1))))
1179 0 : (if (and (string-equal user (substring key (match-end 1)))
1180 0 : value)
1181 0 : (throw 'found-one host)))))
1182 0 : ange-ftp-passwd-hashtable))
1183 0 : nil))
1184 :
1185 : (defun ange-ftp-get-passwd (host user)
1186 : "Return the password for specified HOST and USER, asking user if necessary."
1187 : ;; If `non-essential' is non-nil, don't ask for a password. It will
1188 : ;; be caught in Tramp.
1189 0 : (when non-essential
1190 0 : (throw 'non-essential 'non-essential))
1191 :
1192 0 : (ange-ftp-parse-netrc)
1193 :
1194 : ;; look up password in the hash table first; user might have overridden the
1195 : ;; defaults.
1196 0 : (cond ((ange-ftp-lookup-passwd host user))
1197 :
1198 : ;; See if default user and password set.
1199 0 : ((and (stringp ange-ftp-default-user)
1200 0 : ange-ftp-default-password
1201 0 : (string-equal user ange-ftp-default-user))
1202 0 : ange-ftp-default-password)
1203 :
1204 : ;; See if default user and password set from .netrc file.
1205 0 : ((and (stringp ange-ftp-netrc-default-user)
1206 0 : ange-ftp-netrc-default-password
1207 0 : (string-equal user ange-ftp-netrc-default-user))
1208 0 : ange-ftp-netrc-default-password)
1209 :
1210 : ;; anonymous ftp password is handled specially since there is an
1211 : ;; unwritten rule about how that is used on the Internet.
1212 0 : ((and (or (string-equal user "anonymous")
1213 0 : (string-equal user "ftp"))
1214 0 : ange-ftp-generate-anonymous-password)
1215 0 : (if (stringp ange-ftp-generate-anonymous-password)
1216 0 : ange-ftp-generate-anonymous-password
1217 0 : user-mail-address))
1218 :
1219 : ;; see if same user has logged in to other hosts; if so then prompt
1220 : ;; with the password that was used there.
1221 : (t
1222 0 : (let* ((enable-recursive-minibuffers t)
1223 0 : (other (ange-ftp-get-host-with-passwd user))
1224 0 : (passwd (if other
1225 :
1226 : ;; found another machine with the same user.
1227 : ;; Try that account.
1228 0 : (read-passwd
1229 0 : (format "passwd for %s@%s (default same as %s@%s): "
1230 0 : user host user other)
1231 : nil
1232 0 : (ange-ftp-lookup-passwd other user))
1233 :
1234 : ;; I give up. Ask the user for the password.
1235 0 : (read-passwd
1236 0 : (format "Password for %s@%s: " user host)))))
1237 0 : (ange-ftp-set-passwd host user passwd)
1238 0 : passwd))))
1239 :
1240 : ;;;; ------------------------------------------------------------
1241 : ;;;; Account support
1242 : ;;;; ------------------------------------------------------------
1243 :
1244 : ;; Account passwords must be either specified in the .netrc file, or set
1245 : ;; manually by calling ange-ftp-set-account. For the moment, ange-ftp doesn't
1246 : ;; check to see whether the FTP process is actually prompting for an account
1247 : ;; password.
1248 :
1249 : (defun ange-ftp-set-account (host user account)
1250 : "For a given HOST and USER, set or change the associated ACCOUNT password."
1251 0 : (interactive (list (read-string "Host: ")
1252 0 : (read-string "User: ")
1253 0 : (read-passwd "Account password: ")))
1254 0 : (puthash (ange-ftp-generate-passwd-key host user)
1255 0 : account ange-ftp-account-hashtable))
1256 :
1257 : (defun ange-ftp-get-account (host user)
1258 : "Given a HOST and USER, return the FTP account."
1259 0 : (ange-ftp-parse-netrc)
1260 0 : (or (gethash (ange-ftp-generate-passwd-key host user)
1261 0 : ange-ftp-account-hashtable)
1262 0 : (and (stringp ange-ftp-default-user)
1263 0 : (string-equal user ange-ftp-default-user)
1264 0 : ange-ftp-default-account)
1265 0 : (and (stringp ange-ftp-netrc-default-user)
1266 0 : (string-equal user ange-ftp-netrc-default-user)
1267 0 : ange-ftp-netrc-default-account)))
1268 :
1269 : ;;;; ------------------------------------------------------------
1270 : ;;;; ~/.netrc support
1271 : ;;;; ------------------------------------------------------------
1272 :
1273 : (defun ange-ftp-chase-symlinks (file)
1274 : "Return the filename that FILE references, following all symbolic links."
1275 1 : (let (temp)
1276 1 : (while (setq temp (ange-ftp-real-file-symlink-p file))
1277 0 : (setq file
1278 0 : (if (file-name-absolute-p temp)
1279 0 : temp
1280 : ;; Wouldn't `expand-file-name' be better than `concat' ?
1281 : ;; It would fail when `a/b/..' != `a', tho. --Stef
1282 1 : (concat (file-name-directory file) temp)))))
1283 1 : file)
1284 :
1285 : ;; Move along current line looking for the value of the TOKEN.
1286 : ;; Valid separators between TOKEN and its value are commas and
1287 : ;; whitespace. Second arg LIMIT is a limit for the search.
1288 :
1289 : (defun ange-ftp-parse-netrc-token (token limit)
1290 0 : (if (search-forward token limit t)
1291 0 : (let (beg)
1292 0 : (skip-chars-forward ", \t\r\n" limit)
1293 0 : (if (eq (following-char) ?\") ;quoted token value
1294 0 : (progn (forward-char 1)
1295 0 : (setq beg (point))
1296 0 : (skip-chars-forward "^\"" limit)
1297 0 : (forward-char 1)
1298 0 : (buffer-substring beg (1- (point))))
1299 0 : (setq beg (point))
1300 0 : (skip-chars-forward "^, \t\r\n" limit)
1301 0 : (buffer-substring beg (point))))))
1302 :
1303 : ;; Extract the values for the tokens `machine', `login',
1304 : ;; `password' and `account' in the current buffer. If successful,
1305 : ;; record the information found.
1306 :
1307 : (defun ange-ftp-parse-netrc-group ()
1308 0 : (let ((start (point))
1309 0 : (end (save-excursion
1310 0 : (if (looking-at "machine\\>")
1311 : ;; Skip `machine' and the machine name that follows.
1312 0 : (progn
1313 0 : (skip-chars-forward "^ \t\r\n")
1314 0 : (skip-chars-forward " \t\r\n")
1315 0 : (skip-chars-forward "^ \t\r\n"))
1316 : ;; Skip `default'.
1317 0 : (skip-chars-forward "^ \t\r\n"))
1318 : ;; Find start of the next `machine' or `default'
1319 : ;; or the end of the buffer.
1320 0 : (if (re-search-forward "machine\\>\\|default\\>" nil t)
1321 0 : (match-beginning 0)
1322 0 : (point-max))))
1323 : machine login password account)
1324 0 : (setq machine (ange-ftp-parse-netrc-token "machine" end)
1325 0 : login (ange-ftp-parse-netrc-token "login" end)
1326 0 : password (ange-ftp-parse-netrc-token "password" end)
1327 0 : account (ange-ftp-parse-netrc-token "account" end))
1328 0 : (if (and machine login)
1329 : ;; found a `machine` token.
1330 0 : (progn
1331 0 : (ange-ftp-set-user machine login)
1332 0 : (ange-ftp-set-passwd machine login password)
1333 0 : (and account
1334 0 : (ange-ftp-set-account machine login account)))
1335 0 : (goto-char start)
1336 0 : (if (search-forward "default" end t)
1337 : ;; found a `default' token
1338 0 : (progn
1339 0 : (setq login (ange-ftp-parse-netrc-token "login" end)
1340 0 : password (ange-ftp-parse-netrc-token "password" end)
1341 0 : account (ange-ftp-parse-netrc-token "account" end))
1342 0 : (and login
1343 0 : (setq ange-ftp-netrc-default-user login))
1344 0 : (and password
1345 0 : (setq ange-ftp-netrc-default-password password))
1346 0 : (and account
1347 0 : (setq ange-ftp-netrc-default-account account)))))
1348 0 : (goto-char end)))
1349 :
1350 : ;; Read in ~/.netrc, if one exists. If ~/.netrc file exists and has
1351 : ;; the correct permissions then extract the machine, login,
1352 : ;; password and account information from within.
1353 :
1354 : (defun ange-ftp-parse-netrc ()
1355 : ;; We set this before actually doing it to avoid the possibility
1356 : ;; of an infinite loop if ange-ftp-netrc-filename is an FTP file.
1357 : (interactive)
1358 1 : (let (file attr)
1359 1 : (let ((default-directory "/"))
1360 1 : (setq file (ange-ftp-chase-symlinks
1361 1 : (ange-ftp-real-expand-file-name ange-ftp-netrc-filename)))
1362 1 : (setq attr (ange-ftp-real-file-attributes file)))
1363 1 : (if (and attr ; file exists.
1364 1 : (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed
1365 0 : (save-match-data
1366 0 : (if (or ange-ftp-disable-netrc-security-check
1367 0 : (and (eq (nth 2 attr) (user-uid)) ; Same uids.
1368 0 : (string-match ".r..------" (nth 8 attr))))
1369 0 : (with-current-buffer
1370 : ;; we are cheating a bit here. I'm trying to do the equivalent
1371 : ;; of find-file on the .netrc file, but then nuke it afterwards.
1372 : ;; with the bit of logic below we should be able to have
1373 : ;; encrypted .netrc files.
1374 0 : (generate-new-buffer "*ftp-.netrc*")
1375 0 : (ange-ftp-real-insert-file-contents file)
1376 0 : (setq buffer-file-name file)
1377 0 : (setq default-directory (file-name-directory file))
1378 0 : (normal-mode t)
1379 0 : (run-hooks 'find-file-hook)
1380 0 : (setq buffer-file-name nil)
1381 0 : (goto-char (point-min))
1382 0 : (while (search-forward-regexp "^[ \t]*#.*$" nil t)
1383 0 : (replace-match ""))
1384 0 : (goto-char (point-min))
1385 0 : (skip-chars-forward " \t\r\n")
1386 0 : (while (not (eobp))
1387 0 : (ange-ftp-parse-netrc-group))
1388 0 : (kill-buffer (current-buffer)))
1389 0 : (ange-ftp-message "%s either not owned by you or badly protected."
1390 0 : ange-ftp-netrc-filename)
1391 0 : (sit-for 1))
1392 1 : (setq ange-ftp-netrc-modtime (nth 5 attr))))))
1393 :
1394 : ;; Return a list of prefixes of the form 'user@host:' to be used when
1395 : ;; completion is done in the root directory.
1396 :
1397 : (defun ange-ftp-generate-root-prefixes ()
1398 0 : (ange-ftp-parse-netrc)
1399 0 : (save-match-data
1400 0 : (let (res)
1401 0 : (maphash
1402 : (lambda (key value)
1403 0 : (if (string-match "\\`[^/]*\\(/\\).*\\'" key)
1404 0 : (let ((host (substring key 0 (match-beginning 1)))
1405 0 : (user (substring key (match-end 1))))
1406 0 : (push (concat user "@" host ":") res))))
1407 0 : ange-ftp-passwd-hashtable)
1408 0 : (maphash
1409 0 : (lambda (host user) (push (concat host ":") res))
1410 0 : ange-ftp-user-hashtable)
1411 0 : (or res (list nil)))))
1412 :
1413 : ;;;; ------------------------------------------------------------
1414 : ;;;; Remote file name syntax support.
1415 : ;;;; ------------------------------------------------------------
1416 :
1417 : (defmacro ange-ftp-ftp-name-component (n ns name)
1418 : "Extract the Nth FTP file name component from NS."
1419 3 : `(let ((elt (nth ,n ,ns)))
1420 3 : (match-string elt ,name)))
1421 :
1422 : (defvar ange-ftp-ftp-name-arg "")
1423 : (defvar ange-ftp-ftp-name-res nil)
1424 :
1425 : ;; Parse NAME according to `ange-ftp-name-format' (which see).
1426 : ;; Returns a list (HOST USER NAME), or nil if NAME does not match the format.
1427 : (defun ange-ftp-ftp-name (name)
1428 13 : (if (string-equal name ange-ftp-ftp-name-arg)
1429 0 : ange-ftp-ftp-name-res
1430 13 : (setq ange-ftp-ftp-name-arg name
1431 : ange-ftp-ftp-name-res
1432 13 : (save-match-data
1433 13 : (if (posix-string-match (car ange-ftp-name-format) name)
1434 3 : (let* ((ns (cdr ange-ftp-name-format))
1435 3 : (host (ange-ftp-ftp-name-component 0 ns name))
1436 3 : (user (ange-ftp-ftp-name-component 1 ns name))
1437 3 : (name (ange-ftp-ftp-name-component 2 ns name)))
1438 3 : (if (zerop (length user))
1439 3 : (setq user (ange-ftp-get-user host)))
1440 3 : (list host user name))
1441 13 : nil)))))
1442 :
1443 : ;; Take a FULLNAME that matches according to ange-ftp-name-format and
1444 : ;; replace the name component with NAME.
1445 : (defun ange-ftp-replace-name-component (fullname name)
1446 0 : (save-match-data
1447 0 : (if (posix-string-match (car ange-ftp-name-format) fullname)
1448 0 : (let* ((ns (cdr ange-ftp-name-format))
1449 0 : (elt (nth 2 ns)))
1450 0 : (concat (substring fullname 0 (match-beginning elt))
1451 0 : name
1452 0 : (substring fullname (match-end elt)))))))
1453 :
1454 : ;;;; ------------------------------------------------------------
1455 : ;;;; Miscellaneous utils.
1456 : ;;;; ------------------------------------------------------------
1457 :
1458 : ;; (setq ange-ftp-tmp-keymap (make-sparse-keymap))
1459 : ;; (define-key ange-ftp-tmp-keymap "\C-m" 'exit-minibuffer)
1460 :
1461 : (defun ange-ftp-repaint-minibuffer ()
1462 : "Clear any existing minibuffer message; let the minibuffer contents show."
1463 0 : (message nil))
1464 :
1465 : ;; Return the name of the buffer that collects output from the ftp process
1466 : ;; connected to the given HOST and USER pair.
1467 : (defun ange-ftp-ftp-process-buffer (host user)
1468 0 : (concat "*ftp " user "@" host "*"))
1469 :
1470 : ;; Display the last chunk of output from the ftp process for the given HOST
1471 : ;; USER pair, and signal an error including MSG in the text.
1472 : (defun ange-ftp-error (host user msg)
1473 0 : (save-excursion ;; Prevent pop-to-buffer from changing current buffer.
1474 0 : (let ((cur (selected-window))
1475 : (pop-up-windows t))
1476 0 : (pop-to-buffer
1477 0 : (get-buffer-create
1478 0 : (ange-ftp-ftp-process-buffer host user)))
1479 0 : (goto-char (point-max))
1480 0 : (select-window cur))
1481 0 : (signal 'ftp-error (list (format "FTP Error: %s" msg)))))
1482 :
1483 : (defun ange-ftp-set-buffer-mode ()
1484 : "Set correct modes for the current buffer if visiting a remote file."
1485 10 : (if (and (stringp buffer-file-name)
1486 10 : (ange-ftp-ftp-name buffer-file-name))
1487 10 : (auto-save-mode ange-ftp-auto-save)))
1488 :
1489 : (defun ange-ftp-kill-ftp-process (&optional buffer)
1490 : "Kill the FTP process associated with BUFFER (the current buffer, if nil).
1491 : If the BUFFER's visited filename or `default-directory' is an FTP filename
1492 : then kill the related FTP process."
1493 : (interactive "bKill FTP process associated with buffer: ")
1494 0 : (if (null buffer)
1495 0 : (setq buffer (current-buffer))
1496 0 : (setq buffer (get-buffer buffer)))
1497 0 : (let ((file (or (buffer-file-name buffer)
1498 0 : (with-current-buffer buffer default-directory))))
1499 0 : (if file
1500 0 : (let ((parsed (ange-ftp-ftp-name (expand-file-name file))))
1501 0 : (if parsed
1502 0 : (let ((host (nth 0 parsed))
1503 0 : (user (nth 1 parsed)))
1504 0 : (kill-buffer (get-buffer (ange-ftp-ftp-process-buffer host user)))))))))
1505 :
1506 : (defun ange-ftp-quote-string (string)
1507 : "Quote any characters in STRING that may confuse the FTP process."
1508 : ;; This is said to be wrong; ftp is said to need quoting only for ",
1509 : ;; and that by doubling it. But experiment says UNIX-style kind of
1510 : ;; quoting is correct when talking to ftp on GNU/Linux systems, and
1511 : ;; W32-style kind of quoting on, yes, W32 systems.
1512 0 : (if (stringp string)
1513 0 : (shell-quote-argument string)
1514 0 : ""))
1515 :
1516 : (defun ange-ftp-barf-if-not-directory (directory)
1517 0 : (or (file-directory-p directory)
1518 0 : (let ((exists (file-exists-p directory)))
1519 0 : (signal (if exists 'file-error 'file-missing)
1520 0 : (list "Opening directory"
1521 0 : (if exists "Not a directory" "No such file or directory")
1522 0 : directory)))))
1523 :
1524 : ;;;; ------------------------------------------------------------
1525 : ;;;; FTP process filter support.
1526 : ;;;; ------------------------------------------------------------
1527 :
1528 : (defun ange-ftp-process-handle-line (line proc)
1529 : "Look at the given LINE from the FTP process PROC.
1530 : Try to categorize it into one of four categories:
1531 : good, skip, fatal, or unknown."
1532 0 : (cond ((string-match ange-ftp-xfer-size-msgs line)
1533 0 : (setq ange-ftp-xfer-size
1534 0 : (/ (string-to-number (match-string 1 line))
1535 0 : 1024)))
1536 0 : ((string-match ange-ftp-skip-msgs line)
1537 : t)
1538 0 : ((string-match ange-ftp-good-msgs line)
1539 0 : (setq ange-ftp-process-busy nil
1540 : ange-ftp-process-result t
1541 : ange-ftp-pending-error-line nil
1542 0 : ange-ftp-process-result-line line))
1543 : ;; Check this before checking for errors.
1544 : ;; Otherwise the last line of these three seems to be an error:
1545 : ;; 230-see a significant impact from the move. For those of you who can't
1546 : ;; 230-use DNS to resolve hostnames and get an error message like
1547 : ;; 230-"ftp.stsci.edu: unknown host", the new IP address will be...
1548 0 : ((string-match ange-ftp-multi-msgs line)
1549 0 : (setq ange-ftp-process-multi-skip t))
1550 0 : ((string-match ange-ftp-potential-error-msgs line)
1551 : ;; This looks like an error, but we have to keep reading the output
1552 : ;; to see if it was fixed or not. E.g. it may indicate that IPv6
1553 : ;; failed, but maybe a subsequent IPv4 fallback succeeded.
1554 0 : (set (make-local-variable 'ange-ftp-pending-error-line) line)
1555 : t)
1556 0 : ((string-match ange-ftp-fatal-msgs line)
1557 0 : (delete-process proc)
1558 0 : (setq ange-ftp-process-busy nil
1559 0 : ange-ftp-process-result-line line))
1560 0 : (ange-ftp-process-multi-skip
1561 : t)
1562 : (t
1563 0 : (setq ange-ftp-process-busy nil
1564 0 : ange-ftp-process-result-line line))))
1565 :
1566 : (defun ange-ftp-set-xfer-size (host user bytes)
1567 : "Set the size of the next FTP transfer in bytes."
1568 0 : (let ((proc (ange-ftp-get-process host user)))
1569 0 : (when proc
1570 0 : (let ((buf (process-buffer proc)))
1571 0 : (when buf
1572 0 : (with-current-buffer buf
1573 0 : (setq ange-ftp-xfer-size
1574 : ;; For very large files, BYTES can be a float.
1575 0 : (if (integerp bytes)
1576 0 : (ash bytes -10)
1577 0 : (/ bytes 1024)))))))))
1578 :
1579 : (defun ange-ftp-process-handle-hash (string)
1580 : "Remove hash marks from STRING and display count so far."
1581 0 : (setq string (concat (substring string 0 (match-beginning 0))
1582 0 : (substring string (match-end 0)))
1583 0 : ange-ftp-hash-mark-count (+ (- (match-end 0)
1584 0 : (match-beginning 0))
1585 0 : ange-ftp-hash-mark-count))
1586 0 : (and ange-ftp-hash-mark-unit
1587 0 : ange-ftp-process-msg
1588 0 : ange-ftp-process-verbose
1589 0 : (not (eq (selected-window) (minibuffer-window)))
1590 0 : (not (boundp 'search-message)) ;screws up isearch otherwise
1591 0 : (not cursor-in-echo-area) ;screws up y-or-n-p otherwise
1592 0 : (let ((kbytes (ash (* ange-ftp-hash-mark-unit
1593 0 : ange-ftp-hash-mark-count)
1594 0 : -6)))
1595 0 : (if (zerop ange-ftp-xfer-size)
1596 0 : (ange-ftp-message "%s...%dk" ange-ftp-process-msg kbytes)
1597 0 : (let ((percent (floor (* 100.0 kbytes) ange-ftp-xfer-size)))
1598 : ;; cut out the redisplay of identical %-age messages.
1599 0 : (unless (eq percent ange-ftp-last-percent)
1600 0 : (setq ange-ftp-last-percent percent)
1601 0 : (ange-ftp-message "%s...%d%%" ange-ftp-process-msg percent))))))
1602 0 : string)
1603 :
1604 : ;; Call the function specified by CONT. CONT can be either a function
1605 : ;; or a list of a function and some args. The first two parameters
1606 : ;; passed to the function will be RESULT and LINE. The remaining args
1607 : ;; will be taken from CONT if a list was passed.
1608 :
1609 : (defun ange-ftp-call-cont (cont result line)
1610 0 : (when cont
1611 0 : (if (and (listp cont)
1612 0 : (not (eq (car cont) 'lambda)))
1613 0 : (apply (car cont) result line (cdr cont))
1614 0 : (funcall cont result line))))
1615 :
1616 : ;; Build up a complete line of output from the ftp PROCESS and pass it
1617 : ;; on to ange-ftp-process-handle-line to deal with.
1618 :
1619 : (defun ange-ftp-process-filter (proc str)
1620 : ;; Eliminate nulls.
1621 0 : (while (string-match "\000+" str)
1622 0 : (setq str (replace-match "" nil nil str)))
1623 :
1624 : ;; see if the buffer is still around... it could have been deleted.
1625 0 : (when (buffer-live-p (process-buffer proc))
1626 0 : (with-current-buffer (process-buffer proc)
1627 :
1628 : ;; handle hash mark printing
1629 0 : (and ange-ftp-process-busy
1630 0 : (string-match "^#+$" str)
1631 0 : (setq str (ange-ftp-process-handle-hash str)))
1632 0 : (comint-output-filter proc str)
1633 : ;; Replace STR by the result of the comint processing.
1634 0 : (setq str (buffer-substring comint-last-output-start
1635 0 : (process-mark proc)))
1636 0 : (when ange-ftp-process-busy
1637 0 : (setq ange-ftp-process-string (concat ange-ftp-process-string
1638 0 : str))
1639 :
1640 : ;; if we gave an empty password to the USER command earlier
1641 : ;; then we should send a null password now.
1642 0 : (if (string-match "Password: *$" ange-ftp-process-string)
1643 0 : (process-send-string proc "\n")))
1644 0 : (while (and ange-ftp-process-busy
1645 0 : (string-match "\n" ange-ftp-process-string))
1646 0 : (let ((line (substring ange-ftp-process-string
1647 : 0
1648 0 : (match-beginning 0)))
1649 : (seen-prompt nil))
1650 0 : (setq ange-ftp-process-string (substring ange-ftp-process-string
1651 0 : (match-end 0)))
1652 0 : (while (string-match "\\`ftp> *" line)
1653 0 : (setq seen-prompt t)
1654 0 : (setq line (substring line (match-end 0))))
1655 0 : (if (not (and seen-prompt ange-ftp-pending-error-line))
1656 0 : (ange-ftp-process-handle-line line proc)
1657 : ;; If we've seen a potential error message and it
1658 : ;; hasn't been canceled by a good message before
1659 : ;; seeing a prompt, then the error was real.
1660 0 : (delete-process proc)
1661 0 : (setq ange-ftp-process-busy nil
1662 0 : ange-ftp-process-result-line ange-ftp-pending-error-line))))
1663 :
1664 : ;; has the ftp client finished? if so then do some clean-up
1665 : ;; actions.
1666 0 : (unless ange-ftp-process-busy
1667 : ;; reset the xfer size
1668 0 : (setq ange-ftp-xfer-size 0)
1669 :
1670 : ;; issue the "done" message since we've finished.
1671 0 : (when (and ange-ftp-process-msg
1672 0 : ange-ftp-process-verbose
1673 0 : ange-ftp-process-result)
1674 0 : (ange-ftp-message "%s...done" ange-ftp-process-msg)
1675 0 : (ange-ftp-repaint-minibuffer)
1676 0 : (setq ange-ftp-process-msg nil))
1677 :
1678 : ;; is there a continuation we should be calling? if so,
1679 : ;; we'd better call it, making sure we only call it once.
1680 0 : (when ange-ftp-process-continue
1681 0 : (let ((cont ange-ftp-process-continue))
1682 0 : (setq ange-ftp-process-continue nil)
1683 0 : (ange-ftp-call-cont cont
1684 0 : ange-ftp-process-result
1685 0 : ange-ftp-process-result-line)))))))
1686 :
1687 : (defun ange-ftp-process-sentinel (proc str)
1688 : "When FTP process changes state, nuke all file-entries in cache."
1689 0 : (let ((name (process-name proc)))
1690 0 : (when (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name)
1691 0 : (let ((user (match-string 1 name))
1692 0 : (host (match-string 2 name)))
1693 0 : (ange-ftp-wipe-file-entries host user))))
1694 0 : (setq ange-ftp-ls-cache-file nil))
1695 :
1696 : ;;;; ------------------------------------------------------------
1697 : ;;;; Gateway support.
1698 : ;;;; ------------------------------------------------------------
1699 :
1700 : (defun ange-ftp-use-gateway-p (host)
1701 : "Return whether to access this HOST via a normal (non-smart) gateway."
1702 : ;; yes, I know that I could simplify the following expression, but it is
1703 : ;; clearer (to me at least) this way.
1704 0 : (and (not ange-ftp-smart-gateway)
1705 0 : (not (string-match-p ange-ftp-local-host-regexp host))))
1706 :
1707 : (defun ange-ftp-use-smart-gateway-p (host)
1708 : "Returns whether to access this HOST via a smart gateway."
1709 0 : (and ange-ftp-smart-gateway
1710 0 : (not (string-match-p ange-ftp-local-host-regexp host))))
1711 :
1712 :
1713 : ;;; ------------------------------------------------------------
1714 : ;;; Temporary file location and deletion...
1715 : ;;; ------------------------------------------------------------
1716 :
1717 : (defun ange-ftp-make-tmp-name (host &optional suffix)
1718 : "This routine will return the name of a new file."
1719 0 : (make-temp-file (if (ange-ftp-use-gateway-p host)
1720 0 : ange-ftp-gateway-tmp-name-template
1721 0 : ange-ftp-tmp-name-template)
1722 0 : nil suffix))
1723 :
1724 : (defun ange-ftp-del-tmp-name (filename)
1725 : "Force to delete temporary file."
1726 0 : (delete-file filename))
1727 :
1728 :
1729 : ;;;; ------------------------------------------------------------
1730 : ;;;; Interactive gateway program support.
1731 : ;;;; ------------------------------------------------------------
1732 :
1733 : (defvar ange-ftp-gwp-running t)
1734 : (defvar ange-ftp-gwp-status nil)
1735 :
1736 : (defun ange-ftp-gwp-sentinel (proc str)
1737 0 : (setq ange-ftp-gwp-running nil))
1738 :
1739 : (defun ange-ftp-gwp-filter (proc str)
1740 0 : (comint-output-filter proc str)
1741 0 : (with-current-buffer (process-buffer proc)
1742 : ;; Replace STR by the result of the comint processing.
1743 0 : (setq str (buffer-substring comint-last-output-start (process-mark proc))))
1744 0 : (cond ((string-match "login: *$" str)
1745 0 : (process-send-string proc
1746 0 : (concat
1747 0 : (let ((ange-ftp-default-user t))
1748 0 : (ange-ftp-get-user ange-ftp-gateway-host))
1749 0 : "\n")))
1750 0 : ((string-match "Password: *$" str)
1751 0 : (process-send-string proc
1752 0 : (concat
1753 0 : (ange-ftp-get-passwd ange-ftp-gateway-host
1754 0 : (ange-ftp-get-user
1755 0 : ange-ftp-gateway-host))
1756 0 : "\n")))
1757 0 : ((string-match ange-ftp-gateway-fatal-msgs str)
1758 0 : (delete-process proc)
1759 0 : (setq ange-ftp-gwp-running nil))
1760 0 : ((string-match ange-ftp-gateway-prompt-pattern str)
1761 0 : (setq ange-ftp-gwp-running nil
1762 0 : ange-ftp-gwp-status t))))
1763 :
1764 : (defun ange-ftp-gwp-start (host user name args)
1765 : "Login to the gateway machine and fire up an FTP process."
1766 : ;; If `non-essential' is non-nil, don't reopen a new connection. It
1767 : ;; will be caught in Tramp.
1768 0 : (when non-essential
1769 0 : (throw 'non-essential 'non-essential))
1770 0 : (let (;; It would be nice to make process-connection-type nil,
1771 : ;; but that doesn't work: ftp never responds.
1772 : ;; Can anyone find a fix for that?
1773 0 : (proc (let ((process-connection-type t))
1774 0 : (start-process name name
1775 0 : ange-ftp-gateway-program
1776 0 : ange-ftp-gateway-host)))
1777 0 : (ftp (mapconcat 'identity args " ")))
1778 0 : (set-process-query-on-exit-flag proc nil)
1779 0 : (set-process-sentinel proc 'ange-ftp-gwp-sentinel)
1780 0 : (set-process-filter proc 'ange-ftp-gwp-filter)
1781 0 : (with-current-buffer (process-buffer proc)
1782 0 : (goto-char (point-max))
1783 0 : (set-marker (process-mark proc) (point)))
1784 0 : (setq ange-ftp-gwp-running t
1785 0 : ange-ftp-gwp-status nil)
1786 0 : (ange-ftp-message "Connecting to gateway %s..." ange-ftp-gateway-host)
1787 0 : (while ange-ftp-gwp-running ;perform login sequence
1788 0 : (accept-process-output proc))
1789 0 : (unless ange-ftp-gwp-status
1790 0 : (ange-ftp-error host user "unable to login to gateway"))
1791 0 : (ange-ftp-message "Connecting to gateway %s...done" ange-ftp-gateway-host)
1792 0 : (setq ange-ftp-gwp-running t
1793 0 : ange-ftp-gwp-status nil)
1794 0 : (process-send-string proc ange-ftp-gateway-setup-term-command)
1795 0 : (while ange-ftp-gwp-running ;zap ^M's and double echoing.
1796 0 : (accept-process-output proc))
1797 0 : (unless ange-ftp-gwp-status
1798 0 : (ange-ftp-error host user "unable to set terminal modes on gateway"))
1799 0 : (setq ange-ftp-gwp-running t
1800 0 : ange-ftp-gwp-status nil)
1801 0 : (process-send-string proc (concat "exec " ftp "\n")) ;spawn ftp process
1802 0 : proc))
1803 :
1804 : ;;;; ------------------------------------------------------------
1805 : ;;;; Support for sending commands to the ftp process.
1806 : ;;;; ------------------------------------------------------------
1807 :
1808 : (defun ange-ftp-raw-send-cmd (proc cmd &optional msg cont nowait)
1809 : "Low-level routine to send the given FTP CMD to the FTP process PROC.
1810 : MSG is an optional message to output before and after the command.
1811 : If CONT is non-nil then it is either a function or a list of function
1812 : and some arguments. The function will be called when the FTP command
1813 : has completed.
1814 : If CONT is nil then this routine will return (RESULT . LINE) where RESULT
1815 : is whether the command was successful, and LINE is the line from the FTP
1816 : process that caused the command to complete.
1817 : If NOWAIT is given then the routine will return immediately the command has
1818 : been queued with no result. CONT will still be called, however."
1819 0 : (if (memq (process-status proc) '(run open))
1820 0 : (with-current-buffer (process-buffer proc)
1821 0 : (ange-ftp-wait-not-busy proc)
1822 0 : (setq ange-ftp-process-string ""
1823 : ange-ftp-process-result-line ""
1824 : ange-ftp-process-busy t
1825 : ange-ftp-process-result nil
1826 : ange-ftp-process-multi-skip nil
1827 0 : ange-ftp-process-msg msg
1828 0 : ange-ftp-process-continue cont
1829 : ange-ftp-hash-mark-count 0
1830 : ange-ftp-last-percent -1
1831 0 : cmd (concat cmd "\n"))
1832 0 : (and msg ange-ftp-process-verbose (ange-ftp-message "%s..." msg))
1833 0 : (goto-char (point-max))
1834 0 : (move-marker comint-last-input-start (point))
1835 : ;; don't insert the password into the buffer on the USER command.
1836 0 : (save-match-data
1837 0 : (if (string-match "\\`user \"[^\"]*\"" cmd)
1838 0 : (insert (substring cmd 0 (match-end 0)) " Turtle Power!\n")
1839 0 : (insert cmd)))
1840 0 : (move-marker comint-last-input-end (point))
1841 0 : (process-send-string proc cmd)
1842 0 : (set-marker (process-mark proc) (point))
1843 0 : (if nowait
1844 : nil
1845 0 : (ange-ftp-wait-not-busy proc)
1846 0 : (if cont
1847 : nil ;cont has already been called
1848 0 : (cons ange-ftp-process-result ange-ftp-process-result-line))))))
1849 :
1850 : ;; Wait for the ange-ftp process PROC not to be busy.
1851 : (defun ange-ftp-wait-not-busy (proc)
1852 0 : (with-current-buffer (process-buffer proc)
1853 0 : (condition-case nil
1854 : ;; This is a kludge to let user quit in case ftp gets hung.
1855 : ;; It matters because this function can be called from the filter.
1856 : ;; It is bad to allow quitting in a filter, but getting hung
1857 : ;; is worse. By binding quit-flag to nil, we might avoid
1858 : ;; most of the probability of getting screwed because the user
1859 : ;; wants to quit some command.
1860 0 : (let ((quit-flag nil)
1861 : (inhibit-quit nil))
1862 0 : (while ange-ftp-process-busy
1863 0 : (accept-process-output proc)))
1864 : (quit
1865 : ;; If the user does quit out of this,
1866 : ;; kill the process. That stops any transfer in progress.
1867 : ;; The next operation will open a new ftp connection.
1868 0 : (delete-process proc)
1869 0 : (signal 'quit nil)))))
1870 :
1871 : (defun ange-ftp-nslookup-host (hostname)
1872 : "Attempt to resolve the given HOSTNAME using nslookup if possible."
1873 : (interactive "sHost: ")
1874 0 : (if ange-ftp-nslookup-program
1875 0 : (let ((default-directory
1876 0 : (if (file-accessible-directory-p default-directory)
1877 0 : default-directory
1878 0 : exec-directory))
1879 : ;; It would be nice to make process-connection-type nil,
1880 : ;; but that doesn't work: ftp never responds.
1881 : ;; Can anyone find a fix for that?
1882 0 : (proc (let ((process-connection-type t))
1883 0 : (start-process " *nslookup*" " *nslookup*"
1884 0 : ange-ftp-nslookup-program hostname)))
1885 0 : (res hostname))
1886 0 : (set-process-query-on-exit-flag proc nil)
1887 0 : (with-current-buffer (process-buffer proc)
1888 0 : (while (memq (process-status proc) '(run open))
1889 0 : (accept-process-output proc))
1890 0 : (goto-char (point-min))
1891 0 : (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
1892 0 : (setq res (match-string 1)))
1893 0 : (kill-buffer (current-buffer)))
1894 0 : res)
1895 0 : hostname))
1896 :
1897 : (defun ange-ftp-start-process (host user name)
1898 : "Spawn a new FTP process ready to connect to machine HOST and give it NAME.
1899 : If HOST is only FTP-able through a gateway machine then spawn a shell
1900 : on the gateway machine to do the FTP instead."
1901 : ;; If `non-essential' is non-nil, don't reopen a new connection. It
1902 : ;; will be caught in Tramp.
1903 0 : (when non-essential
1904 0 : (throw 'non-essential 'non-essential))
1905 0 : (let* ((use-gateway (ange-ftp-use-gateway-p host))
1906 0 : (use-smart-ftp (and (not ange-ftp-gateway-host)
1907 0 : (ange-ftp-use-smart-gateway-p host)))
1908 0 : (ftp-prog (if (or use-gateway
1909 0 : use-smart-ftp)
1910 0 : ange-ftp-gateway-ftp-program-name
1911 0 : ange-ftp-ftp-program-name))
1912 0 : (args (append (list ftp-prog) ange-ftp-ftp-program-args))
1913 : ;; Without the following binding, ange-ftp-start-process
1914 : ;; recurses on file-accessible-directory-p, since it needs to
1915 : ;; restart its process in order to determine anything about
1916 : ;; default-directory.
1917 : (file-name-handler-alist)
1918 : (default-directory
1919 0 : (if (file-accessible-directory-p default-directory)
1920 0 : default-directory
1921 0 : exec-directory))
1922 : proc)
1923 : ;; It would be nice to make process-connection-type nil,
1924 : ;; but that doesn't work: ftp never responds.
1925 : ;; Can anyone find a fix for that?
1926 0 : (let ((process-connection-type t)
1927 : ;; Copy this so we don't alter it permanently.
1928 0 : (process-environment (copy-tree process-environment))
1929 0 : (buffer (get-buffer-create name)))
1930 0 : (with-current-buffer buffer
1931 0 : (internal-ange-ftp-mode))
1932 : ;; This tells GNU ftp not to output any fancy escape sequences.
1933 0 : (setenv "TERM" "dumb")
1934 0 : (if use-gateway
1935 0 : (if ange-ftp-gateway-program-interactive
1936 0 : (setq proc (ange-ftp-gwp-start host user name args))
1937 0 : (setq proc (apply 'start-process name name
1938 0 : (append (list ange-ftp-gateway-program
1939 0 : ange-ftp-gateway-host)
1940 0 : args))))
1941 0 : (setq proc (apply 'start-process name name args))))
1942 0 : (with-current-buffer (process-buffer proc)
1943 0 : (goto-char (point-max))
1944 0 : (set-marker (process-mark proc) (point)))
1945 0 : (set-process-query-on-exit-flag proc nil)
1946 0 : (set-process-sentinel proc 'ange-ftp-process-sentinel)
1947 0 : (set-process-filter proc 'ange-ftp-process-filter)
1948 : ;; On Windows, the standard ftp client buffers its output (because
1949 : ;; stdout is a pipe handle) so the startup message may never appear:
1950 : ;; `accept-process-output' at this point would hang indefinitely.
1951 : ;; However, sending an innocuous command ("help foo") forces some
1952 : ;; output that will be ignored, which is just as good. Once we
1953 : ;; start sending normal commands, the output no longer appears to be
1954 : ;; buffered, and everything works correctly. My guess is that the
1955 : ;; output of interest is being sent to stderr which is not buffered.
1956 0 : (when (eq system-type 'windows-nt)
1957 : ;; force ftp output to be treated as DOS text, otherwise the
1958 : ;; output of "help foo" confuses the EOL detection logic.
1959 0 : (set-process-coding-system proc 'raw-text-dos)
1960 0 : (process-send-string proc "help foo\n"))
1961 0 : (accept-process-output proc) ;wait for ftp startup message
1962 0 : proc))
1963 :
1964 : (define-derived-mode internal-ange-ftp-mode comint-mode "Internal Ange-ftp"
1965 : "Major mode for interacting with the FTP process.
1966 :
1967 : \\{comint-mode-map}"
1968 0 : (make-local-variable 'ange-ftp-process-string)
1969 0 : (setq ange-ftp-process-string "")
1970 0 : (make-local-variable 'ange-ftp-process-busy)
1971 0 : (make-local-variable 'ange-ftp-process-result)
1972 0 : (make-local-variable 'ange-ftp-process-msg)
1973 0 : (make-local-variable 'ange-ftp-process-multi-skip)
1974 0 : (make-local-variable 'ange-ftp-process-result-line)
1975 0 : (make-local-variable 'ange-ftp-process-continue)
1976 0 : (make-local-variable 'ange-ftp-hash-mark-count)
1977 0 : (make-local-variable 'ange-ftp-binary-hash-mark-size)
1978 0 : (make-local-variable 'ange-ftp-ascii-hash-mark-size)
1979 0 : (make-local-variable 'ange-ftp-hash-mark-unit)
1980 0 : (make-local-variable 'ange-ftp-xfer-size)
1981 0 : (make-local-variable 'ange-ftp-last-percent)
1982 0 : (setq ange-ftp-hash-mark-count 0)
1983 0 : (setq ange-ftp-xfer-size 0)
1984 0 : (setq ange-ftp-process-result-line "")
1985 0 : (setq comint-prompt-regexp "^ftp> ")
1986 0 : (make-local-variable 'comint-password-prompt-regexp)
1987 : ;; This is a regexp that can't match anything.
1988 : ;; ange-ftp has its own ways of handling passwords.
1989 0 : (setq comint-password-prompt-regexp "\\`a\\`")
1990 0 : (make-local-variable 'paragraph-start)
1991 0 : (setq paragraph-start comint-prompt-regexp))
1992 :
1993 : (defcustom ange-ftp-raw-login nil
1994 : "Use raw FTP commands for login, if account password is not nil.
1995 : Some FTP implementations need this, e.g. ftp in NT 4.0."
1996 : :group 'ange-ftp
1997 : :version "21.3"
1998 : :type 'boolean)
1999 :
2000 : (defun ange-ftp-smart-login (host user password account proc)
2001 : "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT.
2002 : PROC is the FTP-client's process. This routine uses the smart-gateway
2003 : host specified in `ange-ftp-gateway-host'."
2004 0 : (let ((result (ange-ftp-raw-send-cmd
2005 0 : proc
2006 0 : (format "open %s %s"
2007 0 : (ange-ftp-nslookup-host ange-ftp-gateway-host)
2008 0 : ange-ftp-smart-gateway-port)
2009 0 : (format "Opening FTP connection to %s via %s"
2010 0 : host
2011 0 : ange-ftp-gateway-host))))
2012 0 : (or (car result)
2013 0 : (ange-ftp-error host user
2014 0 : (concat "OPEN request failed: "
2015 0 : (cdr result))))
2016 0 : (setq result (ange-ftp-raw-send-cmd
2017 0 : proc (format "user \"%s\"@%s %s %s"
2018 0 : user
2019 0 : (ange-ftp-nslookup-host host)
2020 0 : password
2021 0 : account)
2022 0 : (format "Logging in as user %s@%s"
2023 0 : user host)))
2024 0 : (or (car result)
2025 0 : (progn
2026 0 : (ange-ftp-set-passwd host user nil) ; reset password
2027 0 : (ange-ftp-set-account host user nil) ; reset account
2028 0 : (ange-ftp-error host user
2029 0 : (concat "USER request failed: "
2030 0 : (cdr result)))))))
2031 :
2032 : (defun ange-ftp-normal-login (host user password account proc)
2033 : "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT.
2034 : PROC is the process to the FTP-client. HOST may have an optional
2035 : suffix of the form #PORT to specify a non-default port."
2036 0 : (save-match-data
2037 0 : (string-match "\\`\\([^#]+\\)\\(#\\([0-9]+\\)\\)?\\'" host)
2038 0 : (let* ((nshost (ange-ftp-nslookup-host (match-string 1 host)))
2039 0 : (port (match-string 3 host))
2040 0 : (result (ange-ftp-raw-send-cmd
2041 0 : proc
2042 0 : (if port
2043 0 : (format "open %s %s" nshost port)
2044 0 : (format "open %s" nshost))
2045 0 : (format "Opening FTP connection to %s" host))))
2046 0 : (or (car result)
2047 0 : (ange-ftp-error host user
2048 0 : (concat "OPEN request failed: "
2049 0 : (cdr result))))
2050 0 : (if (not (and ange-ftp-raw-login (string< "" account)))
2051 0 : (setq result (ange-ftp-raw-send-cmd
2052 0 : proc
2053 0 : (if (and (ange-ftp-use-smart-gateway-p host)
2054 0 : ange-ftp-gateway-host)
2055 0 : (format "user \"%s\"@%s %s %s"
2056 0 : user nshost password account)
2057 0 : (format "user \"%s\" %s %s" user password account))
2058 0 : (format "Logging in as user %s@%s" user host)))
2059 0 : (let ((good ange-ftp-good-msgs)
2060 0 : (skip ange-ftp-skip-msgs))
2061 0 : (setq ange-ftp-good-msgs (concat ange-ftp-good-msgs
2062 0 : "\\|^331 \\|^332 "))
2063 0 : (if (string-match (regexp-quote "\\|^331 ") ange-ftp-skip-msgs)
2064 0 : (setq ange-ftp-skip-msgs
2065 0 : (replace-match "" t t ange-ftp-skip-msgs)))
2066 0 : (if (string-match (regexp-quote "\\|^332 ") ange-ftp-skip-msgs)
2067 0 : (setq ange-ftp-skip-msgs
2068 0 : (replace-match "" t t ange-ftp-skip-msgs)))
2069 0 : (setq result (ange-ftp-raw-send-cmd
2070 0 : proc
2071 0 : (format "quote \"USER %s\"" user)
2072 0 : (format "Logging in as user %s@%s" user host)))
2073 0 : (and (car result)
2074 0 : (setq result (ange-ftp-raw-send-cmd
2075 0 : proc
2076 0 : (format "quote \"PASS %s\"" password)
2077 0 : (format "Logging in as user %s@%s" user host)))
2078 0 : (and (car result)
2079 0 : (setq result (ange-ftp-raw-send-cmd
2080 0 : proc
2081 0 : (format "quote \"ACCT %s\"" account)
2082 0 : (format "Logging in as user %s@%s" user host)))
2083 0 : ))
2084 0 : (setq ange-ftp-good-msgs good
2085 0 : ange-ftp-skip-msgs skip)))
2086 0 : (or (car result)
2087 0 : (progn
2088 0 : (ange-ftp-set-passwd host user nil) ;reset password.
2089 0 : (ange-ftp-set-account host user nil) ;reset account.
2090 0 : (ange-ftp-error host user
2091 0 : (concat "USER request failed: "
2092 0 : (cdr result))))))))
2093 :
2094 : ;; ange@hplb.hpl.hp.com says this should not be changed.
2095 : (defvar ange-ftp-hash-mark-msgs
2096 : "[hH]ash mark [^0-9]*\\([0-9]+\\)"
2097 : "Regexp matching the FTP client's output upon doing a HASH command.")
2098 :
2099 : (defun ange-ftp-guess-hash-mark-size (proc)
2100 0 : (if ange-ftp-send-hash
2101 0 : (with-current-buffer (process-buffer proc)
2102 0 : (let* ((status (ange-ftp-raw-send-cmd proc "hash"))
2103 0 : (line (cdr status)))
2104 0 : (save-match-data
2105 0 : (if (string-match ange-ftp-hash-mark-msgs line)
2106 0 : (let ((size (string-to-number (match-string 1 line))))
2107 0 : (setq ange-ftp-ascii-hash-mark-size size
2108 0 : ange-ftp-hash-mark-unit (ash size -4))
2109 :
2110 : ;; if a default value for this is set, use that value.
2111 0 : (or ange-ftp-binary-hash-mark-size
2112 0 : (setq ange-ftp-binary-hash-mark-size size)))))))))
2113 :
2114 : (defvar ange-ftp-process-startup-hook nil)
2115 :
2116 : (defun ange-ftp-get-process (host user)
2117 : "Return an FTP subprocess connected to HOST and logged in as USER.
2118 : Create a new process if needed."
2119 0 : (let* ((name (ange-ftp-ftp-process-buffer host user))
2120 0 : (proc (get-process name)))
2121 0 : (if (and proc (memq (process-status proc) '(run open)))
2122 0 : proc
2123 : ;; If `non-essential' is non-nil, don't reopen a new connection. It
2124 : ;; will be caught in Tramp.
2125 0 : (when non-essential
2126 0 : (throw 'non-essential 'non-essential))
2127 :
2128 : ;; Must delete dead process so that new process can reuse the name.
2129 0 : (if proc (delete-process proc))
2130 0 : (let ((pass (ange-ftp-quote-string
2131 0 : (ange-ftp-get-passwd host user)))
2132 0 : (account (ange-ftp-quote-string
2133 0 : (ange-ftp-get-account host user))))
2134 : ;; grab a suitable process.
2135 0 : (setq proc (ange-ftp-start-process host user name))
2136 :
2137 : ;; login to FTP server.
2138 0 : (if (and (ange-ftp-use-smart-gateway-p host)
2139 0 : ange-ftp-gateway-host)
2140 0 : (ange-ftp-smart-login host user pass account proc)
2141 0 : (ange-ftp-normal-login host user pass account proc))
2142 :
2143 : ;; Tell client to send back hash-marks as progress. It isn't usually
2144 : ;; fatal if this command fails.
2145 0 : (ange-ftp-guess-hash-mark-size proc)
2146 :
2147 : ;; Guess at the host type.
2148 0 : (ange-ftp-guess-host-type host user)
2149 :
2150 : ;; Turn passive mode on or off as requested.
2151 0 : (let* ((case-fold-search t)
2152 : (passive
2153 0 : (or (assoc-default host ange-ftp-passive-host-alist
2154 0 : 'string-match)
2155 0 : (if ange-ftp-try-passive-mode "on"))))
2156 0 : (if passive
2157 0 : (ange-ftp-passive-mode proc passive)))
2158 :
2159 : ;; Run any user-specified hooks. Note that proc, host and user are
2160 : ;; dynamically bound at this point.
2161 0 : (let ((ange-ftp-this-user user)
2162 0 : (ange-ftp-this-host host))
2163 0 : (run-hooks 'ange-ftp-process-startup-hook)))
2164 0 : proc)))
2165 :
2166 : (defun ange-ftp-passive-mode (proc on-or-off)
2167 0 : (if (string-match (concat "Passive mode " on-or-off)
2168 0 : (cdr (ange-ftp-raw-send-cmd
2169 0 : proc (concat "passive " on-or-off)
2170 0 : "Trying passive mode..." nil)))
2171 0 : (ange-ftp-message (concat "Trying passive mode..." on-or-off))
2172 0 : (error "Trying passive mode...failed")))
2173 :
2174 : ;; Variables for caching host and host-type
2175 : (defvar ange-ftp-host-cache nil)
2176 : (defvar ange-ftp-host-type-cache nil)
2177 :
2178 : ;; If ange-ftp-host-type is called with the optional user
2179 : ;; argument, it will attempt to guess the host type by connecting
2180 : ;; as user, if necessary. For efficiency, I have tried to give this
2181 : ;; optional second argument only when necessary. Have I missed any calls
2182 : ;; to ange-ftp-host-type where it should have been supplied?
2183 :
2184 : (defun ange-ftp-host-type (host &optional user)
2185 : "Return a symbol which represents the type of the HOST given.
2186 : If the optional argument USER is given, attempts to guess the
2187 : host-type by logging in as USER."
2188 0 : (cond ((null host) 'unix)
2189 : ;; Return `unix' if HOST is nil, since that's the most vanilla
2190 : ;; possible return value.
2191 0 : ((eq host ange-ftp-host-cache)
2192 0 : ange-ftp-host-type-cache)
2193 : ;; Trigger an ftp connection, in case we need to guess at the host type.
2194 0 : ((and user (ange-ftp-get-process host user) (eq host ange-ftp-host-cache))
2195 0 : ange-ftp-host-type-cache)
2196 : (t
2197 0 : (setq ange-ftp-host-cache host
2198 : ange-ftp-host-type-cache
2199 0 : (cond ((ange-ftp-dumb-unix-host host)
2200 : 'dumb-unix)
2201 : ;; ((and (fboundp 'ange-ftp-vos-host)
2202 : ;; (ange-ftp-vos-host host))
2203 : ;; 'vos)
2204 0 : ((and (fboundp 'ange-ftp-vms-host)
2205 0 : (ange-ftp-vms-host host))
2206 : 'vms)
2207 0 : ((and (fboundp 'ange-ftp-mts-host)
2208 0 : (ange-ftp-mts-host host))
2209 : 'mts)
2210 0 : ((and (fboundp 'ange-ftp-cms-host)
2211 0 : (ange-ftp-cms-host host))
2212 : 'cms)
2213 0 : ((and (fboundp 'ange-ftp-bs2000-posix-host)
2214 0 : (ange-ftp-bs2000-posix-host host))
2215 : 'text-unix) ; POSIX is a non-ASCII Unix
2216 0 : ((and (fboundp 'ange-ftp-bs2000-host)
2217 0 : (ange-ftp-bs2000-host host))
2218 : 'bs2000)
2219 : (t
2220 0 : 'unix))))))
2221 :
2222 : ;; It would be nice to abstract the functions ange-ftp-TYPE-host and
2223 : ;; ange-ftp-add-TYPE-host. The trick is to abstract these functions
2224 : ;; without sacrificing speed. Also, having separate variables
2225 : ;; ange-ftp-TYPE-regexp is more user friendly then requiring the user to
2226 : ;; set an alist to indicate that a host is of a given type. Even with
2227 : ;; automatic host type recognition, setting a regexp is still a good idea
2228 : ;; (for efficiency) if you log into a particular non-UNIX host frequently.
2229 :
2230 : (defvar ange-ftp-fix-name-func-alist nil
2231 : "Alist saying how to convert file name to the host's syntax.
2232 : Association list of (TYPE . FUNC) pairs, where FUNC is a routine which can
2233 : change a UNIX file name into a name more suitable for a host of type TYPE.")
2234 :
2235 : (defvar ange-ftp-fix-dir-name-func-alist nil
2236 : "Alist saying how to convert directory name to the host's syntax.
2237 : Association list of (TYPE . FUNC) pairs, where FUNC is a routine which can
2238 : change UNIX directory name into a directory name more suitable for a host
2239 : of type TYPE.")
2240 :
2241 : ;; *** Perhaps the sense of this variable should be inverted, since there
2242 : ;; *** is only 1 host type that can take ls-style listing options.
2243 : (defvar ange-ftp-dumb-host-types '(dumb-unix)
2244 : "List of host types that can't take UNIX ls-style listing options.")
2245 :
2246 : (defun ange-ftp-send-cmd (host user cmd &optional msg cont nowait)
2247 : "Find an FTP process connected to HOST logged in as USER and send it CMD.
2248 : MSG is an optional status message to be output before and after issuing the
2249 : command.
2250 : See the documentation for `ange-ftp-raw-send-cmd' for a description of CONT
2251 : and NOWAIT."
2252 : ;; Handle conversion to remote file name syntax and remote ls option
2253 : ;; capability.
2254 0 : (let ((cmd0 (car cmd))
2255 0 : (cmd1 (nth 1 cmd))
2256 0 : (ange-ftp-this-user user)
2257 0 : (ange-ftp-this-host host)
2258 0 : (ange-ftp-this-msg msg)
2259 : cmd2 cmd3 host-type fix-name-func result)
2260 :
2261 0 : (cond
2262 :
2263 : ;; pwd case (We don't care what host-type.)
2264 0 : ((null cmd1))
2265 :
2266 : ;; cmd == 'dir "remote-name" "local-name" "ls-switches"
2267 0 : ((progn
2268 0 : (setq cmd2 (nth 2 cmd)
2269 0 : host-type (ange-ftp-host-type host user))
2270 : ;; This will trigger an FTP login, if one doesn't exist
2271 0 : (eq cmd0 'dir))
2272 0 : (setq cmd1 (funcall
2273 0 : (or (cdr (assq host-type ange-ftp-fix-dir-name-func-alist))
2274 0 : 'identity)
2275 0 : cmd1)
2276 0 : cmd3 (nth 3 cmd))
2277 : ;; Need to deal with the HP-UX ftp bug. This should also allow us to
2278 : ;; resolve symlinks to directories on SysV machines. (Sebastian will
2279 : ;; be happy.)
2280 0 : (and (eq host-type 'unix)
2281 0 : (string-match "/\\'" cmd1)
2282 0 : (not (string-match "R" cmd3))
2283 0 : (setq cmd1 (concat cmd1 ".")))
2284 :
2285 : ;; Using "ls -flags foo" has several problems:
2286 : ;; - if foo is a symlink, we may get a single line showing the symlink
2287 : ;; rather than the listing of the directory it points to.
2288 : ;; - if "foo" has spaces, the parsing of the command may be done wrong.
2289 : ;; - some version of netbsd's ftpd only accept a single argument after
2290 : ;; `ls', which can either be the directory or the flags.
2291 : ;; So to work around those problems, we use "cd foo; ls -flags".
2292 :
2293 : ;; If the dir name contains a space, some ftp servers will
2294 : ;; refuse to list it. We instead change directory to the
2295 : ;; directory in question and ls ".".
2296 0 : (when (string-match " " cmd1)
2297 : ;; Keep the result. In case of failure, we will (see below)
2298 : ;; short-circuit CMD and return this result directly.
2299 0 : (setq result (ange-ftp-cd host user (nth 1 cmd) 'noerror))
2300 0 : (setq cmd1 "."))
2301 :
2302 : ;; If the remote ls can take switches, put them in
2303 0 : (unless (memq host-type ange-ftp-dumb-host-types)
2304 0 : (setq cmd0 'ls)
2305 : ;; We cd and then use `ls' with no directory argument.
2306 : ;; This works around a misfeature of some versions of netbsd ftpd
2307 : ;; where `ls' can only take one argument: either one set of flags
2308 : ;; or a file/directory name.
2309 : ;; If we're trying to `ls' a single file, this fails since we
2310 : ;; can't cd to a file. We can't fix this problem here, tho, because
2311 : ;; at this point we don't know whether the argument is a file or
2312 : ;; a directory. Such an `ls' is only ever used (apparently) from
2313 : ;; `insert-directory' when the `full-directory-p' argument is nil
2314 : ;; (which seems to only be used by dired when updating its display
2315 : ;; after operating on a set of files). So we've changed
2316 : ;; `ange-ftp-insert-directory' such that in this case it gets
2317 : ;; a full listing of the directory and extracting the line
2318 : ;; corresponding to the requested file.
2319 0 : (unless (equal cmd1 ".")
2320 0 : (setq result (ange-ftp-cd host user (nth 1 cmd) 'noerror)))
2321 0 : (setq cmd1 cmd3)))
2322 :
2323 : ;; First argument is the remote name
2324 0 : ((progn
2325 0 : (setq fix-name-func (or (cdr (assq host-type
2326 0 : ange-ftp-fix-name-func-alist))
2327 0 : 'identity))
2328 0 : (memq cmd0 '(get delete mkdir rmdir cd)))
2329 0 : (setq cmd1 (funcall fix-name-func cmd1)))
2330 :
2331 : ;; Second argument is the remote name
2332 0 : ((or (memq cmd0 '(append put chmod))
2333 0 : (and (eq cmd0 'quote) (member cmd1 '("mdtm" "size"))))
2334 0 : (setq cmd2 (funcall fix-name-func cmd2)))
2335 : ;; Both arguments are remote names
2336 0 : ((eq cmd0 'rename)
2337 0 : (setq cmd1 (funcall fix-name-func cmd1)
2338 0 : cmd2 (funcall fix-name-func cmd2))))
2339 :
2340 : ;; Turn the command into one long string
2341 0 : (setq cmd0 (symbol-name cmd0))
2342 0 : (setq cmd (concat cmd0
2343 0 : (and cmd1 (concat " " cmd1))
2344 0 : (and cmd2 (concat " " cmd2))))
2345 :
2346 : ;; Actually send the resulting command.
2347 0 : (if (and (consp result) (null (car result)))
2348 : ;; `ange-ftp-cd' has failed, so there's no point sending `cmd'.
2349 0 : result
2350 0 : (let (afsc-result
2351 : afsc-line)
2352 0 : (ange-ftp-raw-send-cmd
2353 0 : (ange-ftp-get-process host user)
2354 0 : cmd
2355 0 : msg
2356 0 : (list (lambda (result line host user cmd msg cont nowait)
2357 0 : (or cont (setq afsc-result result
2358 0 : afsc-line line))
2359 0 : (if result (ange-ftp-call-cont cont result line)
2360 0 : (ange-ftp-raw-send-cmd
2361 0 : (ange-ftp-get-process host user)
2362 0 : cmd
2363 0 : msg
2364 0 : (list (lambda (result line cont)
2365 0 : (or cont (setq afsc-result result
2366 0 : afsc-line line))
2367 0 : (ange-ftp-call-cont cont result line))
2368 0 : cont)
2369 0 : nowait)))
2370 0 : host user cmd msg cont nowait)
2371 0 : nowait)
2372 :
2373 0 : (if nowait
2374 : nil
2375 0 : (if cont
2376 : nil
2377 0 : (cons afsc-result afsc-line)))))))
2378 :
2379 : ;; It might be nice to message users about the host type identified,
2380 : ;; but there is so much other messaging going on, it would not be
2381 : ;; seen. No point in slowing things down just so users can read
2382 : ;; a host type message.
2383 :
2384 : (defconst ange-ftp-cms-name-template
2385 : (concat
2386 : "^[-A-Z0-9$*][-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?"
2387 : "[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?\\.[0-9][0-9][0-9A-Z]$"))
2388 : (defconst ange-ftp-vms-name-template
2389 : "^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$")
2390 : (defconst ange-ftp-mts-name-template
2391 : "^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$")
2392 : (defconst ange-ftp-bs2000-filename-pubset-regexp
2393 : ":[A-Z0-9]+:"
2394 : "Valid pubset for an BS2000 file name.")
2395 : (defconst ange-ftp-bs2000-filename-username-regexp
2396 : (concat
2397 : "\\$[A-Z0-9]*\\.")
2398 : "Valid username for an BS2000 file name.")
2399 : (defconst ange-ftp-bs2000-filename-prefix-regexp
2400 : (concat
2401 : ange-ftp-bs2000-filename-pubset-regexp
2402 : ange-ftp-bs2000-filename-username-regexp)
2403 : "Valid prefix for an BS2000 file name (pubset and user).")
2404 : (defconst ange-ftp-bs2000-name-template
2405 : (concat "^" ange-ftp-bs2000-filename-prefix-regexp "$"))
2406 :
2407 : (defun ange-ftp-guess-host-type (host user)
2408 : "Guess the host type of HOST.
2409 : Works by doing a pwd and examining the directory syntax."
2410 0 : (let ((host-type (ange-ftp-host-type host))
2411 0 : (key (concat host "/" user "/~")))
2412 0 : (if (eq host-type 'unix)
2413 : ;; Note that ange-ftp-host-type returns unix as the default value.
2414 0 : (save-match-data
2415 0 : (let* ((result (ange-ftp-get-pwd host user))
2416 0 : (dir (car result))
2417 : fix-name-func)
2418 0 : (cond ((null dir)
2419 0 : (message "Warning! Unable to get home directory")
2420 0 : (sit-for 1)
2421 0 : (if (string-match
2422 : "^450 No current working directory defined$"
2423 0 : (cdr result))
2424 :
2425 : ;; We'll assume that if pwd bombs with this
2426 : ;; error message, then it's CMS.
2427 0 : (progn
2428 0 : (ange-ftp-add-cms-host host)
2429 0 : (setq ange-ftp-host-cache host
2430 0 : ange-ftp-host-type-cache 'cms))))
2431 :
2432 : ;; try for VMS
2433 0 : ((string-match ange-ftp-vms-name-template dir)
2434 0 : (ange-ftp-add-vms-host host)
2435 : ;; The add-host functions clear the host type cache.
2436 : ;; Therefore, need to set the cache afterwards.
2437 0 : (setq ange-ftp-host-cache host
2438 0 : ange-ftp-host-type-cache 'vms))
2439 :
2440 : ;; try for MTS
2441 0 : ((string-match ange-ftp-mts-name-template dir)
2442 0 : (ange-ftp-add-mts-host host)
2443 0 : (setq ange-ftp-host-cache host
2444 0 : ange-ftp-host-type-cache 'mts))
2445 :
2446 : ;; try for CMS
2447 0 : ((string-match ange-ftp-cms-name-template dir)
2448 0 : (ange-ftp-add-cms-host host)
2449 0 : (setq ange-ftp-host-cache host
2450 0 : ange-ftp-host-type-cache 'cms))
2451 :
2452 : ;; try for BS2000-POSIX
2453 0 : ((ange-ftp-bs2000-posix-host host)
2454 0 : (ange-ftp-add-bs2000-host host)
2455 0 : (setq ange-ftp-host-cache host
2456 0 : ange-ftp-host-type-cache 'text-unix))
2457 : ;; try for BS2000
2458 0 : ((and (string-match ange-ftp-bs2000-name-template dir)
2459 0 : (not (ange-ftp-bs2000-posix-host host)))
2460 0 : (ange-ftp-add-bs2000-host host)
2461 0 : (setq ange-ftp-host-cache host
2462 0 : ange-ftp-host-type-cache 'bs2000))
2463 : ;; assume UN*X
2464 : (t
2465 0 : (setq ange-ftp-host-cache host
2466 0 : ange-ftp-host-type-cache 'unix)))
2467 :
2468 : ;; Now that we have done a pwd, might as well put it in
2469 : ;; the expand-dir hashtable.
2470 0 : (let ((ange-ftp-this-user user)
2471 0 : (ange-ftp-this-host host))
2472 0 : (setq fix-name-func (cdr (assq ange-ftp-host-type-cache
2473 0 : ange-ftp-fix-name-func-alist)))
2474 0 : (if fix-name-func
2475 0 : (setq dir (funcall fix-name-func dir 'reverse))))
2476 0 : (puthash key dir ange-ftp-expand-dir-hashtable))))
2477 :
2478 : ;; In the special case of CMS make sure that know the
2479 : ;; expansion of the home minidisk now, because we will
2480 : ;; be doing a lot of cd's.
2481 0 : (if (and (eq host-type 'cms)
2482 0 : (not (ange-ftp-hash-entry-exists-p
2483 0 : key ange-ftp-expand-dir-hashtable)))
2484 0 : (let ((dir (car (ange-ftp-get-pwd host user))))
2485 0 : (if dir
2486 0 : (puthash key (concat "/" dir) ange-ftp-expand-dir-hashtable)
2487 0 : (message "Warning! Unable to get home directory")
2488 0 : (sit-for 1))))))
2489 :
2490 :
2491 : ;;;; ------------------------------------------------------------
2492 : ;;;; Remote file and directory listing support.
2493 : ;;;; ------------------------------------------------------------
2494 :
2495 : ;; Returns whether HOST's FTP server doesn't like 'ls' or 'dir' commands
2496 : ;; to take switch arguments.
2497 : (defun ange-ftp-dumb-unix-host (host)
2498 0 : (and host ange-ftp-dumb-unix-host-regexp
2499 0 : (string-match-p ange-ftp-dumb-unix-host-regexp host)))
2500 :
2501 : (defun ange-ftp-add-dumb-unix-host (host)
2502 : "Interactively add a given HOST to `ange-ftp-dumb-unix-host-regexp'."
2503 : (interactive
2504 0 : (list (read-string "Host: "
2505 0 : (let ((name (or (buffer-file-name) default-directory)))
2506 0 : (and name (car (ange-ftp-ftp-name name)))))))
2507 0 : (if (not (ange-ftp-dumb-unix-host host))
2508 0 : (setq ange-ftp-dumb-unix-host-regexp
2509 0 : (concat "^" (regexp-quote host) "$"
2510 0 : (and ange-ftp-dumb-unix-host-regexp "\\|")
2511 0 : ange-ftp-dumb-unix-host-regexp)
2512 0 : ange-ftp-host-cache nil)))
2513 :
2514 : (defvar ange-ftp-parse-list-func-alist nil
2515 : "Alist saying how to parse directory listings for certain OS types.
2516 : Association list of (TYPE . FUNC) pairs. The FUNC is a routine which
2517 : can parse the output from a DIR listing for a host of type TYPE.")
2518 :
2519 : ;; With no-error nil, this function returns:
2520 : ;; an error if file is not an ange-ftp-name
2521 : ;; (This should never happen.)
2522 : ;; an error if either the listing is unreadable or there is an ftp error.
2523 : ;; the listing (a string), if everything works.
2524 : ;;
2525 : ;; With no-error t, it returns:
2526 : ;; an error if not an ange-ftp-name
2527 : ;; error if listing is unreadable (most likely caused by a slow connection)
2528 : ;; nil if ftp error (this is because although asking to list a nonexistent
2529 : ;; directory on a remote unix machine usually (except
2530 : ;; maybe for dumb hosts) returns an ls error, but no
2531 : ;; ftp error, if the same is done on a VMS machine,
2532 : ;; an ftp error is returned. Need to trap the error
2533 : ;; so we can go on and try to list the parent.)
2534 : ;; the listing, if everything works.
2535 :
2536 : ;; If WILDCARD is non-nil, then this implements the guts of insert-directory
2537 : ;; in the wildcard case. Then we make a relative directory listing
2538 : ;; of FILE within the directory specified by `default-directory'.
2539 :
2540 : (defvar ange-ftp-before-parse-ls-hook nil
2541 : "Normal hook run before parsing the text of an FTP directory listing.")
2542 :
2543 : (defvar ange-ftp-after-parse-ls-hook nil
2544 : "Normal hook run after parsing the text of an FTP directory listing.")
2545 :
2546 : (defun ange-ftp-ls (file lsargs parse &optional no-error wildcard)
2547 : "Return the output of a `DIR' or `ls' command done over FTP.
2548 : FILE is the full name of the remote file, LSARGS is any args to pass to the
2549 : `ls' command, and PARSE specifies that the output should be parsed and stored
2550 : away in the internal cache."
2551 0 : (when (string-match "^--dired\\s-+" lsargs)
2552 0 : (setq lsargs (replace-match "" nil t lsargs)))
2553 : ;; If parse is t, we assume that file is a directory. i.e. we only parse
2554 : ;; full directory listings.
2555 0 : (let* ((ange-ftp-this-file (ange-ftp-expand-file-name file))
2556 0 : (parsed (ange-ftp-ftp-name ange-ftp-this-file)))
2557 0 : (if parsed
2558 0 : (let* ((host (nth 0 parsed))
2559 0 : (user (nth 1 parsed))
2560 0 : (name (ange-ftp-quote-string (nth 2 parsed)))
2561 0 : (key (directory-file-name ange-ftp-this-file))
2562 0 : (host-type (ange-ftp-host-type host user))
2563 0 : (dumb (memq host-type ange-ftp-dumb-host-types))
2564 : result
2565 : temp
2566 : lscmd parse-func)
2567 0 : (if (string-equal name "")
2568 0 : (setq name
2569 0 : (ange-ftp-real-file-name-as-directory
2570 0 : (ange-ftp-expand-dir host user "~"))))
2571 0 : (if (and ange-ftp-ls-cache-file
2572 0 : (string-equal key ange-ftp-ls-cache-file)
2573 : ;; Don't care about lsargs for dumb hosts.
2574 0 : (or dumb (string-equal lsargs ange-ftp-ls-cache-lsargs)))
2575 0 : ange-ftp-ls-cache-res
2576 0 : (setq temp (ange-ftp-make-tmp-name host))
2577 0 : (if wildcard
2578 0 : (progn
2579 0 : (ange-ftp-cd host user (file-name-directory name))
2580 0 : (setq lscmd (list 'ls file temp lsargs)))
2581 0 : (setq lscmd (list 'dir name temp lsargs)))
2582 0 : (unwind-protect
2583 0 : (if (car (setq result (ange-ftp-send-cmd
2584 0 : host
2585 0 : user
2586 0 : lscmd
2587 0 : (format "Listing %s"
2588 0 : (ange-ftp-abbreviate-filename
2589 0 : ange-ftp-this-file)))))
2590 0 : (with-current-buffer (get-buffer-create
2591 0 : ange-ftp-data-buffer-name)
2592 0 : (erase-buffer)
2593 0 : (if (ange-ftp-real-file-readable-p temp)
2594 0 : (ange-ftp-real-insert-file-contents temp)
2595 0 : (sleep-for ange-ftp-retry-time)
2596 : ;wait for file to possibly appear
2597 0 : (if (ange-ftp-real-file-readable-p temp)
2598 : ;; Try again.
2599 0 : (ange-ftp-real-insert-file-contents temp)
2600 0 : (ange-ftp-error host user
2601 0 : (format
2602 : "list data file %s not readable"
2603 0 : temp))))
2604 : ;; remove ^M inserted by the w32 ftp client
2605 0 : (while (re-search-forward "\r$" nil t)
2606 0 : (replace-match ""))
2607 0 : (goto-char 1)
2608 0 : (run-hooks 'ange-ftp-before-parse-ls-hook)
2609 0 : (if parse
2610 0 : (ange-ftp-set-files
2611 0 : ange-ftp-this-file
2612 0 : (if (setq
2613 : parse-func
2614 0 : (cdr (assq host-type
2615 0 : ange-ftp-parse-list-func-alist)))
2616 0 : (funcall parse-func)
2617 0 : (ange-ftp-parse-dired-listing lsargs))))
2618 : ;; Place this hook here to convert the contents of the
2619 : ;; buffer to a ls compatible format if the host system
2620 : ;; that is being queried is other than Unix i.e. VMS
2621 : ;; returns an ls format that really sucks.
2622 0 : (run-hooks 'ange-ftp-after-parse-ls-hook)
2623 0 : (setq ange-ftp-ls-cache-file key
2624 0 : ange-ftp-ls-cache-lsargs lsargs
2625 : ; For dumb hosts-types this is
2626 : ; meaningless but harmless.
2627 0 : ange-ftp-ls-cache-res (buffer-string))
2628 : ;; (kill-buffer (current-buffer))
2629 0 : (if (equal ange-ftp-ls-cache-res "total 0\n")
2630 : ;; wu-ftpd seems to return a successful result
2631 : ;; with an empty file-listing when doing a
2632 : ;; `DIR /some/file/.' which leads ange-ftp to
2633 : ;; believe that /some/file is a directory ;-(
2634 : nil
2635 0 : ange-ftp-ls-cache-res))
2636 0 : (if no-error
2637 : nil
2638 0 : (ange-ftp-error host user
2639 0 : (concat "DIR failed: " (cdr result)))))
2640 0 : (ange-ftp-del-tmp-name temp))))
2641 0 : (error "Should never happen. Please report. Bug ref. no.: 1"))))
2642 :
2643 : ;;;; ------------------------------------------------------------
2644 : ;;;; Directory information caching support.
2645 : ;;;; ------------------------------------------------------------
2646 :
2647 : (defvar ange-ftp-add-file-entry-alist nil
2648 : "Alist saying how to add file entries on certain OS types.
2649 : Association list of pairs (TYPE . FUNC), where FUNC is a function
2650 : to be used to add a file entry for the OS TYPE.
2651 : The main reason for this alist is to deal with file versions in VMS.")
2652 :
2653 : (defvar ange-ftp-delete-file-entry-alist nil
2654 : "Alist saying how to delete files on certain OS types.
2655 : Association list of pairs (TYPE . FUNC), where FUNC is a function
2656 : to be used to delete a file entry for the OS TYPE.
2657 : The main reason for this alist is to deal with file versions in VMS.")
2658 :
2659 : (defun ange-ftp-add-file-entry (name &optional dir-p)
2660 : "Add a file entry for file NAME, if its directory info exists."
2661 0 : (funcall (or (cdr (assq (ange-ftp-host-type
2662 0 : (car (ange-ftp-ftp-name name)))
2663 0 : ange-ftp-add-file-entry-alist))
2664 0 : 'ange-ftp-internal-add-file-entry)
2665 0 : name dir-p)
2666 0 : (setq ange-ftp-ls-cache-file nil))
2667 :
2668 : (defun ange-ftp-delete-file-entry (name &optional dir-p)
2669 : "Delete the file entry for file NAME, if its directory info exists."
2670 0 : (funcall (or (cdr (assq (ange-ftp-host-type
2671 0 : (car (ange-ftp-ftp-name name)))
2672 0 : ange-ftp-delete-file-entry-alist))
2673 0 : 'ange-ftp-internal-delete-file-entry)
2674 0 : name dir-p)
2675 0 : (setq ange-ftp-ls-cache-file nil))
2676 :
2677 : (defmacro ange-ftp-parse-filename ()
2678 : ;;Extract the filename from the current line of a dired-like listing.
2679 1 : `(save-match-data
2680 : (let ((eol (progn (end-of-line) (point))))
2681 : (beginning-of-line)
2682 : (if (re-search-forward directory-listing-before-filename-regexp eol t)
2683 1 : (buffer-substring (point) eol)))))
2684 :
2685 : ;; This deals with the F switch. Should also do something about
2686 : ;; unquoting names obtained with the SysV b switch and the GNU Q
2687 : ;; switch. See Sebastian's dired-get-filename.
2688 :
2689 : (defun ange-ftp-ls-parser (switches)
2690 : ;; Meant to be called by ange-ftp-parse-dired-listing
2691 0 : (let ((tbl (make-hash-table :test 'equal))
2692 0 : (used-F (and (stringp switches)
2693 0 : (string-match "F" switches)))
2694 : file-type symlink directory file)
2695 0 : (while (setq file (ange-ftp-parse-filename))
2696 0 : (beginning-of-line)
2697 0 : (skip-chars-forward "\t 0-9")
2698 0 : (setq file-type (following-char)
2699 0 : directory (eq file-type ?d))
2700 0 : (if (eq file-type ?l)
2701 0 : (let ((end (string-match " -> " file)))
2702 0 : (if end
2703 : ;; Sometimes `ls' appends a @ at the end of the target.
2704 0 : (setq symlink (substring file (match-end 0)
2705 0 : (string-match "@\\'" file))
2706 0 : file (substring file 0 end))
2707 : ;; Shouldn't happen
2708 0 : (setq symlink "")))
2709 0 : (setq symlink nil))
2710 : ;; Only do a costly regexp search if the F switch was used.
2711 0 : (if (and used-F
2712 0 : (not (string-equal file ""))
2713 0 : (looking-at
2714 0 : ".[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)"))
2715 0 : (let ((socket (eq file-type ?s))
2716 : (executable
2717 0 : (and (not symlink) ; x bits don't mean a thing for symlinks
2718 0 : (string-match
2719 : "[xst]"
2720 0 : (concat (match-string 1)
2721 0 : (match-string 2)
2722 0 : (match-string 3))))))
2723 : ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX)
2724 : ;; and others don't. (sigh...) Beware, that some Unix's don't
2725 : ;; seem to believe in the F-switch
2726 0 : (if (or (and symlink (string-match "@\\'" file))
2727 0 : (and directory (string-match "/\\'" file))
2728 0 : (and executable (string-match "*\\'" file))
2729 0 : (and socket (string-match "=\\'" file)))
2730 0 : (setq file (substring file 0 -1)))))
2731 0 : (puthash file (or symlink directory) tbl)
2732 0 : (forward-line 1))
2733 0 : (puthash "." t tbl)
2734 0 : (puthash ".." t tbl)
2735 0 : tbl))
2736 :
2737 : ;;; The dl stuff for descriptive listings
2738 :
2739 : (defvar ange-ftp-dl-dir-regexp nil
2740 : "Regexp matching directories which are listed in dl format.
2741 : This regexp should not be anchored with a trailing `$', because it should
2742 : match subdirectories as well.")
2743 :
2744 : (defun ange-ftp-add-dl-dir (dir)
2745 : "Interactively add a DIR to `ange-ftp-dl-dir-regexp'."
2746 : (interactive
2747 0 : (list (read-string "Directory: "
2748 0 : (let ((name (or (buffer-file-name) default-directory)))
2749 0 : (and name (ange-ftp-ftp-name name)
2750 0 : (file-name-directory name))))))
2751 0 : (if (not (and ange-ftp-dl-dir-regexp
2752 0 : (string-match ange-ftp-dl-dir-regexp dir)))
2753 0 : (setq ange-ftp-dl-dir-regexp
2754 0 : (concat "^" (regexp-quote dir)
2755 0 : (and ange-ftp-dl-dir-regexp "\\|")
2756 0 : ange-ftp-dl-dir-regexp))))
2757 :
2758 : (defmacro ange-ftp-dl-parser ()
2759 : ;; Parse the current buffer, which is assumed to be a descriptive
2760 : ;; listing, and return a hashtable.
2761 1 : `(let ((tbl (make-hash-table :test 'equal)))
2762 : (while (not (eobp))
2763 : (puthash
2764 : (buffer-substring (point)
2765 : (progn
2766 : (skip-chars-forward "^ /\n")
2767 : (point)))
2768 : (eq (following-char) ?/)
2769 : tbl)
2770 : (forward-line 1))
2771 : (puthash "." t tbl)
2772 : (puthash ".." t tbl)
2773 1 : tbl))
2774 :
2775 : ;; Parse the current buffer which is assumed to be in a dired-like listing
2776 : ;; format, and return a hashtable as the result. If the listing is not really
2777 : ;; a listing, then return nil.
2778 :
2779 : (defun ange-ftp-parse-dired-listing (&optional switches)
2780 0 : (save-match-data
2781 0 : (cond
2782 0 : ((looking-at "^total [0-9]+$")
2783 0 : (forward-line 1)
2784 : ;; Some systems put in a blank line here.
2785 0 : (if (eolp) (forward-line 1))
2786 0 : (ange-ftp-ls-parser switches))
2787 0 : ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'")
2788 : ;; It's an ls error message.
2789 : nil)
2790 0 : ((eobp) ; i.e. (zerop (buffer-size))
2791 : ;; This could be one of:
2792 : ;; (1) An Ultrix ls error message
2793 : ;; (2) A listing with the A switch of an empty directory
2794 : ;; on a machine which doesn't give a total line.
2795 : ;; (3) The twilight zone.
2796 : ;; We'll assume (1) for now.
2797 : nil)
2798 0 : ((re-search-forward directory-listing-before-filename-regexp nil t)
2799 0 : (beginning-of-line)
2800 0 : (ange-ftp-ls-parser switches))
2801 0 : ((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t)
2802 : ;; It's a dl listing (I hope).
2803 : ;; file is bound by the call to ange-ftp-ls
2804 0 : (ange-ftp-add-dl-dir ange-ftp-this-file)
2805 0 : (beginning-of-line)
2806 0 : (ange-ftp-dl-parser))
2807 0 : (t nil))))
2808 :
2809 : (defun ange-ftp-set-files (directory files)
2810 : "For a given DIRECTORY, set or change the associated FILES hashtable."
2811 0 : (and files (puthash (file-name-as-directory directory)
2812 0 : files ange-ftp-files-hashtable)))
2813 :
2814 : (defun ange-ftp-switches-ok (switches)
2815 : "Return SWITCHES (a string) if suitable for use with ls over ftp."
2816 0 : (and (stringp switches)
2817 : ;; We allow the --almost-all switch, which lists all files
2818 : ;; except "." and "..". This is OK because we manually
2819 : ;; insert these entries in the hash table.
2820 0 : (string-match
2821 : "--\\(almost-\\)?all\\>\\|\\(\\`\\| \\)-[[:alpha:]]*[aA]"
2822 0 : switches)
2823 : ;; Disallow other long flags except --(almost-)all.
2824 0 : (not (string-match "\\(\\`\\| \\)--\\w+"
2825 0 : (replace-regexp-in-string
2826 : "--\\(almost-\\)?all\\>" ""
2827 0 : switches)))
2828 : ;; Must include 'l'.
2829 0 : (string-match "\\(\\`\\| \\)-[[:alpha:]]*l" switches)
2830 : ;; Disallow recursive flag.
2831 0 : (not (string-match
2832 0 : "\\(\\`\\| \\)-[[:alpha:]]*R" switches))
2833 0 : switches))
2834 :
2835 : (defun ange-ftp-get-files (directory &optional no-error)
2836 : "Given a DIRECTORY, return a hashtable of file entries.
2837 : This will give an error or return nil, depending on the value of
2838 : NO-ERROR, if a listing for DIRECTORY cannot be obtained."
2839 0 : (setq directory (file-name-as-directory directory)) ;normalize
2840 0 : (or (gethash directory ange-ftp-files-hashtable)
2841 0 : (save-match-data
2842 0 : (and (ange-ftp-ls directory
2843 : ;; This is an efficiency hack. We try to
2844 : ;; anticipate what sort of listing dired
2845 : ;; might want, and cache just such a listing.
2846 0 : (or (and (boundp 'dired-actual-switches)
2847 0 : (ange-ftp-switches-ok dired-actual-switches))
2848 0 : (and (boundp 'dired-listing-switches)
2849 0 : (ange-ftp-switches-ok
2850 0 : dired-listing-switches))
2851 0 : "-al")
2852 0 : t no-error)
2853 0 : (gethash directory ange-ftp-files-hashtable)))))
2854 :
2855 : ;; Given NAME, return the file part that can be used for looking up the
2856 : ;; file's entry in a hashtable.
2857 : (defmacro ange-ftp-get-file-part (name)
2858 8 : `(let ((file (file-name-nondirectory ,name)))
2859 : (if (string-equal file "")
2860 : "."
2861 8 : file)))
2862 :
2863 : ;; Return whether ange-ftp-file-entry-p and ange-ftp-get-file-entry are
2864 : ;; allowed to determine if NAME is a sub-directory by listing it directly,
2865 : ;; rather than listing its parent directory. This is used for efficiency so
2866 : ;; that a wasted listing is not done:
2867 : ;; 1. When looking for a .dired file in dired-x.el.
2868 : ;; 2. The syntax of FILE and DIR make it impossible that FILE could be a valid
2869 : ;; subdirectory. This is of course an OS dependent judgment.
2870 :
2871 : (defvar dired-local-variables-file)
2872 : (defmacro ange-ftp-allow-child-lookup (dir file)
2873 2 : `(not
2874 2 : (let* ((efile ,file) ; expand once.
2875 2 : (edir ,dir)
2876 : (parsed (ange-ftp-ftp-name edir))
2877 : (host-type (ange-ftp-host-type
2878 : (car parsed))))
2879 : (or
2880 : ;; Deal with dired
2881 : (and (boundp 'dired-local-variables-file) ; in the dired-x package
2882 : (stringp dired-local-variables-file)
2883 : (string-equal dired-local-variables-file efile))
2884 : ;; No dots in dir names in vms.
2885 : (and (eq host-type 'vms)
2886 : (string-match "\\." efile))
2887 : ;; No subdirs in mts of cms.
2888 : (and (memq host-type '(mts cms))
2889 : (not (string-equal "/" (nth 2 parsed))))
2890 : ;; No dots in pseudo-dir names in bs2000.
2891 : (and (eq host-type 'bs2000)
2892 2 : (string-match "\\." efile))))))
2893 :
2894 : (defun ange-ftp-file-entry-p (name)
2895 : "Given NAME, return whether there is a file entry for it."
2896 0 : (let* ((name (directory-file-name name))
2897 0 : (dir (file-name-directory name))
2898 0 : (ent (gethash dir ange-ftp-files-hashtable))
2899 0 : (file (ange-ftp-get-file-part name)))
2900 0 : (if ent
2901 0 : (ange-ftp-hash-entry-exists-p file ent)
2902 0 : (or (and (ange-ftp-allow-child-lookup dir file)
2903 0 : (setq ent (ange-ftp-get-files name t))
2904 : ;; Try a child lookup. i.e. try to list file as a
2905 : ;; subdirectory of dir. This is a good idea because
2906 : ;; we may not have read permission for file's parent. Also,
2907 : ;; people tend to work down directory trees anyway. We use
2908 : ;; no-error ;; because if file does not exist as a subdir.,
2909 : ;; then dumb hosts will give an ftp error. Smart unix hosts
2910 : ;; will simply send back the ls
2911 : ;; error message.
2912 0 : (gethash "." ent))
2913 : ;; Child lookup failed, so try the parent.
2914 0 : (ange-ftp-hash-entry-exists-p
2915 0 : file (ange-ftp-get-files dir 'no-error))))))
2916 :
2917 : (defun ange-ftp-get-file-entry (name)
2918 : "Given NAME, return the given file entry.
2919 : The entry will be either t for a directory, nil for a normal file,
2920 : or a string for a symlink. If the file isn't in the hashtable,
2921 : this also returns nil."
2922 0 : (let* ((name (directory-file-name name))
2923 0 : (dir (file-name-directory name))
2924 0 : (ent (gethash dir ange-ftp-files-hashtable))
2925 0 : (file (ange-ftp-get-file-part name)))
2926 0 : (if ent
2927 0 : (gethash file ent)
2928 0 : (or (and (ange-ftp-allow-child-lookup dir file)
2929 0 : (setq ent (ange-ftp-get-files name t))
2930 0 : (gethash "." ent))
2931 : ;; i.e. it's a directory by child lookup
2932 0 : (and (setq ent (ange-ftp-get-files dir t))
2933 0 : (gethash file ent))))))
2934 :
2935 : (defun ange-ftp-internal-delete-file-entry (name &optional dir-p)
2936 0 : (when dir-p
2937 0 : (setq name (file-name-as-directory name))
2938 0 : (remhash name ange-ftp-files-hashtable)
2939 0 : (setq name (directory-file-name name)))
2940 : ;; Note that file-name-as-directory followed by directory-file-name
2941 : ;; serves to canonicalize directory file names to their unix form.
2942 : ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO
2943 0 : (let ((files (gethash (file-name-directory name) ange-ftp-files-hashtable)))
2944 0 : (if files
2945 0 : (remhash (ange-ftp-get-file-part name) files))))
2946 :
2947 : (defun ange-ftp-internal-add-file-entry (name &optional dir-p)
2948 0 : (and dir-p
2949 0 : (setq name (directory-file-name name)))
2950 0 : (let ((files (gethash (file-name-directory name) ange-ftp-files-hashtable)))
2951 0 : (if files
2952 0 : (puthash (ange-ftp-get-file-part name) dir-p files))))
2953 :
2954 : (defun ange-ftp-wipe-file-entries (host user)
2955 : "Get rid of entry for HOST, USER pair from file entry information hashtable."
2956 0 : (let ((new-tbl (make-hash-table :test 'equal
2957 0 : :size (hash-table-size
2958 0 : ange-ftp-files-hashtable))))
2959 0 : (maphash
2960 : (lambda (key val)
2961 0 : (let ((parsed (ange-ftp-ftp-name key)))
2962 0 : (if parsed
2963 0 : (let ((h (nth 0 parsed))
2964 0 : (u (nth 1 parsed)))
2965 0 : (or (and (equal host h) (equal user u))
2966 0 : (puthash key val new-tbl))))))
2967 0 : ange-ftp-files-hashtable)
2968 0 : (setq ange-ftp-files-hashtable new-tbl)))
2969 :
2970 : ;;;; ------------------------------------------------------------
2971 : ;;;; File transfer mode support.
2972 : ;;;; ------------------------------------------------------------
2973 :
2974 : (defun ange-ftp-set-binary-mode (host user)
2975 : "Tell the FTP process for the given HOST & USER to switch to binary mode."
2976 : ;; FIXME: We should keep track of the current mode, so as to avoid
2977 : ;; unnecessary roundtrips.
2978 0 : (let ((result (ange-ftp-send-cmd host user '(type "binary"))))
2979 0 : (if (not (car result))
2980 0 : (ange-ftp-error host user (concat "BINARY failed: " (cdr result)))
2981 0 : (with-current-buffer (process-buffer (ange-ftp-get-process host user))
2982 0 : (and ange-ftp-binary-hash-mark-size
2983 0 : (setq ange-ftp-hash-mark-unit
2984 0 : (ash ange-ftp-binary-hash-mark-size -4)))))))
2985 :
2986 : (defun ange-ftp-set-ascii-mode (host user)
2987 : "Tell the FTP process for the given HOST & USER to switch to ASCII mode."
2988 : ;; FIXME: We should keep track of the current mode, so as to avoid
2989 : ;; unnecessary roundtrips.
2990 0 : (let ((result (ange-ftp-send-cmd host user '(type "ascii"))))
2991 0 : (if (not (car result))
2992 0 : (ange-ftp-error host user (concat "ASCII failed: " (cdr result)))
2993 0 : (with-current-buffer (process-buffer (ange-ftp-get-process host user))
2994 0 : (and ange-ftp-ascii-hash-mark-size
2995 0 : (setq ange-ftp-hash-mark-unit
2996 0 : (ash ange-ftp-ascii-hash-mark-size -4)))))))
2997 :
2998 : (defun ange-ftp-cd (host user dir &optional noerror)
2999 0 : (let ((result (ange-ftp-send-cmd host user (list 'cd dir) "Doing CD")))
3000 0 : (if noerror result
3001 0 : (or (car result)
3002 0 : (ange-ftp-error host user (concat "CD failed: " (cdr result)))))))
3003 :
3004 : (defun ange-ftp-get-pwd (host user)
3005 : "Attempt to get the current working directory for the given HOST/USER pair.
3006 : Returns (DIR . LINE) where DIR is either the directory or nil if not found,
3007 : and LINE is the relevant success or fail line from the FTP-client."
3008 0 : (let* ((result (ange-ftp-send-cmd host user '(pwd) "Getting PWD"))
3009 0 : (line (cdr result))
3010 : dir)
3011 0 : (if (car result)
3012 0 : (save-match-data
3013 0 : (and (or (string-match "\"\\([^\"]*\\)\"" line)
3014 : ;; Some clients cache the value and return it in
3015 : ;; this way without asking the server. (Bug#15058)
3016 0 : (string-match "^Remote directory: \\(.*\\)" line)
3017 0 : (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers!
3018 0 : (setq dir (match-string 1 line)))))
3019 0 : (cons dir line)))
3020 :
3021 : ;;; ------------------------------------------------------------
3022 : ;;; expand-file-name and friends...which currently don't work
3023 : ;;; ------------------------------------------------------------
3024 :
3025 : (defun ange-ftp-expand-dir (host user dir)
3026 : "Return the result of doing a PWD in the current FTP session.
3027 : Use the connection to machine HOST
3028 : logged in as user USER and cd'd to directory DIR."
3029 0 : (let* ((host-type (ange-ftp-host-type host user))
3030 : ;; It is more efficient to call ange-ftp-host-type
3031 : ;; before binding res, because ange-ftp-host-type sometimes
3032 : ;; adds to the info in the expand-dir-hashtable.
3033 : (fix-name-func
3034 0 : (cdr (assq host-type ange-ftp-fix-name-func-alist)))
3035 0 : (key (concat host "/" user "/" dir))
3036 0 : (res (gethash key ange-ftp-expand-dir-hashtable)))
3037 0 : (or res
3038 0 : (progn
3039 0 : (or
3040 0 : (string-equal user "anonymous")
3041 0 : (string-equal user "ftp")
3042 0 : (not (eq host-type 'unix))
3043 0 : (let* ((ange-ftp-good-msgs (concat ange-ftp-expand-dir-regexp
3044 : "\\|"
3045 0 : ange-ftp-good-msgs))
3046 0 : (result (ange-ftp-send-cmd host user
3047 0 : (list 'get dir null-device)
3048 0 : (format "expanding %s" dir)))
3049 0 : (line (cdr result)))
3050 0 : (setq res
3051 0 : (if (string-match ange-ftp-expand-dir-regexp line)
3052 0 : (match-string 1 line)))))
3053 0 : (or res
3054 0 : (if (string-equal dir "~")
3055 0 : (setq res (car (ange-ftp-get-pwd host user)))
3056 0 : (let ((home (ange-ftp-expand-dir host user "~")))
3057 0 : (unwind-protect
3058 0 : (and (ange-ftp-cd host user dir)
3059 0 : (setq res (car (ange-ftp-get-pwd host user))))
3060 0 : (ange-ftp-cd host user home)))))
3061 0 : (if res
3062 0 : (let ((ange-ftp-this-user user)
3063 0 : (ange-ftp-this-host host))
3064 0 : (if fix-name-func
3065 0 : (setq res (funcall fix-name-func res 'reverse)))
3066 0 : (puthash key res ange-ftp-expand-dir-hashtable)))
3067 0 : res))))
3068 :
3069 : (defun ange-ftp-canonize-filename (n)
3070 : "Take a string N and short-circuit //, /. and /.."
3071 0 : (if (string-match "[^:]+//" n) ;don't upset Apollo users
3072 0 : (setq n (substring n (1- (match-end 0)))))
3073 0 : (let ((parsed (ange-ftp-ftp-name n)))
3074 0 : (if parsed
3075 0 : (let ((host (car parsed))
3076 0 : (user (nth 1 parsed))
3077 0 : (name (nth 2 parsed)))
3078 :
3079 : ;; See if remote name is absolute. If so then just expand it and
3080 : ;; replace the name component of the overall name.
3081 0 : (cond ((string-match "\\`/" name)
3082 0 : name)
3083 :
3084 : ;; Name starts with ~ or ~user. Resolve that part of the name
3085 : ;; making it absolute then re-expand it.
3086 0 : ((string-match "\\`~[^/]*" name)
3087 0 : (let* ((tilda (match-string 0 name))
3088 0 : (rest (substring name (match-end 0)))
3089 0 : (dir (ange-ftp-expand-dir host user tilda)))
3090 0 : (if dir
3091 : ;; C-x d /ftp:anonymous@ftp.gnu.org:~/ RET
3092 : ;; seems to cause `rest' to sometimes be empty.
3093 : ;; Maybe it's an error for `rest' to be empty here,
3094 : ;; but until we figure this out, this quick fix
3095 : ;; seems to do the trick.
3096 0 : (setq name (cond ((string-equal rest "") dir)
3097 0 : ((string-equal dir "/") rest)
3098 0 : (t (concat dir rest))))
3099 0 : (error "User \"%s\" is not known"
3100 0 : (substring tilda 1)))))
3101 :
3102 : ;; relative name. Tack on homedir and re-expand.
3103 : (t
3104 0 : (let ((dir (ange-ftp-expand-dir host user "~")))
3105 0 : (if dir
3106 0 : (setq name (concat
3107 0 : (ange-ftp-real-file-name-as-directory dir)
3108 0 : name))
3109 0 : (error "Unable to obtain CWD")))))
3110 :
3111 : ;; If name starts with //, preserve that, for apollo system.
3112 0 : (unless (string-match "\\`//" name)
3113 0 : (if (not (eq system-type 'windows-nt))
3114 0 : (setq name (ange-ftp-real-expand-file-name name))
3115 : ;; Windows UNC default dirs do not make sense for ftp.
3116 0 : (setq name (if (and default-directory
3117 0 : (string-match "\\`//" default-directory))
3118 0 : (ange-ftp-real-expand-file-name name "c:/")
3119 0 : (ange-ftp-real-expand-file-name name)))
3120 : ;; Strip off possible drive specifier.
3121 0 : (if (string-match "\\`[a-zA-Z]:" name)
3122 0 : (setq name (substring name 2))))
3123 0 : (if (string-match "\\`//" name)
3124 0 : (setq name (substring name 1))))
3125 :
3126 : ;; Now substitute the expanded name back into the overall filename.
3127 0 : (ange-ftp-replace-name-component n name))
3128 :
3129 : ;; non-ange-ftp name. Just expand normally.
3130 0 : (if (eq (string-to-char n) ?/)
3131 0 : (ange-ftp-real-expand-file-name n)
3132 0 : (ange-ftp-real-expand-file-name
3133 0 : (ange-ftp-real-file-name-nondirectory n)
3134 0 : (ange-ftp-real-file-name-directory n))))))
3135 :
3136 : (defun ange-ftp-expand-file-name (name &optional default)
3137 : "Documented as `expand-file-name'."
3138 0 : (save-match-data
3139 0 : (setq default (or default default-directory))
3140 0 : (cond
3141 0 : ((ange-ftp-ftp-name name)
3142 : ;; `default' is irrelevant.
3143 0 : (ange-ftp-canonize-filename name))
3144 0 : ((file-name-absolute-p name)
3145 : ;; `name' is absolute but is not an ange-ftp name => not ange-ftp.
3146 0 : (ange-ftp-real-expand-file-name name "/"))
3147 0 : ((ange-ftp-canonize-filename
3148 0 : (concat (file-name-as-directory default) name))))))
3149 :
3150 : ;;; These are problems--they are currently not enabled.
3151 :
3152 : (defvar ange-ftp-file-name-as-directory-alist nil
3153 : "Association list of (TYPE . FUNC) pairs.
3154 : FUNC converts a filename to a directory name for the operating
3155 : system TYPE.")
3156 :
3157 : (defun ange-ftp-file-name-as-directory (name)
3158 : "Documented as `file-name-as-directory'."
3159 0 : (let ((parsed (ange-ftp-ftp-name name)))
3160 0 : (if parsed
3161 0 : (if (string-equal (nth 2 parsed) "")
3162 0 : name
3163 0 : (funcall (or (cdr (assq
3164 0 : (ange-ftp-host-type (car parsed))
3165 0 : ange-ftp-file-name-as-directory-alist))
3166 0 : 'ange-ftp-real-file-name-as-directory)
3167 0 : name))
3168 0 : (ange-ftp-real-file-name-as-directory name))))
3169 :
3170 : (defun ange-ftp-file-name-directory (name)
3171 : "Documented as `file-name-directory'."
3172 0 : (let ((parsed (ange-ftp-ftp-name name)))
3173 0 : (if parsed
3174 0 : (let ((filename (nth 2 parsed)))
3175 0 : (if (string-match-p "\\`~[^/]*\\'" filename)
3176 0 : name
3177 0 : (ange-ftp-replace-name-component
3178 0 : name
3179 0 : (ange-ftp-real-file-name-directory filename))))
3180 0 : (ange-ftp-real-file-name-directory name))))
3181 :
3182 : (defun ange-ftp-file-name-nondirectory (name)
3183 : "Documented as `file-name-nondirectory'."
3184 0 : (let ((parsed (ange-ftp-ftp-name name)))
3185 0 : (if parsed
3186 0 : (let ((filename (nth 2 parsed)))
3187 0 : (if (string-match-p "\\`~[^/]*\\'" filename)
3188 : ""
3189 0 : (ange-ftp-real-file-name-nondirectory filename)))
3190 0 : (ange-ftp-real-file-name-nondirectory name))))
3191 :
3192 : (defun ange-ftp-directory-file-name (dir)
3193 : "Documented as `directory-file-name'."
3194 0 : (let ((parsed (ange-ftp-ftp-name dir)))
3195 0 : (if parsed
3196 0 : (ange-ftp-replace-name-component
3197 0 : dir
3198 0 : (ange-ftp-real-directory-file-name (nth 2 parsed)))
3199 0 : (ange-ftp-real-directory-file-name dir))))
3200 :
3201 :
3202 : ;;; Hooks that handle Emacs primitives.
3203 :
3204 : ;; Returns non-nil if should transfer FILE in binary mode.
3205 : (defun ange-ftp-binary-file (file)
3206 0 : (string-match-p ange-ftp-binary-file-name-regexp file))
3207 :
3208 : (defun ange-ftp-write-region
3209 : (start end filename &optional append visit _lockname mustbenew)
3210 0 : (setq filename (expand-file-name filename))
3211 0 : (when mustbenew
3212 0 : (ange-ftp-barf-or-query-if-file-exists
3213 0 : filename "overwrite" (not (eq mustbenew 'excl))))
3214 0 : (let ((parsed (ange-ftp-ftp-name filename)))
3215 0 : (if parsed
3216 0 : (let* ((host (nth 0 parsed))
3217 0 : (user (nth 1 parsed))
3218 0 : (name (ange-ftp-quote-string (nth 2 parsed)))
3219 0 : (temp (ange-ftp-make-tmp-name host))
3220 : ;; What we REALLY need here is a way to determine if the mode
3221 : ;; of the transfer is irrelevant, i.e. we can use binary mode
3222 : ;; regardless. Maybe a system-type to host-type lookup?
3223 0 : (binary (ange-ftp-binary-file filename))
3224 0 : (cmd (if append 'append 'put))
3225 0 : (abbr (ange-ftp-abbreviate-filename filename))
3226 : ;; we need to reset `last-coding-system-used' to its
3227 : ;; value immediately after calling the real write-region,
3228 : ;; so that `basic-save-buffer' doesn't see whatever value
3229 : ;; might be used when communicating with the ftp process.
3230 0 : (coding-system-used last-coding-system-used))
3231 0 : (unwind-protect
3232 0 : (progn
3233 0 : (let ((filename (buffer-file-name))
3234 0 : (mod-p (buffer-modified-p)))
3235 0 : (unwind-protect
3236 0 : (progn
3237 0 : (ange-ftp-real-write-region start end temp nil
3238 0 : (or visit 'quiet))
3239 0 : (setq coding-system-used last-coding-system-used))
3240 : ;; cleanup forms
3241 0 : (setq coding-system-used last-coding-system-used)
3242 0 : (setq buffer-file-name filename)
3243 0 : (restore-buffer-modified-p mod-p)))
3244 0 : (if binary
3245 0 : (ange-ftp-set-binary-mode host user))
3246 :
3247 : ;; tell the process filter what size the transfer will be.
3248 0 : (let ((attr (file-attributes temp)))
3249 0 : (if attr
3250 0 : (ange-ftp-set-xfer-size host user (nth 7 attr))))
3251 :
3252 : ;; put or append the file.
3253 0 : (let ((result (ange-ftp-send-cmd host user
3254 0 : (list cmd temp name)
3255 0 : (format "Writing %s" abbr))))
3256 0 : (or (car result)
3257 0 : (signal 'ftp-error
3258 0 : (list
3259 : "Opening output file"
3260 0 : (format "FTP Error: \"%s\"" (cdr result))
3261 0 : filename)))))
3262 0 : (ange-ftp-del-tmp-name temp)
3263 0 : (if binary
3264 0 : (ange-ftp-set-ascii-mode host user)))
3265 0 : (if (eq visit t)
3266 0 : (progn
3267 0 : (set-visited-file-modtime (ange-ftp-file-modtime filename))
3268 0 : (ange-ftp-set-buffer-mode)
3269 0 : (setq buffer-file-name filename)
3270 0 : (set-buffer-modified-p nil)))
3271 : ;; ensure `last-coding-system-used' has an appropriate value
3272 0 : (setq last-coding-system-used coding-system-used)
3273 0 : (ange-ftp-message "Wrote %s" abbr)
3274 0 : (ange-ftp-add-file-entry filename))
3275 0 : (ange-ftp-real-write-region start end filename append visit))))
3276 :
3277 : (defun ange-ftp-insert-file-contents (filename &optional visit beg end replace)
3278 0 : (barf-if-buffer-read-only)
3279 0 : (setq filename (expand-file-name filename))
3280 0 : (let ((parsed (ange-ftp-ftp-name filename)))
3281 0 : (if parsed
3282 0 : (progn
3283 0 : (if visit
3284 0 : (setq buffer-file-name filename))
3285 0 : (if (or (file-exists-p filename)
3286 0 : (progn
3287 0 : (setq ange-ftp-ls-cache-file nil)
3288 0 : (remhash (file-name-directory filename)
3289 0 : ange-ftp-files-hashtable)
3290 0 : (file-exists-p filename)))
3291 0 : (let* ((host (nth 0 parsed))
3292 0 : (user (nth 1 parsed))
3293 0 : (name (ange-ftp-quote-string (nth 2 parsed)))
3294 0 : (temp (ange-ftp-make-tmp-name host))
3295 0 : (binary (ange-ftp-binary-file filename))
3296 0 : (abbr (ange-ftp-abbreviate-filename filename))
3297 0 : (coding-system-used last-coding-system-used)
3298 : size)
3299 0 : (unwind-protect
3300 0 : (progn
3301 0 : (if binary
3302 0 : (ange-ftp-set-binary-mode host user))
3303 0 : (let ((result (ange-ftp-send-cmd host user
3304 0 : (list 'get name temp)
3305 0 : (format "Retrieving %s" abbr))))
3306 0 : (or (car result)
3307 0 : (signal 'ftp-error
3308 0 : (list
3309 : "Opening input file"
3310 0 : (format "FTP Error: \"%s\"" (cdr result))
3311 0 : filename))))
3312 0 : (if (or (ange-ftp-real-file-readable-p temp)
3313 0 : (sleep-for ange-ftp-retry-time)
3314 : ;; Wait for file to hopefully appear.
3315 0 : (ange-ftp-real-file-readable-p temp))
3316 0 : (setq
3317 : size
3318 0 : (nth 1 (ange-ftp-real-insert-file-contents
3319 0 : temp visit beg end replace))
3320 0 : coding-system-used last-coding-system-used)
3321 0 : (signal 'ftp-error
3322 0 : (list
3323 : "Opening input file:"
3324 0 : (format
3325 : "FTP Error: %s not arrived or readable"
3326 0 : filename)))))
3327 0 : (if binary
3328 : ;; We must keep `last-coding-system-used'
3329 : ;; unchanged.
3330 0 : (let (last-coding-system-used)
3331 0 : (ange-ftp-set-ascii-mode host user)))
3332 0 : (ange-ftp-del-tmp-name temp))
3333 0 : (if visit
3334 0 : (progn
3335 0 : (set-visited-file-modtime
3336 0 : (ange-ftp-file-modtime filename))
3337 0 : (setq buffer-file-name filename)))
3338 0 : (setq last-coding-system-used coding-system-used)
3339 0 : (list filename size))
3340 0 : (signal 'file-missing
3341 0 : (list
3342 : "Opening input file"
3343 : "No such file or directory"
3344 0 : filename))))
3345 0 : (ange-ftp-real-insert-file-contents filename visit beg end replace))))
3346 :
3347 : (defun ange-ftp-expand-symlink (file dir)
3348 0 : (let ((res (if (file-name-absolute-p file)
3349 0 : (ange-ftp-replace-name-component dir file)
3350 0 : (expand-file-name file dir))))
3351 0 : (if (file-symlink-p res)
3352 0 : (ange-ftp-expand-symlink
3353 0 : (ange-ftp-get-file-entry res)
3354 0 : (file-name-directory (directory-file-name res)))
3355 0 : res)))
3356 :
3357 : (defun ange-ftp-file-symlink-p (file)
3358 : ;; call ange-ftp-expand-file-name rather than the normal
3359 : ;; expand-file-name to stop loops when using a package that
3360 : ;; redefines both file-symlink-p and expand-file-name.
3361 0 : (setq file (ange-ftp-expand-file-name file))
3362 0 : (if (ange-ftp-ftp-name file)
3363 0 : (condition-case nil
3364 0 : (let ((ent (ange-ftp-get-files (file-name-directory file))))
3365 0 : (and ent
3366 0 : (stringp (setq ent
3367 0 : (gethash (ange-ftp-get-file-part file) ent)))
3368 0 : ent))
3369 : ;; If we can't read the parent directory, just assume
3370 : ;; this file is not a symlink.
3371 : ;; This makes it possible to access a directory that
3372 : ;; whose parent is not readable.
3373 0 : (file-error nil))
3374 0 : (ange-ftp-real-file-symlink-p file)))
3375 :
3376 : (defun ange-ftp-file-exists-p (name)
3377 0 : (setq name (expand-file-name name))
3378 0 : (if (ange-ftp-ftp-name name)
3379 0 : (if (ange-ftp-file-entry-p name)
3380 0 : (let ((file-ent (ange-ftp-get-file-entry name)))
3381 0 : (if (stringp file-ent)
3382 0 : (ange-ftp-file-exists-p
3383 0 : (ange-ftp-expand-symlink file-ent
3384 0 : (file-name-directory
3385 0 : (directory-file-name name))))
3386 0 : t)))
3387 0 : (ange-ftp-real-file-exists-p name)))
3388 :
3389 : (defun ange-ftp-file-directory-p (name)
3390 0 : (setq name (expand-file-name name))
3391 0 : (if (ange-ftp-ftp-name name)
3392 : ;; We do a file-name-as-directory on name here because some
3393 : ;; machines (VMS) use a .DIR to indicate the filename associated
3394 : ;; with a directory. This needs to be canonicalized.
3395 0 : (let ((file-ent (ange-ftp-get-file-entry
3396 0 : (ange-ftp-file-name-as-directory name))))
3397 0 : (if (stringp file-ent)
3398 : ;; Calling file-directory-p doesn't work because ange-ftp
3399 : ;; is temporarily disabled for this operation.
3400 0 : (ange-ftp-file-directory-p
3401 0 : (ange-ftp-expand-symlink file-ent
3402 0 : (file-name-directory
3403 0 : (directory-file-name name))))
3404 0 : file-ent))
3405 0 : (ange-ftp-real-file-directory-p name)))
3406 :
3407 : (defun ange-ftp-directory-files (directory &optional full match
3408 : &rest v19-args)
3409 0 : (setq directory (expand-file-name directory))
3410 0 : (if (ange-ftp-ftp-name directory)
3411 0 : (progn
3412 0 : (ange-ftp-barf-if-not-directory directory)
3413 0 : (let ((tail (ange-ftp-hash-table-keys
3414 0 : (ange-ftp-get-files directory)))
3415 : files f)
3416 0 : (setq directory (file-name-as-directory directory))
3417 0 : (while tail
3418 0 : (setq f (car tail)
3419 0 : tail (cdr tail))
3420 0 : (if (or (not match) (string-match-p match f))
3421 0 : (setq files
3422 0 : (cons (if full (concat directory f) f) files))))
3423 0 : (nreverse files)))
3424 0 : (apply 'ange-ftp-real-directory-files directory full match v19-args)))
3425 :
3426 : (defun ange-ftp-directory-files-and-attributes
3427 : (directory &optional full match nosort id-format)
3428 0 : (setq directory (expand-file-name directory))
3429 0 : (if (ange-ftp-ftp-name directory)
3430 0 : (mapcar
3431 : (lambda (file)
3432 0 : (cons file (file-attributes (expand-file-name file directory))))
3433 0 : (ange-ftp-directory-files directory full match nosort))
3434 0 : (ange-ftp-real-directory-files-and-attributes
3435 0 : directory full match nosort id-format)))
3436 :
3437 : (defun ange-ftp-file-attributes (file &optional id-format)
3438 0 : (setq file (expand-file-name file))
3439 0 : (let ((parsed (ange-ftp-ftp-name file)))
3440 0 : (if parsed
3441 0 : (let ((part (ange-ftp-get-file-part file))
3442 0 : (files (ange-ftp-get-files (file-name-directory file))))
3443 0 : (if (ange-ftp-hash-entry-exists-p part files)
3444 0 : (let ((host (nth 0 parsed))
3445 0 : (user (nth 1 parsed))
3446 0 : (name (nth 2 parsed))
3447 0 : (dirp (gethash part files))
3448 0 : (inode (gethash file ange-ftp-inodes-hashtable)))
3449 0 : (unless inode
3450 0 : (setq inode ange-ftp-next-inode-number
3451 0 : ange-ftp-next-inode-number (1+ inode))
3452 0 : (puthash file inode ange-ftp-inodes-hashtable))
3453 0 : (list (if (and (stringp dirp) (file-name-absolute-p dirp))
3454 0 : (ange-ftp-expand-symlink dirp
3455 0 : (file-name-directory file))
3456 0 : dirp) ;0 file type
3457 : -1 ;1 link count
3458 : -1 ;2 uid
3459 : -1 ;3 gid
3460 : '(0 0) ;4 atime
3461 0 : (ange-ftp-file-modtime file) ;5 mtime
3462 : '(0 0) ;6 ctime
3463 0 : (ange-ftp-file-size file) ;7 size
3464 0 : (concat (if (stringp dirp) "l" (if dirp "d" "-"))
3465 0 : "?????????") ;8 mode
3466 : nil ;9 gid weird
3467 0 : inode ;10 "inode number".
3468 : -1 ;11 device number [v19 only]
3469 0 : ))))
3470 0 : (if id-format
3471 0 : (ange-ftp-real-file-attributes file id-format)
3472 0 : (ange-ftp-real-file-attributes file)))))
3473 :
3474 : (defun ange-ftp-file-newer-than-file-p (f1 f2)
3475 0 : (let ((f1-parsed (ange-ftp-ftp-name f1))
3476 0 : (f2-parsed (ange-ftp-ftp-name f2)))
3477 0 : (if (or f1-parsed f2-parsed)
3478 0 : (let ((f1-mt (nth 5 (file-attributes f1)))
3479 0 : (f2-mt (nth 5 (file-attributes f2))))
3480 0 : (cond ((null f1-mt) nil)
3481 0 : ((null f2-mt) t)
3482 0 : (t (> (float-time f1-mt) (float-time f2-mt)))))
3483 0 : (ange-ftp-real-file-newer-than-file-p f1 f2))))
3484 :
3485 : (defun ange-ftp-file-writable-p (file)
3486 0 : (let ((ange-ftp-process-verbose nil))
3487 0 : (setq file (expand-file-name file))
3488 0 : (if (ange-ftp-ftp-name file)
3489 0 : (or (file-exists-p file) ;guess here for speed
3490 0 : (file-directory-p (file-name-directory file)))
3491 0 : (ange-ftp-real-file-writable-p file))))
3492 :
3493 : (defun ange-ftp-file-readable-p (file)
3494 0 : (let ((ange-ftp-process-verbose nil))
3495 0 : (setq file (expand-file-name file))
3496 0 : (if (ange-ftp-ftp-name file)
3497 0 : (file-exists-p file)
3498 0 : (ange-ftp-real-file-readable-p file))))
3499 :
3500 : (defun ange-ftp-file-executable-p (file)
3501 0 : (let ((ange-ftp-process-verbose nil))
3502 0 : (setq file (expand-file-name file))
3503 0 : (if (ange-ftp-ftp-name file)
3504 0 : (file-exists-p file)
3505 0 : (ange-ftp-real-file-executable-p file))))
3506 :
3507 : (defun ange-ftp-delete-file (file &optional trash)
3508 0 : (interactive (list (read-file-name "Delete file: " nil default-directory)
3509 0 : (null current-prefix-arg)))
3510 0 : (setq file (expand-file-name file))
3511 0 : (let ((parsed (ange-ftp-ftp-name file)))
3512 0 : (if parsed
3513 0 : (let* ((host (nth 0 parsed))
3514 0 : (user (nth 1 parsed))
3515 0 : (name (ange-ftp-quote-string (nth 2 parsed)))
3516 0 : (abbr (ange-ftp-abbreviate-filename file))
3517 0 : (result (ange-ftp-send-cmd host user
3518 0 : (list 'delete name)
3519 0 : (format "Deleting %s" abbr))))
3520 0 : (or (car result)
3521 0 : (signal 'ftp-error
3522 0 : (list
3523 : "Removing old name"
3524 0 : (format "FTP Error: \"%s\"" (cdr result))
3525 0 : file)))
3526 0 : (ange-ftp-delete-file-entry file))
3527 0 : (ange-ftp-real-delete-file file trash))))
3528 :
3529 : (defun ange-ftp-file-modtime (file)
3530 : "Return the modification time of remote file FILE.
3531 : Value is (0 0) if the modification time cannot be determined."
3532 0 : (let* ((parsed (ange-ftp-ftp-name file))
3533 : ;; At least one FTP server (wu-ftpd) can return a "226
3534 : ;; Transfer complete" before the "213 MODTIME". Let's skip
3535 : ;; that.
3536 0 : (ange-ftp-skip-msgs (concat ange-ftp-skip-msgs "\\|^226"))
3537 0 : (res (ange-ftp-send-cmd (car parsed) (cadr parsed)
3538 0 : (list 'quote "mdtm" (cadr (cdr parsed)))))
3539 0 : (line (cdr res))
3540 : (modtime '(0 0)))
3541 : ;; MDTM should return "213 YYYYMMDDhhmmss" GMT on success
3542 : ;; following the Internet draft for FTP extensions.
3543 : ;; Bob@rattlesnake.com reports that is returns something different
3544 : ;; for at least one FTP server. So, let's use the response only
3545 : ;; if it matches the Internet draft.
3546 0 : (when (string-match-p "^213 [0-9]\\{14\\}$" line)
3547 0 : (setq modtime
3548 0 : (encode-time
3549 0 : (string-to-number (substring line 16 18))
3550 0 : (string-to-number (substring line 14 16))
3551 0 : (string-to-number (substring line 12 14))
3552 0 : (string-to-number (substring line 10 12))
3553 0 : (string-to-number (substring line 8 10))
3554 0 : (string-to-number (substring line 4 8))
3555 0 : 0)))
3556 0 : modtime))
3557 :
3558 : (defun ange-ftp-verify-visited-file-modtime (buf)
3559 0 : (let ((name (buffer-file-name buf)))
3560 0 : (if (and (stringp name) (ange-ftp-ftp-name name))
3561 0 : (let ((file-mdtm (ange-ftp-file-modtime name))
3562 0 : (buf-mdtm (with-current-buffer buf (visited-file-modtime))))
3563 0 : (or (zerop (car file-mdtm))
3564 0 : (<= (float-time file-mdtm) (float-time buf-mdtm))))
3565 0 : (ange-ftp-real-verify-visited-file-modtime buf))))
3566 :
3567 : (defun ange-ftp-file-size (file &optional ascii-mode)
3568 : "Return the size of remote file FILE. Return -1 if can't get it.
3569 : If ascii-mode is non-nil, return the size with the extra octets that
3570 : need to be inserted, one at the end of each line, to provide correct
3571 : end-of-line semantics for a transfer using TYPE=A. The default is nil,
3572 : so return the size on the remote host exactly. See RFC 3659."
3573 0 : (let* ((parsed (ange-ftp-ftp-name file))
3574 0 : (host (nth 0 parsed))
3575 0 : (user (nth 1 parsed))
3576 0 : (name (ange-ftp-quote-string (nth 2 parsed)))
3577 : ;; At least one FTP server (wu-ftpd) can return a "226
3578 : ;; Transfer complete" before the "213 SIZE". Let's skip
3579 : ;; that.
3580 0 : (ange-ftp-skip-msgs (concat ange-ftp-skip-msgs "\\|^226"))
3581 0 : (res (unwind-protect
3582 0 : (progn
3583 0 : (unless ascii-mode
3584 0 : (ange-ftp-set-binary-mode host user))
3585 0 : (ange-ftp-send-cmd host user (list 'quote "size" name)))
3586 0 : (unless ascii-mode
3587 0 : (ange-ftp-set-ascii-mode host user))))
3588 0 : (line (cdr res)))
3589 0 : (if (string-match "^213 \\([0-9]+\\)$" line)
3590 0 : (string-to-number (match-string 1 line))
3591 0 : -1)))
3592 :
3593 :
3594 : ;;;; ------------------------------------------------------------
3595 : ;;;; File copying support... totally re-written 6/24/92.
3596 : ;;;; ------------------------------------------------------------
3597 :
3598 : (defun ange-ftp-barf-or-query-if-file-exists (absname querystring interactive)
3599 0 : (if (file-exists-p absname)
3600 0 : (if (not interactive)
3601 0 : (signal 'file-already-exists (list absname))
3602 0 : (if (not (yes-or-no-p (format "File %s already exists; %s anyway? "
3603 0 : absname querystring)))
3604 0 : (signal 'file-already-exists (list absname))))))
3605 :
3606 : ;; async local copy commented out for now since I don't seem to get
3607 : ;; the process sentinel called for some processes.
3608 : ;;
3609 : ;; (defun ange-ftp-copy-file-locally (filename newname ok-if-already-exists
3610 : ;; keep-date cont)
3611 : ;; "Kludge to copy a local file and call a continuation when the copy
3612 : ;; finishes."
3613 : ;; ;; check to see if we can overwrite
3614 : ;; (if (or (not ok-if-already-exists)
3615 : ;; (numberp ok-if-already-exists))
3616 : ;; (ange-ftp-barf-or-query-if-file-exists newname "copy to it"
3617 : ;; (numberp ok-if-already-exists)))
3618 : ;; (let ((proc (start-process " *copy*"
3619 : ;; (generate-new-buffer "*copy*")
3620 : ;; "cp"
3621 : ;; filename
3622 : ;; newname))
3623 : ;; res)
3624 : ;; (set-process-sentinel proc 'ange-ftp-copy-file-locally-sentinel)
3625 : ;; (process-kill-without-query proc)
3626 : ;; (with-current-buffer (process-buffer proc)
3627 : ;; (set (make-local-variable 'copy-cont) cont))))
3628 : ;;
3629 : ;; (defun ange-ftp-copy-file-locally-sentinel (proc status)
3630 : ;; (with-current-buffer (process-buffer proc)
3631 : ;; (let ((cont copy-cont)
3632 : ;; (result (buffer-string)))
3633 : ;; (unwind-protect
3634 : ;; (if (and (string-equal status "finished\n")
3635 : ;; (zerop (length result)))
3636 : ;; (ange-ftp-call-cont cont t nil)
3637 : ;; (ange-ftp-call-cont cont
3638 : ;; nil
3639 : ;; (if (zerop (length result))
3640 : ;; (substring status 0 -1)
3641 : ;; (substring result 0 -1))))
3642 : ;; (kill-buffer (current-buffer))))))
3643 :
3644 : ;; this is the extended version of ange-ftp-copy-file-internal that works
3645 : ;; asynchronously if asked nicely.
3646 : (defun ange-ftp-copy-file-internal (filename newname ok-if-already-exists
3647 : keep-date &optional msg cont nowait)
3648 0 : (setq filename (expand-file-name filename)
3649 0 : newname (expand-file-name newname))
3650 :
3651 0 : (or (file-exists-p filename)
3652 0 : (signal 'file-missing
3653 0 : (list "Copy file" "No such file or directory" filename)))
3654 :
3655 : ;; canonicalize newname if a directory.
3656 0 : (if (file-directory-p newname)
3657 0 : (setq newname (expand-file-name (file-name-nondirectory filename) newname)))
3658 :
3659 0 : (let ((f-parsed (ange-ftp-ftp-name filename))
3660 0 : (t-parsed (ange-ftp-ftp-name newname)))
3661 :
3662 : ;; local file to local file copy?
3663 0 : (if (and (not f-parsed) (not t-parsed))
3664 0 : (progn
3665 0 : (ange-ftp-real-copy-file filename newname ok-if-already-exists
3666 0 : keep-date)
3667 0 : (if cont
3668 0 : (ange-ftp-call-cont cont t "Copied locally")))
3669 : ;; one or both files are remote.
3670 0 : (let* ((f-host (and f-parsed (nth 0 f-parsed)))
3671 0 : (f-user (and f-parsed (nth 1 f-parsed)))
3672 0 : (f-name (and f-parsed (ange-ftp-quote-string (nth 2 f-parsed))))
3673 0 : (f-abbr (ange-ftp-abbreviate-filename filename))
3674 0 : (t-host (and t-parsed (nth 0 t-parsed)))
3675 0 : (t-user (and t-parsed (nth 1 t-parsed)))
3676 0 : (t-name (and t-parsed (ange-ftp-quote-string (nth 2 t-parsed))))
3677 0 : (t-abbr (ange-ftp-abbreviate-filename newname filename))
3678 0 : (binary (or (ange-ftp-binary-file filename)
3679 0 : (ange-ftp-binary-file newname)))
3680 : temp1
3681 : temp2)
3682 :
3683 : ;; check to see if we can overwrite
3684 0 : (if (or (not ok-if-already-exists)
3685 0 : (numberp ok-if-already-exists))
3686 0 : (ange-ftp-barf-or-query-if-file-exists newname "copy to it"
3687 0 : (numberp ok-if-already-exists)))
3688 :
3689 : ;; do the copying.
3690 0 : (if f-parsed
3691 :
3692 : ;; filename was remote.
3693 0 : (progn
3694 0 : (if (or (ange-ftp-use-gateway-p f-host)
3695 0 : t-parsed)
3696 : ;; have to use intermediate file if we are getting via
3697 : ;; gateway machine or we are doing a remote to remote copy.
3698 0 : (setq temp1 (ange-ftp-make-tmp-name f-host)))
3699 :
3700 0 : (if binary
3701 0 : (ange-ftp-set-binary-mode f-host f-user))
3702 :
3703 0 : (ange-ftp-send-cmd
3704 0 : f-host
3705 0 : f-user
3706 0 : (list 'get f-name (or temp1 (ange-ftp-quote-string newname)))
3707 0 : (or msg
3708 0 : (if (and temp1 t-parsed)
3709 0 : (format "Getting %s" f-abbr)
3710 0 : (format "Copying %s to %s" f-abbr t-abbr)))
3711 0 : (list 'ange-ftp-cf1
3712 0 : filename newname binary msg
3713 0 : f-parsed f-host f-user f-name f-abbr
3714 0 : t-parsed t-host t-user t-name t-abbr
3715 0 : temp1 temp2 cont nowait)
3716 0 : nowait))
3717 :
3718 : ;; filename wasn't remote. newname must be remote. call the
3719 : ;; function which does the remainder of the copying work.
3720 0 : (ange-ftp-cf1 t nil
3721 0 : filename newname binary msg
3722 0 : f-parsed f-host f-user f-name f-abbr
3723 0 : t-parsed t-host t-user t-name t-abbr
3724 0 : nil nil cont nowait))))))
3725 :
3726 : (defvar ange-ftp-waiting-flag nil)
3727 :
3728 : ;; next part of copying routine.
3729 : (defun ange-ftp-cf1 (result line
3730 : filename newname binary msg
3731 : f-parsed f-host f-user _f-name f-abbr
3732 : t-parsed t-host t-user t-name t-abbr
3733 : temp1 temp2 cont nowait)
3734 0 : (if line
3735 : ;; filename must have been remote, and we must have just done a GET.
3736 0 : (unwind-protect
3737 0 : (or result
3738 : ;; GET failed for some reason. Clean up and get out.
3739 0 : (progn
3740 0 : (and temp1 (ange-ftp-del-tmp-name temp1))
3741 0 : (or cont
3742 0 : (if ange-ftp-waiting-flag
3743 0 : (throw 'ftp-error t)
3744 0 : (signal 'ftp-error
3745 0 : (list "Opening input file"
3746 0 : (format "FTP Error: \"%s\"" line)
3747 0 : filename))))))
3748 : ;; cleanup
3749 0 : (if binary
3750 0 : (ange-ftp-set-ascii-mode f-host f-user))))
3751 :
3752 0 : (if result
3753 : ;; We now have to copy either temp1 or filename to newname.
3754 0 : (if t-parsed
3755 :
3756 : ;; newname was remote.
3757 0 : (progn
3758 0 : (if (ange-ftp-use-gateway-p t-host)
3759 0 : (setq temp2 (ange-ftp-make-tmp-name t-host)))
3760 :
3761 : ;; make sure data is moved into the right place for the
3762 : ;; outgoing transfer. gateway temporary files complicate
3763 : ;; things nicely.
3764 0 : (if temp1
3765 0 : (if temp2
3766 0 : (if (string-equal temp1 temp2)
3767 0 : (setq temp1 nil)
3768 0 : (ange-ftp-real-copy-file temp1 temp2 t))
3769 0 : (setq temp2 temp1 temp1 nil))
3770 0 : (if temp2
3771 0 : (ange-ftp-real-copy-file filename temp2 t)))
3772 :
3773 0 : (if binary
3774 0 : (ange-ftp-set-binary-mode t-host t-user))
3775 :
3776 : ;; tell the process filter what size the file is.
3777 0 : (let ((attr (file-attributes (or temp2 filename))))
3778 0 : (if attr
3779 0 : (ange-ftp-set-xfer-size t-host t-user (nth 7 attr))))
3780 :
3781 0 : (ange-ftp-send-cmd
3782 0 : t-host
3783 0 : t-user
3784 0 : (list 'put (or temp2 (ange-ftp-quote-string filename)) t-name)
3785 0 : (or msg
3786 0 : (if (and temp2 f-parsed)
3787 0 : (format "Putting %s" newname)
3788 0 : (format "Copying %s to %s" f-abbr t-abbr)))
3789 0 : (list 'ange-ftp-cf2
3790 0 : newname t-host t-user binary temp1 temp2 cont)
3791 0 : nowait)
3792 0 : (ange-ftp-add-file-entry newname))
3793 :
3794 : ;; newname wasn't remote.
3795 0 : (ange-ftp-cf2 t nil newname t-host t-user binary temp1 temp2 cont))
3796 :
3797 : ;; first copy failed, tell caller
3798 0 : (ange-ftp-call-cont cont result line)))
3799 :
3800 : ;; last part of copying routine.
3801 : (defun ange-ftp-cf2 (result line newname t-host t-user binary temp1 temp2 cont)
3802 0 : (unwind-protect
3803 0 : (if line
3804 : ;; result from doing a local to remote copy.
3805 0 : (unwind-protect
3806 0 : (progn
3807 0 : (or result
3808 0 : (or cont
3809 0 : (if ange-ftp-waiting-flag
3810 0 : (throw 'ftp-error t)
3811 0 : (signal 'ftp-error
3812 0 : (list "Opening output file"
3813 0 : (format "FTP Error: \"%s\"" line)
3814 0 : newname)))))
3815 :
3816 0 : (ange-ftp-add-file-entry newname))
3817 :
3818 : ;; cleanup.
3819 0 : (if binary
3820 0 : (ange-ftp-set-ascii-mode t-host t-user)))
3821 :
3822 : ;; newname was local.
3823 0 : (if temp1
3824 0 : (ange-ftp-real-copy-file temp1 newname t)))
3825 :
3826 : ;; clean up
3827 0 : (and temp1 (ange-ftp-del-tmp-name temp1))
3828 0 : (and temp2 (ange-ftp-del-tmp-name temp2))
3829 0 : (ange-ftp-call-cont cont result line)))
3830 :
3831 : (defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists
3832 : keep-date preserve-uid-gid
3833 : _preserve-selinux-context)
3834 : (interactive "fCopy file: \nFCopy %s to file: \np")
3835 0 : (ange-ftp-copy-file-internal filename
3836 0 : newname
3837 0 : ok-if-already-exists
3838 0 : keep-date
3839 : nil
3840 : nil
3841 0 : (called-interactively-p 'interactive)))
3842 :
3843 : (defun ange-ftp-copy-files-async (okay-p line verbose-p files)
3844 : "Copy some files in the background.
3845 : OKAY-P must be t, and LINE does not matter. They are here to make this
3846 : function a valid CONT argument for `ange-ftp-raw-send-cmd'.
3847 : If VERBOSE-P is non-nil, print progress report in the echo area.
3848 : When all the files have been copied already, a message is shown anyway.
3849 : FILES is a list of files to copy in the form
3850 : (from-file to-file ok-if-already-exists keep-date)
3851 : E.g.,
3852 : (ange-ftp-copy-files-async t nil t \\='((\"a\" \"b\" t t) (\"c\" \"d\" t t)))"
3853 0 : (unless okay-p (error "%s: %s" 'ange-ftp-copy-files-async line))
3854 0 : (if files
3855 0 : (let* ((ff (car files))
3856 0 : (from-file (nth 0 ff))
3857 0 : (to-file (nth 1 ff))
3858 0 : (ok-if-already-exists (nth 2 ff))
3859 0 : (keep-date (nth 3 ff)))
3860 0 : (ange-ftp-copy-file-internal
3861 0 : from-file to-file ok-if-already-exists keep-date
3862 0 : (and verbose-p (format "%s --> %s" from-file to-file))
3863 0 : (list 'ange-ftp-copy-files-async verbose-p (cdr files))
3864 0 : t))
3865 0 : (message "%s: done" 'ange-ftp-copy-files-async)))
3866 :
3867 :
3868 : ;;;; ------------------------------------------------------------
3869 : ;;;; File renaming support.
3870 : ;;;; ------------------------------------------------------------
3871 :
3872 : (defun ange-ftp-rename-remote-to-remote (filename newname f-parsed t-parsed)
3873 : "Rename remote file FILENAME to remote file NEWNAME."
3874 0 : (let ((f-host (nth 0 f-parsed))
3875 0 : (f-user (nth 1 f-parsed))
3876 0 : (t-host (nth 0 t-parsed))
3877 0 : (t-user (nth 1 t-parsed)))
3878 0 : (if (and (string-equal f-host t-host)
3879 0 : (string-equal f-user t-user))
3880 0 : (let* ((f-name (ange-ftp-quote-string (nth 2 f-parsed)))
3881 0 : (t-name (ange-ftp-quote-string (nth 2 t-parsed)))
3882 0 : (cmd (list 'rename f-name t-name))
3883 0 : (fabbr (ange-ftp-abbreviate-filename filename))
3884 0 : (nabbr (ange-ftp-abbreviate-filename newname filename))
3885 0 : (result (ange-ftp-send-cmd f-host f-user cmd
3886 0 : (format "Renaming %s to %s"
3887 0 : fabbr
3888 0 : nabbr))))
3889 0 : (or (car result)
3890 0 : (signal 'ftp-error
3891 0 : (list
3892 : "Renaming"
3893 0 : (format "FTP Error: \"%s\"" (cdr result))
3894 0 : filename
3895 0 : newname)))
3896 0 : (ange-ftp-add-file-entry newname)
3897 0 : (ange-ftp-delete-file-entry filename))
3898 0 : (ange-ftp-copy-file-internal filename newname t nil)
3899 0 : (delete-file filename))))
3900 :
3901 : (defun ange-ftp-rename-local-to-remote (filename newname)
3902 : "Rename local file FILENAME to remote file NEWNAME."
3903 0 : (let* ((fabbr (ange-ftp-abbreviate-filename filename))
3904 0 : (nabbr (ange-ftp-abbreviate-filename newname filename))
3905 0 : (msg (format "Renaming %s to %s" fabbr nabbr)))
3906 0 : (ange-ftp-copy-file-internal filename newname t nil msg)
3907 0 : (let (ange-ftp-process-verbose)
3908 0 : (delete-file filename))))
3909 :
3910 : (defun ange-ftp-rename-remote-to-local (filename newname)
3911 : "Rename remote file FILENAME to local file NEWNAME."
3912 0 : (let* ((fabbr (ange-ftp-abbreviate-filename filename))
3913 0 : (nabbr (ange-ftp-abbreviate-filename newname filename))
3914 0 : (msg (format "Renaming %s to %s" fabbr nabbr)))
3915 0 : (ange-ftp-copy-file-internal filename newname t nil msg)
3916 0 : (let (ange-ftp-process-verbose)
3917 0 : (delete-file filename))))
3918 :
3919 : (defun ange-ftp-rename-file (filename newname &optional ok-if-already-exists)
3920 : (interactive "fRename file: \nFRename %s to file: \np")
3921 0 : (setq filename (expand-file-name filename))
3922 0 : (setq newname (expand-file-name newname))
3923 0 : (let* ((f-parsed (ange-ftp-ftp-name filename))
3924 0 : (t-parsed (ange-ftp-ftp-name newname)))
3925 0 : (if (and (or f-parsed t-parsed)
3926 0 : (or (not ok-if-already-exists)
3927 0 : (numberp ok-if-already-exists)))
3928 0 : (ange-ftp-barf-or-query-if-file-exists
3929 0 : newname
3930 : "rename to it"
3931 0 : (numberp ok-if-already-exists)))
3932 0 : (if f-parsed
3933 0 : (if t-parsed
3934 0 : (ange-ftp-rename-remote-to-remote filename newname f-parsed
3935 0 : t-parsed)
3936 0 : (ange-ftp-rename-remote-to-local filename newname))
3937 0 : (if t-parsed
3938 0 : (ange-ftp-rename-local-to-remote filename newname)
3939 0 : (ange-ftp-real-rename-file filename newname ok-if-already-exists)))))
3940 :
3941 : ;;;; ------------------------------------------------------------
3942 : ;;;; File name completion support.
3943 : ;;;; ------------------------------------------------------------
3944 :
3945 : ;; If the file entry is not a directory (nor a symlink pointing to a directory)
3946 : ;; returns whether the file (or file pointed to by the symlink) is ignored
3947 : ;; by completion-ignored-extensions.
3948 : ;; Note that `ange-ftp-this-dir' and `ange-ftp-completion-ignored-pattern'
3949 : ;; are used as free variables.
3950 : (defun ange-ftp-file-entry-not-ignored-p (symname val)
3951 0 : (if (stringp val)
3952 0 : (let ((file (ange-ftp-expand-symlink val ange-ftp-this-dir)))
3953 0 : (or (file-directory-p file)
3954 0 : (and (file-exists-p file)
3955 0 : (not (string-match ange-ftp-completion-ignored-pattern
3956 0 : symname)))))
3957 0 : (or val ; is a directory name
3958 0 : (not (string-match ange-ftp-completion-ignored-pattern symname)))))
3959 :
3960 : (defun ange-ftp-root-dir-p (dir)
3961 : ;; Maybe we should use something more like
3962 : ;; (equal dir (file-name-directory (directory-file-name dir))) -stef
3963 0 : (or (and (eq system-type 'windows-nt)
3964 0 : (string-match "\\`[a-zA-Z]:[/\\]\\'" dir))
3965 0 : (string-equal "/" dir)))
3966 :
3967 : (defmacro ange-ftp-ignore-errors-if-non-essential (&rest body)
3968 1 : `(if non-essential
3969 1 : (ignore-errors ,@body)
3970 1 : (progn ,@body)))
3971 :
3972 : (defun ange-ftp-file-name-all-completions (file dir)
3973 0 : (let ((ange-ftp-this-dir (expand-file-name dir)))
3974 0 : (if (ange-ftp-ftp-name ange-ftp-this-dir)
3975 0 : (ange-ftp-ignore-errors-if-non-essential
3976 : (ange-ftp-barf-if-not-directory ange-ftp-this-dir)
3977 : (setq ange-ftp-this-dir
3978 : (ange-ftp-real-file-name-as-directory ange-ftp-this-dir))
3979 : (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))
3980 : (completions (all-completions file tbl)))
3981 :
3982 : ;; see whether each matching file is a directory or not...
3983 : (mapcar
3984 : (lambda (file)
3985 : (let ((ent (gethash file tbl)))
3986 : (if (and ent
3987 : (or (not (stringp ent))
3988 : (file-directory-p
3989 : (ange-ftp-expand-symlink ent
3990 : ange-ftp-this-dir))))
3991 : (concat file "/")
3992 : file)))
3993 0 : completions)))
3994 :
3995 0 : (if (ange-ftp-root-dir-p ange-ftp-this-dir)
3996 0 : (nconc (all-completions file (ange-ftp-generate-root-prefixes))
3997 0 : (ange-ftp-real-file-name-all-completions file
3998 0 : ange-ftp-this-dir))
3999 0 : (ange-ftp-real-file-name-all-completions file ange-ftp-this-dir)))))
4000 :
4001 : (defun ange-ftp-file-name-completion (file dir &optional predicate)
4002 0 : (let ((ange-ftp-this-dir (expand-file-name dir)))
4003 0 : (if (ange-ftp-ftp-name ange-ftp-this-dir)
4004 0 : (progn
4005 0 : (ange-ftp-barf-if-not-directory ange-ftp-this-dir)
4006 0 : (if (equal file "")
4007 : ""
4008 0 : (setq ange-ftp-this-dir
4009 0 : (ange-ftp-real-file-name-as-directory ange-ftp-this-dir)) ;real?
4010 0 : (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))
4011 : (ange-ftp-completion-ignored-pattern
4012 0 : (mapconcat (lambda (s) (if (stringp s)
4013 0 : (concat (regexp-quote s) "$")
4014 0 : "/")) ; / never in filename
4015 0 : completion-ignored-extensions
4016 0 : "\\|")))
4017 0 : (save-match-data
4018 0 : (or (ange-ftp-file-name-completion-1
4019 0 : file tbl ange-ftp-this-dir
4020 0 : 'ange-ftp-file-entry-not-ignored-p)
4021 0 : (ange-ftp-file-name-completion-1
4022 0 : file tbl ange-ftp-this-dir))))))
4023 :
4024 0 : (if (ange-ftp-root-dir-p ange-ftp-this-dir)
4025 0 : (try-completion
4026 0 : file
4027 0 : (nconc (ange-ftp-generate-root-prefixes)
4028 0 : (ange-ftp-real-file-name-all-completions
4029 0 : file ange-ftp-this-dir))
4030 0 : predicate)
4031 0 : (if predicate
4032 0 : (ange-ftp-real-file-name-completion
4033 0 : file ange-ftp-this-dir predicate)
4034 0 : (ange-ftp-real-file-name-completion
4035 0 : file ange-ftp-this-dir))))))
4036 :
4037 :
4038 : (defun ange-ftp-file-name-completion-1 (file tbl dir &optional predicate)
4039 0 : (let ((bestmatch (try-completion file tbl predicate)))
4040 0 : (if bestmatch
4041 0 : (if (eq bestmatch t)
4042 0 : (if (file-directory-p (expand-file-name file dir))
4043 0 : (concat file "/")
4044 0 : t)
4045 0 : (if (and (eq (try-completion bestmatch tbl predicate) t)
4046 0 : (file-directory-p
4047 0 : (expand-file-name bestmatch dir)))
4048 0 : (concat bestmatch "/")
4049 0 : bestmatch)))))
4050 :
4051 : ;; Put these lines uncommented in your .emacs if you want C-r to refresh
4052 : ;; ange-ftp's cache whilst doing filename completion.
4053 : ;;
4054 : ;;(define-key minibuffer-local-completion-map "\C-r" 'ange-ftp-re-read-dir)
4055 : ;;(define-key minibuffer-local-must-match-map "\C-r" 'ange-ftp-re-read-dir)
4056 :
4057 : ;;;###autoload
4058 : (defalias 'ange-ftp-re-read-dir 'ange-ftp-reread-dir)
4059 :
4060 : ;;;###autoload
4061 : (defun ange-ftp-reread-dir (&optional dir)
4062 : "Reread remote directory DIR to update the directory cache.
4063 : The implementation of remote FTP file names caches directory contents
4064 : for speed. Therefore, when new remote files are created, Emacs
4065 : may not know they exist. You can use this command to reread a specific
4066 : directory, so that Emacs will know its current contents."
4067 : (interactive)
4068 0 : (if dir
4069 0 : (setq dir (expand-file-name dir))
4070 0 : (setq dir (file-name-directory (expand-file-name (buffer-string)))))
4071 0 : (if (ange-ftp-ftp-name dir)
4072 0 : (progn
4073 0 : (setq ange-ftp-ls-cache-file nil)
4074 0 : (remhash dir ange-ftp-files-hashtable)
4075 0 : (ange-ftp-get-files dir t))))
4076 :
4077 : (defun ange-ftp-make-directory (dir &optional parents)
4078 0 : (interactive (list (expand-file-name (read-directory-name "Make directory: "))))
4079 0 : (if parents
4080 0 : (let ((parent (file-name-directory (directory-file-name dir))))
4081 0 : (or (file-exists-p parent)
4082 0 : (ange-ftp-make-directory parent parents))))
4083 0 : (if (file-exists-p dir)
4084 0 : (unless parents
4085 0 : (error "Cannot make directory %s: file already exists" dir))
4086 0 : (let ((parsed (ange-ftp-ftp-name dir)))
4087 0 : (if parsed
4088 0 : (let* ((host (nth 0 parsed))
4089 0 : (user (nth 1 parsed))
4090 : ;; Some ftp's on unix machines (at least on Suns)
4091 : ;; insist that mkdir take a filename, and not a
4092 : ;; directory-name name as an arg. Argh!! This is a bug.
4093 : ;; Non-unix machines will probably always insist
4094 : ;; that mkdir takes a directory-name as an arg
4095 : ;; (as the ftp man page says it should).
4096 0 : (name (ange-ftp-quote-string
4097 0 : (if (eq (ange-ftp-host-type host) 'unix)
4098 0 : (ange-ftp-real-directory-file-name (nth 2 parsed))
4099 0 : (ange-ftp-real-file-name-as-directory
4100 0 : (nth 2 parsed)))))
4101 0 : (abbr (ange-ftp-abbreviate-filename dir))
4102 0 : (result (ange-ftp-send-cmd host user
4103 0 : (list 'mkdir name)
4104 0 : (format "Making directory %s"
4105 0 : abbr))))
4106 0 : (or (car result)
4107 0 : (ange-ftp-error host user
4108 0 : (format "Could not make directory %s: %s"
4109 0 : dir
4110 0 : (cdr result))))
4111 0 : (ange-ftp-add-file-entry dir t))
4112 0 : (ange-ftp-real-make-directory dir)))))
4113 :
4114 : (defun ange-ftp-delete-directory (dir &optional recursive trash)
4115 0 : (if (file-directory-p dir)
4116 0 : (let ((parsed (ange-ftp-ftp-name dir)))
4117 0 : (if recursive
4118 0 : (mapc
4119 : (lambda (file)
4120 0 : (if (file-directory-p file)
4121 0 : (ange-ftp-delete-directory file recursive trash)
4122 0 : (delete-file file trash)))
4123 : ;; We do not want to delete "." and "..".
4124 0 : (directory-files
4125 0 : dir 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
4126 0 : (if parsed
4127 0 : (let* ((host (nth 0 parsed))
4128 0 : (user (nth 1 parsed))
4129 : ;; Some ftp's on unix machines (at least on Suns)
4130 : ;; insist that rmdir take a filename, and not a
4131 : ;; directory-name name as an arg. Argh!! This is a bug.
4132 : ;; Non-unix machines will probably always insist
4133 : ;; that rmdir takes a directory-name as an arg
4134 : ;; (as the ftp man page says it should).
4135 0 : (name (ange-ftp-quote-string
4136 0 : (if (eq (ange-ftp-host-type host) 'unix)
4137 0 : (ange-ftp-real-directory-file-name
4138 0 : (nth 2 parsed))
4139 0 : (ange-ftp-real-file-name-as-directory
4140 0 : (nth 2 parsed)))))
4141 0 : (abbr (ange-ftp-abbreviate-filename dir))
4142 : (result
4143 0 : (progn
4144 : ;; CWD must not in this directory.
4145 0 : (ange-ftp-cd host user "/" 'noerror)
4146 0 : (ange-ftp-send-cmd host user
4147 0 : (list 'rmdir name)
4148 0 : (format "Removing directory %s"
4149 0 : abbr)))))
4150 0 : (or (car result)
4151 0 : (ange-ftp-error host user
4152 0 : (format "Could not remove directory %s: %s"
4153 0 : dir
4154 0 : (cdr result))))
4155 0 : (ange-ftp-delete-file-entry dir t))
4156 0 : (ange-ftp-real-delete-directory dir recursive trash)))
4157 0 : (error "Not a directory: %s" dir)))
4158 :
4159 : ;; Make a local copy of FILE and return its name.
4160 :
4161 : (defun ange-ftp-file-local-copy (file)
4162 0 : (let* ((fn1 (expand-file-name file))
4163 0 : (pa1 (ange-ftp-ftp-name fn1)))
4164 0 : (if pa1
4165 0 : (let ((tmp1 (ange-ftp-make-tmp-name (car pa1)
4166 0 : (file-name-extension file t))))
4167 0 : (ange-ftp-copy-file-internal fn1 tmp1 t nil
4168 0 : (format "Getting %s" fn1))
4169 0 : tmp1))))
4170 :
4171 : (defun ange-ftp-file-remote-p (file &optional identification connected)
4172 3 : (let* ((parsed (ange-ftp-ftp-name file))
4173 3 : (host (nth 0 parsed))
4174 3 : (user (nth 1 parsed))
4175 3 : (localname (nth 2 parsed)))
4176 3 : (and (or (not connected)
4177 0 : (let ((proc (get-process (ange-ftp-ftp-process-buffer host user))))
4178 0 : (and proc (processp proc)
4179 3 : (memq (process-status proc) '(run open)))))
4180 3 : (cond
4181 3 : ((eq identification 'method) (and parsed "ftp"))
4182 0 : ((eq identification 'user) user)
4183 0 : ((eq identification 'host) host)
4184 0 : ((eq identification 'localname) localname)
4185 3 : (t (ange-ftp-replace-name-component file ""))))))
4186 :
4187 : (defun ange-ftp-load (file &optional noerror nomessage nosuffix)
4188 0 : (if (ange-ftp-ftp-name file)
4189 0 : (let ((tryfiles (if nosuffix
4190 0 : (list file)
4191 0 : (list (concat file ".elc") (concat file ".el") file)))
4192 : ;; make sure there are no references to temp files
4193 : (load-force-doc-strings t)
4194 : copy)
4195 0 : (while (and tryfiles (not copy))
4196 0 : (catch 'ftp-error
4197 0 : (let ((ange-ftp-waiting-flag t))
4198 0 : (condition-case _error
4199 0 : (setq copy (ange-ftp-file-local-copy (car tryfiles)))
4200 0 : (ftp-error nil))))
4201 0 : (setq tryfiles (cdr tryfiles)))
4202 0 : (if copy
4203 0 : (unwind-protect
4204 0 : (funcall 'load copy noerror nomessage nosuffix)
4205 0 : (delete-file copy))
4206 0 : (or noerror
4207 0 : (signal 'file-error (list "Cannot open load file" file)))
4208 0 : nil))
4209 0 : (ange-ftp-real-load file noerror nomessage nosuffix)))
4210 :
4211 : ;; Calculate default-unhandled-directory for a given ange-ftp buffer.
4212 : (defun ange-ftp-unhandled-file-name-directory (_filename)
4213 : nil)
4214 :
4215 :
4216 : ;; Need the following functions for making filenames of compressed
4217 : ;; files, because some OS's (unlike UNIX) do not allow a filename to
4218 : ;; have two extensions.
4219 :
4220 : (defvar ange-ftp-make-compressed-filename-alist nil
4221 : "Alist of host-type-specific functions to process file names for compression.
4222 : Each element has the form (TYPE . FUNC).
4223 : FUNC should take one argument, a file name, and return a list
4224 : of the form (COMPRESSING NEWNAME).
4225 : COMPRESSING should be t if the specified file should be compressed,
4226 : and nil if it should be uncompressed (that is, if it is a compressed file).
4227 : NEWNAME should be the name to give the new compressed or uncompressed file.")
4228 :
4229 : (declare-function dired-compress-file "dired-aux" (file))
4230 :
4231 : (defun ange-ftp-dired-compress-file (name)
4232 : "Handler used by `dired-compress-file'."
4233 0 : (let ((parsed (ange-ftp-ftp-name name))
4234 : conversion-func)
4235 0 : (if (and parsed
4236 0 : (setq conversion-func
4237 0 : (cdr (assq (ange-ftp-host-type (car parsed))
4238 0 : ange-ftp-make-compressed-filename-alist))))
4239 0 : (let* ((decision
4240 0 : (save-match-data (funcall conversion-func name)))
4241 0 : (compressing (car decision))
4242 0 : (newfile (nth 1 decision)))
4243 0 : (if compressing
4244 0 : (ange-ftp-compress name newfile)
4245 0 : (ange-ftp-uncompress name newfile)))
4246 0 : (let (file-name-handler-alist)
4247 0 : (dired-compress-file name)))))
4248 :
4249 : ;; Copy FILE to this machine, compress it, and copy out to NFILE.
4250 : (defun ange-ftp-compress (file nfile)
4251 0 : (let* ((parsed (ange-ftp-ftp-name file))
4252 0 : (tmp1 (ange-ftp-make-tmp-name (car parsed)))
4253 0 : (tmp2 (ange-ftp-make-tmp-name (car parsed)))
4254 0 : (abbr (ange-ftp-abbreviate-filename file))
4255 0 : (nabbr (ange-ftp-abbreviate-filename nfile))
4256 0 : (msg1 (format "Getting %s" abbr))
4257 0 : (msg2 (format "Putting %s" nabbr)))
4258 0 : (unwind-protect
4259 0 : (progn
4260 0 : (ange-ftp-copy-file-internal file tmp1 t nil msg1)
4261 0 : (and ange-ftp-process-verbose
4262 0 : (ange-ftp-message "Compressing %s..." abbr))
4263 0 : (call-process-region (point)
4264 0 : (point)
4265 0 : shell-file-name
4266 : nil
4267 : t
4268 : nil
4269 : "-c"
4270 0 : (format "compress -f -c < %s > %s" tmp1 tmp2))
4271 0 : (and ange-ftp-process-verbose
4272 0 : (ange-ftp-message "Compressing %s...done" abbr))
4273 0 : (if (zerop (buffer-size))
4274 0 : (progn
4275 0 : (let (ange-ftp-process-verbose)
4276 0 : (delete-file file))
4277 0 : (ange-ftp-copy-file-internal tmp2 nfile t nil msg2))))
4278 0 : (ange-ftp-del-tmp-name tmp1)
4279 0 : (ange-ftp-del-tmp-name tmp2))))
4280 :
4281 : ;; Copy FILE to this machine, uncompress it, and copy out to NFILE.
4282 : (defun ange-ftp-uncompress (file nfile)
4283 0 : (let* ((parsed (ange-ftp-ftp-name file))
4284 0 : (tmp1 (ange-ftp-make-tmp-name (car parsed)))
4285 0 : (tmp2 (ange-ftp-make-tmp-name (car parsed)))
4286 0 : (abbr (ange-ftp-abbreviate-filename file))
4287 0 : (nabbr (ange-ftp-abbreviate-filename nfile))
4288 0 : (msg1 (format "Getting %s" abbr))
4289 0 : (msg2 (format "Putting %s" nabbr))
4290 : ;; ;; Cheap hack because of problems with binary file transfers from
4291 : ;; ;; VMS hosts.
4292 : ;; (gbinary (not (eq 'vms (ange-ftp-host-type (car parsed)))))
4293 : )
4294 0 : (unwind-protect
4295 0 : (progn
4296 0 : (ange-ftp-copy-file-internal file tmp1 t nil msg1)
4297 0 : (and ange-ftp-process-verbose
4298 0 : (ange-ftp-message "Uncompressing %s..." abbr))
4299 0 : (call-process-region (point)
4300 0 : (point)
4301 0 : shell-file-name
4302 : nil
4303 : t
4304 : nil
4305 : "-c"
4306 0 : (format "uncompress -c < %s > %s" tmp1 tmp2))
4307 0 : (and ange-ftp-process-verbose
4308 0 : (ange-ftp-message "Uncompressing %s...done" abbr))
4309 0 : (if (zerop (buffer-size))
4310 0 : (progn
4311 0 : (let (ange-ftp-process-verbose)
4312 0 : (delete-file file))
4313 0 : (ange-ftp-copy-file-internal tmp2 nfile t nil msg2))))
4314 0 : (ange-ftp-del-tmp-name tmp1)
4315 0 : (ange-ftp-del-tmp-name tmp2))))
4316 :
4317 : (defun ange-ftp-find-backup-file-name (fn)
4318 : ;; Either return the ordinary backup name, etc.,
4319 : ;; or return nil meaning don't make a backup.
4320 0 : (if ange-ftp-make-backup-files
4321 0 : (ange-ftp-real-find-backup-file-name fn)))
4322 :
4323 : ;;; Define the handler for special file names
4324 : ;;; that causes ange-ftp to be invoked.
4325 :
4326 : ;;;###autoload
4327 : (defun ange-ftp-hook-function (operation &rest args)
4328 3 : (let ((fn (get operation 'ange-ftp)))
4329 3 : (if fn
4330 : ;; Catch also errors in process-filter.
4331 3 : (condition-case err
4332 3 : (let ((debug-on-error t))
4333 3 : (save-match-data (apply fn args)))
4334 3 : (error (signal (car err) (cdr err))))
4335 3 : (ange-ftp-run-real-handler operation args))))
4336 :
4337 : ;; The following code is commented out because Tramp now deals with
4338 : ;; Ange-FTP filenames, too.
4339 :
4340 : ;;-;;; This regexp takes care of real ange-ftp file names (with a slash
4341 : ;;-;;; and colon).
4342 : ;;-;;; Don't allow the host name to end in a period--some systems use /.:
4343 : ;;-;;;###autoload
4344 : ;;-(or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist)
4345 : ;;- (setq file-name-handler-alist
4346 : ;;- (cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function)
4347 : ;;- file-name-handler-alist)))
4348 : ;;-
4349 : ;;-;;; This regexp recognizes absolute filenames with only one component,
4350 : ;;-;;; for the sake of hostname completion.
4351 : ;;-;;;###autoload
4352 : ;;-(or (assoc "^/[^/:]*\\'" file-name-handler-alist)
4353 : ;;- (setq file-name-handler-alist
4354 : ;;- (cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function)
4355 : ;;- file-name-handler-alist)))
4356 : ;;-
4357 : ;;-;;; This regexp recognizes absolute filenames with only one component
4358 : ;;-;;; on Windows, for the sake of hostname completion.
4359 : ;;-;;; NB. Do not mark this as autoload, because it is very common to
4360 : ;;-;;; do completions in the root directory of drives on Windows.
4361 : ;;-(and (memq system-type '(ms-dos windows-nt))
4362 : ;;- (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist)
4363 : ;;- (setq file-name-handler-alist
4364 : ;;- (cons '("^[a-zA-Z]:/[^/:]*\\'" .
4365 : ;;- ange-ftp-completion-hook-function)
4366 : ;;- file-name-handler-alist))))
4367 :
4368 : ;;; The above two forms are sufficient to cause this file to be loaded
4369 : ;;; if the user ever uses a file name with a colon in it.
4370 :
4371 : ;;; This sets the mode
4372 : (add-hook 'find-file-hook 'ange-ftp-set-buffer-mode)
4373 :
4374 : ;;; Now say where to find the handlers for particular operations.
4375 :
4376 : (put 'file-name-directory 'ange-ftp 'ange-ftp-file-name-directory)
4377 : (put 'file-name-nondirectory 'ange-ftp 'ange-ftp-file-name-nondirectory)
4378 : (put 'file-name-as-directory 'ange-ftp 'ange-ftp-file-name-as-directory)
4379 : (put 'directory-file-name 'ange-ftp 'ange-ftp-directory-file-name)
4380 : (put 'expand-file-name 'ange-ftp 'ange-ftp-expand-file-name)
4381 : (put 'make-directory 'ange-ftp 'ange-ftp-make-directory)
4382 : (put 'delete-directory 'ange-ftp 'ange-ftp-delete-directory)
4383 : (put 'insert-file-contents 'ange-ftp 'ange-ftp-insert-file-contents)
4384 : (put 'directory-files 'ange-ftp 'ange-ftp-directory-files)
4385 : (put 'directory-files-and-attributes 'ange-ftp
4386 : 'ange-ftp-directory-files-and-attributes)
4387 : (put 'file-directory-p 'ange-ftp 'ange-ftp-file-directory-p)
4388 : (put 'file-writable-p 'ange-ftp 'ange-ftp-file-writable-p)
4389 : (put 'file-readable-p 'ange-ftp 'ange-ftp-file-readable-p)
4390 : (put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p)
4391 : (put 'file-symlink-p 'ange-ftp 'ange-ftp-file-symlink-p)
4392 : (put 'delete-file 'ange-ftp 'ange-ftp-delete-file)
4393 : (put 'verify-visited-file-modtime 'ange-ftp
4394 : 'ange-ftp-verify-visited-file-modtime)
4395 : (put 'file-exists-p 'ange-ftp 'ange-ftp-file-exists-p)
4396 : (put 'write-region 'ange-ftp 'ange-ftp-write-region)
4397 : (put 'copy-file 'ange-ftp 'ange-ftp-copy-file)
4398 : (put 'rename-file 'ange-ftp 'ange-ftp-rename-file)
4399 : (put 'file-attributes 'ange-ftp 'ange-ftp-file-attributes)
4400 : (put 'file-newer-than-file-p 'ange-ftp 'ange-ftp-file-newer-than-file-p)
4401 : (put 'file-name-all-completions 'ange-ftp 'ange-ftp-file-name-all-completions)
4402 : (put 'file-name-completion 'ange-ftp 'ange-ftp-file-name-completion)
4403 : (put 'insert-directory 'ange-ftp 'ange-ftp-insert-directory)
4404 : (put 'file-local-copy 'ange-ftp 'ange-ftp-file-local-copy)
4405 : (put 'file-remote-p 'ange-ftp 'ange-ftp-file-remote-p)
4406 : (put 'unhandled-file-name-directory 'ange-ftp
4407 : 'ange-ftp-unhandled-file-name-directory)
4408 : (put 'file-name-sans-versions 'ange-ftp 'ange-ftp-file-name-sans-versions)
4409 : (put 'dired-uncache 'ange-ftp 'ange-ftp-dired-uncache)
4410 : (put 'dired-compress-file 'ange-ftp 'ange-ftp-dired-compress-file)
4411 : (put 'load 'ange-ftp 'ange-ftp-load)
4412 : (put 'find-backup-file-name 'ange-ftp 'ange-ftp-find-backup-file-name)
4413 : (put 'set-file-modes 'ange-ftp 'ange-ftp-set-file-modes)
4414 :
4415 : ;; Turn off truename processing to save time.
4416 : ;; Treat each name as its own truename.
4417 : (put 'file-truename 'ange-ftp 'identity)
4418 :
4419 : ;; We must return non-nil in order to mask our inability to do the job.
4420 : ;; Otherwise there are errors when applied to the target file during
4421 : ;; copying from a (localhost) Tramp file.
4422 : (put 'set-file-times 'ange-ftp 'ignore)
4423 :
4424 : ;; Turn off RCS/SCCS processing to save time.
4425 : ;; This returns nil for any file name as argument.
4426 : (put 'vc-registered 'ange-ftp 'null)
4427 :
4428 : ;; We can handle process-file in a restricted way (just for chown).
4429 : ;; Nothing possible for `start-file-process'.
4430 : (put 'process-file 'ange-ftp 'ange-ftp-process-file)
4431 : (put 'start-file-process 'ange-ftp 'ignore)
4432 : (put 'shell-command 'ange-ftp 'ange-ftp-shell-command)
4433 :
4434 : ;;; Define ways of getting at unmodified Emacs primitives,
4435 : ;;; turning off our handler.
4436 :
4437 : (defun ange-ftp-run-real-handler-orig (operation args)
4438 0 : (let ((inhibit-file-name-handlers
4439 0 : (cons 'ange-ftp-hook-function
4440 0 : (cons 'ange-ftp-completion-hook-function
4441 0 : (and (eq inhibit-file-name-operation operation)
4442 0 : inhibit-file-name-handlers))))
4443 0 : (inhibit-file-name-operation operation))
4444 0 : (apply operation args)))
4445 :
4446 : (defalias 'ange-ftp-run-real-handler
4447 : (if (fboundp 'tramp-run-real-handler)
4448 : 'tramp-run-real-handler 'ange-ftp-run-real-handler-orig))
4449 :
4450 : (defun ange-ftp-real-file-name-directory (&rest args)
4451 0 : (ange-ftp-run-real-handler 'file-name-directory args))
4452 : (defun ange-ftp-real-file-name-nondirectory (&rest args)
4453 0 : (ange-ftp-run-real-handler 'file-name-nondirectory args))
4454 : (defun ange-ftp-real-file-name-as-directory (&rest args)
4455 0 : (ange-ftp-run-real-handler 'file-name-as-directory args))
4456 : (defun ange-ftp-real-directory-file-name (&rest args)
4457 0 : (ange-ftp-run-real-handler 'directory-file-name args))
4458 : (defun ange-ftp-real-expand-file-name (&rest args)
4459 1 : (ange-ftp-run-real-handler 'expand-file-name args))
4460 : (defun ange-ftp-real-make-directory (&rest args)
4461 0 : (ange-ftp-run-real-handler 'make-directory args))
4462 : (defun ange-ftp-real-delete-directory (&rest args)
4463 0 : (ange-ftp-run-real-handler 'delete-directory args))
4464 : (defun ange-ftp-real-insert-file-contents (&rest args)
4465 0 : (ange-ftp-run-real-handler 'insert-file-contents args))
4466 : (defun ange-ftp-real-directory-files (&rest args)
4467 0 : (ange-ftp-run-real-handler 'directory-files args))
4468 : (defun ange-ftp-real-directory-files-and-attributes (&rest args)
4469 0 : (ange-ftp-run-real-handler 'directory-files-and-attributes args))
4470 : (defun ange-ftp-real-file-directory-p (&rest args)
4471 0 : (ange-ftp-run-real-handler 'file-directory-p args))
4472 : (defun ange-ftp-real-file-writable-p (&rest args)
4473 0 : (ange-ftp-run-real-handler 'file-writable-p args))
4474 : (defun ange-ftp-real-file-readable-p (&rest args)
4475 0 : (ange-ftp-run-real-handler 'file-readable-p args))
4476 : (defun ange-ftp-real-file-executable-p (&rest args)
4477 0 : (ange-ftp-run-real-handler 'file-executable-p args))
4478 : (defun ange-ftp-real-file-symlink-p (&rest args)
4479 1 : (ange-ftp-run-real-handler 'file-symlink-p args))
4480 : (defun ange-ftp-real-delete-file (&rest args)
4481 0 : (ange-ftp-run-real-handler 'delete-file args))
4482 : (defun ange-ftp-real-verify-visited-file-modtime (&rest args)
4483 0 : (ange-ftp-run-real-handler 'verify-visited-file-modtime args))
4484 : (defun ange-ftp-real-file-exists-p (&rest args)
4485 0 : (ange-ftp-run-real-handler 'file-exists-p args))
4486 : (defun ange-ftp-real-write-region (&rest args)
4487 0 : (ange-ftp-run-real-handler 'write-region args))
4488 : (defun ange-ftp-real-backup-buffer (&rest args)
4489 0 : (ange-ftp-run-real-handler 'backup-buffer args))
4490 : (defun ange-ftp-real-copy-file (&rest args)
4491 0 : (ange-ftp-run-real-handler 'copy-file args))
4492 : (defun ange-ftp-real-rename-file (&rest args)
4493 0 : (ange-ftp-run-real-handler 'rename-file args))
4494 : (defun ange-ftp-real-file-attributes (&rest args)
4495 1 : (ange-ftp-run-real-handler 'file-attributes args))
4496 : (defun ange-ftp-real-file-newer-than-file-p (&rest args)
4497 0 : (ange-ftp-run-real-handler 'file-newer-than-file-p args))
4498 : (defun ange-ftp-real-file-name-all-completions (&rest args)
4499 0 : (ange-ftp-run-real-handler 'file-name-all-completions args))
4500 : (defun ange-ftp-real-file-name-completion (&rest args)
4501 0 : (ange-ftp-run-real-handler 'file-name-completion args))
4502 : (defun ange-ftp-real-insert-directory (&rest args)
4503 0 : (ange-ftp-run-real-handler 'insert-directory args))
4504 : (defun ange-ftp-real-file-name-sans-versions (&rest args)
4505 0 : (ange-ftp-run-real-handler 'file-name-sans-versions args))
4506 : (defun ange-ftp-real-shell-command (&rest args)
4507 0 : (ange-ftp-run-real-handler 'shell-command args))
4508 : (defun ange-ftp-real-load (&rest args)
4509 0 : (ange-ftp-run-real-handler 'load args))
4510 : (defun ange-ftp-real-find-backup-file-name (&rest args)
4511 0 : (ange-ftp-run-real-handler 'find-backup-file-name args))
4512 :
4513 : ;; Here we support using dired on remote hosts.
4514 : ;; I have turned off the support for using dired on foreign directory formats.
4515 : ;; That involves too many unclean hooks.
4516 : ;; It would be cleaner to support such operations by
4517 : ;; converting the foreign directory format to something dired can understand;
4518 : ;; something close to ls -l output.
4519 : ;; The logical place to do this is in the functions ange-ftp-parse-...-listing.
4520 :
4521 : ;; Some of the old dired hooks would still be needed even if this is done.
4522 : ;; I have preserved (and modernized) those hooks.
4523 : ;; So the format conversion should be all that is needed.
4524 :
4525 : ;; When called from dired, SWITCHES may start with "--dired".
4526 : ;; `ange-ftp-ls' handles this.
4527 :
4528 : (defun ange-ftp-insert-directory (file switches &optional wildcard full)
4529 0 : (if (not (ange-ftp-ftp-name (expand-file-name file)))
4530 0 : (ange-ftp-real-insert-directory file switches wildcard full)
4531 : ;; We used to follow symlinks on `file' here. Apparently it was done
4532 : ;; because some FTP servers react to "ls foo" by listing the symlink foo
4533 : ;; rather than the directory it points to. Now that ange-ftp-ls uses
4534 : ;; "cd foo; ls" instead, this is not necessary any more.
4535 0 : (let ((beg (point))
4536 0 : (end (point-marker)))
4537 0 : (set-marker-insertion-type end t)
4538 0 : (insert
4539 0 : (cond
4540 0 : (wildcard
4541 0 : (let ((default-directory (file-name-directory file)))
4542 0 : (ange-ftp-ls (file-name-nondirectory file) switches nil nil t)))
4543 0 : (full
4544 0 : (ange-ftp-ls file switches 'parse))
4545 : (t
4546 : ;; If `full' is nil we're going to do `ls' for a single file.
4547 : ;; Problem is that for various reasons, ange-ftp-ls needs to cd and
4548 : ;; then do an ls of current dir, which obviously won't work if we
4549 : ;; want to ls a file. So instead, we get a full listing of the
4550 : ;; parent directory and extract the line corresponding to `file'.
4551 0 : (when (string-match "-?d\\'" switches)
4552 : ;; Remove "d" which dired added to `switches'.
4553 0 : (setq switches (substring switches 0 (match-beginning 0))))
4554 0 : (setq file (directory-file-name file))
4555 0 : (let* ((dirlist (ange-ftp-ls (or (file-name-directory file) ".")
4556 0 : switches 'parse))
4557 0 : (filename (file-name-nondirectory file))
4558 : (case-fold-search nil))
4559 : ;; FIXME: This presumes a particular output format, which is
4560 : ;; basically Unix.
4561 0 : (if (string-match (concat "^.+[^ ] " (regexp-quote filename)
4562 0 : "\\( -> .*\\)?[@/*=]?\n") dirlist)
4563 0 : (match-string 0 dirlist)
4564 0 : "")))))
4565 :
4566 : ;; Insert " " for dired's alignment sanity.
4567 0 : (goto-char beg)
4568 0 : (while (re-search-forward "^\\(\\S-\\)" end 'move)
4569 0 : (replace-match " \\1"))
4570 :
4571 : ;; The inserted file could be from somewhere else.
4572 0 : (when (and (not wildcard) (not full)
4573 0 : (search-backward
4574 0 : (if (zerop (length (file-name-nondirectory
4575 0 : (expand-file-name file))))
4576 : "."
4577 0 : (file-name-nondirectory file))
4578 0 : nil 'noerror))
4579 0 : (replace-match (file-relative-name (expand-file-name file)) t)
4580 0 : (goto-char end))
4581 :
4582 0 : (set-marker end nil))))
4583 :
4584 : (defun ange-ftp-dired-uncache (dir)
4585 0 : (if (ange-ftp-ftp-name (expand-file-name dir))
4586 0 : (setq ange-ftp-ls-cache-file nil)))
4587 :
4588 : (defvar ange-ftp-sans-version-alist nil
4589 : "Alist of mapping host type into function to remove file version numbers.")
4590 :
4591 : (defun ange-ftp-file-name-sans-versions (file keep-backup-version)
4592 0 : (let* ((short (ange-ftp-abbreviate-filename file))
4593 0 : (parsed (ange-ftp-ftp-name short))
4594 0 : (func (if parsed (cdr (assq (ange-ftp-host-type (car parsed))
4595 0 : ange-ftp-sans-version-alist)))))
4596 0 : (if func (funcall func file keep-backup-version)
4597 0 : (ange-ftp-real-file-name-sans-versions file keep-backup-version))))
4598 :
4599 : ;; This is the handler for shell-command.
4600 : (defun ange-ftp-shell-command (command &optional output-buffer error-buffer)
4601 0 : (let* ((parsed (ange-ftp-ftp-name default-directory))
4602 0 : (host (nth 0 parsed))
4603 0 : (name (nth 2 parsed)))
4604 0 : (if (not parsed)
4605 0 : (ange-ftp-real-shell-command command output-buffer error-buffer)
4606 0 : (if (> (length name) 0) ; else it's $HOME
4607 0 : (setq command (concat "cd " name "; " command)))
4608 : ;; Remove port from the hostname
4609 0 : (when (string-match "\\(.*\\)#" host)
4610 0 : (setq host (match-string 1 host)))
4611 0 : (setq command
4612 0 : (format "%s %s \"%s\"" ; remsh -l USER does not work well
4613 : ; on a hp-ux machine I tried
4614 0 : remote-shell-program host command))
4615 0 : (ange-ftp-message "Remote command `%s' ..." command)
4616 : ;; Cannot call ange-ftp-real-dired-run-shell-command here as it
4617 : ;; would prepend "cd default-directory" --- which bombs because
4618 : ;; default-directory is in ange-ftp syntax for remote file names.
4619 0 : (ange-ftp-real-shell-command command output-buffer error-buffer))))
4620 :
4621 : ;;; This is the handler for process-file.
4622 : (defun ange-ftp-process-file (program infile buffer display &rest arguments)
4623 : ;; PROGRAM is always one of those below in the cond in dired.el.
4624 : ;; The ARGUMENTS are (nearly) always files.
4625 0 : (if (ange-ftp-ftp-name default-directory)
4626 : ;; Can't use ange-ftp-dired-host-type here because the current
4627 : ;; buffer is *dired-check-process output*
4628 0 : (condition-case oops
4629 0 : (cond ((equal (or (bound-and-true-p dired-chmod-program) "chmod")
4630 0 : program)
4631 0 : (ange-ftp-call-chmod arguments))
4632 : ;; ((equal "chgrp" program))
4633 : ;; ((equal dired-chown-program program))
4634 0 : (t (error "Unknown remote command: %s" program)))
4635 0 : (ftp-error (insert (format "%s: %s, %s\n"
4636 0 : (nth 1 oops)
4637 0 : (nth 2 oops)
4638 0 : (nth 3 oops)))
4639 : ;; Caller expects nonzero value to mean failure.
4640 : 1)
4641 0 : (error (insert (format "%s\n" (nth 1 oops)))
4642 0 : 1))
4643 0 : (apply 'call-process program infile buffer display arguments)))
4644 :
4645 : ;; Handle an attempt to run chmod on a remote file
4646 : ;; by using the ftp chmod command.
4647 : (defun ange-ftp-call-chmod (args)
4648 0 : (if (< (length args) 2)
4649 0 : (error "ange-ftp-call-chmod: missing mode and/or filename: %s" args))
4650 0 : (let ((mode (car args))
4651 0 : (rest (cdr args)))
4652 0 : (if (equal "--" (car rest))
4653 0 : (setq rest (cdr rest)))
4654 0 : (mapc
4655 : (lambda (file)
4656 0 : (setq file (expand-file-name file))
4657 0 : (let ((parsed (ange-ftp-ftp-name file)))
4658 0 : (if parsed
4659 0 : (let* ((host (nth 0 parsed))
4660 0 : (user (nth 1 parsed))
4661 0 : (name (ange-ftp-quote-string (nth 2 parsed)))
4662 0 : (abbr (ange-ftp-abbreviate-filename file))
4663 0 : (result (ange-ftp-send-cmd host user
4664 0 : (list 'chmod mode name)
4665 0 : (format "doing chmod %s"
4666 0 : abbr))))
4667 0 : (or (car result)
4668 0 : (ange-ftp-error
4669 0 : host user (concat "CHMOD failed: " (cdr result))))))))
4670 0 : rest))
4671 0 : (setq ange-ftp-ls-cache-file nil) ;Stop confusing Dired.
4672 : 0)
4673 :
4674 : (defun ange-ftp-set-file-modes (filename mode)
4675 0 : (ange-ftp-call-chmod (list (format "%o" mode) filename)))
4676 :
4677 : ;; This is turned off because it has nothing properly to do
4678 : ;; with dired. It could be reasonable to adapt this to
4679 : ;; replace ange-ftp-copy-file.
4680 :
4681 : ;;;;; ------------------------------------------------------------
4682 : ;;;;; Noddy support for async copy-file within dired.
4683 : ;;;;; ------------------------------------------------------------
4684 :
4685 : ;;(defun ange-ftp-dired-copy-file (from to ok-flag &optional cont nowait)
4686 : ;; "Documented as original."
4687 : ;; (dired-handle-overwrite to)
4688 : ;; (ange-ftp-copy-file-internal from to ok-flag dired-copy-preserve-time nil
4689 : ;; cont nowait))
4690 :
4691 : ;;(defun ange-ftp-dired-do-create-files (op-symbol file-creator operation arg
4692 : ;; &optional marker-char op1
4693 : ;; how-to)
4694 : ;; "Documented as original."
4695 : ;; ;; we need to let ange-ftp-dired-create-files know that we indirectly
4696 : ;; ;; called it rather than somebody else.
4697 : ;; (let ((ange-ftp-dired-do-create-files t)) ; tell who caller is
4698 : ;; (ange-ftp-real-dired-do-create-files op-symbol file-creator operation
4699 : ;; arg marker-char op1 how-to)))
4700 :
4701 : ;;(defun ange-ftp-dired-create-files (file-creator operation fn-list name-constructor
4702 : ;; &optional marker-char)
4703 : ;; "Documented as original."
4704 : ;; (if (and (boundp 'ange-ftp-dired-do-create-files)
4705 : ;; ;; called from ange-ftp-dired-do-create-files?
4706 : ;; ange-ftp-dired-do-create-files
4707 : ;; ;; any files worth copying?
4708 : ;; fn-list
4709 : ;; ;; we only support async copy-file at the mo.
4710 : ;; (eq file-creator 'dired-copy-file)
4711 : ;; ;; it is only worth calling the alternative function for remote files
4712 : ;; ;; as we tie ourself in recursive knots otherwise.
4713 : ;; (or (ange-ftp-ftp-name (car fn-list))
4714 : ;; ;; we can only call the name constructor for dired-do-create-files
4715 : ;; ;; since the one for regexps starts prompting here, there and
4716 : ;; ;; everywhere.
4717 : ;; (ange-ftp-ftp-name (funcall name-constructor (car fn-list)))))
4718 : ;; ;; use the process-filter driven routine rather than the iterative one.
4719 : ;; (ange-ftp-dcf-1 file-creator
4720 : ;; operation
4721 : ;; fn-list
4722 : ;; name-constructor
4723 : ;; (and (boundp 'target) target) ;dynamically bound
4724 : ;; marker-char
4725 : ;; (current-buffer)
4726 : ;; nil ;overwrite-query
4727 : ;; nil ;overwrite-backup-query
4728 : ;; nil ;failures
4729 : ;; nil ;skipped
4730 : ;; 0 ;success-count
4731 : ;; (length fn-list) ;total
4732 : ;; )
4733 : ;; ;; normal case... use the interactive routine... much cheaper.
4734 : ;; (ange-ftp-real-dired-create-files file-creator operation fn-list
4735 : ;; name-constructor marker-char)))
4736 :
4737 : ;;(defun ange-ftp-dcf-1 (file-creator operation fn-list name-constructor
4738 : ;; target marker-char buffer overwrite-query
4739 : ;; overwrite-backup-query failures skipped
4740 : ;; success-count total)
4741 : ;; (with-current-buffer buffer
4742 : ;; (if (null fn-list)
4743 : ;; (ange-ftp-dcf-3 failures operation total skipped
4744 : ;; success-count buffer)
4745 :
4746 : ;; (let* ((from (car fn-list))
4747 : ;; (to (funcall name-constructor from)))
4748 : ;; (if (equal to from)
4749 : ;; (progn
4750 : ;; (setq to nil)
4751 : ;; (dired-log "Cannot %s to same file: %s\n"
4752 : ;; (downcase operation) from)))
4753 : ;; (if (not to)
4754 : ;; (ange-ftp-dcf-1 file-creator
4755 : ;; operation
4756 : ;; (cdr fn-list)
4757 : ;; name-constructor
4758 : ;; target
4759 : ;; marker-char
4760 : ;; buffer
4761 : ;; overwrite-query
4762 : ;; overwrite-backup-query
4763 : ;; failures
4764 : ;; (cons (dired-make-relative from) skipped)
4765 : ;; success-count
4766 : ;; total)
4767 : ;; (let* ((overwrite (file-exists-p to))
4768 : ;; (overwrite-confirmed ; for dired-handle-overwrite
4769 : ;; (and overwrite
4770 : ;; (let ((help-form '(format "\
4771 : ;;Type SPC or `y' to overwrite file `%s',
4772 : ;;DEL or `n' to skip to next,
4773 : ;;ESC or `q' to not overwrite any of the remaining files,
4774 : ;;`!' to overwrite all remaining files with no more questions." to)))
4775 : ;; (dired-query 'overwrite-query
4776 : ;; "Overwrite `%s'?" to))))
4777 : ;; ;; must determine if FROM is marked before file-creator
4778 : ;; ;; gets a chance to delete it (in case of a move).
4779 : ;; (actual-marker-char
4780 : ;; (cond ((integerp marker-char) marker-char)
4781 : ;; (marker-char (dired-file-marker from)) ; slow
4782 : ;; (t nil))))
4783 : ;; (condition-case err
4784 : ;; (funcall file-creator from to overwrite-confirmed
4785 : ;; (list 'ange-ftp-dcf-2
4786 : ;; nil ;err
4787 : ;; file-creator operation fn-list
4788 : ;; name-constructor
4789 : ;; target
4790 : ;; marker-char actual-marker-char
4791 : ;; buffer to from
4792 : ;; overwrite
4793 : ;; overwrite-confirmed
4794 : ;; overwrite-query
4795 : ;; overwrite-backup-query
4796 : ;; failures skipped success-count
4797 : ;; total)
4798 : ;; t)
4799 : ;; (file-error ; FILE-CREATOR aborted
4800 : ;; (ange-ftp-dcf-2 nil ;result
4801 : ;; nil ;line
4802 : ;; err
4803 : ;; file-creator operation fn-list
4804 : ;; name-constructor
4805 : ;; target
4806 : ;; marker-char actual-marker-char
4807 : ;; buffer to from
4808 : ;; overwrite
4809 : ;; overwrite-confirmed
4810 : ;; overwrite-query
4811 : ;; overwrite-backup-query
4812 : ;; failures skipped success-count
4813 : ;; total)))))))))
4814 :
4815 : ;;(defun ange-ftp-dcf-2 (result line err
4816 : ;; file-creator operation fn-list
4817 : ;; name-constructor
4818 : ;; target
4819 : ;; marker-char actual-marker-char
4820 : ;; buffer to from
4821 : ;; overwrite
4822 : ;; overwrite-confirmed
4823 : ;; overwrite-query
4824 : ;; overwrite-backup-query
4825 : ;; failures skipped success-count
4826 : ;; total)
4827 : ;; (with-current-buffer buffer
4828 : ;; (if (or err (not result))
4829 : ;; (progn
4830 : ;; (setq failures (cons (dired-make-relative from) failures))
4831 : ;; (dired-log "%s `%s' to `%s' failed:\n%s\n"
4832 : ;; operation from to (or err line)))
4833 : ;; (if overwrite
4834 : ;; ;; If we get here, file-creator hasn't been aborted
4835 : ;; ;; and the old entry (if any) has to be deleted
4836 : ;; ;; before adding the new entry.
4837 : ;; (dired-remove-file to))
4838 : ;; (setq success-count (1+ success-count))
4839 : ;; (message "%s: %d of %d" operation success-count total)
4840 : ;; (dired-add-file to actual-marker-char))
4841 :
4842 : ;; (ange-ftp-dcf-1 file-creator operation (cdr fn-list)
4843 : ;; name-constructor
4844 : ;; target
4845 : ;; marker-char
4846 : ;; buffer
4847 : ;; overwrite-query
4848 : ;; overwrite-backup-query
4849 : ;; failures skipped success-count
4850 : ;; total)))
4851 :
4852 : ;;(defun ange-ftp-dcf-3 (failures operation total skipped success-count
4853 : ;; buffer)
4854 : ;; (with-current-buffer buffer
4855 : ;; (cond
4856 : ;; (failures
4857 : ;; (dired-log-summary
4858 : ;; (message "%s failed for %d of %d file%s %s"
4859 : ;; operation (length failures) total
4860 : ;; (dired-plural-s total) failures)))
4861 : ;; (skipped
4862 : ;; (dired-log-summary
4863 : ;; (message "%s: %d of %d file%s skipped %s"
4864 : ;; operation (length skipped) total
4865 : ;; (dired-plural-s total) skipped)))
4866 : ;; (t
4867 : ;; (message "%s: %s file%s."
4868 : ;; operation success-count (dired-plural-s success-count))))
4869 : ;; (dired-move-to-filename)))
4870 :
4871 : ;;;; -----------------------------------------------
4872 : ;;;; Unix Descriptive Listing (dl) Support
4873 : ;;;; -----------------------------------------------
4874 :
4875 : ;; This is turned off because nothing uses it currently
4876 : ;; and because I don't understand what it's supposed to be for. --rms.
4877 :
4878 : ;;(defconst ange-ftp-dired-dl-re-dir
4879 : ;; "^. [^ /]+/[ \n]"
4880 : ;; "Regular expression to use to search for dl directories.")
4881 :
4882 : ;;(or (assq 'unix:dl ange-ftp-dired-re-dir-alist)
4883 : ;; (setq ange-ftp-dired-re-dir-alist
4884 : ;; (cons (cons 'unix:dl ange-ftp-dired-dl-re-dir)
4885 : ;; ange-ftp-dired-re-dir-alist)))
4886 :
4887 : ;;(defun ange-ftp-dired-dl-move-to-filename (&optional raise-error eol)
4888 : ;; "In dired, move to the first character of the filename on this line."
4889 : ;; ;; This is the Unix dl version.
4890 : ;; (or eol (setq eol (progn (end-of-line) (point))))
4891 : ;; (let (case-fold-search)
4892 : ;; (beginning-of-line)
4893 : ;; (if (looking-at ". [^ ]+ +\\([0-9]+\\|-\\|=\\) ")
4894 : ;; (goto-char (+ (point) 2))
4895 : ;; (if raise-error
4896 : ;; (error "No file on this line")
4897 : ;; nil))))
4898 :
4899 : ;;(or (assq 'unix:dl ange-ftp-dired-move-to-filename-alist)
4900 : ;; (setq ange-ftp-dired-move-to-filename-alist
4901 : ;; (cons '(unix:dl . ange-ftp-dired-dl-move-to-filename)
4902 : ;; ange-ftp-dired-move-to-filename-alist)))
4903 :
4904 : ;;(defun ange-ftp-dired-dl-move-to-end-of-filename (&optional no-error eol)
4905 : ;; ;; Assumes point is at beginning of filename.
4906 : ;; ;; So, it should be called only after (dired-move-to-filename t).
4907 : ;; ;; On failure, signals an error or returns nil.
4908 : ;; ;; This is the Unix dl version.
4909 : ;; (let ((opoint (point))
4910 : ;; case-fold-search hidden)
4911 : ;; (or eol (setq eol (line-end-position)))
4912 : ;; (setq hidden (and selective-display
4913 : ;; (save-excursion
4914 : ;; (search-forward "\r" eol t))))
4915 : ;; (if hidden
4916 : ;; (if no-error
4917 : ;; nil
4918 : ;; (error
4919 : ;; (substitute-command-keys
4920 : ;; "File line is hidden, type \\[dired-hide-subdir] to unhide")))
4921 : ;; (skip-chars-forward "^ /" eol)
4922 : ;; (if (eq opoint (point))
4923 : ;; (if no-error
4924 : ;; nil
4925 : ;; (error "No file on this line"))
4926 : ;; (point)))))
4927 :
4928 : ;;(or (assq 'unix:dl ange-ftp-dired-move-to-end-of-filename-alist)
4929 : ;; (setq ange-ftp-dired-move-to-end-of-filename-alist
4930 : ;; (cons '(unix:dl . ange-ftp-dired-dl-move-to-end-of-filename)
4931 : ;; ange-ftp-dired-move-to-end-of-filename-alist)))
4932 :
4933 : ;;;; ------------------------------------------------------------
4934 : ;;;; VOS support (VOS support is probably broken,
4935 : ;;;; but I don't know anything about VOS.)
4936 : ;;;; ------------------------------------------------------------
4937 : ;
4938 : ;(defun ange-ftp-fix-name-for-vos (name &optional reverse)
4939 : ; (setq name (copy-sequence name))
4940 : ; (let ((from (if reverse ?\> ?\/))
4941 : ; (to (if reverse ?\/ ?\>))
4942 : ; (i (1- (length name))))
4943 : ; (while (>= i 0)
4944 : ; (if (= (aref name i) from)
4945 : ; (aset name i to))
4946 : ; (setq i (1- i)))
4947 : ; name))
4948 : ;
4949 : ;(or (assq 'vos ange-ftp-fix-name-func-alist)
4950 : ; (setq ange-ftp-fix-name-func-alist
4951 : ; (cons '(vos . ange-ftp-fix-name-for-vos)
4952 : ; ange-ftp-fix-name-func-alist)))
4953 : ;
4954 : ;(or (memq 'vos ange-ftp-dumb-host-types)
4955 : ; (setq ange-ftp-dumb-host-types
4956 : ; (cons 'vos ange-ftp-dumb-host-types)))
4957 : ;
4958 : ;(defun ange-ftp-fix-dir-name-for-vos (dir-name)
4959 : ; (ange-ftp-fix-name-for-vos
4960 : ; (concat dir-name
4961 : ; (if (eq ?/ (aref dir-name (1- (length dir-name))))
4962 : ; "" "/")
4963 : ; "*")))
4964 : ;
4965 : ;(or (assq 'vos ange-ftp-fix-dir-name-func-alist)
4966 : ; (setq ange-ftp-fix-dir-name-func-alist
4967 : ; (cons '(vos . ange-ftp-fix-dir-name-for-vos)
4968 : ; ange-ftp-fix-dir-name-func-alist)))
4969 : ;
4970 : ;(defvar ange-ftp-vos-host-regexp nil
4971 : ; "If a host matches this regexp then it is assumed to be running VOS.")
4972 : ;
4973 : ;(defun ange-ftp-vos-host (host)
4974 : ; (and ange-ftp-vos-host-regexp
4975 : ; (save-match-data
4976 : ; (string-match ange-ftp-vos-host-regexp host))))
4977 : ;
4978 : ;(defun ange-ftp-parse-vos-listing ()
4979 : ; "Parse the current buffer which is assumed to be in VOS list -all
4980 : ;format, and return a hashtable as the result."
4981 : ; (let ((tbl (ange-ftp-make-hashtable))
4982 : ; (type-list
4983 : ; '(("^Files: [0-9]+ +Blocks: [0-9]+\n+" nil 40)
4984 : ; ("^Dirs: [0-9]+\n+" t 30)))
4985 : ; type-regexp type-is-dir type-col file)
4986 : ; (goto-char (point-min))
4987 : ; (save-match-data
4988 : ; (while type-list
4989 : ; (setq type-regexp (car (car type-list))
4990 : ; type-is-dir (nth 1 (car type-list))
4991 : ; type-col (nth 2 (car type-list))
4992 : ; type-list (cdr type-list))
4993 : ; (if (re-search-forward type-regexp nil t)
4994 : ; (while (eq (char-after (point)) ? )
4995 : ; (move-to-column type-col)
4996 : ; (setq file (buffer-substring (point)
4997 : ; (progn
4998 : ; (end-of-line 1)
4999 : ; (point))))
5000 : ; (puthash file type-is-dir tbl)
5001 : ; (forward-line 1))))
5002 : ; (puthash "." 'vosdir tbl)
5003 : ; (puthash ".." 'vosdir tbl))
5004 : ; tbl))
5005 : ;
5006 : ;(or (assq 'vos ange-ftp-parse-list-func-alist)
5007 : ; (setq ange-ftp-parse-list-func-alist
5008 : ; (cons '(vos . ange-ftp-parse-vos-listing)
5009 : ; ange-ftp-parse-list-func-alist)))
5010 :
5011 : ;;;; ------------------------------------------------------------
5012 : ;;;; VMS support.
5013 : ;;;; ------------------------------------------------------------
5014 :
5015 : ;; Convert NAME from UNIX-ish to VMS. If REVERSE given then convert from VMS
5016 : ;; to UNIX-ish.
5017 : (defun ange-ftp-fix-name-for-vms (name &optional reverse)
5018 0 : (save-match-data
5019 0 : (if reverse
5020 0 : (if (string-match "\\`\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)\\'" name)
5021 0 : (let (drive dir file)
5022 0 : (setq drive (match-string 1 name))
5023 0 : (setq dir (match-string 2 name))
5024 0 : (setq file (match-string 3 name))
5025 0 : (and dir
5026 0 : (setq dir (subst-char-in-string
5027 0 : ?/ ?. (substring dir 1 -1) t)))
5028 0 : (concat (and drive
5029 0 : (concat "/" drive "/"))
5030 0 : dir (and dir "/")
5031 0 : file))
5032 0 : (error "name %s didn't match" name))
5033 0 : (let (drive dir file tmp quote)
5034 0 : (if (string-match "\\`\".+\"\\'" name)
5035 0 : (setq name (substring name 1 -1)
5036 0 : quote "\"")
5037 0 : (setq quote ""))
5038 0 : (if (string-match "\\`/[^:]+:/" name)
5039 0 : (setq drive (substring name 1
5040 0 : (1- (match-end 0)))
5041 0 : name (substring name (match-end 0))))
5042 0 : (setq tmp (file-name-directory name))
5043 0 : (if tmp
5044 0 : (setq dir (subst-char-in-string ?/ ?. (substring tmp 0 -1) t)))
5045 0 : (setq file (file-name-nondirectory name))
5046 0 : (concat quote drive
5047 0 : (and dir (concat "[" (if drive nil ".") dir "]"))
5048 0 : file quote)))))
5049 :
5050 : ;; (ange-ftp-fix-name-for-vms "/PUB$:/ANONYMOUS/SDSCPUB/NEXT/Readme.txt;1")
5051 : ;; (ange-ftp-fix-name-for-vms "/PUB$:[ANONYMOUS.SDSCPUB.NEXT]Readme.txt;1" t)
5052 :
5053 : (or (assq 'vms ange-ftp-fix-name-func-alist)
5054 : (setq ange-ftp-fix-name-func-alist
5055 : (cons '(vms . ange-ftp-fix-name-for-vms)
5056 : ange-ftp-fix-name-func-alist)))
5057 :
5058 : (or (memq 'vms ange-ftp-dumb-host-types)
5059 : (setq ange-ftp-dumb-host-types
5060 : (cons 'vms ange-ftp-dumb-host-types)))
5061 :
5062 : ;; It is important that this function barf for directories for which we know
5063 : ;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/".
5064 : ;; This is because it saves an unnecessary FTP error, or possibly the listing
5065 : ;; might succeed, but give erroneous info. This last case is particularly
5066 : ;; likely for OS's (like MTS) for which we need to use a wildcard in order
5067 : ;; to list a directory.
5068 :
5069 : ;; Convert name from UNIX-ish to VMS ready for a DIRectory listing.
5070 : (defun ange-ftp-fix-dir-name-for-vms (dir-name)
5071 : ;; Should there be entries for .. -> [-] and . -> [] below. Don't
5072 : ;; think so, because expand-filename should have already short-circuited
5073 : ;; them.
5074 0 : (cond ((string-equal dir-name "/")
5075 0 : (error "Cannot get listing for fictitious \"/\" directory"))
5076 0 : ((string-match "\\`/[-A-Z0-9_$]+:/\\'" dir-name)
5077 0 : (error "Cannot get listing for device"))
5078 0 : ((ange-ftp-fix-name-for-vms dir-name))))
5079 :
5080 : (or (assq 'vms ange-ftp-fix-dir-name-func-alist)
5081 : (setq ange-ftp-fix-dir-name-func-alist
5082 : (cons '(vms . ange-ftp-fix-dir-name-for-vms)
5083 : ange-ftp-fix-dir-name-func-alist)))
5084 :
5085 : (defvar ange-ftp-vms-host-regexp nil)
5086 :
5087 : ;; Return non-nil if HOST is running VMS.
5088 : (defun ange-ftp-vms-host (host)
5089 0 : (and ange-ftp-vms-host-regexp
5090 0 : (string-match-p ange-ftp-vms-host-regexp host)))
5091 :
5092 : ;; Because some VMS ftp servers convert filenames to lower case
5093 : ;; we allow a-z in the filename regexp. I'm not too happy about this.
5094 :
5095 : (defconst ange-ftp-vms-filename-regexp
5096 : (concat
5097 : "\\(\\([_A-Za-z0-9$]?\\|[_A-Za-z0-9$][-_A-Za-z0-9$]*\\)\\."
5098 : "[-_A-Za-z0-9$]*;+[0-9]*\\)")
5099 : "Regular expression to match for a valid VMS file name in Dired buffer.
5100 : Stupid freaking bug! Position of _ and $ shouldn't matter but they do.
5101 : Having [A-Z0-9$_] bombs on filename _$$CHANGE_LOG$.TXT$ and $CHANGE_LOG$.TX.
5102 : Other orders of $ and _ seem to all work just fine.")
5103 :
5104 : ;; These parsing functions are as general as possible because the syntax
5105 : ;; of ftp listings from VMS hosts is a bit erratic. What saves us is that
5106 : ;; the VMS filename syntax is so rigid. If they bomb on a listing in the
5107 : ;; standard VMS Multinet format, then this is a bug. If they bomb on a listing
5108 : ;; from vms.weird.net, then too bad.
5109 :
5110 : ;; Extract the next filename from a VMS dired-like listing.
5111 : (defun ange-ftp-parse-vms-filename ()
5112 0 : (if (re-search-forward
5113 0 : ange-ftp-vms-filename-regexp
5114 0 : nil t)
5115 0 : (match-string 0)))
5116 :
5117 : ;; Parse the current buffer which is assumed to be in MultiNet FTP dir
5118 : ;; format, and return a hashtable as the result.
5119 : (defun ange-ftp-parse-vms-listing ()
5120 0 : (let ((tbl (make-hash-table :test 'equal))
5121 : file)
5122 0 : (goto-char (point-min))
5123 0 : (save-match-data
5124 0 : (while (setq file (ange-ftp-parse-vms-filename))
5125 0 : (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file)
5126 : ;; deal with directories
5127 0 : (puthash (substring file 0 (match-beginning 0)) t tbl)
5128 0 : (puthash file nil tbl)
5129 0 : (if (string-match ";[0-9]+\\'" file) ; deal with extension
5130 : ;; sans extension
5131 0 : (puthash (substring file 0 (match-beginning 0)) nil tbl)))
5132 0 : (forward-line 1))
5133 : ;; Would like to look for a "Total" line, or a "Directory" line to
5134 : ;; make sure that the listing isn't complete garbage before putting
5135 : ;; in "." and "..", but we can't count on VMS giving us
5136 : ;; either of these.
5137 0 : (puthash "." t tbl)
5138 0 : (puthash ".." t tbl))
5139 0 : tbl))
5140 :
5141 : (add-to-list 'ange-ftp-parse-list-func-alist
5142 : '(vms . ange-ftp-parse-vms-listing))
5143 :
5144 : ;; This version only deletes file entries which have
5145 : ;; explicit version numbers, because that is all VMS allows.
5146 :
5147 : ;; Can the following two functions be speeded up using file
5148 : ;; completion functions?
5149 :
5150 : (defun ange-ftp-vms-delete-file-entry (name &optional dir-p)
5151 0 : (if dir-p
5152 0 : (ange-ftp-internal-delete-file-entry name t)
5153 0 : (save-match-data
5154 0 : (let ((file (ange-ftp-get-file-part name)))
5155 0 : (if (string-match ";[0-9]+\\'" file)
5156 : ;; In VMS you can't delete a file without an explicit
5157 : ;; version number, or wild-card (e.g. FOO;*)
5158 : ;; For now, we give up on wildcards.
5159 0 : (let ((files (gethash (file-name-directory name)
5160 0 : ange-ftp-files-hashtable)))
5161 0 : (if files
5162 0 : (let* ((root (substring file 0
5163 0 : (match-beginning 0)))
5164 0 : (regexp (concat "^"
5165 0 : (regexp-quote root)
5166 0 : ";[0-9]+$"))
5167 : versions)
5168 0 : (remhash file files)
5169 : ;; Now we need to check if there are any
5170 : ;; versions left. If not, then delete the
5171 : ;; root entry.
5172 0 : (maphash
5173 : (lambda (key _val)
5174 0 : (and (string-match regexp key)
5175 0 : (setq versions t)))
5176 0 : files)
5177 0 : (or versions
5178 0 : (remhash root files))))))))))
5179 :
5180 : (or (assq 'vms ange-ftp-delete-file-entry-alist)
5181 : (setq ange-ftp-delete-file-entry-alist
5182 : (cons '(vms . ange-ftp-vms-delete-file-entry)
5183 : ange-ftp-delete-file-entry-alist)))
5184 :
5185 : (defun ange-ftp-vms-add-file-entry (name &optional dir-p)
5186 0 : (if dir-p
5187 0 : (ange-ftp-internal-add-file-entry name t)
5188 0 : (let ((files (gethash (file-name-directory name)
5189 0 : ange-ftp-files-hashtable)))
5190 0 : (if files
5191 0 : (let ((file (ange-ftp-get-file-part name)))
5192 0 : (save-match-data
5193 0 : (if (string-match ";[0-9]+\\'" file)
5194 0 : (puthash (substring file 0 (match-beginning 0)) nil files)
5195 : ;; Need to figure out what version of the file
5196 : ;; is being added.
5197 0 : (let ((regexp (concat "^"
5198 0 : (regexp-quote file)
5199 0 : ";\\([0-9]+\\)$"))
5200 : (version 0))
5201 0 : (maphash
5202 : (lambda (name val)
5203 0 : (and (string-match regexp name)
5204 0 : (setq version
5205 0 : (max version
5206 0 : (string-to-number (match-string 1 name))))))
5207 0 : files)
5208 0 : (setq version (1+ version))
5209 0 : (puthash
5210 0 : (concat file ";" (int-to-string version))
5211 0 : nil files))))
5212 0 : (puthash file nil files))))))
5213 :
5214 : (or (assq 'vms ange-ftp-add-file-entry-alist)
5215 : (setq ange-ftp-add-file-entry-alist
5216 : (cons '(vms . ange-ftp-vms-add-file-entry)
5217 : ange-ftp-add-file-entry-alist)))
5218 :
5219 :
5220 : (defun ange-ftp-add-vms-host (host)
5221 : "Mark HOST as the name of a machine running VMS."
5222 : (interactive
5223 0 : (list (read-string "Host: "
5224 0 : (let ((name (or (buffer-file-name) default-directory)))
5225 0 : (and name (car (ange-ftp-ftp-name name)))))))
5226 0 : (if (not (ange-ftp-vms-host host))
5227 0 : (setq ange-ftp-vms-host-regexp
5228 0 : (concat "^" (regexp-quote host) "$"
5229 0 : (and ange-ftp-vms-host-regexp "\\|")
5230 0 : ange-ftp-vms-host-regexp)
5231 0 : ange-ftp-host-cache nil)))
5232 :
5233 :
5234 : (defun ange-ftp-vms-file-name-as-directory (name)
5235 0 : (save-match-data
5236 0 : (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?\\'" name)
5237 0 : (setq name (substring name 0 (match-beginning 0))))
5238 0 : (ange-ftp-real-file-name-as-directory name)))
5239 :
5240 : (or (assq 'vms ange-ftp-file-name-as-directory-alist)
5241 : (setq ange-ftp-file-name-as-directory-alist
5242 : (cons '(vms . ange-ftp-vms-file-name-as-directory)
5243 : ange-ftp-file-name-as-directory-alist)))
5244 :
5245 : ;;; Tree dired support:
5246 :
5247 : ;; For this code I have borrowed liberally from Sebastian Kremer's
5248 : ;; dired-vms.el
5249 :
5250 :
5251 : ;;;; These regexps must be anchored to beginning of line.
5252 : ;;;; Beware that the ftpd may put the device in front of the filename.
5253 :
5254 : ;;(defconst ange-ftp-dired-vms-re-exe "^. [^ \t.]+\\.\\(EXE\\|exe\\)[; ]"
5255 : ;; "Regular expression to use to search for VMS executable files.")
5256 :
5257 : ;;(defconst ange-ftp-dired-vms-re-dir "^. [^ \t.]+\\.\\(DIR\\|dir\\)[; ]"
5258 : ;; "Regular expression to use to search for VMS directories.")
5259 :
5260 : ;;(or (assq 'vms ange-ftp-dired-re-exe-alist)
5261 : ;; (setq ange-ftp-dired-re-exe-alist
5262 : ;; (cons (cons 'vms ange-ftp-dired-vms-re-exe)
5263 : ;; ange-ftp-dired-re-exe-alist)))
5264 :
5265 : ;;(or (assq 'vms ange-ftp-dired-re-dir-alist)
5266 : ;; (setq ange-ftp-dired-re-dir-alist
5267 : ;; (cons (cons 'vms ange-ftp-dired-vms-re-dir)
5268 : ;; ange-ftp-dired-re-dir-alist)))
5269 :
5270 : ;;(defun ange-ftp-dired-vms-insert-headerline (dir)
5271 : ;; ;; VMS inserts a headerline. I would prefer the headerline
5272 : ;; ;; to be in ange-ftp format. This version tries to
5273 : ;; ;; be careful, because we can't count on a headerline
5274 : ;; ;; over ftp, and we wouldn't want to delete anything
5275 : ;; ;; important.
5276 : ;; (save-excursion
5277 : ;; (if (looking-at "^ wildcard ")
5278 : ;; (forward-line 1))
5279 : ;; (if (looking-at "^[ \n\t]*[^\n]+\\][ \t]*\n")
5280 : ;; (delete-region (point) (match-end 0))))
5281 : ;; (ange-ftp-real-dired-insert-headerline dir))
5282 :
5283 : ;;(or (assq 'vms ange-ftp-dired-insert-headerline-alist)
5284 : ;; (setq ange-ftp-dired-insert-headerline-alist
5285 : ;; (cons '(vms . ange-ftp-dired-vms-insert-headerline)
5286 : ;; ange-ftp-dired-insert-headerline-alist)))
5287 :
5288 : ;;(defun ange-ftp-dired-vms-move-to-filename (&optional raise-error eol)
5289 : ;; "In dired, move to first char of filename on this line.
5290 : ;;Returns position (point) or nil if no filename on this line."
5291 : ;; ;; This is the VMS version.
5292 : ;; (let (case-fold-search)
5293 : ;; (or eol (setq eol (progn (end-of-line) (point))))
5294 : ;; (beginning-of-line)
5295 : ;; (if (re-search-forward ange-ftp-vms-filename-regexp eol t)
5296 : ;; (goto-char (match-beginning 1))
5297 : ;; (if raise-error
5298 : ;; (error "No file on this line")
5299 : ;; nil))))
5300 :
5301 : ;;(or (assq 'vms ange-ftp-dired-move-to-filename-alist)
5302 : ;; (setq ange-ftp-dired-move-to-filename-alist
5303 : ;; (cons '(vms . ange-ftp-dired-vms-move-to-filename)
5304 : ;; ange-ftp-dired-move-to-filename-alist)))
5305 :
5306 : ;;(defun ange-ftp-dired-vms-move-to-end-of-filename (&optional no-error eol)
5307 : ;; ;; Assumes point is at beginning of filename.
5308 : ;; ;; So, it should be called only after (dired-move-to-filename t).
5309 : ;; ;; case-fold-search must be nil, at least for VMS.
5310 : ;; ;; On failure, signals an error or returns nil.
5311 : ;; ;; This is the VMS version.
5312 : ;; (let (opoint hidden case-fold-search)
5313 : ;; (setq opoint (point))
5314 : ;; (or eol (setq eol (line-end-position)))
5315 : ;; (setq hidden (and selective-display
5316 : ;; (save-excursion (search-forward "\r" eol t))))
5317 : ;; (if hidden
5318 : ;; nil
5319 : ;; (re-search-forward ange-ftp-vms-filename-regexp eol t))
5320 : ;; (or no-error
5321 : ;; (not (eq opoint (point)))
5322 : ;; (error
5323 : ;; (if hidden
5324 : ;; (substitute-command-keys
5325 : ;; "File line is hidden, type \\[dired-hide-subdir] to unhide")
5326 : ;; "No file on this line")))
5327 : ;; (if (eq opoint (point))
5328 : ;; nil
5329 : ;; (point))))
5330 :
5331 : ;;(or (assq 'vms ange-ftp-dired-move-to-end-of-filename-alist)
5332 : ;; (setq ange-ftp-dired-move-to-end-of-filename-alist
5333 : ;; (cons '(vms . ange-ftp-dired-vms-move-to-end-of-filename)
5334 : ;; ange-ftp-dired-move-to-end-of-filename-alist)))
5335 :
5336 : ;;(defun ange-ftp-dired-vms-between-files ()
5337 : ;; (save-excursion
5338 : ;; (beginning-of-line)
5339 : ;; (or (equal (following-char) 10) ; newline
5340 : ;; (equal (following-char) 9) ; tab
5341 : ;; (progn (forward-char 2)
5342 : ;; (or (looking-at "Total of")
5343 : ;; (equal (following-char) 32))))))
5344 :
5345 : ;;(or (assq 'vms ange-ftp-dired-between-files-alist)
5346 : ;; (setq ange-ftp-dired-between-files-alist
5347 : ;; (cons '(vms . ange-ftp-dired-vms-between-files)
5348 : ;; ange-ftp-dired-between-files-alist)))
5349 :
5350 : ;; Beware! In VMS filenames must be of the form "FILE.TYPE".
5351 : ;; Therefore, we cannot just append a ".Z" to filenames for
5352 : ;; compressed files. Instead, we turn "FILE.TYPE" into
5353 : ;; "FILE.TYPE-Z". Hope that this is a reasonable thing to do.
5354 :
5355 : (defun ange-ftp-vms-make-compressed-filename (name &optional _reverse)
5356 0 : (cond
5357 0 : ((string-match "-Z;[0-9]+\\'" name)
5358 0 : (list nil (substring name 0 (match-beginning 0))))
5359 0 : ((string-match ";[0-9]+\\'" name)
5360 0 : (list nil (substring name 0 (match-beginning 0))))
5361 0 : ((string-match "-Z\\'" name)
5362 0 : (list nil (substring name 0 -2)))
5363 : (t
5364 0 : (list t
5365 0 : (if (string-match ";[0-9]+\\'" name)
5366 0 : (concat (substring name 0 (match-beginning 0))
5367 0 : "-Z")
5368 0 : (concat name "-Z"))))))
5369 :
5370 : (or (assq 'vms ange-ftp-make-compressed-filename-alist)
5371 : (setq ange-ftp-make-compressed-filename-alist
5372 : (cons '(vms . ange-ftp-vms-make-compressed-filename)
5373 : ange-ftp-make-compressed-filename-alist)))
5374 :
5375 : ;;;; When the filename is too long, VMS will use two lines to list a file
5376 : ;;;; (damn them!) This will confuse dired. To solve this, need to convince
5377 : ;;;; Sebastian to use a function dired-go-to-end-of-file-line, instead of
5378 : ;;;; (forward-line 1). This would require a number of changes to dired.el.
5379 : ;;;; If dired gets confused, revert-buffer will fix it.
5380 :
5381 : ;;(defun ange-ftp-dired-vms-ls-trim ()
5382 : ;; (goto-char (point-min))
5383 : ;; (let ((case-fold-search nil))
5384 : ;; (re-search-forward ange-ftp-vms-filename-regexp))
5385 : ;; (beginning-of-line)
5386 : ;; (delete-region (point-min) (point))
5387 : ;; (forward-line 1)
5388 : ;; (delete-region (point) (point-max)))
5389 :
5390 :
5391 : ;;(or (assq 'vms ange-ftp-dired-ls-trim-alist)
5392 : ;; (setq ange-ftp-dired-ls-trim-alist
5393 : ;; (cons '(vms . ange-ftp-dired-vms-ls-trim)
5394 : ;; ange-ftp-dired-ls-trim-alist)))
5395 :
5396 : (defun ange-ftp-vms-sans-version (name &rest _args)
5397 0 : (save-match-data
5398 0 : (if (string-match ";[0-9]+\\'" name)
5399 0 : (substring name 0 (match-beginning 0))
5400 0 : name)))
5401 :
5402 : (or (assq 'vms ange-ftp-sans-version-alist)
5403 : (setq ange-ftp-sans-version-alist
5404 : (cons '(vms . ange-ftp-vms-sans-version)
5405 : ange-ftp-sans-version-alist)))
5406 :
5407 : ;;(defvar ange-ftp-file-version-alist)
5408 :
5409 : ;;;;; The vms version of clean-directory has 2 more optional args
5410 : ;;;;; than the usual dired version. This is so that it can be used by
5411 : ;;;;; ange-ftp-dired-vms-flag-backup-files.
5412 :
5413 : ;;(defun ange-ftp-dired-vms-clean-directory (keep &optional marker msg)
5414 : ;; "Flag numerical backups for deletion.
5415 : ;;Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest.
5416 : ;;Positive prefix arg KEEP overrides `dired-kept-versions';
5417 : ;;Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive.
5418 :
5419 : ;;To clear the flags on these files, you can use \\[dired-flag-backup-files]
5420 : ;;with a prefix argument."
5421 : ;;; (interactive "P") ; Never actually called interactively.
5422 : ;; (setq keep (max 1 (if keep (prefix-numeric-value keep) dired-kept-versions)))
5423 : ;; (let ((early-retention (if (< keep 0) (- keep) kept-old-versions))
5424 : ;; ;; late-retention must NEVER be allowed to be less than 1 in VMS!
5425 : ;; ;; This could wipe ALL copies of the file.
5426 : ;; (late-retention (max 1 (if (<= keep 0) dired-kept-versions keep)))
5427 : ;; (action (or msg "Cleaning"))
5428 : ;; (ange-ftp-trample-marker (or marker dired-del-marker))
5429 : ;; (ange-ftp-file-version-alist ()))
5430 : ;; (message (concat action
5431 : ;; " numerical backups (keeping %d late, %d old)...")
5432 : ;; late-retention early-retention)
5433 : ;; ;; Look at each file.
5434 : ;; ;; If the file has numeric backup versions,
5435 : ;; ;; put on ange-ftp-file-version-alist an element of the form
5436 : ;; ;; (FILENAME . VERSION-NUMBER-LIST)
5437 : ;; (dired-map-dired-file-lines 'ange-ftp-dired-vms-collect-file-versions)
5438 : ;; ;; Sort each VERSION-NUMBER-LIST,
5439 : ;; ;; and remove the versions not to be deleted.
5440 : ;; (let ((fval ange-ftp-file-version-alist))
5441 : ;; (while fval
5442 : ;; (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<)))
5443 : ;; (v-count (length sorted-v-list)))
5444 : ;; (if (> v-count (+ early-retention late-retention))
5445 : ;; (rplacd (nthcdr early-retention sorted-v-list)
5446 : ;; (nthcdr (- v-count late-retention)
5447 : ;; sorted-v-list)))
5448 : ;; (rplacd (car fval)
5449 : ;; (cdr sorted-v-list)))
5450 : ;; (setq fval (cdr fval))))
5451 : ;; ;; Look at each file. If it is a numeric backup file,
5452 : ;; ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion.
5453 : ;; (dired-map-dired-file-lines
5454 : ;; 'ange-ftp-dired-vms-trample-file-versions mark)
5455 : ;; (message (concat action " numerical backups...done"))))
5456 :
5457 : ;;(or (assq 'vms ange-ftp-dired-clean-directory-alist)
5458 : ;; (setq ange-ftp-dired-clean-directory-alist
5459 : ;; (cons '(vms . ange-ftp-dired-vms-clean-directory)
5460 : ;; ange-ftp-dired-clean-directory-alist)))
5461 :
5462 : ;;(defun ange-ftp-dired-vms-collect-file-versions (fn)
5463 : ;; ;; "If it looks like file FN has versions, return a list of the versions.
5464 : ;; ;;That is a list of strings which are file names.
5465 : ;; ;;The caller may want to flag some of these files for deletion."
5466 : ;;(let ((name (nth 2 (ange-ftp-ftp-name fn))))
5467 : ;; (if (string-match ";[0-9]+$" name)
5468 : ;; (let* ((name (substring name 0 (match-beginning 0)))
5469 : ;; (fn (ange-ftp-replace-name-component fn name)))
5470 : ;; (if (not (assq fn ange-ftp-file-version-alist))
5471 : ;; (let* ((base-versions
5472 : ;; (concat (file-name-nondirectory name) ";"))
5473 : ;; (bv-length (length base-versions))
5474 : ;; (possibilities (file-name-all-completions
5475 : ;; base-versions
5476 : ;; (file-name-directory fn)))
5477 : ;; (versions (mapcar
5478 : ;; (lambda (arg)
5479 : ;; (if (and (string-match
5480 : ;; "[0-9]+$" arg bv-length)
5481 : ;; (= (match-beginning 0) bv-length))
5482 : ;; (string-to-int (substring arg bv-length))
5483 : ;; 0))
5484 : ;; possibilities)))
5485 : ;; (if versions
5486 : ;; (setq
5487 : ;; ange-ftp-file-version-alist
5488 : ;; (cons (cons fn versions)
5489 : ;; ange-ftp-file-version-alist)))))))))
5490 :
5491 : ;;(defun ange-ftp-dired-vms-trample-file-versions (fn)
5492 : ;; (let* ((start-vn (string-match ";[0-9]+$" fn))
5493 : ;; base-version-list)
5494 : ;; (and start-vn
5495 : ;; (setq base-version-list ; there was a base version to which
5496 : ;; (assoc (substring fn 0 start-vn) ; this looks like a
5497 : ;; ange-ftp-file-version-alist)) ; subversion
5498 : ;; (not (memq (string-to-int (substring fn (1+ start-vn)))
5499 : ;; base-version-list)) ; this one doesn't make the cut
5500 : ;; (progn (beginning-of-line)
5501 : ;; (delete-char 1)
5502 : ;; (insert ange-ftp-trample-marker)))))
5503 :
5504 : ;;(defun ange-ftp-dired-vms-flag-backup-files (&optional unflag-p)
5505 : ;; (let ((dired-kept-versions 1)
5506 : ;; (kept-old-versions 0)
5507 : ;; marker msg)
5508 : ;; (if unflag-p
5509 : ;; (setq marker ?\040 msg "Unflagging")
5510 : ;; (setq marker dired-del-marker msg "Cleaning"))
5511 : ;; (ange-ftp-dired-vms-clean-directory nil marker msg)))
5512 :
5513 : ;;(or (assq 'vms ange-ftp-dired-flag-backup-files-alist)
5514 : ;; (setq ange-ftp-dired-flag-backup-files-alist
5515 : ;; (cons '(vms . ange-ftp-dired-vms-flag-backup-files)
5516 : ;; ange-ftp-dired-flag-backup-files-alist)))
5517 :
5518 : ;;(defun ange-ftp-dired-vms-backup-diff (&optional switches)
5519 : ;; (let ((file (dired-get-filename 'no-dir))
5520 : ;; bak)
5521 : ;; (if (and (string-match ";[0-9]+$" file)
5522 : ;; ;; Find most recent previous version.
5523 : ;; (let ((root (substring file 0 (match-beginning 0)))
5524 : ;; (ver
5525 : ;; (string-to-int (substring file (1+ (match-beginning 0)))))
5526 : ;; found)
5527 : ;; (setq ver (1- ver))
5528 : ;; (while (and (> ver 0) (not found))
5529 : ;; (setq bak (concat root ";" (int-to-string ver)))
5530 : ;; (and (file-exists-p bak) (setq found t))
5531 : ;; (setq ver (1- ver)))
5532 : ;; found))
5533 : ;; (if switches
5534 : ;; (diff (expand-file-name bak) (expand-file-name file) switches)
5535 : ;; (diff (expand-file-name bak) (expand-file-name file)))
5536 : ;; (error "No previous version found for %s" file))))
5537 :
5538 : ;;(or (assq 'vms ange-ftp-dired-backup-diff-alist)
5539 : ;; (setq ange-ftp-dired-backup-diff-alist
5540 : ;; (cons '(vms . ange-ftp-dired-vms-backup-diff)
5541 : ;; ange-ftp-dired-backup-diff-alist)))
5542 :
5543 :
5544 : ;;;; ------------------------------------------------------------
5545 : ;;;; MTS support
5546 : ;;;; ------------------------------------------------------------
5547 :
5548 :
5549 : ;; Convert NAME from UNIX-ish to MTS. If REVERSE given then convert from
5550 : ;; MTS to UNIX-ish.
5551 : (defun ange-ftp-fix-name-for-mts (name &optional reverse)
5552 0 : (save-match-data
5553 0 : (if reverse
5554 0 : (if (string-match "\\`\\([^:]+:\\)?\\(.*\\)\\'" name)
5555 0 : (let (acct file)
5556 0 : (setq acct (match-string 1 name))
5557 0 : (setq file (match-string 2 name))
5558 0 : (concat (and acct (concat "/" acct "/"))
5559 0 : file))
5560 0 : (error "name %s didn't match" name))
5561 0 : (if (string-match "\\`/\\([^:]+:\\)/\\(.*\\)\\'" name)
5562 0 : (concat (match-string 1 name) (match-string 2 name))
5563 : ;; Let's hope that mts will recognize it anyway.
5564 0 : name))))
5565 :
5566 : (or (assq 'mts ange-ftp-fix-name-func-alist)
5567 : (setq ange-ftp-fix-name-func-alist
5568 : (cons '(mts . ange-ftp-fix-name-for-mts)
5569 : ange-ftp-fix-name-func-alist)))
5570 :
5571 : ;; Convert name from UNIX-ish to MTS ready for a DIRectory listing.
5572 : ;; Remember that there are no directories in MTS.
5573 : (defun ange-ftp-fix-dir-name-for-mts (dir-name)
5574 0 : (if (string-equal dir-name "/")
5575 0 : (error "Cannot get listing for fictitious \"/\" directory")
5576 0 : (let ((dir-name (ange-ftp-fix-name-for-mts dir-name)))
5577 0 : (cond
5578 0 : ((string-equal dir-name "")
5579 : "?")
5580 0 : ((string-match ":\\'" dir-name)
5581 0 : (concat dir-name "?"))
5582 0 : (dir-name))))) ; It's just a single file.
5583 :
5584 : (or (assq 'mts ange-ftp-fix-dir-name-func-alist)
5585 : (setq ange-ftp-fix-dir-name-func-alist
5586 : (cons '(mts . ange-ftp-fix-dir-name-for-mts)
5587 : ange-ftp-fix-dir-name-func-alist)))
5588 :
5589 : (or (memq 'mts ange-ftp-dumb-host-types)
5590 : (setq ange-ftp-dumb-host-types
5591 : (cons 'mts ange-ftp-dumb-host-types)))
5592 :
5593 : (defvar ange-ftp-mts-host-regexp nil)
5594 :
5595 : ;; Return non-nil if HOST is running MTS.
5596 : (defun ange-ftp-mts-host (host)
5597 0 : (and ange-ftp-mts-host-regexp
5598 0 : (string-match-p ange-ftp-mts-host-regexp host)))
5599 :
5600 : ;; Parse the current buffer which is assumed to be in mts ftp dir format.
5601 : (defun ange-ftp-parse-mts-listing ()
5602 0 : (let ((tbl (make-hash-table :test 'equal)))
5603 0 : (goto-char (point-min))
5604 0 : (save-match-data
5605 0 : (while (re-search-forward directory-listing-before-filename-regexp nil t)
5606 0 : (end-of-line)
5607 0 : (skip-chars-backward " ")
5608 0 : (let ((end (point)))
5609 0 : (skip-chars-backward "-A-Z0-9_.!")
5610 0 : (puthash (buffer-substring (point) end) nil tbl))
5611 0 : (forward-line 1)))
5612 : ;; Don't need to bother with ..
5613 0 : (puthash "." t tbl)
5614 0 : tbl))
5615 :
5616 : (add-to-list 'ange-ftp-parse-list-func-alist
5617 : '(mts . ange-ftp-parse-mts-listing))
5618 :
5619 : (defun ange-ftp-add-mts-host (host)
5620 : "Mark HOST as the name of a machine running MTS."
5621 : (interactive
5622 0 : (list (read-string "Host: "
5623 0 : (let ((name (or (buffer-file-name) default-directory)))
5624 0 : (and name (car (ange-ftp-ftp-name name)))))))
5625 0 : (if (not (ange-ftp-mts-host host))
5626 0 : (setq ange-ftp-mts-host-regexp
5627 0 : (concat "^" (regexp-quote host) "$"
5628 0 : (and ange-ftp-mts-host-regexp "\\|")
5629 0 : ange-ftp-mts-host-regexp)
5630 0 : ange-ftp-host-cache nil)))
5631 :
5632 : ;;; Tree dired support:
5633 :
5634 : ;;;; There aren't too many systems left that use MTS. This dired support will
5635 : ;;;; work for the implementation of ftp on mtsg.ubc.ca. I hope other mts systems
5636 : ;;;; implement ftp in the same way. If not, it might be necessary to make the
5637 : ;;;; following more flexible.
5638 :
5639 : ;;(defun ange-ftp-dired-mts-move-to-filename (&optional raise-error eol)
5640 : ;; "In dired, move to first char of filename on this line.
5641 : ;;Returns position (point) or nil if no filename on this line."
5642 : ;; ;; This is the MTS version.
5643 : ;; (or eol (setq eol (progn (end-of-line) (point))))
5644 : ;; (beginning-of-line)
5645 : ;; (if (re-search-forward
5646 : ;; ange-ftp-date-regexp eol t)
5647 : ;; (progn
5648 : ;; (skip-chars-forward " ") ; Eat blanks after date
5649 : ;; (skip-chars-forward "0-9:" eol) ; Eat time or year
5650 : ;; (skip-chars-forward " " eol) ; one space before filename
5651 : ;; ;; When listing an account other than the users own account it appends
5652 : ;; ;; ACCT: to the beginning of the filename. Skip over this.
5653 : ;; (and (looking-at "[A-Z0-9_.]+:")
5654 : ;; (goto-char (match-end 0)))
5655 : ;; (point))
5656 : ;; (if raise-error
5657 : ;; (error "No file on this line")
5658 : ;; nil)))
5659 :
5660 : ;;(or (assq 'mts ange-ftp-dired-move-to-filename-alist)
5661 : ;; (setq ange-ftp-dired-move-to-filename-alist
5662 : ;; (cons '(mts . ange-ftp-dired-mts-move-to-filename)
5663 : ;; ange-ftp-dired-move-to-filename-alist)))
5664 :
5665 : ;;(defun ange-ftp-dired-mts-move-to-end-of-filename (&optional no-error eol)
5666 : ;; ;; Assumes point is at beginning of filename.
5667 : ;; ;; So, it should be called only after (dired-move-to-filename t).
5668 : ;; ;; On failure, signals an error or returns nil.
5669 : ;; ;; This is the MTS version.
5670 : ;; (let (opoint hidden case-fold-search)
5671 : ;; (setq opoint (point)
5672 : ;; eol (line-end-position)
5673 : ;; hidden (and selective-display
5674 : ;; (save-excursion (search-forward "\r" eol t))))
5675 : ;; (if hidden
5676 : ;; nil
5677 : ;; (skip-chars-forward "-A-Z0-9._!" eol))
5678 : ;; (or no-error
5679 : ;; (not (eq opoint (point)))
5680 : ;; (error
5681 : ;; (if hidden
5682 : ;; (substitute-command-keys
5683 : ;; "File line is hidden, type \\[dired-hide-subdir] to unhide")
5684 : ;; "No file on this line")))
5685 : ;; (if (eq opoint (point))
5686 : ;; nil
5687 : ;; (point))))
5688 :
5689 : ;;(or (assq 'mts ange-ftp-dired-move-to-end-of-filename-alist)
5690 : ;; (setq ange-ftp-dired-move-to-end-of-filename-alist
5691 : ;; (cons '(mts . ange-ftp-dired-mts-move-to-end-of-filename)
5692 : ;; ange-ftp-dired-move-to-end-of-filename-alist)))
5693 :
5694 : ;;;; ------------------------------------------------------------
5695 : ;;;; CMS support
5696 : ;;;; ------------------------------------------------------------
5697 :
5698 : ;; Since CMS doesn't have any full file name syntax, we have to fudge
5699 : ;; things with cd's. We actually send too many cd's, but it's dangerous
5700 : ;; to try to remember the current minidisk, because if the connection
5701 : ;; is closed and needs to be reopened, we will find ourselves back in
5702 : ;; the default minidisk. This is fairly likely since CMS ftp servers
5703 : ;; usually close the connection after 5 minutes of inactivity.
5704 :
5705 : ;; Have I got the filename character set right?
5706 :
5707 : (defun ange-ftp-fix-name-for-cms (name &optional reverse)
5708 0 : (save-match-data
5709 0 : (if reverse
5710 : ;; Since we only convert output from a pwd in this direction,
5711 : ;; we'll assume that it's a minidisk, and make it into a
5712 : ;; directory file name. Note that the expand-dir-hashtable
5713 : ;; stores directories without the trailing /. Is this
5714 : ;; consistent?
5715 0 : (concat "/" name)
5716 0 : (if (string-match "\\`/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?\\'"
5717 0 : name)
5718 0 : (let ((minidisk (match-string 1 name)))
5719 0 : (if (match-beginning 2)
5720 0 : (let ((file (match-string 2 name))
5721 0 : (cmd (concat "cd " minidisk))
5722 :
5723 : ;; Note that host and user are bound in the call
5724 : ;; to ange-ftp-send-cmd
5725 0 : (proc (ange-ftp-get-process ange-ftp-this-host
5726 0 : ange-ftp-this-user)))
5727 :
5728 : ;; Must use ange-ftp-raw-send-cmd here to avoid
5729 : ;; an infinite loop.
5730 0 : (if (car (ange-ftp-raw-send-cmd proc cmd ange-ftp-this-msg))
5731 0 : file
5732 : ;; failed... try ONCE more.
5733 0 : (setq proc (ange-ftp-get-process ange-ftp-this-host
5734 0 : ange-ftp-this-user))
5735 0 : (let ((result (ange-ftp-raw-send-cmd proc cmd
5736 0 : ange-ftp-this-msg)))
5737 0 : (if (car result)
5738 0 : file
5739 : ;; failed. give up.
5740 0 : (ange-ftp-error ange-ftp-this-host ange-ftp-this-user
5741 0 : (format "cd to minidisk %s failed: %s"
5742 0 : minidisk (cdr result)))))))
5743 : ;; return the minidisk
5744 0 : minidisk))
5745 0 : (error "Invalid CMS filename")))))
5746 :
5747 : (or (assq 'cms ange-ftp-fix-name-func-alist)
5748 : (setq ange-ftp-fix-name-func-alist
5749 : (cons '(cms . ange-ftp-fix-name-for-cms)
5750 : ange-ftp-fix-name-func-alist)))
5751 :
5752 : (or (memq 'cms ange-ftp-dumb-host-types)
5753 : (setq ange-ftp-dumb-host-types
5754 : (cons 'cms ange-ftp-dumb-host-types)))
5755 :
5756 : ;; Convert name from UNIX-ish to CMS ready for a DIRectory listing.
5757 : (defun ange-ftp-fix-dir-name-for-cms (dir-name)
5758 0 : (cond
5759 0 : ((string-equal "/" dir-name)
5760 0 : (error "Cannot get listing for fictitious \"/\" directory"))
5761 0 : ((string-match "\\`/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?\\'" dir-name)
5762 0 : (let* ((minidisk (match-string 1 dir-name))
5763 : ;; host and user are bound in the call to ange-ftp-send-cmd
5764 0 : (proc (ange-ftp-get-process ange-ftp-this-host ange-ftp-this-user))
5765 0 : (cmd (concat "cd " minidisk))
5766 0 : (file (if (match-beginning 2)
5767 : ;; it's a single file
5768 0 : (match-string 2 dir-name)
5769 : ;; use the wild-card
5770 0 : "*")))
5771 0 : (if (car (ange-ftp-raw-send-cmd proc cmd))
5772 0 : file
5773 : ;; try again...
5774 0 : (setq proc (ange-ftp-get-process ange-ftp-this-host
5775 0 : ange-ftp-this-user))
5776 0 : (let ((result (ange-ftp-raw-send-cmd proc cmd)))
5777 0 : (if (car result)
5778 0 : file
5779 : ;; give up
5780 0 : (ange-ftp-error ange-ftp-this-host ange-ftp-this-user
5781 0 : (format "cd to minidisk %s failed: %s"
5782 0 : minidisk (cdr result))))))))
5783 0 : (t (error "Invalid CMS file name"))))
5784 :
5785 : (or (assq 'cms ange-ftp-fix-dir-name-func-alist)
5786 : (setq ange-ftp-fix-dir-name-func-alist
5787 : (cons '(cms . ange-ftp-fix-dir-name-for-cms)
5788 : ange-ftp-fix-dir-name-func-alist)))
5789 :
5790 : (defvar ange-ftp-cms-host-regexp nil
5791 : "Regular expression to match hosts running the CMS operating system.")
5792 :
5793 : ;; Return non-nil if HOST is running CMS.
5794 : (defun ange-ftp-cms-host (host)
5795 0 : (and ange-ftp-cms-host-regexp
5796 0 : (string-match-p ange-ftp-cms-host-regexp host)))
5797 :
5798 : (defun ange-ftp-add-cms-host (host)
5799 : "Mark HOST as the name of a CMS host."
5800 : (interactive
5801 0 : (list (read-string "Host: "
5802 0 : (let ((name (or (buffer-file-name) default-directory)))
5803 0 : (and name (car (ange-ftp-ftp-name name)))))))
5804 0 : (if (not (ange-ftp-cms-host host))
5805 0 : (setq ange-ftp-cms-host-regexp
5806 0 : (concat "^" (regexp-quote host) "$"
5807 0 : (and ange-ftp-cms-host-regexp "\\|")
5808 0 : ange-ftp-cms-host-regexp)
5809 0 : ange-ftp-host-cache nil)))
5810 :
5811 : (defun ange-ftp-parse-cms-listing ()
5812 : ;; Parse the current buffer which is assumed to be a CMS directory listing.
5813 : ;; If we succeed in getting a listing, then we will assume that the minidisk
5814 : ;; exists. file is bound by the call to ange-ftp-ls. This doesn't work
5815 : ;; because ange-ftp doesn't know that the root hashtable has only part of
5816 : ;; the info. It will assume that if a minidisk isn't in it, then it doesn't
5817 : ;; exist. It would be nice if completion worked for minidisks, as we
5818 : ;; discover them.
5819 : ; (let* ((dir-file (directory-file-name file))
5820 : ; (root (file-name-directory dir-file))
5821 : ; (minidisk (ange-ftp-get-file-part dir-file))
5822 : ; (root-tbl (ange-ftp-get-hash-entry root ange-ftp-files-hashtable)))
5823 : ; (if root-tbl
5824 : ; (puthash minidisk t root-tbl)
5825 : ; (setq root-tbl (ange-ftp-make-hashtable))
5826 : ; (puthash minidisk t root-tbl)
5827 : ; (puthash "." t root-tbl)
5828 : ; (ange-ftp-set-files root root-tbl)))
5829 : ;; Now do the usual parsing
5830 0 : (let ((tbl (make-hash-table :test 'equal)))
5831 0 : (goto-char (point-min))
5832 0 : (save-match-data
5833 0 : (while
5834 0 : (re-search-forward
5835 0 : "^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t)
5836 0 : (puthash (concat (match-string 1) "." (match-string 2)) nil tbl)
5837 0 : (forward-line 1))
5838 0 : (puthash "." t tbl))
5839 0 : tbl))
5840 :
5841 : (add-to-list 'ange-ftp-parse-list-func-alist
5842 : '(cms . ange-ftp-parse-cms-listing))
5843 :
5844 : ;;;;; Tree dired support:
5845 :
5846 : ;;(defconst ange-ftp-dired-cms-re-exe
5847 : ;; "^. [-A-Z0-9$_]+ +EXEC "
5848 : ;; "Regular expression to use to search for CMS executables.")
5849 :
5850 : ;;(or (assq 'cms ange-ftp-dired-re-exe-alist)
5851 : ;; (setq ange-ftp-dired-re-exe-alist
5852 : ;; (cons (cons 'cms ange-ftp-dired-cms-re-exe)
5853 : ;; ange-ftp-dired-re-exe-alist)))
5854 :
5855 :
5856 : ;;(defun ange-ftp-dired-cms-insert-headerline (dir)
5857 : ;; ;; CMS has no total line, so we insert a blank line for
5858 : ;; ;; aesthetics.
5859 : ;; (insert "\n")
5860 : ;; (forward-char -1)
5861 : ;; (ange-ftp-real-dired-insert-headerline dir))
5862 :
5863 : ;;(or (assq 'cms ange-ftp-dired-insert-headerline-alist)
5864 : ;; (setq ange-ftp-dired-insert-headerline-alist
5865 : ;; (cons '(cms . ange-ftp-dired-cms-insert-headerline)
5866 : ;; ange-ftp-dired-insert-headerline-alist)))
5867 :
5868 : ;;(defun ange-ftp-dired-cms-move-to-filename (&optional raise-error eol)
5869 : ;; "In dired, move to the first char of filename on this line."
5870 : ;; ;; This is the CMS version.
5871 : ;; (or eol (setq eol (progn (end-of-line) (point))))
5872 : ;; (let (case-fold-search)
5873 : ;; (beginning-of-line)
5874 : ;; (if (re-search-forward " [-A-Z0-9$_]+ +[-A-Z0-9$_]+ +[VF] +[0-9]+ " eol t)
5875 : ;; (goto-char (1+ (match-beginning 0)))
5876 : ;; (if raise-error
5877 : ;; (error "No file on this line")
5878 : ;; nil))))
5879 :
5880 : ;;(or (assq 'cms ange-ftp-dired-move-to-filename-alist)
5881 : ;; (setq ange-ftp-dired-move-to-filename-alist
5882 : ;; (cons '(cms . ange-ftp-dired-cms-move-to-filename)
5883 : ;; ange-ftp-dired-move-to-filename-alist)))
5884 :
5885 : ;;(defun ange-ftp-dired-cms-move-to-end-of-filename (&optional no-error eol)
5886 : ;; ;; Assumes point is at beginning of filename.
5887 : ;; ;; So, it should be called only after (dired-move-to-filename t).
5888 : ;; ;; case-fold-search must be nil, at least for VMS.
5889 : ;; ;; On failure, signals an error or returns nil.
5890 : ;; ;; This is the CMS version.
5891 : ;; (let ((opoint (point))
5892 : ;; case-fold-search hidden)
5893 : ;; (or eol (setq eol (line-end-position)))
5894 : ;; (setq hidden (and selective-display
5895 : ;; (save-excursion
5896 : ;; (search-forward "\r" eol t))))
5897 : ;; (if hidden
5898 : ;; (if no-error
5899 : ;; nil
5900 : ;; (error
5901 : ;; (substitute-command-keys
5902 : ;; "File line is hidden, type \\[dired-hide-subdir] to unhide")))
5903 : ;; (skip-chars-forward "-A-Z0-9$_" eol)
5904 : ;; (skip-chars-forward " " eol)
5905 : ;; (skip-chars-forward "-A-Z0-9$_" eol)
5906 : ;; (if (eq opoint (point))
5907 : ;; (if no-error
5908 : ;; nil
5909 : ;; (error "No file on this line"))
5910 : ;; (point)))))
5911 :
5912 : ;;(or (assq 'cms ange-ftp-dired-move-to-end-of-filename-alist)
5913 : ;; (setq ange-ftp-dired-move-to-end-of-filename-alist
5914 : ;; (cons '(cms . ange-ftp-dired-cms-move-to-end-of-filename)
5915 : ;; ange-ftp-dired-move-to-end-of-filename-alist)))
5916 :
5917 : (defun ange-ftp-cms-make-compressed-filename (name &optional _reverse)
5918 0 : (if (string-match "-Z\\'" name)
5919 0 : (list nil (substring name 0 -2))
5920 0 : (list t (concat name "-Z"))))
5921 :
5922 : (or (assq 'cms ange-ftp-make-compressed-filename-alist)
5923 : (setq ange-ftp-make-compressed-filename-alist
5924 : (cons '(cms . ange-ftp-cms-make-compressed-filename)
5925 : ange-ftp-make-compressed-filename-alist)))
5926 :
5927 : ;;(defun ange-ftp-dired-cms-get-filename (&optional localp no-error-if-not-filep)
5928 : ;; (let ((name (ange-ftp-real-dired-get-filename localp no-error-if-not-filep)))
5929 : ;; (and name
5930 : ;; (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" name)
5931 : ;; (concat (substring name 0 (match-end 1))
5932 : ;; "."
5933 : ;; (substring name (match-beginning 2) (match-end 2)))
5934 : ;; name))))
5935 :
5936 : ;;(or (assq 'cms ange-ftp-dired-get-filename-alist)
5937 : ;; (setq ange-ftp-dired-get-filename-alist
5938 : ;; (cons '(cms . ange-ftp-dired-cms-get-filename)
5939 : ;; ange-ftp-dired-get-filename-alist)))
5940 :
5941 : ;;;; ------------------------------------------------------------
5942 : ;;;; BS2000 support
5943 : ;;;; ------------------------------------------------------------
5944 :
5945 : ;; There seems to be an error with regexps. '-' has to be the first
5946 : ;; character inside of the square brackets.
5947 : (defconst ange-ftp-bs2000-short-filename-regexp
5948 : "[-A-Z0-9$#@.]*[A-Z][-A-Z0-9$#@.]*"
5949 : "Regular expression to match for a valid short BS2000 file name.")
5950 :
5951 : (defconst ange-ftp-bs2000-fix-name-regexp-reverse
5952 : (concat
5953 : "^\\(" ange-ftp-bs2000-filename-pubset-regexp "\\)?"
5954 : "\\(" ange-ftp-bs2000-filename-username-regexp "\\)?"
5955 : "\\(" ange-ftp-bs2000-short-filename-regexp "\\)?")
5956 : "Regular expression used in `ange-ftp-fix-name-for-bs2000'.")
5957 :
5958 : (defconst ange-ftp-bs2000-fix-name-regexp
5959 : (concat
5960 : "/?\\(" ange-ftp-bs2000-filename-pubset-regexp "/\\)?"
5961 : "\\(\\$[A-Z0-9]*/\\)?"
5962 : "\\(" ange-ftp-bs2000-short-filename-regexp "\\)?")
5963 : "Regular expression used in `ange-ftp-fix-name-for-bs2000'.")
5964 :
5965 : (defcustom ange-ftp-bs2000-special-prefix
5966 : "X"
5967 : "Prefix used for filenames starting with `#' or `@'."
5968 : :group 'ange-ftp
5969 : :type 'string)
5970 :
5971 : ;; Convert NAME from UNIX-ish to BS2000. If REVERSE given then convert from
5972 : ;; BS2000 to UNIX-ish.
5973 : (defun ange-ftp-fix-name-for-bs2000 (name &optional reverse)
5974 0 : (save-match-data
5975 0 : (if reverse
5976 0 : (if (string-match
5977 0 : ange-ftp-bs2000-fix-name-regexp-reverse
5978 0 : name)
5979 0 : (let ((pubset (if (match-beginning 1)
5980 0 : (substring name 0 (match-end 1))))
5981 0 : (userid (if (match-beginning 2)
5982 0 : (substring name
5983 0 : (match-beginning 2)
5984 0 : (1- (match-end 2)))))
5985 0 : (filename (if (match-beginning 3)
5986 0 : (substring name (match-beginning 3)))))
5987 0 : (concat
5988 : "/"
5989 : ;; we have to insert "_/" here to prevent expand-file-name to
5990 : ;; interpret BS2000 pubsets as the special escape prefix:
5991 0 : (and pubset (concat "_/" pubset "/"))
5992 0 : (and userid (concat userid "/"))
5993 0 : filename))
5994 0 : (error "name %s didn't match" name))
5995 : ;; and here we (maybe) have to remove the inserted "_/" 'cause
5996 : ;; of our prevention of the special escape prefix above:
5997 0 : (if (string-match (concat "^/_/") name)
5998 0 : (setq name (substring name 2)))
5999 0 : (if (string-match
6000 0 : ange-ftp-bs2000-fix-name-regexp
6001 0 : name)
6002 0 : (let ((pubset (if (match-beginning 1)
6003 0 : (substring name
6004 0 : (match-beginning 1)
6005 0 : (1- (match-end 1)))))
6006 0 : (userid (if (match-beginning 2)
6007 0 : (substring name
6008 0 : (match-beginning 2)
6009 0 : (1- (match-end 2)))))
6010 0 : (filename (if (match-beginning 3)
6011 0 : (substring name (match-beginning 3)))))
6012 0 : (if (and (boundp 'filename)
6013 0 : (stringp filename)
6014 0 : (string-match "[#@].+" filename))
6015 0 : (setq filename (concat ange-ftp-bs2000-special-prefix
6016 0 : (substring filename 1))))
6017 0 : (upcase
6018 0 : (concat
6019 0 : pubset
6020 0 : (and userid (concat userid "."))
6021 : ;; change every '/' in filename to a '.', normally not necessary
6022 0 : (and filename
6023 0 : (subst-char-in-string ?/ ?. filename)))))
6024 : ;; Let's hope that BS2000 recognize this anyway:
6025 0 : name))))
6026 :
6027 : (or (assq 'bs2000 ange-ftp-fix-name-func-alist)
6028 : (setq ange-ftp-fix-name-func-alist
6029 : (cons '(bs2000 . ange-ftp-fix-name-for-bs2000)
6030 : ange-ftp-fix-name-func-alist)))
6031 :
6032 : ;; Convert name from UNIX-ish to BS2000 ready for a DIRectory listing.
6033 : ;; Remember that there are no directories in BS2000.
6034 : (defun ange-ftp-fix-dir-name-for-bs2000 (dir-name)
6035 0 : (if (string-equal dir-name "/")
6036 : "*" ;; Don't use an empty string here!
6037 0 : (ange-ftp-fix-name-for-bs2000 dir-name)))
6038 :
6039 : (or (assq 'bs2000 ange-ftp-fix-dir-name-func-alist)
6040 : (setq ange-ftp-fix-dir-name-func-alist
6041 : (cons '(bs2000 . ange-ftp-fix-dir-name-for-bs2000)
6042 : ange-ftp-fix-dir-name-func-alist)))
6043 :
6044 : (or (memq 'bs2000 ange-ftp-dumb-host-types)
6045 : (setq ange-ftp-dumb-host-types
6046 : (cons 'bs2000 ange-ftp-dumb-host-types)))
6047 :
6048 : (defvar ange-ftp-bs2000-host-regexp nil)
6049 : (defvar ange-ftp-bs2000-posix-host-regexp nil)
6050 :
6051 : ;; Return non-nil if HOST is running BS2000.
6052 : (defun ange-ftp-bs2000-host (host)
6053 0 : (and ange-ftp-bs2000-host-regexp
6054 0 : (string-match-p ange-ftp-bs2000-host-regexp host)))
6055 : ;; Return non-nil if HOST is running BS2000 with POSIX subsystem.
6056 : (defun ange-ftp-bs2000-posix-host (host)
6057 0 : (and ange-ftp-bs2000-posix-host-regexp
6058 0 : (string-match-p ange-ftp-bs2000-posix-host-regexp host)))
6059 :
6060 : (defun ange-ftp-add-bs2000-host (host)
6061 : "Mark HOST as the name of a machine running BS2000."
6062 : (interactive
6063 0 : (list (read-string "Host: "
6064 0 : (let ((name (or (buffer-file-name) default-directory)))
6065 0 : (and name (car (ange-ftp-ftp-name name)))))))
6066 0 : (if (not (ange-ftp-bs2000-host host))
6067 0 : (setq ange-ftp-bs2000-host-regexp
6068 0 : (concat "^" (regexp-quote host) "$"
6069 0 : (and ange-ftp-bs2000-host-regexp "\\|")
6070 0 : ange-ftp-bs2000-host-regexp)
6071 0 : ange-ftp-host-cache nil)))
6072 :
6073 : (defun ange-ftp-add-bs2000-posix-host (host)
6074 : "Mark HOST as the name of a machine running BS2000 with POSIX subsystem."
6075 : (interactive
6076 0 : (list (read-string "Host: "
6077 0 : (let ((name (or (buffer-file-name) default-directory)))
6078 0 : (and name (car (ange-ftp-ftp-name name)))))))
6079 0 : (if (not (ange-ftp-bs2000-posix-host host))
6080 0 : (setq ange-ftp-bs2000-posix-host-regexp
6081 0 : (concat "^" (regexp-quote host) "$"
6082 0 : (and ange-ftp-bs2000-posix-host-regexp "\\|")
6083 0 : ange-ftp-bs2000-posix-host-regexp)
6084 0 : ange-ftp-host-cache nil))
6085 : ;; Install CD hook to cd to posix on connecting:
6086 0 : (add-hook 'ange-ftp-process-startup-hook 'ange-ftp-bs2000-cd-to-posix)
6087 0 : host)
6088 :
6089 : (defconst ange-ftp-bs2000-filename-regexp
6090 : (concat
6091 : "\\(" ange-ftp-bs2000-filename-prefix-regexp "\\)?"
6092 : "\\(" ange-ftp-bs2000-short-filename-regexp "\\)")
6093 : "Regular expression to match for a valid BS2000 file name.")
6094 :
6095 : (defcustom ange-ftp-bs2000-additional-pubsets
6096 : nil
6097 : "List of additional pubsets available to all users."
6098 : :group 'ange-ftp
6099 : :type '(repeat string))
6100 :
6101 : ;; These parsing functions are as general as possible because the syntax
6102 : ;; of ftp listings from BS2000 hosts is a bit erratic. What saves us is that
6103 : ;; the BS2000 filename syntax is so rigid.
6104 :
6105 : ;; Extract the next filename from a BS2000 dired-like listing.
6106 : (defun ange-ftp-parse-bs2000-filename ()
6107 0 : (if (re-search-forward ange-ftp-bs2000-filename-regexp nil t)
6108 0 : (match-string 2)))
6109 :
6110 : ;; Parse the current buffer which is assumed to be in (some) BS2000 FTP dir
6111 : ;; format, and return a hashtable as the result.
6112 : (defun ange-ftp-parse-bs2000-listing ()
6113 0 : (let ((tbl (make-hash-table :test 'equal))
6114 : pubset
6115 : file)
6116 : ;; get current pubset
6117 0 : (goto-char (point-min))
6118 0 : (if (re-search-forward ange-ftp-bs2000-filename-pubset-regexp nil t)
6119 0 : (setq pubset (match-string 0)))
6120 : ;; add files to hashtable
6121 0 : (goto-char (point-min))
6122 0 : (save-match-data
6123 0 : (while (setq file (ange-ftp-parse-bs2000-filename))
6124 0 : (puthash file nil tbl)))
6125 : ;; add . and ..
6126 0 : (puthash "." t tbl)
6127 0 : (puthash ".." t tbl)
6128 : ;; add all additional pubsets, if not listing one of them
6129 0 : (if (not (member pubset ange-ftp-bs2000-additional-pubsets))
6130 0 : (mapc (lambda (pubset) (puthash pubset t tbl))
6131 0 : ange-ftp-bs2000-additional-pubsets))
6132 0 : tbl))
6133 :
6134 : (add-to-list 'ange-ftp-parse-list-func-alist
6135 : '(bs2000 . ange-ftp-parse-bs2000-listing))
6136 :
6137 : (defun ange-ftp-bs2000-cd-to-posix ()
6138 : "cd to POSIX subsystem if the current host matches
6139 : `ange-ftp-bs2000-posix-host-regexp'. All BS2000 hosts with POSIX subsystem
6140 : MUST BE EXPLICITLY SET with `ange-ftp-add-bs2000-posix-host' for they cannot
6141 : be recognized automatically (they are all valid BS2000 hosts too)."
6142 0 : (if (and ange-ftp-this-host (ange-ftp-bs2000-posix-host ange-ftp-this-host))
6143 0 : (progn
6144 : ;; change to POSIX:
6145 : ; (ange-ftp-raw-send-cmd proc "cd %POSIX")
6146 0 : (ange-ftp-cd ange-ftp-this-host ange-ftp-this-user "%POSIX")
6147 : ;; put new home directory in the expand-dir hashtable.
6148 : ;; `ange-ftp-this-host' and `ange-ftp-this-user' are bound in
6149 : ;; ange-ftp-get-process.
6150 0 : (puthash (concat ange-ftp-this-host "/" ange-ftp-this-user "/~")
6151 0 : (car (ange-ftp-get-pwd ange-ftp-this-host ange-ftp-this-user))
6152 0 : ange-ftp-expand-dir-hashtable))))
6153 :
6154 : ;; Not available yet:
6155 : ;; ange-ftp-bs2000-delete-file-entry
6156 : ;; ange-ftp-bs2000-add-file-entry
6157 : ;; ange-ftp-bs2000-file-name-as-directory
6158 : ;; ange-ftp-bs2000-make-compressed-filename
6159 : ;; ange-ftp-bs2000-file-name-sans-versions
6160 :
6161 : ;;;; ------------------------------------------------------------
6162 : ;;;; Finally provide package.
6163 : ;;;; ------------------------------------------------------------
6164 :
6165 : (provide 'ange-ftp)
6166 :
6167 : ;;; ange-ftp.el ends here
|