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