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