aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
authorGerd Moellmann2000-03-20 13:12:47 +0000
committerGerd Moellmann2000-03-20 13:12:47 +0000
commita1cc310c2b92fc27d5d4b9739846249da243d193 (patch)
tree99a77bb1812a10c3c97547a90b89bcb961475ca1 /lisp
parent8749abea4344b8a9763317e523362ce75ae008ac (diff)
downloademacs-a1cc310c2b92fc27d5d4b9739846249da243d193.tar.gz
emacs-a1cc310c2b92fc27d5d4b9739846249da243d193.zip
Moved to net subdir.
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ange-ftp.el5695
-rw-r--r--lisp/browse-url.el1033
-rw-r--r--lisp/goto-addr.el234
-rw-r--r--lisp/net-utils.el858
-rw-r--r--lisp/quickurl.el552
-rw-r--r--lisp/rcompile.el179
-rw-r--r--lisp/rlogin.el373
-rw-r--r--lisp/snmp-mode.el716
-rw-r--r--lisp/telnet.el261
-rw-r--r--lisp/webjump.el403
-rw-r--r--lisp/zone-mode.el117
11 files changed, 0 insertions, 10421 deletions
diff --git a/lisp/ange-ftp.el b/lisp/ange-ftp.el
deleted file mode 100644
index 695a44fcaa5..00000000000
--- a/lisp/ange-ftp.el
+++ /dev/null
@@ -1,5695 +0,0 @@
1;;; ange-ftp.el --- transparent FTP support for GNU Emacs
2
3;; Copyright (C) 1989,90,91,92,93,94,95,96,98 Free Software Foundation, Inc.
4
5;; Author: Andy Norman (ange@hplb.hpl.hp.com)
6;; Maintainer: FSF
7;; Keywords: comm
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option)
14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING. If not, write to the
23;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24;; Boston, MA 02111-1307, USA.
25
26;;; Commentary:
27
28;; This package attempts to make accessing files and directories using FTP
29;; from within GNU Emacs as simple and transparent as possible. A subset of
30;; the common file-handling routines are extended to interact with FTP.
31
32;; Usage:
33;;
34;; Some of the common GNU Emacs file-handling operations have been made
35;; FTP-smart. If one of these routines is given a filename that matches
36;; '/user@host:name' then it will spawn an FTP process connecting to machine
37;; 'host' as account 'user' and perform its operation on the file 'name'.
38;;
39;; For example: if find-file is given a filename of:
40;;
41;; /ange@anorman:/tmp/notes
42;;
43;; then ange-ftp spawns an FTP process, connect to the host 'anorman' as
44;; user 'ange', get the file '/tmp/notes' and pop up a buffer containing the
45;; contents of that file as if it were on the local filesystem. If ange-ftp
46;; needs a password to connect then it reads one in the echo area.
47
48;; Extended filename syntax:
49;;
50;; The default extended filename syntax is '/user@host:name', where the
51;; 'user@' part may be omitted. This syntax can be customised to a certain
52;; extent by changing ange-ftp-name-format. There are limitations.
53;; The `host' part has an optional suffix `#port' which may be used to
54;; specify a non-default port number for the connexion.
55;;
56;; If the user part is omitted then ange-ftp generates a default user
57;; instead whose value depends on the variable ange-ftp-default-user.
58
59;; Passwords:
60;;
61;; A password is required for each host/user pair. Ange-ftp reads passwords
62;; as needed. You can also specify a password with ange-ftp-set-passwd, or
63;; in a *valid* ~/.netrc file.
64
65;; Passwords for user "anonymous":
66;;
67;; Passwords for the user "anonymous" (or "ftp") are handled
68;; specially. The variable `ange-ftp-generate-anonymous-password'
69;; controls what happens: if the value of this variable is a string,
70;; then this is used as the password; if non-nil (the default), then
71;; the value of `user-mail-address' is used; if nil then the user
72;; is prompted for a password as normal.
73
74;; "Dumb" UNIX hosts:
75;;
76;; The FTP servers on some UNIX machines have problems if the 'ls' command is
77;; used.
78;;
79;; The routine ange-ftp-add-dumb-unix-host can be called to tell ange-ftp to
80;; limit itself to the DIR command and not 'ls' for a given UNIX host. Note
81;; that this change will take effect for the current GNU Emacs session only.
82;; See below for a discussion of non-UNIX hosts. If a large number of
83;; machines with similar hostnames have this problem then it is easier to set
84;; the value of ange-ftp-dumb-unix-host-regexp in your .emacs file. ange-ftp
85;; is unable to automatically recognize dumb unix hosts.
86
87;; File name completion:
88;;
89;; Full file-name completion is supported on UNIX, VMS, CMS, and MTS hosts.
90;; To do filename completion, ange-ftp needs a listing from the remote host.
91;; Therefore, for very slow connections, it might not save any time.
92
93;; FTP processes:
94;;
95;; When ange-ftp starts up an FTP process, it leaves it running for speed
96;; purposes. Some FTP servers will close the connection after a period of
97;; time, but ange-ftp should be able to quietly reconnect the next time that
98;; the process is needed.
99;;
100;; Killing the "*ftp user@host*" buffer also kills the ftp process.
101;; This should not cause ange-ftp any grief.
102
103;; Binary file transfers:
104;;
105;; By default ange-ftp transfers files in ASCII mode. If a file being
106;; transferred matches the value of ange-ftp-binary-file-name-regexp then
107;; binary mode is used for that transfer.
108
109;; Account passwords:
110;;
111;; Some FTP servers require an additional password which is sent by the
112;; ACCOUNT command. ange-ftp partially supports this by allowing the user to
113;; specify an account password by either calling ange-ftp-set-account, or by
114;; specifying an account token in the .netrc file. If the account password
115;; is set by either of these methods then ange-ftp will issue an ACCOUNT
116;; command upon starting the FTP process.
117
118;; Preloading:
119;;
120;; ange-ftp can be preloaded, but must be put in the site-init.el file and
121;; not the site-load.el file in order for the documentation strings for the
122;; functions being overloaded to be available.
123
124;; Status reports:
125;;
126;; Most ange-ftp commands that talk to the FTP process output a status
127;; message on what they are doing. In addition, ange-ftp can take advantage
128;; of the FTP client's HASH command to display the status of transferring
129;; files and listing directories. See the documentation for the variables
130;; ange-ftp-{ascii,binary}-hash-mark-size, ange-ftp-send-hash and
131;; ange-ftp-process-verbose for more details.
132
133;; Gateways:
134;;
135;; Sometimes it is necessary for the FTP process to be run on a different
136;; machine than the machine running GNU Emacs. This can happen when the
137;; local machine has restrictions on what hosts it can access.
138;;
139;; ange-ftp has support for running the ftp process on a different (gateway)
140;; machine. The way it works is as follows:
141;;
142;; 1) Set the variable 'ange-ftp-gateway-host' to the name of a machine
143;; that doesn't have the access restrictions.
144;;
145;; 2) Set the variable 'ange-ftp-local-host-regexp' to a regular expression
146;; that matches hosts that can be contacted from running a local ftp
147;; process, but fails to match hosts that can't be accessed locally. For
148;; example:
149;;
150;; "\\.hp\\.com$\\|^[^.]*$"
151;;
152;; will match all hosts that are in the .hp.com domain, or don't have an
153;; explicit domain in their name, but will fail to match hosts with
154;; explicit domains or that are specified by their ip address.
155;;
156;; 3) Using NFS and symlinks, make sure that there is a shared directory with
157;; the *same* name between the local machine and the gateway machine.
158;; This directory is necessary for temporary files created by ange-ftp.
159;;
160;; 4) Set the variable 'ange-ftp-gateway-tmp-name-template' to the name of
161;; this directory plus an identifying filename prefix. For example:
162;;
163;; "/nfs/hplose/ange/ange-ftp"
164;;
165;; where /nfs/hplose/ange is a directory that is shared between the
166;; gateway machine and the local machine.
167;;
168;; The simplest way of getting a ftp process running on the gateway machine
169;; is if you can spawn a remote shell using either 'rsh' or 'remsh'. If you
170;; can't do this for some reason such as security then points 7 onwards will
171;; discuss an alternative approach.
172;;
173;; 5) Set the variable ange-ftp-gateway-program to the name of the remote
174;; shell process such as 'remsh' or 'rsh' if the default isn't correct.
175;;
176;; 6) Set the variable ange-ftp-gateway-program-interactive to nil if it
177;; isn't already. This tells ange-ftp that you are using a remote shell
178;; rather than logging in using telnet or rlogin.
179;;
180;; That should be all you need to allow ange-ftp to spawn a ftp process on
181;; the gateway machine. If you have to use telnet or rlogin to get to the
182;; gateway machine then follow the instructions below.
183;;
184;; 7) Set the variable ange-ftp-gateway-program to the name of the program
185;; that lets you log onto the gateway machine. This may be something like
186;; telnet or rlogin.
187;;
188;; 8) Set the variable ange-ftp-gateway-prompt-pattern to a regular
189;; expression that matches the prompt you get when you login to the
190;; gateway machine. Be very specific here; this regexp must not match
191;; *anything* in your login banner except this prompt.
192;; shell-prompt-pattern is far too general as it appears to match some
193;; login banners from Sun machines. For example:
194;;
195;; "^$*$ *"
196;;
197;; 9) Set the variable ange-ftp-gateway-program-interactive to 't' to let
198;; ange-ftp know that it has to "hand-hold" the login to the gateway
199;; machine.
200;;
201;; 10) Set the variable ange-ftp-gateway-setup-term-command to a UNIX command
202;; that will put the pty connected to the gateway machine into a
203;; no-echoing mode, and will strip off carriage-returns from output from
204;; the gateway machine. For example:
205;;
206;; "stty -onlcr -echo"
207;;
208;; will work on HP-UX machines, whereas:
209;;
210;; "stty -echo nl"
211;;
212;; appears to work for some Sun machines.
213;;
214;; That's all there is to it.
215
216;; Smart gateways:
217;;
218;; If you have a "smart" ftp program that allows you to issue commands like
219;; "USER foo@bar" which do nice proxy things, then look at the variables
220;; ange-ftp-smart-gateway and ange-ftp-smart-gateway-port.
221;;
222;; Otherwise, if there is an alternate ftp program that implements proxy in
223;; a transparent way (i.e. w/o specifying the proxy host), that will
224;; connect you directly to the desired destination host:
225;; Set ange-ftp-gateway-ftp-program-name to that program's name.
226;; Set ange-ftp-local-host-regexp to a value as stated earlier on.
227;; Leave ange-ftp-gateway-host set to nil.
228;; Set ange-ftp-smart-gateway to t.
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 yourself 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. 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 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 $$.
330
331;; MTS support:
332;;
333;; Ange-ftp has full support for hosts running
334;; the Michigan terminal system. It should be able to automatically
335;; recognize any MTS machine. However, if it fails to do this, you can use
336;; the command ange-ftp-add-mts-host. As well, you can set the variable
337;; ange-ftp-mts-host-regexp in your .emacs file. We would be grateful if you
338;; would report any failures to automatically recognize a MTS host as a bug.
339;;
340;; Filename syntax:
341;;
342;; MTS filenames are entered in a UNIX-y way. For example, if your account
343;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be
344;; entered as
345;; /YYYY@mtsg.ubc.ca:/XXXX:/FILE
346;; In other words, MTS accounts are treated as UNIX directories. Of course,
347;; to access a file in another account, you must have access permission for
348;; it. If FILE were in your own account, then you could enter it in a
349;; relative name fashion as
350;; /YYYY@mtsg.ubc.ca:FILE
351;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the
352;; filename does not contain a TYPE (i.e. it can have as many "."'s as you
353;; like.) MTS filenames are always in upper case, and hence be sure to enter
354;; them as such! MTS is not case sensitive, but an EMACS running under UNIX
355;; is.
356
357;; CMS support:
358;;
359;; Ange-ftp has full support for hosts running
360;; CMS. It should be able to automatically recognize any CMS machine.
361;; However, if it fails to do this, you can use the command
362;; ange-ftp-add-cms-host. As well, you can set the variable
363;; ange-ftp-cms-host-regexp in your .emacs file. We would be grateful if you
364;; would report any failures to automatically recognize a CMS host as a bug.
365;;
366;; Filename syntax:
367;;
368;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are
369;; treated as UNIX directories. For example to access the file READ.ME in
370;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter
371;; /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME
372;; If *.301 is the default minidisk for this account, you could access
373;; FOO.BAR on this minidisk as
374;; /anonymous@cuvmb.cc.columbia.edu:FOO.BAR
375;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be
376;; up to 8 characters. Again, beware that CMS filenames are always upper
377;; case, and hence must be entered as such.
378;;
379;; Tips:
380;; 1. CMS machines, with the exception of anonymous accounts, nearly always
381;; need an account password. To have ange-ftp send an account password,
382;; you can either include it in your .netrc file, or use
383;; ange-ftp-set-account.
384;; 2. Ange-ftp cannot send "write passwords" for a minidisk. Hopefully, we
385;; can fix this.
386;;
387;; ------------------------------------------------------------------
388;; Bugs:
389;; ------------------------------------------------------------------
390;;
391;; 1. Umask problems:
392;; Be warned that files created by using ange-ftp will take account of the
393;; umask of the ftp daemon process rather than the umask of the creating
394;; user. This is particularly important when logging in as the root user.
395;; The way that I tighten up the ftp daemon's umask under HP-UX is to make
396;; sure that the umask is changed to 027 before I spawn /etc/inetd. I
397;; suspect that there is something similar on other systems.
398;;
399;; 2. Some combinations of FTP clients and servers break and get out of sync
400;; when asked to list a non-existent directory. Some of the ai.mit.edu
401;; machines cause this problem for some FTP clients. Using
402;; ange-ftp-kill-ftp-process can restart the ftp process, which
403;; should get things back in sync.
404;;
405;; 3. Ange-ftp does not check to make sure that when creating a new file,
406;; you provide a valid filename for the remote operating system.
407;; If you do not, then the remote FTP server will most likely
408;; translate your filename in some way. This may cause ange-ftp to
409;; get confused about what exactly is the name of the file. The
410;; most common causes of this are using lower case filenames on systems
411;; which support only upper case, and using filenames which are too
412;; long.
413;;
414;; 4. Null (blank) passwords confuse both ange-ftp and some FTP daemons.
415;;
416;; 5. Ange-ftp likes to use pty's to talk to its FTP processes. If GNU Emacs
417;; for some reason creates a FTP process that only talks via pipes then
418;; ange-ftp won't be getting the information it requires at the time that
419;; it wants it since pipes flush at different times to pty's. One
420;; disgusting way around this problem is to talk to the FTP process via
421;; rlogin which does the 'right' things with pty's.
422;;
423;; 6. For CMS support, we send too many cd's. Since cd's are cheap, I haven't
424;; worried about this too much. Eventually, we should have some caching
425;; of the current minidisk.
426;;
427;; 7. Some CMS machines do not assign a default minidisk when you ftp them as
428;; anonymous. It is then necessary to guess a valid minidisk name, and cd
429;; to it. This is (understandably) beyond ange-ftp.
430;;
431;; 8. Remote to remote copying of files on non-Unix machines can be risky.
432;; Depending on the variable ange-ftp-binary-file-name-regexp, ange-ftp
433;; will use binary mode for the copy. Between systems of different
434;; architecture, this still may not be enough to guarantee the integrity
435;; of binary files. Binary file transfers from VMS machines are
436;; particularly problematical. Should ange-ftp-binary-file-name-regexp be
437;; an alist of OS type, regexp pairs?
438;;
439;; 9. The code to do compression of files over ftp is not as careful as it
440;; should be. It deletes the old remote version of the file, before
441;; actually checking if the local to remote transfer of the compressed
442;; file succeeds. Of course to delete the original version of the file
443;; after transferring the compressed version back is also dangerous,
444;; because some OS's have severe restrictions on the length of filenames,
445;; and when the compressed version is copied back the "-Z" or ".Z" may be
446;; truncated. Then, ange-ftp would delete the only remaining version of
447;; the file. Maybe ange-ftp should make backups when it compresses files
448;; (of course, the backup "~" could also be truncated off, sigh...).
449;; Suggestions?
450;;
451;; 10. If a dir listing is attempted for an empty directory on (at least
452;; some) VMS hosts, an ftp error is given. This is really an ftp bug, and
453;; I don't know how to get ange-ftp work to around it.
454;;
455;; 11. Bombs on filenames that start with a space. Deals well with filenames
456;; containing spaces, but beware that the remote ftpd may not like them
457;; much.
458;;
459;; 12. The dired support for non-Unix-like systems does not currently work.
460;; It needs to be reimplemented by modifying the parse-...-listing
461;; functions to convert the directory listing to ls -l format.
462;;
463;; 13. The famous @ bug. As mentioned above in TIPS, ULTRIX marks symlinks
464;; with a trailing @ in a ls -alF listing. In order to account for this
465;; ange-ftp looks to chop trailing @'s off of symlink names when it is
466;; parsing a listing with the F switch. This will cause ange-ftp to
467;; incorrectly get the name of a symlink on a non-ULTRIX host if its name
468;; ends in an @. ange-ftp will correct itself if you take F out of the
469;; dired ls switches (C-u s will allow you to edit the switches). The
470;; dired buffer will be automatically reverted, which will allow ange-ftp
471;; to fix its files hashtable. A cookie to anyone who can think of a
472;; fast, sure-fire way to recognize ULTRIX over ftp.
473
474;; If you find any bugs or problems with this package, PLEASE either e-mail
475;; the above author, or send a message to the ange-ftp-lovers mailing list
476;; below. Ideas and constructive comments are especially welcome.
477
478;; ange-ftp-lovers:
479;;
480;; ange-ftp has its own mailing list modestly called ange-ftp-lovers. All
481;; users of ange-ftp are welcome to subscribe (see below) and to discuss
482;; aspects of ange-ftp. New versions of ange-ftp are posted periodically to
483;; the mailing list.
484
485;; [The following information about lists may be obsolete.]
486
487;; To [un]subscribe to ange-ftp-lovers, or to report mailer problems with the
488;; list, please mail one of the following addresses:
489;;
490;; ange-ftp-lovers-request@anorman.hpl.hp.com
491;; or
492;; ange-ftp-lovers-request%anorman.hpl.hp.com@hplb.hpl.hp.com
493;;
494;; Please don't forget the -request part.
495;;
496;; For mail to be posted directly to ange-ftp-lovers, send to one of the
497;; following addresses:
498;;
499;; ange-ftp-lovers@anorman.hpl.hp.com
500;; or
501;; ange-ftp-lovers%anorman.hpl.hp.com@hplb.hpl.hp.com
502;;
503;; Alternatively, there is a mailing list that only gets announcements of new
504;; ange-ftp releases. This is called ange-ftp-lovers-announce, and can be
505;; subscribed to by e-mailing to the -request address as above. Please make
506;; it clear in the request which mailing list you wish to join.
507
508;; The archives for ange-ftp-lovers can be found via anonymous ftp under:
509;;
510;; ftp.reed.edu:pub/mailing-lists/ange-ftp/
511
512;; -----------------------------------------------------------
513;; Technical information on this package:
514;; -----------------------------------------------------------
515
516;; ange-ftp works by putting a handler on file-name-handler-alist
517;; which is called by many primitives, and a few non-primitives,
518;; whenever they see a file name of the appropriate sort.
519
520;; Checklist for adding non-UNIX support for TYPE
521;;
522;; The following functions may need TYPE versions:
523;; (not all functions will be needed for every OS)
524;;
525;; ange-ftp-fix-name-for-TYPE
526;; ange-ftp-fix-dir-name-for-TYPE
527;; ange-ftp-TYPE-host
528;; ange-ftp-TYPE-add-host
529;; ange-ftp-parse-TYPE-listing
530;; ange-ftp-TYPE-delete-file-entry
531;; ange-ftp-TYPE-add-file-entry
532;; ange-ftp-TYPE-file-name-as-directory
533;; ange-ftp-TYPE-make-compressed-filename
534;; ange-ftp-TYPE-file-name-sans-versions
535;;
536;; Variables:
537;;
538;; ange-ftp-TYPE-host-regexp
539;; May need to add TYPE to ange-ftp-dumb-host-types
540;;
541;; Check the following functions for OS dependent coding:
542;;
543;; ange-ftp-host-type
544;; ange-ftp-guess-host-type
545;; ange-ftp-allow-child-lookup
546
547;; Host type conventions:
548;;
549;; The function ange-ftp-host-type and the variable ange-ftp-dired-host-type
550;; (mostly) follow the following conventions for remote host types. At
551;; least, I think that future code should try to follow these conventions,
552;; and the current code should eventually be made compliant.
553;;
554;; nil = local host type, whatever that is (probably unix).
555;; Think nil as in "not a remote host". This value is used by
556;; ange-ftp-dired-host-type for local buffers.
557;;
558;; t = a remote host of unknown type. Think t as in true, it's remote.
559;; Currently, `unix' is used as the default remote host type.
560;; Maybe we should use t.
561;;
562;; TYPE = a remote host of TYPE type.
563;;
564;; TYPE:LIST = a remote host of TYPE type, using a specialized ftp listing
565;; program called list. This is currently only used for Unix
566;; dl (descriptive listings), when ange-ftp-dired-host-type
567;; is set to `unix:dl'.
568
569;; Bug report codes:
570;;
571;; Because of their naive faith in this code, there are certain situations
572;; which the writers of this program believe could never happen. However,
573;; being realists they have put calls to `error' in the program at these
574;; points. These errors provide a code, which is an integer, greater than 1.
575;; To aid debugging. the error codes, and the functions in which they reside
576;; are listed below.
577;;
578;; 1: See ange-ftp-ls
579;;
580
581;; -----------------------------------------------------------
582;; Hall of fame:
583;; -----------------------------------------------------------
584;;
585;; Thanks to Roland McGrath for improving the filename syntax handling,
586;; for suggesting many enhancements and for numerous cleanups to the code.
587;;
588;; Thanks to Jamie Zawinski for bugfixes and for ideas such as gateways.
589;;
590;; Thanks to Ken Laprade for improved .netrc parsing, password reading, and
591;; dired / shell auto-loading.
592;;
593;; Thanks to Sebastian Kremer for dired support and for many ideas and
594;; bugfixes.
595;;
596;; Thanks to Joe Wells for bugfixes, the original non-UNIX system support,
597;; VOS support, and hostname completion.
598;;
599;; Thanks to Nakagawa Takayuki for many good ideas, filename-completion, help
600;; with file-name expansion, efficiency worries, stylistic concerns and many
601;; bugfixes.
602;;
603;; Thanks to Sandy Rutherford who re-wrote most of ange-ftp to support VMS,
604;; MTS, CMS and UNIX-dls. Sandy also added dired-support for non-UNIX OS and
605;; auto-recognition of the host type.
606;;
607;; Thanks to Dave Smith who wrote the info file for ange-ftp.
608;;
609;; Finally, thanks to Keith Waclena, Mark D. Baushke, Terence Kelleher, Ping
610;; Zhou, Edward Vielmetti, Jack Repenning, Mike Balenger, Todd Kaufmann,
611;; Kjetil Svarstad, Tom Wurgler, Linus Tolke, Niko Makila, Carl Edman, Bill
612;; Trost, Dave Brennan, Dan Jacobson, Andy Scott, Steve Anderson, Sanjay
613;; Mathur, the folks on the ange-ftp-lovers mailing list and many others
614;; whose names I've forgotten who have helped to debug and fix problems with
615;; ange-ftp.el.
616
617;;; Code:
618
619(require 'comint)
620;; Silence compiler:
621(eval-when-compile
622 (require 'dired)
623 (defvar comint-last-output-start nil)
624 (defvar comint-last-input-start nil)
625 (defvar comint-last-input-end nil))
626
627;;;; ------------------------------------------------------------
628;;;; User customization variables.
629;;;; ------------------------------------------------------------
630
631(defgroup ange-ftp nil
632 "Accessing remote files and directories using FTP
633 made as simple and transparent as possible."
634 :group 'files
635 :prefix "ange-ftp-")
636
637(defcustom ange-ftp-name-format
638 '("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*[^@/:.]\\):\\(.*\\)" . (3 2 4))
639 "*Format of a fully expanded remote file name.
640
641This is a list of the form \(REGEXP HOST USER NAME\),
642where REGEXP is a regular expression matching
643the full remote name, and HOST, USER, and NAME are the numbers of
644parenthesized expressions in REGEXP for the components (in that order)."
645 :group 'ange-ftp
646 :type '(list regexp
647 (integer :tag "Host group")
648 (integer :tag "User group")
649 (integer :tag "Name group")))
650
651;; ange-ftp-multi-skip-msgs should only match ###-, where ### is one of
652;; the number codes corresponding to ange-ftp-good-msgs or ange-ftp-fatal-msgs.
653;; Otherwise, ange-ftp will go into multi-skip mode, and never come out.
654
655(defvar ange-ftp-multi-msgs
656 "^220-\\|^230-\\|^226\\|^25.-\\|^221-\\|^200-\\|^331-\\|^4[25]1-\\|^530-"
657 "*Regular expression matching the start of a multiline ftp reply.")
658
659(defvar ange-ftp-good-msgs
660 "^220 \\|^230 \\|^226 \\|^25. \\|^221 \\|^200 \\|^[Hh]ash mark"
661 "*Regular expression matching ftp \"success\" messages.")
662
663;; CMS and the odd VMS machine say 200 Port rather than 200 PORT.
664;; Also CMS machines use a multiline 550- reply to say that you
665;; don't have write permission. ange-ftp gets into multi-line skip
666;; mode and hangs. Have it ignore 550- instead. It will then barf
667;; when it gets the 550 line, as it should.
668
669(defcustom ange-ftp-skip-msgs
670 (concat "^200 \\(PORT\\|Port\\) \\|^331 \\|^150 \\|^350 \\|^[0-9]+ bytes \\|"
671 "^Connected \\|^$\\|^Remote system\\|^Using\\|^ \\|Password:\\|"
672 "^Data connection \\|"
673 "^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye\\|"
674 "^227 .*[Pp]assive\\|^200 EPRT\\|^500 .*EPRT")
675 "*Regular expression matching ftp messages that can be ignored."
676 :group 'ange-ftp
677 :type 'regexp)
678
679(defcustom ange-ftp-fatal-msgs
680 (concat "^ftp: \\|^Not connected\\|^530 \\|^4[25]1 \\|rcmd: \\|"
681 "^No control connection\\|unknown host\\|^lost connection")
682 "*Regular expression matching ftp messages that indicate serious errors.
683
684These mean that the FTP process should (or already has) been killed."
685 :group 'ange-ftp
686 :type 'regexp)
687
688(defcustom ange-ftp-gateway-fatal-msgs
689 "No route to host\\|Connection closed\\|No such host\\|Login incorrect"
690 "*Regular expression matching login failure messages from rlogin/telnet."
691 :group 'ange-ftp
692 :type 'regexp)
693
694(defcustom ange-ftp-xfer-size-msgs
695 "^150 .* connection for .* (\\([0-9]+\\) bytes)"
696 "*Regular expression used to determine the number of bytes in a FTP transfer."
697 :group 'ange-ftp
698 :type 'regexp)
699
700(defcustom ange-ftp-tmp-name-template
701 (expand-file-name "ange-ftp" temporary-file-directory)
702 "*Template used to create temporary files."
703 :group 'ange-ftp
704 :type 'directory)
705
706(defcustom ange-ftp-gateway-tmp-name-template "/tmp/ange-ftp"
707 "*Template used to create temporary files when ftp-ing through a gateway.
708
709Files starting with this prefix need to be accessible from BOTH the local
710machine and the gateway machine, and need to have the SAME name on both
711machines, that is, /tmp is probably NOT what you want, since that is rarely
712cross-mounted."
713 :group 'ange-ftp
714 :type 'directory)
715
716(defcustom ange-ftp-netrc-filename "~/.netrc"
717 "*File in .netrc format to search for passwords."
718 :group 'ange-ftp
719 :type 'file)
720
721(defcustom ange-ftp-disable-netrc-security-check (eq system-type 'windows-nt)
722 "*If non-nil avoid checking permissions on the .netrc file."
723 :group 'ange-ftp
724 :type 'boolean)
725
726(defcustom ange-ftp-default-user nil
727 "*User name to use when none is specified in a file name.
728
729If non-nil but not a string, you are prompted for the name.
730If nil, the value of `ange-ftp-netrc-default-user' is used.
731If that is nil too, then your login name is used.
732
733Once a connection to a given host has been initiated, the user name
734and password information for that host are cached and re-used by
735ange-ftp. Use \\[ange-ftp-set-user] to change the cached values,
736since setting `ange-ftp-default-user' directly does not affect
737the cached information."
738 :group 'ange-ftp
739 :type '(choice (const :tag "Default" nil)
740 string
741 (other :tag "Prompt" t)))
742
743(defcustom ange-ftp-netrc-default-user nil
744 "Alternate default user name to use when none is specified.
745
746This variable is set from the `default' command in your `.netrc' file,
747if there is one."
748 :group 'ange-ftp
749 :type '(choice (const :tag "Default" nil)
750 string))
751
752(defcustom ange-ftp-default-password nil
753 "*Password to use when the user name equals `ange-ftp-default-user'."
754 :group 'ange-ftp
755 :type '(choice (const :tag "Default" nil)
756 string))
757
758(defcustom ange-ftp-default-account nil
759 "*Account to use when the user name equals `ange-ftp-default-user'."
760 :group 'ange-ftp
761 :type '(choice (const :tag "Default" nil)
762 string))
763
764(defcustom ange-ftp-netrc-default-password nil
765 "*Password to use when the user name equals `ange-ftp-netrc-default-user'."
766 :group 'ange-ftp
767 :type '(choice (const :tag "Default" nil)
768 string))
769
770(defcustom ange-ftp-netrc-default-account nil
771 "*Account to use when the user name equals `ange-ftp-netrc-default-user'."
772 :group 'ange-ftp
773 :type '(choice (const :tag "Default" nil)
774 string))
775
776(defcustom ange-ftp-generate-anonymous-password t
777 "*If t, use value of `user-mail-address' as password for anonymous ftp.
778
779If a string, then use that string as the password.
780If nil, prompt the user for a password."
781 :group 'ange-ftp
782 :type '(choice (const :tag "Prompt" nil)
783 string
784 (other :tag "User address" t)))
785
786(defcustom ange-ftp-dumb-unix-host-regexp nil
787 "*If non-nil, regexp matching hosts on which `dir' command lists directory."
788 :group 'ange-ftp
789 :type '(choice (const :tag "Default" nil)
790 string))
791
792(defcustom ange-ftp-binary-file-name-regexp
793 (concat "\\.[zZ]$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|"
794 "\\.dvi$\\|\\.ps$\\|\\.elc$\\|TAGS$\\|\\.gif$\\|"
795 "\\.EXE\\(;[0-9]+\\)?$\\|\\.[zZ]-part-..$\\|\\.gz$\\|"
796 "\\.taz$\\|\\.tgz$")
797 "*If a file matches this regexp then it is transferred in binary mode."
798 :group 'ange-ftp
799 :type 'regexp)
800
801(defcustom ange-ftp-gateway-host nil
802 "*Name of host to use as gateway machine when local FTP isn't possible."
803 :group 'ange-ftp
804 :type '(choice (const :tag "Default" nil)
805 string))
806
807(defcustom ange-ftp-local-host-regexp ".*"
808 "*Regexp selecting hosts which can be reached directly with ftp.
809
810For other hosts the FTP process is started on \`ange-ftp-gateway-host\'
811instead, and/or reached via \`ange-ftp-gateway-ftp-program-name\'."
812 :group 'ange-ftp
813 :type 'regexp)
814
815(defcustom ange-ftp-gateway-program-interactive nil
816 "*If non-nil then the gateway program should give a shell prompt.
817
818Both telnet and rlogin do something like this."
819 :group 'ange-ftp
820 :type 'boolean)
821
822(defcustom ange-ftp-gateway-program remote-shell-program
823 "*Name of program to spawn a shell on the gateway machine.
824
825Valid candidates are rsh (remsh on some systems), telnet and rlogin. See
826also the gateway variable above."
827 :group 'ange-ftp
828 :type '(choice (const "rsh")
829 (const "telnet")
830 (const "rlogin")
831 string))
832
833(defcustom ange-ftp-gateway-prompt-pattern "^[^#$%>;\n]*[#$%>;] *"
834 "*Regexp matching prompt after complete login sequence on gateway machine.
835
836A match for this means the shell is now awaiting input. Make this regexp as
837strict as possible; it shouldn't match *anything* at all except the user's
838initial prompt. The above string will fail under most SUN-3's since it
839matches the login banner."
840 :group 'ange-ftp
841 :type 'regexp)
842
843(defvar ange-ftp-gateway-setup-term-command
844 (if (eq system-type 'hpux)
845 "stty -onlcr -echo\n"
846 "stty -echo nl\n")
847 "*Set up terminal after logging in to the gateway machine.
848This command should stop the terminal from echoing each command, and
849arrange to strip out trailing ^M characters.")
850
851(defcustom ange-ftp-smart-gateway nil
852 "*Non-nil means the ftp gateway and/or the gateway ftp program is smart.
853
854Don't bother telnetting, etc., already connected to desired host transparently,
855or just issue a user@host command in case \`ange-ftp-gateway-host\' is non-nil."
856 :group 'ange-ftp
857 :type 'boolean)
858
859(defcustom ange-ftp-smart-gateway-port "21"
860 "*Port on gateway machine to use when smart gateway is in operation."
861 :group 'ange-ftp
862 :type 'string)
863
864(defcustom ange-ftp-send-hash t
865 "*If non-nil, send the HASH command to the FTP client."
866 :group 'ange-ftp
867 :type 'boolean)
868
869(defcustom ange-ftp-binary-hash-mark-size nil
870 "*Default size, in bytes, between hash-marks when transferring a binary file.
871If nil, this variable will be locally overridden if the FTP client outputs a
872suitable response to the HASH command. If non-nil, this value takes
873precedence over the local value."
874 :group 'ange-ftp
875 :type '(choice (const :tag "Overridden" nil)
876 integer))
877
878(defcustom ange-ftp-ascii-hash-mark-size 1024
879 "*Default size, in bytes, between hash-marks when transferring an ASCII file.
880This variable is buffer-local and will be locally overridden if the FTP client
881outputs a suitable response to the HASH command."
882 :group 'ange-ftp
883 :type 'integer)
884
885(defcustom ange-ftp-process-verbose t
886 "*If non-nil then be chatty about interaction with the FTP process."
887 :group 'ange-ftp
888 :type 'boolean)
889
890(defcustom ange-ftp-ftp-program-name "ftp"
891 "*Name of FTP program to run."
892 :group 'ange-ftp
893 :type 'string)
894
895(defcustom ange-ftp-gateway-ftp-program-name "ftp"
896 "*Name of FTP program to run when accessing non-local hosts.
897
898Some AT&T folks claim to use something called `pftp' here."
899 :group 'ange-ftp
900 :type 'string)
901
902(defcustom ange-ftp-ftp-program-args '("-i" "-n" "-g" "-v")
903 "*A list of arguments passed to the FTP program when started."
904 :group 'ange-ftp
905 :type '(repeat string))
906
907(defcustom ange-ftp-nslookup-program nil
908 "*If non-nil, this is a string naming the nslookup program."
909 :group 'ange-ftp
910 :type '(choice (const :tag "None" nil)
911 string))
912
913(defcustom ange-ftp-make-backup-files ()
914 "*Non-nil means make backup files for \"magic\" remote files."
915 :group 'ange-ftp
916 :type 'boolean)
917
918(defcustom ange-ftp-retry-time 5
919 "*Number of seconds to wait before retry if file or listing doesn't arrive.
920This might need to be increased for very slow connections."
921 :group 'ange-ftp
922 :type 'integer)
923
924(defcustom ange-ftp-auto-save 0
925 "If 1, allow ange-ftp files to be auto-saved.
926If 0, inhibit auto-saving of ange-ftp files.
927Don't use any other value."
928 :group 'ange-ftp
929 :type '(choice (const :tag "Suppress" 0)
930 (const :tag "Allow" 1)))
931
932(defcustom ange-ftp-try-passive-mode nil
933 "It t, try to use passive mode in ftp, if the client program
934supports the `passive' command."
935 :group 'ange-ftp
936 :type 'boolean
937 :version 21.1)
938
939
940;;;; ------------------------------------------------------------
941;;;; Hash table support.
942;;;; ------------------------------------------------------------
943
944(require 'backquote)
945
946(defun ange-ftp-make-hashtable (&optional size)
947 "Make an obarray suitable for use as a hashtable.
948SIZE, if supplied, should be a prime number."
949 (make-vector (or size 31) 0))
950
951(defun ange-ftp-map-hashtable (fun tbl)
952 "Call FUNCTION on each key and value in HASHTABLE."
953 (mapatoms
954 (function
955 (lambda (sym)
956 (funcall fun (get sym 'key) (get sym 'val))))
957 tbl))
958
959(defmacro ange-ftp-make-hash-key (key)
960 "Convert KEY into a suitable key for a hashtable."
961 (` (if (stringp (, key))
962 (, key)
963 (prin1-to-string (, key)))))
964
965(defun ange-ftp-get-hash-entry (key tbl)
966 "Return the value associated with KEY in HASHTABLE."
967 (let ((sym (intern-soft (ange-ftp-make-hash-key key) tbl)))
968 (and sym (get sym 'val))))
969
970(defun ange-ftp-put-hash-entry (key val tbl)
971 "Record an association between KEY and VALUE in HASHTABLE."
972 (let ((sym (intern (ange-ftp-make-hash-key key) tbl)))
973 (put sym 'val val)
974 (put sym 'key key)))
975
976(defun ange-ftp-del-hash-entry (key tbl)
977 "Copy all symbols except KEY in HASHTABLE and return modified hashtable."
978 (let* ((len (length tbl))
979 (new-tbl (ange-ftp-make-hashtable len))
980 (i (1- len)))
981 (ange-ftp-map-hashtable
982 (function
983 (lambda (k v)
984 (or (equal k key)
985 (ange-ftp-put-hash-entry k v new-tbl))))
986 tbl)
987 (while (>= i 0)
988 (aset tbl i (aref new-tbl i))
989 (setq i (1- i)))
990 tbl))
991
992(defun ange-ftp-hash-entry-exists-p (key tbl)
993 "Return whether there is an association for KEY in TABLE."
994 (intern-soft (ange-ftp-make-hash-key key) tbl))
995
996(defun ange-ftp-hash-table-keys (tbl)
997 "Return a sorted list of all the active keys in TABLE, as strings."
998 (sort (all-completions "" tbl)
999 (function string-lessp)))
1000
1001;;;; ------------------------------------------------------------
1002;;;; Internal variables.
1003;;;; ------------------------------------------------------------
1004
1005(defvar ange-ftp-data-buffer-name " *ftp data*"
1006 "Buffer name to hold directory listing data received from ftp process.")
1007
1008(defvar ange-ftp-netrc-modtime nil
1009 "Last modified time of the netrc file from file-attributes.")
1010
1011(defvar ange-ftp-user-hashtable (ange-ftp-make-hashtable)
1012 "Hash table holding associations between HOST, USER pairs.")
1013
1014(defvar ange-ftp-passwd-hashtable (ange-ftp-make-hashtable)
1015 "Mapping between a HOST, USER pair and a PASSWORD for them.
1016All HOST values should be in lower case.")
1017
1018(defvar ange-ftp-account-hashtable (ange-ftp-make-hashtable)
1019 "Mapping between a HOST, USER pair and a ACCOUNT password for them.")
1020
1021(defvar ange-ftp-files-hashtable (ange-ftp-make-hashtable 97)
1022 "Hash table for storing directories and their respective files.")
1023
1024(defvar ange-ftp-inodes-hashtable (ange-ftp-make-hashtable 97)
1025 "Hash table for storing file names and their \"inode numbers\".")
1026
1027(defvar ange-ftp-next-inode-number 1
1028 "Next \"inode number\" value. We give each file name a unique number.")
1029
1030(defvar ange-ftp-ls-cache-lsargs nil
1031 "Last set of args used by ange-ftp-ls.")
1032
1033(defvar ange-ftp-ls-cache-file nil
1034 "Last file passed to ange-ftp-ls.")
1035
1036(defvar ange-ftp-ls-cache-res nil
1037 "Last result returned from ange-ftp-ls.")
1038
1039(defconst ange-ftp-expand-dir-hashtable (ange-ftp-make-hashtable))
1040
1041(defconst ange-ftp-expand-dir-regexp "^5.0 \\([^: ]+\\):")
1042
1043;; These are local variables in each FTP process buffer.
1044(defvar ange-ftp-hash-mark-unit nil)
1045(defvar ange-ftp-hash-mark-count nil)
1046(defvar ange-ftp-xfer-size nil)
1047(defvar ange-ftp-process-string nil)
1048(defvar ange-ftp-process-result-line nil)
1049(defvar ange-ftp-process-busy nil)
1050(defvar ange-ftp-process-result nil)
1051(defvar ange-ftp-process-multi-skip nil)
1052(defvar ange-ftp-process-msg nil)
1053(defvar ange-ftp-process-continue nil)
1054(defvar ange-ftp-last-percent nil)
1055
1056;; These variables are bound by one function and examined by another.
1057;; Leave them void globally for error checking.
1058(defvar ange-ftp-this-file)
1059(defvar ange-ftp-this-dir)
1060(defvar ange-ftp-this-user)
1061(defvar ange-ftp-this-host)
1062(defvar ange-ftp-this-msg)
1063(defvar ange-ftp-completion-ignored-pattern)
1064(defvar ange-ftp-trample-marker)
1065
1066;; New error symbols.
1067(put 'ftp-error 'error-conditions '(ftp-error file-error error))
1068;; (put 'ftp-error 'error-message "FTP error")
1069
1070;;; ------------------------------------------------------------
1071;;; Enhanced message support.
1072;;; ------------------------------------------------------------
1073
1074(defun ange-ftp-message (fmt &rest args)
1075 "Display message in echo area, but indicate if truncated.
1076Args are as in `message': a format string, plus arguments to be formatted."
1077 (let ((msg (apply (function format) fmt args))
1078 (max (window-width (minibuffer-window))))
1079 (if noninteractive
1080 msg
1081 (if (>= (length msg) max)
1082 ;; Take just the last MAX - 3 chars of the string.
1083 (setq msg (concat "> " (substring msg (- 3 max)))))
1084 (message "%s" msg))))
1085
1086(defun ange-ftp-abbreviate-filename (file &optional new)
1087 "Abbreviate the file name FILE relative to the default-directory.
1088If the optional parameter NEW is given and the non-directory parts match,
1089only return the directory part of FILE."
1090 (save-match-data
1091 (if (and default-directory
1092 (string-match (concat "^"
1093 (regexp-quote default-directory)
1094 ".") file))
1095 (setq file (substring file (1- (match-end 0)))))
1096 (if (and new
1097 (string-equal (file-name-nondirectory file)
1098 (file-name-nondirectory new)))
1099 (setq file (file-name-directory file)))
1100 (or file "./")))
1101
1102;;;; ------------------------------------------------------------
1103;;;; User / Host mapping support.
1104;;;; ------------------------------------------------------------
1105
1106(defun ange-ftp-set-user (host user)
1107 "For a given HOST, set or change the default USER."
1108 (interactive "sHost: \nsUser: ")
1109 (ange-ftp-put-hash-entry host user ange-ftp-user-hashtable))
1110
1111(defun ange-ftp-get-user (host)
1112 "Given a HOST, return the default USER."
1113 (ange-ftp-parse-netrc)
1114 (let ((user (ange-ftp-get-hash-entry host ange-ftp-user-hashtable)))
1115 (or user
1116 (prog1
1117 (setq user
1118 (cond ((stringp ange-ftp-default-user)
1119 ;; We have a default name. Use it.
1120 ange-ftp-default-user)
1121 (ange-ftp-default-user
1122 ;; Ask the user.
1123 (let ((enable-recursive-minibuffers t))
1124 (read-string (format "User for %s: " host)
1125 (user-login-name))))
1126 (ange-ftp-netrc-default-user)
1127 ;; Default to the user's login name.
1128 (t
1129 (user-login-name))))
1130 (ange-ftp-set-user host user)))))
1131
1132;;;; ------------------------------------------------------------
1133;;;; Password support.
1134;;;; ------------------------------------------------------------
1135
1136(defmacro ange-ftp-generate-passwd-key (host user)
1137 (` (concat (downcase (, host)) "/" (, user))))
1138
1139(defmacro ange-ftp-lookup-passwd (host user)
1140 (` (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key (, host) (, user))
1141 ange-ftp-passwd-hashtable)))
1142
1143(defun ange-ftp-set-passwd (host user passwd)
1144 "For a given HOST and USER, set or change the associated PASSWORD."
1145 (interactive (list (read-string "Host: ")
1146 (read-string "User: ")
1147 (read-passwd "Password: ")))
1148 (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user)
1149 passwd
1150 ange-ftp-passwd-hashtable))
1151
1152(defun ange-ftp-get-host-with-passwd (user)
1153 "Given a USER, return a host we know the password for."
1154 (ange-ftp-parse-netrc)
1155 (catch 'found-one
1156 (ange-ftp-map-hashtable
1157 (function (lambda (host val)
1158 (if (ange-ftp-lookup-passwd host user)
1159 (throw 'found-one host))))
1160 ange-ftp-user-hashtable)
1161 (save-match-data
1162 (ange-ftp-map-hashtable
1163 (function
1164 (lambda (key value)
1165 (if (string-match "^[^/]*\\(/\\).*$" key)
1166 (let ((host (substring key 0 (match-beginning 1))))
1167 (if (and (string-equal user (substring key (match-end 1)))
1168 value)
1169 (throw 'found-one host))))))
1170 ange-ftp-passwd-hashtable))
1171 nil))
1172
1173(defun ange-ftp-get-passwd (host user)
1174 "Return the password for specified HOST and USER, asking user if necessary."
1175 (ange-ftp-parse-netrc)
1176
1177 ;; look up password in the hash table first; user might have overridden the
1178 ;; defaults.
1179 (cond ((ange-ftp-lookup-passwd host user))
1180
1181 ;; See if default user and password set.
1182 ((and (stringp ange-ftp-default-user)
1183 ange-ftp-default-password
1184 (string-equal user ange-ftp-default-user))
1185 ange-ftp-default-password)
1186
1187 ;; See if default user and password set from .netrc file.
1188 ((and (stringp ange-ftp-netrc-default-user)
1189 ange-ftp-netrc-default-password
1190 (string-equal user ange-ftp-netrc-default-user))
1191 ange-ftp-netrc-default-password)
1192
1193 ;; anonymous ftp password is handled specially since there is an
1194 ;; unwritten rule about how that is used on the Internet.
1195 ((and (or (string-equal user "anonymous")
1196 (string-equal user "ftp"))
1197 ange-ftp-generate-anonymous-password)
1198 (if (stringp ange-ftp-generate-anonymous-password)
1199 ange-ftp-generate-anonymous-password
1200 user-mail-address))
1201
1202 ;; see if same user has logged in to other hosts; if so then prompt
1203 ;; with the password that was used there.
1204 (t
1205 (let* ((other (ange-ftp-get-host-with-passwd user))
1206 (passwd (if other
1207
1208 ;; found another machine with the same user.
1209 ;; Try that account.
1210 (read-passwd
1211 (format "passwd for %s@%s (default same as %s@%s): "
1212 user host user other)
1213 nil
1214 (ange-ftp-lookup-passwd other user))
1215
1216 ;; I give up. Ask the user for the password.
1217 (read-passwd
1218 (format "Password for %s@%s: " user host)))))
1219 (ange-ftp-set-passwd host user passwd)
1220 passwd))))
1221
1222;;;; ------------------------------------------------------------
1223;;;; Account support
1224;;;; ------------------------------------------------------------
1225
1226;; Account passwords must be either specified in the .netrc file, or set
1227;; manually by calling ange-ftp-set-account. For the moment, ange-ftp doesn't
1228;; check to see whether the FTP process is actually prompting for an account
1229;; password.
1230
1231(defun ange-ftp-set-account (host user account)
1232 "For a given HOST and USER, set or change the associated ACCOUNT password."
1233 (interactive (list (read-string "Host: ")
1234 (read-string "User: ")
1235 (read-passwd "Account password: ")))
1236 (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user)
1237 account
1238 ange-ftp-account-hashtable))
1239
1240(defun ange-ftp-get-account (host user)
1241 "Given a HOST and USER, return the FTP account."
1242 (ange-ftp-parse-netrc)
1243 (or (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key host user)
1244 ange-ftp-account-hashtable)
1245 (and (stringp ange-ftp-default-user)
1246 (string-equal user ange-ftp-default-user)
1247 ange-ftp-default-account)
1248 (and (stringp ange-ftp-netrc-default-user)
1249 (string-equal user ange-ftp-netrc-default-user)
1250 ange-ftp-netrc-default-account)))
1251
1252;;;; ------------------------------------------------------------
1253;;;; ~/.netrc support
1254;;;; ------------------------------------------------------------
1255
1256(defun ange-ftp-chase-symlinks (file)
1257 "Return the filename that FILE references, following all symbolic links."
1258 (let (temp)
1259 (while (setq temp (ange-ftp-real-file-symlink-p file))
1260 (setq file
1261 (if (file-name-absolute-p temp)
1262 temp
1263 (concat (file-name-directory file) temp)))))
1264 file)
1265
1266;; Move along current line looking for the value of the TOKEN.
1267;; Valid separators between TOKEN and its value are commas and
1268;; whitespace. Second arg LIMIT is a limit for the search.
1269
1270(defun ange-ftp-parse-netrc-token (token limit)
1271 (if (search-forward token limit t)
1272 (let (beg)
1273 (skip-chars-forward ", \t\r\n" limit)
1274 (if (eq (following-char) ?\") ;quoted token value
1275 (progn (forward-char 1)
1276 (setq beg (point))
1277 (skip-chars-forward "^\"" limit)
1278 (forward-char 1)
1279 (buffer-substring beg (1- (point))))
1280 (setq beg (point))
1281 (skip-chars-forward "^, \t\r\n" limit)
1282 (buffer-substring beg (point))))))
1283
1284;; Extract the values for the tokens `machine', `login',
1285;; `password' and `account' in the current buffer. If successful,
1286;; record the information found.
1287
1288(defun ange-ftp-parse-netrc-group ()
1289 (let ((start (point))
1290 (end (save-excursion
1291 (if (looking-at "machine\\>")
1292 ;; Skip `machine' and the machine name that follows.
1293 (progn
1294 (skip-chars-forward "^ \t\r\n")
1295 (skip-chars-forward " \t\r\n")
1296 (skip-chars-forward "^ \t\r\n"))
1297 ;; Skip `default'.
1298 (skip-chars-forward "^ \t\r\n"))
1299 ;; Find start of the next `machine' or `default'
1300 ;; or the end of the buffer.
1301 (if (re-search-forward "machine\\>\\|default\\>" nil t)
1302 (match-beginning 0)
1303 (point-max))))
1304 machine login password account)
1305 (setq machine (ange-ftp-parse-netrc-token "machine" end)
1306 login (ange-ftp-parse-netrc-token "login" end)
1307 password (ange-ftp-parse-netrc-token "password" end)
1308 account (ange-ftp-parse-netrc-token "account" end))
1309 (if (and machine login)
1310 ;; found a `machine` token.
1311 (progn
1312 (ange-ftp-set-user machine login)
1313 (ange-ftp-set-passwd machine login password)
1314 (and account
1315 (ange-ftp-set-account machine login account)))
1316 (goto-char start)
1317 (if (search-forward "default" end t)
1318 ;; found a `default' token
1319 (progn
1320 (setq login (ange-ftp-parse-netrc-token "login" end)
1321 password (ange-ftp-parse-netrc-token "password" end)
1322 account (ange-ftp-parse-netrc-token "account" end))
1323 (and login
1324 (setq ange-ftp-netrc-default-user login))
1325 (and password
1326 (setq ange-ftp-netrc-default-password password))
1327 (and account
1328 (setq ange-ftp-netrc-default-account account)))))
1329 (goto-char end)))
1330
1331;; Read in ~/.netrc, if one exists. If ~/.netrc file exists and has
1332;; the correct permissions then extract the \`machine\', \`login\',
1333;; \`password\' and \`account\' information from within.
1334
1335(defun ange-ftp-parse-netrc ()
1336 ;; We set this before actually doing it to avoid the possibility
1337 ;; of an infinite loop if ange-ftp-netrc-filename is an FTP file.
1338 (interactive)
1339 (let (file attr)
1340 (let ((default-directory "/"))
1341 (setq file (ange-ftp-chase-symlinks
1342 (ange-ftp-real-expand-file-name ange-ftp-netrc-filename)))
1343 (setq attr (ange-ftp-real-file-attributes file)))
1344 (if (and attr ; file exists.
1345 (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed
1346 (save-match-data
1347 (if (or ange-ftp-disable-netrc-security-check
1348 (and (eq (nth 2 attr) (user-uid)) ; Same uids.
1349 (string-match ".r..------" (nth 8 attr))))
1350 (save-excursion
1351 ;; we are cheating a bit here. I'm trying to do the equivalent
1352 ;; of find-file on the .netrc file, but then nuke it afterwards.
1353 ;; with the bit of logic below we should be able to have
1354 ;; encrypted .netrc files.
1355 (set-buffer (generate-new-buffer "*ftp-.netrc*"))
1356 (ange-ftp-real-insert-file-contents file)
1357 (setq buffer-file-name file)
1358 (setq default-directory (file-name-directory file))
1359 (normal-mode t)
1360 (mapcar 'funcall find-file-hooks)
1361 (setq buffer-file-name nil)
1362 (goto-char (point-min))
1363 (skip-chars-forward " \t\r\n")
1364 (while (not (eobp))
1365 (ange-ftp-parse-netrc-group))
1366 (kill-buffer (current-buffer)))
1367 (ange-ftp-message "%s either not owned by you or badly protected."
1368 ange-ftp-netrc-filename)
1369 (sit-for 1))
1370 (setq ange-ftp-netrc-modtime (nth 5 attr))))))
1371
1372;; Return a list of prefixes of the form 'user@host:' to be used when
1373;; completion is done in the root directory.
1374
1375(defun ange-ftp-generate-root-prefixes ()
1376 (ange-ftp-parse-netrc)
1377 (save-match-data
1378 (let (res)
1379 (ange-ftp-map-hashtable
1380 (function
1381 (lambda (key value)
1382 (if (string-match "^[^/]*\\(/\\).*$" key)
1383 (let ((host (substring key 0 (match-beginning 1)))
1384 (user (substring key (match-end 1))))
1385 (setq res (cons (list (concat user "@" host ":"))
1386 res))))))
1387 ange-ftp-passwd-hashtable)
1388 (ange-ftp-map-hashtable
1389 (function (lambda (host user)
1390 (setq res (cons (list (concat host ":"))
1391 res))))
1392 ange-ftp-user-hashtable)
1393 (or res (list nil)))))
1394
1395;;;; ------------------------------------------------------------
1396;;;; Remote file name syntax support.
1397;;;; ------------------------------------------------------------
1398
1399(defmacro ange-ftp-ftp-name-component (n ns name)
1400 "Extract the Nth ftp file name component from NS."
1401 (` (let ((elt (nth (, n) (, ns))))
1402 (if (match-beginning elt)
1403 (substring (, name) (match-beginning elt) (match-end elt))))))
1404
1405(defvar ange-ftp-ftp-name-arg "")
1406(defvar ange-ftp-ftp-name-res nil)
1407
1408;; Parse NAME according to `ange-ftp-name-format' (which see).
1409;; Returns a list (HOST USER NAME), or nil if NAME does not match the format.
1410(defun ange-ftp-ftp-name (name)
1411 (if (string-equal name ange-ftp-ftp-name-arg)
1412 ange-ftp-ftp-name-res
1413 (setq ange-ftp-ftp-name-arg name
1414 ange-ftp-ftp-name-res
1415 (save-match-data
1416 (if (posix-string-match (car ange-ftp-name-format) name)
1417 (let* ((ns (cdr ange-ftp-name-format))
1418 (host (ange-ftp-ftp-name-component 0 ns name))
1419 (user (ange-ftp-ftp-name-component 1 ns name))
1420 (name (ange-ftp-ftp-name-component 2 ns name)))
1421 (if (zerop (length user))
1422 (setq user (ange-ftp-get-user host)))
1423 (list host user name))
1424 nil)))))
1425
1426;; Take a FULLNAME that matches according to ange-ftp-name-format and
1427;; replace the name component with NAME.
1428(defun ange-ftp-replace-name-component (fullname name)
1429 (save-match-data
1430 (if (posix-string-match (car ange-ftp-name-format) fullname)
1431 (let* ((ns (cdr ange-ftp-name-format))
1432 (elt (nth 2 ns)))
1433 (concat (substring fullname 0 (match-beginning elt))
1434 name
1435 (substring fullname (match-end elt)))))))
1436
1437;;;; ------------------------------------------------------------
1438;;;; Miscellaneous utils.
1439;;;; ------------------------------------------------------------
1440
1441;; (setq ange-ftp-tmp-keymap (make-sparse-keymap))
1442;; (define-key ange-ftp-tmp-keymap "\C-m" 'exit-minibuffer)
1443
1444(defun ange-ftp-repaint-minibuffer ()
1445 "Clear any existing minibuffer message; let the minibuffer contents show."
1446 (message nil))
1447
1448;; Return the name of the buffer that collects output from the ftp process
1449;; connected to the given HOST and USER pair.
1450(defun ange-ftp-ftp-process-buffer (host user)
1451 (concat "*ftp " user "@" host "*"))
1452
1453;; Display the last chunk of output from the ftp process for the given HOST
1454;; USER pair, and signal an error including MSG in the text.
1455(defun ange-ftp-error (host user msg)
1456 (let ((cur (selected-window))
1457 (pop-up-windows t))
1458 (pop-to-buffer
1459 (get-buffer-create
1460 (ange-ftp-ftp-process-buffer host user)))
1461 (goto-char (point-max))
1462 (select-window cur))
1463 (signal 'ftp-error (list (format "FTP Error: %s" msg))))
1464
1465(defun ange-ftp-set-buffer-mode ()
1466 "Set correct modes for the current buffer if visiting a remote file."
1467 (if (and (stringp buffer-file-name)
1468 (ange-ftp-ftp-name buffer-file-name))
1469 (auto-save-mode ange-ftp-auto-save)))
1470
1471(defun ange-ftp-kill-ftp-process (&optional buffer)
1472 "Kill the FTP process associated with BUFFER (the current buffer, if nil).
1473If the BUFFER's visited filename or default-directory is an ftp filename
1474then kill the related ftp process."
1475 (interactive "bKill FTP process associated with buffer: ")
1476 (if (null buffer)
1477 (setq buffer (current-buffer))
1478 (setq buffer (get-buffer buffer)))
1479 (let ((file (or (buffer-file-name buffer)
1480 (save-excursion (set-buffer buffer) default-directory))))
1481 (if file
1482 (let ((parsed (ange-ftp-ftp-name (expand-file-name file))))
1483 (if parsed
1484 (let ((host (nth 0 parsed))
1485 (user (nth 1 parsed)))
1486 (kill-buffer (get-buffer (ange-ftp-ftp-process-buffer host user)))))))))
1487
1488(defun ange-ftp-quote-string (string)
1489 "Quote any characters in STRING that may confuse the ftp process."
1490 (apply (function concat)
1491 (mapcar (function
1492 ;; This is said to be wrong; ftp is said to
1493 ;; need quoting only for ", and that by doubling it.
1494 ;; But experiment says this kind of quoting is correct
1495 ;; when talking to ftp on GNU/Linux systems.
1496 (lambda (char)
1497 (if (or (<= char ? )
1498 (> char ?\~)
1499 (= char ?\")
1500 (= char ?\\))
1501 (vector ?\\ char)
1502 (vector char))))
1503 string)))
1504
1505(defun ange-ftp-barf-if-not-directory (directory)
1506 (or (file-directory-p directory)
1507 (signal 'file-error
1508 (list "Opening directory"
1509 (if (file-exists-p directory)
1510 "not a directory"
1511 "no such file or directory")
1512 directory))))
1513
1514;;;; ------------------------------------------------------------
1515;;;; FTP process filter support.
1516;;;; ------------------------------------------------------------
1517
1518(defun ange-ftp-process-handle-line (line proc)
1519 "Look at the given LINE from the ftp process PROC.
1520Try to categorize it into one of four categories:
1521good, skip, fatal, or unknown."
1522 (cond ((string-match ange-ftp-xfer-size-msgs line)
1523 (setq ange-ftp-xfer-size
1524 (ash (string-to-int (substring line
1525 (match-beginning 1)
1526 (match-end 1)))
1527 -10)))
1528 ((string-match ange-ftp-skip-msgs line)
1529 t)
1530 ((string-match ange-ftp-good-msgs line)
1531 (setq ange-ftp-process-busy nil
1532 ange-ftp-process-result t
1533 ange-ftp-process-result-line line))
1534 ;; Check this before checking for errors.
1535 ;; Otherwise the last line of these three seems to be an error:
1536 ;; 230-see a significant impact from the move. For those of you who can't
1537 ;; 230-use DNS to resolve hostnames and get an error message like
1538 ;; 230-"ftp.stsci.edu: unknown host", the new IP address will be...
1539 ((string-match ange-ftp-multi-msgs line)
1540 (setq ange-ftp-process-multi-skip t))
1541 ((string-match ange-ftp-fatal-msgs line)
1542 (delete-process proc)
1543 (setq ange-ftp-process-busy nil
1544 ange-ftp-process-result-line line))
1545 (ange-ftp-process-multi-skip
1546 t)
1547 (t
1548 (setq ange-ftp-process-busy nil
1549 ange-ftp-process-result-line line))))
1550
1551(defun ange-ftp-set-xfer-size (host user bytes)
1552 "Set the size of the next FTP transfer in bytes."
1553 (let ((proc (ange-ftp-get-process host user)))
1554 (if proc
1555 (let ((buf (process-buffer proc)))
1556 (if buf
1557 (save-excursion
1558 (set-buffer buf)
1559 (setq ange-ftp-xfer-size (ash bytes -10))))))))
1560
1561(defun ange-ftp-process-handle-hash (str)
1562 "Remove hash marks from STRING and display count so far."
1563 (setq str (concat (substring str 0 (match-beginning 0))
1564 (substring str (match-end 0)))
1565 ange-ftp-hash-mark-count (+ (- (match-end 0)
1566 (match-beginning 0))
1567 ange-ftp-hash-mark-count))
1568 (and ange-ftp-hash-mark-unit
1569 ange-ftp-process-msg
1570 ange-ftp-process-verbose
1571 (not (eq (selected-window) (minibuffer-window)))
1572 (not (boundp 'search-message)) ;screws up isearch otherwise
1573 (not cursor-in-echo-area) ;screws up y-or-n-p otherwise
1574 (let ((kbytes (ash (* ange-ftp-hash-mark-unit
1575 ange-ftp-hash-mark-count)
1576 -6)))
1577 (if (zerop ange-ftp-xfer-size)
1578 (ange-ftp-message "%s...%dk" ange-ftp-process-msg kbytes)
1579 (let ((percent (/ (* 100 kbytes) ange-ftp-xfer-size)))
1580 ;; cut out the redisplay of identical %-age messages.
1581 (if (not (eq percent ange-ftp-last-percent))
1582 (progn
1583 (setq ange-ftp-last-percent percent)
1584 (ange-ftp-message "%s...%d%%" ange-ftp-process-msg percent)))))))
1585 str)
1586
1587;; Call the function specified by CONT. CONT can be either a function
1588;; or a list of a function and some args. The first two parameters
1589;; passed to the function will be RESULT and LINE. The remaining args
1590;; will be taken from CONT if a list was passed.
1591
1592(defun ange-ftp-call-cont (cont result line)
1593 (if cont
1594 (if (and (listp cont)
1595 (not (eq (car cont) 'lambda)))
1596 (apply (car cont) result line (cdr cont))
1597 (funcall cont result line))))
1598
1599;; Build up a complete line of output from the ftp PROCESS and pass it
1600;; on to ange-ftp-process-handle-line to deal with.
1601
1602(defun ange-ftp-process-filter (proc str)
1603 (let ((buffer (process-buffer proc))
1604 (old-buffer (current-buffer)))
1605
1606 ;; Eliminate nulls.
1607 (while (string-match "\000+" str)
1608 (setq str (replace-match "" nil nil str)))
1609
1610 ;; see if the buffer is still around... it could have been deleted.
1611 (if (buffer-name buffer)
1612 (unwind-protect
1613 (progn
1614 (set-buffer (process-buffer proc))
1615
1616 ;; handle hash mark printing
1617 (and ange-ftp-process-busy
1618 (string-match "^#+$" str)
1619 (setq str (ange-ftp-process-handle-hash str)))
1620 (comint-output-filter proc str)
1621 ;; Replace STR by the result of the comint processing.
1622 (setq str (buffer-substring comint-last-output-start
1623 (process-mark proc)))
1624 (if ange-ftp-process-busy
1625 (progn
1626 (setq ange-ftp-process-string (concat ange-ftp-process-string
1627 str))
1628
1629 ;; if we gave an empty password to the USER command earlier
1630 ;; then we should send a null password now.
1631 (if (string-match "Password: *$" ange-ftp-process-string)
1632 (send-string proc "\n"))))
1633 (while (and ange-ftp-process-busy
1634 (string-match "\n" ange-ftp-process-string))
1635 (let ((line (substring ange-ftp-process-string
1636 0
1637 (match-beginning 0))))
1638 (setq ange-ftp-process-string (substring ange-ftp-process-string
1639 (match-end 0)))
1640 (while (string-match "^ftp> *" line)
1641 (setq line (substring line (match-end 0))))
1642 (ange-ftp-process-handle-line line proc)))
1643
1644 ;; has the ftp client finished? if so then do some clean-up
1645 ;; actions.
1646 (if (not ange-ftp-process-busy)
1647 (progn
1648 ;; reset the xfer size
1649 (setq ange-ftp-xfer-size 0)
1650
1651 ;; issue the "done" message since we've finished.
1652 (if (and ange-ftp-process-msg
1653 ange-ftp-process-verbose
1654 ange-ftp-process-result)
1655 (progn
1656 (ange-ftp-message "%s...done" ange-ftp-process-msg)
1657 (ange-ftp-repaint-minibuffer)
1658 (setq ange-ftp-process-msg nil)))
1659
1660 ;; is there a continuation we should be calling? if so,
1661 ;; we'd better call it, making sure we only call it once.
1662 (if ange-ftp-process-continue
1663 (let ((cont ange-ftp-process-continue))
1664 (setq ange-ftp-process-continue nil)
1665 (ange-ftp-call-cont cont
1666 ange-ftp-process-result
1667 ange-ftp-process-result-line))))))
1668 (set-buffer old-buffer)))))
1669
1670(defun ange-ftp-process-sentinel (proc str)
1671 "When ftp process changes state, nuke all file-entries in cache."
1672 (let ((name (process-name proc)))
1673 (if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name)
1674 (let ((user (substring name (match-beginning 1) (match-end 1)))
1675 (host (substring name (match-beginning 2) (match-end 2))))
1676 (ange-ftp-wipe-file-entries host user))))
1677 (setq ange-ftp-ls-cache-file nil))
1678
1679;;;; ------------------------------------------------------------
1680;;;; Gateway support.
1681;;;; ------------------------------------------------------------
1682
1683(defun ange-ftp-use-gateway-p (host)
1684 "Returns whether to access this host via a normal (non-smart) gateway."
1685 ;; yes, I know that I could simplify the following expression, but it is
1686 ;; clearer (to me at least) this way.
1687 (and (not ange-ftp-smart-gateway)
1688 (save-match-data
1689 (not (string-match ange-ftp-local-host-regexp host)))))
1690
1691(defun ange-ftp-use-smart-gateway-p (host)
1692 "Returns whether to access this host via a smart gateway."
1693 (and ange-ftp-smart-gateway
1694 (save-match-data
1695 (not (string-match ange-ftp-local-host-regexp host)))))
1696
1697
1698;;; ------------------------------------------------------------
1699;;; Temporary file location and deletion...
1700;;; ------------------------------------------------------------
1701
1702(defun ange-ftp-make-tmp-name (host)
1703 "This routine will return the name of a new file."
1704 (make-temp-file (if (ange-ftp-use-gateway-p host)
1705 ange-ftp-gateway-tmp-name-template
1706 ange-ftp-tmp-name-template)))
1707
1708(defalias 'ange-ftp-del-tmp-name 'delete-file)
1709
1710;;;; ------------------------------------------------------------
1711;;;; Interactive gateway program support.
1712;;;; ------------------------------------------------------------
1713
1714(defvar ange-ftp-gwp-running t)
1715(defvar ange-ftp-gwp-status nil)
1716
1717(defun ange-ftp-gwp-sentinel (proc str)
1718 (setq ange-ftp-gwp-running nil))
1719
1720(defun ange-ftp-gwp-filter (proc str)
1721 (comint-output-filter proc str)
1722 (save-excursion
1723 (set-buffer (process-buffer proc))
1724 ;; Replace STR by the result of the comint processing.
1725 (setq str (buffer-substring comint-last-output-start (process-mark proc))))
1726 (cond ((string-match "login: *$" str)
1727 (send-string proc
1728 (concat
1729 (let ((ange-ftp-default-user t))
1730 (ange-ftp-get-user ange-ftp-gateway-host))
1731 "\n")))
1732 ((string-match "Password: *$" str)
1733 (send-string proc
1734 (concat
1735 (ange-ftp-get-passwd ange-ftp-gateway-host
1736 (ange-ftp-get-user
1737 ange-ftp-gateway-host))
1738 "\n")))
1739 ((string-match ange-ftp-gateway-fatal-msgs str)
1740 (delete-process proc)
1741 (setq ange-ftp-gwp-running nil))
1742 ((string-match ange-ftp-gateway-prompt-pattern str)
1743 (setq ange-ftp-gwp-running nil
1744 ange-ftp-gwp-status t))))
1745
1746(defun ange-ftp-gwp-start (host user name args)
1747 "Login to the gateway machine and fire up an ftp process."
1748 (let* ((gw-user (ange-ftp-get-user ange-ftp-gateway-host))
1749 ;; It would be nice to make process-connection-type nil,
1750 ;; but that doesn't work: ftp never responds.
1751 ;; Can anyone find a fix for that?
1752 (proc (let ((process-connection-type t))
1753 (start-process name name
1754 ange-ftp-gateway-program
1755 ange-ftp-gateway-host)))
1756 (ftp (mapconcat (function identity) args " ")))
1757 (process-kill-without-query proc)
1758 (set-process-sentinel proc (function ange-ftp-gwp-sentinel))
1759 (set-process-filter proc (function ange-ftp-gwp-filter))
1760 (save-excursion
1761 (set-buffer (process-buffer proc))
1762 (goto-char (point-max))
1763 (set-marker (process-mark proc) (point)))
1764 (setq ange-ftp-gwp-running t
1765 ange-ftp-gwp-status nil)
1766 (ange-ftp-message "Connecting to gateway %s..." ange-ftp-gateway-host)
1767 (while ange-ftp-gwp-running ;perform login sequence
1768 (accept-process-output proc))
1769 (if (not ange-ftp-gwp-status)
1770 (ange-ftp-error host user "unable to login to gateway"))
1771 (ange-ftp-message "Connecting to gateway %s...done" ange-ftp-gateway-host)
1772 (setq ange-ftp-gwp-running t
1773 ange-ftp-gwp-status nil)
1774 (process-send-string proc ange-ftp-gateway-setup-term-command)
1775 (while ange-ftp-gwp-running ;zap ^M's and double echoing.
1776 (accept-process-output proc))
1777 (if (not ange-ftp-gwp-status)
1778 (ange-ftp-error host user "unable to set terminal modes on gateway"))
1779 (setq ange-ftp-gwp-running t
1780 ange-ftp-gwp-status nil)
1781 (process-send-string proc (concat "exec " ftp "\n")) ;spawn ftp process
1782 proc))
1783
1784;;;; ------------------------------------------------------------
1785;;;; Support for sending commands to the ftp process.
1786;;;; ------------------------------------------------------------
1787
1788(defun ange-ftp-raw-send-cmd (proc cmd &optional msg cont nowait)
1789 "Low-level routine to send the given ftp CMD to the ftp PROCESS.
1790MSG is an optional message to output before and after the command.
1791If CONT is non-nil then it is either a function or a list of function and
1792some arguments. The function will be called when the ftp command has completed.
1793If CONT is nil then this routine will return \( RESULT . LINE \) where RESULT
1794is whether the command was successful, and LINE is the line from the FTP
1795process that caused the command to complete.
1796If NOWAIT is given then the routine will return immediately the command has
1797been queued with no result. CONT will still be called, however."
1798 (if (memq (process-status proc) '(run open))
1799 (save-excursion
1800 (set-buffer (process-buffer proc))
1801 (ange-ftp-wait-not-busy proc)
1802 (setq ange-ftp-process-string ""
1803 ange-ftp-process-result-line ""
1804 ange-ftp-process-busy t
1805 ange-ftp-process-result nil
1806 ange-ftp-process-multi-skip nil
1807 ange-ftp-process-msg msg
1808 ange-ftp-process-continue cont
1809 ange-ftp-hash-mark-count 0
1810 ange-ftp-last-percent -1
1811 cmd (concat cmd "\n"))
1812 (and msg ange-ftp-process-verbose (ange-ftp-message "%s..." msg))
1813 (goto-char (point-max))
1814 (move-marker comint-last-input-start (point))
1815 ;; don't insert the password into the buffer on the USER command.
1816 (save-match-data
1817 (if (string-match "^user \"[^\"]*\"" cmd)
1818 (insert (substring cmd 0 (match-end 0)) " Turtle Power!\n")
1819 (insert cmd)))
1820 (move-marker comint-last-input-end (point))
1821 (send-string proc cmd)
1822 (set-marker (process-mark proc) (point))
1823 (if nowait
1824 nil
1825 (ange-ftp-wait-not-busy proc)
1826 (if cont
1827 nil ;cont has already been called
1828 (cons ange-ftp-process-result ange-ftp-process-result-line))))))
1829
1830;; Wait for the ange-ftp process PROC not to be busy.
1831(defun ange-ftp-wait-not-busy (proc)
1832 (save-excursion
1833 (set-buffer (process-buffer proc))
1834 (condition-case nil
1835 ;; This is a kludge to let user quit in case ftp gets hung.
1836 ;; It matters because this function can be called from the filter.
1837 ;; It is bad to allow quitting in a filter, but getting hung
1838 ;; is worse. By binding quit-flag to nil, we might avoid
1839 ;; most of the probability of getting screwed because the user
1840 ;; wants to quit some command.
1841 (let ((quit-flag nil)
1842 (inhibit-quit nil))
1843 (while ange-ftp-process-busy
1844 (accept-process-output proc)))
1845 (quit
1846 ;; If the user does quit out of this,
1847 ;; kill the process. That stops any transfer in progress.
1848 ;; The next operation will open a new ftp connection.
1849 (delete-process proc)
1850 (signal 'quit nil)))))
1851
1852(defun ange-ftp-nslookup-host (host)
1853 "Attempt to resolve the given HOSTNAME using nslookup if possible."
1854 (interactive "sHost: ")
1855 (if ange-ftp-nslookup-program
1856 (let ((default-directory
1857 (if (file-accessible-directory-p default-directory)
1858 default-directory
1859 exec-directory))
1860 ;; It would be nice to make process-connection-type nil,
1861 ;; but that doesn't work: ftp never responds.
1862 ;; Can anyone find a fix for that?
1863 (proc (let ((process-connection-type t))
1864 (start-process " *nslookup*" " *nslookup*"
1865 ange-ftp-nslookup-program host)))
1866 (res host))
1867 (process-kill-without-query proc)
1868 (save-excursion
1869 (set-buffer (process-buffer proc))
1870 (while (memq (process-status proc) '(run open))
1871 (accept-process-output proc))
1872 (goto-char (point-min))
1873 (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
1874 (setq res (buffer-substring (match-beginning 1)
1875 (match-end 1))))
1876 (kill-buffer (current-buffer)))
1877 res)
1878 host))
1879
1880(defun ange-ftp-start-process (host user name)
1881 "Spawn a new ftp process ready to connect to machine HOST and give it NAME.
1882If HOST is only ftp-able through a gateway machine then spawn a shell
1883on the gateway machine to do the ftp instead."
1884 (let* ((use-gateway (ange-ftp-use-gateway-p host))
1885 (use-smart-ftp (and (not ange-ftp-gateway-host)
1886 (ange-ftp-use-smart-gateway-p host)))
1887 (ftp-prog (if (or use-gateway
1888 use-smart-ftp)
1889 ange-ftp-gateway-ftp-program-name
1890 ange-ftp-ftp-program-name))
1891 (args (append (list ftp-prog) ange-ftp-ftp-program-args))
1892 ;; Without the following binding, ange-ftp-start-process
1893 ;; recurses on file-accessible-directory-p, since it needs to
1894 ;; restart its process in order to determine anything about
1895 ;; default-directory.
1896 (file-name-handler-alist)
1897 (default-directory
1898 (if (file-accessible-directory-p default-directory)
1899 default-directory
1900 exec-directory))
1901 proc)
1902 ;; It would be nice to make process-connection-type nil,
1903 ;; but that doesn't work: ftp never responds.
1904 ;; Can anyone find a fix for that?
1905 (let ((process-connection-type t)
1906 (process-environment process-environment)
1907 (buffer (get-buffer-create name)))
1908 (save-excursion
1909 (set-buffer buffer)
1910 (internal-ange-ftp-mode))
1911 ;; This tells GNU ftp not to output any fancy escape sequences.
1912 (setenv "TERM" "dumb")
1913 (if use-gateway
1914 (if ange-ftp-gateway-program-interactive
1915 (setq proc (ange-ftp-gwp-start host user name args))
1916 (setq proc (apply 'start-process name name
1917 (append (list ange-ftp-gateway-program
1918 ange-ftp-gateway-host)
1919 args))))
1920 (setq proc (apply 'start-process name name args))))
1921 (save-excursion
1922 (set-buffer (process-buffer proc))
1923 (goto-char (point-max))
1924 (set-marker (process-mark proc) (point)))
1925 (process-kill-without-query proc)
1926 (set-process-sentinel proc (function ange-ftp-process-sentinel))
1927 (set-process-filter proc (function ange-ftp-process-filter))
1928 ;; On Windows, the standard ftp client buffers its output (because
1929 ;; stdout is a pipe handle) so the startup message may never appear:
1930 ;; `accept-process-output' at this point would hang indefinitely.
1931 ;; However, sending an innocuous command ("help foo") forces some
1932 ;; output that will be ignored, which is just as good. Once we
1933 ;; start sending normal commands, the output no longer appears to be
1934 ;; buffered, and everything works correctly. My guess is that the
1935 ;; output of interest is being sent to stderr which is not buffered.
1936 (when (eq system-type 'windows-nt)
1937 ;; force ftp output to be treated as DOS text, otherwise the
1938 ;; output of "help foo" confuses the EOL detection logic.
1939 (set-process-coding-system proc 'raw-text-dos)
1940 (process-send-string proc "help foo\n"))
1941 (accept-process-output proc) ;wait for ftp startup message
1942 proc))
1943
1944(put 'internal-ange-ftp-mode 'mode-class 'special)
1945
1946(defun internal-ange-ftp-mode ()
1947 "Major mode for interacting with the FTP process.
1948
1949\\{comint-mode-map}"
1950 (interactive)
1951 (comint-mode)
1952 (setq major-mode 'internal-ange-ftp-mode)
1953 (setq mode-name "Internal Ange-ftp")
1954 (let ((proc (get-buffer-process (current-buffer))))
1955 (make-local-variable 'ange-ftp-process-string)
1956 (setq ange-ftp-process-string "")
1957 (make-local-variable 'ange-ftp-process-busy)
1958 (make-local-variable 'ange-ftp-process-result)
1959 (make-local-variable 'ange-ftp-process-msg)
1960 (make-local-variable 'ange-ftp-process-multi-skip)
1961 (make-local-variable 'ange-ftp-process-result-line)
1962 (make-local-variable 'ange-ftp-process-continue)
1963 (make-local-variable 'ange-ftp-hash-mark-count)
1964 (make-local-variable 'ange-ftp-binary-hash-mark-size)
1965 (make-local-variable 'ange-ftp-ascii-hash-mark-size)
1966 (make-local-variable 'ange-ftp-hash-mark-unit)
1967 (make-local-variable 'ange-ftp-xfer-size)
1968 (make-local-variable 'ange-ftp-last-percent)
1969 (setq ange-ftp-hash-mark-count 0)
1970 (setq ange-ftp-xfer-size 0)
1971 (setq ange-ftp-process-result-line "")
1972
1973 (setq comint-prompt-regexp "^ftp> ")
1974 (make-local-variable 'comint-password-prompt-regexp)
1975 ;; This is a regexp that can't match anything.
1976 ;; ange-ftp has its own ways of handling passwords.
1977 (setq comint-password-prompt-regexp "^a\\'z")
1978 (make-local-variable 'paragraph-start)
1979 (setq paragraph-start comint-prompt-regexp)))
1980
1981(defun ange-ftp-smart-login (host user pass account proc)
1982 "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT.
1983PROC is the FTP-client's process. This routine uses the smart-gateway
1984host specified in ``ange-ftp-gateway-host''."
1985 (let ((result (ange-ftp-raw-send-cmd
1986 proc
1987 (format "open %s %s"
1988 (ange-ftp-nslookup-host ange-ftp-gateway-host)
1989 ange-ftp-smart-gateway-port)
1990 (format "Opening FTP connection to %s via %s"
1991 host
1992 ange-ftp-gateway-host))))
1993 (or (car result)
1994 (ange-ftp-error host user
1995 (concat "OPEN request failed: "
1996 (cdr result))))
1997 (setq result (ange-ftp-raw-send-cmd
1998 proc (format "user \"%s\"@%s %s %s"
1999 user
2000 (ange-ftp-nslookup-host host)
2001 pass
2002 account)
2003 (format "Logging in as user %s@%s"
2004 user host)))
2005 (or (car result)
2006 (progn
2007 (ange-ftp-set-passwd host user nil) ; reset password
2008 (ange-ftp-set-account host user nil) ; reset account
2009 (ange-ftp-error host user
2010 (concat "USER request failed: "
2011 (cdr result)))))))
2012
2013(defun ange-ftp-normal-login (host user pass account proc)
2014 "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT.
2015PROC is the process to the FTP-client. HOST may have an optional
2016suffix of the form #PORT to specify a non-default port"
2017 (save-match-data
2018 (string-match "^\\([^#]+\\)\\(#\\([0-9]+\\)\\)?\\'" host)
2019 (let* ((nshost (ange-ftp-nslookup-host (match-string 1 host)))
2020 (port (match-string 3 host))
2021 (result (ange-ftp-raw-send-cmd
2022 proc
2023 (if port
2024 (format "open %s %s" nshost port)
2025 (format "open %s" nshost))
2026 (format "Opening FTP connection to %s" host))))
2027 (or (car result)
2028 (ange-ftp-error host user
2029 (concat "OPEN request failed: "
2030 (cdr result))))
2031 (setq result (ange-ftp-raw-send-cmd
2032 proc
2033 (if (and (ange-ftp-use-smart-gateway-p host)
2034 ange-ftp-gateway-host)
2035 (format "user \"%s\"@%s %s %s" user nshost pass account)
2036 (format "user \"%s\" %s %s" user pass account))
2037 (format "Logging in as user %s@%s" user host)))
2038 (or (car result)
2039 (progn
2040 (ange-ftp-set-passwd host user nil) ;reset password.
2041 (ange-ftp-set-account host user nil) ;reset account.
2042 (ange-ftp-error host user
2043 (concat "USER request failed: "
2044 (cdr result))))))))
2045
2046;; ange@hplb.hpl.hp.com says this should not be changed.
2047(defvar ange-ftp-hash-mark-msgs
2048 "[hH]ash mark [^0-9]*\\([0-9]+\\)"
2049 "*Regexp matching the FTP client's output upon doing a HASH command.")
2050
2051(defun ange-ftp-guess-hash-mark-size (proc)
2052 (if ange-ftp-send-hash
2053 (save-excursion
2054 (set-buffer (process-buffer proc))
2055 (let* ((status (ange-ftp-raw-send-cmd proc "hash"))
2056 (result (car status))
2057 (line (cdr status)))
2058 (save-match-data
2059 (if (string-match ange-ftp-hash-mark-msgs line)
2060 (let ((size (string-to-int
2061 (substring line
2062 (match-beginning 1)
2063 (match-end 1)))))
2064 (setq ange-ftp-ascii-hash-mark-size size
2065 ange-ftp-hash-mark-unit (ash size -4))
2066
2067 ;; if a default value for this is set, use that value.
2068 (or ange-ftp-binary-hash-mark-size
2069 (setq ange-ftp-binary-hash-mark-size size)))))))))
2070
2071(defun ange-ftp-get-process (host user)
2072 "Return an FTP subprocess connected to HOST and logged in as USER.
2073Create a new process if needed."
2074 (let* ((name (ange-ftp-ftp-process-buffer host user))
2075 (proc (get-process name)))
2076 (if (and proc (memq (process-status proc) '(run open)))
2077 proc
2078 ;; Must delete dead process so that new process can reuse the name.
2079 (if proc (delete-process proc))
2080 (let ((pass (ange-ftp-quote-string
2081 (ange-ftp-get-passwd host user)))
2082 (account (ange-ftp-quote-string
2083 (ange-ftp-get-account host user))))
2084 ;; grab a suitable process.
2085 (setq proc (ange-ftp-start-process host user name))
2086
2087 ;; login to FTP server.
2088 (if (and (ange-ftp-use-smart-gateway-p host)
2089 ange-ftp-gateway-host)
2090 (ange-ftp-smart-login host user pass account proc)
2091 (ange-ftp-normal-login host user pass account proc))
2092
2093 ;; Tell client to send back hash-marks as progress. It isn't usually
2094 ;; fatal if this command fails.
2095 (ange-ftp-guess-hash-mark-size proc)
2096
2097 ;; Guess at the host type.
2098 (ange-ftp-guess-host-type host user)
2099
2100 ;; Try to use passive mode if asked to.
2101 (when ange-ftp-try-passive-mode
2102 (let ((answer (cdr (ange-ftp-raw-send-cmd
2103 proc "passive" "Trying passive mode..." nil))))
2104 (if (string-match "\\?\\|refused" answer)
2105 (message "Trying passive mode...ok")
2106 (message "Trying passive mode...failed"))))
2107
2108 ;; Run any user-specified hooks. Note that proc, host and user are
2109 ;; dynamically bound at this point.
2110 (run-hooks 'ange-ftp-process-startup-hook))
2111 proc)))
2112
2113;; Variables for caching host and host-type
2114(defvar ange-ftp-host-cache nil)
2115(defvar ange-ftp-host-type-cache nil)
2116
2117;; If ange-ftp-host-type is called with the optional user
2118;; argument, it will attempt to guess the host type by connecting
2119;; as user, if necessary. For efficiency, I have tried to give this
2120;; optional second argument only when necessary. Have I missed any calls
2121;; to ange-ftp-host-type where it should have been supplied?
2122
2123(defun ange-ftp-host-type (host &optional user)
2124 "Return a symbol which represents the type of the HOST given.
2125If the optional argument USER is given, attempts to guess the
2126host-type by logging in as USER."
2127 (cond ((null host) 'unix)
2128 ;; Return `unix' if HOST is nil, since that's the most vanilla
2129 ;; possible return value.
2130 ((eq host ange-ftp-host-cache)
2131 ange-ftp-host-type-cache)
2132 ;; Trigger an ftp connection, in case we need to guess at the host type.
2133 ((and user (ange-ftp-get-process host user) (eq host ange-ftp-host-cache))
2134 ange-ftp-host-type-cache)
2135 (t
2136 (setq ange-ftp-host-cache host
2137 ange-ftp-host-type-cache
2138 (cond ((ange-ftp-dumb-unix-host host)
2139 'dumb-unix)
2140 ;; ((and (fboundp 'ange-ftp-vos-host)
2141 ;; (ange-ftp-vos-host host))
2142 ;; 'vos)
2143 ((and (fboundp 'ange-ftp-vms-host)
2144 (ange-ftp-vms-host host))
2145 'vms)
2146 ((and (fboundp 'ange-ftp-mts-host)
2147 (ange-ftp-mts-host host))
2148 'mts)
2149 ((and (fboundp 'ange-ftp-cms-host)
2150 (ange-ftp-cms-host host))
2151 'cms)
2152 (t
2153 'unix))))))
2154
2155;; It would be nice to abstract the functions ange-ftp-TYPE-host and
2156;; ange-ftp-add-TYPE-host. The trick is to abstract these functions
2157;; without sacrificing speed. Also, having separate variables
2158;; ange-ftp-TYPE-regexp is more user friendly then requiring the user to
2159;; set an alist to indicate that a host is of a given type. Even with
2160;; automatic host type recognition, setting a regexp is still a good idea
2161;; (for efficiency) if you log into a particular non-UNIX host frequently.
2162
2163(defvar ange-ftp-fix-name-func-alist nil
2164 "Alist saying how to convert file name to the host's syntax.
2165Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
2166which can change a UNIX file name into a name more suitable for a host of type
2167TYPE.")
2168
2169(defvar ange-ftp-fix-dir-name-func-alist nil
2170 "Alist saying how to convert directory name to the host's syntax.
2171Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
2172which can change UNIX directory name into a directory name more suitable
2173for a host of type TYPE.")
2174
2175;; *** Perhaps the sense of this variable should be inverted, since there
2176;; *** is only 1 host type that can take ls-style listing options.
2177(defvar ange-ftp-dumb-host-types '(dumb-unix)
2178 "List of host types that can't take UNIX ls-style listing options.")
2179
2180(defun ange-ftp-send-cmd (host user cmd &optional msg cont nowait)
2181 "Find an ftp process connected to HOST logged in as USER and send it CMD.
2182MSG is an optional status message to be output before and after issuing the
2183command.
2184See the documentation for ange-ftp-raw-send-cmd for a description of CONT
2185and NOWAIT."
2186 ;; Handle conversion to remote file name syntax and remote ls option
2187 ;; capability.
2188 (let ((cmd0 (car cmd))
2189 (cmd1 (nth 1 cmd))
2190 (ange-ftp-this-user user)
2191 (ange-ftp-this-host host)
2192 (ange-ftp-this-msg msg)
2193 cmd2 cmd3 host-type fix-name-func)
2194
2195 (cond
2196
2197 ;; pwd case (We don't care what host-type.)
2198 ((null cmd1))
2199
2200 ;; cmd == 'dir "remote-name" "local-name" "ls-switches"
2201 ((progn
2202 (setq cmd2 (nth 2 cmd)
2203 host-type (ange-ftp-host-type host user))
2204 ;; This will trigger an FTP login, if one doesn't exist
2205 (eq cmd0 'dir))
2206 (setq cmd1 (funcall
2207 (or (cdr (assq host-type ange-ftp-fix-dir-name-func-alist))
2208 'identity)
2209 cmd1)
2210 cmd3 (nth 3 cmd))
2211 ;; Need to deal with the HP-UX ftp bug. This should also allow
2212 ;; us to resolve symlinks to directories on SysV machines. (Sebastian will
2213 ;; be happy.)
2214 (and (eq host-type 'unix)
2215 (string-match "/$" cmd1)
2216 (not (string-match "R" cmd3))
2217 (setq cmd1 (concat cmd1 ".")))
2218
2219 ;; If the dir name contains a space, some ftp servers will
2220 ;; refuse to list it. We instead change directory to the
2221 ;; directory in question and ls ".".
2222 (when (string-match " " cmd1)
2223 (ange-ftp-cd host user (nth 1 cmd))
2224 (setq cmd1 "."))
2225
2226 ;; If the remote ls can take switches, put them in
2227 (or (memq host-type ange-ftp-dumb-host-types)
2228 (setq cmd0 'ls
2229 cmd1 (format "\"%s %s\"" cmd3 cmd1))))
2230
2231 ;; First argument is the remote name
2232 ((progn
2233 (setq fix-name-func (or (cdr (assq host-type
2234 ange-ftp-fix-name-func-alist))
2235 'identity))
2236 (memq cmd0 '(get delete mkdir rmdir cd)))
2237 (setq cmd1 (funcall fix-name-func cmd1)))
2238
2239 ;; Second argument is the remote name
2240 ((memq cmd0 '(append put chmod))
2241 (setq cmd2 (funcall fix-name-func cmd2)))
2242
2243 ;; Both arguments are remote names
2244 ((eq cmd0 'rename)
2245 (setq cmd1 (funcall fix-name-func cmd1)
2246 cmd2 (funcall fix-name-func cmd2))))
2247
2248 ;; Turn the command into one long string
2249 (setq cmd0 (symbol-name cmd0))
2250 (setq cmd (concat cmd0
2251 (and cmd1 (concat " " cmd1))
2252 (and cmd2 (concat " " cmd2))))
2253
2254 ;; Actually send the resulting command.
2255 (let (afsc-result
2256 afsc-line)
2257 (ange-ftp-raw-send-cmd
2258 (ange-ftp-get-process host user)
2259 cmd
2260 msg
2261 (list
2262 (function (lambda (result line host user
2263 cmd msg cont nowait)
2264 (or cont
2265 (setq afsc-result result
2266 afsc-line line))
2267 (if result
2268 (ange-ftp-call-cont cont result line)
2269 (ange-ftp-raw-send-cmd
2270 (ange-ftp-get-process host user)
2271 cmd
2272 msg
2273 (list
2274 (function (lambda (result line cont)
2275 (or cont
2276 (setq afsc-result result
2277 afsc-line line))
2278 (ange-ftp-call-cont cont result line)))
2279 cont)
2280 nowait))))
2281 host user cmd msg cont nowait)
2282 nowait)
2283
2284 (if nowait
2285 nil
2286 (if cont
2287 nil
2288 (cons afsc-result afsc-line))))))
2289
2290;; It might be nice to message users about the host type identified,
2291;; but there is so much other messaging going on, it would not be
2292;; seen. No point in slowing things down just so users can read
2293;; a host type message.
2294
2295(defconst ange-ftp-cms-name-template
2296 (concat
2297 "^[-A-Z0-9$*][-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?"
2298 "[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?\\.[0-9][0-9][0-9A-Z]$"))
2299(defconst ange-ftp-vms-name-template
2300 "^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$")
2301(defconst ange-ftp-mts-name-template
2302 "^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$")
2303
2304(defun ange-ftp-guess-host-type (host user)
2305 "Guess at the the host type of HOST.
2306Works by doing a pwd and examining the directory syntax."
2307 (let ((host-type (ange-ftp-host-type host))
2308 (key (concat host "/" user "/~")))
2309 (if (eq host-type 'unix)
2310 ;; Note that ange-ftp-host-type returns unix as the default value.
2311 (save-match-data
2312 (let* ((result (ange-ftp-get-pwd host user))
2313 (dir (car result))
2314 fix-name-func)
2315 (cond ((null dir)
2316 (message "Warning! Unable to get home directory")
2317 (sit-for 1)
2318 (if (string-match
2319 "^450 No current working directory defined$"
2320 (cdr result))
2321
2322 ;; We'll assume that if pwd bombs with this
2323 ;; error message, then it's CMS.
2324 (progn
2325 (ange-ftp-add-cms-host host)
2326 (setq ange-ftp-host-cache host
2327 ange-ftp-host-type-cache 'cms))))
2328
2329 ;; try for VMS
2330 ((string-match ange-ftp-vms-name-template dir)
2331 (ange-ftp-add-vms-host host)
2332 ;; The add-host functions clear the host type cache.
2333 ;; Therefore, need to set the cache afterwards.
2334 (setq ange-ftp-host-cache host
2335 ange-ftp-host-type-cache 'vms))
2336
2337 ;; try for MTS
2338 ((string-match ange-ftp-mts-name-template dir)
2339 (ange-ftp-add-mts-host host)
2340 (setq ange-ftp-host-cache host
2341 ange-ftp-host-type-cache 'mts))
2342
2343 ;; try for CMS
2344 ((string-match ange-ftp-cms-name-template dir)
2345 (ange-ftp-add-cms-host host)
2346 (setq ange-ftp-host-cache host
2347 ange-ftp-host-type-cache 'cms))
2348
2349 ;; assume UN*X
2350 (t
2351 (setq ange-ftp-host-cache host
2352 ange-ftp-host-type-cache 'unix)))
2353
2354 ;; Now that we have done a pwd, might as well put it in
2355 ;; the expand-dir hashtable.
2356 (let ((ange-ftp-this-user user)
2357 (ange-ftp-this-host host))
2358 (setq fix-name-func (cdr (assq ange-ftp-host-type-cache
2359 ange-ftp-fix-name-func-alist)))
2360 (if fix-name-func
2361 (setq dir (funcall fix-name-func dir 'reverse))))
2362 (ange-ftp-put-hash-entry key dir
2363 ange-ftp-expand-dir-hashtable))))
2364
2365 ;; In the special case of CMS make sure that know the
2366 ;; expansion of the home minidisk now, because we will
2367 ;; be doing a lot of cd's.
2368 (if (and (eq host-type 'cms)
2369 (not (ange-ftp-hash-entry-exists-p
2370 key ange-ftp-expand-dir-hashtable)))
2371 (let ((dir (car (ange-ftp-get-pwd host user))))
2372 (if dir
2373 (ange-ftp-put-hash-entry key (concat "/" dir)
2374 ange-ftp-expand-dir-hashtable)
2375 (message "Warning! Unable to get home directory")
2376 (sit-for 1))))))
2377
2378
2379;;;; ------------------------------------------------------------
2380;;;; Remote file and directory listing support.
2381;;;; ------------------------------------------------------------
2382
2383;; Returns whether HOST's FTP server doesn't like \'ls\' or \'dir\' commands
2384;; to take switch arguments.
2385(defun ange-ftp-dumb-unix-host (host)
2386 (and host ange-ftp-dumb-unix-host-regexp
2387 (save-match-data
2388 (string-match ange-ftp-dumb-unix-host-regexp host))))
2389
2390(defun ange-ftp-add-dumb-unix-host (host)
2391 "Interactively adds a given HOST to ange-ftp-dumb-unix-host-regexp."
2392 (interactive
2393 (list (read-string "Host: "
2394 (let ((name (or (buffer-file-name) default-directory)))
2395 (and name (car (ange-ftp-ftp-name name)))))))
2396 (if (not (ange-ftp-dumb-unix-host host))
2397 (setq ange-ftp-dumb-unix-host-regexp
2398 (concat "^" (regexp-quote host) "$"
2399 (and ange-ftp-dumb-unix-host-regexp "\\|")
2400 ange-ftp-dumb-unix-host-regexp)
2401 ange-ftp-host-cache nil)))
2402
2403(defvar ange-ftp-parse-list-func-alist nil
2404 "Alist saying how to parse directory listings for certain OS types.
2405Association list of \( TYPE \. FUNC \) pairs. The FUNC is a routine
2406which can parse the output from a DIR listing for a host of type TYPE.")
2407
2408;; With no-error nil, this function returns:
2409;; an error if file is not an ange-ftp-name
2410;; (This should never happen.)
2411;; an error if either the listing is unreadable or there is an ftp error.
2412;; the listing (a string), if everything works.
2413;;
2414;; With no-error t, it returns:
2415;; an error if not an ange-ftp-name
2416;; error if listing is unreadable (most likely caused by a slow connection)
2417;; nil if ftp error (this is because although asking to list a nonexistent
2418;; directory on a remote unix machine usually (except
2419;; maybe for dumb hosts) returns an ls error, but no
2420;; ftp error, if the same is done on a VMS machine,
2421;; an ftp error is returned. Need to trap the error
2422;; so we can go on and try to list the parent.)
2423;; the listing, if everything works.
2424
2425;; If WILDCARD is non-nil, then this implements the guts of insert-directory
2426;; in the wildcard case. Then we make a relative directory listing
2427;; of FILE within the directory specified by `default-directory'.
2428
2429(defvar ange-ftp-before-parse-ls-hook nil
2430 "Normal hook run before parsing the text of an ftp directory listing.")
2431
2432(defun ange-ftp-ls (file lsargs parse &optional no-error wildcard)
2433 "Return the output of an `DIR' or `ls' command done over ftp.
2434FILE is the full name of the remote file, LSARGS is any args to pass to the
2435`ls' command, and PARSE specifies that the output should be parsed and stored
2436away in the internal cache."
2437 ;; If parse is t, we assume that file is a directory. i.e. we only parse
2438 ;; full directory listings.
2439 (let* ((ange-ftp-this-file (ange-ftp-expand-file-name file))
2440 (parsed (ange-ftp-ftp-name ange-ftp-this-file)))
2441 (if parsed
2442 (let* ((host (nth 0 parsed))
2443 (user (nth 1 parsed))
2444 (name (ange-ftp-quote-string (nth 2 parsed)))
2445 (key (directory-file-name ange-ftp-this-file))
2446 (host-type (ange-ftp-host-type host user))
2447 (dumb (memq host-type ange-ftp-dumb-host-types))
2448 result
2449 temp
2450 lscmd parse-func)
2451 (if (string-equal name "")
2452 (setq name
2453 (ange-ftp-real-file-name-as-directory
2454 (ange-ftp-expand-dir host user "~"))))
2455 (if (and ange-ftp-ls-cache-file
2456 (string-equal key ange-ftp-ls-cache-file)
2457 ;; Don't care about lsargs for dumb hosts.
2458 (or dumb (string-equal lsargs ange-ftp-ls-cache-lsargs)))
2459 ange-ftp-ls-cache-res
2460 (setq temp (ange-ftp-make-tmp-name host))
2461 (if wildcard
2462 (progn
2463 (ange-ftp-cd host user (file-name-directory name))
2464 (setq lscmd (list 'dir file temp lsargs)))
2465 (setq lscmd (list 'dir name temp lsargs)))
2466 (unwind-protect
2467 (if (car (setq result (ange-ftp-send-cmd
2468 host
2469 user
2470 lscmd
2471 (format "Listing %s"
2472 (ange-ftp-abbreviate-filename
2473 ange-ftp-this-file)))))
2474 (save-excursion
2475 (set-buffer (get-buffer-create
2476 ange-ftp-data-buffer-name))
2477 (erase-buffer)
2478 (if (ange-ftp-real-file-readable-p temp)
2479 (ange-ftp-real-insert-file-contents temp)
2480 (sleep-for ange-ftp-retry-time)
2481 ;wait for file to possibly appear
2482 (if (ange-ftp-real-file-readable-p temp)
2483 ;; Try again.
2484 (ange-ftp-real-insert-file-contents temp)
2485 (ange-ftp-error host user
2486 (format
2487 "list data file %s not readable"
2488 temp))))
2489 (run-hooks 'ange-ftp-before-parse-ls-hook)
2490 (if parse
2491 (ange-ftp-set-files
2492 ange-ftp-this-file
2493 (if (setq
2494 parse-func
2495 (cdr (assq host-type
2496 ange-ftp-parse-list-func-alist)))
2497 (funcall parse-func)
2498 (ange-ftp-parse-dired-listing lsargs))))
2499 (setq ange-ftp-ls-cache-file key
2500 ange-ftp-ls-cache-lsargs lsargs
2501 ; For dumb hosts-types this is
2502 ; meaningless but harmless.
2503 ange-ftp-ls-cache-res (buffer-string))
2504 ;; (kill-buffer (current-buffer))
2505 ange-ftp-ls-cache-res)
2506 (if no-error
2507 nil
2508 (ange-ftp-error host user
2509 (concat "DIR failed: " (cdr result)))))
2510 (ange-ftp-del-tmp-name temp))))
2511 (error "Should never happen. Please report. Bug ref. no.: 1"))))
2512
2513;;;; ------------------------------------------------------------
2514;;;; Directory information caching support.
2515;;;; ------------------------------------------------------------
2516
2517(defconst ange-ftp-date-regexp
2518 (let* ((l "\\([A-Za-z]\\|[^\0-\177]\\)")
2519 ;; In some locales, month abbreviations are as short as 2 letters,
2520 ;; and they can be padded on the right with spaces.
2521 ;; weiand: changed: month ends with . or , or .,
2522;;old (month (concat l l "+ *"))
2523 (month (concat l l "+[.]?,? *"))
2524 ;; Recognize any non-ASCII character.
2525 ;; The purpose is to match a Kanji character.
2526 (k "[^\0-\177]")
2527 (s " ")
2528 (mm "[ 0-1][0-9]")
2529 ;; weiand: changed: day ends with .
2530;;old (dd "[ 0-3][0-9]")
2531 (dd "[ 0-3][0-9][.]?")
2532 (western (concat "\\(" month s dd "\\|" dd s month "\\)"))
2533 (japanese (concat mm k s dd k)))
2534 ;; Require the previous column to end in a digit.
2535 ;; This avoids recognizing `1 may 1997' as a date in the line:
2536 ;; -r--r--r-- 1 may 1997 1168 Oct 19 16:49 README
2537 (concat "[0-9]" s "\\(" western "\\|" japanese "\\)" s))
2538 "Regular expression to match up to the column before the file name in a
2539directory listing. This regular expression is designed to recognize dates
2540regardless of the language.")
2541
2542(defvar ange-ftp-add-file-entry-alist nil
2543 "Alist saying how to add file entries on certain OS types.
2544Association list of pairs \( TYPE \. FUNC \), where FUNC
2545is a function to be used to add a file entry for the OS TYPE. The
2546main reason for this alist is to deal with file versions in VMS.")
2547
2548(defvar ange-ftp-delete-file-entry-alist nil
2549 "Alist saying how to delete files on certain OS types.
2550Association list of pairs \( TYPE \. FUNC \), where FUNC
2551is a function to be used to delete a file entry for the OS TYPE.
2552The main reason for this alist is to deal with file versions in VMS.")
2553
2554(defun ange-ftp-add-file-entry (name &optional dir-p)
2555 "Add a file entry for file NAME, if its directory info exists."
2556 (funcall (or (cdr (assq (ange-ftp-host-type
2557 (car (ange-ftp-ftp-name name)))
2558 ange-ftp-add-file-entry-alist))
2559 'ange-ftp-internal-add-file-entry)
2560 name dir-p)
2561 (setq ange-ftp-ls-cache-file nil))
2562
2563(defun ange-ftp-delete-file-entry (name &optional dir-p)
2564 "Delete the file entry for file NAME, if its directory info exists."
2565 (funcall (or (cdr (assq (ange-ftp-host-type
2566 (car (ange-ftp-ftp-name name)))
2567 ange-ftp-delete-file-entry-alist))
2568 'ange-ftp-internal-delete-file-entry)
2569 name dir-p)
2570 (setq ange-ftp-ls-cache-file nil))
2571
2572(defmacro ange-ftp-parse-filename ()
2573 ;;Extract the filename from the current line of a dired-like listing.
2574 (` (let ((eol (progn (end-of-line) (point))))
2575 (beginning-of-line)
2576 (if (re-search-forward ange-ftp-date-regexp eol t)
2577 (progn
2578 (skip-chars-forward " ")
2579 (skip-chars-forward "^ " eol)
2580 (skip-chars-forward " " eol)
2581 ;; We bomb on filenames starting with a space.
2582 (buffer-substring (point) eol))))))
2583
2584;; This deals with the F switch. Should also do something about
2585;; unquoting names obtained with the SysV b switch and the GNU Q
2586;; switch. See Sebastian's dired-get-filename.
2587
2588(defmacro ange-ftp-ls-parser ()
2589 ;; Note that switches is dynamically bound.
2590 ;; Meant to be called by ange-ftp-parse-dired-listing
2591 (` (let ((tbl (ange-ftp-make-hashtable))
2592 (used-F (and (stringp switches)
2593 (string-match "F" switches)))
2594 file-type symlink directory file)
2595 (while (setq file (ange-ftp-parse-filename))
2596 (beginning-of-line)
2597 (skip-chars-forward "\t 0-9")
2598 (setq file-type (following-char)
2599 directory (eq file-type ?d))
2600 (if (eq file-type ?l)
2601 (if (string-match " -> " file)
2602 (setq symlink (substring file (match-end 0))
2603 file (substring file 0 (match-beginning 0)))
2604 ;; Shouldn't happen
2605 (setq symlink ""))
2606 (setq symlink nil))
2607 ;; Only do a costly regexp search if the F switch was used.
2608 (if (and used-F
2609 (not (string-equal file ""))
2610 (looking-at
2611 ".[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)"))
2612 (let ((socket (eq file-type ?s))
2613 (executable
2614 (and (not symlink) ; x bits don't mean a thing for symlinks
2615 (string-match "[xst]"
2616 (concat
2617 (buffer-substring
2618 (match-beginning 1)
2619 (match-end 1))
2620 (buffer-substring
2621 (match-beginning 2)
2622 (match-end 2))
2623 (buffer-substring
2624 (match-beginning 3)
2625 (match-end 3)))))))
2626 ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX)
2627 ;; and others don't. (sigh...) Beware, that some Unix's don't
2628 ;; seem to believe in the F-switch
2629 (if (or (and symlink (string-match "@$" file))
2630 (and directory (string-match "/$" file))
2631 (and executable (string-match "*$" file))
2632 (and socket (string-match "=$" file)))
2633 (setq file (substring file 0 -1)))))
2634 (ange-ftp-put-hash-entry file (or symlink directory) tbl)
2635 (forward-line 1))
2636 (ange-ftp-put-hash-entry "." t tbl)
2637 (ange-ftp-put-hash-entry ".." t tbl)
2638 tbl)))
2639
2640;;; The dl stuff for descriptive listings
2641
2642(defvar ange-ftp-dl-dir-regexp nil
2643 "Regexp matching directories which are listed in dl format.
2644This regexp should not be anchored with a trailing `$', because it should
2645match subdirectories as well.")
2646
2647(defun ange-ftp-add-dl-dir (dir)
2648 "Interactively adds a DIR to ange-ftp-dl-dir-regexp."
2649 (interactive
2650 (list (read-string "Directory: "
2651 (let ((name (or (buffer-file-name) default-directory)))
2652 (and name (ange-ftp-ftp-name name)
2653 (file-name-directory name))))))
2654 (if (not (and ange-ftp-dl-dir-regexp
2655 (string-match ange-ftp-dl-dir-regexp dir)))
2656 (setq ange-ftp-dl-dir-regexp
2657 (concat "^" (regexp-quote dir)
2658 (and ange-ftp-dl-dir-regexp "\\|")
2659 ange-ftp-dl-dir-regexp))))
2660
2661(defmacro ange-ftp-dl-parser ()
2662 ;; Parse the current buffer, which is assumed to be a descriptive
2663 ;; listing, and return a hashtable.
2664 (` (let ((tbl (ange-ftp-make-hashtable)))
2665 (while (not (eobp))
2666 (ange-ftp-put-hash-entry
2667 (buffer-substring (point)
2668 (progn
2669 (skip-chars-forward "^ /\n")
2670 (point)))
2671 (eq (following-char) ?/)
2672 tbl)
2673 (forward-line 1))
2674 (ange-ftp-put-hash-entry "." t tbl)
2675 (ange-ftp-put-hash-entry ".." t tbl)
2676 tbl)))
2677
2678;; Parse the current buffer which is assumed to be in a dired-like listing
2679;; format, and return a hashtable as the result. If the listing is not really
2680;; a listing, then return nil.
2681
2682(defun ange-ftp-parse-dired-listing (&optional switches)
2683 (save-match-data
2684 (cond
2685 ((looking-at "^total [0-9]+$")
2686 (forward-line 1)
2687 ;; Some systems put in a blank line here.
2688 (if (eolp) (forward-line 1))
2689 (ange-ftp-ls-parser))
2690 ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'")
2691 ;; It's an ls error message.
2692 nil)
2693 ((eobp) ; i.e. (zerop (buffer-size))
2694 ;; This could be one of:
2695 ;; (1) An Ultrix ls error message
2696 ;; (2) A listing with the A switch of an empty directory
2697 ;; on a machine which doesn't give a total line.
2698 ;; (3) The twilight zone.
2699 ;; We'll assume (1) for now.
2700 nil)
2701 ((re-search-forward ange-ftp-date-regexp nil t)
2702 (beginning-of-line)
2703 (ange-ftp-ls-parser))
2704 ((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t)
2705 ;; It's a dl listing (I hope).
2706 ;; file is bound by the call to ange-ftp-ls
2707 (ange-ftp-add-dl-dir ange-ftp-this-file)
2708 (beginning-of-line)
2709 (ange-ftp-dl-parser))
2710 (t nil))))
2711
2712(defun ange-ftp-set-files (directory files)
2713 "For a given DIRECTORY, set or change the associated FILES hashtable."
2714 (and files (ange-ftp-put-hash-entry (file-name-as-directory directory)
2715 files ange-ftp-files-hashtable)))
2716
2717(defun ange-ftp-get-files (directory &optional no-error)
2718 "Given a given DIRECTORY, return a hashtable of file entries.
2719This will give an error or return nil, depending on the value of
2720NO-ERROR, if a listing for DIRECTORY cannot be obtained."
2721 (setq directory (file-name-as-directory directory)) ;normalize
2722 (or (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable)
2723 (save-match-data
2724 (and (ange-ftp-ls directory
2725 ;; This is an efficiency hack. We try to
2726 ;; anticipate what sort of listing dired
2727 ;; might want, and cache just such a listing.
2728 (if (and (boundp 'dired-actual-switches)
2729 (stringp dired-actual-switches)
2730 ;; We allow the A switch, which lists
2731 ;; all files except "." and "..".
2732 ;; This is OK because we manually
2733 ;; insert these entries
2734 ;; in the hash table.
2735 (string-match
2736 "[aA]" dired-actual-switches)
2737 (string-match
2738 "l" dired-actual-switches)
2739 (not (string-match
2740 "R" dired-actual-switches)))
2741 dired-actual-switches
2742 (if (and (boundp 'dired-listing-switches)
2743 (stringp dired-listing-switches)
2744 (string-match
2745 "[aA]" dired-listing-switches)
2746 (string-match
2747 "l" dired-listing-switches)
2748 (not (string-match
2749 "R" dired-listing-switches)))
2750 dired-listing-switches
2751 "-al"))
2752 t no-error)
2753 (ange-ftp-get-hash-entry
2754 directory ange-ftp-files-hashtable)))))
2755
2756;; Given NAME, return the file part that can be used for looking up the
2757;; file's entry in a hashtable.
2758(defmacro ange-ftp-get-file-part (name)
2759 (` (let ((file (file-name-nondirectory (, name))))
2760 (if (string-equal file "")
2761 "."
2762 file))))
2763
2764;; Return whether ange-ftp-file-entry-p and ange-ftp-get-file-entry are
2765;; allowed to determine if NAME is a sub-directory by listing it directly,
2766;; rather than listing its parent directory. This is used for efficiency so
2767;; that a wasted listing is not done:
2768;; 1. When looking for a .dired file in dired-x.el.
2769;; 2. The syntax of FILE and DIR make it impossible that FILE could be a valid
2770;; subdirectory. This is of course an OS dependent judgement.
2771
2772(defmacro ange-ftp-allow-child-lookup (dir file)
2773 (` (not
2774 (let* ((efile (, file)) ; expand once.
2775 (edir (, dir))
2776 (parsed (ange-ftp-ftp-name edir))
2777 (host-type (ange-ftp-host-type
2778 (car parsed))))
2779 (or
2780 ;; Deal with dired
2781 (and (boundp 'dired-local-variables-file) ; in the dired-x package
2782 (stringp dired-local-variables-file)
2783 (string-equal dired-local-variables-file efile))
2784 ;; No dots in dir names in vms.
2785 (and (eq host-type 'vms)
2786 (string-match "\\." efile))
2787 ;; No subdirs in mts of cms.
2788 (and (memq host-type '(mts cms))
2789 (not (string-equal "/" (nth 2 parsed)))))))))
2790
2791(defun ange-ftp-file-entry-p (name)
2792 "Given NAME, return whether there is a file entry for it."
2793 (let* ((name (directory-file-name name))
2794 (dir (file-name-directory name))
2795 (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable))
2796 (file (ange-ftp-get-file-part name)))
2797 (if ent
2798 (ange-ftp-hash-entry-exists-p file ent)
2799 (or (and (ange-ftp-allow-child-lookup dir file)
2800 (setq ent (ange-ftp-get-files name t))
2801 ;; Try a child lookup. i.e. try to list file as a
2802 ;; subdirectory of dir. This is a good idea because
2803 ;; we may not have read permission for file's parent. Also,
2804 ;; people tend to work down directory trees anyway. We use
2805 ;; no-error ;; because if file does not exist as a subdir.,
2806 ;; then dumb hosts will give an ftp error. Smart unix hosts
2807 ;; will simply send back the ls
2808 ;; error message.
2809 (ange-ftp-get-hash-entry "." ent))
2810 ;; Child lookup failed, so try the parent.
2811 (let ((table (ange-ftp-get-files dir)))
2812 ;; If the dir doesn't exist, don't use it as a hash table.
2813 (and table
2814 (ange-ftp-hash-entry-exists-p file
2815 table)))))))
2816
2817(defun ange-ftp-get-file-entry (name)
2818 "Given NAME, return the given file entry.
2819The entry will be either t for a directory, nil for a normal file,
2820or a string for a symlink. If the file isn't in the hashtable,
2821this also returns nil."
2822 (let* ((name (directory-file-name name))
2823 (dir (file-name-directory name))
2824 (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable))
2825 (file (ange-ftp-get-file-part name)))
2826 (if ent
2827 (ange-ftp-get-hash-entry file ent)
2828 (or (and (ange-ftp-allow-child-lookup dir file)
2829 (setq ent (ange-ftp-get-files name t))
2830 (ange-ftp-get-hash-entry "." ent))
2831 ;; i.e. it's a directory by child lookup
2832 (ange-ftp-get-hash-entry file
2833 (ange-ftp-get-files dir))))))
2834
2835(defun ange-ftp-internal-delete-file-entry (name &optional dir-p)
2836 (if dir-p
2837 (progn
2838 (setq name (file-name-as-directory name))
2839 (ange-ftp-del-hash-entry name ange-ftp-files-hashtable)
2840 (setq name (directory-file-name name))))
2841 ;; Note that file-name-as-directory followed by directory-file-name
2842 ;; serves to canonicalize directory file names to their unix form.
2843 ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO
2844 (let ((files (ange-ftp-get-hash-entry (file-name-directory name)
2845 ange-ftp-files-hashtable)))
2846 (if files
2847 (ange-ftp-del-hash-entry (ange-ftp-get-file-part name)
2848 files))))
2849
2850(defun ange-ftp-internal-add-file-entry (name &optional dir-p)
2851 (and dir-p
2852 (setq name (directory-file-name name)))
2853 (let ((files (ange-ftp-get-hash-entry (file-name-directory name)
2854 ange-ftp-files-hashtable)))
2855 (if files
2856 (ange-ftp-put-hash-entry (ange-ftp-get-file-part name)
2857 dir-p
2858 files))))
2859
2860(defun ange-ftp-wipe-file-entries (host user)
2861 "Get rid of entry for HOST, USER pair from file entry information hashtable."
2862 (let ((new-tbl (ange-ftp-make-hashtable (length ange-ftp-files-hashtable))))
2863 (ange-ftp-map-hashtable
2864 (function
2865 (lambda (key val)
2866 (let ((parsed (ange-ftp-ftp-name key)))
2867 (if parsed
2868 (let ((h (nth 0 parsed))
2869 (u (nth 1 parsed)))
2870 (or (and (equal host h) (equal user u))
2871 (ange-ftp-put-hash-entry key val new-tbl)))))))
2872 ange-ftp-files-hashtable)
2873 (setq ange-ftp-files-hashtable new-tbl)))
2874
2875;;;; ------------------------------------------------------------
2876;;;; File transfer mode support.
2877;;;; ------------------------------------------------------------
2878
2879(defun ange-ftp-set-binary-mode (host user)
2880 "Tell the ftp process for the given HOST & USER to switch to binary mode."
2881 (let ((result (ange-ftp-send-cmd host user '(type "binary"))))
2882 (if (not (car result))
2883 (ange-ftp-error host user (concat "BINARY failed: " (cdr result)))
2884 (save-excursion
2885 (set-buffer (process-buffer (ange-ftp-get-process host user)))
2886 (and ange-ftp-binary-hash-mark-size
2887 (setq ange-ftp-hash-mark-unit
2888 (ash ange-ftp-binary-hash-mark-size -4)))))))
2889
2890(defun ange-ftp-set-ascii-mode (host user)
2891 "Tell the ftp process for the given HOST & USER to switch to ascii mode."
2892 (let ((result (ange-ftp-send-cmd host user '(type "ascii"))))
2893 (if (not (car result))
2894 (ange-ftp-error host user (concat "ASCII failed: " (cdr result)))
2895 (save-excursion
2896 (set-buffer (process-buffer (ange-ftp-get-process host user)))
2897 (and ange-ftp-ascii-hash-mark-size
2898 (setq ange-ftp-hash-mark-unit
2899 (ash ange-ftp-ascii-hash-mark-size -4)))))))
2900
2901(defun ange-ftp-cd (host user dir)
2902 (let ((result (ange-ftp-send-cmd host user (list 'cd dir) "Doing CD")))
2903 (or (car result)
2904 (ange-ftp-error host user (concat "CD failed: " (cdr result))))))
2905
2906(defun ange-ftp-get-pwd (host user)
2907 "Attempts to get the current working directory for the given HOST/USER pair.
2908Returns \( DIR . LINE \) where DIR is either the directory or nil if not found,
2909and LINE is the relevant success or fail line from the FTP-client."
2910 (let* ((result (ange-ftp-send-cmd host user '(pwd) "Getting PWD"))
2911 (line (cdr result))
2912 dir)
2913 (if (car result)
2914 (save-match-data
2915 (and (or (string-match "\"\\([^\"]*\\)\"" line)
2916 (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers!
2917 (setq dir (substring line
2918 (match-beginning 1)
2919 (match-end 1))))))
2920 (cons dir line)))
2921
2922;;; ------------------------------------------------------------
2923;;; expand-file-name and friends...which currently don't work
2924;;; ------------------------------------------------------------
2925
2926(defun ange-ftp-expand-dir (host user dir)
2927 "Return the result of doing a PWD in the current FTP session.
2928Use the connection to machine HOST
2929logged in as user USER and cd'd to directory DIR."
2930 (let* ((host-type (ange-ftp-host-type host user))
2931 ;; It is more efficient to call ange-ftp-host-type
2932 ;; before binding res, because ange-ftp-host-type sometimes
2933 ;; adds to the info in the expand-dir-hashtable.
2934 (fix-name-func
2935 (cdr (assq host-type ange-ftp-fix-name-func-alist)))
2936 (key (concat host "/" user "/" dir))
2937 (res (ange-ftp-get-hash-entry key ange-ftp-expand-dir-hashtable)))
2938 (or res
2939 (progn
2940 (or
2941 (string-equal user "anonymous")
2942 (string-equal user "ftp")
2943 (not (eq host-type 'unix))
2944 (let* ((ange-ftp-good-msgs (concat ange-ftp-expand-dir-regexp
2945 "\\|"
2946 ange-ftp-good-msgs))
2947 (result (ange-ftp-send-cmd host user
2948 (list 'get dir null-device)
2949 (format "expanding %s" dir)))
2950 (line (cdr result)))
2951 (setq res
2952 (if (string-match ange-ftp-expand-dir-regexp line)
2953 (substring line
2954 (match-beginning 1)
2955 (match-end 1))))))
2956 (or res
2957 (if (string-equal dir "~")
2958 (setq res (car (ange-ftp-get-pwd host user)))
2959 (let ((home (ange-ftp-expand-dir host user "~")))
2960 (unwind-protect
2961 (and (ange-ftp-cd host user dir)
2962 (setq res (car (ange-ftp-get-pwd host user))))
2963 (ange-ftp-cd host user home)))))
2964 (if res
2965 (let ((ange-ftp-this-user user)
2966 (ange-ftp-this-host host))
2967 (if fix-name-func
2968 (setq res (funcall fix-name-func res 'reverse)))
2969 (ange-ftp-put-hash-entry
2970 key res ange-ftp-expand-dir-hashtable)))
2971 res))))
2972
2973(defun ange-ftp-canonize-filename (n)
2974 "Take a string and short-circuit //, /. and /.."
2975 (if (string-match "[^:]+//" n) ;don't upset Apollo users
2976 (setq n (substring n (1- (match-end 0)))))
2977 (let ((parsed (ange-ftp-ftp-name n)))
2978 (if parsed
2979 (let ((host (car parsed))
2980 (user (nth 1 parsed))
2981 (name (nth 2 parsed)))
2982
2983 ;; See if remote name is absolute. If so then just expand it and
2984 ;; replace the name component of the overall name.
2985 (cond ((string-match "^/" name)
2986 name)
2987
2988 ;; Name starts with ~ or ~user. Resolve that part of the name
2989 ;; making it absolute then re-expand it.
2990 ((string-match "^~[^/]*" name)
2991 (let* ((tilda (substring name
2992 (match-beginning 0)
2993 (match-end 0)))
2994 (rest (substring name (match-end 0)))
2995 (dir (ange-ftp-expand-dir host user tilda)))
2996 (if dir
2997 (setq name (concat dir rest))
2998 (error "User \"%s\" is not known"
2999 (substring tilda 1)))))
3000
3001 ;; relative name. Tack on homedir and re-expand.
3002 (t
3003 (let ((dir (ange-ftp-expand-dir host user "~")))
3004 (if dir
3005 (setq name (concat
3006 (ange-ftp-real-file-name-as-directory dir)
3007 name))
3008 (error "Unable to obtain CWD")))))
3009
3010 ;; If name starts with //, preserve that, for apollo system.
3011 (if (not (string-match "^//" name))
3012 (progn
3013 (if (not (eq system-type 'windows-nt))
3014 (setq name (ange-ftp-real-expand-file-name name))
3015 ;; Windows UNC default dirs do not make sense for ftp.
3016 (if (string-match "^//" default-directory)
3017 (setq name (ange-ftp-real-expand-file-name name "c:/"))
3018 (setq name (ange-ftp-real-expand-file-name name)))
3019 ;; Strip off possible drive specifier.
3020 (if (string-match "^[a-zA-Z]:" name)
3021 (setq name (substring name 2))))
3022 (if (string-match "^//" name)
3023 (setq name (substring name 1)))))
3024
3025 ;; Now substitute the expanded name back into the overall filename.
3026 (ange-ftp-replace-name-component n name))
3027
3028 ;; non-ange-ftp name. Just expand normally.
3029 (if (eq (string-to-char n) ?/)
3030 (ange-ftp-real-expand-file-name n)
3031 (ange-ftp-real-expand-file-name
3032 (ange-ftp-real-file-name-nondirectory n)
3033 (ange-ftp-real-file-name-directory n))))))
3034
3035(defun ange-ftp-expand-file-name (name &optional default)
3036 "Documented as original."
3037 (save-match-data
3038 (setq default (or default default-directory))
3039 (cond ((eq (string-to-char name) ?~)
3040 (ange-ftp-real-expand-file-name name))
3041 ((eq (string-to-char name) ?/)
3042 (ange-ftp-canonize-filename name))
3043 ((and (eq system-type 'windows-nt)
3044 (eq (string-to-char name) ?\\))
3045 (ange-ftp-canonize-filename name))
3046 ((and (eq system-type 'windows-nt)
3047 (or (string-match "^[a-zA-Z]:" name)
3048 (string-match "^[a-zA-Z]:" default)))
3049 (ange-ftp-real-expand-file-name name default))
3050 ((zerop (length name))
3051 (ange-ftp-canonize-filename default))
3052 ((ange-ftp-canonize-filename
3053 (concat (file-name-as-directory default) name))))))
3054
3055;;; These are problems--they are currently not enabled.
3056
3057(defvar ange-ftp-file-name-as-directory-alist nil
3058 "Association list of \( TYPE \. FUNC \) pairs.
3059FUNC converts a filename to a directory name for the operating
3060system TYPE.")
3061
3062(defun ange-ftp-file-name-as-directory (name)
3063 "Documented as original."
3064 (let ((parsed (ange-ftp-ftp-name name)))
3065 (if parsed
3066 (if (string-equal (nth 2 parsed) "")
3067 name
3068 (funcall (or (cdr (assq
3069 (ange-ftp-host-type (car parsed))
3070 ange-ftp-file-name-as-directory-alist))
3071 'ange-ftp-real-file-name-as-directory)
3072 name))
3073 (ange-ftp-real-file-name-as-directory name))))
3074
3075(defun ange-ftp-file-name-directory (name)
3076 "Documented as original."
3077 (let ((parsed (ange-ftp-ftp-name name)))
3078 (if parsed
3079 (let ((filename (nth 2 parsed)))
3080 (if (save-match-data
3081 (string-match "^~[^/]*$" filename))
3082 name
3083 (ange-ftp-replace-name-component
3084 name
3085 (ange-ftp-real-file-name-directory filename))))
3086 (ange-ftp-real-file-name-directory name))))
3087
3088(defun ange-ftp-file-name-nondirectory (name)
3089 "Documented as original."
3090 (let ((parsed (ange-ftp-ftp-name name)))
3091 (if parsed
3092 (let ((filename (nth 2 parsed)))
3093 (if (save-match-data
3094 (string-match "^~[^/]*$" filename))
3095 ""
3096 (ange-ftp-real-file-name-nondirectory filename)))
3097 (ange-ftp-real-file-name-nondirectory name))))
3098
3099(defun ange-ftp-directory-file-name (dir)
3100 "Documented as original."
3101 (let ((parsed (ange-ftp-ftp-name dir)))
3102 (if parsed
3103 (ange-ftp-replace-name-component
3104 dir
3105 (ange-ftp-real-directory-file-name (nth 2 parsed)))
3106 (ange-ftp-real-directory-file-name dir))))
3107
3108
3109;;; Hooks that handle Emacs primitives.
3110
3111;; Returns non-nil if should transfer FILE in binary mode.
3112(defun ange-ftp-binary-file (file)
3113 (save-match-data
3114 (string-match ange-ftp-binary-file-name-regexp file)))
3115
3116(defun ange-ftp-write-region (start end filename &optional append visit)
3117 (setq filename (expand-file-name filename))
3118 (let ((parsed (ange-ftp-ftp-name filename)))
3119 (if parsed
3120 (let* ((host (nth 0 parsed))
3121 (user (nth 1 parsed))
3122 (name (ange-ftp-quote-string (nth 2 parsed)))
3123 (temp (ange-ftp-make-tmp-name host))
3124 ;; What we REALLY need here is a way to determine if the mode
3125 ;; of the transfer is irrelevant, i.e. we can use binary mode
3126 ;; regardless. Maybe a system-type to host-type lookup?
3127 (binary (or (ange-ftp-binary-file filename)
3128 (memq (ange-ftp-host-type host user)
3129 '(unix dumb-unix))))
3130 (cmd (if append 'append 'put))
3131 (abbr (ange-ftp-abbreviate-filename filename))
3132 ;; we need to reset `last-coding-system-used' to its
3133 ;; value immediately after calling the real write-region,
3134 ;; so that `basic-save-buffer' doesn't see whatever value
3135 ;; might be used when communicating with the ftp process.
3136 (coding-system-used last-coding-system-used))
3137 (unwind-protect
3138 (progn
3139 (let ((executing-kbd-macro t)
3140 (filename (buffer-file-name))
3141 (mod-p (buffer-modified-p)))
3142 (unwind-protect
3143 (ange-ftp-real-write-region start end temp nil visit)
3144 ;; cleanup forms
3145 (setq buffer-file-name filename)
3146 (set-buffer-modified-p mod-p)))
3147 ;; save value used by the real write-region
3148 (setq coding-system-used last-coding-system-used)
3149 (if binary
3150 (ange-ftp-set-binary-mode host user))
3151
3152 ;; tell the process filter what size the transfer will be.
3153 (let ((attr (file-attributes temp)))
3154 (if attr
3155 (ange-ftp-set-xfer-size host user (nth 7 attr))))
3156
3157 ;; put or append the file.
3158 (let ((result (ange-ftp-send-cmd host user
3159 (list cmd temp name)
3160 (format "Writing %s" abbr))))
3161 (or (car result)
3162 (signal 'ftp-error
3163 (list
3164 "Opening output file"
3165 (format "FTP Error: \"%s\"" (cdr result))
3166 filename)))))
3167 (ange-ftp-del-tmp-name temp)
3168 (if binary
3169 (ange-ftp-set-ascii-mode host user)))
3170 (if (eq visit t)
3171 (progn
3172 (set-visited-file-modtime '(0 0))
3173 (ange-ftp-set-buffer-mode)
3174 (setq buffer-file-name filename)
3175 (set-buffer-modified-p nil)))
3176 ;; ensure `last-coding-system-used' has an appropriate value
3177 (setq last-coding-system-used coding-system-used)
3178 (ange-ftp-message "Wrote %s" abbr)
3179 (ange-ftp-add-file-entry filename))
3180 (ange-ftp-real-write-region start end filename append visit))))
3181
3182(defun ange-ftp-insert-file-contents (filename &optional visit beg end replace)
3183 (barf-if-buffer-read-only)
3184 (setq filename (expand-file-name filename))
3185 (let ((parsed (ange-ftp-ftp-name filename)))
3186 (if parsed
3187 (progn
3188 (if visit
3189 (setq buffer-file-name filename))
3190 (if (or (file-exists-p filename)
3191 (progn
3192 (setq ange-ftp-ls-cache-file nil)
3193 (ange-ftp-del-hash-entry (file-name-directory filename)
3194 ange-ftp-files-hashtable)
3195 (file-exists-p filename)))
3196 (let* ((host (nth 0 parsed))
3197 (user (nth 1 parsed))
3198 (name (ange-ftp-quote-string (nth 2 parsed)))
3199 (temp (ange-ftp-make-tmp-name host))
3200 (binary (or (ange-ftp-binary-file filename)
3201 (memq (ange-ftp-host-type host user)
3202 '(unix dumb-unix))))
3203 (abbr (ange-ftp-abbreviate-filename filename))
3204 (coding-system-used last-coding-system-used)
3205 size)
3206 (unwind-protect
3207 (progn
3208 (if binary
3209 (ange-ftp-set-binary-mode host user))
3210 (let ((result (ange-ftp-send-cmd host user
3211 (list 'get name temp)
3212 (format "Retrieving %s" abbr))))
3213 (or (car result)
3214 (signal 'ftp-error
3215 (list
3216 "Opening input file"
3217 (format "FTP Error: \"%s\"" (cdr result))
3218 filename))))
3219 (if (or (ange-ftp-real-file-readable-p temp)
3220 (sleep-for ange-ftp-retry-time)
3221 ;; Wait for file to hopefully appear.
3222 (ange-ftp-real-file-readable-p temp))
3223 (setq
3224 size
3225 (nth 1 (ange-ftp-real-insert-file-contents
3226 temp visit beg end replace))
3227 coding-system-used last-coding-system-used
3228 ;; override autodetection of buffer file type
3229 ;; to ensure buffer is saved in DOS format
3230 buffer-file-type binary)
3231 (signal 'ftp-error
3232 (list
3233 "Opening input file:"
3234 (format
3235 "FTP Error: %s not arrived or readable"
3236 filename)))))
3237 (if binary
3238 ;; We must keep `last-coding-system-used'
3239 ;; unchanged.
3240 (let (last-coding-system-used)
3241 (ange-ftp-set-ascii-mode host user)))
3242 (ange-ftp-del-tmp-name temp))
3243 (if visit
3244 (progn
3245 (set-visited-file-modtime '(0 0))
3246 (setq buffer-file-name filename)))
3247 (setq last-coding-system-used coding-system-used)
3248 (list filename size))
3249 (signal 'file-error
3250 (list
3251 "Opening input file"
3252 filename))))
3253 (ange-ftp-real-insert-file-contents filename visit beg end replace))))
3254
3255(defun ange-ftp-expand-symlink (file dir)
3256 (if (file-name-absolute-p file)
3257 (ange-ftp-replace-name-component dir file)
3258 (expand-file-name file dir)))
3259
3260(defun ange-ftp-file-symlink-p (file)
3261 ;; call ange-ftp-expand-file-name rather than the normal
3262 ;; expand-file-name to stop loops when using a package that
3263 ;; redefines both file-symlink-p and expand-file-name.
3264 (setq file (ange-ftp-expand-file-name file))
3265 (if (ange-ftp-ftp-name file)
3266 (let ((file-ent
3267 (ange-ftp-get-hash-entry
3268 (ange-ftp-get-file-part file)
3269 (ange-ftp-get-files (file-name-directory file)))))
3270 (if (stringp file-ent)
3271 (if (file-name-absolute-p file-ent)
3272 (ange-ftp-replace-name-component
3273 (file-name-directory file) file-ent)
3274 file-ent)))
3275 (ange-ftp-real-file-symlink-p file)))
3276
3277(defun ange-ftp-file-exists-p (name)
3278 (setq name (expand-file-name name))
3279 (if (ange-ftp-ftp-name name)
3280 (if (ange-ftp-file-entry-p name)
3281 (let ((file-ent (ange-ftp-get-file-entry name)))
3282 (if (stringp file-ent)
3283 (file-exists-p
3284 (ange-ftp-expand-symlink file-ent
3285 (file-name-directory
3286 (directory-file-name name))))
3287 t)))
3288 (ange-ftp-real-file-exists-p name)))
3289
3290(defun ange-ftp-file-directory-p (name)
3291 (setq name (expand-file-name name))
3292 (if (ange-ftp-ftp-name name)
3293 ;; We do a file-name-as-directory on name here because some
3294 ;; machines (VMS) use a .DIR to indicate the filename associated
3295 ;; with a directory. This needs to be canonicalized.
3296 (let ((file-ent (ange-ftp-get-file-entry
3297 (ange-ftp-file-name-as-directory name))))
3298 (if (stringp file-ent)
3299 (file-directory-p
3300 (ange-ftp-expand-symlink file-ent
3301 (file-name-directory
3302 (directory-file-name name))))
3303 file-ent))
3304 (ange-ftp-real-file-directory-p name)))
3305
3306(defun ange-ftp-directory-files (directory &optional full match
3307 &rest v19-args)
3308 (setq directory (expand-file-name directory))
3309 (if (ange-ftp-ftp-name directory)
3310 (progn
3311 (ange-ftp-barf-if-not-directory directory)
3312 (let ((tail (ange-ftp-hash-table-keys
3313 (ange-ftp-get-files directory)))
3314 files f)
3315 (setq directory (file-name-as-directory directory))
3316 (save-match-data
3317 (while tail
3318 (setq f (car tail)
3319 tail (cdr tail))
3320 (if (or (not match) (string-match match f))
3321 (setq files
3322 (cons (if full (concat directory f) f) files)))))
3323 (nreverse files)))
3324 (apply 'ange-ftp-real-directory-files directory full match v19-args)))
3325
3326(defun ange-ftp-file-attributes (file)
3327 (setq file (expand-file-name file))
3328 (let ((parsed (ange-ftp-ftp-name file)))
3329 (if parsed
3330 (let ((part (ange-ftp-get-file-part file))
3331 (files (ange-ftp-get-files (file-name-directory file))))
3332 (if (ange-ftp-hash-entry-exists-p part files)
3333 (let ((host (nth 0 parsed))
3334 (user (nth 1 parsed))
3335 (name (nth 2 parsed))
3336 (dirp (ange-ftp-get-hash-entry part files))
3337 (inode (ange-ftp-get-hash-entry
3338 file ange-ftp-inodes-hashtable)))
3339 (unless inode
3340 (setq inode ange-ftp-next-inode-number
3341 ange-ftp-next-inode-number (1+ inode))
3342 (ange-ftp-put-hash-entry file inode ange-ftp-inodes-hashtable))
3343 (list (if (and (stringp dirp) (file-name-absolute-p dirp))
3344 (ange-ftp-expand-symlink dirp
3345 (file-name-directory file))
3346 dirp) ;0 file type
3347 -1 ;1 link count
3348 -1 ;2 uid
3349 -1 ;3 gid
3350 '(0 0) ;4 atime
3351 '(0 0) ;5 mtime
3352 '(0 0) ;6 ctime
3353 -1 ;7 size
3354 (concat (if (stringp dirp) "l" (if dirp "d" "-"))
3355 "?????????") ;8 mode
3356 nil ;9 gid weird
3357 inode ;10 "inode number".
3358 -1 ;11 device number [v19 only]
3359 ))))
3360 (ange-ftp-real-file-attributes file))))
3361
3362(defun ange-ftp-file-writable-p (file)
3363 (setq file (expand-file-name file))
3364 (if (ange-ftp-ftp-name file)
3365 (or (file-exists-p file) ;guess here for speed
3366 (file-directory-p (file-name-directory file)))
3367 (ange-ftp-real-file-writable-p file)))
3368
3369(defun ange-ftp-file-readable-p (file)
3370 (setq file (expand-file-name file))
3371 (if (ange-ftp-ftp-name file)
3372 (file-exists-p file)
3373 (ange-ftp-real-file-readable-p file)))
3374
3375(defun ange-ftp-file-executable-p (file)
3376 (setq file (expand-file-name file))
3377 (if (ange-ftp-ftp-name file)
3378 (file-exists-p file)
3379 (ange-ftp-real-file-executable-p file)))
3380
3381(defun ange-ftp-delete-file (file)
3382 (interactive "fDelete file: ")
3383 (setq file (expand-file-name file))
3384 (let ((parsed (ange-ftp-ftp-name file)))
3385 (if parsed
3386 (let* ((host (nth 0 parsed))
3387 (user (nth 1 parsed))
3388 (name (ange-ftp-quote-string (nth 2 parsed)))
3389 (abbr (ange-ftp-abbreviate-filename file))
3390 (result (ange-ftp-send-cmd host user
3391 (list 'delete name)
3392 (format "Deleting %s" abbr))))
3393 (or (car result)
3394 (signal 'ftp-error
3395 (list
3396 "Removing old name"
3397 (format "FTP Error: \"%s\"" (cdr result))
3398 file)))
3399 (ange-ftp-delete-file-entry file))
3400 (ange-ftp-real-delete-file file))))
3401
3402(defun ange-ftp-verify-visited-file-modtime (buf)
3403 (let ((name (buffer-file-name buf)))
3404 (if (and (stringp name) (ange-ftp-ftp-name name))
3405 t
3406 (ange-ftp-real-verify-visited-file-modtime buf))))
3407
3408;;;; ------------------------------------------------------------
3409;;;; File copying support... totally re-written 6/24/92.
3410;;;; ------------------------------------------------------------
3411
3412(defun ange-ftp-barf-or-query-if-file-exists (absname querystring interactive)
3413 (if (file-exists-p absname)
3414 (if (not interactive)
3415 (signal 'file-already-exists (list absname))
3416 (if (not (yes-or-no-p (format "File %s already exists; %s anyway? "
3417 absname querystring)))
3418 (signal 'file-already-exists (list absname))))))
3419
3420;; async local copy commented out for now since I don't seem to get
3421;; the process sentinel called for some processes.
3422;;
3423;; (defun ange-ftp-copy-file-locally (filename newname ok-if-already-exists
3424;; keep-date cont)
3425;; "Kludge to copy a local file and call a continuation when the copy
3426;; finishes."
3427;; ;; check to see if we can overwrite
3428;; (if (or (not ok-if-already-exists)
3429;; (numberp ok-if-already-exists))
3430;; (ange-ftp-barf-or-query-if-file-exists newname "copy to it"
3431;; (numberp ok-if-already-exists)))
3432;; (let ((proc (start-process " *copy*"
3433;; (generate-new-buffer "*copy*")
3434;; "cp"
3435;; filename
3436;; newname))
3437;; res)
3438;; (set-process-sentinel proc (function ange-ftp-copy-file-locally-sentinel))
3439;; (process-kill-without-query proc)
3440;; (save-excursion
3441;; (set-buffer (process-buffer proc))
3442;; (make-variable-buffer-local 'copy-cont)
3443;; (setq copy-cont cont))))
3444;;
3445;; (defun ange-ftp-copy-file-locally-sentinel (proc status)
3446;; (save-excursion
3447;; (set-buffer (process-buffer proc))
3448;; (let ((cont copy-cont)
3449;; (result (buffer-string)))
3450;; (unwind-protect
3451;; (if (and (string-equal status "finished\n")
3452;; (zerop (length result)))
3453;; (ange-ftp-call-cont cont t nil)
3454;; (ange-ftp-call-cont cont
3455;; nil
3456;; (if (zerop (length result))
3457;; (substring status 0 -1)
3458;; (substring result 0 -1))))
3459;; (kill-buffer (current-buffer))))))
3460
3461;; this is the extended version of ange-ftp-copy-file-internal that works
3462;; asynchronously if asked nicely.
3463(defun ange-ftp-copy-file-internal (filename newname ok-if-already-exists
3464 keep-date &optional msg cont nowait)
3465 (setq filename (expand-file-name filename)
3466 newname (expand-file-name newname))
3467
3468 ;; canonicalize newname if a directory.
3469 (if (file-directory-p newname)
3470 (setq newname (expand-file-name (file-name-nondirectory filename) newname)))
3471
3472 (let ((f-parsed (ange-ftp-ftp-name filename))
3473 (t-parsed (ange-ftp-ftp-name newname)))
3474
3475 ;; local file to local file copy?
3476 (if (and (not f-parsed) (not t-parsed))
3477 (progn
3478 (ange-ftp-real-copy-file filename newname ok-if-already-exists
3479 keep-date)
3480 (if cont
3481 (ange-ftp-call-cont cont t "Copied locally")))
3482 ;; one or both files are remote.
3483 (let* ((f-host (and f-parsed (nth 0 f-parsed)))
3484 (f-user (and f-parsed (nth 1 f-parsed)))
3485 (f-name (and f-parsed (ange-ftp-quote-string (nth 2 f-parsed))))
3486 (f-abbr (ange-ftp-abbreviate-filename filename))
3487 (t-host (and t-parsed (nth 0 t-parsed)))
3488 (t-user (and t-parsed (nth 1 t-parsed)))
3489 (t-name (and t-parsed (ange-ftp-quote-string (nth 2 t-parsed))))
3490 (t-abbr (ange-ftp-abbreviate-filename newname filename))
3491 (binary (or (ange-ftp-binary-file filename)
3492 (ange-ftp-binary-file newname)
3493 (and (memq (ange-ftp-host-type f-host f-user)
3494 '(unix dumb-unix))
3495 (memq (ange-ftp-host-type t-host t-user)
3496 '(unix dumb-unix)))))
3497 temp1
3498 temp2)
3499
3500 ;; check to see if we can overwrite
3501 (if (or (not ok-if-already-exists)
3502 (numberp ok-if-already-exists))
3503 (ange-ftp-barf-or-query-if-file-exists newname "copy to it"
3504 (numberp ok-if-already-exists)))
3505
3506 ;; do the copying.
3507 (if f-parsed
3508
3509 ;; filename was remote.
3510 (progn
3511 (if (or (ange-ftp-use-gateway-p f-host)
3512 t-parsed)
3513 ;; have to use intermediate file if we are getting via
3514 ;; gateway machine or we are doing a remote to remote copy.
3515 (setq temp1 (ange-ftp-make-tmp-name f-host)))
3516
3517 (if binary
3518 (ange-ftp-set-binary-mode f-host f-user))
3519
3520 (ange-ftp-send-cmd
3521 f-host
3522 f-user
3523 (list 'get f-name (or temp1 (ange-ftp-quote-string newname)))
3524 (or msg
3525 (if (and temp1 t-parsed)
3526 (format "Getting %s" f-abbr)
3527 (format "Copying %s to %s" f-abbr t-abbr)))
3528 (list (function ange-ftp-cf1)
3529 filename newname binary msg
3530 f-parsed f-host f-user f-name f-abbr
3531 t-parsed t-host t-user t-name t-abbr
3532 temp1 temp2 cont nowait)
3533 nowait))
3534
3535 ;; filename wasn't remote. newname must be remote. call the
3536 ;; function which does the remainder of the copying work.
3537 (ange-ftp-cf1 t nil
3538 filename newname binary msg
3539 f-parsed f-host f-user f-name f-abbr
3540 t-parsed t-host t-user t-name t-abbr
3541 nil nil cont nowait))))))
3542
3543(defvar ange-ftp-waiting-flag nil)
3544
3545;; next part of copying routine.
3546(defun ange-ftp-cf1 (result line
3547 filename newname binary msg
3548 f-parsed f-host f-user f-name f-abbr
3549 t-parsed t-host t-user t-name t-abbr
3550 temp1 temp2 cont nowait)
3551 (if line
3552 ;; filename must have been remote, and we must have just done a GET.
3553 (unwind-protect
3554 (or result
3555 ;; GET failed for some reason. Clean up and get out.
3556 (progn
3557 (and temp1 (ange-ftp-del-tmp-name temp1))
3558 (or cont
3559 (if ange-ftp-waiting-flag
3560 (throw 'ftp-error t)
3561 (signal 'ftp-error
3562 (list "Opening input file"
3563 (format "FTP Error: \"%s\"" line)
3564 filename))))))
3565 ;; cleanup
3566 (if binary
3567 (ange-ftp-set-ascii-mode f-host f-user))))
3568
3569 (if result
3570 ;; We now have to copy either temp1 or filename to newname.
3571 (if t-parsed
3572
3573 ;; newname was remote.
3574 (progn
3575 (if (ange-ftp-use-gateway-p t-host)
3576 (setq temp2 (ange-ftp-make-tmp-name t-host)))
3577
3578 ;; make sure data is moved into the right place for the
3579 ;; outgoing transfer. gateway temporary files complicate
3580 ;; things nicely.
3581 (if temp1
3582 (if temp2
3583 (if (string-equal temp1 temp2)
3584 (setq temp1 nil)
3585 (ange-ftp-real-copy-file temp1 temp2 t))
3586 (setq temp2 temp1 temp1 nil))
3587 (if temp2
3588 (ange-ftp-real-copy-file filename temp2 t)))
3589
3590 (if binary
3591 (ange-ftp-set-binary-mode t-host t-user))
3592
3593 ;; tell the process filter what size the file is.
3594 (let ((attr (file-attributes (or temp2 filename))))
3595 (if attr
3596 (ange-ftp-set-xfer-size t-host t-user (nth 7 attr))))
3597
3598 (ange-ftp-send-cmd
3599 t-host
3600 t-user
3601 (list 'put (or temp2 filename) t-name)
3602 (or msg
3603 (if (and temp2 f-parsed)
3604 (format "Putting %s" newname)
3605 (format "Copying %s to %s" f-abbr t-abbr)))
3606 (list (function ange-ftp-cf2)
3607 newname t-host t-user binary temp1 temp2 cont)
3608 nowait))
3609
3610 ;; newname wasn't remote.
3611 (ange-ftp-cf2 t nil newname t-host t-user binary temp1 temp2 cont))
3612
3613 ;; first copy failed, tell caller
3614 (ange-ftp-call-cont cont result line)))
3615
3616;; last part of copying routine.
3617(defun ange-ftp-cf2 (result line newname t-host t-user binary temp1 temp2 cont)
3618 (unwind-protect
3619 (if line
3620 ;; result from doing a local to remote copy.
3621 (unwind-protect
3622 (progn
3623 (or result
3624 (or cont
3625 (if ange-ftp-waiting-flag
3626 (throw 'ftp-error t)
3627 (signal 'ftp-error
3628 (list "Opening output file"
3629 (format "FTP Error: \"%s\"" line)
3630 newname)))))
3631
3632 (ange-ftp-add-file-entry newname))
3633
3634 ;; cleanup.
3635 (if binary
3636 (ange-ftp-set-ascii-mode t-host t-user)))
3637
3638 ;; newname was local.
3639 (if temp1
3640 (ange-ftp-real-copy-file temp1 newname t)))
3641
3642 ;; clean up
3643 (and temp1 (ange-ftp-del-tmp-name temp1))
3644 (and temp2 (ange-ftp-del-tmp-name temp2))
3645 (ange-ftp-call-cont cont result line)))
3646
3647(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists
3648 keep-date)
3649 (interactive "fCopy file: \nFCopy %s to file: \np")
3650 (ange-ftp-copy-file-internal filename
3651 newname
3652 ok-if-already-exists
3653 keep-date
3654 nil
3655 nil
3656 (interactive-p)))
3657
3658;;;; ------------------------------------------------------------
3659;;;; File renaming support.
3660;;;; ------------------------------------------------------------
3661
3662(defun ange-ftp-rename-remote-to-remote (filename newname f-parsed t-parsed)
3663 "Rename remote file FILE to remote file NEWNAME."
3664 (let ((f-host (nth 0 f-parsed))
3665 (f-user (nth 1 f-parsed))
3666 (t-host (nth 0 t-parsed))
3667 (t-user (nth 1 t-parsed)))
3668 (if (and (string-equal f-host t-host)
3669 (string-equal f-user t-user))
3670 (let* ((f-name (ange-ftp-quote-string (nth 2 f-parsed)))
3671 (t-name (ange-ftp-quote-string (nth 2 t-parsed)))
3672 (cmd (list 'rename f-name t-name))
3673 (fabbr (ange-ftp-abbreviate-filename filename))
3674 (nabbr (ange-ftp-abbreviate-filename newname filename))
3675 (result (ange-ftp-send-cmd f-host f-user cmd
3676 (format "Renaming %s to %s"
3677 fabbr
3678 nabbr))))
3679 (or (car result)
3680 (signal 'ftp-error
3681 (list
3682 "Renaming"
3683 (format "FTP Error: \"%s\"" (cdr result))
3684 filename
3685 newname)))
3686 (ange-ftp-add-file-entry newname)
3687 (ange-ftp-delete-file-entry filename))
3688 (ange-ftp-copy-file-internal filename newname t nil)
3689 (delete-file filename))))
3690
3691(defun ange-ftp-rename-local-to-remote (filename newname)
3692 "Rename local FILENAME to remote file NEWNAME."
3693 (let* ((fabbr (ange-ftp-abbreviate-filename filename))
3694 (nabbr (ange-ftp-abbreviate-filename newname filename))
3695 (msg (format "Renaming %s to %s" fabbr nabbr)))
3696 (ange-ftp-copy-file-internal filename newname t nil msg)
3697 (let (ange-ftp-process-verbose)
3698 (delete-file filename))))
3699
3700(defun ange-ftp-rename-remote-to-local (filename newname)
3701 "Rename remote file FILENAME to local file NEWNAME."
3702 (let* ((fabbr (ange-ftp-abbreviate-filename filename))
3703 (nabbr (ange-ftp-abbreviate-filename newname filename))
3704 (msg (format "Renaming %s to %s" fabbr nabbr)))
3705 (ange-ftp-copy-file-internal filename newname t nil msg)
3706 (let (ange-ftp-process-verbose)
3707 (delete-file filename))))
3708
3709(defun ange-ftp-rename-file (filename newname &optional ok-if-already-exists)
3710 (interactive "fRename file: \nFRename %s to file: \np")
3711 (setq filename (expand-file-name filename))
3712 (setq newname (expand-file-name newname))
3713 (let* ((f-parsed (ange-ftp-ftp-name filename))
3714 (t-parsed (ange-ftp-ftp-name newname)))
3715 (if (and (or f-parsed t-parsed)
3716 (or (not ok-if-already-exists)
3717 (numberp ok-if-already-exists)))
3718 (ange-ftp-barf-or-query-if-file-exists
3719 newname
3720 "rename to it"
3721 (numberp ok-if-already-exists)))
3722 (if f-parsed
3723 (if t-parsed
3724 (ange-ftp-rename-remote-to-remote filename newname f-parsed
3725 t-parsed)
3726 (ange-ftp-rename-remote-to-local filename newname))
3727 (if t-parsed
3728 (ange-ftp-rename-local-to-remote filename newname)
3729 (ange-ftp-real-rename-file filename newname ok-if-already-exists)))))
3730
3731;;;; ------------------------------------------------------------
3732;;;; File name completion support.
3733;;;; ------------------------------------------------------------
3734
3735;; If the file entry SYM is a symlink, returns whether its file exists.
3736;; Note that `ange-ftp-this-dir' is used as a free variable.
3737(defun ange-ftp-file-entry-active-p (sym)
3738 (let ((val (get sym 'val)))
3739 (or (not (stringp val))
3740 (file-exists-p (ange-ftp-expand-symlink val ange-ftp-this-dir)))))
3741
3742;; If the file entry is not a directory (nor a symlink pointing to a directory)
3743;; returns whether the file (or file pointed to by the symlink) is ignored
3744;; by completion-ignored-extensions.
3745;; Note that `ange-ftp-this-dir' and `ange-ftp-completion-ignored-pattern'
3746;; are used as free variables.
3747(defun ange-ftp-file-entry-not-ignored-p (sym)
3748 (let ((val (get sym 'val))
3749 (symname (symbol-name sym)))
3750 (if (stringp val)
3751 (let ((file (ange-ftp-expand-symlink val ange-ftp-this-dir)))
3752 (or (file-directory-p file)
3753 (and (file-exists-p file)
3754 (not (string-match ange-ftp-completion-ignored-pattern
3755 symname)))))
3756 (or val ; is a directory name
3757 (not (string-match ange-ftp-completion-ignored-pattern symname))))))
3758
3759(defun ange-ftp-file-name-all-completions (file dir)
3760 (let ((ange-ftp-this-dir (expand-file-name dir)))
3761 (if (ange-ftp-ftp-name ange-ftp-this-dir)
3762 (progn
3763 (ange-ftp-barf-if-not-directory ange-ftp-this-dir)
3764 (setq ange-ftp-this-dir
3765 (ange-ftp-real-file-name-as-directory ange-ftp-this-dir))
3766 (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))
3767 (completions
3768 (all-completions file tbl
3769 (function ange-ftp-file-entry-active-p))))
3770
3771 ;; see whether each matching file is a directory or not...
3772 (mapcar
3773 (function
3774 (lambda (file)
3775 (let ((ent (ange-ftp-get-hash-entry file tbl)))
3776 (if (and ent
3777 (or (not (stringp ent))
3778 (file-directory-p
3779 (ange-ftp-expand-symlink ent
3780 ange-ftp-this-dir))))
3781 (concat file "/")
3782 file))))
3783 completions)))
3784
3785 (if (or (and (eq system-type 'windows-nt)
3786 (string-match "^[a-zA-Z]:[/\\]$" ange-ftp-this-dir))
3787 (string-equal "/" ange-ftp-this-dir))
3788 (nconc (all-completions file (ange-ftp-generate-root-prefixes))
3789 (ange-ftp-real-file-name-all-completions file
3790 ange-ftp-this-dir))
3791 (ange-ftp-real-file-name-all-completions file ange-ftp-this-dir)))))
3792
3793(defun ange-ftp-file-name-completion (file dir)
3794 (let ((ange-ftp-this-dir (expand-file-name dir)))
3795 (if (ange-ftp-ftp-name ange-ftp-this-dir)
3796 (progn
3797 (ange-ftp-barf-if-not-directory ange-ftp-this-dir)
3798 (if (equal file "")
3799 ""
3800 (setq ange-ftp-this-dir
3801 (ange-ftp-real-file-name-as-directory ange-ftp-this-dir)) ;real?
3802 (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))
3803 (ange-ftp-completion-ignored-pattern
3804 (mapconcat (function
3805 (lambda (s) (if (stringp s)
3806 (concat (regexp-quote s) "$")
3807 "/"))) ; / never in filename
3808 completion-ignored-extensions
3809 "\\|")))
3810 (save-match-data
3811 (or (ange-ftp-file-name-completion-1
3812 file tbl ange-ftp-this-dir
3813 (function ange-ftp-file-entry-not-ignored-p))
3814 (ange-ftp-file-name-completion-1
3815 file tbl ange-ftp-this-dir
3816 (function ange-ftp-file-entry-active-p)))))))
3817
3818 (if (or (and (eq system-type 'windows-nt)
3819 (string-match "^[a-zA-Z]:[/\\]$" ange-ftp-this-dir))
3820 (string-equal "/" ange-ftp-this-dir))
3821 (try-completion
3822 file
3823 (nconc (ange-ftp-generate-root-prefixes)
3824 (mapcar 'list
3825 (ange-ftp-real-file-name-all-completions
3826 file ange-ftp-this-dir))))
3827 (ange-ftp-real-file-name-completion file ange-ftp-this-dir)))))
3828
3829
3830(defun ange-ftp-file-name-completion-1 (file tbl dir predicate)
3831 (let ((bestmatch (try-completion file tbl predicate)))
3832 (if bestmatch
3833 (if (eq bestmatch t)
3834 (if (file-directory-p (expand-file-name file dir))
3835 (concat file "/")
3836 t)
3837 (if (and (eq (try-completion bestmatch tbl predicate) t)
3838 (file-directory-p
3839 (expand-file-name bestmatch dir)))
3840 (concat bestmatch "/")
3841 bestmatch)))))
3842
3843;; Put these lines uncommmented in your .emacs if you want C-r to refresh
3844;; ange-ftp's cache whilst doing filename completion.
3845;;
3846;;(define-key minibuffer-local-completion-map "\C-r" 'ange-ftp-re-read-dir)
3847;;(define-key minibuffer-local-must-match-map "\C-r" 'ange-ftp-re-read-dir)
3848
3849;; The autoload cookie is to make sure the doc is always available.
3850;;;###autoload (defalias 'ange-ftp-re-read-dir 'ange-ftp-reread-dir)
3851;;;###autoload
3852(defun ange-ftp-reread-dir (&optional dir)
3853 "Reread remote directory DIR to update the directory cache.
3854The implementation of remote ftp file names caches directory contents
3855for speed. Therefore, when new remote files are created, Emacs
3856may not know they exist. You can use this command to reread a specific
3857directory, so that Emacs will know its current contents."
3858 (interactive)
3859 (if dir
3860 (setq dir (expand-file-name dir))
3861 (setq dir (file-name-directory (expand-file-name (buffer-string)))))
3862 (if (ange-ftp-ftp-name dir)
3863 (progn
3864 (setq ange-ftp-ls-cache-file nil)
3865 (ange-ftp-del-hash-entry dir ange-ftp-files-hashtable)
3866 (ange-ftp-get-files dir t))))
3867
3868(defun ange-ftp-make-directory (dir &optional parents)
3869 (interactive (list (expand-file-name (read-file-name "Make directory: "))))
3870 (if parents
3871 (let ((parent (file-name-directory (directory-file-name dir))))
3872 (or (file-exists-p parent)
3873 (ange-ftp-make-directory parent parents))))
3874 (if (file-exists-p dir)
3875 (error "Cannot make directory %s: file already exists" dir)
3876 (let ((parsed (ange-ftp-ftp-name dir)))
3877 (if parsed
3878 (let* ((host (nth 0 parsed))
3879 (user (nth 1 parsed))
3880 ;; Some ftp's on unix machines (at least on Suns)
3881 ;; insist that mkdir take a filename, and not a
3882 ;; directory-name name as an arg. Argh!! This is a bug.
3883 ;; Non-unix machines will probably always insist
3884 ;; that mkdir takes a directory-name as an arg
3885 ;; (as the ftp man page says it should).
3886 (name (ange-ftp-quote-string
3887 (if (eq (ange-ftp-host-type host) 'unix)
3888 (ange-ftp-real-directory-file-name (nth 2 parsed))
3889 (ange-ftp-real-file-name-as-directory
3890 (nth 2 parsed)))))
3891 (abbr (ange-ftp-abbreviate-filename dir))
3892 (result (ange-ftp-send-cmd host user
3893 (list 'mkdir name)
3894 (format "Making directory %s"
3895 abbr))))
3896 (or (car result)
3897 (ange-ftp-error host user
3898 (format "Could not make directory %s: %s"
3899 dir
3900 (cdr result))))
3901 (ange-ftp-add-file-entry dir t))
3902 (ange-ftp-real-make-directory dir)))))
3903
3904(defun ange-ftp-delete-directory (dir)
3905 (if (file-directory-p dir)
3906 (let ((parsed (ange-ftp-ftp-name dir)))
3907 (if parsed
3908 (let* ((host (nth 0 parsed))
3909 (user (nth 1 parsed))
3910 ;; Some ftp's on unix machines (at least on Suns)
3911 ;; insist that rmdir take a filename, and not a
3912 ;; directory-name name as an arg. Argh!! This is a bug.
3913 ;; Non-unix machines will probably always insist
3914 ;; that rmdir takes a directory-name as an arg
3915 ;; (as the ftp man page says it should).
3916 (name (ange-ftp-quote-string
3917 (if (eq (ange-ftp-host-type host) 'unix)
3918 (ange-ftp-real-directory-file-name
3919 (nth 2 parsed))
3920 (ange-ftp-real-file-name-as-directory
3921 (nth 2 parsed)))))
3922 (abbr (ange-ftp-abbreviate-filename dir))
3923 (result (ange-ftp-send-cmd host user
3924 (list 'rmdir name)
3925 (format "Removing directory %s"
3926 abbr))))
3927 (or (car result)
3928 (ange-ftp-error host user
3929 (format "Could not remove directory %s: %s"
3930 dir
3931 (cdr result))))
3932 (ange-ftp-delete-file-entry dir t))
3933 (ange-ftp-real-delete-directory dir)))
3934 (error "Not a directory: %s" dir)))
3935
3936;; Make a local copy of FILE and return its name.
3937
3938(defun ange-ftp-file-local-copy (file)
3939 (let* ((fn1 (expand-file-name file))
3940 (pa1 (ange-ftp-ftp-name fn1)))
3941 (if pa1
3942 (let ((tmp1 (ange-ftp-make-tmp-name (car pa1))))
3943 (ange-ftp-copy-file-internal fn1 tmp1 t nil
3944 (format "Getting %s" fn1))
3945 tmp1))))
3946
3947(defun ange-ftp-load (file &optional noerror nomessage nosuffix)
3948 (if (ange-ftp-ftp-name file)
3949 (let ((tryfiles (if nosuffix
3950 (list file)
3951 (list (concat file ".elc") (concat file ".el") file)))
3952 ;; make sure there are no references to temp files
3953 (load-force-doc-strings t)
3954 copy)
3955 (while (and tryfiles (not copy))
3956 (catch 'ftp-error
3957 (let ((ange-ftp-waiting-flag t))
3958 (condition-case error
3959 (setq copy (ange-ftp-file-local-copy (car tryfiles)))
3960 (ftp-error nil))))
3961 (setq tryfiles (cdr tryfiles)))
3962 (if copy
3963 (unwind-protect
3964 (funcall 'load copy noerror nomessage nosuffix)
3965 (delete-file copy))
3966 (or noerror
3967 (signal 'file-error (list "Cannot open load file" file)))
3968 nil))
3969 (ange-ftp-real-load file noerror nomessage nosuffix)))
3970
3971;; Calculate default-unhandled-directory for a given ange-ftp buffer.
3972(defun ange-ftp-unhandled-file-name-directory (filename)
3973 (file-name-directory ange-ftp-tmp-name-template))
3974
3975
3976;; Need the following functions for making filenames of compressed
3977;; files, because some OS's (unlike UNIX) do not allow a filename to
3978;; have two extensions.
3979
3980(defvar ange-ftp-make-compressed-filename-alist nil
3981 "Alist of host-type-specific functions to process file names for compression.
3982Each element has the form (TYPE . FUNC).
3983FUNC should take one argument, a file name, and return a list
3984of the form (COMPRESSING NEWNAME).
3985COMPRESSING should be t if the specified file should be compressed,
3986and nil if it should be uncompressed (that is, if it is a compressed file).
3987NEWNAME should be the name to give the new compressed or uncompressed file.")
3988
3989(defun ange-ftp-dired-compress-file (name)
3990 (let ((parsed (ange-ftp-ftp-name name))
3991 conversion-func)
3992 (if (and parsed
3993 (setq conversion-func
3994 (cdr (assq (ange-ftp-host-type (car parsed))
3995 ange-ftp-make-compressed-filename-alist))))
3996 (let* ((decision
3997 (save-match-data (funcall conversion-func name)))
3998 (compressing (car decision))
3999 (newfile (nth 1 decision)))
4000 (if compressing
4001 (ange-ftp-compress name newfile)
4002 (ange-ftp-uncompress name newfile)))
4003 (let (file-name-handler-alist)
4004 (dired-compress-file name)))))
4005
4006;; Copy FILE to this machine, compress it, and copy out to NFILE.
4007(defun ange-ftp-compress (file nfile)
4008 (let* ((parsed (ange-ftp-ftp-name file))
4009 (tmp1 (ange-ftp-make-tmp-name (car parsed)))
4010 (tmp2 (ange-ftp-make-tmp-name (car parsed)))
4011 (abbr (ange-ftp-abbreviate-filename file))
4012 (nabbr (ange-ftp-abbreviate-filename nfile))
4013 (msg1 (format "Getting %s" abbr))
4014 (msg2 (format "Putting %s" nabbr)))
4015 (unwind-protect
4016 (progn
4017 (ange-ftp-copy-file-internal file tmp1 t nil msg1)
4018 (and ange-ftp-process-verbose
4019 (ange-ftp-message "Compressing %s..." abbr))
4020 (call-process-region (point)
4021 (point)
4022 shell-file-name
4023 nil
4024 t
4025 nil
4026 "-c"
4027 (format "compress -f -c < %s > %s" tmp1 tmp2))
4028 (and ange-ftp-process-verbose
4029 (ange-ftp-message "Compressing %s...done" abbr))
4030 (if (zerop (buffer-size))
4031 (progn
4032 (let (ange-ftp-process-verbose)
4033 (delete-file file))
4034 (ange-ftp-copy-file-internal tmp2 nfile t nil msg2))))
4035 (ange-ftp-del-tmp-name tmp1)
4036 (ange-ftp-del-tmp-name tmp2))))
4037
4038;; Copy FILE to this machine, uncompress it, and copy out to NFILE.
4039(defun ange-ftp-uncompress (file nfile)
4040 (let* ((parsed (ange-ftp-ftp-name file))
4041 (tmp1 (ange-ftp-make-tmp-name (car parsed)))
4042 (tmp2 (ange-ftp-make-tmp-name (car parsed)))
4043 (abbr (ange-ftp-abbreviate-filename file))
4044 (nabbr (ange-ftp-abbreviate-filename nfile))
4045 (msg1 (format "Getting %s" abbr))
4046 (msg2 (format "Putting %s" nabbr))
4047;; ;; Cheap hack because of problems with binary file transfers from
4048;; ;; VMS hosts.
4049;; (gbinary (not (eq 'vms (ange-ftp-host-type (car parsed)))))
4050 )
4051 (unwind-protect
4052 (progn
4053 (ange-ftp-copy-file-internal file tmp1 t nil msg1)
4054 (and ange-ftp-process-verbose
4055 (ange-ftp-message "Uncompressing %s..." abbr))
4056 (call-process-region (point)
4057 (point)
4058 shell-file-name
4059 nil
4060 t
4061 nil
4062 "-c"
4063 (format "uncompress -c < %s > %s" tmp1 tmp2))
4064 (and ange-ftp-process-verbose
4065 (ange-ftp-message "Uncompressing %s...done" abbr))
4066 (if (zerop (buffer-size))
4067 (progn
4068 (let (ange-ftp-process-verbose)
4069 (delete-file file))
4070 (ange-ftp-copy-file-internal tmp2 nfile t nil msg2))))
4071 (ange-ftp-del-tmp-name tmp1)
4072 (ange-ftp-del-tmp-name tmp2))))
4073
4074(defun ange-ftp-find-backup-file-name (fn)
4075 ;; Either return the ordinary backup name, etc.,
4076 ;; or return nil meaning don't make a backup.
4077 (if ange-ftp-make-backup-files
4078 (ange-ftp-real-find-backup-file-name fn)))
4079
4080;;; Define the handler for special file names
4081;;; that causes ange-ftp to be invoked.
4082
4083;;;###autoload
4084(defun ange-ftp-hook-function (operation &rest args)
4085 (let ((fn (get operation 'ange-ftp)))
4086 (if fn (apply fn args)
4087 (ange-ftp-run-real-handler operation args))))
4088
4089
4090;;; This regexp takes care of real ange-ftp file names (with a slash
4091;;; and colon).
4092;;; Don't allow the host name to end in a period--some systems use /.:
4093;;;###autoload
4094(or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist)
4095 (setq file-name-handler-alist
4096 (cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function)
4097 file-name-handler-alist)))
4098
4099;;; This regexp recognizes absolute filenames with only one component,
4100;;; for the sake of hostname completion.
4101;;;###autoload
4102(or (assoc "^/[^/:]*\\'" file-name-handler-alist)
4103 (setq file-name-handler-alist
4104 (cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function)
4105 file-name-handler-alist)))
4106
4107;;; This regexp recognizes absolute filenames with only one component
4108;;; on Windows, for the sake of hostname completion.
4109;;; NB. Do not mark this as autoload, because it is very common to
4110;;; do completions in the root directory of drives on Windows.
4111(and (memq system-type '(ms-dos windows-nt))
4112 (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist)
4113 (setq file-name-handler-alist
4114 (cons '("^[a-zA-Z]:/[^/:]*\\'" .
4115 ange-ftp-completion-hook-function)
4116 file-name-handler-alist))))
4117
4118;;; The above two forms are sufficient to cause this file to be loaded
4119;;; if the user ever uses a file name with a colon in it.
4120
4121;;; This sets the mode
4122(or (memq 'ange-ftp-set-buffer-mode find-file-hooks)
4123 (setq find-file-hooks
4124 (cons 'ange-ftp-set-buffer-mode find-file-hooks)))
4125
4126;;; Now say where to find the handlers for particular operations.
4127
4128(put 'file-name-directory 'ange-ftp 'ange-ftp-file-name-directory)
4129(put 'file-name-nondirectory 'ange-ftp 'ange-ftp-file-name-nondirectory)
4130(put 'file-name-as-directory 'ange-ftp 'ange-ftp-file-name-as-directory)
4131(put 'directory-file-name 'ange-ftp 'ange-ftp-directory-file-name)
4132(put 'expand-file-name 'ange-ftp 'ange-ftp-expand-file-name)
4133(put 'make-directory 'ange-ftp 'ange-ftp-make-directory)
4134(put 'delete-directory 'ange-ftp 'ange-ftp-delete-directory)
4135(put 'insert-file-contents 'ange-ftp 'ange-ftp-insert-file-contents)
4136(put 'directory-files 'ange-ftp 'ange-ftp-directory-files)
4137(put 'file-directory-p 'ange-ftp 'ange-ftp-file-directory-p)
4138(put 'file-writable-p 'ange-ftp 'ange-ftp-file-writable-p)
4139(put 'file-readable-p 'ange-ftp 'ange-ftp-file-readable-p)
4140(put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p)
4141(put 'file-symlink-p 'ange-ftp 'ange-ftp-file-symlink-p)
4142(put 'delete-file 'ange-ftp 'ange-ftp-delete-file)
4143(put 'read-file-name-internal 'ange-ftp 'ange-ftp-read-file-name-internal)
4144(put 'verify-visited-file-modtime 'ange-ftp
4145 'ange-ftp-verify-visited-file-modtime)
4146(put 'file-exists-p 'ange-ftp 'ange-ftp-file-exists-p)
4147(put 'write-region 'ange-ftp 'ange-ftp-write-region)
4148(put 'backup-buffer 'ange-ftp 'ange-ftp-backup-buffer)
4149(put 'copy-file 'ange-ftp 'ange-ftp-copy-file)
4150(put 'rename-file 'ange-ftp 'ange-ftp-rename-file)
4151(put 'file-attributes 'ange-ftp 'ange-ftp-file-attributes)
4152(put 'file-name-all-completions 'ange-ftp 'ange-ftp-file-name-all-completions)
4153(put 'file-name-completion 'ange-ftp 'ange-ftp-file-name-completion)
4154(put 'insert-directory 'ange-ftp 'ange-ftp-insert-directory)
4155(put 'file-local-copy 'ange-ftp 'ange-ftp-file-local-copy)
4156(put 'unhandled-file-name-directory 'ange-ftp
4157 'ange-ftp-unhandled-file-name-directory)
4158(put 'file-name-sans-versions 'ange-ftp 'ange-ftp-file-name-sans-versions)
4159(put 'dired-uncache 'ange-ftp 'ange-ftp-dired-uncache)
4160(put 'dired-compress-file 'ange-ftp 'ange-ftp-dired-compress-file)
4161(put 'load 'ange-ftp 'ange-ftp-load)
4162(put 'find-backup-file-name 'ange-ftp 'ange-ftp-find-backup-file-name)
4163
4164;; Turn off truename processing to save time.
4165;; Treat each name as its own truename.
4166(put 'file-truename 'ange-ftp 'identity)
4167
4168;; Turn off RCS/SCCS processing to save time.
4169;; This returns nil for any file name as argument.
4170(put 'vc-registered 'ange-ftp 'null)
4171
4172(put 'dired-call-process 'ange-ftp 'ange-ftp-dired-call-process)
4173(put 'shell-command 'ange-ftp 'ange-ftp-shell-command)
4174
4175;;; Define ways of getting at unmodified Emacs primitives,
4176;;; turning off our handler.
4177
4178(defun ange-ftp-run-real-handler (operation args)
4179 (let ((inhibit-file-name-handlers
4180 (cons 'ange-ftp-hook-function
4181 (cons 'ange-ftp-completion-hook-function
4182 (and (eq inhibit-file-name-operation operation)
4183 inhibit-file-name-handlers))))
4184 (inhibit-file-name-operation operation))
4185 (apply operation args)))
4186
4187(defun ange-ftp-real-file-name-directory (&rest args)
4188 (ange-ftp-run-real-handler 'file-name-directory args))
4189(defun ange-ftp-real-file-name-nondirectory (&rest args)
4190 (ange-ftp-run-real-handler 'file-name-nondirectory args))
4191(defun ange-ftp-real-file-name-as-directory (&rest args)
4192 (ange-ftp-run-real-handler 'file-name-as-directory args))
4193(defun ange-ftp-real-directory-file-name (&rest args)
4194 (ange-ftp-run-real-handler 'directory-file-name args))
4195(defun ange-ftp-real-expand-file-name (&rest args)
4196 (ange-ftp-run-real-handler 'expand-file-name args))
4197(defun ange-ftp-real-make-directory (&rest args)
4198 (ange-ftp-run-real-handler 'make-directory args))
4199(defun ange-ftp-real-delete-directory (&rest args)
4200 (ange-ftp-run-real-handler 'delete-directory args))
4201(defun ange-ftp-real-insert-file-contents (&rest args)
4202 (ange-ftp-run-real-handler 'insert-file-contents args))
4203(defun ange-ftp-real-directory-files (&rest args)
4204 (ange-ftp-run-real-handler 'directory-files args))
4205(defun ange-ftp-real-file-directory-p (&rest args)
4206 (ange-ftp-run-real-handler 'file-directory-p args))
4207(defun ange-ftp-real-file-writable-p (&rest args)
4208 (ange-ftp-run-real-handler 'file-writable-p args))
4209(defun ange-ftp-real-file-readable-p (&rest args)
4210 (ange-ftp-run-real-handler 'file-readable-p args))
4211(defun ange-ftp-real-file-executable-p (&rest args)
4212 (ange-ftp-run-real-handler 'file-executable-p args))
4213(defun ange-ftp-real-file-symlink-p (&rest args)
4214 (ange-ftp-run-real-handler 'file-symlink-p args))
4215(defun ange-ftp-real-delete-file (&rest args)
4216 (ange-ftp-run-real-handler 'delete-file args))
4217(defun ange-ftp-real-read-file-name-internal (&rest args)
4218 (ange-ftp-run-real-handler 'read-file-name-internal args))
4219(defun ange-ftp-real-verify-visited-file-modtime (&rest args)
4220 (ange-ftp-run-real-handler 'verify-visited-file-modtime args))
4221(defun ange-ftp-real-file-exists-p (&rest args)
4222 (ange-ftp-run-real-handler 'file-exists-p args))
4223(defun ange-ftp-real-write-region (&rest args)
4224 (ange-ftp-run-real-handler 'write-region args))
4225(defun ange-ftp-real-backup-buffer (&rest args)
4226 (ange-ftp-run-real-handler 'backup-buffer args))
4227(defun ange-ftp-real-copy-file (&rest args)
4228 (ange-ftp-run-real-handler 'copy-file args))
4229(defun ange-ftp-real-rename-file (&rest args)
4230 (ange-ftp-run-real-handler 'rename-file args))
4231(defun ange-ftp-real-file-attributes (&rest args)
4232 (ange-ftp-run-real-handler 'file-attributes args))
4233(defun ange-ftp-real-file-name-all-completions (&rest args)
4234 (ange-ftp-run-real-handler 'file-name-all-completions args))
4235(defun ange-ftp-real-file-name-completion (&rest args)
4236 (ange-ftp-run-real-handler 'file-name-completion args))
4237(defun ange-ftp-real-insert-directory (&rest args)
4238 (ange-ftp-run-real-handler 'insert-directory args))
4239(defun ange-ftp-real-file-name-sans-versions (&rest args)
4240 (ange-ftp-run-real-handler 'file-name-sans-versions args))
4241(defun ange-ftp-real-shell-command (&rest args)
4242 (ange-ftp-run-real-handler 'shell-command args))
4243(defun ange-ftp-real-load (&rest args)
4244 (ange-ftp-run-real-handler 'load args))
4245(defun ange-ftp-real-find-backup-file-name (&rest args)
4246 (ange-ftp-run-real-handler 'find-backup-file-name args))
4247
4248;; Here we support using dired on remote hosts.
4249;; I have turned off the support for using dired on foreign directory formats.
4250;; That involves too many unclean hooks.
4251;; It would be cleaner to support such operations by
4252;; converting the foreign directory format to something dired can understand;
4253;; something close to ls -l output.
4254;; The logical place to do this is in the functions ange-ftp-parse-...-listing.
4255
4256;; Some of the old dired hooks would still be needed even if this is done.
4257;; I have preserved (and modernized) those hooks.
4258;; So the format conversion should be all that is needed.
4259
4260(defun ange-ftp-insert-directory (file switches &optional wildcard full)
4261 (let ((short (ange-ftp-abbreviate-filename file))
4262 (parsed (ange-ftp-ftp-name (expand-file-name file))))
4263 (if parsed
4264 (insert
4265 (if wildcard
4266 (let ((default-directory (file-name-directory file)))
4267 (ange-ftp-ls (file-name-nondirectory file) switches nil nil t))
4268 (ange-ftp-ls file switches full)))
4269 (ange-ftp-real-insert-directory file switches wildcard full))))
4270
4271(defun ange-ftp-dired-uncache (dir)
4272 (if (ange-ftp-ftp-name (expand-file-name dir))
4273 (setq ange-ftp-ls-cache-file nil)))
4274
4275(defvar ange-ftp-sans-version-alist nil
4276 "Alist of mapping host type into function to remove file version numbers.")
4277
4278(defun ange-ftp-file-name-sans-versions (file keep-backup-version)
4279 (let* ((short (ange-ftp-abbreviate-filename file))
4280 (parsed (ange-ftp-ftp-name short))
4281 host-type func)
4282 (if parsed
4283 (setq host-type (ange-ftp-host-type (car parsed))
4284 func (cdr (assq (ange-ftp-host-type (car parsed))
4285 ange-ftp-sans-version-alist))))
4286 (if func (funcall func file keep-backup-version)
4287 (ange-ftp-real-file-name-sans-versions file keep-backup-version))))
4288
4289;; This is the handler for shell-command.
4290(defun ange-ftp-shell-command (command &optional output-buffer error-buffer)
4291 (let* ((parsed (ange-ftp-ftp-name default-directory))
4292 (host (nth 0 parsed))
4293 (user (nth 1 parsed))
4294 (name (nth 2 parsed)))
4295 (if (not parsed)
4296 (ange-ftp-real-shell-command command output-buffer error-buffer)
4297 (if (> (length name) 0) ; else it's $HOME
4298 (setq command (concat "cd " name "; " command)))
4299 (setq command
4300 (format "%s %s \"%s\"" ; remsh -l USER does not work well
4301 ; on a hp-ux machine I tried
4302 remote-shell-program host command))
4303 (ange-ftp-message "Remote command '%s' ..." command)
4304 ;; Cannot call ange-ftp-real-dired-run-shell-command here as it
4305 ;; would prepend "cd default-directory" --- which bombs because
4306 ;; default-directory is in ange-ftp syntax for remote file names.
4307 (ange-ftp-real-shell-command command output-buffer error-buffer))))
4308
4309;;; This is the handler for call-process.
4310(defun ange-ftp-dired-call-process (program discard &rest arguments)
4311 ;; PROGRAM is always one of those below in the cond in dired.el.
4312 ;; The ARGUMENTS are (nearly) always files.
4313 (if (ange-ftp-ftp-name default-directory)
4314 ;; Can't use ange-ftp-dired-host-type here because the current
4315 ;; buffer is *dired-check-process output*
4316 (condition-case oops
4317 (cond ((equal dired-chmod-program program)
4318 (ange-ftp-call-chmod arguments))
4319 ;; ((equal "chgrp" program))
4320 ;; ((equal dired-chown-program program))
4321 (t (error "Unknown remote command: %s" program)))
4322 (ftp-error (insert (format "%s: %s, %s\n"
4323 (nth 1 oops)
4324 (nth 2 oops)
4325 (nth 3 oops)))
4326 ;; Caller expects nonzero value to mean failure.
4327 1)
4328 (error (insert (format "%s\n" (nth 1 oops)))
4329 1))
4330 (apply 'call-process program nil (not discard) nil arguments)))
4331
4332(defvar ange-ftp-remote-shell "rsh"
4333 "Remote shell to use for chmod, if FTP server rejects the `chmod' command.")
4334
4335;; Handle an attempt to run chmod on a remote file
4336;; by using the ftp chmod command.
4337(defun ange-ftp-call-chmod (args)
4338 (if (< (length args) 2)
4339 (error "ange-ftp-call-chmod: missing mode and/or filename: %s" args))
4340 (let ((mode (car args))
4341 (rest (cdr args)))
4342 (if (equal "--" (car rest))
4343 (setq rest (cdr rest)))
4344 (mapcar
4345 (function
4346 (lambda (file)
4347 (setq file (expand-file-name file))
4348 (let ((parsed (ange-ftp-ftp-name file)))
4349 (if parsed
4350 (let* ((host (nth 0 parsed))
4351 (user (nth 1 parsed))
4352 (name (ange-ftp-quote-string (nth 2 parsed)))
4353 (abbr (ange-ftp-abbreviate-filename file))
4354 (result (ange-ftp-send-cmd host user
4355 (list 'chmod mode name)
4356 (format "doing chmod %s"
4357 abbr))))
4358 (or (car result)
4359 (call-process
4360 ange-ftp-remote-shell
4361 nil t nil host dired-chmod-program mode name)))))))
4362 rest))
4363 (setq ange-ftp-ls-cache-file nil) ;Stop confusing Dired.
4364 0)
4365
4366;;; This is turned off because it has nothing properly to do
4367;;; with dired. It could be reasonable to adapt this to
4368;;; replace ange-ftp-copy-file.
4369
4370;;;;; ------------------------------------------------------------
4371;;;;; Noddy support for async copy-file within dired.
4372;;;;; ------------------------------------------------------------
4373
4374;;(defun ange-ftp-dired-copy-file (from to ok-flag &optional cont nowait)
4375;; "Documented as original."
4376;; (dired-handle-overwrite to)
4377;; (ange-ftp-copy-file-internal from to ok-flag dired-copy-preserve-time nil
4378;; cont nowait))
4379
4380;;(defun ange-ftp-dired-do-create-files (op-symbol file-creator operation arg
4381;; &optional marker-char op1
4382;; how-to)
4383;; "Documented as original."
4384;; ;; we need to let ange-ftp-dired-create-files know that we indirectly
4385;; ;; called it rather than somebody else.
4386;; (let ((ange-ftp-dired-do-create-files t)) ; tell who caller is
4387;; (ange-ftp-real-dired-do-create-files op-symbol file-creator operation
4388;; arg marker-char op1 how-to)))
4389
4390;;(defun ange-ftp-dired-create-files (file-creator operation fn-list name-constructor
4391;; &optional marker-char)
4392;; "Documented as original."
4393;; (if (and (boundp 'ange-ftp-dired-do-create-files)
4394;; ;; called from ange-ftp-dired-do-create-files?
4395;; ange-ftp-dired-do-create-files
4396;; ;; any files worth copying?
4397;; fn-list
4398;; ;; we only support async copy-file at the mo.
4399;; (eq file-creator 'dired-copy-file)
4400;; ;; it is only worth calling the alternative function for remote files
4401;; ;; as we tie ourself in recursive knots otherwise.
4402;; (or (ange-ftp-ftp-name (car fn-list))
4403;; ;; we can only call the name constructor for dired-do-create-files
4404;; ;; since the one for regexps starts prompting here, there and
4405;; ;; everywhere.
4406;; (ange-ftp-ftp-name (funcall name-constructor (car fn-list)))))
4407;; ;; use the process-filter driven routine rather than the iterative one.
4408;; (ange-ftp-dcf-1 file-creator
4409;; operation
4410;; fn-list
4411;; name-constructor
4412;; (and (boundp 'target) target) ;dynamically bound
4413;; marker-char
4414;; (current-buffer)
4415;; nil ;overwrite-query
4416;; nil ;overwrite-backup-query
4417;; nil ;failures
4418;; nil ;skipped
4419;; 0 ;success-count
4420;; (length fn-list) ;total
4421;; )
4422;; ;; normal case... use the interactive routine... much cheaper.
4423;; (ange-ftp-real-dired-create-files file-creator operation fn-list
4424;; name-constructor marker-char)))
4425
4426;;(defun ange-ftp-dcf-1 (file-creator operation fn-list name-constructor
4427;; target marker-char buffer overwrite-query
4428;; overwrite-backup-query failures skipped
4429;; success-count total)
4430;; (let ((old-buf (current-buffer)))
4431;; (unwind-protect
4432;; (progn
4433;; (set-buffer buffer)
4434;; (if (null fn-list)
4435;; (ange-ftp-dcf-3 failures operation total skipped
4436;; success-count buffer)
4437
4438;; (let* ((from (car fn-list))
4439;; (to (funcall name-constructor from)))
4440;; (if (equal to from)
4441;; (progn
4442;; (setq to nil)
4443;; (dired-log "Cannot %s to same file: %s\n"
4444;; (downcase operation) from)))
4445;; (if (not to)
4446;; (ange-ftp-dcf-1 file-creator
4447;; operation
4448;; (cdr fn-list)
4449;; name-constructor
4450;; target
4451;; marker-char
4452;; buffer
4453;; overwrite-query
4454;; overwrite-backup-query
4455;; failures
4456;; (cons (dired-make-relative from) skipped)
4457;; success-count
4458;; total)
4459;; (let* ((overwrite (file-exists-p to))
4460;; (overwrite-confirmed ; for dired-handle-overwrite
4461;; (and overwrite
4462;; (let ((help-form '(format "\
4463;;Type SPC or `y' to overwrite file `%s',
4464;;DEL or `n' to skip to next,
4465;;ESC or `q' to not overwrite any of the remaining files,
4466;;`!' to overwrite all remaining files with no more questions." to)))
4467;; (dired-query 'overwrite-query
4468;; "Overwrite `%s'?" to))))
4469;; ;; must determine if FROM is marked before file-creator
4470;; ;; gets a chance to delete it (in case of a move).
4471;; (actual-marker-char
4472;; (cond ((integerp marker-char) marker-char)
4473;; (marker-char (dired-file-marker from)) ; slow
4474;; (t nil))))
4475;; (condition-case err
4476;; (funcall file-creator from to overwrite-confirmed
4477;; (list (function ange-ftp-dcf-2)
4478;; nil ;err
4479;; file-creator operation fn-list
4480;; name-constructor
4481;; target
4482;; marker-char actual-marker-char
4483;; buffer to from
4484;; overwrite
4485;; overwrite-confirmed
4486;; overwrite-query
4487;; overwrite-backup-query
4488;; failures skipped success-count
4489;; total)
4490;; t)
4491;; (file-error ; FILE-CREATOR aborted
4492;; (ange-ftp-dcf-2 nil ;result
4493;; nil ;line
4494;; err
4495;; file-creator operation fn-list
4496;; name-constructor
4497;; target
4498;; marker-char actual-marker-char
4499;; buffer to from
4500;; overwrite
4501;; overwrite-confirmed
4502;; overwrite-query
4503;; overwrite-backup-query
4504;; failures skipped success-count
4505;; total))))))))
4506;; (set-buffer old-buf))))
4507
4508;;(defun ange-ftp-dcf-2 (result line err
4509;; file-creator operation fn-list
4510;; name-constructor
4511;; target
4512;; marker-char actual-marker-char
4513;; buffer to from
4514;; overwrite
4515;; overwrite-confirmed
4516;; overwrite-query
4517;; overwrite-backup-query
4518;; failures skipped success-count
4519;; total)
4520;; (let ((old-buf (current-buffer)))
4521;; (unwind-protect
4522;; (progn
4523;; (set-buffer buffer)
4524;; (if (or err (not result))
4525;; (progn
4526;; (setq failures (cons (dired-make-relative from) failures))
4527;; (dired-log "%s `%s' to `%s' failed:\n%s\n"
4528;; operation from to (or err line)))
4529;; (if overwrite
4530;; ;; If we get here, file-creator hasn't been aborted
4531;; ;; and the old entry (if any) has to be deleted
4532;; ;; before adding the new entry.
4533;; (dired-remove-file to))
4534;; (setq success-count (1+ success-count))
4535;; (message "%s: %d of %d" operation success-count total)
4536;; (dired-add-file to actual-marker-char))
4537
4538;; (ange-ftp-dcf-1 file-creator operation (cdr fn-list)
4539;; name-constructor
4540;; target
4541;; marker-char
4542;; buffer
4543;; overwrite-query
4544;; overwrite-backup-query
4545;; failures skipped success-count
4546;; total))
4547;; (set-buffer old-buf))))
4548
4549;;(defun ange-ftp-dcf-3 (failures operation total skipped success-count
4550;; buffer)
4551;; (let ((old-buf (current-buffer)))
4552;; (unwind-protect
4553;; (progn
4554;; (set-buffer buffer)
4555;; (cond
4556;; (failures
4557;; (dired-log-summary
4558;; (message "%s failed for %d of %d file%s %s"
4559;; operation (length failures) total
4560;; (dired-plural-s total) failures)))
4561;; (skipped
4562;; (dired-log-summary
4563;; (message "%s: %d of %d file%s skipped %s"
4564;; operation (length skipped) total
4565;; (dired-plural-s total) skipped)))
4566;; (t
4567;; (message "%s: %s file%s."
4568;; operation success-count (dired-plural-s success-count))))
4569;; (dired-move-to-filename))
4570;; (set-buffer old-buf))))
4571
4572;;;; -----------------------------------------------
4573;;;; Unix Descriptive Listing (dl) Support
4574;;;; -----------------------------------------------
4575
4576;; This is turned off because nothing uses it currently
4577;; and because I don't understand what it's supposed to be for. --rms.
4578
4579;;(defconst ange-ftp-dired-dl-re-dir
4580;; "^. [^ /]+/[ \n]"
4581;; "Regular expression to use to search for dl directories.")
4582
4583;;(or (assq 'unix:dl ange-ftp-dired-re-dir-alist)
4584;; (setq ange-ftp-dired-re-dir-alist
4585;; (cons (cons 'unix:dl ange-ftp-dired-dl-re-dir)
4586;; ange-ftp-dired-re-dir-alist)))
4587
4588;;(defun ange-ftp-dired-dl-move-to-filename (&optional raise-error eol)
4589;; "In dired, move to the first character of the filename on this line."
4590;; ;; This is the Unix dl version.
4591;; (or eol (setq eol (progn (end-of-line) (point))))
4592;; (let (case-fold-search)
4593;; (beginning-of-line)
4594;; (if (looking-at ". [^ ]+ +\\([0-9]+\\|-\\|=\\) ")
4595;; (goto-char (+ (point) 2))
4596;; (if raise-error
4597;; (error "No file on this line")
4598;; nil))))
4599
4600;;(or (assq 'unix:dl ange-ftp-dired-move-to-filename-alist)
4601;; (setq ange-ftp-dired-move-to-filename-alist
4602;; (cons '(unix:dl . ange-ftp-dired-dl-move-to-filename)
4603;; ange-ftp-dired-move-to-filename-alist)))
4604
4605;;(defun ange-ftp-dired-dl-move-to-end-of-filename (&optional no-error eol)
4606;; ;; Assumes point is at beginning of filename.
4607;; ;; So, it should be called only after (dired-move-to-filename t).
4608;; ;; On failure, signals an error or returns nil.
4609;; ;; This is the Unix dl version.
4610;; (let ((opoint (point))
4611;; case-fold-search hidden)
4612;; (or eol (setq eol (save-excursion (end-of-line) (point))))
4613;; (setq hidden (and selective-display
4614;; (save-excursion
4615;; (search-forward "\r" eol t))))
4616;; (if hidden
4617;; (if no-error
4618;; nil
4619;; (error
4620;; (substitute-command-keys
4621;; "File line is hidden, type \\[dired-hide-subdir] to unhide")))
4622;; (skip-chars-forward "^ /" eol)
4623;; (if (eq opoint (point))
4624;; (if no-error
4625;; nil
4626;; (error "No file on this line"))
4627;; (point)))))
4628
4629;;(or (assq 'unix:dl ange-ftp-dired-move-to-end-of-filename-alist)
4630;; (setq ange-ftp-dired-move-to-end-of-filename-alist
4631;; (cons '(unix:dl . ange-ftp-dired-dl-move-to-end-of-filename)
4632;; ange-ftp-dired-move-to-end-of-filename-alist)))
4633
4634;;;; ------------------------------------------------------------
4635;;;; VOS support (VOS support is probably broken,
4636;;;; but I don't know anything about VOS.)
4637;;;; ------------------------------------------------------------
4638;
4639;(defun ange-ftp-fix-name-for-vos (name &optional reverse)
4640; (setq name (copy-sequence name))
4641; (let ((from (if reverse ?\> ?\/))
4642; (to (if reverse ?\/ ?\>))
4643; (i (1- (length name))))
4644; (while (>= i 0)
4645; (if (= (aref name i) from)
4646; (aset name i to))
4647; (setq i (1- i)))
4648; name))
4649;
4650;(or (assq 'vos ange-ftp-fix-name-func-alist)
4651; (setq ange-ftp-fix-name-func-alist
4652; (cons '(vos . ange-ftp-fix-name-for-vos)
4653; ange-ftp-fix-name-func-alist)))
4654;
4655;(or (memq 'vos ange-ftp-dumb-host-types)
4656; (setq ange-ftp-dumb-host-types
4657; (cons 'vos ange-ftp-dumb-host-types)))
4658;
4659;(defun ange-ftp-fix-dir-name-for-vos (dir-name)
4660; (ange-ftp-fix-name-for-vos
4661; (concat dir-name
4662; (if (eq ?/ (aref dir-name (1- (length dir-name))))
4663; "" "/")
4664; "*")))
4665;
4666;(or (assq 'vos ange-ftp-fix-dir-name-func-alist)
4667; (setq ange-ftp-fix-dir-name-func-alist
4668; (cons '(vos . ange-ftp-fix-dir-name-for-vos)
4669; ange-ftp-fix-dir-name-func-alist)))
4670;
4671;(defvar ange-ftp-vos-host-regexp nil
4672; "If a host matches this regexp then it is assumed to be running VOS.")
4673;
4674;(defun ange-ftp-vos-host (host)
4675; (and ange-ftp-vos-host-regexp
4676; (save-match-data
4677; (string-match ange-ftp-vos-host-regexp host))))
4678;
4679;(defun ange-ftp-parse-vos-listing ()
4680; "Parse the current buffer which is assumed to be in VOS list -all
4681;format, and return a hashtable as the result."
4682; (let ((tbl (ange-ftp-make-hashtable))
4683; (type-list
4684; '(("^Files: [0-9]+ +Blocks: [0-9]+\n+" nil 40)
4685; ("^Dirs: [0-9]+\n+" t 30)))
4686; type-regexp type-is-dir type-col file)
4687; (goto-char (point-min))
4688; (save-match-data
4689; (while type-list
4690; (setq type-regexp (car (car type-list))
4691; type-is-dir (nth 1 (car type-list))
4692; type-col (nth 2 (car type-list))
4693; type-list (cdr type-list))
4694; (if (re-search-forward type-regexp nil t)
4695; (while (eq (char-after (point)) ? )
4696; (move-to-column type-col)
4697; (setq file (buffer-substring (point)
4698; (progn
4699; (end-of-line 1)
4700; (point))))
4701; (ange-ftp-put-hash-entry file type-is-dir tbl)
4702; (forward-line 1))))
4703; (ange-ftp-put-hash-entry "." 'vosdir tbl)
4704; (ange-ftp-put-hash-entry ".." 'vosdir tbl))
4705; tbl))
4706;
4707;(or (assq 'vos ange-ftp-parse-list-func-alist)
4708; (setq ange-ftp-parse-list-func-alist
4709; (cons '(vos . ange-ftp-parse-vos-listing)
4710; ange-ftp-parse-list-func-alist)))
4711
4712;;;; ------------------------------------------------------------
4713;;;; VMS support.
4714;;;; ------------------------------------------------------------
4715
4716;; Convert NAME from UNIX-ish to VMS. If REVERSE given then convert from VMS
4717;; to UNIX-ish.
4718(defun ange-ftp-fix-name-for-vms (name &optional reverse)
4719 (save-match-data
4720 (if reverse
4721 (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name)
4722 (let (drive dir file)
4723 (if (match-beginning 1)
4724 (setq drive (substring name
4725 (match-beginning 1)
4726 (match-end 1))))
4727 (if (match-beginning 2)
4728 (setq dir
4729 (substring name (match-beginning 2) (match-end 2))))
4730 (if (match-beginning 3)
4731 (setq file
4732 (substring name (match-beginning 3) (match-end 3))))
4733 (and dir
4734 (setq dir (apply (function concat)
4735 (mapcar (function
4736 (lambda (char)
4737 (if (= char ?.)
4738 (vector ?/)
4739 (vector char))))
4740 (substring dir 1 -1)))))
4741 (concat (and drive
4742 (concat "/" drive "/"))
4743 dir (and dir "/")
4744 file))
4745 (error "name %s didn't match" name))
4746 (let (drive dir file tmp)
4747 (if (string-match "^/[^:]+:/" name)
4748 (setq drive (substring name 1
4749 (1- (match-end 0)))
4750 name (substring name (match-end 0))))
4751 (setq tmp (file-name-directory name))
4752 (if tmp
4753 (setq dir (apply (function concat)
4754 (mapcar (function
4755 (lambda (char)
4756 (if (= char ?/)
4757 (vector ?.)
4758 (vector char))))
4759 (substring tmp 0 -1)))))
4760 (setq file (file-name-nondirectory name))
4761 (concat drive
4762 (and dir (concat "[" (if drive nil ".") dir "]"))
4763 file)))))
4764
4765;; (ange-ftp-fix-name-for-vms "/PUB$:/ANONYMOUS/SDSCPUB/NEXT/Readme.txt;1")
4766;; (ange-ftp-fix-name-for-vms "/PUB$:[ANONYMOUS.SDSCPUB.NEXT]Readme.txt;1" t)
4767
4768(or (assq 'vms ange-ftp-fix-name-func-alist)
4769 (setq ange-ftp-fix-name-func-alist
4770 (cons '(vms . ange-ftp-fix-name-for-vms)
4771 ange-ftp-fix-name-func-alist)))
4772
4773(or (memq 'vms ange-ftp-dumb-host-types)
4774 (setq ange-ftp-dumb-host-types
4775 (cons 'vms ange-ftp-dumb-host-types)))
4776
4777;; It is important that this function barf for directories for which we know
4778;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/".
4779;; This is because it saves an unnecessary FTP error, or possibly the listing
4780;; might succeed, but give erroneous info. This last case is particularly
4781;; likely for OS's (like MTS) for which we need to use a wildcard in order
4782;; to list a directory.
4783
4784;; Convert name from UNIX-ish to VMS ready for a DIRectory listing.
4785(defun ange-ftp-fix-dir-name-for-vms (dir-name)
4786 ;; Should there be entries for .. -> [-] and . -> [] below. Don't
4787 ;; think so, because expand-filename should have already short-circuited
4788 ;; them.
4789 (cond ((string-equal dir-name "/")
4790 (error "Cannot get listing for fictitious \"/\" directory."))
4791 ((string-match "^/[-A-Z0-9_$]+:/$" dir-name)
4792 (error "Cannot get listing for device."))
4793 ((ange-ftp-fix-name-for-vms dir-name))))
4794
4795(or (assq 'vms ange-ftp-fix-dir-name-func-alist)
4796 (setq ange-ftp-fix-dir-name-func-alist
4797 (cons '(vms . ange-ftp-fix-dir-name-for-vms)
4798 ange-ftp-fix-dir-name-func-alist)))
4799
4800(defvar ange-ftp-vms-host-regexp nil)
4801
4802;; Return non-nil if HOST is running VMS.
4803(defun ange-ftp-vms-host (host)
4804 (and ange-ftp-vms-host-regexp
4805 (save-match-data
4806 (string-match ange-ftp-vms-host-regexp host))))
4807
4808;; Because some VMS ftp servers convert filenames to lower case
4809;; we allow a-z in the filename regexp. I'm not too happy about this.
4810
4811(defconst ange-ftp-vms-filename-regexp
4812 (concat
4813 "\\(\\([_A-Za-z0-9$]?\\|[_A-Za-z0-9$][-_A-Za-z0-9$]*\\)\\."
4814 "[-_A-Za-z0-9$]*;+[0-9]*\\)")
4815 "Regular expression to match for a valid VMS file name in Dired buffer.
4816Stupid freaking bug! Position of _ and $ shouldn't matter but they do.
4817Having [A-Z0-9$_] bombs on filename _$$CHANGE_LOG$.TXT$ and $CHANGE_LOG$.TX
4818Other orders of $ and _ seem to all work just fine.")
4819
4820;; These parsing functions are as general as possible because the syntax
4821;; of ftp listings from VMS hosts is a bit erratic. What saves us is that
4822;; the VMS filename syntax is so rigid. If they bomb on a listing in the
4823;; standard VMS Multinet format, then this is a bug. If they bomb on a listing
4824;; from vms.weird.net, then too bad.
4825
4826;; Extract the next filename from a VMS dired-like listing.
4827(defun ange-ftp-parse-vms-filename ()
4828 (if (re-search-forward
4829 ange-ftp-vms-filename-regexp
4830 nil t)
4831 (buffer-substring (match-beginning 0) (match-end 0))))
4832
4833;; Parse the current buffer which is assumed to be in MultiNet FTP dir
4834;; format, and return a hashtable as the result.
4835(defun ange-ftp-parse-vms-listing ()
4836 (let ((tbl (ange-ftp-make-hashtable))
4837 file)
4838 (goto-char (point-min))
4839 (save-match-data
4840 (while (setq file (ange-ftp-parse-vms-filename))
4841 (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file)
4842 ;; deal with directories
4843 (ange-ftp-put-hash-entry
4844 (substring file 0 (match-beginning 0)) t tbl)
4845 (ange-ftp-put-hash-entry file nil tbl)
4846 (if (string-match ";[0-9]+$" file) ; deal with extension
4847 ;; sans extension
4848 (ange-ftp-put-hash-entry
4849 (substring file 0 (match-beginning 0)) nil tbl)))
4850 (forward-line 1))
4851 ;; Would like to look for a "Total" line, or a "Directory" line to
4852 ;; make sure that the listing isn't complete garbage before putting
4853 ;; in "." and "..", but we can't even count on all VAX's giving us
4854 ;; either of these.
4855 (ange-ftp-put-hash-entry "." t tbl)
4856 (ange-ftp-put-hash-entry ".." t tbl))
4857 tbl))
4858
4859(or (assq 'vms ange-ftp-parse-list-func-alist)
4860 (setq ange-ftp-parse-list-func-alist
4861 (cons '(vms . ange-ftp-parse-vms-listing)
4862 ange-ftp-parse-list-func-alist)))
4863
4864;; This version only deletes file entries which have
4865;; explicit version numbers, because that is all VMS allows.
4866
4867;; Can the following two functions be speeded up using file
4868;; completion functions?
4869
4870(defun ange-ftp-vms-delete-file-entry (name &optional dir-p)
4871 (if dir-p
4872 (ange-ftp-internal-delete-file-entry name t)
4873 (save-match-data
4874 (let ((file (ange-ftp-get-file-part name)))
4875 (if (string-match ";[0-9]+$" file)
4876 ;; In VMS you can't delete a file without an explicit
4877 ;; version number, or wild-card (e.g. FOO;*)
4878 ;; For now, we give up on wildcards.
4879 (let ((files (ange-ftp-get-hash-entry
4880 (file-name-directory name)
4881 ange-ftp-files-hashtable)))
4882 (if files
4883 (let* ((root (substring file 0
4884 (match-beginning 0)))
4885 (regexp (concat "^"
4886 (regexp-quote root)
4887 ";[0-9]+$"))
4888 versions)
4889 (ange-ftp-del-hash-entry file files)
4890 ;; Now we need to check if there are any
4891 ;; versions left. If not, then delete the
4892 ;; root entry.
4893 (mapatoms
4894 '(lambda (sym)
4895 (and (string-match regexp (get sym 'key))
4896 (setq versions t)))
4897 files)
4898 (or versions
4899 (ange-ftp-del-hash-entry root files))))))))))
4900
4901(or (assq 'vms ange-ftp-delete-file-entry-alist)
4902 (setq ange-ftp-delete-file-entry-alist
4903 (cons '(vms . ange-ftp-vms-delete-file-entry)
4904 ange-ftp-delete-file-entry-alist)))
4905
4906(defun ange-ftp-vms-add-file-entry (name &optional dir-p)
4907 (if dir-p
4908 (ange-ftp-internal-add-file-entry name t)
4909 (let ((files (ange-ftp-get-hash-entry
4910 (file-name-directory name)
4911 ange-ftp-files-hashtable)))
4912 (if files
4913 (let ((file (ange-ftp-get-file-part name)))
4914 (save-match-data
4915 (if (string-match ";[0-9]+$" file)
4916 (ange-ftp-put-hash-entry
4917 (substring file 0 (match-beginning 0))
4918 nil files)
4919 ;; Need to figure out what version of the file
4920 ;; is being added.
4921 (let ((regexp (concat "^"
4922 (regexp-quote file)
4923 ";\\([0-9]+\\)$"))
4924 (version 0))
4925 (mapatoms
4926 '(lambda (sym)
4927 (let ((name (get sym 'key)))
4928 (and (string-match regexp name)
4929 (setq version
4930 (max version
4931 (string-to-int
4932 (substring name
4933 (match-beginning 1)
4934 (match-end 1))))))))
4935 files)
4936 (setq version (1+ version))
4937 (ange-ftp-put-hash-entry
4938 (concat file ";" (int-to-string version))
4939 nil files))))
4940 (ange-ftp-put-hash-entry file nil files))))))
4941
4942(or (assq 'vms ange-ftp-add-file-entry-alist)
4943 (setq ange-ftp-add-file-entry-alist
4944 (cons '(vms . ange-ftp-vms-add-file-entry)
4945 ange-ftp-add-file-entry-alist)))
4946
4947
4948(defun ange-ftp-add-vms-host (host)
4949 "Mark HOST as the name of a machine running VMS."
4950 (interactive
4951 (list (read-string "Host: "
4952 (let ((name (or (buffer-file-name) default-directory)))
4953 (and name (car (ange-ftp-ftp-name name)))))))
4954 (if (not (ange-ftp-vms-host host))
4955 (setq ange-ftp-vms-host-regexp
4956 (concat "^" (regexp-quote host) "$"
4957 (and ange-ftp-vms-host-regexp "\\|")
4958 ange-ftp-vms-host-regexp)
4959 ange-ftp-host-cache nil)))
4960
4961
4962(defun ange-ftp-vms-file-name-as-directory (name)
4963 (save-match-data
4964 (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name)
4965 (setq name (substring name 0 (match-beginning 0))))
4966 (ange-ftp-real-file-name-as-directory name)))
4967
4968(or (assq 'vms ange-ftp-file-name-as-directory-alist)
4969 (setq ange-ftp-file-name-as-directory-alist
4970 (cons '(vms . ange-ftp-vms-file-name-as-directory)
4971 ange-ftp-file-name-as-directory-alist)))
4972
4973;;; Tree dired support:
4974
4975;; For this code I have borrowed liberally from Sebastian Kremer's
4976;; dired-vms.el
4977
4978
4979;;;; These regexps must be anchored to beginning of line.
4980;;;; Beware that the ftpd may put the device in front of the filename.
4981
4982;;(defconst ange-ftp-dired-vms-re-exe "^. [^ \t.]+\\.\\(EXE\\|exe\\)[; ]"
4983;; "Regular expression to use to search for VMS executable files.")
4984
4985;;(defconst ange-ftp-dired-vms-re-dir "^. [^ \t.]+\\.\\(DIR\\|dir\\)[; ]"
4986;; "Regular expression to use to search for VMS directories.")
4987
4988;;(or (assq 'vms ange-ftp-dired-re-exe-alist)
4989;; (setq ange-ftp-dired-re-exe-alist
4990;; (cons (cons 'vms ange-ftp-dired-vms-re-exe)
4991;; ange-ftp-dired-re-exe-alist)))
4992
4993;;(or (assq 'vms ange-ftp-dired-re-dir-alist)
4994;; (setq ange-ftp-dired-re-dir-alist
4995;; (cons (cons 'vms ange-ftp-dired-vms-re-dir)
4996;; ange-ftp-dired-re-dir-alist)))
4997
4998;;(defun ange-ftp-dired-vms-insert-headerline (dir)
4999;; ;; VMS inserts a headerline. I would prefer the headerline
5000;; ;; to be in ange-ftp format. This version tries to
5001;; ;; be careful, because we can't count on a headerline
5002;; ;; over ftp, and we wouldn't want to delete anything
5003;; ;; important.
5004;; (save-excursion
5005;; (if (looking-at "^ wildcard ")
5006;; (forward-line 1))
5007;; (if (looking-at "^[ \n\t]*[^\n]+\\][ \t]*\n")
5008;; (delete-region (point) (match-end 0))))
5009;; (ange-ftp-real-dired-insert-headerline dir))
5010
5011;;(or (assq 'vms ange-ftp-dired-insert-headerline-alist)
5012;; (setq ange-ftp-dired-insert-headerline-alist
5013;; (cons '(vms . ange-ftp-dired-vms-insert-headerline)
5014;; ange-ftp-dired-insert-headerline-alist)))
5015
5016;;(defun ange-ftp-dired-vms-move-to-filename (&optional raise-error eol)
5017;; "In dired, move to first char of filename on this line.
5018;;Returns position (point) or nil if no filename on this line."
5019;; ;; This is the VMS version.
5020;; (let (case-fold-search)
5021;; (or eol (setq eol (progn (end-of-line) (point))))
5022;; (beginning-of-line)
5023;; (if (re-search-forward ange-ftp-vms-filename-regexp eol t)
5024;; (goto-char (match-beginning 1))
5025;; (if raise-error
5026;; (error "No file on this line")
5027;; nil))))
5028
5029;;(or (assq 'vms ange-ftp-dired-move-to-filename-alist)
5030;; (setq ange-ftp-dired-move-to-filename-alist
5031;; (cons '(vms . ange-ftp-dired-vms-move-to-filename)
5032;; ange-ftp-dired-move-to-filename-alist)))
5033
5034;;(defun ange-ftp-dired-vms-move-to-end-of-filename (&optional no-error eol)
5035;; ;; Assumes point is at beginning of filename.
5036;; ;; So, it should be called only after (dired-move-to-filename t).
5037;; ;; case-fold-search must be nil, at least for VMS.
5038;; ;; On failure, signals an error or returns nil.
5039;; ;; This is the VMS version.
5040;; (let (opoint hidden case-fold-search)
5041;; (setq opoint (point))
5042;; (or eol (setq eol (save-excursion (end-of-line) (point))))
5043;; (setq hidden (and selective-display
5044;; (save-excursion (search-forward "\r" eol t))))
5045;; (if hidden
5046;; nil
5047;; (re-search-forward ange-ftp-vms-filename-regexp eol t))
5048;; (or no-error
5049;; (not (eq opoint (point)))
5050;; (error
5051;; (if hidden
5052;; (substitute-command-keys
5053;; "File line is hidden, type \\[dired-hide-subdir] to unhide")
5054;; "No file on this line")))
5055;; (if (eq opoint (point))
5056;; nil
5057;; (point))))
5058
5059;;(or (assq 'vms ange-ftp-dired-move-to-end-of-filename-alist)
5060;; (setq ange-ftp-dired-move-to-end-of-filename-alist
5061;; (cons '(vms . ange-ftp-dired-vms-move-to-end-of-filename)
5062;; ange-ftp-dired-move-to-end-of-filename-alist)))
5063
5064;;(defun ange-ftp-dired-vms-between-files ()
5065;; (save-excursion
5066;; (beginning-of-line)
5067;; (or (equal (following-char) 10) ; newline
5068;; (equal (following-char) 9) ; tab
5069;; (progn (forward-char 2)
5070;; (or (looking-at "Total of")
5071;; (equal (following-char) 32))))))
5072
5073;;(or (assq 'vms ange-ftp-dired-between-files-alist)
5074;; (setq ange-ftp-dired-between-files-alist
5075;; (cons '(vms . ange-ftp-dired-vms-between-files)
5076;; ange-ftp-dired-between-files-alist)))
5077
5078;; Beware! In VMS filenames must be of the form "FILE.TYPE".
5079;; Therefore, we cannot just append a ".Z" to filenames for
5080;; compressed files. Instead, we turn "FILE.TYPE" into
5081;; "FILE.TYPE-Z". Hope that this is a reasonable thing to do.
5082
5083(defun ange-ftp-vms-make-compressed-filename (name &optional reverse)
5084 (cond
5085 ((string-match "-Z;[0-9]+$" name)
5086 (list nil (substring name 0 (match-beginning 0))))
5087 ((string-match ";[0-9]+$" name)
5088 (list nil (substring name 0 (match-beginning 0))))
5089 ((string-match "-Z$" name)
5090 (list nil (substring name 0 -2)))
5091 (t
5092 (list t
5093 (if (string-match ";[0-9]+$" name)
5094 (concat (substring name 0 (match-beginning 0))
5095 "-Z")
5096 (concat name "-Z"))))))
5097
5098(or (assq 'vms ange-ftp-make-compressed-filename-alist)
5099 (setq ange-ftp-make-compressed-filename-alist
5100 (cons '(vms . ange-ftp-vms-make-compressed-filename)
5101 ange-ftp-make-compressed-filename-alist)))
5102
5103;;;; When the filename is too long, VMS will use two lines to list a file
5104;;;; (damn them!) This will confuse dired. To solve this, need to convince
5105;;;; Sebastian to use a function dired-go-to-end-of-file-line, instead of
5106;;;; (forward-line 1). This would require a number of changes to dired.el.
5107;;;; If dired gets confused, revert-buffer will fix it.
5108
5109;;(defun ange-ftp-dired-vms-ls-trim ()
5110;; (goto-char (point-min))
5111;; (let ((case-fold-search nil))
5112;; (re-search-forward ange-ftp-vms-filename-regexp))
5113;; (beginning-of-line)
5114;; (delete-region (point-min) (point))
5115;; (forward-line 1)
5116;; (delete-region (point) (point-max)))
5117
5118
5119;;(or (assq 'vms ange-ftp-dired-ls-trim-alist)
5120;; (setq ange-ftp-dired-ls-trim-alist
5121;; (cons '(vms . ange-ftp-dired-vms-ls-trim)
5122;; ange-ftp-dired-ls-trim-alist)))
5123
5124(defun ange-ftp-vms-sans-version (name &rest args)
5125 (save-match-data
5126 (if (string-match ";[0-9]+$" name)
5127 (substring name 0 (match-beginning 0))
5128 name)))
5129
5130(or (assq 'vms ange-ftp-sans-version-alist)
5131 (setq ange-ftp-sans-version-alist
5132 (cons '(vms . ange-ftp-vms-sans-version)
5133 ange-ftp-sans-version-alist)))
5134
5135;;(defvar ange-ftp-file-version-alist)
5136
5137;;;;; The vms version of clean-directory has 2 more optional args
5138;;;;; than the usual dired version. This is so that it can be used by
5139;;;;; ange-ftp-dired-vms-flag-backup-files.
5140
5141;;(defun ange-ftp-dired-vms-clean-directory (keep &optional marker msg)
5142;; "Flag numerical backups for deletion.
5143;;Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest.
5144;;Positive prefix arg KEEP overrides `dired-kept-versions';
5145;;Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive.
5146
5147;;To clear the flags on these files, you can use \\[dired-flag-backup-files]
5148;;with a prefix argument."
5149;;; (interactive "P") ; Never actually called interactively.
5150;; (setq keep (max 1 (if keep (prefix-numeric-value keep) dired-kept-versions)))
5151;; (let ((early-retention (if (< keep 0) (- keep) kept-old-versions))
5152;; ;; late-retention must NEVER be allowed to be less than 1 in VMS!
5153;; ;; This could wipe ALL copies of the file.
5154;; (late-retention (max 1 (if (<= keep 0) dired-kept-versions keep)))
5155;; (action (or msg "Cleaning"))
5156;; (ange-ftp-trample-marker (or marker dired-del-marker))
5157;; (ange-ftp-file-version-alist ()))
5158;; (message (concat action
5159;; " numerical backups (keeping %d late, %d old)...")
5160;; late-retention early-retention)
5161;; ;; Look at each file.
5162;; ;; If the file has numeric backup versions,
5163;; ;; put on ange-ftp-file-version-alist an element of the form
5164;; ;; (FILENAME . VERSION-NUMBER-LIST)
5165;; (dired-map-dired-file-lines (function
5166;; ange-ftp-dired-vms-collect-file-versions))
5167;; ;; Sort each VERSION-NUMBER-LIST,
5168;; ;; and remove the versions not to be deleted.
5169;; (let ((fval ange-ftp-file-version-alist))
5170;; (while fval
5171;; (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<)))
5172;; (v-count (length sorted-v-list)))
5173;; (if (> v-count (+ early-retention late-retention))
5174;; (rplacd (nthcdr early-retention sorted-v-list)
5175;; (nthcdr (- v-count late-retention)
5176;; sorted-v-list)))
5177;; (rplacd (car fval)
5178;; (cdr sorted-v-list)))
5179;; (setq fval (cdr fval))))
5180;; ;; Look at each file. If it is a numeric backup file,
5181;; ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion.
5182;; (dired-map-dired-file-lines
5183;; (function
5184;; ange-ftp-dired-vms-trample-file-versions mark))
5185;; (message (concat action " numerical backups...done"))))
5186
5187;;(or (assq 'vms ange-ftp-dired-clean-directory-alist)
5188;; (setq ange-ftp-dired-clean-directory-alist
5189;; (cons '(vms . ange-ftp-dired-vms-clean-directory)
5190;; ange-ftp-dired-clean-directory-alist)))
5191
5192;;(defun ange-ftp-dired-vms-collect-file-versions (fn)
5193;; ;; "If it looks like file FN has versions, return a list of the versions.
5194;; ;;That is a list of strings which are file names.
5195;; ;;The caller may want to flag some of these files for deletion."
5196;;(let ((name (nth 2 (ange-ftp-ftp-name fn))))
5197;; (if (string-match ";[0-9]+$" name)
5198;; (let* ((name (substring name 0 (match-beginning 0)))
5199;; (fn (ange-ftp-replace-name-component fn name)))
5200;; (if (not (assq fn ange-ftp-file-version-alist))
5201;; (let* ((base-versions
5202;; (concat (file-name-nondirectory name) ";"))
5203;; (bv-length (length base-versions))
5204;; (possibilities (file-name-all-completions
5205;; base-versions
5206;; (file-name-directory fn)))
5207;; (versions (mapcar
5208;; '(lambda (arg)
5209;; (if (and (string-match
5210;; "[0-9]+$" arg bv-length)
5211;; (= (match-beginning 0) bv-length))
5212;; (string-to-int (substring arg bv-length))
5213;; 0))
5214;; possibilities)))
5215;; (if versions
5216;; (setq
5217;; ange-ftp-file-version-alist
5218;; (cons (cons fn versions)
5219;; ange-ftp-file-version-alist)))))))))
5220
5221;;(defun ange-ftp-dired-vms-trample-file-versions (fn)
5222;; (let* ((start-vn (string-match ";[0-9]+$" fn))
5223;; base-version-list)
5224;; (and start-vn
5225;; (setq base-version-list ; there was a base version to which
5226;; (assoc (substring fn 0 start-vn) ; this looks like a
5227;; ange-ftp-file-version-alist)) ; subversion
5228;; (not (memq (string-to-int (substring fn (1+ start-vn)))
5229;; base-version-list)) ; this one doesn't make the cut
5230;; (progn (beginning-of-line)
5231;; (delete-char 1)
5232;; (insert ange-ftp-trample-marker)))))
5233
5234;;(defun ange-ftp-dired-vms-flag-backup-files (&optional unflag-p)
5235;; (let ((dired-kept-versions 1)
5236;; (kept-old-versions 0)
5237;; marker msg)
5238;; (if unflag-p
5239;; (setq marker ?\040 msg "Unflagging")
5240;; (setq marker dired-del-marker msg "Cleaning"))
5241;; (ange-ftp-dired-vms-clean-directory nil marker msg)))
5242
5243;;(or (assq 'vms ange-ftp-dired-flag-backup-files-alist)
5244;; (setq ange-ftp-dired-flag-backup-files-alist
5245;; (cons '(vms . ange-ftp-dired-vms-flag-backup-files)
5246;; ange-ftp-dired-flag-backup-files-alist)))
5247
5248;;(defun ange-ftp-dired-vms-backup-diff (&optional switches)
5249;; (let ((file (dired-get-filename 'no-dir))
5250;; bak)
5251;; (if (and (string-match ";[0-9]+$" file)
5252;; ;; Find most recent previous version.
5253;; (let ((root (substring file 0 (match-beginning 0)))
5254;; (ver
5255;; (string-to-int (substring file (1+ (match-beginning 0)))))
5256;; found)
5257;; (setq ver (1- ver))
5258;; (while (and (> ver 0) (not found))
5259;; (setq bak (concat root ";" (int-to-string ver)))
5260;; (and (file-exists-p bak) (setq found t))
5261;; (setq ver (1- ver)))
5262;; found))
5263;; (if switches
5264;; (diff (expand-file-name bak) (expand-file-name file) switches)
5265;; (diff (expand-file-name bak) (expand-file-name file)))
5266;; (error "No previous version found for %s" file))))
5267
5268;;(or (assq 'vms ange-ftp-dired-backup-diff-alist)
5269;; (setq ange-ftp-dired-backup-diff-alist
5270;; (cons '(vms . ange-ftp-dired-vms-backup-diff)
5271;; ange-ftp-dired-backup-diff-alist)))
5272
5273
5274;;;; ------------------------------------------------------------
5275;;;; MTS support
5276;;;; ------------------------------------------------------------
5277
5278
5279;; Convert NAME from UNIX-ish to MTS. If REVERSE given then convert from
5280;; MTS to UNIX-ish.
5281(defun ange-ftp-fix-name-for-mts (name &optional reverse)
5282 (save-match-data
5283 (if reverse
5284 (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name)
5285 (let (acct file)
5286 (if (match-beginning 1)
5287 (setq acct (substring name 0 (match-end 1))))
5288 (if (match-beginning 2)
5289 (setq file (substring name
5290 (match-beginning 2) (match-end 2))))
5291 (concat (and acct (concat "/" acct "/"))
5292 file))
5293 (error "name %s didn't match" name))
5294 (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" name)
5295 (concat (substring name 1 (match-end 1))
5296 (substring name (match-beginning 2) (match-end 2)))
5297 ;; Let's hope that mts will recognize it anyway.
5298 name))))
5299
5300(or (assq 'mts ange-ftp-fix-name-func-alist)
5301 (setq ange-ftp-fix-name-func-alist
5302 (cons '(mts . ange-ftp-fix-name-for-mts)
5303 ange-ftp-fix-name-func-alist)))
5304
5305;; Convert name from UNIX-ish to MTS ready for a DIRectory listing.
5306;; Remember that there are no directories in MTS.
5307(defun ange-ftp-fix-dir-name-for-mts (dir-name)
5308 (if (string-equal dir-name "/")
5309 (error "Cannot get listing for fictitious \"/\" directory.")
5310 (let ((dir-name (ange-ftp-fix-name-for-mts dir-name)))
5311 (cond
5312 ((string-equal dir-name "")
5313 "?")
5314 ((string-match ":$" dir-name)
5315 (concat dir-name "?"))
5316 (dir-name))))) ; It's just a single file.
5317
5318(or (assq 'mts ange-ftp-fix-dir-name-func-alist)
5319 (setq ange-ftp-fix-dir-name-func-alist
5320 (cons '(mts . ange-ftp-fix-dir-name-for-mts)
5321 ange-ftp-fix-dir-name-func-alist)))
5322
5323(or (memq 'mts ange-ftp-dumb-host-types)
5324 (setq ange-ftp-dumb-host-types
5325 (cons 'mts ange-ftp-dumb-host-types)))
5326
5327(defvar ange-ftp-mts-host-regexp nil)
5328
5329;; Return non-nil if HOST is running MTS.
5330(defun ange-ftp-mts-host (host)
5331 (and ange-ftp-mts-host-regexp
5332 (save-match-data
5333 (string-match ange-ftp-mts-host-regexp host))))
5334
5335;; Parse the current buffer which is assumed to be in mts ftp dir format.
5336(defun ange-ftp-parse-mts-listing ()
5337 (let ((tbl (ange-ftp-make-hashtable)))
5338 (goto-char (point-min))
5339 (save-match-data
5340 (while (re-search-forward ange-ftp-date-regexp nil t)
5341 (end-of-line)
5342 (skip-chars-backward " ")
5343 (let ((end (point)))
5344 (skip-chars-backward "-A-Z0-9_.!")
5345 (ange-ftp-put-hash-entry (buffer-substring (point) end) nil tbl))
5346 (forward-line 1)))
5347 ;; Don't need to bother with ..
5348 (ange-ftp-put-hash-entry "." t tbl)
5349 tbl))
5350
5351(or (assq 'mts ange-ftp-parse-list-func-alist)
5352 (setq ange-ftp-parse-list-func-alist
5353 (cons '(mts . ange-ftp-parse-mts-listing)
5354 ange-ftp-parse-list-func-alist)))
5355
5356(defun ange-ftp-add-mts-host (host)
5357 "Mark HOST as the name of a machine running MTS."
5358 (interactive
5359 (list (read-string "Host: "
5360 (let ((name (or (buffer-file-name) default-directory)))
5361 (and name (car (ange-ftp-ftp-name name)))))))
5362 (if (not (ange-ftp-mts-host host))
5363 (setq ange-ftp-mts-host-regexp
5364 (concat "^" (regexp-quote host) "$"
5365 (and ange-ftp-mts-host-regexp "\\|")
5366 ange-ftp-mts-host-regexp)
5367 ange-ftp-host-cache nil)))
5368
5369;;; Tree dired support:
5370
5371;;;; There aren't too many systems left that use MTS. This dired support will
5372;;;; work for the implementation of ftp on mtsg.ubc.ca. I hope other mts systems
5373;;;; implement ftp in the same way. If not, it might be necessary to make the
5374;;;; following more flexible.
5375
5376;;(defun ange-ftp-dired-mts-move-to-filename (&optional raise-error eol)
5377;; "In dired, move to first char of filename on this line.
5378;;Returns position (point) or nil if no filename on this line."
5379;; ;; This is the MTS version.
5380;; (or eol (setq eol (progn (end-of-line) (point))))
5381;; (beginning-of-line)
5382;; (if (re-search-forward
5383;; ange-ftp-date-regexp eol t)
5384;; (progn
5385;; (skip-chars-forward " ") ; Eat blanks after date
5386;; (skip-chars-forward "0-9:" eol) ; Eat time or year
5387;; (skip-chars-forward " " eol) ; one space before filename
5388;; ;; When listing an account other than the users own account it appends
5389;; ;; ACCT: to the beginning of the filename. Skip over this.
5390;; (and (looking-at "[A-Z0-9_.]+:")
5391;; (goto-char (match-end 0)))
5392;; (point))
5393;; (if raise-error
5394;; (error "No file on this line")
5395;; nil)))
5396
5397;;(or (assq 'mts ange-ftp-dired-move-to-filename-alist)
5398;; (setq ange-ftp-dired-move-to-filename-alist
5399;; (cons '(mts . ange-ftp-dired-mts-move-to-filename)
5400;; ange-ftp-dired-move-to-filename-alist)))
5401
5402;;(defun ange-ftp-dired-mts-move-to-end-of-filename (&optional no-error eol)
5403;; ;; Assumes point is at beginning of filename.
5404;; ;; So, it should be called only after (dired-move-to-filename t).
5405;; ;; On failure, signals an error or returns nil.
5406;; ;; This is the MTS version.
5407;; (let (opoint hidden case-fold-search)
5408;; (setq opoint (point)
5409;; eol (save-excursion (end-of-line) (point))
5410;; hidden (and selective-display
5411;; (save-excursion (search-forward "\r" eol t))))
5412;; (if hidden
5413;; nil
5414;; (skip-chars-forward "-A-Z0-9._!" eol))
5415;; (or no-error
5416;; (not (eq opoint (point)))
5417;; (error
5418;; (if hidden
5419;; (substitute-command-keys
5420;; "File line is hidden, type \\[dired-hide-subdir] to unhide")
5421;; "No file on this line")))
5422;; (if (eq opoint (point))
5423;; nil
5424;; (point))))
5425
5426;;(or (assq 'mts ange-ftp-dired-move-to-end-of-filename-alist)
5427;; (setq ange-ftp-dired-move-to-end-of-filename-alist
5428;; (cons '(mts . ange-ftp-dired-mts-move-to-end-of-filename)
5429;; ange-ftp-dired-move-to-end-of-filename-alist)))
5430
5431;;;; ------------------------------------------------------------
5432;;;; CMS support
5433;;;; ------------------------------------------------------------
5434
5435;; Since CMS doesn't have any full file name syntax, we have to fudge
5436;; things with cd's. We actually send too many cd's, but it's dangerous
5437;; to try to remember the current minidisk, because if the connection
5438;; is closed and needs to be reopened, we will find ourselves back in
5439;; the default minidisk. This is fairly likely since CMS ftp servers
5440;; usually close the connection after 5 minutes of inactivity.
5441
5442;; Have I got the filename character set right?
5443
5444(defun ange-ftp-fix-name-for-cms (name &optional reverse)
5445 (save-match-data
5446 (if reverse
5447 ;; Since we only convert output from a pwd in this direction,
5448 ;; we'll assume that it's a minidisk, and make it into a
5449 ;; directory file name. Note that the expand-dir-hashtable
5450 ;; stores directories without the trailing /. Is this
5451 ;; consistent?
5452 (concat "/" name)
5453 (if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$"
5454 name)
5455 (let ((minidisk (substring name 1 (match-end 1))))
5456 (if (match-beginning 2)
5457 (let ((file (substring name (match-beginning 2)
5458 (match-end 2)))
5459 (cmd (concat "cd " minidisk))
5460
5461 ;; Note that host and user are bound in the call
5462 ;; to ange-ftp-send-cmd
5463 (proc (ange-ftp-get-process ange-ftp-this-host
5464 ange-ftp-this-user)))
5465
5466 ;; Must use ange-ftp-raw-send-cmd here to avoid
5467 ;; an infinite loop.
5468 (if (car (ange-ftp-raw-send-cmd proc cmd ange-ftp-this-msg))
5469 file
5470 ;; failed... try ONCE more.
5471 (setq proc (ange-ftp-get-process ange-ftp-this-host
5472 ange-ftp-this-user))
5473 (let ((result (ange-ftp-raw-send-cmd proc cmd
5474 ange-ftp-this-msg)))
5475 (if (car result)
5476 file
5477 ;; failed. give up.
5478 (ange-ftp-error ange-ftp-this-host ange-ftp-this-user
5479 (format "cd to minidisk %s failed: %s"
5480 minidisk (cdr result)))))))
5481 ;; return the minidisk
5482 minidisk))
5483 (error "Invalid CMS filename")))))
5484
5485(or (assq 'cms ange-ftp-fix-name-func-alist)
5486 (setq ange-ftp-fix-name-func-alist
5487 (cons '(cms . ange-ftp-fix-name-for-cms)
5488 ange-ftp-fix-name-func-alist)))
5489
5490(or (memq 'cms ange-ftp-dumb-host-types)
5491 (setq ange-ftp-dumb-host-types
5492 (cons 'cms ange-ftp-dumb-host-types)))
5493
5494;; Convert name from UNIX-ish to CMS ready for a DIRectory listing.
5495(defun ange-ftp-fix-dir-name-for-cms (dir-name)
5496 (cond
5497 ((string-equal "/" dir-name)
5498 (error "Cannot get listing for fictitious \"/\" directory."))
5499 ((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-name)
5500 (let* ((minidisk (substring dir-name (match-beginning 1) (match-end 1)))
5501 ;; host and user are bound in the call to ange-ftp-send-cmd
5502 (proc (ange-ftp-get-process ange-ftp-this-host ange-ftp-this-user))
5503 (cmd (concat "cd " minidisk))
5504 (file (if (match-beginning 2)
5505 ;; it's a single file
5506 (substring dir-name (match-beginning 2)
5507 (match-end 2))
5508 ;; use the wild-card
5509 "*")))
5510 (if (car (ange-ftp-raw-send-cmd proc cmd))
5511 file
5512 ;; try again...
5513 (setq proc (ange-ftp-get-process ange-ftp-this-host
5514 ange-ftp-this-user))
5515 (let ((result (ange-ftp-raw-send-cmd proc cmd)))
5516 (if (car result)
5517 file
5518 ;; give up
5519 (ange-ftp-error ange-ftp-this-host ange-ftp-this-user
5520 (format "cd to minidisk %s failed: %s"
5521 minidisk (cdr result))))))))
5522 (t (error "Invalid CMS file name"))))
5523
5524(or (assq 'cms ange-ftp-fix-dir-name-func-alist)
5525 (setq ange-ftp-fix-dir-name-func-alist
5526 (cons '(cms . ange-ftp-fix-dir-name-for-cms)
5527 ange-ftp-fix-dir-name-func-alist)))
5528
5529(defvar ange-ftp-cms-host-regexp nil
5530 "Regular expression to match hosts running the CMS operating system.")
5531
5532;; Return non-nil if HOST is running CMS.
5533(defun ange-ftp-cms-host (host)
5534 (and ange-ftp-cms-host-regexp
5535 (save-match-data
5536 (string-match ange-ftp-cms-host-regexp host))))
5537
5538(defun ange-ftp-add-cms-host (host)
5539 "Mark HOST as the name of a CMS host."
5540 (interactive
5541 (list (read-string "Host: "
5542 (let ((name (or (buffer-file-name) default-directory)))
5543 (and name (car (ange-ftp-ftp-name name)))))))
5544 (if (not (ange-ftp-cms-host host))
5545 (setq ange-ftp-cms-host-regexp
5546 (concat "^" (regexp-quote host) "$"
5547 (and ange-ftp-cms-host-regexp "\\|")
5548 ange-ftp-cms-host-regexp)
5549 ange-ftp-host-cache nil)))
5550
5551(defun ange-ftp-parse-cms-listing ()
5552 ;; Parse the current buffer which is assumed to be a CMS directory listing.
5553 ;; If we succeed in getting a listing, then we will assume that the minidisk
5554 ;; exists. file is bound by the call to ange-ftp-ls. This doesn't work
5555 ;; because ange-ftp doesn't know that the root hashtable has only part of
5556 ;; the info. It will assume that if a minidisk isn't in it, then it doesn't
5557 ;; exist. It would be nice if completion worked for minidisks, as we
5558 ;; discover them.
5559; (let* ((dir-file (directory-file-name file))
5560; (root (file-name-directory dir-file))
5561; (minidisk (ange-ftp-get-file-part dir-file))
5562; (root-tbl (ange-ftp-get-hash-entry root ange-ftp-files-hashtable)))
5563; (if root-tbl
5564; (ange-ftp-put-hash-entry minidisk t root-tbl)
5565; (setq root-tbl (ange-ftp-make-hashtable))
5566; (ange-ftp-put-hash-entry minidisk t root-tbl)
5567; (ange-ftp-put-hash-entry "." t root-tbl)
5568; (ange-ftp-set-files root root-tbl)))
5569 ;; Now do the usual parsing
5570 (let ((tbl (ange-ftp-make-hashtable)))
5571 (goto-char (point-min))
5572 (save-match-data
5573 (while
5574 (re-search-forward
5575 "^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t)
5576 (ange-ftp-put-hash-entry
5577 (concat (buffer-substring (match-beginning 1)
5578 (match-end 1))
5579 "."
5580 (buffer-substring (match-beginning 2)
5581 (match-end 2)))
5582 nil tbl)
5583 (forward-line 1))
5584 (ange-ftp-put-hash-entry "." t tbl))
5585 tbl))
5586
5587(or (assq 'cms ange-ftp-parse-list-func-alist)
5588 (setq ange-ftp-parse-list-func-alist
5589 (cons '(cms . ange-ftp-parse-cms-listing)
5590 ange-ftp-parse-list-func-alist)))
5591
5592;;;;; Tree dired support:
5593
5594;;(defconst ange-ftp-dired-cms-re-exe
5595;; "^. [-A-Z0-9$_]+ +EXEC "
5596;; "Regular expression to use to search for CMS executables.")
5597
5598;;(or (assq 'cms ange-ftp-dired-re-exe-alist)
5599;; (setq ange-ftp-dired-re-exe-alist
5600;; (cons (cons 'cms ange-ftp-dired-cms-re-exe)
5601;; ange-ftp-dired-re-exe-alist)))
5602
5603
5604;;(defun ange-ftp-dired-cms-insert-headerline (dir)
5605;; ;; CMS has no total line, so we insert a blank line for
5606;; ;; aesthetics.
5607;; (insert "\n")
5608;; (forward-char -1)
5609;; (ange-ftp-real-dired-insert-headerline dir))
5610
5611;;(or (assq 'cms ange-ftp-dired-insert-headerline-alist)
5612;; (setq ange-ftp-dired-insert-headerline-alist
5613;; (cons '(cms . ange-ftp-dired-cms-insert-headerline)
5614;; ange-ftp-dired-insert-headerline-alist)))
5615
5616;;(defun ange-ftp-dired-cms-move-to-filename (&optional raise-error eol)
5617;; "In dired, move to the first char of filename on this line."
5618;; ;; This is the CMS version.
5619;; (or eol (setq eol (progn (end-of-line) (point))))
5620;; (let (case-fold-search)
5621;; (beginning-of-line)
5622;; (if (re-search-forward " [-A-Z0-9$_]+ +[-A-Z0-9$_]+ +[VF] +[0-9]+ " eol t)
5623;; (goto-char (1+ (match-beginning 0)))
5624;; (if raise-error
5625;; (error "No file on this line")
5626;; nil))))
5627
5628;;(or (assq 'cms ange-ftp-dired-move-to-filename-alist)
5629;; (setq ange-ftp-dired-move-to-filename-alist
5630;; (cons '(cms . ange-ftp-dired-cms-move-to-filename)
5631;; ange-ftp-dired-move-to-filename-alist)))
5632
5633;;(defun ange-ftp-dired-cms-move-to-end-of-filename (&optional no-error eol)
5634;; ;; Assumes point is at beginning of filename.
5635;; ;; So, it should be called only after (dired-move-to-filename t).
5636;; ;; case-fold-search must be nil, at least for VMS.
5637;; ;; On failure, signals an error or returns nil.
5638;; ;; This is the CMS version.
5639;; (let ((opoint (point))
5640;; case-fold-search hidden)
5641;; (or eol (setq eol (save-excursion (end-of-line) (point))))
5642;; (setq hidden (and selective-display
5643;; (save-excursion
5644;; (search-forward "\r" eol t))))
5645;; (if hidden
5646;; (if no-error
5647;; nil
5648;; (error
5649;; (substitute-command-keys
5650;; "File line is hidden, type \\[dired-hide-subdir] to unhide")))
5651;; (skip-chars-forward "-A-Z0-9$_" eol)
5652;; (skip-chars-forward " " eol)
5653;; (skip-chars-forward "-A-Z0-9$_" eol)
5654;; (if (eq opoint (point))
5655;; (if no-error
5656;; nil
5657;; (error "No file on this line"))
5658;; (point)))))
5659
5660;;(or (assq 'cms ange-ftp-dired-move-to-end-of-filename-alist)
5661;; (setq ange-ftp-dired-move-to-end-of-filename-alist
5662;; (cons '(cms . ange-ftp-dired-cms-move-to-end-of-filename)
5663;; ange-ftp-dired-move-to-end-of-filename-alist)))
5664
5665(defun ange-ftp-cms-make-compressed-filename (name &optional reverse)
5666 (if (string-match "-Z$" name)
5667 (list nil (substring name 0 -2))
5668 (list t (concat name "-Z"))))
5669
5670(or (assq 'cms ange-ftp-make-compressed-filename-alist)
5671 (setq ange-ftp-make-compressed-filename-alist
5672 (cons '(cms . ange-ftp-cms-make-compressed-filename)
5673 ange-ftp-make-compressed-filename-alist)))
5674
5675;;(defun ange-ftp-dired-cms-get-filename (&optional localp no-error-if-not-filep)
5676;; (let ((name (ange-ftp-real-dired-get-filename localp no-error-if-not-filep)))
5677;; (and name
5678;; (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" name)
5679;; (concat (substring name 0 (match-end 1))
5680;; "."
5681;; (substring name (match-beginning 2) (match-end 2)))
5682;; name))))
5683
5684;;(or (assq 'cms ange-ftp-dired-get-filename-alist)
5685;; (setq ange-ftp-dired-get-filename-alist
5686;; (cons '(cms . ange-ftp-dired-cms-get-filename)
5687;; ange-ftp-dired-get-filename-alist)))
5688
5689;;;; ------------------------------------------------------------
5690;;;; Finally provide package.
5691;;;; ------------------------------------------------------------
5692
5693(provide 'ange-ftp)
5694
5695;;; ange-ftp.el ends here
diff --git a/lisp/browse-url.el b/lisp/browse-url.el
deleted file mode 100644
index 1cdfc1c1f86..00000000000
--- a/lisp/browse-url.el
+++ /dev/null
@@ -1,1033 +0,0 @@
1;;; browse-url.el --- Pass a URL to a WWW browser
2
3;; Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc.
4
5;; Author: Denis Howe <dbh@doc.ic.ac.uk>
6;; Maintainer: Dave Love <fx@gnu.org>
7;; Created: 03 Apr 1995
8;; Keywords: hypertext, hypermedia, mouse
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 2, or (at your option)
15;; any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING. If not, write to the
24;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;; Boston, MA 02111-1307, USA.
26
27;;; Commentary:
28
29;; This package provides functions which read a URL (Uniform Resource
30;; Locator) from the minibuffer, defaulting to the URL around point,
31;; and ask a World-Wide Web browser to load it. It can also load the
32;; URL associated with the current buffer. Different browsers use
33;; different methods of remote control so there is one function for
34;; each supported browser. If the chosen browser is not running, it
35;; is started. Currently there is support for:
36
37;; Function Browser Earliest version
38;; browse-url-netscape Netscape 1.1b1
39;; browse-url-mosaic XMosaic/mMosaic <= 2.4
40;; browse-url-cci XMosaic 2.5
41;; browse-url-w3 w3 0
42;; browse-url-w3-gnudoit w3 remotely
43;; browse-url-iximosaic IXI Mosaic ?
44;; browse-url-lynx-* Lynx 0
45;; browse-url-grail Grail 0.3b1
46;; browse-url-mmm MMM ?
47;; browse-url-generic arbitrary
48
49;; [A version of the Netscape browser is now free software
50;; <URL:http://www.mozilla.org/>, albeit not GPLed, so it is
51;; reasonable to have that as the default.]
52
53;; Note that versions of Netscape before 1.1b1 did not have remote
54;; control. <URL:http://www.netscape.com/newsref/std/x-remote.html>.
55
56;; Browsers can cache Web pages so it may be necessary to tell them to
57;; reload the current page if it has changed (e.g. if you have edited
58;; it). There is currently no perfect automatic solution to this.
59
60;; Netscape allows you to specify the id of the window you want to
61;; control but which window DO you want to control and how do you
62;; discover its id?
63
64;; If using XMosaic before version 2.5, check the definition of
65;; browse-url-usr1-signal below.
66;; <URL:http://www.ncsa.uiuc.edu/SDG/Software/XMosaic/remote-control.html>
67
68;; XMosaic version 2.5 introduced Common Client Interface allowing you
69;; to control mosaic through Unix sockets.
70;; <URL:http://www.ncsa.uiuc.edu/SDG/Software/XMosaic/CCI/cci-spec.html>
71
72;; William M. Perry's excellent "w3" WWW browser for
73;; Emacs <URL:ftp://cs.indiana.edu/pub/elisp/w3/>
74;; has a function w3-follow-url-at-point, but that
75;; doesn't let you edit the URL like browse-url.
76;; The `gnuserv' package that can be used to control it in another
77;; Emacs process is available from
78;; <URL:ftp://ftp.splode.com/pub/users/friedman/packages/>.
79
80;; Grail is the freely available WWW browser implemented in Python, a
81;; cool object-oriented freely available interpreted language. Grail
82;; 0.3b1 was the first version to have remote control as distributed.
83;; For more information on Grail see
84;; <URL:http://grail.cnri.reston.va.us/> and for more information on
85;; Python see <url:http://www.python.org/>. Grail support in
86;; browse-url.el written by Barry Warsaw <bwarsaw@python.org>.
87
88;; MMM is a semi-free WWW browser implemented in Objective Caml, an
89;; interesting impure functional programming language. See
90;; <URL:http://pauillac.inria.fr/%7Erouaix/mmm/>.
91
92;; Lynx is now distributed by the FSF. See also
93;; <URL:http://lynx.browser.org/>.
94
95;; Free graphical browsers that could be used by `browse-url-generic'
96;; include Chimera <URL:ftp://ftp.cs.unlv.edu/pub/chimera> and
97;; <URL:http://www.unlv.edu/chimera/>, Arena
98;; <URL:ftp://ftp.yggdrasil.com/pub/dist/web/arena> and Amaya
99;; <URL:ftp://ftp.w3.org/pub/amaya>. mMosaic
100;; <URL:ftp://sig.enst.fr/pub/multicast/mMosaic/>,
101;; <URL:http://sig.enst.fr/~dauphin/mMosaic/> (with development
102;; support for Java applets and multicast) can be used like Mosaic by
103;; setting `browse-url-mosaic-program' appropriately.
104
105;; I [Denis Howe, not Dave Love] recommend Nelson Minar
106;; <nelson@santafe.edu>'s excellent html-helper-mode.el for editing
107;; HTML and thank Nelson for his many useful comments on this code.
108;; <URL:http://www.santafe.edu/%7Enelson/hhm-beta/>
109
110;; See also hm--html-menus <URL:http://www.tnt.uni-hannover.de/%7Emuenkel/
111;; software/own/hm--html-menus/>. For composing correct HTML see also
112;; PSGML the general SGML structure editor package
113;; <URL:ftp://ftp.lysator.liu.se/pub/sgml>; hm--html-menus can be used
114;; with this.
115
116;; This package generalises function html-previewer-process in Marc
117;; Andreessen's html-mode (LCD modes/html-mode.el.Z). See also the
118;; ffap.el package. The huge hyperbole package also contains similar
119;; functions.
120
121;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
122;; Help!
123
124;; Can you write and test some code for the Macintrash and Windoze
125;; Netscape remote control APIs? (See the URL above).
126
127;; Do any other browsers have remote control?
128
129;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
130;; Usage
131
132;; To display the URL at or before point:
133;; M-x browse-url-at-point RET
134;; or, similarly but with the opportunity to edit the URL extracted from
135;; the buffer, use:
136;; M-x browse-url
137
138;; To display a URL by shift-clicking on it, put this in your ~/.emacs
139;; file:
140;; (global-set-key [S-mouse-2] 'browse-url-at-mouse)
141;; (Note that using Shift-mouse-1 is not desirable because
142;; that event has a standard meaning in Emacs.)
143
144;; To display the current buffer in a web browser:
145;; M-x browse-url-of-buffer RET
146
147;; To display the current region in a web browser:
148;; M-x browse-url-of-region RET
149
150;; In Dired, to display the file named on the current line:
151;; M-x browse-url-of-dired-file RET
152
153;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
154;; Customisation (~/.emacs)
155
156;; To see what variables are available for customization, type
157;; `M-x set-variable browse-url TAB'. Better, use
158;; `M-x customize-group browse-url'.
159
160;; Bind the browse-url commands to keys with the `C-c C-z' prefix
161;; (as used by html-helper-mode):
162;; (global-set-key "\C-c\C-z." 'browse-url-at-point)
163;; (global-set-key "\C-c\C-zb" 'browse-url-of-buffer)
164;; (global-set-key "\C-c\C-zr" 'browse-url-of-region)
165;; (global-set-key "\C-c\C-zu" 'browse-url)
166;; (global-set-key "\C-c\C-zv" 'browse-url-of-file)
167;; (add-hook 'dired-mode-hook
168;; (lambda ()
169;; (local-set-key "\C-c\C-zf" 'browse-url-of-dired-file)))
170
171;; Browse URLs in mail messages by clicking mouse-2:
172;; (add-hook 'rmail-mode-hook (lambda () ; rmail-mode startup
173;; (define-key rmail-mode-map [mouse-2] 'browse-url-at-mouse)))
174
175;; Browse URLs in Usenet messages by clicking mouse-2:
176;; (eval-after-load "gnus"
177;; '(define-key gnus-article-mode-map [mouse-2] 'browse-url-at-mouse))
178;; [The current version of Gnus provides a standard feature to
179;; activate URLs in article buffers for invocation of browse-url with
180;; mouse-2.]
181
182;; Use the Emacs w3 browser when not running under X11:
183;; (or (eq window-system 'x)
184;; (setq browse-url-browser-function 'browse-url-w3))
185
186;; To always save modified buffers before displaying the file in a browser:
187;; (setq browse-url-save-file t)
188
189;; To get round the Netscape caching problem, you could EITHER have
190;; write-file in html-helper-mode make Netscape reload the document:
191;;
192;; (autoload 'browse-url-netscape-reload "browse-url"
193;; "Ask a WWW browser to redisplay the current file." t)
194;; (add-hook 'html-helper-mode-hook
195;; (lambda ()
196;; (add-hook 'local-write-file-hooks
197;; (lambda ()
198;; (let ((local-write-file-hooks))
199;; (save-buffer))
200;; (browse-url-netscape-reload)
201;; t) ; => file written by hook
202;; t))) ; append to l-w-f-hooks
203;;
204;; OR have browse-url-of-file ask Netscape to load and then reload the
205;; file:
206;;
207;; (add-hook 'browse-url-of-file-hook 'browse-url-netscape-reload)
208
209;; You may also want to customise browse-url-netscape-arguments, e.g.
210;; (setq browse-url-netscape-arguments '("-install"))
211;;
212;; or similarly for the other browsers.
213
214;; To invoke different browsers for different URLs:
215;; (setq browse-url-browser-function '(("^mailto:" . browse-url-mail)
216;; ("." . browse-url-netscape)))
217
218;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
219;;; Code:
220
221;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
222;; Variables
223
224(eval-when-compile (require 'thingatpt)
225 (require 'term)
226 (require 'dired)
227 (require 'w3-auto nil t))
228
229(defgroup browse-url nil
230 "Use a web browser to look at a URL."
231 :prefix "browse-url-"
232 :group 'hypermedia)
233
234;;;###autoload
235(defcustom browse-url-browser-function
236 (if (eq system-type 'windows-nt)
237 'browse-url-default-windows-browser
238 'browse-url-netscape)
239 "*Function to display the current buffer in a WWW browser.
240This is used by the `browse-url-at-point', `browse-url-at-mouse', and
241`browse-url-of-file' commands.
242
243If the value is not a function it should be a list of pairs
244(REGEXP . FUNCTION). In this case the function called will be the one
245associated with the first REGEXP which matches the current URL. The
246function is passed the URL and any other args of `browse-url'. The last
247regexp should probably be \".\" to specify a default browser."
248 :type '(choice
249 (function-item :tag "Emacs W3" :value browse-url-w3)
250 (function-item :tag "W3 in another Emacs via `gnudoit'"
251 :value browse-url-w3-gnudoit)
252 (function-item :tag "Netscape" :value browse-url-netscape)
253 (function-item :tag "Mosaic" :value browse-url-mosaic)
254 (function-item :tag "Mosaic using CCI" :value browse-url-cci)
255 (function-item :tag "IXI Mosaic" :value browse-url-iximosaic)
256 (function-item :tag "Lynx in an xterm window"
257 :value browse-url-lynx-xterm)
258 (function-item :tag "Lynx in an Emacs window"
259 :value browse-url-lynx-emacs)
260 (function-item :tag "Grail" :value browse-url-grail)
261 (function-item :tag "MMM" :value browse-url-mmm)
262 (function-item :tag "Specified by `Browse Url Generic Program'"
263 :value browse-url-generic)
264 (function-item :tag "Default Windows browser"
265 :value browse-url-default-windows-browser)
266 (function :tag "Your own function"))
267 :version "20.4"
268 :group 'browse-url)
269
270(defcustom browse-url-netscape-program "netscape"
271 ;; Info about netscape-remote from Karl Berry.
272 "The name by which to invoke Netscape.
273
274The free program `netscape-remote' from
275<URL:http://home.netscape.com/newsref/std/remote.c> is said to start
276up very much quicker than `netscape'. Reported to compile on a GNU
277system, given vroot.h from the same directory, with cc flags
278 -DSTANDALONE -L/usr/X11R6/lib -lXmu -lX11."
279 :type 'string
280 :group 'browse-url)
281
282(defcustom browse-url-netscape-arguments nil
283 "A list of strings to pass to Netscape as arguments."
284 :type '(repeat (string :tag "Argument"))
285 :group 'browse-url)
286
287(defcustom browse-url-netscape-startup-arguments browse-url-netscape-arguments
288 "A list of strings to pass to Netscape when it starts up.
289Defaults to the value of `browse-url-netscape-arguments' at the time
290`browse-url' is loaded."
291 :type '(repeat (string :tag "Argument"))
292 :group 'browse-url)
293
294;;;###autoload
295(defcustom browse-url-new-window-p nil
296 "*If non-nil, always open a new browser window with appropriate browsers.
297Passing an interactive argument to \\[browse-url], or specific browser
298commands reverses the effect of this variable. Requires Netscape version
2991.1N or later or XMosaic version 2.5 or later if using those browsers."
300 :type 'boolean
301 :group 'browse-url)
302
303;;;###autoload
304(defcustom browse-url-netscape-display nil
305 "*The X display for running Netscape, if not same as Emacs'."
306 :type '(choice string (const :tag "Default" nil))
307 :group 'browse-url)
308
309(defcustom browse-url-mosaic-program "xmosaic"
310 "The name by which to invoke Mosaic (or mMosaic)."
311 :type 'string
312 :version "20.3"
313 :group 'browse-url)
314
315(defcustom browse-url-mosaic-arguments nil
316 "A list of strings to pass to Mosaic as arguments."
317 :type '(repeat (string :tag "Argument"))
318 :group 'browse-url)
319
320(defcustom browse-url-filename-alist
321 '(("^/\\(ftp@\\|anonymous@\\)?\\([^:]+\\):/*" . "ftp://\\2/")
322 ;; The above loses the username to avoid the browser prompting for
323 ;; it in anonymous cases. If it's not anonymous the next regexp
324 ;; applies.
325 ("^/\\([^:@]+@\\)?\\([^:]+\\):/*" . "ftp://\\1\\2/")
326 ("^/+" . "file:/"))
327 "An alist of (REGEXP . STRING) pairs used by `browse-url-of-file'.
328Any substring of a filename matching one of the REGEXPs is replaced by
329the corresponding STRING using `replace-match', not treating STRING
330literally. All pairs are applied in the order given. The default
331value converts ange-ftp/EFS-style paths into ftp URLs and prepends
332`file:' to any path beginning with `/'.
333
334For example, adding to the default a specific translation of an ange-ftp
335address to an HTTP URL:
336
337 (setq browse-url-filename-alist
338 '((\"/webmaster@webserver:/home/www/html/\" .
339 \"http://www.acme.co.uk/\")
340 (\"^/\\(ftp@\\|anonymous@\\)?\\([^:]+\\):/*\" . \"ftp://\\2/\")
341 (\"^/\\([^:@]+@\\)?\\([^:]+\\):/*\" . \"ftp://\\1\\2/\")
342 (\"^/+\" . \"file:/\")))
343"
344 :type '(repeat (cons :format "%v"
345 (regexp :tag "Regexp")
346 (string :tag "Replacement")))
347 :version "20.3"
348 :group 'browse-url)
349
350;;;###autoload
351(defcustom browse-url-save-file nil
352 "*If non-nil, save the buffer before displaying its file.
353Used by the `browse-url-of-file' command."
354 :type 'boolean
355 :group 'browse-url)
356
357(defcustom browse-url-of-file-hook nil
358 "Run after `browse-url-of-file' has asked a browser to load a file.
359
360Set this to `browse-url-netscape-reload' to force Netscape to load the
361file rather than displaying a cached copy."
362 :type 'hook
363 :options '(browse-url-netscape-reload)
364 :group 'browse-url)
365
366(defvar browse-url-usr1-signal
367 (if (and (boundp 'emacs-major-version)
368 (or (> emacs-major-version 19) (>= emacs-minor-version 29)))
369 'SIGUSR1 ; Why did I think this was in lower case before?
370 30) ; Check /usr/include/signal.h.
371 "The argument to `signal-process' for sending SIGUSR1 to XMosaic.
372Emacs 19.29 accepts 'SIGUSR1, earlier versions require an integer
373which is 30 on SunOS and 16 on HP-UX and Solaris.")
374
375(defcustom browse-url-CCI-port 3003
376 "Port to access XMosaic via CCI.
377This can be any number between 1024 and 65535 but must correspond to
378the value set in the browser."
379 :type 'integer
380 :group 'browse-url)
381
382(defcustom browse-url-CCI-host "localhost"
383 "*Host to access XMosaic via CCI.
384This should be the host name of the machine running XMosaic with CCI
385enabled. The port number should be set in `browse-url-CCI-port'."
386 :type 'string
387 :group 'browse-url)
388
389(defvar browse-url-temp-file-name nil)
390(make-variable-buffer-local 'browse-url-temp-file-name)
391
392(defcustom browse-url-xterm-program "xterm"
393 "The name of the terminal emulator used by `browse-url-lynx-xterm'.
394This might, for instance, be a separate colour version of xterm."
395 :type 'string
396 :group 'browse-url)
397
398(defcustom browse-url-xterm-args nil
399 "*A list of strings defining options for `browse-url-xterm-program'.
400These might set its size, for instance."
401 :type '(repeat (string :tag "Argument"))
402 :group 'browse-url)
403
404(defcustom browse-url-lynx-emacs-args (and (not window-system)
405 '("-show_cursor"))
406 "A list of strings defining options for Lynx in an Emacs buffer.
407
408The default is none in a window system, otherwise `-show_cursor' to
409indicate the position of the current link in the absence of
410highlighting, assuming the normal default for showing the cursor."
411 :type '(repeat (string :tag "Argument"))
412 :version "20.3"
413 :group 'browse-url)
414
415(defcustom browse-url-gnudoit-program "gnudoit"
416 "The name of the `gnudoit' program used by `browse-url-w3-gnudoit'."
417 :type 'string
418 :group 'browse-url)
419
420(defcustom browse-url-gnudoit-args '("-q")
421 "*A list of strings defining options for `browse-url-gnudoit-program'.
422These might set the port, for instance."
423 :type '(repeat (string :tag "Argument"))
424 :group 'browse-url)
425
426;;;###autoload
427(defcustom browse-url-generic-program nil
428 "*The name of the browser program used by `browse-url-generic'."
429 :type '(choice string (const :tag "None" nil))
430 :group 'browse-url)
431
432(defcustom browse-url-generic-args nil
433 "*A list of strings defining options for `browse-url-generic-program'."
434 :type '(repeat (string :tag "Argument"))
435 :group 'browse-url)
436
437(defcustom browse-url-temp-dir temporary-file-directory
438 "The name of a directory for browse-url's temporary files.
439Such files are generated by functions like `browse-url-of-region'.
440You might want to set this to somewhere with restricted read permissions
441for privacy's sake."
442 :type 'string
443 :group 'browse-url)
444
445(defcustom browse-url-netscape-version
446 3
447 "The version of Netscape you are using.
448This affects how URL reloading is done; the mechanism changed
449incompatibly at version 4."
450 :type 'number
451 :group 'browse-url)
452
453(defcustom browse-url-lynx-input-field 'avoid
454 "*Action on selecting an existing Lynx buffer at an input field.
455What to do when sending a new URL to an existing Lynx buffer in Emacs
456if the Lynx cursor is on an input field (in which case the `g' command
457would be entered as data). Such fields are recognized by the
458underlines ____. Allowed values: nil: disregard it, 'warn: warn the
459user and don't emit the URL, 'avoid: try to avoid the field by moving
460down (this *won't* always work)."
461 :type '(choice (const :tag "Move to try to avoid field" :value avoid)
462 (const :tag "Disregard" :value nil)
463 (const :tag "Warn, don't emit URL" :value warn))
464 :version "20.3"
465 :group 'browse-url)
466
467(defvar browse-url-lynx-input-attempts 10
468 "*How many times to try to move down from a series of lynx input fields.")
469
470(defcustom browse-url-lynx-input-delay 0.2
471 "How many seconds to wait for lynx between moves down from an input field.")
472
473;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
474;; URL input
475
476(defun browse-url-url-at-point ()
477 (let ((url (thing-at-point 'url)))
478 (set-text-properties 0 (length url) nil url)
479 url))
480
481;; Having this as a separate function called by the browser-specific
482;; functions allows them to be stand-alone commands, making it easier
483;; to switch between browsers.
484
485(defun browse-url-interactive-arg (prompt)
486 "Read a URL from the minibuffer, prompting with PROMPT.
487Default to the URL at or before point. If invoked with a mouse button,
488set point to the position clicked first. Return a list for use in
489`interactive' containing the URL and `browse-url-new-window-p' or its
490negation if a prefix argument was given."
491 (let ((event (elt (this-command-keys) 0)))
492 (and (listp event) (mouse-set-point event)))
493 (list (read-string prompt (browse-url-url-at-point))
494 (not (eq (null browse-url-new-window-p)
495 (null current-prefix-arg)))))
496
497;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
498;; Browse current buffer
499
500;;;###autoload
501(defun browse-url-of-file (&optional file)
502 "Ask a WWW browser to display FILE.
503Display the current buffer's file if FILE is nil or if called
504interactively. Turn the filename into a URL with function
505`browse-url-file-url'. Pass the URL to a browser using the
506`browse-url' function then run `browse-url-of-file-hook'."
507 (interactive)
508 (or file
509 (setq file (buffer-file-name))
510 (error "Current buffer has no file"))
511 (let ((buf (get-file-buffer file)))
512 (if buf
513 (save-excursion
514 (set-buffer buf)
515 (cond ((not (buffer-modified-p)))
516 (browse-url-save-file (save-buffer))
517 (t (message "%s modified since last save" file))))))
518 (browse-url (browse-url-file-url file))
519 (run-hooks 'browse-url-of-file-hook))
520
521(defun browse-url-file-url (file)
522 "Return the URL corresponding to FILE.
523Use variable `browse-url-filename-alist' to map filenames to URLs."
524 ;; URL-encode special chars, do % first
525 (let ((s 0))
526 (while (setq s (string-match "%" file s))
527 (setq file (replace-match "%25" t t file)
528 s (1+ s))))
529 (while (string-match "[*\"()',=;? ]" file)
530 (let ((enc (format "%%%x" (aref file (match-beginning 0)))))
531 (setq file (replace-match enc t t file))))
532 (let ((maps browse-url-filename-alist))
533 (while maps
534 (let* ((map (car maps))
535 (from-re (car map))
536 (to-string (cdr map)))
537 (setq maps (cdr maps))
538 (and (string-match from-re file)
539 (setq file (replace-match to-string t nil file))))))
540 file)
541
542;;;###autoload
543(defun browse-url-of-buffer (&optional buffer)
544 "Ask a WWW browser to display BUFFER.
545Display the current buffer if BUFFER is nil. Display only the
546currently visible part of BUFFER (from a temporary file) if buffer is
547narrowed."
548 (interactive)
549 (save-excursion
550 (and buffer (set-buffer buffer))
551 (let ((file-name
552 ;; Ignore real name if restricted
553 (and (= (- (point-max) (point-min)) (buffer-size))
554 (or buffer-file-name
555 (and (boundp 'dired-directory) dired-directory)))))
556 (or file-name
557 (progn
558 (or browse-url-temp-file-name
559 (setq browse-url-temp-file-name
560 (convert-standard-filename
561 (make-temp-file
562 (expand-file-name "burl" browse-url-temp-dir)))))
563 (setq file-name browse-url-temp-file-name)
564 (write-region (point-min) (point-max) file-name nil 'no-message)))
565 (browse-url-of-file file-name))))
566
567(defun browse-url-delete-temp-file (&optional temp-file-name)
568 ;; Delete browse-url-temp-file-name from the file system
569 ;; If optional arg TEMP-FILE-NAME is non-nil, delete it instead
570 (let ((file-name (or temp-file-name browse-url-temp-file-name)))
571 (if (and file-name (file-exists-p file-name))
572 (delete-file file-name))))
573
574(add-hook 'kill-buffer-hook 'browse-url-delete-temp-file)
575
576;;;###autoload
577(defun browse-url-of-dired-file ()
578 "In Dired, ask a WWW browser to display the file named on this line."
579 (interactive)
580 (browse-url-of-file (dired-get-filename)))
581
582;;;###autoload
583(defun browse-url-of-region (min max)
584 "Ask a WWW browser to display the current region."
585 (interactive "r")
586 (save-excursion
587 (save-restriction
588 (narrow-to-region min max)
589 (browse-url-of-buffer))))
590
591;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
592;; Browser-independent commands
593
594;; A generic command to call the current browse-url-browser-function
595
596;;;###autoload
597(defun browse-url (url &rest args)
598 "Ask a WWW browser to load URL.
599Prompts for a URL, defaulting to the URL at or before point. Variable
600`browse-url-browser-function' says which browser to use."
601 (interactive (browse-url-interactive-arg "URL: "))
602 (if (functionp browse-url-browser-function)
603 (apply browse-url-browser-function url args)
604 ;; The `function' can be an alist; look down it for first match
605 ;; and apply the function (which might be a lambda).
606 (catch 'done
607 (mapcar
608 (lambda (bf)
609 (when (string-match (car bf) url)
610 (apply (cdr bf) url args)
611 (throw 'done t)))
612 browse-url-browser-function)
613 (error "No browser in browse-url-browser-function matching URL %s"
614 url))))
615
616;;;###autoload
617(defun browse-url-at-point ()
618 "Ask a WWW browser to load the URL at or before point.
619Doesn't let you edit the URL like `browse-url'. Variable
620`browse-url-browser-function' says which browser to use."
621 (interactive)
622 (browse-url (browse-url-url-at-point)))
623
624(defun browse-url-event-buffer (event)
625 (window-buffer (posn-window (event-start event))))
626
627(defun browse-url-event-point (event)
628 (posn-point (event-start event)))
629
630;;;###autoload
631(defun browse-url-at-mouse (event)
632 "Ask a WWW browser to load a URL clicked with the mouse.
633The URL is the one around or before the position of the mouse click
634but point is not changed. Doesn't let you edit the URL like
635`browse-url'. Variable `browse-url-browser-function' says which browser
636to use."
637 (interactive "e")
638 (save-excursion
639 (set-buffer (browse-url-event-buffer event))
640 (goto-char (browse-url-event-point event))
641 (let ((url (browse-url-url-at-point)))
642 (if (string-equal url "")
643 (error "No URL found"))
644 (browse-url url browse-url-new-window-p))))
645
646;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
647;; Browser-specific commands
648
649;; --- Default MS-Windows browser ---
650
651(defun browse-url-default-windows-browser (url &optional new-window)
652 (interactive (browse-url-interactive-arg "URL: "))
653 (w32-shell-execute "open" url))
654
655;; --- Netscape ---
656
657(defun browse-url-process-environment ()
658 "Set DISPLAY in the environment to the X display Netscape is running on.
659This is either the value of variable `browse-url-netscape-display' if
660non-nil, or the same display as Emacs if different from the current
661environment, otherwise just use the current environment."
662 (let ((display (or browse-url-netscape-display (browse-url-emacs-display))))
663 (if display
664 (cons (concat "DISPLAY=" display) process-environment)
665 process-environment)))
666
667(defun browse-url-emacs-display ()
668 "Return the X display Emacs is running on.
669This is nil if the display is the same as the DISPLAY environment variable.
670
671Actually Emacs could be using several displays; this just returns the
672one showing the selected frame."
673 (let ((display (cdr-safe (assq 'display (frame-parameters)))))
674 (and (not (equal display (getenv "DISPLAY")))
675 display)))
676
677;;;###autoload
678(defun browse-url-netscape (url &optional new-window)
679 "Ask the Netscape WWW browser to load URL.
680
681Default to the URL around or before point. The strings in variable
682`browse-url-netscape-arguments' are also passed to Netscape.
683
684When called interactively, if variable `browse-url-new-window-p' is
685non-nil, load the document in a new Netscape window, otherwise use a
686random existing one. A non-nil interactive prefix argument reverses
687the effect of `browse-url-new-window-p'.
688
689When called non-interactively, optional second argument NEW-WINDOW is
690used instead of `browse-url-new-window-p'."
691 (interactive (browse-url-interactive-arg "Netscape URL: "))
692 ;; URL encode any `confusing' characters in the URL. This needs to
693 ;; include at least commas; presumably also close parens.
694 (while (string-match "[,)]" url)
695 (setq url (replace-match
696 (format "%%%x" (string-to-char (match-string 0 url))) t t url)))
697 (let* ((process-environment (browse-url-process-environment))
698 (process (apply 'start-process
699 (concat "netscape " url) nil
700 browse-url-netscape-program
701 (append
702 browse-url-netscape-arguments
703 (if (eq window-system 'w32)
704 (list url)
705 (append
706 (if new-window '("-noraise"))
707 (list "-remote"
708 (concat "openURL(" url
709 (if new-window ",new-window")
710 ")"))))))))
711 (set-process-sentinel process
712 (list 'lambda '(process change)
713 (list 'browse-url-netscape-sentinel 'process url)))))
714
715(defun browse-url-netscape-sentinel (process url)
716 "Handle a change to the process communicating with Netscape."
717 (or (eq (process-exit-status process) 0)
718 (let* ((process-environment (browse-url-process-environment)))
719 ;; Netscape not running - start it
720 (message "Starting Netscape...")
721 (apply 'start-process (concat "netscape" url) nil
722 browse-url-netscape-program
723 (append browse-url-netscape-startup-arguments (list url))))))
724
725(defun browse-url-netscape-reload ()
726 "Ask Netscape to reload its current document.
727How depends on `browse-url-netscape-version'."
728 (interactive)
729 ;; Backwards incompatibility reported by
730 ;; <peter.kruse@psychologie.uni-regensburg.de>.
731 (browse-url-netscape-send (if (>= browse-url-netscape-version 4)
732 "xfeDoCommand(reload)"
733 "reload")))
734
735(defun browse-url-netscape-send (command)
736 "Send a remote control command to Netscape."
737 (let* ((process-environment (browse-url-process-environment)))
738 (apply 'start-process "netscape" nil
739 browse-url-netscape-program
740 (append browse-url-netscape-arguments
741 (list "-remote" command)))))
742
743;; --- Mosaic ---
744
745;;;###autoload
746(defun browse-url-mosaic (url &optional new-window)
747 "Ask the XMosaic WWW browser to load URL.
748
749Default to the URL around or before point. The strings in variable
750`browse-url-mosaic-arguments' are also passed to Mosaic and the
751program is invoked according to the variable
752`browse-url-mosaic-program'.
753
754When called interactively, if variable `browse-url-new-window-p' is
755non-nil, load the document in a new Mosaic window, otherwise use a
756random existing one. A non-nil interactive prefix argument reverses
757the effect of `browse-url-new-window-p'.
758
759When called non-interactively, optional second argument NEW-WINDOW is
760used instead of `browse-url-new-window-p'."
761 (interactive (browse-url-interactive-arg "Mosaic URL: "))
762 (let ((pidfile (expand-file-name "~/.mosaicpid"))
763 pid)
764 (if (file-readable-p pidfile)
765 (save-excursion
766 (find-file pidfile)
767 (goto-char (point-min))
768 (setq pid (read (current-buffer)))
769 (kill-buffer nil)))
770 (if (and pid (zerop (signal-process pid 0))) ; Mosaic running
771 (save-excursion
772 (find-file (format "/tmp/Mosaic.%d" pid))
773 (erase-buffer)
774 (insert (if new-window
775 "newwin\n"
776 "goto\n")
777 url "\n")
778 (save-buffer)
779 (kill-buffer nil)
780 ;; Send signal SIGUSR to Mosaic
781 (message "Signalling Mosaic...")
782 (signal-process pid browse-url-usr1-signal)
783 ;; Or you could try:
784 ;; (call-process "kill" nil 0 nil "-USR1" (int-to-string pid))
785 (message "Signalling Mosaic...done")
786 )
787 ;; Mosaic not running - start it
788 (message "Starting Mosaic...")
789 (apply 'start-process "xmosaic" nil browse-url-mosaic-program
790 (append browse-url-mosaic-arguments (list url)))
791 (message "Starting Mosaic...done"))))
792
793;; --- Grail ---
794
795;;;###autoload
796(defvar browse-url-grail
797 (concat (or (getenv "GRAILDIR") "~/.grail") "/user/rcgrail.py")
798 "Location of Grail remote control client script `rcgrail.py'.
799Typically found in $GRAILDIR/rcgrail.py, or ~/.grail/user/rcgrail.py.")
800
801;;;###autoload
802(defun browse-url-grail (url &optional new-window)
803 "Ask the Grail WWW browser to load URL.
804Default to the URL around or before point. Runs the program in the
805variable `browse-url-grail'."
806 (interactive (browse-url-interactive-arg "Grail URL: "))
807 (message "Sending URL to Grail...")
808 (save-excursion
809 (set-buffer (get-buffer-create " *Shell Command Output*"))
810 (erase-buffer)
811 ;; don't worry about this failing.
812 (if new-window
813 (call-process browse-url-grail nil 0 nil "-b" url)
814 (call-process browse-url-grail nil 0 nil url))
815 (message "Sending URL to Grail... done")))
816
817;; --- Mosaic using CCI ---
818
819;;;###autoload
820(defun browse-url-cci (url &optional new-window)
821 "Ask the XMosaic WWW browser to load URL.
822Default to the URL around or before point.
823
824This function only works for XMosaic version 2.5 or later. You must
825select `CCI' from XMosaic's File menu, set the CCI Port Address to the
826value of variable `browse-url-CCI-port', and enable `Accept requests'.
827
828When called interactively, if variable `browse-url-new-window-p' is
829non-nil, load the document in a new browser window, otherwise use a
830random existing one. A non-nil interactive prefix argument reverses
831the effect of `browse-url-new-window-p'.
832
833When called non-interactively, optional second argument NEW-WINDOW is
834used instead of `browse-url-new-window-p'."
835 (interactive (browse-url-interactive-arg "Mosaic URL: "))
836 (open-network-stream "browse-url" " *browse-url*"
837 browse-url-CCI-host browse-url-CCI-port)
838 ;; Todo: start browser if fails
839 (process-send-string "browse-url"
840 (concat "get url (" url ") output "
841 (if new-window
842 "new"
843 "current")
844 "\r\n"))
845 (process-send-string "browse-url" "disconnect\r\n")
846 (delete-process "browse-url"))
847
848;; --- IXI Mosaic ---
849
850;;;###autoload
851(defun browse-url-iximosaic (url &optional new-window)
852 ;; new-window ignored
853 "Ask the IXIMosaic WWW browser to load URL.
854Default to the URL around or before point."
855 (interactive (browse-url-interactive-arg "IXI Mosaic URL: "))
856 (start-process "tellw3b" nil "tellw3b"
857 "-service WWW_BROWSER ixi_showurl " url))
858
859;; --- W3 ---
860
861;;;###autoload
862(defun browse-url-w3 (url &optional new-window)
863 "Ask the w3 WWW browser to load URL.
864Default to the URL around or before point.
865
866When called interactively, if variable `browse-url-new-window-p' is
867non-nil, load the document in a new window. A non-nil interactive
868prefix argument reverses the effect of `browse-url-new-window-p'.
869
870When called non-interactively, optional second argument NEW-WINDOW is
871used instead of `browse-url-new-window-p'."
872 (interactive (browse-url-interactive-arg "W3 URL: "))
873 (require 'w3) ; w3-fetch-other-window not autoloaded
874 (if new-window
875 (w3-fetch-other-window url)
876 (w3-fetch url)))
877
878;;;###autoload
879(defun browse-url-w3-gnudoit (url &optional new-window)
880 ;; new-window ignored
881 "Ask another Emacs running gnuserv to load the URL using the W3 browser.
882The `browse-url-gnudoit-program' program is used with options given by
883`browse-url-gnudoit-args'. Default to the URL around or before point."
884 (interactive (browse-url-interactive-arg "W3 URL: "))
885 (apply 'start-process (concat "gnudoit:" url) nil
886 browse-url-gnudoit-program
887 (append browse-url-gnudoit-args (list (concat "(w3-fetch \"" url "\")") "(raise-frame)"))))
888
889;; --- Lynx in an xterm ---
890
891;;;###autoload
892(defun browse-url-lynx-xterm (url &optional new-window)
893 ;; new-window ignored
894 "Ask the Lynx WWW browser to load URL.
895Default to the URL around or before point. A new Lynx process is run
896in an Xterm window using the Xterm program named by `browse-url-xterm-program'
897with possible additional arguments `browse-url-xterm-args'."
898 (interactive (browse-url-interactive-arg "Lynx URL: "))
899 (apply #'start-process `(,(concat "lynx" url) nil ,browse-url-xterm-program
900 ,@browse-url-xterm-args "-e" "lynx" ,url)))
901
902;; --- Lynx in an Emacs "term" window ---
903
904;;;###autoload
905(defun browse-url-lynx-emacs (url &optional new-buffer)
906 "Ask the Lynx WWW browser to load URL.
907Default to the URL around or before point. With a prefix argument, run
908a new Lynx process in a new buffer.
909
910When called interactively, if variable `browse-url-new-window-p' is
911non-nil, load the document in a new lynx in a new term window,
912otherwise use any existing one. A non-nil interactive prefix argument
913reverses the effect of `browse-url-new-window-p'.
914
915When called non-interactively, optional second argument NEW-WINDOW is
916used instead of `browse-url-new-window-p'."
917 (interactive (browse-url-interactive-arg "Lynx URL: "))
918 (let* ((system-uses-terminfo t) ; Lynx uses terminfo
919 ;; (term-term-name "vt100") ; ??
920 (buf (get-buffer "*lynx*"))
921 (proc (and buf (get-buffer-process buf)))
922 (n browse-url-lynx-input-attempts))
923 (if (and new-buffer buf)
924 ;; Rename away the OLD buffer. This isn't very polite, but
925 ;; term insists on working in a buffer named *lynx* and would
926 ;; choke on *lynx*<1>
927 (progn (set-buffer buf)
928 (rename-uniquely)))
929 (if (or new-buffer
930 (not buf)
931 (not proc)
932 (not (memq (process-status proc) '(run stop))))
933 ;; start a new lynx
934 (progn
935 (setq buf
936 (apply #'make-term
937 `("lynx" "lynx" nil ,@browse-url-lynx-emacs-args ,url)))
938 (switch-to-buffer buf)
939 (term-char-mode)
940 (set-process-sentinel
941 (get-buffer-process buf)
942 ;; Don't leave around a dead one (especially because of its
943 ;; munged keymap.)
944 (lambda (process event)
945 (if (not (memq (process-status process) '(run stop)))
946 (let ((buf (process-buffer process)))
947 (if buf (kill-buffer buf)))))))
948 ;; send the url to lynx in the old buffer
949 (let ((win (get-buffer-window buf t)))
950 (if win
951 (select-window win)
952 (switch-to-buffer buf)))
953 (if (eq (following-char) ?_)
954 (cond ((eq browse-url-lynx-input-field 'warn)
955 (error "Please move out of the input field first."))
956 ((eq browse-url-lynx-input-field 'avoid)
957 (while (and (eq (following-char) ?_) (> n 0))
958 (term-send-down) ; down arrow
959 (sit-for browse-url-lynx-input-delay))
960 (if (eq (following-char) ?_)
961 (error "Cannot move out of the input field, sorry.")))))
962 (term-send-string proc (concat "g" ; goto
963 "\C-u" ; kill default url
964 url
965 "\r")))))
966
967;; --- MMM ---
968
969;;;###autoload
970(defun browse-url-mmm (url &optional new-window)
971 "Ask the MMM WWW browser to load URL.
972Default to the URL around or before point."
973 (interactive (browse-url-interactive-arg "MMM URL: "))
974 (message "Sending URL to MMM...")
975 (save-excursion
976 (set-buffer (get-buffer-create " *Shell Command Output*"))
977 (erase-buffer)
978 ;; mmm_remote just SEGVs if the file isn't there...
979 (if (or (file-exists-p (expand-file-name "~/.mmm_remote"))
980 ;; location in v 0.4:
981 (file-exists-p (expand-file-name "~/.mmm/remote")))
982 (call-process "mmm_remote" nil 0 nil url)
983 (call-process "mmm" nil 0 nil "-external" url))
984 (message "Sending URL to MMM... done")))
985
986;; --- mailto ---
987
988;;;###autoload
989(defun browse-url-mail (url &optional new-window)
990 "Open a new mail message buffer within Emacs.
991Default to using the mailto: URL around or before point as the
992recipient's address. Supplying a non-nil interactive prefix argument
993will cause the mail to be composed in another window rather than the
994current one.
995
996When called interactively, if variable `browse-url-new-window-p' is
997non-nil use `compose-mail-other-window', otherwise `compose-mail'. A
998non-nil interactive prefix argument reverses the effect of
999`browse-url-new-window-p'.
1000
1001When called non-interactively, optional second argument NEW-WINDOW is
1002used instead of `browse-url-new-window-p'."
1003 (interactive (browse-url-interactive-arg "Mailto URL: "))
1004 (save-excursion
1005 (let ((to (if (string-match "^mailto:" url)
1006 (substring url 7)
1007 url)))
1008 (if new-window
1009 (compose-mail-other-window to nil nil nil
1010 (list 'insert-buffer (current-buffer)))
1011 (compose-mail to nil nil nil nil
1012 (list 'insert-buffer (current-buffer)))))))
1013
1014;; --- Random browser ---
1015
1016;;;###autoload
1017(defun browse-url-generic (url &optional new-window)
1018 ;; new-window ignored
1019 "Ask the WWW browser defined by `browse-url-generic-program' to load URL.
1020Default to the URL around or before point. A fresh copy of the
1021browser is started up in a new process with possible additional arguments
1022`browse-url-generic-args'. This is appropriate for browsers which
1023don't offer a form of remote control."
1024 (interactive (browse-url-interactive-arg "URL: "))
1025 (if (not browse-url-generic-program)
1026 (error "No browser defined (`browse-url-generic-program')"))
1027 (apply 'start-process (concat browse-url-generic-program url) nil
1028 browse-url-generic-program
1029 (append browse-url-generic-args (list url))))
1030
1031(provide 'browse-url)
1032
1033;;; browse-url.el ends here
diff --git a/lisp/goto-addr.el b/lisp/goto-addr.el
deleted file mode 100644
index 2cf502bad6a..00000000000
--- a/lisp/goto-addr.el
+++ /dev/null
@@ -1,234 +0,0 @@
1;;; goto-addr.el --- click to browse URL or to send to e-mail address
2
3;; Copyright (C) 1995 Free Software Foundation, Inc.
4
5;; Author: Eric Ding <ericding@mit.edu>
6;; Maintainer: Eric Ding <ericding@mit.edu>
7;; Created: 15 Aug 1995
8;; Keywords: mh-e, www, mouse, mail
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 2, or (at your option)
15;; any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING. If not, write to the
24;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;; Boston, MA 02111-1307, USA.
26
27;;; Commentary:
28
29;; This package allows you to click or hit a key sequence while on a
30;; URL or e-mail address, and either load the URL into a browser of
31;; your choice using the browse-url package, or if it's an e-mail
32;; address, to send an e-mail to that address. By default, we bind to
33;; the [mouse-2] and the [C-c return] key sequences.
34
35;; INSTALLATION
36;;
37;; To use goto-address in a particular mode (for example, while
38;; reading mail in mh-e), add something like this in your .emacs file:
39;;
40;; (add-hook 'mh-show-mode-hook 'goto-address)
41;;
42;; The mouse click method is bound to [mouse-2] on highlighted URL's or
43;; e-mail addresses only; it functions normally everywhere else. To bind
44;; another mouse click to the function, add the following to your .emacs
45;; (for example):
46;;
47;; (setq goto-address-highlight-keymap
48;; (let ((m (make-sparse-keymap)))
49;; (define-key m [S-mouse-2] 'goto-address-at-mouse)
50;; m))
51;;
52
53;; BUG REPORTS
54;;
55;; Please send bug reports to me at ericding@mit.edu.
56
57;; Known bugs/features:
58;; * goto-address-mail-regexp only catches foo@bar.org style addressing,
59;; not stuff like X.400 addresses, etc.
60;; * regexp also catches Message-Id line, since it is in the format of
61;; an Internet e-mail address (like Compuserve addresses)
62;; * If show buffer is fontified after goto-address-fontify is run
63;; (say, using font-lock-fontify-buffer), then font-lock face will
64;; override goto-address faces.
65
66;;; Code:
67
68(require 'browse-url)
69
70(defgroup goto-address nil
71 "Click to browse URL or to send to e-mail address."
72 :group 'mouse
73 :group 'hypermedia)
74
75
76;;; I don't expect users to want fontify'ing without highlighting.
77(defcustom goto-address-fontify-p t
78 "*If t, URL's and e-mail addresses in buffer are fontified.
79But only if `goto-address-highlight-p' is also non-nil."
80 :type 'boolean
81 :group 'goto-address)
82
83(defcustom goto-address-highlight-p t
84 "*If t, URL's and e-mail addresses in buffer are highlighted."
85 :type 'boolean
86 :group 'goto-address)
87
88(defcustom goto-address-fontify-maximum-size 30000
89 "*Maximum size of file in which to fontify and/or highlight URL's."
90 :type 'integer
91 :group 'goto-address)
92
93(defvar goto-address-mail-regexp
94 "[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+"
95 "A regular expression probably matching an e-mail address.")
96
97(defvar goto-address-url-regexp
98 (concat "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|"
99 "telnet\\|wais\\):\\(//[-a-zA-Z0-9_.]+:"
100 "[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*"
101 "[-a-zA-Z0-9_=#$@~`%&*+|\\/]")
102 "A regular expression probably matching a URL.")
103
104(defvar goto-address-highlight-keymap
105 (let ((m (make-sparse-keymap)))
106 (define-key m [mouse-2] 'goto-address-at-mouse)
107 m)
108 "keymap to hold goto-addr's mouse key defs under highlighted URLs.")
109
110(defcustom goto-address-url-face 'bold
111 "*Face to use for URLs."
112 :type 'face
113 :group 'goto-address)
114
115(defcustom goto-address-url-mouse-face 'highlight
116 "*Face to use for URLs when the mouse is on them."
117 :type 'face
118 :group 'goto-address)
119
120(defcustom goto-address-mail-face 'italic
121 "*Face to use for e-mail addresses."
122 :type 'face
123 :group 'goto-address)
124
125(defcustom goto-address-mail-mouse-face 'secondary-selection
126 "*Face to use for e-mail addresses when the mouse is on them."
127 :type 'face
128 :group 'goto-address)
129
130(defun goto-address-fontify ()
131 "Fontify the URL's and e-mail addresses in the current buffer.
132This function implements `goto-address-highlight-p'
133and `goto-address-fontify-p'."
134 (save-excursion
135 (let ((inhibit-read-only t)
136 (inhibit-point-motion-hooks t)
137 (modified (buffer-modified-p)))
138 (goto-char (point-min))
139 (if (< (- (point-max) (point)) goto-address-fontify-maximum-size)
140 (progn
141 (while (re-search-forward goto-address-url-regexp nil t)
142 (let* ((s (match-beginning 0))
143 (e (match-end 0))
144 (this-overlay (make-overlay s e)))
145 (and goto-address-fontify-p
146 (overlay-put this-overlay 'face goto-address-url-face))
147 (overlay-put this-overlay
148 'mouse-face goto-address-url-mouse-face)
149 (overlay-put this-overlay
150 'local-map goto-address-highlight-keymap)))
151 (goto-char (point-min))
152 (while (re-search-forward goto-address-mail-regexp nil t)
153 (let* ((s (match-beginning 0))
154 (e (match-end 0))
155 (this-overlay (make-overlay s e)))
156 (and goto-address-fontify-p
157 (overlay-put this-overlay 'face goto-address-mail-face))
158 (overlay-put this-overlay 'mouse-face
159 goto-address-mail-mouse-face)
160 (overlay-put this-overlay
161 'local-map goto-address-highlight-keymap)))))
162 (and (buffer-modified-p)
163 (not modified)
164 (set-buffer-modified-p nil)))))
165
166;;; code to find and goto addresses; much of this has been blatantly
167;;; snarfed from browse-url.el
168
169;;;###autoload
170(defun goto-address-at-mouse (event)
171 "Send to the e-mail address or load the URL clicked with the mouse.
172Send mail to address at position of mouse click. See documentation for
173`goto-address-find-address-at-point'. If no address is found
174there, then load the URL at or before the position of the mouse click."
175 (interactive "e")
176 (save-excursion
177 (let ((posn (event-start event)))
178 (set-buffer (window-buffer (posn-window posn)))
179 (goto-char (posn-point posn))
180 (let ((address
181 (save-excursion (goto-address-find-address-at-point))))
182 (if (string-equal address "")
183 (let ((url (browse-url-url-at-point)))
184 (if (string-equal url "")
185 (error "No e-mail address or URL found")
186 (browse-url url)))
187 (compose-mail address))))))
188
189;;;###autoload
190(defun goto-address-at-point ()
191 "Send to the e-mail address or load the URL at point.
192Send mail to address at point. See documentation for
193`goto-address-find-address-at-point'. If no address is found
194there, then load the URL at or before point."
195 (interactive)
196 (save-excursion
197 (let ((address (save-excursion (goto-address-find-address-at-point))))
198 (if (string-equal address "")
199 (let ((url (browse-url-url-at-point)))
200 (if (string-equal url "")
201 (error "No e-mail address or URL found")
202 (browse-url url)))
203 (compose-mail address)))))
204
205(defun goto-address-find-address-at-point ()
206 "Find e-mail address around or before point.
207Then search backwards to beginning of line for the start of an e-mail
208address. If no e-mail address found, return the empty string."
209 (let ((bol (save-excursion (beginning-of-line) (point))))
210 (re-search-backward "[^-_A-z0-9.@]" bol 'lim)
211 (if (or (looking-at goto-address-mail-regexp) ; already at start
212 (let ((eol (save-excursion (end-of-line) (point))))
213 (and (re-search-forward goto-address-mail-regexp eol 'lim)
214 (goto-char (match-beginning 0)))))
215 (buffer-substring (match-beginning 0) (match-end 0))
216 "")))m
217
218;;;###autoload
219(defun goto-address ()
220 "Sets up goto-address functionality in the current buffer.
221Allows user to use mouse/keyboard command to click to go to a URL
222or to send e-mail.
223By default, goto-address binds to mouse-2 and C-c RET.
224
225Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
226`goto-address-highlight-p' for more information)."
227 (interactive)
228 (local-set-key "\C-c\r" 'goto-address-at-point)
229 (if goto-address-highlight-p
230 (goto-address-fontify)))
231
232(provide 'goto-addr)
233
234;;; goto-addr.el ends here.
diff --git a/lisp/net-utils.el b/lisp/net-utils.el
deleted file mode 100644
index f03d321e868..00000000000
--- a/lisp/net-utils.el
+++ /dev/null
@@ -1,858 +0,0 @@
1;;; net-utils.el --- Network functions
2
3;; Author: Peter Breton <pbreton@cs.umb.edu>
4;; Created: Sun Mar 16 1997
5;; Keywords: network communications
6;; Time-stamp: <1999-11-13 10:19:01 pbreton>
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26;;
27;; There are three main areas of functionality:
28;;
29;; * Wrap common network utility programs (ping, traceroute, netstat,
30;; nslookup, arp, route). Note that these wrappers are of the diagnostic
31;; functions of these programs only.
32;;
33;; * Implement some very basic protocols in Emacs Lisp (finger and whois)
34;;
35;; * Support connections to HOST/PORT, generally for debugging and the like.
36;; In other words, for doing much the same thing as "telnet HOST PORT", and
37;; then typing commands.
38;;
39;; PATHS
40;;
41;; On some systems, some of these programs are not in normal user path,
42;; but rather in /sbin, /usr/sbin, and so on.
43
44
45;;; Code:
46(eval-when-compile
47 (require 'comint))
48
49;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
50;; Customization Variables
51;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52
53(defgroup net-utils nil
54 "Network utility functions."
55 :prefix "net-utils-"
56 :group 'comm
57 :version "20.3"
58 )
59
60(defcustom net-utils-remove-ctl-m
61 (member system-type (list 'windows-nt 'msdos))
62 "If non-nil, remove control-Ms from output."
63 :group 'net-utils
64 :type 'boolean
65 )
66
67(defcustom traceroute-program
68 (if (eq system-type 'windows-nt)
69 "tracert"
70 "traceroute")
71 "Program to trace network hops to a destination."
72 :group 'net-utils
73 :type 'string
74 )
75
76(defcustom traceroute-program-options nil
77 "Options for the traceroute program."
78 :group 'net-utils
79 :type '(repeat string)
80 )
81
82(defcustom ping-program "ping"
83 "Program to send network test packets to a host."
84 :group 'net-utils
85 :type 'string
86 )
87
88;; On Linux and Irix, the system's ping program seems to send packets
89;; indefinitely unless told otherwise
90(defcustom ping-program-options
91 (and (memq system-type (list 'linux 'gnu/linux 'irix))
92 (list "-c" "4"))
93 "Options for the ping program.
94These options can be used to limit how many ICMP packets are emitted."
95 :group 'net-utils
96 :type '(repeat string)
97 )
98
99(defcustom ipconfig-program
100 (if (eq system-type 'windows-nt)
101 "ipconfig"
102 "ifconfig")
103 "Program to print network configuration information."
104 :group 'net-utils
105 :type 'string
106 )
107
108(defcustom ipconfig-program-options
109 (list
110 (if (eq system-type 'windows-nt)
111 "/all" "-a"))
112 "Options for ipconfig-program."
113 :group 'net-utils
114 :type '(repeat string)
115 )
116
117(defcustom netstat-program "netstat"
118 "Program to print network statistics."
119 :group 'net-utils
120 :type 'string
121 )
122
123(defcustom netstat-program-options
124 (list "-a")
125 "Options for netstat-program."
126 :group 'net-utils
127 :type '(repeat string)
128 )
129
130(defcustom arp-program "arp"
131 "Program to print IP to address translation tables."
132 :group 'net-utils
133 :type 'string
134 )
135
136(defcustom arp-program-options
137 (list "-a")
138 "Options for arp-program."
139 :group 'net-utils
140 :type '(repeat string)
141 )
142
143(defcustom route-program
144 (if (eq system-type 'windows-nt)
145 "route"
146 "netstat")
147 "Program to print routing tables."
148 :group 'net-utils
149 :type 'string
150 )
151
152(defcustom route-program-options
153 (if (eq system-type 'windows-nt)
154 (list "print")
155 (list "-r"))
156 "Options for route-program."
157 :group 'net-utils
158 :type '(repeat string)
159 )
160
161(defcustom nslookup-program "nslookup"
162 "Program to interactively query DNS information."
163 :group 'net-utils
164 :type 'string
165 )
166
167(defcustom nslookup-program-options nil
168 "List of options to pass to the nslookup program."
169 :group 'net-utils
170 :type '(repeat string)
171 )
172
173(defcustom nslookup-prompt-regexp "^> "
174 "Regexp to match the nslookup prompt."
175 :group 'net-utils
176 :type 'regexp
177 )
178
179(defcustom dig-program "dig"
180 "Program to query DNS information."
181 :group 'net-utils
182 :type 'string
183 )
184
185(defcustom ftp-program "ftp"
186 "Progam to run to do FTP transfers."
187 :group 'net-utils
188 :type 'string
189 )
190
191(defcustom ftp-program-options nil
192 "List of options to pass to the FTP program."
193 :group 'net-utils
194 :type '(repeat string)
195 )
196
197(defcustom ftp-prompt-regexp "^ftp>"
198 "Regexp which matches the FTP program's prompt."
199 :group 'net-utils
200 :type 'regexp
201 )
202
203(defcustom smbclient-program "smbclient"
204 "Smbclient program."
205 :group 'net-utils
206 :type 'string
207 )
208
209(defcustom smbclient-program-options nil
210 "List of options to pass to the smbclient program."
211 :group 'net-utils
212 :type '(repeat string)
213 )
214
215(defcustom smbclient-prompt-regexp "^smb: \>"
216 "Regexp which matches the smbclient program's prompt."
217 :group 'net-utils
218 :type 'regexp
219 )
220
221;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
222;; Nslookup goodies
223;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
224
225(defconst nslookup-font-lock-keywords
226 (and window-system
227 (progn
228 (require 'font-lock)
229 (list
230 (list nslookup-prompt-regexp 0 font-lock-reference-face)
231 (list "^[A-Za-z0-9 _]+:" 0 font-lock-type-face)
232 (list "\\<\\(SOA\\|NS\\|MX\\|A\\|CNAME\\)\\>"
233 1 font-lock-keyword-face)
234 ;; Dotted quads
235 (list
236 (mapconcat 'identity
237 (make-list 4 "[0-9]+")
238 "\\.")
239 0 font-lock-variable-name-face)
240 ;; Host names
241 (list
242 (let ((host-expression "[-A-Za-z0-9]+"))
243 (concat
244 (mapconcat 'identity
245 (make-list 2 host-expression)
246 "\\.")
247 "\\(\\." host-expression "\\)*")
248 )
249 0 font-lock-variable-name-face)
250 )))
251 "Expressions to font-lock for nslookup.")
252
253;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
254;; FTP goodies
255;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
256
257(defconst ftp-font-lock-keywords
258 (and window-system
259 (progn
260 (require 'font-lock)
261 (list
262 (list ftp-prompt-regexp 0 font-lock-reference-face)))))
263
264;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
265;; smbclient goodies
266;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
267
268(defconst smbclient-font-lock-keywords
269 (and window-system
270 (progn
271 (require 'font-lock)
272 (list
273 (list smbclient-prompt-regexp 0 font-lock-reference-face)))))
274
275;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
276;; Utility functions
277;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
278
279;; Simplified versions of some at-point functions from ffap.el.
280;; It's not worth loading all of ffap just for these.
281(defun net-utils-machine-at-point ()
282 (let ((pt (point)))
283 (buffer-substring-no-properties
284 (save-excursion
285 (skip-chars-backward "-a-zA-Z0-9.")
286 (point))
287 (save-excursion
288 (skip-chars-forward "-a-zA-Z0-9.")
289 (skip-chars-backward "." pt)
290 (point)))))
291
292(defun net-utils-url-at-point ()
293 (let ((pt (point)))
294 (buffer-substring-no-properties
295 (save-excursion
296 (skip-chars-backward "--:=&?$+@-Z_a-z~#,%")
297 (skip-chars-forward "^A-Za-z0-9" pt)
298 (point))
299 (save-excursion
300 (skip-chars-forward "--:=&?$+@-Z_a-z~#,%")
301 (skip-chars-backward ":;.,!?" pt)
302 (point)))))
303
304
305(defun net-utils-remove-ctrl-m-filter (process output-string)
306 "Remove trailing control Ms."
307 (let ((old-buffer (current-buffer))
308 (filtered-string output-string))
309 (unwind-protect
310 (let ((moving))
311 (set-buffer (process-buffer process))
312 (setq moving (= (point) (process-mark process)))
313
314 (while (string-match "\r" filtered-string)
315 (setq filtered-string
316 (replace-match "" nil nil filtered-string)))
317
318 (save-excursion
319 ;; Insert the text, moving the process-marker.
320 (goto-char (process-mark process))
321 (insert filtered-string)
322 (set-marker (process-mark process) (point)))
323 (if moving (goto-char (process-mark process))))
324 (set-buffer old-buffer))))
325
326(defmacro net-utils-run-program (name header program &rest args)
327 "Run a network information program."
328 ` (let ((buf (get-buffer-create (concat "*" ,name "*"))))
329 (set-buffer buf)
330 (erase-buffer)
331 (insert ,header "\n")
332 (set-process-filter
333 (apply 'start-process ,name buf ,program ,@args)
334 'net-utils-remove-ctrl-m-filter)
335 (display-buffer buf)))
336
337;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
338;; Wrappers for external network programs
339;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
340
341;;;###autoload
342(defun traceroute (target)
343 "Run traceroute program for TARGET."
344 (interactive "sTarget: ")
345 (let ((options
346 (if traceroute-program-options
347 (append traceroute-program-options (list target))
348 (list target))))
349 (net-utils-run-program
350 (concat "Traceroute" " " target)
351 (concat "** Traceroute ** " traceroute-program " ** " target)
352 traceroute-program
353 options
354 )))
355
356;;;###autoload
357(defun ping (host)
358 "Ping HOST.
359If your system's ping continues until interrupted, you can try setting
360`ping-program-options'."
361 (interactive
362 (list (read-from-minibuffer "Ping host: " (net-utils-machine-at-point))))
363 (let ((options
364 (if ping-program-options
365 (append ping-program-options (list host))
366 (list host))))
367 (net-utils-run-program
368 (concat "Ping" " " host)
369 (concat "** Ping ** " ping-program " ** " host)
370 ping-program
371 options
372 )))
373
374;;;###autoload
375(defun ipconfig ()
376 "Run ipconfig program."
377 (interactive)
378 (net-utils-run-program
379 "Ipconfig"
380 (concat "** Ipconfig ** " ipconfig-program " ** ")
381 ipconfig-program
382 ipconfig-program-options
383 ))
384
385;; This is the normal name on most Unixes.
386;;;###autoload
387(defalias 'ifconfig 'ipconfig)
388
389;;;###autoload
390(defun netstat ()
391 "Run netstat program."
392 (interactive)
393 (net-utils-run-program
394 "Netstat"
395 (concat "** Netstat ** " netstat-program " ** ")
396 netstat-program
397 netstat-program-options
398 ))
399
400;;;###autoload
401(defun arp ()
402 "Run the arp program."
403 (interactive)
404 (net-utils-run-program
405 "Arp"
406 (concat "** Arp ** " arp-program " ** ")
407 arp-program
408 arp-program-options
409 ))
410
411;;;###autoload
412(defun route ()
413 "Run the route program."
414 (interactive)
415 (net-utils-run-program
416 "Route"
417 (concat "** Route ** " route-program " ** ")
418 route-program
419 route-program-options
420 ))
421
422;; FIXME -- Needs to be a process filter
423;; (defun netstat-with-filter (filter)
424;; "Run netstat program."
425;; (interactive "sFilter: ")
426;; (netstat)
427;; (set-buffer (get-buffer "*Netstat*"))
428;; (goto-char (point-min))
429;; (delete-matching-lines filter)
430;; )
431
432;;;###autoload
433(defun nslookup-host (host)
434 "Lookup the DNS information for HOST."
435 (interactive
436 (list (read-from-minibuffer "Lookup host: " (net-utils-machine-at-point))))
437 (let ((options
438 (if nslookup-program-options
439 (append nslookup-program-options (list host))
440 (list host))))
441 (net-utils-run-program
442 "Nslookup"
443 (concat "** "
444 (mapconcat 'identity
445 (list "Nslookup" host nslookup-program)
446 " ** "))
447 nslookup-program
448 options
449 )))
450
451
452;;;###autoload
453(defun nslookup ()
454 "Run nslookup program."
455 (interactive)
456 (require 'comint)
457 (comint-run nslookup-program)
458 (set-process-filter (get-buffer-process "*nslookup*")
459 'net-utils-remove-ctrl-m-filter)
460 (nslookup-mode)
461 )
462
463;; Using a derived mode gives us keymaps, hooks, etc.
464(define-derived-mode
465 nslookup-mode comint-mode "Nslookup"
466 "Major mode for interacting with the nslookup program."
467 (set
468 (make-local-variable 'font-lock-defaults)
469 '((nslookup-font-lock-keywords)))
470 (setq local-abbrev-table nslookup-mode-abbrev-table)
471 (abbrev-mode t)
472 (make-local-variable 'comint-prompt-regexp)
473 (setq comint-prompt-regexp nslookup-prompt-regexp)
474 (make-local-variable 'comint-input-autoexpand)
475 (setq comint-input-autoexpand t)
476 )
477
478(define-key nslookup-mode-map "\t" 'comint-dynamic-complete)
479
480(define-abbrev nslookup-mode-abbrev-table "e" "exit")
481(define-abbrev nslookup-mode-abbrev-table "f" "finger")
482(define-abbrev nslookup-mode-abbrev-table "h" "help")
483(define-abbrev nslookup-mode-abbrev-table "lse" "lserver")
484(define-abbrev nslookup-mode-abbrev-table "q" "exit")
485(define-abbrev nslookup-mode-abbrev-table "r" "root")
486(define-abbrev nslookup-mode-abbrev-table "s" "set")
487(define-abbrev nslookup-mode-abbrev-table "se" "server")
488(define-abbrev nslookup-mode-abbrev-table "v" "viewer")
489
490;;;###autoload
491(defun dig (host)
492 "Run dig program."
493 (interactive
494 (list
495 (progn
496 (require 'ffap)
497 (read-from-minibuffer
498 "Lookup host: "
499 (or (ffap-string-at-point 'machine) "")))))
500 (net-utils-run-program
501 "Dig"
502 (concat "** "
503 (mapconcat 'identity
504 (list "Dig" host dig-program)
505 " ** "))
506 dig-program
507 (list host)
508 ))
509
510;; This is a lot less than ange-ftp, but much simpler.
511;;;###autoload
512(defun ftp (host)
513 "Run ftp program."
514 (interactive
515 (list
516 (read-from-minibuffer
517 "Ftp to Host: " (net-utils-machine-at-point))))
518 (require 'comint)
519 (let ((buf (get-buffer-create (concat "*ftp [" host "]*"))))
520 (set-buffer buf)
521 (comint-mode)
522 (comint-exec buf (concat "ftp-" host) ftp-program nil
523 (if ftp-program-options
524 (append (list host) ftp-program-options)
525 (list host)))
526 (ftp-mode)
527 (switch-to-buffer-other-window buf)
528 ))
529
530(define-derived-mode
531 ftp-mode comint-mode "FTP"
532 "Major mode for interacting with the ftp program."
533
534 (set
535 (make-local-variable 'font-lock-defaults)
536 '((ftp-font-lock-keywords)))
537
538 (make-local-variable 'comint-prompt-regexp)
539 (setq comint-prompt-regexp ftp-prompt-regexp)
540
541 (make-local-variable 'comint-input-autoexpand)
542 (setq comint-input-autoexpand t)
543
544 ;; Already buffer local!
545 (setq comint-output-filter-functions
546 (list 'comint-watch-for-password-prompt))
547
548 (setq local-abbrev-table ftp-mode-abbrev-table)
549 (abbrev-mode t)
550 )
551
552(define-abbrev ftp-mode-abbrev-table "q" "quit")
553(define-abbrev ftp-mode-abbrev-table "g" "get")
554(define-abbrev ftp-mode-abbrev-table "p" "prompt")
555(define-abbrev ftp-mode-abbrev-table "anon" "anonymous")
556
557;; Occasionally useful
558(define-key ftp-mode-map "\t" 'comint-dynamic-complete)
559
560(defun smbclient (host service)
561 "Connect to SERVICE on HOST via SMB."
562 (interactive
563 (list
564 (read-from-minibuffer
565 "Connect to Host: " (net-utils-machine-at-point))
566 (read-from-minibuffer "SMB Service: ")))
567 (require 'comint)
568 (let* ((name (format "smbclient [%s\\%s]" host service))
569 (buf (get-buffer-create (concat "*" name "*")))
570 (service-name (concat "\\\\" host "\\" service)))
571 (set-buffer buf)
572 (comint-mode)
573 (comint-exec buf name smbclient-program nil
574 (if smbclient-program-options
575 (append (list service-name) smbclient-program-options)
576 (list service-name)))
577 (smbclient-mode)
578 (switch-to-buffer-other-window buf)
579 ))
580
581(defun smbclient-list-shares (host)
582 "List services on HOST."
583 (interactive
584 (list
585 (read-from-minibuffer
586 "Connect to Host: " (net-utils-machine-at-point))
587 ))
588 (let ((buf (get-buffer-create (format "*SMB Shares on %s*" host))))
589 (set-buffer buf)
590 (comint-mode)
591 (comint-exec
592 buf
593 "smbclient-list-shares"
594 smbclient-program
595 nil
596 (list "-L" host)
597 )
598 (smbclient-mode)
599 (switch-to-buffer-other-window buf)))
600
601(define-derived-mode
602 smbclient-mode comint-mode "smbclient"
603 "Major mode for interacting with the smbclient program."
604
605 (set
606 (make-local-variable 'font-lock-defaults)
607 '((smbclient-font-lock-keywords)))
608
609 (make-local-variable 'comint-prompt-regexp)
610 (setq comint-prompt-regexp smbclient-prompt-regexp)
611
612 (make-local-variable 'comint-input-autoexpand)
613 (setq comint-input-autoexpand t)
614
615 ;; Already buffer local!
616 (setq comint-output-filter-functions
617 (list 'comint-watch-for-password-prompt))
618
619 (setq local-abbrev-table smbclient-mode-abbrev-table)
620 (abbrev-mode t)
621 )
622
623(define-abbrev smbclient-mode-abbrev-table "q" "quit")
624
625
626;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
627;; Network Connections
628;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
629
630;; Full list is available at:
631;; ftp://ftp.isi.edu/in-notes/iana/assignments/port-numbers
632(defvar network-connection-service-alist
633 (list
634 (cons 'echo 7)
635 (cons 'active-users 11)
636 (cons 'daytime 13)
637 (cons 'chargen 19)
638 (cons 'ftp 21)
639 (cons 'telnet 23)
640 (cons 'smtp 25)
641 (cons 'time 37)
642 (cons 'whois 43)
643 (cons 'gopher 70)
644 (cons 'finger 79)
645 (cons 'www 80)
646 (cons 'pop2 109)
647 (cons 'pop3 110)
648 (cons 'sun-rpc 111)
649 (cons 'nntp 119)
650 (cons 'ntp 123)
651 (cons 'netbios-name 137)
652 (cons 'netbios-data 139)
653 (cons 'irc 194)
654 (cons 'https 443)
655 (cons 'rlogin 513)
656 )
657 "Alist of services and associated TCP port numbers.
658This list in not complete.")
659
660;; Workhorse macro
661(defmacro run-network-program (process-name host port
662 &optional initial-string)
663 `
664 (let ((tcp-connection)
665 (buf)
666 )
667 (setq buf (get-buffer-create (concat "*" ,process-name "*")))
668 (set-buffer buf)
669 (or
670 (setq tcp-connection
671 (open-network-stream
672 ,process-name
673 buf
674 ,host
675 ,port
676 ))
677 (error "Could not open connection to %s" ,host))
678 (erase-buffer)
679 (set-marker (process-mark tcp-connection) (point-min))
680 (set-process-filter tcp-connection 'net-utils-remove-ctrl-m-filter)
681 (and ,initial-string
682 (process-send-string tcp-connection
683 (concat ,initial-string "\r\n")))
684 (display-buffer buf)))
685
686;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
687;; Simple protocols
688;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
689
690;; Finger protocol
691;;;###autoload
692(defun finger (user host)
693 "Finger USER on HOST."
694 ;; One of those great interactive statements that's actually
695 ;; longer than the function call! The idea is that if the user
696 ;; uses a string like "pbreton@cs.umb.edu", we won't ask for the
697 ;; host name. If we don't see an "@", we'll prompt for the host.
698 (interactive
699 (let* ((answer (read-from-minibuffer "Finger User: "
700 (net-utils-url-at-point)))
701 (index (string-match (regexp-quote "@") answer)))
702 (if index
703 (list
704 (substring answer 0 index)
705 (substring answer (1+ index)))
706 (list
707 answer
708 (read-from-minibuffer "At Host: " (net-utils-machine-at-point))))))
709 (let* (
710 (user-and-host (concat user "@" host))
711 (process-name
712 (concat "Finger [" user-and-host "]"))
713 )
714 (run-network-program
715 process-name
716 host
717 (cdr (assoc 'finger network-connection-service-alist))
718 user-and-host
719 )))
720
721(defcustom whois-server-name "rs.internic.net"
722 "Default host name for the whois service."
723 :group 'net-utils
724 :type 'string
725 )
726
727(defcustom whois-server-list
728 '(("whois.arin.net") ; Networks, ASN's, and related POC's (numbers)
729 ("rs.internic.net") ; domain related info
730 ("whois.abuse.net")
731 ("whois.apnic.net")
732 ("nic.ddn.mil")
733 ("whois.nic.mil")
734 ("whois.nic.gov")
735 ("whois.ripe.net"))
736 "A list of whois servers that can be queried."
737 :group 'net-utils
738 :type '(repeat (list string)))
739
740(defcustom whois-server-tld
741 '(("rs.internic.net" . "com")
742 ("rs.internic.net" . "org")
743 ("whois.ripe.net" . "be")
744 ("whois.ripe.net" . "de")
745 ("whois.ripe.net" . "dk")
746 ("whois.ripe.net" . "it")
747 ("whois.ripe.net" . "fi")
748 ("whois.ripe.net" . "fr")
749 ("whois.ripe.net" . "uk")
750 ("whois.apnic.net" . "au")
751 ("whois.apnic.net" . "ch")
752 ("whois.apnic.net" . "hk")
753 ("whois.apnic.net" . "jp")
754 ("whois.nic.gov" . "gov")
755 ("whois.nic.mil" . "mil"))
756 "Alist to map top level domains to whois servers."
757 :group 'net-utils
758 :type '(repeat (cons string string)))
759
760(defcustom whois-guess-server t
761 "If non-nil then whois will try to deduce the appropriate whois
762server from the query. If the query doesn't look like a domain or hostname
763then the server named by whois-server-name is used."
764 :group 'net-utils
765 :type 'boolean)
766
767(defun whois-get-tld (host)
768 "Return the top level domain of `host', or nil if it isn't a domain name."
769 (let ((i (1- (length host)))
770 (max-len (- (length host) 5)))
771 (while (not (or (= i max-len) (char-equal (aref host i) ?.)))
772 (setq i (1- i)))
773 (if (= i max-len)
774 nil
775 (substring host (1+ i)))))
776
777;; Whois protocol
778;;;###autoload
779(defun whois (arg search-string)
780 "Send SEARCH-STRING to server defined by the `whois-server-name' variable.
781If `whois-guess-server' is non-nil, then try to deduce the correct server
782from SEARCH-STRING. With argument, prompt for whois server."
783 (interactive "P\nsWhois: ")
784 (let* ((whois-apropos-host (if whois-guess-server
785 (rassoc (whois-get-tld search-string)
786 whois-server-tld)
787 nil))
788 (server-name (if whois-apropos-host
789 (car whois-apropos-host)
790 whois-server-name))
791 (host
792 (if arg
793 (completing-read "Whois server name: "
794 whois-server-list nil nil "whois.")
795 server-name)))
796 (run-network-program
797 "Whois"
798 host
799 (cdr (assoc 'whois network-connection-service-alist))
800 search-string
801 )))
802
803(defcustom whois-reverse-lookup-server "whois.arin.net"
804 "Server which provides inverse DNS mapping."
805 :group 'net-utils
806 :type 'string
807 )
808
809;;;###autoload
810(defun whois-reverse-lookup ()
811 (interactive)
812 (let ((whois-server-name whois-reverse-lookup-server))
813 (call-interactively 'whois)))
814
815;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
816;;; General Network connection
817;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
818
819;;;###autoload
820(defun network-connection-to-service (host service)
821 "Open a network connection to SERVICE on HOST."
822 (interactive
823 (list
824 (read-from-minibuffer "Host: " (net-utils-machine-at-point))
825 (completing-read "Service: "
826 (mapcar
827 (function
828 (lambda (elt)
829 (list (symbol-name (car elt)))))
830 network-connection-service-alist))))
831 (network-connection
832 host
833 (cdr (assoc (intern service) network-connection-service-alist)))
834 )
835
836;;;###autoload
837(defun network-connection (host port)
838 "Open a network connection to HOST on PORT."
839 (interactive "sHost: \nnPort: ")
840 (network-service-connection host (number-to-string port)))
841
842(defun network-service-connection (host service)
843 "Open a network connection to SERVICE on HOST."
844 (require 'comint)
845 (let (
846 (process-name (concat "Network Connection [" host " " service "]"))
847 (portnum (string-to-number service))
848 )
849 (or (zerop portnum) (setq service portnum))
850 (make-comint
851 process-name
852 (cons host service))
853 (pop-to-buffer (get-buffer (concat "*" process-name "*")))
854 ))
855
856(provide 'net-utils)
857
858;;; net-utils.el ends here
diff --git a/lisp/quickurl.el b/lisp/quickurl.el
deleted file mode 100644
index 5e230231bab..00000000000
--- a/lisp/quickurl.el
+++ /dev/null
@@ -1,552 +0,0 @@
1;;; quickurl.el --- Insert an URL based on text at point in buffer.
2
3;; Copyright (C) 1999 Free Software Foundation, Inc.
4
5;; Author: Dave Pearson <davep@hagbard.demon.co.uk>
6;; Maintainer: Dave Pearson <davep@hagbard.demon.co.uk>
7;; Created: 1999-05-28
8;; Keywords: hypermedia
9
10;; This file is part of GNU emacs.
11
12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 2, or (at your option)
15;; any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING. If not, write to the
24;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;; Boston, MA 02111-1307, USA.
26
27;;; Commentary:
28;;
29;; This package provides a simple method of inserting an URL based on the
30;; text at point in the current buffer. This is part of an on-going effort
31;; to increase the information I provide people while reducing the ammount
32;; of typing I need to do. No-doubt there are undiscovered Emacs packages
33;; out there that do all of this and do it better, feel free to point me to
34;; them, in the mean time I'm having fun playing with Emacs Lisp.
35;;
36;; The URLs are stored in an external file as a list of either cons cells,
37;; or lists. A cons cell entry looks like this:
38;;
39;; (<Lookup> . <URL>)
40;;
41;; where <Lookup> is a string that acts as the keyword lookup and <URL> is
42;; the URL associated with it. An example might be:
43;;
44;; ("GNU" . "http://www.gnu.org/")
45;;
46;; A list entry looks like:
47;;
48;; (<Lookup> <URL> <Comment>)
49;;
50;; where <Lookup> and <URL> are the same as with the cons cell and <Comment>
51;; is any text you like that describes the URL. This description will be
52;; used when presenting a list of URLS using `quickurl-list'. An example
53;; might be:
54;;
55;; ("FSF" "http://www.fsf.org/" "The Free Software Foundation")
56;;
57;; Given the above, your quickurl file might look like:
58;;
59;; (("GNU" . "http://www.gnu.org/")
60;; ("FSF" "http://www.fsf.org/" "The Free Software Foundation")
61;; ("emacs" . "http://www.emacs.org/")
62;; ("hagbard" "http://www.hagbard.demon.co.uk" "Hagbard's World"))
63;;
64;; In case you're wondering about the mixture of cons cells and lists,
65;; quickurl started life using just the cons cells, there were no comments.
66;; URL comments are a later addition and so there is a mixture to keep
67;; backward compatibility with existing URL lists.
68;;
69;; The name and location of the file is up to you, the default name used by
70;; `quickurl' is stored in `quickurl-url-file'.
71;;
72;; quickurl is always available from:
73;;
74;; <URL:http://www.hagbard.demon.co.uk/archives/quickurl.el>
75;; <URL:http://www.acemake.com/hagbard/archives/quickurl.el>
76
77;;; TODO:
78;;
79;; o The quickurl-browse-url* functions pretty much duplicate their non
80;; browsing friends. It would feel better if a more generic solution could
81;; be found.
82
83;;; Code:
84
85;; Things we need:
86
87(eval-when-compile
88 (require 'cl))
89(require 'thingatpt)
90(require 'pp)
91(require 'browse-url)
92
93;; Attempt to handle older/other emacs.
94(eval-and-compile
95 ;; If customize isn't available just use defvar instead.
96 (unless (fboundp 'defgroup)
97 (defmacro defgroup (&rest rest) nil)
98 (defmacro defcustom (symbol init docstring &rest rest)
99 `(defvar ,symbol ,init ,docstring))))
100
101;; Customize options.
102
103(defgroup quickurl nil
104 "Insert an URL based on text at point in buffer."
105 :version "21.1"
106 :group 'abbrev
107 :prefix "quickurl-")
108
109(defcustom quickurl-url-file "~/.quickurls"
110 "*File that contains the URL list."
111 :type 'file
112 :group 'quickurl)
113
114(defcustom quickurl-format-function (lambda (url) (format "<URL:%s>" url))
115 "*Function to format the URL before insertion into the current buffer."
116 :type 'function
117 :group 'quickurl)
118
119(defcustom quickurl-sort-function (lambda (list)
120 (sort list
121 (lambda (x y)
122 (string<
123 (downcase (quickurl-url-description x))
124 (downcase (quickurl-url-description y))))))
125 "*Function to sort the URL list."
126 :type 'function
127 :group 'quickurl)
128
129(defcustom quickurl-grab-lookup-function #'current-word
130 "*Function to grab the thing to lookup."
131 :type 'function
132 :group 'quickurl)
133
134(defcustom quickurl-assoc-function #'assoc-ignore-case
135 "*Function to use for alist lookup into `quickurl-urls'."
136 :type 'function
137 :group 'quickurl)
138
139(defcustom quickurl-completion-ignore-case t
140 "*Should `quickurl-ask' ignore case when doing the input lookup?"
141 :type 'boolean
142 :group 'quickurl)
143
144(defcustom quickurl-prefix ";; -*- lisp -*-\n\n"
145 "*Text to write to `quickurl-url-file' before writing the URL list."
146 :type 'string
147 :group 'quickurl)
148
149(defcustom quickurl-postfix ""
150 "*Text to write to `quickurl-url-file' after writing the URL list.
151
152See the constant `quickurl-reread-hook-postfix' for some example text that
153could be used here."
154 :type 'string
155 :group 'quickurl)
156
157(defcustom quickurl-list-mode-hook nil
158 "*Hooks for `quickurl-list-mode'."
159 :type 'hook
160 :group 'quickurl)
161
162;; Constants.
163
164;;;###autoload
165(defconst quickurl-reread-hook-postfix
166 "
167;; Local Variables:
168;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil)))
169;; End:
170"
171 "Example `quickurl-postfix' text that adds a local variable to the
172`quickurl-url-file' so that if you edit it by hand it will ensure that
173`quickurl-urls' is updated with the new URL list.
174
175To make use of this do something like:
176
177 (setq quickurl-postfix quickurl-reread-hook-postfix)
178
179in your ~/.emacs (after loading/requiring quickurl).")
180
181;; Non-customize variables.
182
183(defvar quickurl-urls nil
184 "URL alist for use with `quickurl' and `quickurl-ask'.")
185
186(defvar quickurl-list-mode-map nil
187 "Local keymap for a `quickurl-list-mode' buffer.")
188
189(defvar quickurl-list-buffer-name "*quickurl-list*"
190 "Name for the URL listinig buffer.")
191
192(defvar quickurl-list-last-buffer nil
193 "`current-buffer' when `quickurl-list' was called.")
194
195;; Functions for working with an URL entry.
196
197(defun quickurl-url-commented-p (url)
198 "Does the URL have a comment?"
199 (listp (cdr url)))
200
201(defun quickurl-make-url (keyword url &optional comment)
202 "Create an URL from KEYWORD, URL and (optionaly) COMMENT."
203 (if (and comment (not (zerop (length comment))))
204 (list keyword url comment)
205 (cons keyword url)))
206
207(defun quickurl-url-keyword (url)
208 "Return the keyword for the URL.
209
210Note that this function is a setfable place."
211 (car url))
212
213(defsetf quickurl-url-keyword (url) (store)
214 `(setf (car ,url) ,store))
215
216(defun quickurl-url-url (url)
217 "Return the actual URL of the URL.
218
219Note that this function is a setfable place."
220 (if (quickurl-url-commented-p url)
221 (cadr url)
222 (cdr url)))
223
224(defsetf quickurl-url-url (url) (store)
225 `
226 (if (quickurl-url-commented-p ,url)
227 (setf (cadr ,url) ,store)
228 (setf (cdr ,url) ,store)))
229
230(defun quickurl-url-comment (url)
231 "Get the comment from an URL.
232
233If the URL has no comment an empty string is returned. Also note that this
234function is a setfable place."
235 (if (quickurl-url-commented-p url)
236 (nth 2 url)
237 ""))
238
239(defsetf quickurl-url-comment (url) (store)
240 `
241 (if (quickurl-url-commented-p ,url)
242 (if (zerop (length ,store))
243 (setf (cdr ,url) (cadr ,url))
244 (setf (nth 2 ,url) ,store))
245 (unless (zerop (length ,store))
246 (setf (cdr ,url) (list (cdr ,url) ,store)))))
247
248(defun quickurl-url-description (url)
249 "Return a description for the URL.
250
251If the URL has a comment then this is returned, otherwise the keyword is
252returned."
253 (let ((desc (quickurl-url-comment url)))
254 (if (zerop (length desc))
255 (quickurl-url-keyword url)
256 desc)))
257
258;; Main code:
259
260(defun* quickurl-read (&optional (buffer (current-buffer)))
261 "`read' the URL list from BUFFER into `quickurl-urls'.
262
263Note that this function moves point to `point-min' before doing the `read'
264It also restores point after the `read'."
265 (save-excursion
266 (setf (point) (point-min))
267 (setq quickurl-urls (funcall quickurl-sort-function (read buffer)))))
268
269(defun quickurl-load-urls ()
270 "Load the contents of `quickurl-url-file' into `quickurl-urls'."
271 (when (file-exists-p quickurl-url-file)
272 (with-temp-buffer
273 (insert-file-contents quickurl-url-file)
274 (quickurl-read))))
275
276(defun quickurl-save-urls ()
277 "Save the contents of `quickurl-urls' to `quickurl-url-file'."
278 (with-temp-buffer
279 (let ((standard-output (current-buffer)))
280 (princ quickurl-prefix)
281 (pp quickurl-urls)
282 (princ quickurl-postfix)
283 (write-region (point-min) (point-max) quickurl-url-file nil 0))))
284
285(defun quickurl-find-url (lookup)
286 "Return URL associated with key LOOKUP.
287
288The lookup is done by looking in the alist `quickurl-urls' and the `cons'
289for the URL is returned. The actual method used to look into the alist
290depends on the setting of the variable `quickurl-assoc-function'."
291 (funcall quickurl-assoc-function lookup quickurl-urls))
292
293(defun quickurl-insert (url &optional silent)
294 "Insert URL, formatted using `quickurl-format-function'.
295
296Also display a `message' saying what the URL was unless SILENT is non-nil."
297 (insert (funcall quickurl-format-function (quickurl-url-url url)))
298 (unless silent
299 (message "Found %s" (quickurl-url-url url))))
300
301;;;###autoload
302(defun* quickurl (&optional (lookup (funcall quickurl-grab-lookup-function)))
303 "Insert an URL based on LOOKUP.
304
305If not supplied LOOKUP is taken to be the word at point in the current
306buffer, this default action can be modifed via
307`quickurl-grab-lookup-function'."
308 (interactive)
309 (when lookup
310 (quickurl-load-urls)
311 (let ((url (quickurl-find-url lookup)))
312 (if (null url)
313 (error "No URL associated with \"%s\"" lookup)
314 (when (looking-at "\\w")
315 (skip-syntax-forward "\\w"))
316 (insert " ")
317 (quickurl-insert url)))))
318
319;;;###autoload
320(defun quickurl-ask (lookup)
321 "Insert an URL, with `completing-read' prompt, based on LOOKUP."
322 (interactive
323 (list
324 (progn
325 (quickurl-load-urls)
326 (let ((completion-ignore-case quickurl-completion-ignore-case))
327 (completing-read "Lookup: " quickurl-urls nil t)))))
328 (let ((url (quickurl-find-url lookup)))
329 (when url
330 (quickurl-insert url))))
331
332(defun quickurl-grab-url ()
333 "Attempt to grab a word/url pair from point in the current buffer.
334
335Point should be somewhere on the URL and the word is taken to be the thing
336that is returned from calling `quickurl-grab-lookup-function' once a
337`backward-word' has been issued at the start of the URL.
338
339It is assumed that the URL is either \"unguarded\" or is wrapped inside an
340<URL:...> wrapper."
341 (let ((url (thing-at-point 'url)))
342 (when url
343 (save-excursion
344 (beginning-of-thing 'url)
345 ;; `beginning-of-thing' doesn't take you to the start of a marked-up
346 ;; URL, only to the start of the URL within the "markup". So, we
347 ;; need to do a little more work to get to where we want to be.
348 (when (thing-at-point-looking-at thing-at-point-markedup-url-regexp)
349 (search-backward "<URL:"))
350 (backward-word 1)
351 (let ((word (funcall quickurl-grab-lookup-function)))
352 (when word
353 (quickurl-make-url
354 ;; The grab function may return the word with properties. I don't
355 ;; want the properties. I couldn't find a method of stripping
356 ;; them from a "string" so this will have to do. If you know of
357 ;; a better method of doing this I'd love to know.
358 (with-temp-buffer
359 (insert word)
360 (buffer-substring-no-properties (point-min) (point-max)))
361 url)))))))
362
363;;;###autoload
364(defun quickurl-add-url (word url comment)
365 "Allow the user to interactively add a new URL associated with WORD.
366
367See `quickurl-grab-url' for details on how the default word/url combination
368is decided."
369 (interactive (let ((word-url (quickurl-grab-url)))
370 (list (read-string "Word: " (quickurl-url-keyword word-url))
371 (read-string "URL: " (quickurl-url-url word-url))
372 (read-string "Comment: " (quickurl-url-comment word-url)))))
373 (if (zerop (length word))
374 (error "You must specify a WORD for lookup")
375 (quickurl-load-urls)
376 (let* ((current-url (quickurl-find-url word))
377 (add-it (if current-url
378 (if (interactive-p)
379 (y-or-n-p (format "\"%s\" exists, replace URL? " word))
380 t)
381 t)))
382 (when add-it
383 (if current-url
384 (progn
385 (setf (quickurl-url-url current-url) url)
386 (setf (quickurl-url-comment current-url) comment))
387 (push (quickurl-make-url word url comment) quickurl-urls))
388 (setq quickurl-urls (funcall quickurl-sort-function quickurl-urls))
389 (quickurl-save-urls)
390 (when (get-buffer quickurl-list-buffer-name)
391 (quickurl-list-populate-buffer))
392 (when (interactive-p)
393 (message "Added %s" url))))))
394
395;;;###autoload
396(defun* quickurl-browse-url (&optional (lookup (funcall quickurl-grab-lookup-function)))
397 "Browse the URL associated with LOOKUP.
398
399If not supplied LOOKUP is taken to be the word at point in the
400current buffer, this default action can be modifed via
401`quickurl-grab-lookup-function'."
402 (interactive)
403 (when lookup
404 (quickurl-load-urls)
405 (let ((url (quickurl-find-url lookup)))
406 (if url
407 (browse-url (quickurl-url-url url))
408 (error "No URL associated with \"%s\"" lookup)))))
409
410;;;###autoload
411(defun quickurl-browse-url-ask (lookup)
412 "Browse the URL, with `completing-read' prompt, associated with LOOKUP."
413 (interactive (list
414 (progn
415 (quickurl-load-urls)
416 (completing-read "Browse: " quickurl-urls nil t))))
417 (let ((url (quickurl-find-url lookup)))
418 (when url
419 (browse-url (quickurl-url-url url)))))
420
421;;;###autoload
422(defun quickurl-edit-urls ()
423 "Pull `quickurl-url-file' into a buffer for hand editing."
424 (interactive)
425 (find-file quickurl-url-file))
426
427;; quickurl-list mode.
428
429(unless quickurl-list-mode-map
430 (let ((map (make-sparse-keymap)))
431 (suppress-keymap map t)
432 (define-key map "a" #'quickurl-list-add-url)
433 (define-key map [(control m)] #'quickurl-list-insert-url)
434 (define-key map "u" #'quickurl-list-insert-naked-url)
435 (define-key map " " #'quickurl-list-insert-with-lookup)
436 (define-key map "l" #'quickurl-list-insert-lookup)
437 (define-key map "d" #'quickurl-list-insert-with-desc)
438 (define-key map [(control g)] #'quickurl-list-quit)
439 (define-key map "q" #'quickurl-list-quit)
440 (define-key map [mouse-2] #'quickurl-list-mouse-select)
441 (define-key map "?" #'describe-mode)
442 (setq quickurl-list-mode-map map)))
443
444(put 'quickurl-list-mode 'mode-class 'special)
445
446;;;###autoload
447(defun quickurl-list-mode ()
448 "A mode for browsing the quickurl URL list.
449
450The key bindings for `quickurl-list-mode' are:
451
452\\{quickurl-list-mode-map}"
453 (interactive)
454 (kill-all-local-variables)
455 (use-local-map quickurl-list-mode-map)
456 (setq major-mode 'quickurl-list-mode
457 mode-name "quickurl list")
458 (run-hooks 'quickurl-list-mode-hook)
459 (setq buffer-read-only t
460 truncate-lines t))
461
462;;;###autoload
463(defun quickurl-list ()
464 "Display `quickurl-list' as a formatted list using `quickurl-list-mode'."
465 (interactive)
466 (quickurl-load-urls)
467 (unless (string= (buffer-name) quickurl-list-buffer-name)
468 (setq quickurl-list-last-buffer (current-buffer)))
469 (pop-to-buffer quickurl-list-buffer-name)
470 (quickurl-list-populate-buffer)
471 (quickurl-list-mode))
472
473(defun quickurl-list-populate-buffer ()
474 "Populate the `quickurl-list' buffer."
475 (with-current-buffer (get-buffer quickurl-list-buffer-name)
476 (let ((buffer-read-only nil)
477 (fmt (format "%%-%ds %%s\n"
478 (apply #'max (or (loop for url in quickurl-urls
479 collect (length (quickurl-url-description url)))
480 (list 20))))))
481 (setf (buffer-string) "")
482 (loop for url in quickurl-urls
483 do (let ((start (point)))
484 (insert (format fmt (quickurl-url-description url)
485 (quickurl-url-url url)))
486 (put-text-property start (1- (point))
487 'mouse-face 'highlight)))
488 (setf (point) (point-min)))))
489
490(defun quickurl-list-add-url (word url comment)
491 "Wrapper for `quickurl-add-url' that doesn't guess the parameters."
492 (interactive "sWord: \nsURL: \nsComment: ")
493 (quickurl-add-url word url comment))
494
495(defun quickurl-list-quit ()
496 "Kill the buffer named `quickurl-list-buffer-name'."
497 (interactive)
498 (kill-buffer quickurl-list-buffer-name)
499 (switch-to-buffer quickurl-list-last-buffer)
500 (delete-other-windows))
501
502(defun quickurl-list-mouse-select (event)
503 "Select the URL under the mouse click."
504 (interactive "e")
505 (setf (point) (posn-point (event-end event)))
506 (quickurl-list-insert-url))
507
508(defun quickurl-list-insert (type)
509 "Insert the URL under cursor into `quickurl-list-last-buffer'.
510TYPE dictates what will be inserted, options are:
511 `url' - Insert the URL as <URL:url>
512 `naked-url' - Insert the URL with no formatting
513 `with-lookup' - Insert \"lookup <URL:url>\"
514 `with-desc' - Insert \"description <URL:url>\"
515 `lookup' - Insert the lookup for that URL"
516 (let ((url (nth (save-excursion
517 (beginning-of-line)
518 (count-lines (point-min) (point)))
519 quickurl-urls)))
520 (if url
521 (with-current-buffer quickurl-list-last-buffer
522 (insert
523 (case type
524 ('url (format "<URL:%s>" (quickurl-url-url url)))
525 ('naked-url (quickurl-url-url url))
526 ('with-lookup (format "%s <URL:%s>"
527 (quickurl-url-keyword url)
528 (quickurl-url-url url)))
529 ('with-desc (format "%S <URL:%s>"
530 (quickurl-url-description url)
531 (quickurl-url-url url)))
532 ('lookup (quickurl-url-keyword url)))))
533 (error "No URL details on that line"))
534 url))
535
536(defmacro quickurl-list-make-inserter (type)
537 "Macro to make a key-response function for use in `quickurl-list-mode-map'."
538 `(defun ,(intern (format "quickurl-list-insert-%S" type)) ()
539 ,(format "Insert the result of calling `quickurl-list-insert' with `%s'." type)
540 (interactive)
541 (when (quickurl-list-insert ',type)
542 (quickurl-list-quit))))
543
544(quickurl-list-make-inserter url)
545(quickurl-list-make-inserter naked-url)
546(quickurl-list-make-inserter with-lookup)
547(quickurl-list-make-inserter with-desc)
548(quickurl-list-make-inserter lookup)
549
550(provide 'quickurl)
551
552;;; quickurl.el ends here
diff --git a/lisp/rcompile.el b/lisp/rcompile.el
deleted file mode 100644
index ec97c7c4dcb..00000000000
--- a/lisp/rcompile.el
+++ /dev/null
@@ -1,179 +0,0 @@
1;;; rcompile.el --- run a compilation on a remote machine
2
3;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
4
5;; Author: Albert <alon@milcse.rtsg.mot.com>
6;; Maintainer: FSF
7;; Created: 1993 Oct 6
8;; Keywords: tools, processes
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 2, or (at your option)
15;; any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING. If not, write to the
24;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;; Boston, MA 02111-1307, USA.
26
27;;; Commentary:
28
29;; This package is for running a remote compilation and using emacs to parse
30;; the error messages. It works by rsh'ing the compilation to a remote host
31;; and parsing the output. If the file visited at the time remote-compile was
32;; called was loaded remotely (ange-ftp), the host and user name are obtained
33;; by the calling ange-ftp-ftp-name on the current directory. In this case the
34;; next-error command will also ange-ftp the files over. This is achieved
35;; automatically because the compilation-parse-errors function uses
36;; default-directory to build its file names. If however the file visited was
37;; loaded locally, remote-compile prompts for a host and user and assumes the
38;; files mounted locally (otherwise, how was the visited file loaded).
39
40;; See the user defined variables section for more info.
41
42;; I was contemplating redefining "compile" to "remote-compile" automatically
43;; if the file visited was ange-ftp'ed but decided against it for now. If you
44;; feel this is a good idea, let me know and I'll consider it again.
45
46;; Installation:
47
48;; To use rcompile, you also need to give yourself permission to connect to
49;; the remote host. You do this by putting lines like:
50
51;; monopoly alon
52;; vme33
53;;
54;; in a file named .rhosts in the home directory (of the remote machine).
55;; Be careful what you put in this file. A line like:
56;;
57;; +
58;;
59;; Will allow anyone access to your account without a password. I suggest you
60;; read the rhosts(5) manual page before you edit this file (if you are not
61;; familiar with it already)
62
63;;; Code:
64
65(provide 'rcompile)
66(require 'compile)
67;;; The following should not be needed.
68;;; (eval-when-compile (require 'ange-ftp))
69
70;;;; user defined variables
71
72(defgroup remote-compile nil
73 "Run a compilation on a remote machine"
74 :group 'processes
75 :group 'tools)
76
77
78(defcustom remote-compile-host nil
79 "*Host for remote compilations."
80 :type '(choice string (const nil))
81 :group 'remote-compile)
82
83(defcustom remote-compile-user nil
84 "User for remote compilations.
85nil means use the value returned by \\[user-login-name]."
86 :type '(choice string (const nil))
87 :group 'remote-compile)
88
89(defcustom remote-compile-run-before nil
90 "*Command to run before compilation.
91This can be used for setting up environment variables,
92since rsh does not invoke the shell as a login shell and files like .login
93\(tcsh\) and .bash_profile \(bash\) are not run.
94nil means run no commands."
95 :type '(choice string (const nil))
96 :group 'remote-compile)
97
98(defcustom remote-compile-prompt-for-host nil
99 "*Non-nil means prompt for host if not available from filename."
100 :type 'boolean
101 :group 'remote-compile)
102
103(defcustom remote-compile-prompt-for-user nil
104 "*Non-nil means prompt for user if not available from filename."
105 :type 'boolean
106 :group 'remote-compile)
107
108;;;; internal variables
109
110;; History of remote compile hosts and users
111(defvar remote-compile-host-history nil)
112(defvar remote-compile-user-history nil)
113
114
115;;;; entry point
116
117;;;###autoload
118(defun remote-compile (host user command)
119 "Compile the the current buffer's directory on HOST. Log in as USER.
120See \\[compile]."
121 (interactive
122 (let ((parsed (or (and (featurep 'ange-ftp)
123 (ange-ftp-ftp-name default-directory))))
124 host user command prompt)
125 (if parsed
126 (setq host (nth 0 parsed)
127 user (nth 1 parsed))
128 (setq prompt (if (stringp remote-compile-host)
129 (format "Compile on host (default %s): "
130 remote-compile-host)
131 "Compile on host: ")
132 host (if (or remote-compile-prompt-for-host
133 (null remote-compile-host))
134 (read-from-minibuffer prompt
135 "" nil nil
136 'remote-compile-host-history)
137 remote-compile-host)
138 user (if remote-compile-prompt-for-user
139 (read-from-minibuffer (format
140 "Compile by user (default %s)"
141 (or remote-compile-user
142 (user-login-name)))
143 "" nil nil
144 'remote-compile-user-history)
145 remote-compile-user)))
146 (setq command (read-from-minibuffer "Compile command: "
147 compile-command nil nil
148 '(compile-history . 1)))
149 (list (if (string= host "") remote-compile-host host)
150 (if (string= user "") remote-compile-user user)
151 command)))
152 (setq compile-command command)
153 (cond (user
154 (setq remote-compile-user user))
155 ((null remote-compile-user)
156 (setq remote-compile-user (user-login-name))))
157 (let* ((parsed (and (featurep 'ange-ftp)
158 (ange-ftp-ftp-name default-directory)))
159 (compile-command
160 (format "%s %s -l %s \"(%scd %s; %s)\""
161 remote-shell-program
162 host
163 remote-compile-user
164 (if remote-compile-run-before
165 (concat remote-compile-run-before "; ")
166 "")
167 (if parsed (nth 2 parsed) default-directory)
168 compile-command)))
169 (setq remote-compile-host host)
170 (save-some-buffers nil nil)
171 (compile-internal compile-command "No more errors")
172 ;; Set comint-file-name-prefix in the compilation buffer so
173 ;; compilation-parse-errors will find referenced files by ange-ftp.
174 (save-excursion
175 (set-buffer compilation-last-buffer)
176 (make-variable-buffer-local 'comint-file-name-prefix)
177 (setq comint-file-name-prefix (concat "/" host ":")))))
178
179;;; rcompile.el ends here
diff --git a/lisp/rlogin.el b/lisp/rlogin.el
deleted file mode 100644
index 8448e563eb0..00000000000
--- a/lisp/rlogin.el
+++ /dev/null
@@ -1,373 +0,0 @@
1;;; rlogin.el --- remote login interface
2
3;; Copyright (C) 1992, 93, 94, 95, 97, 1998 Free Software Foundation, Inc.
4
5;; Author: Noah Friedman
6;; Maintainer: Noah Friedman <friedman@splode.com>
7;; Keywords: unix, comm
8
9;; $Id: rlogin.el,v 1.44 1998/10/03 00:44:26 friedman Exp $
10
11;; This file is part of GNU Emacs.
12
13;; GNU Emacs is free software; you can redistribute it and/or modify
14;; it under the terms of the GNU General Public License as published by
15;; the Free Software Foundation; either version 2, or (at your option)
16;; any later version.
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
24;; along with GNU Emacs; see the file COPYING. If not, write to the
25;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;; Boston, MA 02111-1307, USA.
27
28;;; Commentary:
29
30;; Support for remote logins using `rlogin'.
31;; This program is layered on top of shell.el; the code here only accounts
32;; for the variations needed to handle a remote process, e.g. directory
33;; tracking and the sending of some special characters.
34
35;; If you wish for rlogin mode to prompt you in the minibuffer for
36;; passwords when a password prompt appears, just enter m-x send-invisible
37;; and type in your line, or add `comint-watch-for-password-prompt' to
38;; `comint-output-filter-functions'.
39
40;;; Code:
41
42(require 'comint)
43(require 'shell)
44
45(defgroup rlogin nil
46 "Remote login interface"
47 :group 'processes
48 :group 'unix)
49
50(defcustom rlogin-program "rlogin"
51 "*Name of program to invoke rlogin"
52 :type 'string
53 :group 'rlogin)
54
55(defcustom rlogin-explicit-args nil
56 "*List of arguments to pass to rlogin on the command line."
57 :type '(repeat (string :tag "Argument"))
58 :group 'rlogin)
59
60(defcustom rlogin-mode-hook nil
61 "*Hooks to run after setting current buffer to rlogin-mode."
62 :type 'hook
63 :group 'rlogin)
64
65(defcustom rlogin-process-connection-type
66 (save-match-data
67 ;; Solaris 2.x `rlogin' will spew a bunch of ioctl error messages if
68 ;; stdin isn't a tty.
69 (cond ((and (boundp 'system-configuration)
70 (stringp system-configuration)
71 (string-match "-solaris2" system-configuration))
72 t)
73 (t nil)))
74 "*If non-`nil', use a pty for the local rlogin process.
75If `nil', use a pipe (if pipes are supported on the local system).
76
77Generally it is better not to waste ptys on systems which have a static
78number of them. On the other hand, some implementations of `rlogin' assume
79a pty is being used, and errors will result from using a pipe instead."
80 :type '(choice (const :tag "pipes" nil)
81 (other :tag "ptys" t))
82 :group 'rlogin)
83
84(defcustom rlogin-directory-tracking-mode 'local
85 "*Control whether and how to do directory tracking in an rlogin buffer.
86
87nil means don't do directory tracking.
88
89t means do so using an ftp remote file name.
90
91Any other value means do directory tracking using local file names.
92This works only if the remote machine and the local one
93share the same directories (through NFS). This is the default.
94
95This variable becomes local to a buffer when set in any fashion for it.
96
97It is better to use the function of the same name to change the behavior of
98directory tracking in an rlogin session once it has begun, rather than
99simply setting this variable, since the function does the necessary
100re-synching of directories."
101 :type '(choice (const :tag "off" nil)
102 (const :tag "ftp" t)
103 (other :tag "local" local))
104 :group 'rlogin)
105
106(make-variable-buffer-local 'rlogin-directory-tracking-mode)
107
108(defcustom rlogin-host nil
109 "*The name of the remote host. This variable is buffer-local."
110 :type '(choice (const nil) string)
111 :group 'rlogin)
112
113(defcustom rlogin-remote-user nil
114 "*The username used on the remote host.
115This variable is buffer-local and defaults to your local user name.
116If rlogin is invoked with the `-l' option to specify the remote username,
117this variable is set from that."
118 :type '(choice (const nil) string)
119 :group 'rlogin)
120
121;; Initialize rlogin mode map.
122(defvar rlogin-mode-map '())
123(cond
124 ((null rlogin-mode-map)
125 (setq rlogin-mode-map (if (consp shell-mode-map)
126 (cons 'keymap shell-mode-map)
127 (copy-keymap shell-mode-map)))
128 (define-key rlogin-mode-map "\C-c\C-c" 'rlogin-send-Ctrl-C)
129 (define-key rlogin-mode-map "\C-c\C-d" 'rlogin-send-Ctrl-D)
130 (define-key rlogin-mode-map "\C-c\C-z" 'rlogin-send-Ctrl-Z)
131 (define-key rlogin-mode-map "\C-c\C-\\" 'rlogin-send-Ctrl-backslash)
132 (define-key rlogin-mode-map "\C-d" 'rlogin-delchar-or-send-Ctrl-D)
133 (define-key rlogin-mode-map "\C-i" 'rlogin-tab-or-complete)))
134
135
136;;;###autoload (add-hook 'same-window-regexps "^\\*rlogin-.*\\*\\(\\|<[0-9]+>\\)")
137
138(defvar rlogin-history nil)
139
140;;;###autoload
141(defun rlogin (input-args &optional buffer)
142 "Open a network login connection via `rlogin' with args INPUT-ARGS.
143INPUT-ARGS should start with a host name; it may also contain
144other arguments for `rlogin'.
145
146Input is sent line-at-a-time to the remote connection.
147
148Communication with the remote host is recorded in a buffer `*rlogin-HOST*'
149\(or `*rlogin-USER@HOST*' if the remote username differs\).
150If a prefix argument is given and the buffer `*rlogin-HOST*' already exists,
151a new buffer with a different connection will be made.
152
153When called from a program, if the optional second argument BUFFER is
154a string or buffer, it specifies the buffer to use.
155
156The variable `rlogin-program' contains the name of the actual program to
157run. It can be a relative or absolute path.
158
159The variable `rlogin-explicit-args' is a list of arguments to give to
160the rlogin when starting. They are added after any arguments given in
161INPUT-ARGS.
162
163If the default value of `rlogin-directory-tracking-mode' is t, then the
164default directory in that buffer is set to a remote (FTP) file name to
165access your home directory on the remote machine. Occasionally this causes
166an error, if you cannot access the home directory on that machine. This
167error is harmless as long as you don't try to use that default directory.
168
169If `rlogin-directory-tracking-mode' is neither t nor nil, then the default
170directory is initially set up to your (local) home directory.
171This is useful if the remote machine and your local machine
172share the same files via NFS. This is the default.
173
174If you wish to change directory tracking styles during a session, use the
175function `rlogin-directory-tracking-mode' rather than simply setting the
176variable."
177 (interactive (list
178 (read-from-minibuffer "rlogin arguments (hostname first): "
179 nil nil nil 'rlogin-history)
180 current-prefix-arg))
181
182 (let* ((process-connection-type rlogin-process-connection-type)
183 (args (if rlogin-explicit-args
184 (append (rlogin-parse-words input-args)
185 rlogin-explicit-args)
186 (rlogin-parse-words input-args)))
187 (host (car args))
188 (user (or (car (cdr (member "-l" args)))
189 (user-login-name)))
190 (buffer-name (if (string= user (user-login-name))
191 (format "*rlogin-%s*" host)
192 (format "*rlogin-%s@%s*" user host)))
193 proc)
194
195 (cond ((null buffer))
196 ((stringp buffer)
197 (setq buffer-name buffer))
198 ((bufferp buffer)
199 (setq buffer-name (buffer-name buffer)))
200 ((numberp buffer)
201 (setq buffer-name (format "%s<%d>" buffer-name buffer)))
202 (t
203 (setq buffer-name (generate-new-buffer-name buffer-name))))
204
205 (setq buffer (get-buffer-create buffer-name))
206 (pop-to-buffer buffer-name)
207
208 (cond
209 ((comint-check-proc buffer-name))
210 (t
211 (comint-exec buffer buffer-name rlogin-program nil args)
212 (setq proc (get-buffer-process buffer))
213 ;; Set process-mark to point-max in case there is text in the
214 ;; buffer from a previous exited process.
215 (set-marker (process-mark proc) (point-max))
216
217 ;; comint-output-filter-functions is treated like a hook: it is
218 ;; processed via run-hooks or run-hooks-with-args in later versions
219 ;; of emacs.
220 ;; comint-output-filter-functions should already have a
221 ;; permanent-local property, at least in emacs 19.27 or later.
222 (cond
223 ((fboundp 'make-local-hook)
224 (make-local-hook 'comint-output-filter-functions)
225 (add-hook 'comint-output-filter-functions 'rlogin-carriage-filter
226 nil t))
227 (t
228 (make-local-variable 'comint-output-filter-functions)
229 (add-hook 'comint-output-filter-functions 'rlogin-carriage-filter)))
230
231 (rlogin-mode)
232
233 (make-local-variable 'rlogin-host)
234 (setq rlogin-host host)
235 (make-local-variable 'rlogin-remote-user)
236 (setq rlogin-remote-user user)
237
238 (condition-case ()
239 (cond ((eq rlogin-directory-tracking-mode t)
240 ;; Do this here, rather than calling the tracking mode
241 ;; function, to avoid a gratuitous resync check; the default
242 ;; should be the user's home directory, be it local or remote.
243 (setq comint-file-name-prefix
244 (concat "/" rlogin-remote-user "@" rlogin-host ":"))
245 (cd-absolute comint-file-name-prefix))
246 ((null rlogin-directory-tracking-mode))
247 (t
248 (cd-absolute (concat comint-file-name-prefix "~/"))))
249 (error nil))))))
250
251(put 'rlogin-mode 'mode-class 'special)
252
253(defun rlogin-mode ()
254 "Set major-mode for rlogin sessions.
255If `rlogin-mode-hook' is set, run it."
256 (interactive)
257 (kill-all-local-variables)
258 (shell-mode)
259 (setq major-mode 'rlogin-mode)
260 (setq mode-name "rlogin")
261 (use-local-map rlogin-mode-map)
262 (setq shell-dirtrackp rlogin-directory-tracking-mode)
263 (make-local-variable 'comint-file-name-prefix)
264 (run-hooks 'rlogin-mode-hook))
265
266(defun rlogin-directory-tracking-mode (&optional prefix)
267 "Do remote or local directory tracking, or disable entirely.
268
269If called with no prefix argument or a unspecified prefix argument (just
270``\\[universal-argument]'' with no number) do remote directory tracking via
271ange-ftp. If called as a function, give it no argument.
272
273If called with a negative prefix argument, disable directory tracking
274entirely.
275
276If called with a positive, numeric prefix argument, e.g.
277``\\[universal-argument] 1 M-x rlogin-directory-tracking-mode\'',
278then do directory tracking but assume the remote filesystem is the same as
279the local system. This only works in general if the remote machine and the
280local one share the same directories (through NFS)."
281 (interactive "P")
282 (cond
283 ((or (null prefix)
284 (consp prefix))
285 (setq rlogin-directory-tracking-mode t)
286 (setq shell-dirtrackp t)
287 (setq comint-file-name-prefix
288 (concat "/" rlogin-remote-user "@" rlogin-host ":")))
289 ((< prefix 0)
290 (setq rlogin-directory-tracking-mode nil)
291 (setq shell-dirtrackp nil))
292 (t
293 (setq rlogin-directory-tracking-mode 'local)
294 (setq comint-file-name-prefix "")
295 (setq shell-dirtrackp t)))
296 (cond
297 (shell-dirtrackp
298 (let* ((proc (get-buffer-process (current-buffer)))
299 (proc-mark (process-mark proc))
300 (current-input (buffer-substring proc-mark (point-max)))
301 (orig-point (point))
302 (offset (and (>= orig-point proc-mark)
303 (- (point-max) orig-point))))
304 (unwind-protect
305 (progn
306 (delete-region proc-mark (point-max))
307 (goto-char (point-max))
308 (shell-resync-dirs))
309 (goto-char proc-mark)
310 (insert current-input)
311 (if offset
312 (goto-char (- (point-max) offset))
313 (goto-char orig-point)))))))
314
315
316;; Parse a line into its constituent parts (words separated by
317;; whitespace). Return a list of the words.
318(defun rlogin-parse-words (line)
319 (let ((list nil)
320 (posn 0)
321 (match-data (match-data)))
322 (while (string-match "[^ \t\n]+" line posn)
323 (setq list (cons (substring line (match-beginning 0) (match-end 0))
324 list))
325 (setq posn (match-end 0)))
326 (set-match-data (match-data))
327 (nreverse list)))
328
329(defun rlogin-carriage-filter (string)
330 (let* ((point-marker (point-marker))
331 (end (process-mark (get-buffer-process (current-buffer))))
332 (beg (or (and (boundp 'comint-last-output-start)
333 comint-last-output-start)
334 (- end (length string)))))
335 (goto-char beg)
336 (while (search-forward "\C-m" end t)
337 (delete-char -1))
338 (goto-char point-marker)))
339
340(defun rlogin-send-Ctrl-C ()
341 (interactive)
342 (process-send-string nil "\C-c"))
343
344(defun rlogin-send-Ctrl-D ()
345 (interactive)
346 (process-send-string nil "\C-d"))
347
348(defun rlogin-send-Ctrl-Z ()
349 (interactive)
350 (process-send-string nil "\C-z"))
351
352(defun rlogin-send-Ctrl-backslash ()
353 (interactive)
354 (process-send-string nil "\C-\\"))
355
356(defun rlogin-delchar-or-send-Ctrl-D (arg)
357 "\
358Delete ARG characters forward, or send a C-d to process if at end of buffer."
359 (interactive "p")
360 (if (eobp)
361 (rlogin-send-Ctrl-D)
362 (delete-char arg)))
363
364(defun rlogin-tab-or-complete ()
365 "Complete file name if doing directory tracking, or just insert TAB."
366 (interactive)
367 (if rlogin-directory-tracking-mode
368 (comint-dynamic-complete)
369 (insert "\C-i")))
370
371(provide 'rlogin)
372
373;;; rlogin.el ends here
diff --git a/lisp/snmp-mode.el b/lisp/snmp-mode.el
deleted file mode 100644
index 8753cceda25..00000000000
--- a/lisp/snmp-mode.el
+++ /dev/null
@@ -1,716 +0,0 @@
1;;; snmp-mode.el --- SNMP & SNMPv2 MIB major mode.
2
3;; Copyright (C) 1995,1998 Free Software Foundation, Inc.
4
5;; Author: Paul D. Smith <psmith@BayNetworks.com>
6;; Keywords: data
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;; INTRODUCTION
26;; ------------
27;; This package provides a major mode for editing SNMP MIBs. It
28;; provides all the modern Emacs 19 bells and whistles: default
29;; fontification via font-lock, imenu search functions, etc.
30;;
31;; SNMP mode also uses tempo, a textual boilerplate insertion package
32;; distributed with Emacs, to add in boilerplate SNMP MIB structures.
33;; See tempo.el for more details about tempo.
34;;
35;; If you want to change or add new tempo templates, use the tempo tag
36;; list `snmp-tempo-tags' (or `snmpv2-tempo-tags'): this list is
37;; automatically installed when snmp-mode (or snmpv2-mode) is entered.
38;;
39;; The SNMPv2 mode in this version has been enhanced thanks to popular
40;; demand.
41;;
42;; I'm very interested in new tempo macros for both v1 and v2, and any
43;; other suggestions for enhancements (different syntax table items, new
44;; keybindings, etc.)
45;;
46;;
47;; USAGE
48;; -----
49;; Mostly, use it as you would any other mode. There's a very
50;; simplistic auto-indent feature; hopefully it'll help more than get in
51;; your way. For the most part it tries to indent to the same level as
52;; the previous line. It will try to recognize some very simple tokens
53;; on the previous line that tell it to use extra indent or outdent.
54;;
55;; Templates
56;; ---------
57;; To use the Tempo templates, type the Tempo tag (or a unique prefix)
58;; and use C-c C-i (C-c TAB) to complete it; if you don't have
59;; tempo-interactive set to nil it will ask you to fill in values.
60;; Fields with predefined values (SYNTAX, STATUS, etc.) will do
61;; completing-reads on a list of valid values; use the normal SPC or TAB
62;; to complete.
63;;
64;; Currently the following templates are available:
65;;
66;; objectType -- Defines an OBJECT-TYPE macro.
67;;
68;; tableType -- Defines both a Table and Entry OBJECT-TYPE, and a
69;; SEQUENCE for the ASN.1 Entry definition.
70;;
71;; Once the template is done, you can use C-cC-f and C-cC-b to move back
72;; and forth between the Tempo sequence points to fill in the rest of
73;; the information.
74;;
75;; Font Lock
76;; ------------
77;;
78;; If you want font-lock in your MIB buffers, add this:
79;;
80;; (add-hook 'snmp-common-mode-hook 'turn-on-font-lock)
81;;
82;; Enabling global-font-lock-mode is also sufficient.
83;;
84
85;;;----------------------------------------------------------------------------
86;;
87;; Customize these:
88;;
89;;;----------------------------------------------------------------------------
90
91(defgroup snmp nil
92 "Mode for editing SNMP MIB files."
93 :group 'data
94 :version "20.4")
95
96(defcustom snmp-special-indent t
97 "*If non-nil, use a simple heuristic to try to guess the right indentation.
98If nil, then no special indentation is attempted."
99 :type 'boolean
100 :group 'snmp)
101
102(defcustom snmp-indent-level 4
103 "*Indentation level for SNMP MIBs."
104 :type 'integer
105 :group 'snmp)
106
107(defcustom snmp-tab-always-indent nil
108 "*Non-nil means TAB should always reindent the current line.
109A value of nil means reindent if point is within the initial line indentation;
110otherwise insert a TAB."
111 :type 'boolean
112 :group 'snmp)
113
114(defcustom snmp-completion-ignore-case t
115 "*Non-nil means that case differences are ignored during completion.
116A value of nil means that case is significant.
117This is used during Tempo template completion."
118 :type 'boolean
119 :group 'snmp)
120
121(defcustom snmp-common-mode-hook nil
122 "*Hook(s) evaluated when a buffer enters either SNMP or SNMPv2 mode."
123 :type 'hook
124 :group 'snmp)
125
126(defcustom snmp-mode-hook nil
127 "*Hook(s) evaluated when a buffer enters SNMP mode."
128 :type 'hook
129 :group 'snmp)
130
131(defcustom snmpv2-mode-hook nil
132 "*Hook(s) evaluated when a buffer enters SNMPv2 mode."
133 :type 'hook
134 :group 'snmp)
135
136(defvar snmp-tempo-tags nil
137 "*Tempo tags for SNMP mode.")
138
139(defvar snmpv2-tempo-tags nil
140 "*Tempo tags for SNMPv2 mode.")
141
142
143;; Enable fontification for SNMP MIBs
144;;
145
146;; These are pretty basic fontifications. Note we assume these macros
147;; are first on a line (except whitespace), to speed up fontification.
148;;
149(defvar snmp-font-lock-keywords-1
150 (list
151 ;; OBJECT-TYPE, TRAP-TYPE, and OBJECT-IDENTIFIER macros
152 '("^[ \t]*\\([a-z][-a-zA-Z0-9]+\\)[ \t]+\\(\\(MODULE-\\(COMPLIANCE\\|IDENTITY\\)\\|OBJECT-\\(COMPLIANCE\\|GROUP\\|IDENTITY\\|TYPE\\)\\|TRAP-\\(GROUP\\|TYPE\\)\\)\\|\\(OBJECT\\)[ \t]+\\(IDENTIFIER\\)[ \t]*::=\\)"
153 (1 font-lock-variable-name-face) (3 font-lock-keyword-face nil t)
154 (7 font-lock-keyword-face nil t) (8 font-lock-keyword-face nil t))
155
156 ;; DEFINITIONS clause
157 '("^[ \t]*\\([A-Z][-a-zA-Z0-9]+\\)[ \t]+\\(DEFINITIONS\\)[ \t]*::="
158 (1 font-lock-function-name-face) (2 font-lock-keyword-face))
159 )
160 "Basic SNMP MIB mode expression highlighting.")
161
162(defvar snmp-font-lock-keywords-2
163 (append
164 '(("ACCESS\\|BEGIN\\|DE\\(FVAL\\|SCRIPTION\\)\\|END\\|FROM\\|I\\(MPORTS\\|NDEX\\)\\|S\\(TATUS\\|YNTAX\\)"
165 (0 font-lock-keyword-face)))
166 snmp-font-lock-keywords-1)
167 "Medium SNMP MIB mode expression highlighting.")
168
169(defvar snmp-font-lock-keywords-3
170 (append
171 '(("\\([^\n]+\\)[ \t]+::=[ \t]+\\(SEQUENCE\\)[ \t]+{"
172 (1 font-lock-reference-face) (2 font-lock-keyword-face))
173 ("::=[ \t]*{[ \t]*\\([a-z0-9].*[ \t]+\\)?\\([0-9]+\\)[ \t]*}"
174 (1 font-lock-reference-face nil t) (2 font-lock-variable-name-face)))
175 snmp-font-lock-keywords-2)
176 "Gaudy SNMP MIB mode expression highlighting.")
177
178(defvar snmp-font-lock-keywords snmp-font-lock-keywords-1
179 "Default SNMP MIB mode expression highlighting.")
180
181
182;; These lists are used for the completion capabilities in the tempo
183;; templates.
184;;
185
186(defvar snmp-mode-syntax-list nil
187 "Predefined types for SYNTAX clauses.")
188
189(defvar snmp-rfc1155-types
190 '(("INTEGER") ("OCTET STRING") ("OBJECT IDENTIFIER") ("NULL") ("IpAddress")
191 ("NetworkAddress") ("Counter") ("Gauge") ("TimeTicks") ("Opaque"))
192 "Types from RFC 1155 v1 SMI.")
193
194(defvar snmp-rfc1213-types
195 '(("DisplayString"))
196 "Types from RFC 1213 MIB-II.")
197
198(defvar snmp-rfc1902-types
199 '(("INTEGER") ("OCTET STRING") ("OBJECT IDENTIFIER") ("Integer32")
200 ("IpAddress") ("Counter32") ("Gauge32") ("Unsigned32") ("TimeTicks")
201 ("Opaque") ("Counter64"))
202 "Types from RFC 1902 v2 SMI.")
203
204(defvar snmp-rfc1903-types
205 '(("DisplayString") ("PhysAddress") ("MacAddress") ("TruthValue")
206 ("TestAndIncr") ("AutonomousType") ("InstancePointer")
207 ("VariablePointer") ("RowPointer") ("RowStatus") ("TimeStamp")
208 ("TimeInterval") ("DateAndTime") ("StorageType") ("TDomain")
209 ("TAddress"))
210 "Types from RFC 1903 Textual Conventions.")
211
212
213(defvar snmp-mode-access-list nil
214 "Predefined values for ACCESS clauses.")
215
216(defvar snmp-rfc1155-access
217 '(("read-only") ("read-write") ("write-only") ("not-accessible"))
218 "ACCESS values from RFC 1155 v1 SMI.")
219
220(defvar snmp-rfc1902-access
221 '(("read-only") ("read-write") ("read-create") ("not-accessible")
222 ("accessible-for-notify"))
223 "ACCESS values from RFC 1155 v1 SMI.")
224
225
226(defvar snmp-mode-status-list nil
227 "Predefined values for STATUS clauses.")
228
229(defvar snmp-rfc1212-status
230 '(("mandatory") ("obsolete") ("deprecated"))
231 "STATUS values from RFC 1212 v1 SMI.")
232
233(defvar snmp-rfc1902-status
234 '(("current") ("obsolete") ("deprecated"))
235 "STATUS values from RFC 1902 v2 SMI.")
236
237
238;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
239;;;----------------------------------------------------------------------------
240;;
241;; Nothing to customize below here.
242;;
243;;;----------------------------------------------------------------------------
244;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
245
246
247;; Need this stuff when compiling for imenu macros, etc.
248;;
249(eval-when-compile
250 (require 'cl)
251 (require 'imenu))
252
253
254;; Create abbrev table for SNMP MIB mode
255;;
256(defvar snmp-mode-abbrev-table nil
257 "Abbrev table in use in SNMP mode.")
258(define-abbrev-table 'snmp-mode-abbrev-table ())
259
260
261;; Create abbrev table for SNMPv2 mode
262;;
263(defvar snmpv2-mode-abbrev-table nil
264 "Abbrev table in use in SNMPv2 mode.")
265(define-abbrev-table 'snmpv2-mode-abbrev-table ())
266
267
268;; Set up our keymap
269;;
270(defvar snmp-mode-map (make-sparse-keymap)
271 "Keymap used in SNMP mode.")
272
273(define-key snmp-mode-map "\t" 'snmp-indent-command)
274(define-key snmp-mode-map "\177" 'backward-delete-char-untabify)
275
276(define-key snmp-mode-map "\C-c\C-i" 'tempo-complete-tag)
277(define-key snmp-mode-map "\C-c\C-f" 'tempo-forward-mark)
278(define-key snmp-mode-map "\C-c\C-b" 'tempo-backward-mark)
279
280
281;; Set up our syntax table
282;;
283(defvar snmp-mode-syntax-table nil
284 "Syntax table used for buffers in SNMP mode.")
285
286(if snmp-mode-syntax-table
287 ()
288 (setq snmp-mode-syntax-table (make-syntax-table))
289 (modify-syntax-entry ?\\ "\\" snmp-mode-syntax-table)
290 (modify-syntax-entry ?- "_ 1234" snmp-mode-syntax-table)
291 (modify-syntax-entry ?\n ">" snmp-mode-syntax-table)
292 (modify-syntax-entry ?\^m ">" snmp-mode-syntax-table)
293 (modify-syntax-entry ?_ "." snmp-mode-syntax-table)
294 (modify-syntax-entry ?: "." snmp-mode-syntax-table)
295 (modify-syntax-entry ?= "." snmp-mode-syntax-table))
296
297;; Set up the stuff that's common between snmp-mode and snmpv2-mode
298;;
299(defun snmp-common-mode (name mode abbrev font-keywords imenu-index tempo-tags)
300 (kill-all-local-variables)
301
302 ;; Become the current major mode
303 (setq mode-name name)
304 (setq major-mode mode)
305
306 ;; Activate keymap, syntax table, and abbrev table
307 (use-local-map snmp-mode-map)
308 (set-syntax-table snmp-mode-syntax-table)
309 (setq local-abbrev-table abbrev)
310
311 ;; Set up paragraphs (?)
312 (make-local-variable 'paragraph-start)
313 (setq paragraph-start (concat "$\\|" page-delimiter))
314 (make-local-variable 'paragraph-separate)
315 (setq paragraph-separate paragraph-start)
316 (make-local-variable 'paragraph-ignore-fill-prefix)
317 (setq paragraph-ignore-fill-prefix t)
318
319 ;; Set up comments
320 (make-local-variable 'comment-start)
321 (setq comment-start "-- ")
322 (make-local-variable 'comment-start-skip)
323 (setq comment-start-skip "--+[ \t]*")
324 (make-local-variable 'comment-column)
325 (setq comment-column 40)
326 (make-local-variable 'parse-sexp-ignore-comments)
327 (setq parse-sexp-ignore-comments t)
328
329 ;; Set up indentation
330 (make-local-variable 'indent-line-function)
331 (setq indent-line-function (if snmp-special-indent
332 'snmp-indent-line
333 'indent-to-left-margin))
334
335 ;; Font Lock
336 (make-local-variable 'font-lock-defaults)
337 (setq font-lock-defaults (cons font-keywords '(nil nil ((?- . "w 1234")))))
338
339 ;; Imenu
340 (make-local-variable 'imenu-create-index-function)
341 (setq imenu-create-index-function imenu-index)
342
343 ;; Tempo
344 (tempo-use-tag-list tempo-tags)
345 (make-local-variable 'tempo-match-finder)
346 (setq tempo-match-finder "\\b\\(.+\\)\\=")
347 (make-local-variable 'tempo-interactive)
348 (setq tempo-interactive t)
349
350 ;; Miscellaneous customization
351 (make-local-variable 'require-final-newline)
352 (setq require-final-newline t))
353
354
355;; SNMPv1 MIB Editing Mode.
356;;
357;;;###autoload
358(defun snmp-mode ()
359 "Major mode for editing SNMP MIBs.
360Expression and list commands understand all C brackets.
361Tab indents for C code.
362Comments start with -- and end with newline or another --.
363Delete converts tabs to spaces as it moves back.
364\\{snmp-mode-map}
365Turning on snmp-mode runs the hooks in `snmp-common-mode-hook', then
366`snmp-mode-hook'."
367 (interactive)
368
369 (snmp-common-mode "SNMP" 'snmp-mode
370 snmp-mode-abbrev-table
371 '(snmp-font-lock-keywords
372 snmp-font-lock-keywords-1
373 snmp-font-lock-keywords-2
374 snmp-font-lock-keywords-3)
375 'snmp-mode-imenu-create-index
376 'snmp-tempo-tags)
377
378 ;; Completion lists
379 (make-local-variable 'snmp-mode-syntax-list)
380 (setq snmp-mode-syntax-list (append snmp-rfc1155-types
381 snmp-rfc1213-types
382 snmp-mode-syntax-list))
383 (make-local-variable 'snmp-mode-access-list)
384 (setq snmp-mode-access-list snmp-rfc1155-access)
385 (make-local-variable 'snmp-mode-status-list)
386 (setq snmp-mode-status-list snmp-rfc1212-status)
387
388 ;; Run hooks
389 (run-hooks 'snmp-common-mode-hook)
390 (run-hooks 'snmp-mode-hook))
391
392
393;;;###autoload
394(defun snmpv2-mode ()
395 "Major mode for editing SNMPv2 MIBs.
396Expression and list commands understand all C brackets.
397Tab indents for C code.
398Comments start with -- and end with newline or another --.
399Delete converts tabs to spaces as it moves back.
400\\{snmp-mode-map}
401Turning on snmp-mode runs the hooks in `snmp-common-mode-hook',
402then `snmpv2-mode-hook'."
403 (interactive)
404
405 (snmp-common-mode "SNMPv2" 'snmpv2-mode
406 snmpv2-mode-abbrev-table
407 '(snmp-font-lock-keywords
408 snmp-font-lock-keywords-1
409 snmp-font-lock-keywords-2
410 snmp-font-lock-keywords-3)
411 'snmp-mode-imenu-create-index
412 'snmpv2-tempo-tags)
413
414 ;; Completion lists
415 (make-local-variable 'snmp-mode-syntax-list)
416 (setq snmp-mode-syntax-list (append snmp-rfc1902-types
417 snmp-rfc1903-types
418 snmp-mode-syntax-list))
419 (make-local-variable 'snmp-mode-access-list)
420 (setq snmp-mode-access-list snmp-rfc1902-access)
421 (make-local-variable 'snmp-mode-status-list)
422 (setq snmp-mode-status-list snmp-rfc1902-status)
423
424 ;; Run hooks
425 (run-hooks 'snmp-common-mode-hook)
426 (run-hooks 'snmpv2-mode-hook))
427
428
429;;;----------------------------------------------------------------------------
430;;
431;; Indentation Setup
432;;
433;;;----------------------------------------------------------------------------
434
435(defvar snmp-macro-open
436 "[a-zA-Z][-a-zA-Z0-9]*[ \t]*\\(OBJECT\\|TRAP\\)-\\(TYPE\\|GROUP\\)\
437\\|DESCRIPTION\\|IMPORTS\\|MODULE\\(-IDENTITY\\|-COMPLIANCE\\)\
438\\|.*::=[ \t]*\\(BEGIN\\|TEXTUAL-CONVENTION\\)[ \t]*$")
439
440(defvar snmp-macro-close
441 "::=[ \t]*{\\|\\(END\\|.*[;\"]\\)[ \t]*$")
442
443(defun snmp-calculate-indent ()
444 "Calculate the current line indentation in SNMP MIB code.
445
446We use a very simple scheme: if the previous non-empty line was a \"macro
447open\" string, add `snmp-indent-level' to it. If it was a \"macro close\"
448string, subtract `snmp-indent-level'. Otherwise, use the same indentation
449as the previous non-empty line. Note comments are considered empty
450lines for the purposes of this function."
451 (let ((empty (concat "\\([ \t]*\\)\\(" comment-start-skip "\\|$\\)"))
452 (case-fold-search nil)) ; keywords must be in uppercase
453 (save-excursion
454 (while (and (>= (forward-line -1) 0)
455 (looking-at empty)))
456 (skip-chars-forward " \t")
457 (+ (current-column)
458 ;; Are we looking at a macro open string? If so, add more.
459 (cond ((looking-at snmp-macro-open)
460 snmp-indent-level)
461 ;; macro close string? If so, remove some.
462 ((looking-at snmp-macro-close)
463 (- snmp-indent-level))
464 ;; Neither; just stay here.
465 (t 0))))))
466
467(defun snmp-indent-line ()
468 "Indent current line as SNMP MIB code."
469 (let ((indent (snmp-calculate-indent))
470 (pos (- (point-max) (point)))
471 shift-amt beg end)
472 (beginning-of-line)
473 (setq beg (point))
474 (skip-chars-forward " \t")
475 (setq shift-amt (- indent (current-column)))
476 (if (zerop shift-amt)
477 nil
478 (delete-region beg (point))
479 (indent-to indent))
480 ;; If initial point was within line's indentation,
481 ;; position after the indentation. Else stay at same point in text.
482 (if (> (- (point-max) pos) (point))
483 (goto-char (- (point-max) pos)))))
484
485(defun snmp-indent-command ()
486 "Indent current line as SNMP MIB code, or sometimes insert a TAB.
487If `snmp-tab-always-indent' is t, always reindent the current line when
488this command is run.
489If `snmp-tab-always-indent' is nil, reindent the current line if point is
490in the initial indentation. Otherwise, insert a TAB."
491 (interactive)
492 (if (and (not snmp-tab-always-indent)
493 (save-excursion
494 (skip-chars-backward " \t")
495 (not (bolp))))
496 (insert-tab)
497 (snmp-indent-line)))
498
499
500;;;----------------------------------------------------------------------------
501;;
502;; Imenu Setup
503;;
504;;;----------------------------------------------------------------------------
505
506(defvar snmp-clause-regexp
507 "^[ \t]*\\([a-zA-Z][-a-zA-Z0-9]*\\)[ \t\n]*\
508\\(TRAP-TYPE\\|::=\\|OBJECT\\(-TYPE[ \t\n]+SYNTAX\\|[ \t\n]+IDENTIFIER[ \t\n]*::=\\)\\)")
509
510(defun snmp-mode-imenu-create-index ()
511 (let ((index-alist '())
512 (index-oid-alist '())
513 (index-tc-alist '())
514 (index-table-alist '())
515 (index-trap-alist '())
516 (case-fold-search nil) ; keywords must be uppercase
517 prev-pos token marker end)
518 (goto-char (point-min))
519 (imenu-progress-message prev-pos 0)
520 ;; Search for a useful MIB item (that's not in a comment)
521 (save-match-data
522 (while (re-search-forward snmp-clause-regexp nil t)
523 (imenu-progress-message prev-pos)
524 (setq
525 end (match-end 0)
526 token (cons (buffer-substring (match-beginning 1) (match-end 1))
527 (set-marker (make-marker) (match-beginning 1))))
528 (goto-char (match-beginning 2))
529 (cond ((looking-at "OBJECT-TYPE[ \t\n]+SYNTAX")
530 (push token index-alist))
531 ((looking-at "OBJECT[ \t\n]+IDENTIFIER[ \t\n]*::=")
532 (push token index-oid-alist))
533 ((looking-at "::=[ \t\n]*SEQUENCE[ \t\n]*{")
534 (push token index-table-alist))
535 ((looking-at "TRAP-TYPE")
536 (push token index-trap-alist))
537 ((looking-at "::=")
538 (push token index-tc-alist)))
539 (goto-char end)))
540 ;; Create the menu
541 (imenu-progress-message prev-pos 100)
542 (setq index-alist (nreverse index-alist))
543 (and index-tc-alist
544 (push (cons "Textual Conventions" (nreverse index-tc-alist))
545 index-alist))
546 (and index-trap-alist
547 (push (cons "Traps" (nreverse index-trap-alist))
548 index-alist))
549 (and index-table-alist
550 (push (cons "Tables" (nreverse index-table-alist))
551 index-alist))
552 (and index-oid-alist
553 (push (cons "Object IDs" (nreverse index-oid-alist))
554 index-alist))
555 index-alist))
556
557
558;;;----------------------------------------------------------------------------
559;;
560;; Tempo Setup
561;;
562;;;----------------------------------------------------------------------------
563
564(require 'tempo)
565
566;; Perform a completing-read with info given
567;;
568(defun snmp-completing-read (prompt table &optional pred require init hist)
569 "Read from the minibuffer, with completion.
570Like `completing-read', but the variable `snmp-completion-ignore-case'
571controls whether case is significant."
572 (let ((completion-ignore-case snmp-completion-ignore-case))
573 (completing-read prompt table pred require init hist)))
574
575;; OBJECT-TYPE macro template
576;;
577(tempo-define-template "snmp-object-type"
578 '(> (P "Object Label: ") " OBJECT-TYPE" n>
579 "SYNTAX "
580 (if tempo-interactive
581 (snmp-completing-read "Syntax: " snmp-mode-syntax-list nil nil)
582 p) n>
583 "ACCESS "
584 (if tempo-interactive
585 (snmp-completing-read "Access: " snmp-mode-access-list nil t)
586 p) n>
587 "STATUS "
588 (if tempo-interactive
589 (snmp-completing-read "Status: " snmp-mode-status-list nil t)
590 p) n>
591 "DESCRIPTION" n> "\"" p "\"" n>
592 (P "Default Value: " defval t)
593 (if (string= "" (tempo-lookup-named 'defval))
594 nil
595 '(l "DEFVAL { " (s defval) " }" n>))
596 "::= { " (p "OID: ") " }" n)
597 "objectType"
598 "Insert an OBJECT-TYPE macro."
599 'snmp-tempo-tags)
600
601;; Table macro template
602;;
603(tempo-define-template "snmp-table-type"
604 ;; First the table OBJECT-TYPE
605 '(> (P "Table Name: " table)
606 (P "Entry Name: " entry t)
607 (let* ((entry (tempo-lookup-named 'entry))
608 (seq (copy-sequence entry)))
609 (aset entry 0 (downcase (aref entry 0)))
610 (aset seq 0 (upcase (aref seq 0)))
611 (tempo-save-named 'obj-entry entry)
612 (tempo-save-named 'seq-entry seq)
613 nil)
614 " OBJECT-TYPE" n>
615 "SYNTAX SEQUENCE OF "
616 (s seq-entry) n>
617 "ACCESS not-accessible" n>
618 "STATUS mandatory" n>
619 "DESCRIPTION" n> "\"" p "\"" n>
620 "::= { " (p "OID: ") " }" n n>
621 ;; Next the row OBJECT-TYPE
622 (s obj-entry) " OBJECT-TYPE" n>
623 "SYNTAX " (s seq-entry) n>
624 "ACCESS not-accessible" n>
625 "STATUS mandatory" n>
626 "DESCRIPTION" n> "\"" p "\"" n>
627 "INDEX { " (p "Index List: ") " }" n>
628 "::= {" (s table) " 1 }" n n>
629 ;; Finally the SEQUENCE type
630 (s seq-entry) " ::= SEQUENCE {" n> p n> "}" n)
631 "tableType"
632 "Insert an SNMP table."
633 'snmp-tempo-tags)
634
635
636;; v2 SMI OBJECT-TYPE macro template
637;;
638(tempo-define-template "snmpv2-object-type"
639 '(> (P "Object Label: ") " OBJECT-TYPE" n>
640 "SYNTAX "
641 (if tempo-interactive
642 (snmp-completing-read "Syntax: " snmp-mode-syntax-list nil nil)
643 p) n>
644 "MAX-ACCESS "
645 (if tempo-interactive
646 (snmp-completing-read "Max Access: " snmp-mode-access-list nil t)
647 p) n>
648 "STATUS "
649 (if tempo-interactive
650 (snmp-completing-read "Status: " snmp-mode-status-list nil t)
651 p) n>
652 "DESCRIPTION" n> "\"" p "\"" n>
653 (P "Default Value: " defval t)
654 (if (string= "" (tempo-lookup-named 'defval))
655 nil
656 '(l "DEFVAL { " (s defval) " }" n>))
657 "::= { " (p "OID: ") " }" n)
658 "objectType"
659 "Insert an v2 SMI OBJECT-TYPE macro."
660 'snmpv2-tempo-tags)
661
662;; v2 SMI Table macro template
663;;
664(tempo-define-template "snmpv2-table-type"
665 ;; First the table OBJECT-TYPE
666 '(> (P "Table Name: " table)
667 (P "Entry Name: " entry t)
668 (let* ((entry (tempo-lookup-named 'entry))
669 (seq (copy-sequence entry)))
670 (aset entry 0 (downcase (aref entry 0)))
671 (aset seq 0 (upcase (aref seq 0)))
672 (tempo-save-named 'obj-entry entry)
673 (tempo-save-named 'seq-entry seq)
674 nil)
675 " OBJECT-TYPE" n>
676 "SYNTAX SEQUENCE OF "
677 (s seq-entry) n>
678 "MAX-ACCESS not-accessible" n>
679 "STATUS current" n>
680 "DESCRIPTION" n> "\"" p "\"" n>
681 "::= { " (p "OID: ") " }" n n>
682 ;; Next the row OBJECT-TYPE
683 (s obj-entry) " OBJECT-TYPE" n>
684 "SYNTAX " (s seq-entry) n>
685 "MAX-ACCESS not-accessible" n>
686 "STATUS current" n>
687 "DESCRIPTION" n> "\"" p "\"" n>
688 "INDEX { " (p "Index List: ") " }" n>
689 "::= { " (s table) " 1 }" n n>
690 ;; Finally the SEQUENCE type
691 (s seq-entry) " ::= SEQUENCE {" n> p n> "}" n)
692 "tableType"
693 "Insert an v2 SMI SNMP table."
694 'snmpv2-tempo-tags)
695
696;; v2 SMI TEXTUAL-CONVENTION macro template
697;;
698(tempo-define-template "snmpv2-textual-convention"
699 '(> (P "Texual Convention Type: ") " ::= TEXTUAL-CONVENTION" n>
700 "STATUS "
701 (if tempo-interactive
702 (snmp-completing-read "Status: " snmp-mode-status-list nil t)
703 p) n>
704 "DESCRIPTION" n> "\"" p "\"" n>
705 "SYNTAX "
706 (if tempo-interactive
707 (snmp-completing-read "Syntax: " snmp-mode-syntax-list nil nil)
708 p) n> )
709 "textualConvention"
710 "Insert an v2 SMI TEXTUAL-CONVENTION macro."
711 'snmpv2-tempo-tags)
712
713
714(provide 'snmp-mode)
715
716;; snmp-mode.el ends here
diff --git a/lisp/telnet.el b/lisp/telnet.el
deleted file mode 100644
index 557d00534d4..00000000000
--- a/lisp/telnet.el
+++ /dev/null
@@ -1,261 +0,0 @@
1;;; telnet.el --- run a telnet session from within an Emacs buffer
2
3;; Copyright (C) 1985, 1988, 1992, 1994 Free Software Foundation, Inc.
4
5;; Author: William F. Schelter
6;; Maintainer: FSF
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26
27;; This mode is intended to be used for telnet or rsh to a remote host;
28;; `telnet' and `rsh' are the two entry points. Multiple telnet or rsh
29;; sessions are supported.
30;;
31;; Normally, input is sent to the remote telnet/rsh line-by-line, as you
32;; type RET or LFD. C-c C-c sends a C-c to the remote immediately;
33;; C-c C-z sends C-z immediately. C-c C-q followed by any character
34;; sends that character immediately.
35;;
36;; All RET characters are filtered out of the output coming back from the
37;; remote system. The mode tries to do other useful translations based
38;; on what it sees coming back from the other system before the password
39;; query. It knows about UNIX, ITS, TOPS-20 and Explorer systems.
40;;
41;; You can use the global telnet-host-properties to associate a telnet
42;; program and login name with each host you regularly telnet to.
43
44;;; Code:
45
46;; to do fix software types for lispm:
47;; to eval current expression. Also to try to send escape keys correctly.
48;; essentially we'll want the rubout-handler off.
49
50;; filter is simplistic but should be okay for typical shell usage.
51;; needs hacking if it is going to deal with asynchronous output in a sane
52;; manner
53
54(require 'comint)
55
56(defvar telnet-host-properties ()
57 "Specify which telnet program to use for particular hosts.
58Each element has the form (HOSTNAME PROGRAM [LOGIN-NAME])
59HOSTNAME says which machine the element applies to.
60PROGRAM says which program to run, to talk to that machine.
61LOGIN-NAME, which is optional, says what to log in as on that machine.")
62
63(defvar telnet-new-line "\r")
64(defvar telnet-mode-map nil)
65(defvar telnet-prompt-pattern "^[^#$%>\n]*[#$%>] *")
66(defvar telnet-replace-c-g nil)
67(make-variable-buffer-local
68 (defvar telnet-remote-echoes t
69 "True if the telnet process will echo input."))
70(make-variable-buffer-local
71 (defvar telnet-interrupt-string "\C-c" "String sent by C-c."))
72
73(defvar telnet-count 0
74 "Number of output strings from telnet process while looking for password.")
75(make-variable-buffer-local 'telnet-count)
76
77(defvar telnet-program "telnet"
78 "Program to run to open a telnet connection.")
79
80(defvar telnet-initial-count -50
81 "Initial value of `telnet-count'. Should be set to the negative of the
82number of terminal writes telnet will make setting up the host connection.")
83
84(defvar telnet-maximum-count 4
85 "Maximum value `telnet-count' can have.
86After this many passes, we stop looking for initial setup data.
87Should be set to the number of terminal writes telnet will make
88rejecting one login and prompting again for a username and password.")
89
90(defun telnet-interrupt-subjob ()
91 (interactive)
92 "Interrupt the program running through telnet on the remote host."
93 (send-string nil telnet-interrupt-string))
94
95(defun telnet-c-z ()
96 (interactive)
97 (send-string nil "\C-z"))
98
99(defun send-process-next-char ()
100 (interactive)
101 (send-string nil
102 (char-to-string
103 (let ((inhibit-quit t))
104 (prog1 (read-char)
105 (setq quit-flag nil))))))
106
107; initialization on first load.
108(if telnet-mode-map
109 nil
110 (setq telnet-mode-map (nconc (make-sparse-keymap) comint-mode-map))
111 (define-key telnet-mode-map "\C-m" 'telnet-send-input)
112; (define-key telnet-mode-map "\C-j" 'telnet-send-input)
113 (define-key telnet-mode-map "\C-c\C-q" 'send-process-next-char)
114 (define-key telnet-mode-map "\C-c\C-c" 'telnet-interrupt-subjob)
115 (define-key telnet-mode-map "\C-c\C-z" 'telnet-c-z))
116
117;;maybe should have a flag for when have found type
118(defun telnet-check-software-type-initialize (string)
119 "Tries to put correct initializations in. Needs work."
120 (let ((case-fold-search t))
121 (cond ((string-match "unix" string)
122 (setq telnet-prompt-pattern comint-prompt-regexp)
123 (setq telnet-new-line "\n"))
124 ((string-match "tops-20" string) ;;maybe add telnet-replace-c-g
125 (setq telnet-prompt-pattern "[@>]*"))
126 ((string-match "its" string)
127 (setq telnet-prompt-pattern "^[^*>\n]*[*>] *"))
128 ((string-match "explorer" string) ;;explorer telnet needs work
129 (setq telnet-replace-c-g ?\n))))
130 (setq comint-prompt-regexp telnet-prompt-pattern))
131
132(defun telnet-initial-filter (proc string)
133 ;For reading up to and including password; also will get machine type.
134 (save-current-buffer
135 (set-buffer (process-buffer proc))
136 (let ((case-fold-search t))
137 (cond ((string-match "No such host" string)
138 (kill-buffer (process-buffer proc))
139 (error "No such host"))
140 ((string-match "passw" string)
141 (telnet-filter proc string)
142 (setq telnet-count 0)
143 (send-string proc (concat (comint-read-noecho "Password: " t)
144 telnet-new-line))
145 (clear-this-command-keys))
146 (t (telnet-check-software-type-initialize string)
147 (telnet-filter proc string)
148 (cond ((> telnet-count telnet-maximum-count)
149 (set-process-filter proc 'telnet-filter))
150 (t (setq telnet-count (1+ telnet-count)))))))))
151
152;; Identical to comint-simple-send, except that it sends telnet-new-line
153;; instead of "\n".
154(defun telnet-simple-send (proc string)
155 (comint-send-string proc string)
156 (comint-send-string proc telnet-new-line))
157
158(defun telnet-filter (proc string)
159 (save-excursion
160 (set-buffer (process-buffer proc))
161 (let* ((last-insertion (marker-position (process-mark proc)))
162 (delta (- (point) last-insertion))
163 (ie (and comint-last-input-end
164 (marker-position comint-last-input-end)))
165 (w (get-buffer-window (current-buffer)))
166 (ws (and w (window-start w))))
167 (goto-char last-insertion)
168 (insert-before-markers string)
169 (set-marker comint-last-output-start last-insertion)
170 (set-marker (process-mark proc) (point))
171 (if ws (set-window-start w ws t))
172 (if ie (set-marker comint-last-input-end ie))
173 (while (progn (skip-chars-backward "^\C-m" last-insertion)
174 (> (point) last-insertion))
175 (delete-region (1- (point)) (point)))
176 (goto-char (process-mark proc))
177 (and telnet-replace-c-g
178 (subst-char-in-region last-insertion (point) ?\C-g
179 telnet-replace-c-g t))
180 ;; If point is after the insertion place, move it
181 ;; along with the text.
182 (if (> delta 0)
183 (goto-char (+ (process-mark proc) delta))))))
184
185(defun telnet-send-input ()
186 (interactive)
187; (comint-send-input telnet-new-line telnet-remote-echoes)
188 (comint-send-input)
189 (if telnet-remote-echoes
190 (delete-region comint-last-input-start
191 comint-last-input-end)))
192
193;;;###autoload (add-hook 'same-window-regexps "\\*telnet-.*\\*\\(\\|<[0-9]+>\\)")
194
195;;;###autoload
196(defun telnet (host)
197 "Open a network login connection to host named HOST (a string).
198Communication with HOST is recorded in a buffer `*PROGRAM-HOST*'
199where PROGRAM is the telnet program being used. This program
200is controlled by the contents of the global variable `telnet-host-properties',
201falling back on the value of the global variable `telnet-program'.
202Normally input is edited in Emacs and sent a line at a time."
203 (interactive "sOpen connection to host: ")
204 (let* ((comint-delimiter-argument-list '(?\ ?\t))
205 (properties (cdr (assoc host telnet-host-properties)))
206 (telnet-program (if properties (car properties) telnet-program))
207 (name (concat telnet-program "-" (comint-arguments host 0 nil) ))
208 (buffer (get-buffer (concat "*" name "*")))
209 (telnet-options (if (cdr properties) (cons "-l" (cdr properties))))
210 process)
211 (if (and buffer (get-buffer-process buffer))
212 (pop-to-buffer (concat "*" name "*"))
213 (pop-to-buffer
214 (apply 'make-comint name telnet-program nil telnet-options))
215 (setq process (get-buffer-process (current-buffer)))
216 (set-process-filter process 'telnet-initial-filter)
217 ;; Don't send the `open' cmd till telnet is ready for it.
218 (accept-process-output process)
219 (erase-buffer)
220 (send-string process (concat "open " host "\n"))
221 (telnet-mode)
222 (setq comint-input-sender 'telnet-simple-send)
223 (setq telnet-count telnet-initial-count))))
224
225(put 'telnet-mode 'mode-class 'special)
226
227(defun telnet-mode ()
228 "This mode is for using telnet (or rsh) from a buffer to another host.
229It has most of the same commands as comint-mode.
230There is a variable ``telnet-interrupt-string'' which is the character
231sent to try to stop execution of a job on the remote host.
232Data is sent to the remote host when RET is typed.
233
234\\{telnet-mode-map}
235"
236 (interactive)
237 (comint-mode)
238 (setq major-mode 'telnet-mode
239 mode-name "Telnet"
240 comint-prompt-regexp telnet-prompt-pattern)
241 (use-local-map telnet-mode-map)
242 (run-hooks 'telnet-mode-hook))
243
244;;;###autoload (add-hook 'same-window-regexps "\\*rsh-[^-]*\\*\\(\\|<[0-9]*>\\)")
245
246;;;###autoload
247(defun rsh (host)
248 "Open a network login connection to host named HOST (a string).
249Communication with HOST is recorded in a buffer `*rsh-HOST*'.
250Normally input is edited in Emacs and sent a line at a time."
251 (interactive "sOpen rsh connection to host: ")
252 (require 'shell)
253 (let ((name (concat "rsh-" host )))
254 (pop-to-buffer (make-comint name remote-shell-program nil host))
255 (set-process-filter (get-process name) 'telnet-initial-filter)
256 (telnet-mode)
257 (setq telnet-count -16)))
258
259(provide 'telnet)
260
261;;; telnet.el ends here
diff --git a/lisp/webjump.el b/lisp/webjump.el
deleted file mode 100644
index c55a12c45e8..00000000000
--- a/lisp/webjump.el
+++ /dev/null
@@ -1,403 +0,0 @@
1;;; webjump.el --- programmable Web hotlist
2
3;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
4
5;; Author: Neil W. Van Dyke <nwv@acm.org>
6;; Created: 09-Aug-1996
7;; Keywords: comm www
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option)
14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING. If not, write to the
23;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24;; Boston, MA 02111-1307, USA.
25
26;;; Commentary:
27
28;; WebJump provides a sort of ``programmable hotlist'' of Web sites that can
29;; quickly be invoked in your Web browser. Each Web site in the hotlist has a
30;; name, and you select the desired site name via a completing string prompt in
31;; the minibuffer. The URL for each Web site is defined as a static string or
32;; a built-in or custom function, allowing interactive prompting for
33;; site-specific queries and options.
34
35;; Note that WebJump was originally intended to complement your conventional
36;; browser-based hotlist, not replace it. (Though there's no reason you
37;; couldn't use WebJump for your entire hotlist if you were so inclined.)
38
39;; The `webjump-sites' variable, which defines the hotlist, defaults to some
40;; example sites. You'll probably want to override it with your own favorite
41;; sites. The documentation for the variable describes the syntax.
42
43;; You may wish to add something like the following to your `.emacs' file:
44;;
45;; (require 'webjump)
46;; (global-set-key "\C-cj" 'webjump)
47;; (setq webjump-sites
48;; (append '(
49;; ("My Home Page" . "www.someisp.net/users/joebobjr/")
50;; ("Pop's Site" . "www.joebob-and-son.com/")
51;; )
52;; webjump-sample-sites))
53;;
54;; The above loads this package, binds `C-c j' to invoke WebJump, and adds your
55;; personal favorite sites to the hotlist.
56
57;; The `webjump-sample-sites' variable mostly contains some site entries that
58;; are expected to be generally relevant to many users, but excluding
59;; those that the GNU project would not want to recommend.
60
61;; The `browse-url' package is used to submit URLs to the browser, so any
62;; browser-specific configuration should be done there.
63
64;;; Code:
65
66;;-------------------------------------------------------- Package Dependencies
67
68(require 'browse-url)
69
70;;------------------------------------------------------------------- Constants
71
72(defvar webjump-sample-sites
73 '(
74
75 ;; FSF, not including Emacs-specific.
76 ("GNU Project FTP Archive" .
77 [mirrors "ftp://ftp.gnu.org/pub/gnu/"
78 ;; ASIA:
79 "ftp://ftp.cs.titech.ac.jp"
80 "ftp://tron.um.u-tokyo.ac.jp/pub/GNU/prep"
81 "ftp://cair-archive.kaist.ac.kr/pub/gnu"
82 "ftp://ftp.nectec.or.th/pub/mirrors/gnu"
83 ;; AUSTRALIA:
84 "ftp://archie.au/gnu"
85 "ftp://archie.oz/gnu"
86 "ftp://archie.oz.au/gnu"
87 ;; AFRICA:
88 "ftp://ftp.sun.ac.za/pub/gnu"
89 ;; MIDDLE-EAST:
90 "ftp://ftp.technion.ac.il/pub/unsupported/gnu"
91 ;; EUROPE:
92 "ftp://irisa.irisa.fr/pub/gnu"
93 "ftp://ftp.univ-lyon1.fr/pub/gnu"
94 "ftp://ftp.mcc.ac.uk"
95 "ftp://unix.hensa.ac.uk/mirrors/uunet/systems/gnu"
96 "ftp://src.doc.ic.ac.uk/gnu"
97 "ftp://ftp.ieunet.ie/pub/gnu"
98 "ftp://ftp.eunet.ch"
99 "ftp://nic.switch.ch/mirror/gnu"
100 "ftp://ftp.informatik.rwth-aachen.de/pub/gnu"
101 "ftp://ftp.informatik.tu-muenchen.de"
102 "ftp://ftp.win.tue.nl/pub/gnu"
103 "ftp://ftp.nl.net"
104 "ftp://ftp.etsimo.uniovi.es/pub/gnu"
105 "ftp://ftp.funet.fi/pub/gnu"
106 "ftp://ftp.denet.dk"
107 "ftp://ftp.stacken.kth.se"
108 "ftp://isy.liu.se"
109 "ftp://ftp.luth.se/pub/unix/gnu"
110 "ftp://ftp.sunet.se/pub/gnu"
111 "ftp://archive.eu.net"
112 ;; SOUTH AMERICA:
113 "ftp://ftp.inf.utfsm.cl/pub/gnu"
114 "ftp://ftp.unicamp.br/pub/gnu"
115 ;; WESTERN CANADA:
116 "ftp://ftp.cs.ubc.ca/mirror2/gnu"
117 ;; USA:
118 "ftp://wuarchive.wustl.edu/systems/gnu"
119 "ftp://labrea.stanford.edu"
120 "ftp://ftp.digex.net/pub/gnu"
121 "ftp://ftp.kpc.com/pub/mirror/gnu"
122 "ftp://f.ms.uky.edu/pub3/gnu"
123 "ftp://jaguar.utah.edu/gnustuff"
124 "ftp://ftp.hawaii.edu/mirrors/gnu"
125 "ftp://uiarchive.cso.uiuc.edu/pub/gnu"
126 "ftp://ftp.cs.columbia.edu/archives/gnu/prep"
127 "ftp://gatekeeper.dec.com/pub/GNU"
128 "ftp://ftp.uu.net/systems/gnu"])
129 ("GNU Project Home Page" . "www.gnu.org")
130
131 ;; Emacs.
132 ("Emacs Lisp Archive" .
133 "ftp://ftp.emacs.org/pub/")
134
135 ;; Internet search engines.
136 ("AltaVista" .
137 [simple-query
138 "www.altavista.digital.com"
139 "www.altavista.digital.com/cgi-bin/query?pg=aq&what=web&fmt=.&q="
140 "&r=&d0=&d1="])
141 ("Archie" .
142 [simple-query "hoohoo.ncsa.uiuc.edu/cgi-bin/AA.pl"
143 "hoohoo.ncsa.uiuc.edu/cgi-bin/AA.pl?query=" ""])
144 ("Lycos" .
145 [simple-query "www.lycos.com"
146 "www.lycos.com/cgi-bin/pursuit?cat=lycos&query=" ""])
147 ("Yahoo" .
148 [simple-query "www.yahoo.com" "search.yahoo.com/bin/search?p=" ""])
149
150 ;; Misc. general interest.
151 ("Interactive Weather Information Network" . webjump-to-iwin)
152 ("Usenet FAQs" .
153 [simple-query "www.cis.ohio-state.edu/hypertext/faq/usenet/FAQ-List.html"
154 "www.cis.ohio-state.edu/htbin/search-usenet-faqs/form?find="
155 ""])
156 ("RTFM Usenet FAQs by Group" .
157 "ftp://rtfm.mit.edu/pub/usenet-by-group/")
158 ("RTFM Usenet FAQs by Hierachy" .
159 "ftp://rtfm.mit.edu/pub/usenet-by-hierarchy/")
160 ("X Consortium Archive" . "ftp.x.org")
161 ("Yahoo: Reference" . "www.yahoo.com/Reference/")
162
163 ;; Computer social issues, privacy, professionalism.
164 ("Association for Computing Machinery" . "www.acm.org")
165 ("Computer Professionals for Social Responsibility" . "www.cpsr.org/dox/")
166 ("Electronic Frontier Foundation" . "www.eff.org")
167 ("IEEE Computer Society" . "www.computer.org")
168 ("Risks Digest" . webjump-to-risks)
169
170 ;; Fun.
171 ("Bastard Operator from Hell" . "www.replay.com/bofh/")
172
173 )
174 "Sample hotlist for WebJump. See the documentation for the `webjump'
175function and the `webjump-sites' variable.")
176
177(defvar webjump-state-to-postal-alist
178 '(("Alabama" . "al") ("Alaska" . "ak") ("Arizona" . "az") ("Arkansas" . "ar")
179 ("California" . "ca") ("Colorado" . "co") ("Connecticut" . "ct")
180 ("Delaware" . "de") ("Florida" . "fl") ("Georgia" . "ga") ("Hawaii" . "hi")
181 ("Idaho" . "id") ("Illinois" . "il") ("Indiana" . "in") ("Iowa" . "ia")
182 ("Kansas" . "ks") ("Kentucky" . "ky") ("Louisiana" . "la") ("Maine" . "me")
183 ("Maryland" . "md") ("Massachusetts" . "ma") ("Michigan" . "mi")
184 ("Minnesota" . "mn") ("Mississippi" . "ms") ("Missouri" . "mo")
185 ("Montana" . "mt") ("Nebraska" . "ne") ("Nevada" . "nv")
186 ("New Hampshire" . "nh") ("New Jersey" . "nj") ("New Mexico" . "nm")
187 ("New York" . "ny") ("North Carolina" . "nc") ("North Dakota" . "nd")
188 ("Ohio" . "oh") ("Oklahoma" . "ok") ("Oregon" . "or")
189 ("Pennsylvania" . "pa") ("Rhode Island" . "ri") ("South Carolina" . "sc")
190 ("South Dakota" . "sd") ("Tennessee" . "tn") ("Texas" . "tx")
191 ("Utah" . "ut") ("Vermont" . "vt") ("Virginia" . "va")
192 ("Washington" . "wa") ("West Virginia" . "wv") ("Wisconsin" . "wi")
193 ("Wyoming" . "wy")))
194
195;;------------------------------------------------------------ Option Variables
196
197(defvar webjump-sites
198 webjump-sample-sites
199 "*Hotlist for WebJump.
200
201The hotlist is represented as an association list, with the CAR of each cell
202being the name of the Web site, and the CDR being the definition for the URL of
203that site. The URL definition can be a string (the URL), a vector (specifying
204a special \"builtin\" which returns a URL), a symbol (name of a function which
205returns a URL), or a list (which when `eval'ed yields a URL).
206
207If the URL definition is a vector, then a \"builtin\" is used. A builtin has a
208Lisp-like syntax, with the name as the first element of the vector, and any
209arguments as the following elements. The three current builtins are `name',
210which returns the name of the site as the URL, `simple-query', which
211returns a URL that is a function of a query entered by the user, and `mirrors',
212which allows the user to select from among multiple mirror sites for the same
213content.
214
215The first argument to the `simple-query' builtin is a static URL to use if the
216user enters a blank query. The second and third arguments are the prefix and
217suffix, respectively, to add to the encoded query the user enters. This
218builtin covers Web sites that have single-string searches with the query
219embedded in the URL.
220
221The arguments to the `mirrors' builtin are URLs of mirror sites.
222
223If the symbol of a function is given, then the function will be called with the
224Web site name (the one you specified in the CAR of the alist cell) as a
225parameter. This might come in handy for various kludges.
226
227For convenience, if the `http://', `ftp://', or `file://' prefix is missing
228from a URL, WebJump will make a guess at what you wanted and prepend it before
229submitting the URL.")
230
231;;------------------------------------------------------- Sample Site Functions
232
233(defun webjump-to-iwin (name)
234 (let ((prefix "http://iwin.nws.noaa.gov/")
235 (state (webjump-read-choice name "state"
236 (append '(("Puerto Rico" . "pr"))
237 webjump-state-to-postal-alist))))
238 (if state
239 (concat prefix "iwin/" state "/"
240 (webjump-read-choice name "option"
241 '(("Hourly Report" . "hourly")
242 ("State Forecast" . "state")
243 ("Local Forecast" . "local")
244 ("Zone Forecast" . "zone")
245 ("Short-Term Forecast" . "shortterm")
246 ("Weather Summary" . "summary")
247 ("Public Information" . "public")
248 ("Climatic Data" . "climate")
249 ("Aviation Products" . "aviation")
250 ("Hydro Products" . "hydro")
251 ("Special Weather" . "special")
252 ("Watches and Warnings" . "warnings"))
253 "zone")
254 ".html")
255 prefix)))
256
257(defun webjump-to-risks (name)
258 (let (issue volume)
259 (if (and (setq volume (webjump-read-number (concat name " volume")))
260 (setq issue (webjump-read-number (concat name " issue"))))
261 (format "catless.ncl.ac.uk/Risks/%d.%02d.html" volume issue)
262 "catless.ncl.ac.uk/Risks/")))
263
264;;-------------------------------------------------------------- Core Functions
265
266;;;###autoload
267(defun webjump ()
268 "Jumps to a Web site from a programmable hotlist.
269
270See the documentation for the `webjump-sites' variable for how to customize the
271hotlist.
272
273Please submit bug reports and other feedback to the author, Neil W. Van Dyke
274<nwv@acm.org>."
275 (interactive)
276 (let* ((completion-ignore-case t)
277 (item (assoc-ignore-case
278 (completing-read "WebJump to site: " webjump-sites nil t)
279 webjump-sites))
280 (name (car item))
281 (expr (cdr item)))
282 (browse-url (webjump-url-fix
283 (cond ((not expr) "")
284 ((stringp expr) expr)
285 ((vectorp expr) (webjump-builtin expr name))
286 ((listp expr) (eval expr))
287 ((symbolp expr)
288 (if (fboundp expr)
289 (funcall expr name)
290 (error "WebJump URL function \"%s\" undefined."
291 expr)))
292 (t (error "WebJump URL expression for \"%s\" invalid."
293 name)))))))
294
295(defun webjump-builtin (expr name)
296 (if (< (length expr) 1)
297 (error "WebJump URL builtin for \"%s\" empty." name))
298 (let ((builtin (aref expr 0)))
299 (cond
300 ((eq builtin 'mirrors)
301 (if (= (length expr) 1)
302 (error
303 "WebJump URL builtin \"mirrors\" for \"%s\" needs at least 1 arg."))
304 (webjump-choose-mirror name (cdr (append expr nil))))
305 ((eq builtin 'name)
306 name)
307 ((eq builtin 'simple-query)
308 (webjump-builtin-check-args expr name 3)
309 (webjump-do-simple-query name (aref expr 1) (aref expr 2) (aref expr 3)))
310 (t (error "WebJump URL builtin \"%s\" for \"%s\" invalid."
311 builtin name)))))
312
313(defun webjump-builtin-check-args (expr name count)
314 (or (= (length expr) (1+ count))
315 (error "WebJump URL builtin \"%s\" for \"%s\" needs %d args."
316 (aref expr 0) name count)))
317
318(defun webjump-choose-mirror (name urls)
319 (webjump-read-url-choice (concat name " mirror")
320 urls
321 (webjump-mirror-default urls)))
322
323(defun webjump-do-simple-query (name noquery-url query-prefix query-suffix)
324 (let ((query (webjump-read-string (concat name " query"))))
325 (if query
326 (concat query-prefix (webjump-url-encode query) query-suffix)
327 noquery-url)))
328
329(defun webjump-mirror-default (urls)
330 ;; Note: This should be modified to apply some simple kludges/heuristics to
331 ;; pick a site which is likely "close". As a tie-breaker among candidates
332 ;; judged equally desirable, randomness might be used.
333 (car urls))
334
335(defun webjump-read-choice (name what choices &optional default)
336 (let* ((completion-ignore-case t)
337 (choice (completing-read (concat name " " what ": ") choices nil t)))
338 (if (webjump-null-or-blank-string-p choice)
339 default
340 (cdr (assoc choice choices)))))
341
342(defun webjump-read-number (prompt)
343 ;; Note: I should make this more robust someday.
344 (let ((input (webjump-read-string prompt)))
345 (if input (string-to-number input))))
346
347(defun webjump-read-string (prompt)
348 (let ((input (read-string (concat prompt ": "))))
349 (if (webjump-null-or-blank-string-p input) nil input)))
350
351(defun webjump-read-url-choice (what urls &optional default)
352 ;; Note: Convert this to use `webjump-read-choice' someday.
353 (let* ((completions (mapcar (function (lambda (n) (cons n n)))
354 urls))
355 (input (completing-read (concat what
356 ;;(if default " (RET for default)" "")
357 ": ")
358 completions
359 nil
360 t)))
361 (if (webjump-null-or-blank-string-p input)
362 default
363 (car (assoc input completions)))))
364
365(defun webjump-null-or-blank-string-p (str)
366 (or (null str) (string-match "^[ \t]*$" str)))
367
368(defun webjump-url-encode (str)
369 (mapconcat '(lambda (c)
370 (cond ((= c 32) "+")
371 ((or (and (>= c ?a) (<= c ?z))
372 (and (>= c ?A) (<= c ?Z))
373 (and (>= c ?0) (<= c ?9)))
374 (char-to-string c))
375 (t (upcase (format "%%%02x" c)))))
376 str
377 ""))
378
379(defun webjump-url-fix (url)
380 (if (webjump-null-or-blank-string-p url)
381 ""
382 (webjump-url-fix-trailing-slash
383 (cond
384 ((string-match "^[a-zA-Z]+:" url) url)
385 ((string-match "^/" url) (concat "file://" url))
386 ((string-match "^\\([^\\./]+\\)" url)
387 (concat (if (string= (downcase (match-string 1 url)) "ftp")
388 "ftp"
389 "http")
390 "://"
391 url))
392 (t url)))))
393
394(defun webjump-url-fix-trailing-slash (url)
395 (if (string-match "^[a-zA-Z]+://[^/]+$" url)
396 (concat url "/")
397 url))
398
399;;-----------------------------------------------------------------------------
400
401(provide 'webjump)
402
403;; webjump.el ends here
diff --git a/lisp/zone-mode.el b/lisp/zone-mode.el
deleted file mode 100644
index 2a534d8a6d0..00000000000
--- a/lisp/zone-mode.el
+++ /dev/null
@@ -1,117 +0,0 @@
1;;; zone-mode.el -- major mode for editing DNS zone files.
2
3;; Copyright (C) 1998 Free Software Foundation, Inc.
4
5;; Author: John Heidemann <johnh@isi.edu>
6;; Keywords: DNS, languages
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;;
26;;; See the comments in ``define-derived-mode zone-mode''
27;;; (the last function in this file)
28;;; for what this mode is and how to use it automatically.
29;;;
30
31;;;
32;;; Credits:
33;;; Zone-mode was written by John Heidemann <johnh@isi.edu>,
34;;; with bug fixes from Simon Leinen <simon@limmat.switch.ch>.
35;;;
36
37;;; Code:
38
39(defun zone-mode-update-serial ()
40 "Update the serial number in a zone."
41 (interactive)
42 (save-excursion
43 (goto-char (point-min))
44 (while (re-search-forward "\\b\\([0-9]+\\)\\([0-9][0-9]\\)\\([ \t]+;[ \t]+[Ss]erial\\)" (point-max) t)
45 (let* ((old-date (match-string 1))
46 (old-seq (match-string 2))
47 (old-seq-num (string-to-number (match-string 2)))
48 (old-flag (match-string 3))
49 (cur-date (format-time-string "%Y%m%d"))
50 (new-seq
51 (cond
52 ((not (string= old-date cur-date))
53 "00") ;; reset sequeence number
54 ((>= old-seq-num 99)
55 (error "Serial number's sequenece cannot increment beyond 99."))
56 (t
57 (format "%02d" (1+ old-seq-num)))))
58 (old-serial (concat old-date old-seq))
59 (new-serial (concat cur-date new-seq)))
60 (if (string-lessp new-serial old-serial)
61 (error (format "Serial numbers want to move backwards from %s to %s!" old-serial new-serial))
62 (replace-match (concat cur-date new-seq old-flag) t t))))))
63
64;;;###autoload
65(defun zone-mode-update-serial-hook ()
66 "Update the serial number in a zone if the file was modified"
67 (interactive)
68 (if (buffer-modified-p (current-buffer))
69 (zone-mode-update-serial))
70 nil ;; so we can run from write-file-hooks
71 )
72
73(defvar zone-mode-syntax-table nil
74 "Zone-mode's syntax table.")
75
76(defun zone-mode-load-time-setup ()
77 "init zone-mode stuff"
78 (setq zone-mode-syntax-table (make-syntax-table))
79 (modify-syntax-entry ?\; "<" zone-mode-syntax-table)
80 (modify-syntax-entry ?\n ">" zone-mode-syntax-table))
81
82;;;###autoload
83(define-derived-mode zone-mode fundamental-mode "zone"
84 "A mode for editing DNS zone files.
85
86Zone-mode does two things:
87
88 - automatically update the serial number for a zone
89 when saving the file
90
91 - fontification"
92
93 (make-local-hook 'write-file-hooks)
94 (add-hook 'write-file-hooks 'zone-mode-update-serial-hook)
95
96 (if (null zone-mode-syntax-table)
97 (zone-mode-load-time-setup)) ;; should have been run at load-time
98
99 ;; font-lock support:
100 (set-syntax-table zone-mode-syntax-table)
101 (make-local-variable 'comment-start)
102 (setq comment-start ";")
103 (make-local-variable 'comment-start-skip)
104 ;; Look within the line for a ; following an even number of backslashes
105 ;; after either a non-backslash or the line beginning.
106 (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*")
107 (make-local-variable 'comment-column)
108 (setq comment-column 40)
109 (make-local-variable 'font-lock-defaults)
110 (setq font-lock-defaults
111 '(nil nil nil nil beginning-of-line)))
112
113(zone-mode-load-time-setup)
114
115(provide 'zone-mode)
116
117;;; zone-mode.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-02-02 23:58:57 +0000