Mercurial > emacs
changeset 28210:b56f9152e329
Moved here from lisp.
| author | Gerd Moellmann <gerd@gnu.org> |
|---|---|
| date | Mon, 20 Mar 2000 13:12:14 +0000 |
| parents | 62de58b6dfb7 |
| children | 1ebbd6d6b1d4 |
| files | lisp/net/ange-ftp.el lisp/net/browse-url.el lisp/net/goto-addr.el lisp/net/net-utils.el lisp/net/quickurl.el lisp/net/rcompile.el lisp/net/rlogin.el lisp/net/snmp-mode.el lisp/net/telnet.el lisp/net/webjump.el lisp/net/zone-mode.el |
| diffstat | 11 files changed, 10421 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/ange-ftp.el Mon Mar 20 13:12:14 2000 +0000 @@ -0,0 +1,5695 @@ +;;; ange-ftp.el --- transparent FTP support for GNU Emacs + +;; Copyright (C) 1989,90,91,92,93,94,95,96,98 Free Software Foundation, Inc. + +;; Author: Andy Norman (ange@hplb.hpl.hp.com) +;; Maintainer: FSF +;; Keywords: comm + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package attempts to make accessing files and directories using FTP +;; from within GNU Emacs as simple and transparent as possible. A subset of +;; the common file-handling routines are extended to interact with FTP. + +;; Usage: +;; +;; Some of the common GNU Emacs file-handling operations have been made +;; FTP-smart. If one of these routines is given a filename that matches +;; '/user@host:name' then it will spawn an FTP process connecting to machine +;; 'host' as account 'user' and perform its operation on the file 'name'. +;; +;; For example: if find-file is given a filename of: +;; +;; /ange@anorman:/tmp/notes +;; +;; then ange-ftp spawns an FTP process, connect to the host 'anorman' as +;; user 'ange', get the file '/tmp/notes' and pop up a buffer containing the +;; contents of that file as if it were on the local filesystem. If ange-ftp +;; needs a password to connect then it reads one in the echo area. + +;; Extended filename syntax: +;; +;; The default extended filename syntax is '/user@host:name', where the +;; 'user@' part may be omitted. This syntax can be customised to a certain +;; extent by changing ange-ftp-name-format. There are limitations. +;; The `host' part has an optional suffix `#port' which may be used to +;; specify a non-default port number for the connexion. +;; +;; If the user part is omitted then ange-ftp generates a default user +;; instead whose value depends on the variable ange-ftp-default-user. + +;; Passwords: +;; +;; A password is required for each host/user pair. Ange-ftp reads passwords +;; as needed. You can also specify a password with ange-ftp-set-passwd, or +;; in a *valid* ~/.netrc file. + +;; Passwords for user "anonymous": +;; +;; Passwords for the user "anonymous" (or "ftp") are handled +;; specially. The variable `ange-ftp-generate-anonymous-password' +;; controls what happens: if the value of this variable is a string, +;; then this is used as the password; if non-nil (the default), then +;; the value of `user-mail-address' is used; if nil then the user +;; is prompted for a password as normal. + +;; "Dumb" UNIX hosts: +;; +;; The FTP servers on some UNIX machines have problems if the 'ls' command is +;; used. +;; +;; The routine ange-ftp-add-dumb-unix-host can be called to tell ange-ftp to +;; limit itself to the DIR command and not 'ls' for a given UNIX host. Note +;; that this change will take effect for the current GNU Emacs session only. +;; See below for a discussion of non-UNIX hosts. If a large number of +;; machines with similar hostnames have this problem then it is easier to set +;; the value of ange-ftp-dumb-unix-host-regexp in your .emacs file. ange-ftp +;; is unable to automatically recognize dumb unix hosts. + +;; File name completion: +;; +;; Full file-name completion is supported on UNIX, VMS, CMS, and MTS hosts. +;; To do filename completion, ange-ftp needs a listing from the remote host. +;; Therefore, for very slow connections, it might not save any time. + +;; FTP processes: +;; +;; When ange-ftp starts up an FTP process, it leaves it running for speed +;; purposes. Some FTP servers will close the connection after a period of +;; time, but ange-ftp should be able to quietly reconnect the next time that +;; the process is needed. +;; +;; Killing the "*ftp user@host*" buffer also kills the ftp process. +;; This should not cause ange-ftp any grief. + +;; Binary file transfers: +;; +;; By default ange-ftp transfers files in ASCII mode. If a file being +;; transferred matches the value of ange-ftp-binary-file-name-regexp then +;; binary mode is used for that transfer. + +;; Account passwords: +;; +;; Some FTP servers require an additional password which is sent by the +;; ACCOUNT command. ange-ftp partially supports this by allowing the user to +;; specify an account password by either calling ange-ftp-set-account, or by +;; specifying an account token in the .netrc file. If the account password +;; is set by either of these methods then ange-ftp will issue an ACCOUNT +;; command upon starting the FTP process. + +;; Preloading: +;; +;; ange-ftp can be preloaded, but must be put in the site-init.el file and +;; not the site-load.el file in order for the documentation strings for the +;; functions being overloaded to be available. + +;; Status reports: +;; +;; Most ange-ftp commands that talk to the FTP process output a status +;; message on what they are doing. In addition, ange-ftp can take advantage +;; of the FTP client's HASH command to display the status of transferring +;; files and listing directories. See the documentation for the variables +;; ange-ftp-{ascii,binary}-hash-mark-size, ange-ftp-send-hash and +;; ange-ftp-process-verbose for more details. + +;; Gateways: +;; +;; Sometimes it is necessary for the FTP process to be run on a different +;; machine than the machine running GNU Emacs. This can happen when the +;; local machine has restrictions on what hosts it can access. +;; +;; ange-ftp has support for running the ftp process on a different (gateway) +;; machine. The way it works is as follows: +;; +;; 1) Set the variable 'ange-ftp-gateway-host' to the name of a machine +;; that doesn't have the access restrictions. +;; +;; 2) Set the variable 'ange-ftp-local-host-regexp' to a regular expression +;; that matches hosts that can be contacted from running a local ftp +;; process, but fails to match hosts that can't be accessed locally. For +;; example: +;; +;; "\\.hp\\.com$\\|^[^.]*$" +;; +;; will match all hosts that are in the .hp.com domain, or don't have an +;; explicit domain in their name, but will fail to match hosts with +;; explicit domains or that are specified by their ip address. +;; +;; 3) Using NFS and symlinks, make sure that there is a shared directory with +;; the *same* name between the local machine and the gateway machine. +;; This directory is necessary for temporary files created by ange-ftp. +;; +;; 4) Set the variable 'ange-ftp-gateway-tmp-name-template' to the name of +;; this directory plus an identifying filename prefix. For example: +;; +;; "/nfs/hplose/ange/ange-ftp" +;; +;; where /nfs/hplose/ange is a directory that is shared between the +;; gateway machine and the local machine. +;; +;; The simplest way of getting a ftp process running on the gateway machine +;; is if you can spawn a remote shell using either 'rsh' or 'remsh'. If you +;; can't do this for some reason such as security then points 7 onwards will +;; discuss an alternative approach. +;; +;; 5) Set the variable ange-ftp-gateway-program to the name of the remote +;; shell process such as 'remsh' or 'rsh' if the default isn't correct. +;; +;; 6) Set the variable ange-ftp-gateway-program-interactive to nil if it +;; isn't already. This tells ange-ftp that you are using a remote shell +;; rather than logging in using telnet or rlogin. +;; +;; That should be all you need to allow ange-ftp to spawn a ftp process on +;; the gateway machine. If you have to use telnet or rlogin to get to the +;; gateway machine then follow the instructions below. +;; +;; 7) Set the variable ange-ftp-gateway-program to the name of the program +;; that lets you log onto the gateway machine. This may be something like +;; telnet or rlogin. +;; +;; 8) Set the variable ange-ftp-gateway-prompt-pattern to a regular +;; expression that matches the prompt you get when you login to the +;; gateway machine. Be very specific here; this regexp must not match +;; *anything* in your login banner except this prompt. +;; shell-prompt-pattern is far too general as it appears to match some +;; login banners from Sun machines. For example: +;; +;; "^$*$ *" +;; +;; 9) Set the variable ange-ftp-gateway-program-interactive to 't' to let +;; ange-ftp know that it has to "hand-hold" the login to the gateway +;; machine. +;; +;; 10) Set the variable ange-ftp-gateway-setup-term-command to a UNIX command +;; that will put the pty connected to the gateway machine into a +;; no-echoing mode, and will strip off carriage-returns from output from +;; the gateway machine. For example: +;; +;; "stty -onlcr -echo" +;; +;; will work on HP-UX machines, whereas: +;; +;; "stty -echo nl" +;; +;; appears to work for some Sun machines. +;; +;; That's all there is to it. + +;; Smart gateways: +;; +;; If you have a "smart" ftp program that allows you to issue commands like +;; "USER foo@bar" which do nice proxy things, then look at the variables +;; ange-ftp-smart-gateway and ange-ftp-smart-gateway-port. +;; +;; Otherwise, if there is an alternate ftp program that implements proxy in +;; a transparent way (i.e. w/o specifying the proxy host), that will +;; connect you directly to the desired destination host: +;; Set ange-ftp-gateway-ftp-program-name to that program's name. +;; Set ange-ftp-local-host-regexp to a value as stated earlier on. +;; Leave ange-ftp-gateway-host set to nil. +;; Set ange-ftp-smart-gateway to t. + +;; Tips for using ange-ftp: +;; +;; 1. For dired to work on a host which marks symlinks with a trailing @ in +;; an ls -alF listing, you need to (setq dired-ls-F-marks-symlinks t). +;; Most UNIX systems do not do this, but ULTRIX does. If you think that +;; there is a chance you might connect to an ULTRIX machine (such as +;; prep.ai.mit.edu), then set this variable accordingly. This will have +;; the side effect that dired will have problems with symlinks whose names +;; end in an @. If you get yourself into this situation then editing +;; dired's ls-switches to remove "F", will temporarily fix things. +;; +;; 2. If you know that you are connecting to a certain non-UNIX machine +;; frequently, and ange-ftp seems to be unable to guess its host-type, +;; then setting the appropriate host-type regexp +;; (ange-ftp-vms-host-regexp, ange-ftp-mts-host-regexp, or +;; ange-ftp-cms-host-regexp) accordingly should help. Also, please report +;; ange-ftp's inability to recognize the host-type as a bug. +;; +;; 3. For slow connections, you might get "listing unreadable" error +;; messages, or get an empty buffer for a file that you know has something +;; in it. The solution is to increase the value of ange-ftp-retry-time. +;; Its default value is 5 which is plenty for reasonable connections. +;; However, for some transatlantic connections I set this to 20. +;; +;; 4. Beware of compressing files on non-UNIX hosts. Ange-ftp will do it by +;; copying the file to the local machine, compressing it there, and then +;; sending it back. Binary file transfers between machines of different +;; architectures can be a risky business. Test things out first on some +;; test files. See "Bugs" below. Also, note that ange-ftp copies files by +;; moving them through the local machine. Again, be careful when doing +;; this with binary files on non-Unix machines. +;; +;; 5. Beware that dired over ftp will use your setting of dired-no-confirm +;; (list of dired commands for which confirmation is not asked). You +;; might want to reconsider your setting of this variable, because you +;; might want confirmation for more commands on remote direds than on +;; local direds. For example, I strongly recommend that you not include +;; compress and uncompress in this list. If there is enough demand it +;; might be a good idea to have an alist ange-ftp-dired-no-confirm of +;; pairs ( TYPE . LIST ), where TYPE is an operating system type and LIST +;; is a list of commands for which confirmation would be suppressed. Then +;; remote dired listings would take their (buffer-local) value of +;; dired-no-confirm from this alist. Who votes for this? + +;; --------------------------------------------------------------------- +;; Non-UNIX support: +;; --------------------------------------------------------------------- + +;; VMS support: +;; +;; Ange-ftp has full support for VMS hosts. It +;; should be able to automatically recognize any VMS machine. However, if it +;; fails to do this, you can use the command ange-ftp-add-vms-host. As well, +;; you can set the variable ange-ftp-vms-host-regexp in your .emacs file. We +;; would be grateful if you would report any failures to automatically +;; recognize a VMS host as a bug. +;; +;; Filename Syntax: +;; +;; For ease of *implementation*, the user enters the VMS filename syntax in a +;; UNIX-y way. For example: +;; PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1 +;; would be entered as: +;; /PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1 +;; i.e. to log in as anonymous on ymir.claremont.edu and grab the file: +;; [.CSV.POLICY]RULES.MEM +;; you would type: +;; C-x C-f /anonymous@ymir.claremont.edu:CSV/POLICY/RULES.MEM +;; +;; A legal VMS filename is of the form: FILE.TYPE;## +;; where FILE can be up to 39 characters +;; TYPE can be up to 39 characters +;; ## is a version number (an integer between 1 and 32,767) +;; Valid characters in FILE and TYPE are A-Z 0-9 _ - $ +;; $ cannot begin a filename, and - cannot be used as the first or last +;; character. +;; +;; Tips: +;; 1. Although VMS is not case sensitive, EMACS running under UNIX is. +;; Therefore, to access a VMS file, you must enter the filename with upper +;; case letters. +;; 2. To access the latest version of file under VMS, you use the filename +;; without the ";" and version number. You should always edit the latest +;; version of a file. If you want to edit an earlier version, copy it to a +;; new file first. This has nothing to do with ange-ftp, but is simply +;; good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is +;; latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you +;; inadvertently do C-x C-f /ymir.claremont.edu:FILE.TXT;3, you will find +;; that VMS will not allow you to save the file because it will refuse to +;; overwrite FILE.TXT;3, but instead will want to create FILE.TXT;4, and +;; attach the buffer to this file. To get out of this situation, M-x +;; write-file /ymir.claremont.edu:FILE.TXT will attach the buffer to +;; latest version of the file. For this reason, in dired "f" +;; (dired-find-file), always loads the file sans version, whereas "v", +;; (dired-view-file), always loads the explicit version number. The +;; reasoning being that it reasonable to view old versions of a file, but +;; not to edit them. +;; 3. EMACS has a feature in which it does environment variable substitution +;; in filenames. Therefore, to enter a $ in a filename, you must quote it +;; by typing $$. + +;; MTS support: +;; +;; Ange-ftp has full support for hosts running +;; the Michigan terminal system. It should be able to automatically +;; recognize any MTS machine. However, if it fails to do this, you can use +;; the command ange-ftp-add-mts-host. As well, you can set the variable +;; ange-ftp-mts-host-regexp in your .emacs file. We would be grateful if you +;; would report any failures to automatically recognize a MTS host as a bug. +;; +;; Filename syntax: +;; +;; MTS filenames are entered in a UNIX-y way. For example, if your account +;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be +;; entered as +;; /YYYY@mtsg.ubc.ca:/XXXX:/FILE +;; In other words, MTS accounts are treated as UNIX directories. Of course, +;; to access a file in another account, you must have access permission for +;; it. If FILE were in your own account, then you could enter it in a +;; relative name fashion as +;; /YYYY@mtsg.ubc.ca:FILE +;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the +;; filename does not contain a TYPE (i.e. it can have as many "."'s as you +;; like.) MTS filenames are always in upper case, and hence be sure to enter +;; them as such! MTS is not case sensitive, but an EMACS running under UNIX +;; is. + +;; CMS support: +;; +;; Ange-ftp has full support for hosts running +;; CMS. It should be able to automatically recognize any CMS machine. +;; However, if it fails to do this, you can use the command +;; ange-ftp-add-cms-host. As well, you can set the variable +;; ange-ftp-cms-host-regexp in your .emacs file. We would be grateful if you +;; would report any failures to automatically recognize a CMS host as a bug. +;; +;; Filename syntax: +;; +;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are +;; treated as UNIX directories. For example to access the file READ.ME in +;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter +;; /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME +;; If *.301 is the default minidisk for this account, you could access +;; FOO.BAR on this minidisk as +;; /anonymous@cuvmb.cc.columbia.edu:FOO.BAR +;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be +;; up to 8 characters. Again, beware that CMS filenames are always upper +;; case, and hence must be entered as such. +;; +;; Tips: +;; 1. CMS machines, with the exception of anonymous accounts, nearly always +;; need an account password. To have ange-ftp send an account password, +;; you can either include it in your .netrc file, or use +;; ange-ftp-set-account. +;; 2. Ange-ftp cannot send "write passwords" for a minidisk. Hopefully, we +;; can fix this. +;; +;; ------------------------------------------------------------------ +;; Bugs: +;; ------------------------------------------------------------------ +;; +;; 1. Umask problems: +;; Be warned that files created by using ange-ftp will take account of the +;; umask of the ftp daemon process rather than the umask of the creating +;; user. This is particularly important when logging in as the root user. +;; The way that I tighten up the ftp daemon's umask under HP-UX is to make +;; sure that the umask is changed to 027 before I spawn /etc/inetd. I +;; suspect that there is something similar on other systems. +;; +;; 2. Some combinations of FTP clients and servers break and get out of sync +;; when asked to list a non-existent directory. Some of the ai.mit.edu +;; machines cause this problem for some FTP clients. Using +;; ange-ftp-kill-ftp-process can restart the ftp process, which +;; should get things back in sync. +;; +;; 3. Ange-ftp does not check to make sure that when creating a new file, +;; you provide a valid filename for the remote operating system. +;; If you do not, then the remote FTP server will most likely +;; translate your filename in some way. This may cause ange-ftp to +;; get confused about what exactly is the name of the file. The +;; most common causes of this are using lower case filenames on systems +;; which support only upper case, and using filenames which are too +;; long. +;; +;; 4. Null (blank) passwords confuse both ange-ftp and some FTP daemons. +;; +;; 5. Ange-ftp likes to use pty's to talk to its FTP processes. If GNU Emacs +;; for some reason creates a FTP process that only talks via pipes then +;; ange-ftp won't be getting the information it requires at the time that +;; it wants it since pipes flush at different times to pty's. One +;; disgusting way around this problem is to talk to the FTP process via +;; rlogin which does the 'right' things with pty's. +;; +;; 6. For CMS support, we send too many cd's. Since cd's are cheap, I haven't +;; worried about this too much. Eventually, we should have some caching +;; of the current minidisk. +;; +;; 7. Some CMS machines do not assign a default minidisk when you ftp them as +;; anonymous. It is then necessary to guess a valid minidisk name, and cd +;; to it. This is (understandably) beyond ange-ftp. +;; +;; 8. Remote to remote copying of files on non-Unix machines can be risky. +;; Depending on the variable ange-ftp-binary-file-name-regexp, ange-ftp +;; will use binary mode for the copy. Between systems of different +;; architecture, this still may not be enough to guarantee the integrity +;; of binary files. Binary file transfers from VMS machines are +;; particularly problematical. Should ange-ftp-binary-file-name-regexp be +;; an alist of OS type, regexp pairs? +;; +;; 9. The code to do compression of files over ftp is not as careful as it +;; should be. It deletes the old remote version of the file, before +;; actually checking if the local to remote transfer of the compressed +;; file succeeds. Of course to delete the original version of the file +;; after transferring the compressed version back is also dangerous, +;; because some OS's have severe restrictions on the length of filenames, +;; and when the compressed version is copied back the "-Z" or ".Z" may be +;; truncated. Then, ange-ftp would delete the only remaining version of +;; the file. Maybe ange-ftp should make backups when it compresses files +;; (of course, the backup "~" could also be truncated off, sigh...). +;; Suggestions? +;; +;; 10. If a dir listing is attempted for an empty directory on (at least +;; some) VMS hosts, an ftp error is given. This is really an ftp bug, and +;; I don't know how to get ange-ftp work to around it. +;; +;; 11. Bombs on filenames that start with a space. Deals well with filenames +;; containing spaces, but beware that the remote ftpd may not like them +;; much. +;; +;; 12. The dired support for non-Unix-like systems does not currently work. +;; It needs to be reimplemented by modifying the parse-...-listing +;; functions to convert the directory listing to ls -l format. +;; +;; 13. The famous @ bug. As mentioned above in TIPS, ULTRIX marks symlinks +;; with a trailing @ in a ls -alF listing. In order to account for this +;; ange-ftp looks to chop trailing @'s off of symlink names when it is +;; parsing a listing with the F switch. This will cause ange-ftp to +;; incorrectly get the name of a symlink on a non-ULTRIX host if its name +;; ends in an @. ange-ftp will correct itself if you take F out of the +;; dired ls switches (C-u s will allow you to edit the switches). The +;; dired buffer will be automatically reverted, which will allow ange-ftp +;; to fix its files hashtable. A cookie to anyone who can think of a +;; fast, sure-fire way to recognize ULTRIX over ftp. + +;; If you find any bugs or problems with this package, PLEASE either e-mail +;; the above author, or send a message to the ange-ftp-lovers mailing list +;; below. Ideas and constructive comments are especially welcome. + +;; ange-ftp-lovers: +;; +;; ange-ftp has its own mailing list modestly called ange-ftp-lovers. All +;; users of ange-ftp are welcome to subscribe (see below) and to discuss +;; aspects of ange-ftp. New versions of ange-ftp are posted periodically to +;; the mailing list. + +;; [The following information about lists may be obsolete.] + +;; To [un]subscribe to ange-ftp-lovers, or to report mailer problems with the +;; list, please mail one of the following addresses: +;; +;; ange-ftp-lovers-request@anorman.hpl.hp.com +;; or +;; ange-ftp-lovers-request%anorman.hpl.hp.com@hplb.hpl.hp.com +;; +;; Please don't forget the -request part. +;; +;; For mail to be posted directly to ange-ftp-lovers, send to one of the +;; following addresses: +;; +;; ange-ftp-lovers@anorman.hpl.hp.com +;; or +;; ange-ftp-lovers%anorman.hpl.hp.com@hplb.hpl.hp.com +;; +;; Alternatively, there is a mailing list that only gets announcements of new +;; ange-ftp releases. This is called ange-ftp-lovers-announce, and can be +;; subscribed to by e-mailing to the -request address as above. Please make +;; it clear in the request which mailing list you wish to join. + +;; The archives for ange-ftp-lovers can be found via anonymous ftp under: +;; +;; ftp.reed.edu:pub/mailing-lists/ange-ftp/ + +;; ----------------------------------------------------------- +;; Technical information on this package: +;; ----------------------------------------------------------- + +;; ange-ftp works by putting a handler on file-name-handler-alist +;; which is called by many primitives, and a few non-primitives, +;; whenever they see a file name of the appropriate sort. + +;; Checklist for adding non-UNIX support for TYPE +;; +;; The following functions may need TYPE versions: +;; (not all functions will be needed for every OS) +;; +;; ange-ftp-fix-name-for-TYPE +;; ange-ftp-fix-dir-name-for-TYPE +;; ange-ftp-TYPE-host +;; ange-ftp-TYPE-add-host +;; ange-ftp-parse-TYPE-listing +;; ange-ftp-TYPE-delete-file-entry +;; ange-ftp-TYPE-add-file-entry +;; ange-ftp-TYPE-file-name-as-directory +;; ange-ftp-TYPE-make-compressed-filename +;; ange-ftp-TYPE-file-name-sans-versions +;; +;; Variables: +;; +;; ange-ftp-TYPE-host-regexp +;; May need to add TYPE to ange-ftp-dumb-host-types +;; +;; Check the following functions for OS dependent coding: +;; +;; ange-ftp-host-type +;; ange-ftp-guess-host-type +;; ange-ftp-allow-child-lookup + +;; Host type conventions: +;; +;; The function ange-ftp-host-type and the variable ange-ftp-dired-host-type +;; (mostly) follow the following conventions for remote host types. At +;; least, I think that future code should try to follow these conventions, +;; and the current code should eventually be made compliant. +;; +;; nil = local host type, whatever that is (probably unix). +;; Think nil as in "not a remote host". This value is used by +;; ange-ftp-dired-host-type for local buffers. +;; +;; t = a remote host of unknown type. Think t as in true, it's remote. +;; Currently, `unix' is used as the default remote host type. +;; Maybe we should use t. +;; +;; TYPE = a remote host of TYPE type. +;; +;; TYPE:LIST = a remote host of TYPE type, using a specialized ftp listing +;; program called list. This is currently only used for Unix +;; dl (descriptive listings), when ange-ftp-dired-host-type +;; is set to `unix:dl'. + +;; Bug report codes: +;; +;; Because of their naive faith in this code, there are certain situations +;; which the writers of this program believe could never happen. However, +;; being realists they have put calls to `error' in the program at these +;; points. These errors provide a code, which is an integer, greater than 1. +;; To aid debugging. the error codes, and the functions in which they reside +;; are listed below. +;; +;; 1: See ange-ftp-ls +;; + +;; ----------------------------------------------------------- +;; Hall of fame: +;; ----------------------------------------------------------- +;; +;; Thanks to Roland McGrath for improving the filename syntax handling, +;; for suggesting many enhancements and for numerous cleanups to the code. +;; +;; Thanks to Jamie Zawinski for bugfixes and for ideas such as gateways. +;; +;; Thanks to Ken Laprade for improved .netrc parsing, password reading, and +;; dired / shell auto-loading. +;; +;; Thanks to Sebastian Kremer for dired support and for many ideas and +;; bugfixes. +;; +;; Thanks to Joe Wells for bugfixes, the original non-UNIX system support, +;; VOS support, and hostname completion. +;; +;; Thanks to Nakagawa Takayuki for many good ideas, filename-completion, help +;; with file-name expansion, efficiency worries, stylistic concerns and many +;; bugfixes. +;; +;; Thanks to Sandy Rutherford who re-wrote most of ange-ftp to support VMS, +;; MTS, CMS and UNIX-dls. Sandy also added dired-support for non-UNIX OS and +;; auto-recognition of the host type. +;; +;; Thanks to Dave Smith who wrote the info file for ange-ftp. +;; +;; Finally, thanks to Keith Waclena, Mark D. Baushke, Terence Kelleher, Ping +;; Zhou, Edward Vielmetti, Jack Repenning, Mike Balenger, Todd Kaufmann, +;; Kjetil Svarstad, Tom Wurgler, Linus Tolke, Niko Makila, Carl Edman, Bill +;; Trost, Dave Brennan, Dan Jacobson, Andy Scott, Steve Anderson, Sanjay +;; Mathur, the folks on the ange-ftp-lovers mailing list and many others +;; whose names I've forgotten who have helped to debug and fix problems with +;; ange-ftp.el. + +;;; Code: + +(require 'comint) +;; Silence compiler: +(eval-when-compile + (require 'dired) + (defvar comint-last-output-start nil) + (defvar comint-last-input-start nil) + (defvar comint-last-input-end nil)) + +;;;; ------------------------------------------------------------ +;;;; User customization variables. +;;;; ------------------------------------------------------------ + +(defgroup ange-ftp nil + "Accessing remote files and directories using FTP + made as simple and transparent as possible." + :group 'files + :prefix "ange-ftp-") + +(defcustom ange-ftp-name-format + '("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*[^@/:.]\\):\\(.*\\)" . (3 2 4)) + "*Format of a fully expanded remote file name. + +This is a list of the form \(REGEXP HOST USER NAME\), +where REGEXP is a regular expression matching +the full remote name, and HOST, USER, and NAME are the numbers of +parenthesized expressions in REGEXP for the components (in that order)." + :group 'ange-ftp + :type '(list regexp + (integer :tag "Host group") + (integer :tag "User group") + (integer :tag "Name group"))) + +;; ange-ftp-multi-skip-msgs should only match ###-, where ### is one of +;; the number codes corresponding to ange-ftp-good-msgs or ange-ftp-fatal-msgs. +;; Otherwise, ange-ftp will go into multi-skip mode, and never come out. + +(defvar ange-ftp-multi-msgs + "^220-\\|^230-\\|^226\\|^25.-\\|^221-\\|^200-\\|^331-\\|^4[25]1-\\|^530-" + "*Regular expression matching the start of a multiline ftp reply.") + +(defvar ange-ftp-good-msgs + "^220 \\|^230 \\|^226 \\|^25. \\|^221 \\|^200 \\|^[Hh]ash mark" + "*Regular expression matching ftp \"success\" messages.") + +;; CMS and the odd VMS machine say 200 Port rather than 200 PORT. +;; Also CMS machines use a multiline 550- reply to say that you +;; don't have write permission. ange-ftp gets into multi-line skip +;; mode and hangs. Have it ignore 550- instead. It will then barf +;; when it gets the 550 line, as it should. + +(defcustom ange-ftp-skip-msgs + (concat "^200 \\(PORT\\|Port\\) \\|^331 \\|^150 \\|^350 \\|^[0-9]+ bytes \\|" + "^Connected \\|^$\\|^Remote system\\|^Using\\|^ \\|Password:\\|" + "^Data connection \\|" + "^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye\\|" + "^227 .*[Pp]assive\\|^200 EPRT\\|^500 .*EPRT") + "*Regular expression matching ftp messages that can be ignored." + :group 'ange-ftp + :type 'regexp) + +(defcustom ange-ftp-fatal-msgs + (concat "^ftp: \\|^Not connected\\|^530 \\|^4[25]1 \\|rcmd: \\|" + "^No control connection\\|unknown host\\|^lost connection") + "*Regular expression matching ftp messages that indicate serious errors. + +These mean that the FTP process should (or already has) been killed." + :group 'ange-ftp + :type 'regexp) + +(defcustom ange-ftp-gateway-fatal-msgs + "No route to host\\|Connection closed\\|No such host\\|Login incorrect" + "*Regular expression matching login failure messages from rlogin/telnet." + :group 'ange-ftp + :type 'regexp) + +(defcustom ange-ftp-xfer-size-msgs + "^150 .* connection for .* (\\([0-9]+\\) bytes)" + "*Regular expression used to determine the number of bytes in a FTP transfer." + :group 'ange-ftp + :type 'regexp) + +(defcustom ange-ftp-tmp-name-template + (expand-file-name "ange-ftp" temporary-file-directory) + "*Template used to create temporary files." + :group 'ange-ftp + :type 'directory) + +(defcustom ange-ftp-gateway-tmp-name-template "/tmp/ange-ftp" + "*Template used to create temporary files when ftp-ing through a gateway. + +Files starting with this prefix need to be accessible from BOTH the local +machine and the gateway machine, and need to have the SAME name on both +machines, that is, /tmp is probably NOT what you want, since that is rarely +cross-mounted." + :group 'ange-ftp + :type 'directory) + +(defcustom ange-ftp-netrc-filename "~/.netrc" + "*File in .netrc format to search for passwords." + :group 'ange-ftp + :type 'file) + +(defcustom ange-ftp-disable-netrc-security-check (eq system-type 'windows-nt) + "*If non-nil avoid checking permissions on the .netrc file." + :group 'ange-ftp + :type 'boolean) + +(defcustom ange-ftp-default-user nil + "*User name to use when none is specified in a file name. + +If non-nil but not a string, you are prompted for the name. +If nil, the value of `ange-ftp-netrc-default-user' is used. +If that is nil too, then your login name is used. + +Once a connection to a given host has been initiated, the user name +and password information for that host are cached and re-used by +ange-ftp. Use \\[ange-ftp-set-user] to change the cached values, +since setting `ange-ftp-default-user' directly does not affect +the cached information." + :group 'ange-ftp + :type '(choice (const :tag "Default" nil) + string + (other :tag "Prompt" t))) + +(defcustom ange-ftp-netrc-default-user nil + "Alternate default user name to use when none is specified. + +This variable is set from the `default' command in your `.netrc' file, +if there is one." + :group 'ange-ftp + :type '(choice (const :tag "Default" nil) + string)) + +(defcustom ange-ftp-default-password nil + "*Password to use when the user name equals `ange-ftp-default-user'." + :group 'ange-ftp + :type '(choice (const :tag "Default" nil) + string)) + +(defcustom ange-ftp-default-account nil + "*Account to use when the user name equals `ange-ftp-default-user'." + :group 'ange-ftp + :type '(choice (const :tag "Default" nil) + string)) + +(defcustom ange-ftp-netrc-default-password nil + "*Password to use when the user name equals `ange-ftp-netrc-default-user'." + :group 'ange-ftp + :type '(choice (const :tag "Default" nil) + string)) + +(defcustom ange-ftp-netrc-default-account nil + "*Account to use when the user name equals `ange-ftp-netrc-default-user'." + :group 'ange-ftp + :type '(choice (const :tag "Default" nil) + string)) + +(defcustom ange-ftp-generate-anonymous-password t + "*If t, use value of `user-mail-address' as password for anonymous ftp. + +If a string, then use that string as the password. +If nil, prompt the user for a password." + :group 'ange-ftp + :type '(choice (const :tag "Prompt" nil) + string + (other :tag "User address" t))) + +(defcustom ange-ftp-dumb-unix-host-regexp nil + "*If non-nil, regexp matching hosts on which `dir' command lists directory." + :group 'ange-ftp + :type '(choice (const :tag "Default" nil) + string)) + +(defcustom ange-ftp-binary-file-name-regexp + (concat "\\.[zZ]$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|" + "\\.dvi$\\|\\.ps$\\|\\.elc$\\|TAGS$\\|\\.gif$\\|" + "\\.EXE\\(;[0-9]+\\)?$\\|\\.[zZ]-part-..$\\|\\.gz$\\|" + "\\.taz$\\|\\.tgz$") + "*If a file matches this regexp then it is transferred in binary mode." + :group 'ange-ftp + :type 'regexp) + +(defcustom ange-ftp-gateway-host nil + "*Name of host to use as gateway machine when local FTP isn't possible." + :group 'ange-ftp + :type '(choice (const :tag "Default" nil) + string)) + +(defcustom ange-ftp-local-host-regexp ".*" + "*Regexp selecting hosts which can be reached directly with ftp. + +For other hosts the FTP process is started on \`ange-ftp-gateway-host\' +instead, and/or reached via \`ange-ftp-gateway-ftp-program-name\'." + :group 'ange-ftp + :type 'regexp) + +(defcustom ange-ftp-gateway-program-interactive nil + "*If non-nil then the gateway program should give a shell prompt. + +Both telnet and rlogin do something like this." + :group 'ange-ftp + :type 'boolean) + +(defcustom ange-ftp-gateway-program remote-shell-program + "*Name of program to spawn a shell on the gateway machine. + +Valid candidates are rsh (remsh on some systems), telnet and rlogin. See +also the gateway variable above." + :group 'ange-ftp + :type '(choice (const "rsh") + (const "telnet") + (const "rlogin") + string)) + +(defcustom ange-ftp-gateway-prompt-pattern "^[^#$%>;\n]*[#$%>;] *" + "*Regexp matching prompt after complete login sequence on gateway machine. + +A match for this means the shell is now awaiting input. Make this regexp as +strict as possible; it shouldn't match *anything* at all except the user's +initial prompt. The above string will fail under most SUN-3's since it +matches the login banner." + :group 'ange-ftp + :type 'regexp) + +(defvar ange-ftp-gateway-setup-term-command + (if (eq system-type 'hpux) + "stty -onlcr -echo\n" + "stty -echo nl\n") + "*Set up terminal after logging in to the gateway machine. +This command should stop the terminal from echoing each command, and +arrange to strip out trailing ^M characters.") + +(defcustom ange-ftp-smart-gateway nil + "*Non-nil means the ftp gateway and/or the gateway ftp program is smart. + +Don't bother telnetting, etc., already connected to desired host transparently, +or just issue a user@host command in case \`ange-ftp-gateway-host\' is non-nil." + :group 'ange-ftp + :type 'boolean) + +(defcustom ange-ftp-smart-gateway-port "21" + "*Port on gateway machine to use when smart gateway is in operation." + :group 'ange-ftp + :type 'string) + +(defcustom ange-ftp-send-hash t + "*If non-nil, send the HASH command to the FTP client." + :group 'ange-ftp + :type 'boolean) + +(defcustom ange-ftp-binary-hash-mark-size nil + "*Default size, in bytes, between hash-marks when transferring a binary file. +If nil, this variable will be locally overridden if the FTP client outputs a +suitable response to the HASH command. If non-nil, this value takes +precedence over the local value." + :group 'ange-ftp + :type '(choice (const :tag "Overridden" nil) + integer)) + +(defcustom ange-ftp-ascii-hash-mark-size 1024 + "*Default size, in bytes, between hash-marks when transferring an ASCII file. +This variable is buffer-local and will be locally overridden if the FTP client +outputs a suitable response to the HASH command." + :group 'ange-ftp + :type 'integer) + +(defcustom ange-ftp-process-verbose t + "*If non-nil then be chatty about interaction with the FTP process." + :group 'ange-ftp + :type 'boolean) + +(defcustom ange-ftp-ftp-program-name "ftp" + "*Name of FTP program to run." + :group 'ange-ftp + :type 'string) + +(defcustom ange-ftp-gateway-ftp-program-name "ftp" + "*Name of FTP program to run when accessing non-local hosts. + +Some AT&T folks claim to use something called `pftp' here." + :group 'ange-ftp + :type 'string) + +(defcustom ange-ftp-ftp-program-args '("-i" "-n" "-g" "-v") + "*A list of arguments passed to the FTP program when started." + :group 'ange-ftp + :type '(repeat string)) + +(defcustom ange-ftp-nslookup-program nil + "*If non-nil, this is a string naming the nslookup program." + :group 'ange-ftp + :type '(choice (const :tag "None" nil) + string)) + +(defcustom ange-ftp-make-backup-files () + "*Non-nil means make backup files for \"magic\" remote files." + :group 'ange-ftp + :type 'boolean) + +(defcustom ange-ftp-retry-time 5 + "*Number of seconds to wait before retry if file or listing doesn't arrive. +This might need to be increased for very slow connections." + :group 'ange-ftp + :type 'integer) + +(defcustom ange-ftp-auto-save 0 + "If 1, allow ange-ftp files to be auto-saved. +If 0, inhibit auto-saving of ange-ftp files. +Don't use any other value." + :group 'ange-ftp + :type '(choice (const :tag "Suppress" 0) + (const :tag "Allow" 1))) + +(defcustom ange-ftp-try-passive-mode nil + "It t, try to use passive mode in ftp, if the client program +supports the `passive' command." + :group 'ange-ftp + :type 'boolean + :version 21.1) + + +;;;; ------------------------------------------------------------ +;;;; Hash table support. +;;;; ------------------------------------------------------------ + +(require 'backquote) + +(defun ange-ftp-make-hashtable (&optional size) + "Make an obarray suitable for use as a hashtable. +SIZE, if supplied, should be a prime number." + (make-vector (or size 31) 0)) + +(defun ange-ftp-map-hashtable (fun tbl) + "Call FUNCTION on each key and value in HASHTABLE." + (mapatoms + (function + (lambda (sym) + (funcall fun (get sym 'key) (get sym 'val)))) + tbl)) + +(defmacro ange-ftp-make-hash-key (key) + "Convert KEY into a suitable key for a hashtable." + (` (if (stringp (, key)) + (, key) + (prin1-to-string (, key))))) + +(defun ange-ftp-get-hash-entry (key tbl) + "Return the value associated with KEY in HASHTABLE." + (let ((sym (intern-soft (ange-ftp-make-hash-key key) tbl))) + (and sym (get sym 'val)))) + +(defun ange-ftp-put-hash-entry (key val tbl) + "Record an association between KEY and VALUE in HASHTABLE." + (let ((sym (intern (ange-ftp-make-hash-key key) tbl))) + (put sym 'val val) + (put sym 'key key))) + +(defun ange-ftp-del-hash-entry (key tbl) + "Copy all symbols except KEY in HASHTABLE and return modified hashtable." + (let* ((len (length tbl)) + (new-tbl (ange-ftp-make-hashtable len)) + (i (1- len))) + (ange-ftp-map-hashtable + (function + (lambda (k v) + (or (equal k key) + (ange-ftp-put-hash-entry k v new-tbl)))) + tbl) + (while (>= i 0) + (aset tbl i (aref new-tbl i)) + (setq i (1- i))) + tbl)) + +(defun ange-ftp-hash-entry-exists-p (key tbl) + "Return whether there is an association for KEY in TABLE." + (intern-soft (ange-ftp-make-hash-key key) tbl)) + +(defun ange-ftp-hash-table-keys (tbl) + "Return a sorted list of all the active keys in TABLE, as strings." + (sort (all-completions "" tbl) + (function string-lessp))) + +;;;; ------------------------------------------------------------ +;;;; Internal variables. +;;;; ------------------------------------------------------------ + +(defvar ange-ftp-data-buffer-name " *ftp data*" + "Buffer name to hold directory listing data received from ftp process.") + +(defvar ange-ftp-netrc-modtime nil + "Last modified time of the netrc file from file-attributes.") + +(defvar ange-ftp-user-hashtable (ange-ftp-make-hashtable) + "Hash table holding associations between HOST, USER pairs.") + +(defvar ange-ftp-passwd-hashtable (ange-ftp-make-hashtable) + "Mapping between a HOST, USER pair and a PASSWORD for them. +All HOST values should be in lower case.") + +(defvar ange-ftp-account-hashtable (ange-ftp-make-hashtable) + "Mapping between a HOST, USER pair and a ACCOUNT password for them.") + +(defvar ange-ftp-files-hashtable (ange-ftp-make-hashtable 97) + "Hash table for storing directories and their respective files.") + +(defvar ange-ftp-inodes-hashtable (ange-ftp-make-hashtable 97) + "Hash table for storing file names and their \"inode numbers\".") + +(defvar ange-ftp-next-inode-number 1 + "Next \"inode number\" value. We give each file name a unique number.") + +(defvar ange-ftp-ls-cache-lsargs nil + "Last set of args used by ange-ftp-ls.") + +(defvar ange-ftp-ls-cache-file nil + "Last file passed to ange-ftp-ls.") + +(defvar ange-ftp-ls-cache-res nil + "Last result returned from ange-ftp-ls.") + +(defconst ange-ftp-expand-dir-hashtable (ange-ftp-make-hashtable)) + +(defconst ange-ftp-expand-dir-regexp "^5.0 \\([^: ]+\\):") + +;; These are local variables in each FTP process buffer. +(defvar ange-ftp-hash-mark-unit nil) +(defvar ange-ftp-hash-mark-count nil) +(defvar ange-ftp-xfer-size nil) +(defvar ange-ftp-process-string nil) +(defvar ange-ftp-process-result-line nil) +(defvar ange-ftp-process-busy nil) +(defvar ange-ftp-process-result nil) +(defvar ange-ftp-process-multi-skip nil) +(defvar ange-ftp-process-msg nil) +(defvar ange-ftp-process-continue nil) +(defvar ange-ftp-last-percent nil) + +;; These variables are bound by one function and examined by another. +;; Leave them void globally for error checking. +(defvar ange-ftp-this-file) +(defvar ange-ftp-this-dir) +(defvar ange-ftp-this-user) +(defvar ange-ftp-this-host) +(defvar ange-ftp-this-msg) +(defvar ange-ftp-completion-ignored-pattern) +(defvar ange-ftp-trample-marker) + +;; New error symbols. +(put 'ftp-error 'error-conditions '(ftp-error file-error error)) +;; (put 'ftp-error 'error-message "FTP error") + +;;; ------------------------------------------------------------ +;;; Enhanced message support. +;;; ------------------------------------------------------------ + +(defun ange-ftp-message (fmt &rest args) + "Display message in echo area, but indicate if truncated. +Args are as in `message': a format string, plus arguments to be formatted." + (let ((msg (apply (function format) fmt args)) + (max (window-width (minibuffer-window)))) + (if noninteractive + msg + (if (>= (length msg) max) + ;; Take just the last MAX - 3 chars of the string. + (setq msg (concat "> " (substring msg (- 3 max))))) + (message "%s" msg)))) + +(defun ange-ftp-abbreviate-filename (file &optional new) + "Abbreviate the file name FILE relative to the default-directory. +If the optional parameter NEW is given and the non-directory parts match, +only return the directory part of FILE." + (save-match-data + (if (and default-directory + (string-match (concat "^" + (regexp-quote default-directory) + ".") file)) + (setq file (substring file (1- (match-end 0))))) + (if (and new + (string-equal (file-name-nondirectory file) + (file-name-nondirectory new))) + (setq file (file-name-directory file))) + (or file "./"))) + +;;;; ------------------------------------------------------------ +;;;; User / Host mapping support. +;;;; ------------------------------------------------------------ + +(defun ange-ftp-set-user (host user) + "For a given HOST, set or change the default USER." + (interactive "sHost: \nsUser: ") + (ange-ftp-put-hash-entry host user ange-ftp-user-hashtable)) + +(defun ange-ftp-get-user (host) + "Given a HOST, return the default USER." + (ange-ftp-parse-netrc) + (let ((user (ange-ftp-get-hash-entry host ange-ftp-user-hashtable))) + (or user + (prog1 + (setq user + (cond ((stringp ange-ftp-default-user) + ;; We have a default name. Use it. + ange-ftp-default-user) + (ange-ftp-default-user + ;; Ask the user. + (let ((enable-recursive-minibuffers t)) + (read-string (format "User for %s: " host) + (user-login-name)))) + (ange-ftp-netrc-default-user) + ;; Default to the user's login name. + (t + (user-login-name)))) + (ange-ftp-set-user host user))))) + +;;;; ------------------------------------------------------------ +;;;; Password support. +;;;; ------------------------------------------------------------ + +(defmacro ange-ftp-generate-passwd-key (host user) + (` (concat (downcase (, host)) "/" (, user)))) + +(defmacro ange-ftp-lookup-passwd (host user) + (` (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key (, host) (, user)) + ange-ftp-passwd-hashtable))) + +(defun ange-ftp-set-passwd (host user passwd) + "For a given HOST and USER, set or change the associated PASSWORD." + (interactive (list (read-string "Host: ") + (read-string "User: ") + (read-passwd "Password: "))) + (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user) + passwd + ange-ftp-passwd-hashtable)) + +(defun ange-ftp-get-host-with-passwd (user) + "Given a USER, return a host we know the password for." + (ange-ftp-parse-netrc) + (catch 'found-one + (ange-ftp-map-hashtable + (function (lambda (host val) + (if (ange-ftp-lookup-passwd host user) + (throw 'found-one host)))) + ange-ftp-user-hashtable) + (save-match-data + (ange-ftp-map-hashtable + (function + (lambda (key value) + (if (string-match "^[^/]*\\(/\\).*$" key) + (let ((host (substring key 0 (match-beginning 1)))) + (if (and (string-equal user (substring key (match-end 1))) + value) + (throw 'found-one host)))))) + ange-ftp-passwd-hashtable)) + nil)) + +(defun ange-ftp-get-passwd (host user) + "Return the password for specified HOST and USER, asking user if necessary." + (ange-ftp-parse-netrc) + + ;; look up password in the hash table first; user might have overridden the + ;; defaults. + (cond ((ange-ftp-lookup-passwd host user)) + + ;; See if default user and password set. + ((and (stringp ange-ftp-default-user) + ange-ftp-default-password + (string-equal user ange-ftp-default-user)) + ange-ftp-default-password) + + ;; See if default user and password set from .netrc file. + ((and (stringp ange-ftp-netrc-default-user) + ange-ftp-netrc-default-password + (string-equal user ange-ftp-netrc-default-user)) + ange-ftp-netrc-default-password) + + ;; anonymous ftp password is handled specially since there is an + ;; unwritten rule about how that is used on the Internet. + ((and (or (string-equal user "anonymous") + (string-equal user "ftp")) + ange-ftp-generate-anonymous-password) + (if (stringp ange-ftp-generate-anonymous-password) + ange-ftp-generate-anonymous-password + user-mail-address)) + + ;; see if same user has logged in to other hosts; if so then prompt + ;; with the password that was used there. + (t + (let* ((other (ange-ftp-get-host-with-passwd user)) + (passwd (if other + + ;; found another machine with the same user. + ;; Try that account. + (read-passwd + (format "passwd for %s@%s (default same as %s@%s): " + user host user other) + nil + (ange-ftp-lookup-passwd other user)) + + ;; I give up. Ask the user for the password. + (read-passwd + (format "Password for %s@%s: " user host))))) + (ange-ftp-set-passwd host user passwd) + passwd)))) + +;;;; ------------------------------------------------------------ +;;;; Account support +;;;; ------------------------------------------------------------ + +;; Account passwords must be either specified in the .netrc file, or set +;; manually by calling ange-ftp-set-account. For the moment, ange-ftp doesn't +;; check to see whether the FTP process is actually prompting for an account +;; password. + +(defun ange-ftp-set-account (host user account) + "For a given HOST and USER, set or change the associated ACCOUNT password." + (interactive (list (read-string "Host: ") + (read-string "User: ") + (read-passwd "Account password: "))) + (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user) + account + ange-ftp-account-hashtable)) + +(defun ange-ftp-get-account (host user) + "Given a HOST and USER, return the FTP account." + (ange-ftp-parse-netrc) + (or (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key host user) + ange-ftp-account-hashtable) + (and (stringp ange-ftp-default-user) + (string-equal user ange-ftp-default-user) + ange-ftp-default-account) + (and (stringp ange-ftp-netrc-default-user) + (string-equal user ange-ftp-netrc-default-user) + ange-ftp-netrc-default-account))) + +;;;; ------------------------------------------------------------ +;;;; ~/.netrc support +;;;; ------------------------------------------------------------ + +(defun ange-ftp-chase-symlinks (file) + "Return the filename that FILE references, following all symbolic links." + (let (temp) + (while (setq temp (ange-ftp-real-file-symlink-p file)) + (setq file + (if (file-name-absolute-p temp) + temp + (concat (file-name-directory file) temp))))) + file) + +;; Move along current line looking for the value of the TOKEN. +;; Valid separators between TOKEN and its value are commas and +;; whitespace. Second arg LIMIT is a limit for the search. + +(defun ange-ftp-parse-netrc-token (token limit) + (if (search-forward token limit t) + (let (beg) + (skip-chars-forward ", \t\r\n" limit) + (if (eq (following-char) ?\") ;quoted token value + (progn (forward-char 1) + (setq beg (point)) + (skip-chars-forward "^\"" limit) + (forward-char 1) + (buffer-substring beg (1- (point)))) + (setq beg (point)) + (skip-chars-forward "^, \t\r\n" limit) + (buffer-substring beg (point)))))) + +;; Extract the values for the tokens `machine', `login', +;; `password' and `account' in the current buffer. If successful, +;; record the information found. + +(defun ange-ftp-parse-netrc-group () + (let ((start (point)) + (end (save-excursion + (if (looking-at "machine\\>") + ;; Skip `machine' and the machine name that follows. + (progn + (skip-chars-forward "^ \t\r\n") + (skip-chars-forward " \t\r\n") + (skip-chars-forward "^ \t\r\n")) + ;; Skip `default'. + (skip-chars-forward "^ \t\r\n")) + ;; Find start of the next `machine' or `default' + ;; or the end of the buffer. + (if (re-search-forward "machine\\>\\|default\\>" nil t) + (match-beginning 0) + (point-max)))) + machine login password account) + (setq machine (ange-ftp-parse-netrc-token "machine" end) + login (ange-ftp-parse-netrc-token "login" end) + password (ange-ftp-parse-netrc-token "password" end) + account (ange-ftp-parse-netrc-token "account" end)) + (if (and machine login) + ;; found a `machine` token. + (progn + (ange-ftp-set-user machine login) + (ange-ftp-set-passwd machine login password) + (and account + (ange-ftp-set-account machine login account))) + (goto-char start) + (if (search-forward "default" end t) + ;; found a `default' token + (progn + (setq login (ange-ftp-parse-netrc-token "login" end) + password (ange-ftp-parse-netrc-token "password" end) + account (ange-ftp-parse-netrc-token "account" end)) + (and login + (setq ange-ftp-netrc-default-user login)) + (and password + (setq ange-ftp-netrc-default-password password)) + (and account + (setq ange-ftp-netrc-default-account account))))) + (goto-char end))) + +;; Read in ~/.netrc, if one exists. If ~/.netrc file exists and has +;; the correct permissions then extract the \`machine\', \`login\', +;; \`password\' and \`account\' information from within. + +(defun ange-ftp-parse-netrc () + ;; We set this before actually doing it to avoid the possibility + ;; of an infinite loop if ange-ftp-netrc-filename is an FTP file. + (interactive) + (let (file attr) + (let ((default-directory "/")) + (setq file (ange-ftp-chase-symlinks + (ange-ftp-real-expand-file-name ange-ftp-netrc-filename))) + (setq attr (ange-ftp-real-file-attributes file))) + (if (and attr ; file exists. + (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed + (save-match-data + (if (or ange-ftp-disable-netrc-security-check + (and (eq (nth 2 attr) (user-uid)) ; Same uids. + (string-match ".r..------" (nth 8 attr)))) + (save-excursion + ;; we are cheating a bit here. I'm trying to do the equivalent + ;; of find-file on the .netrc file, but then nuke it afterwards. + ;; with the bit of logic below we should be able to have + ;; encrypted .netrc files. + (set-buffer (generate-new-buffer "*ftp-.netrc*")) + (ange-ftp-real-insert-file-contents file) + (setq buffer-file-name file) + (setq default-directory (file-name-directory file)) + (normal-mode t) + (mapcar 'funcall find-file-hooks) + (setq buffer-file-name nil) + (goto-char (point-min)) + (skip-chars-forward " \t\r\n") + (while (not (eobp)) + (ange-ftp-parse-netrc-group)) + (kill-buffer (current-buffer))) + (ange-ftp-message "%s either not owned by you or badly protected." + ange-ftp-netrc-filename) + (sit-for 1)) + (setq ange-ftp-netrc-modtime (nth 5 attr)))))) + +;; Return a list of prefixes of the form 'user@host:' to be used when +;; completion is done in the root directory. + +(defun ange-ftp-generate-root-prefixes () + (ange-ftp-parse-netrc) + (save-match-data + (let (res) + (ange-ftp-map-hashtable + (function + (lambda (key value) + (if (string-match "^[^/]*\\(/\\).*$" key) + (let ((host (substring key 0 (match-beginning 1))) + (user (substring key (match-end 1)))) + (setq res (cons (list (concat user "@" host ":")) + res)))))) + ange-ftp-passwd-hashtable) + (ange-ftp-map-hashtable + (function (lambda (host user) + (setq res (cons (list (concat host ":")) + res)))) + ange-ftp-user-hashtable) + (or res (list nil))))) + +;;;; ------------------------------------------------------------ +;;;; Remote file name syntax support. +;;;; ------------------------------------------------------------ + +(defmacro ange-ftp-ftp-name-component (n ns name) + "Extract the Nth ftp file name component from NS." + (` (let ((elt (nth (, n) (, ns)))) + (if (match-beginning elt) + (substring (, name) (match-beginning elt) (match-end elt)))))) + +(defvar ange-ftp-ftp-name-arg "") +(defvar ange-ftp-ftp-name-res nil) + +;; Parse NAME according to `ange-ftp-name-format' (which see). +;; Returns a list (HOST USER NAME), or nil if NAME does not match the format. +(defun ange-ftp-ftp-name (name) + (if (string-equal name ange-ftp-ftp-name-arg) + ange-ftp-ftp-name-res + (setq ange-ftp-ftp-name-arg name + ange-ftp-ftp-name-res + (save-match-data + (if (posix-string-match (car ange-ftp-name-format) name) + (let* ((ns (cdr ange-ftp-name-format)) + (host (ange-ftp-ftp-name-component 0 ns name)) + (user (ange-ftp-ftp-name-component 1 ns name)) + (name (ange-ftp-ftp-name-component 2 ns name))) + (if (zerop (length user)) + (setq user (ange-ftp-get-user host))) + (list host user name)) + nil))))) + +;; Take a FULLNAME that matches according to ange-ftp-name-format and +;; replace the name component with NAME. +(defun ange-ftp-replace-name-component (fullname name) + (save-match-data + (if (posix-string-match (car ange-ftp-name-format) fullname) + (let* ((ns (cdr ange-ftp-name-format)) + (elt (nth 2 ns))) + (concat (substring fullname 0 (match-beginning elt)) + name + (substring fullname (match-end elt))))))) + +;;;; ------------------------------------------------------------ +;;;; Miscellaneous utils. +;;;; ------------------------------------------------------------ + +;; (setq ange-ftp-tmp-keymap (make-sparse-keymap)) +;; (define-key ange-ftp-tmp-keymap "\C-m" 'exit-minibuffer) + +(defun ange-ftp-repaint-minibuffer () + "Clear any existing minibuffer message; let the minibuffer contents show." + (message nil)) + +;; Return the name of the buffer that collects output from the ftp process +;; connected to the given HOST and USER pair. +(defun ange-ftp-ftp-process-buffer (host user) + (concat "*ftp " user "@" host "*")) + +;; Display the last chunk of output from the ftp process for the given HOST +;; USER pair, and signal an error including MSG in the text. +(defun ange-ftp-error (host user msg) + (let ((cur (selected-window)) + (pop-up-windows t)) + (pop-to-buffer + (get-buffer-create + (ange-ftp-ftp-process-buffer host user))) + (goto-char (point-max)) + (select-window cur)) + (signal 'ftp-error (list (format "FTP Error: %s" msg)))) + +(defun ange-ftp-set-buffer-mode () + "Set correct modes for the current buffer if visiting a remote file." + (if (and (stringp buffer-file-name) + (ange-ftp-ftp-name buffer-file-name)) + (auto-save-mode ange-ftp-auto-save))) + +(defun ange-ftp-kill-ftp-process (&optional buffer) + "Kill the FTP process associated with BUFFER (the current buffer, if nil). +If the BUFFER's visited filename or default-directory is an ftp filename +then kill the related ftp process." + (interactive "bKill FTP process associated with buffer: ") + (if (null buffer) + (setq buffer (current-buffer)) + (setq buffer (get-buffer buffer))) + (let ((file (or (buffer-file-name buffer) + (save-excursion (set-buffer buffer) default-directory)))) + (if file + (let ((parsed (ange-ftp-ftp-name (expand-file-name file)))) + (if parsed + (let ((host (nth 0 parsed)) + (user (nth 1 parsed))) + (kill-buffer (get-buffer (ange-ftp-ftp-process-buffer host user))))))))) + +(defun ange-ftp-quote-string (string) + "Quote any characters in STRING that may confuse the ftp process." + (apply (function concat) + (mapcar (function + ;; This is said to be wrong; ftp is said to + ;; need quoting only for ", and that by doubling it. + ;; But experiment says this kind of quoting is correct + ;; when talking to ftp on GNU/Linux systems. + (lambda (char) + (if (or (<= char ? ) + (> char ?\~) + (= char ?\") + (= char ?\\)) + (vector ?\\ char) + (vector char)))) + string))) + +(defun ange-ftp-barf-if-not-directory (directory) + (or (file-directory-p directory) + (signal 'file-error + (list "Opening directory" + (if (file-exists-p directory) + "not a directory" + "no such file or directory") + directory)))) + +;;;; ------------------------------------------------------------ +;;;; FTP process filter support. +;;;; ------------------------------------------------------------ + +(defun ange-ftp-process-handle-line (line proc) + "Look at the given LINE from the ftp process PROC. +Try to categorize it into one of four categories: +good, skip, fatal, or unknown." + (cond ((string-match ange-ftp-xfer-size-msgs line) + (setq ange-ftp-xfer-size + (ash (string-to-int (substring line + (match-beginning 1) + (match-end 1))) + -10))) + ((string-match ange-ftp-skip-msgs line) + t) + ((string-match ange-ftp-good-msgs line) + (setq ange-ftp-process-busy nil + ange-ftp-process-result t + ange-ftp-process-result-line line)) + ;; Check this before checking for errors. + ;; Otherwise the last line of these three seems to be an error: + ;; 230-see a significant impact from the move. For those of you who can't + ;; 230-use DNS to resolve hostnames and get an error message like + ;; 230-"ftp.stsci.edu: unknown host", the new IP address will be... + ((string-match ange-ftp-multi-msgs line) + (setq ange-ftp-process-multi-skip t)) + ((string-match ange-ftp-fatal-msgs line) + (delete-process proc) + (setq ange-ftp-process-busy nil + ange-ftp-process-result-line line)) + (ange-ftp-process-multi-skip + t) + (t + (setq ange-ftp-process-busy nil + ange-ftp-process-result-line line)))) + +(defun ange-ftp-set-xfer-size (host user bytes) + "Set the size of the next FTP transfer in bytes." + (let ((proc (ange-ftp-get-process host user))) + (if proc + (let ((buf (process-buffer proc))) + (if buf + (save-excursion + (set-buffer buf) + (setq ange-ftp-xfer-size (ash bytes -10)))))))) + +(defun ange-ftp-process-handle-hash (str) + "Remove hash marks from STRING and display count so far." + (setq str (concat (substring str 0 (match-beginning 0)) + (substring str (match-end 0))) + ange-ftp-hash-mark-count (+ (- (match-end 0) + (match-beginning 0)) + ange-ftp-hash-mark-count)) + (and ange-ftp-hash-mark-unit + ange-ftp-process-msg + ange-ftp-process-verbose + (not (eq (selected-window) (minibuffer-window))) + (not (boundp 'search-message)) ;screws up isearch otherwise + (not cursor-in-echo-area) ;screws up y-or-n-p otherwise + (let ((kbytes (ash (* ange-ftp-hash-mark-unit + ange-ftp-hash-mark-count) + -6))) + (if (zerop ange-ftp-xfer-size) + (ange-ftp-message "%s...%dk" ange-ftp-process-msg kbytes) + (let ((percent (/ (* 100 kbytes) ange-ftp-xfer-size))) + ;; cut out the redisplay of identical %-age messages. + (if (not (eq percent ange-ftp-last-percent)) + (progn + (setq ange-ftp-last-percent percent) + (ange-ftp-message "%s...%d%%" ange-ftp-process-msg percent))))))) + str) + +;; Call the function specified by CONT. CONT can be either a function +;; or a list of a function and some args. The first two parameters +;; passed to the function will be RESULT and LINE. The remaining args +;; will be taken from CONT if a list was passed. + +(defun ange-ftp-call-cont (cont result line) + (if cont + (if (and (listp cont) + (not (eq (car cont) 'lambda))) + (apply (car cont) result line (cdr cont)) + (funcall cont result line)))) + +;; Build up a complete line of output from the ftp PROCESS and pass it +;; on to ange-ftp-process-handle-line to deal with. + +(defun ange-ftp-process-filter (proc str) + (let ((buffer (process-buffer proc)) + (old-buffer (current-buffer))) + + ;; Eliminate nulls. + (while (string-match "\000+" str) + (setq str (replace-match "" nil nil str))) + + ;; see if the buffer is still around... it could have been deleted. + (if (buffer-name buffer) + (unwind-protect + (progn + (set-buffer (process-buffer proc)) + + ;; handle hash mark printing + (and ange-ftp-process-busy + (string-match "^#+$" str) + (setq str (ange-ftp-process-handle-hash str))) + (comint-output-filter proc str) + ;; Replace STR by the result of the comint processing. + (setq str (buffer-substring comint-last-output-start + (process-mark proc))) + (if ange-ftp-process-busy + (progn + (setq ange-ftp-process-string (concat ange-ftp-process-string + str)) + + ;; if we gave an empty password to the USER command earlier + ;; then we should send a null password now. + (if (string-match "Password: *$" ange-ftp-process-string) + (send-string proc "\n")))) + (while (and ange-ftp-process-busy + (string-match "\n" ange-ftp-process-string)) + (let ((line (substring ange-ftp-process-string + 0 + (match-beginning 0)))) + (setq ange-ftp-process-string (substring ange-ftp-process-string + (match-end 0))) + (while (string-match "^ftp> *" line) + (setq line (substring line (match-end 0)))) + (ange-ftp-process-handle-line line proc))) + + ;; has the ftp client finished? if so then do some clean-up + ;; actions. + (if (not ange-ftp-process-busy) + (progn + ;; reset the xfer size + (setq ange-ftp-xfer-size 0) + + ;; issue the "done" message since we've finished. + (if (and ange-ftp-process-msg + ange-ftp-process-verbose + ange-ftp-process-result) + (progn + (ange-ftp-message "%s...done" ange-ftp-process-msg) + (ange-ftp-repaint-minibuffer) + (setq ange-ftp-process-msg nil))) + + ;; is there a continuation we should be calling? if so, + ;; we'd better call it, making sure we only call it once. + (if ange-ftp-process-continue + (let ((cont ange-ftp-process-continue)) + (setq ange-ftp-process-continue nil) + (ange-ftp-call-cont cont + ange-ftp-process-result + ange-ftp-process-result-line)))))) + (set-buffer old-buffer))))) + +(defun ange-ftp-process-sentinel (proc str) + "When ftp process changes state, nuke all file-entries in cache." + (let ((name (process-name proc))) + (if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name) + (let ((user (substring name (match-beginning 1) (match-end 1))) + (host (substring name (match-beginning 2) (match-end 2)))) + (ange-ftp-wipe-file-entries host user)))) + (setq ange-ftp-ls-cache-file nil)) + +;;;; ------------------------------------------------------------ +;;;; Gateway support. +;;;; ------------------------------------------------------------ + +(defun ange-ftp-use-gateway-p (host) + "Returns whether to access this host via a normal (non-smart) gateway." + ;; yes, I know that I could simplify the following expression, but it is + ;; clearer (to me at least) this way. + (and (not ange-ftp-smart-gateway) + (save-match-data + (not (string-match ange-ftp-local-host-regexp host))))) + +(defun ange-ftp-use-smart-gateway-p (host) + "Returns whether to access this host via a smart gateway." + (and ange-ftp-smart-gateway + (save-match-data + (not (string-match ange-ftp-local-host-regexp host))))) + + +;;; ------------------------------------------------------------ +;;; Temporary file location and deletion... +;;; ------------------------------------------------------------ + +(defun ange-ftp-make-tmp-name (host) + "This routine will return the name of a new file." + (make-temp-file (if (ange-ftp-use-gateway-p host) + ange-ftp-gateway-tmp-name-template + ange-ftp-tmp-name-template))) + +(defalias 'ange-ftp-del-tmp-name 'delete-file) + +;;;; ------------------------------------------------------------ +;;;; Interactive gateway program support. +;;;; ------------------------------------------------------------ + +(defvar ange-ftp-gwp-running t) +(defvar ange-ftp-gwp-status nil) + +(defun ange-ftp-gwp-sentinel (proc str) + (setq ange-ftp-gwp-running nil)) + +(defun ange-ftp-gwp-filter (proc str) + (comint-output-filter proc str) + (save-excursion + (set-buffer (process-buffer proc)) + ;; Replace STR by the result of the comint processing. + (setq str (buffer-substring comint-last-output-start (process-mark proc)))) + (cond ((string-match "login: *$" str) + (send-string proc + (concat + (let ((ange-ftp-default-user t)) + (ange-ftp-get-user ange-ftp-gateway-host)) + "\n"))) + ((string-match "Password: *$" str) + (send-string proc + (concat + (ange-ftp-get-passwd ange-ftp-gateway-host + (ange-ftp-get-user + ange-ftp-gateway-host)) + "\n"))) + ((string-match ange-ftp-gateway-fatal-msgs str) + (delete-process proc) + (setq ange-ftp-gwp-running nil)) + ((string-match ange-ftp-gateway-prompt-pattern str) + (setq ange-ftp-gwp-running nil + ange-ftp-gwp-status t)))) + +(defun ange-ftp-gwp-start (host user name args) + "Login to the gateway machine and fire up an ftp process." + (let* ((gw-user (ange-ftp-get-user ange-ftp-gateway-host)) + ;; It would be nice to make process-connection-type nil, + ;; but that doesn't work: ftp never responds. + ;; Can anyone find a fix for that? + (proc (let ((process-connection-type t)) + (start-process name name + ange-ftp-gateway-program + ange-ftp-gateway-host))) + (ftp (mapconcat (function identity) args " "))) + (process-kill-without-query proc) + (set-process-sentinel proc (function ange-ftp-gwp-sentinel)) + (set-process-filter proc (function ange-ftp-gwp-filter)) + (save-excursion + (set-buffer (process-buffer proc)) + (goto-char (point-max)) + (set-marker (process-mark proc) (point))) + (setq ange-ftp-gwp-running t + ange-ftp-gwp-status nil) + (ange-ftp-message "Connecting to gateway %s..." ange-ftp-gateway-host) + (while ange-ftp-gwp-running ;perform login sequence + (accept-process-output proc)) + (if (not ange-ftp-gwp-status) + (ange-ftp-error host user "unable to login to gateway")) + (ange-ftp-message "Connecting to gateway %s...done" ange-ftp-gateway-host) + (setq ange-ftp-gwp-running t + ange-ftp-gwp-status nil) + (process-send-string proc ange-ftp-gateway-setup-term-command) + (while ange-ftp-gwp-running ;zap ^M's and double echoing. + (accept-process-output proc)) + (if (not ange-ftp-gwp-status) + (ange-ftp-error host user "unable to set terminal modes on gateway")) + (setq ange-ftp-gwp-running t + ange-ftp-gwp-status nil) + (process-send-string proc (concat "exec " ftp "\n")) ;spawn ftp process + proc)) + +;;;; ------------------------------------------------------------ +;;;; Support for sending commands to the ftp process. +;;;; ------------------------------------------------------------ + +(defun ange-ftp-raw-send-cmd (proc cmd &optional msg cont nowait) + "Low-level routine to send the given ftp CMD to the ftp PROCESS. +MSG is an optional message to output before and after the command. +If CONT is non-nil then it is either a function or a list of function and +some arguments. The function will be called when the ftp command has completed. +If CONT is nil then this routine will return \( RESULT . LINE \) where RESULT +is whether the command was successful, and LINE is the line from the FTP +process that caused the command to complete. +If NOWAIT is given then the routine will return immediately the command has +been queued with no result. CONT will still be called, however." + (if (memq (process-status proc) '(run open)) + (save-excursion + (set-buffer (process-buffer proc)) + (ange-ftp-wait-not-busy proc) + (setq ange-ftp-process-string "" + ange-ftp-process-result-line "" + ange-ftp-process-busy t + ange-ftp-process-result nil + ange-ftp-process-multi-skip nil + ange-ftp-process-msg msg + ange-ftp-process-continue cont + ange-ftp-hash-mark-count 0 + ange-ftp-last-percent -1 + cmd (concat cmd "\n")) + (and msg ange-ftp-process-verbose (ange-ftp-message "%s..." msg)) + (goto-char (point-max)) + (move-marker comint-last-input-start (point)) + ;; don't insert the password into the buffer on the USER command. + (save-match-data + (if (string-match "^user \"[^\"]*\"" cmd) + (insert (substring cmd 0 (match-end 0)) " Turtle Power!\n") + (insert cmd))) + (move-marker comint-last-input-end (point)) + (send-string proc cmd) + (set-marker (process-mark proc) (point)) + (if nowait + nil + (ange-ftp-wait-not-busy proc) + (if cont + nil ;cont has already been called + (cons ange-ftp-process-result ange-ftp-process-result-line)))))) + +;; Wait for the ange-ftp process PROC not to be busy. +(defun ange-ftp-wait-not-busy (proc) + (save-excursion + (set-buffer (process-buffer proc)) + (condition-case nil + ;; This is a kludge to let user quit in case ftp gets hung. + ;; It matters because this function can be called from the filter. + ;; It is bad to allow quitting in a filter, but getting hung + ;; is worse. By binding quit-flag to nil, we might avoid + ;; most of the probability of getting screwed because the user + ;; wants to quit some command. + (let ((quit-flag nil) + (inhibit-quit nil)) + (while ange-ftp-process-busy + (accept-process-output proc))) + (quit + ;; If the user does quit out of this, + ;; kill the process. That stops any transfer in progress. + ;; The next operation will open a new ftp connection. + (delete-process proc) + (signal 'quit nil))))) + +(defun ange-ftp-nslookup-host (host) + "Attempt to resolve the given HOSTNAME using nslookup if possible." + (interactive "sHost: ") + (if ange-ftp-nslookup-program + (let ((default-directory + (if (file-accessible-directory-p default-directory) + default-directory + exec-directory)) + ;; It would be nice to make process-connection-type nil, + ;; but that doesn't work: ftp never responds. + ;; Can anyone find a fix for that? + (proc (let ((process-connection-type t)) + (start-process " *nslookup*" " *nslookup*" + ange-ftp-nslookup-program host))) + (res host)) + (process-kill-without-query proc) + (save-excursion + (set-buffer (process-buffer proc)) + (while (memq (process-status proc) '(run open)) + (accept-process-output proc)) + (goto-char (point-min)) + (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t) + (setq res (buffer-substring (match-beginning 1) + (match-end 1)))) + (kill-buffer (current-buffer))) + res) + host)) + +(defun ange-ftp-start-process (host user name) + "Spawn a new ftp process ready to connect to machine HOST and give it NAME. +If HOST is only ftp-able through a gateway machine then spawn a shell +on the gateway machine to do the ftp instead." + (let* ((use-gateway (ange-ftp-use-gateway-p host)) + (use-smart-ftp (and (not ange-ftp-gateway-host) + (ange-ftp-use-smart-gateway-p host))) + (ftp-prog (if (or use-gateway + use-smart-ftp) + ange-ftp-gateway-ftp-program-name + ange-ftp-ftp-program-name)) + (args (append (list ftp-prog) ange-ftp-ftp-program-args)) + ;; Without the following binding, ange-ftp-start-process + ;; recurses on file-accessible-directory-p, since it needs to + ;; restart its process in order to determine anything about + ;; default-directory. + (file-name-handler-alist) + (default-directory + (if (file-accessible-directory-p default-directory) + default-directory + exec-directory)) + proc) + ;; It would be nice to make process-connection-type nil, + ;; but that doesn't work: ftp never responds. + ;; Can anyone find a fix for that? + (let ((process-connection-type t) + (process-environment process-environment) + (buffer (get-buffer-create name))) + (save-excursion + (set-buffer buffer) + (internal-ange-ftp-mode)) + ;; This tells GNU ftp not to output any fancy escape sequences. + (setenv "TERM" "dumb") + (if use-gateway + (if ange-ftp-gateway-program-interactive + (setq proc (ange-ftp-gwp-start host user name args)) + (setq proc (apply 'start-process name name + (append (list ange-ftp-gateway-program + ange-ftp-gateway-host) + args)))) + (setq proc (apply 'start-process name name args)))) + (save-excursion + (set-buffer (process-buffer proc)) + (goto-char (point-max)) + (set-marker (process-mark proc) (point))) + (process-kill-without-query proc) + (set-process-sentinel proc (function ange-ftp-process-sentinel)) + (set-process-filter proc (function ange-ftp-process-filter)) + ;; On Windows, the standard ftp client buffers its output (because + ;; stdout is a pipe handle) so the startup message may never appear: + ;; `accept-process-output' at this point would hang indefinitely. + ;; However, sending an innocuous command ("help foo") forces some + ;; output that will be ignored, which is just as good. Once we + ;; start sending normal commands, the output no longer appears to be + ;; buffered, and everything works correctly. My guess is that the + ;; output of interest is being sent to stderr which is not buffered. + (when (eq system-type 'windows-nt) + ;; force ftp output to be treated as DOS text, otherwise the + ;; output of "help foo" confuses the EOL detection logic. + (set-process-coding-system proc 'raw-text-dos) + (process-send-string proc "help foo\n")) + (accept-process-output proc) ;wait for ftp startup message + proc)) + +(put 'internal-ange-ftp-mode 'mode-class 'special) + +(defun internal-ange-ftp-mode () + "Major mode for interacting with the FTP process. + +\\{comint-mode-map}" + (interactive) + (comint-mode) + (setq major-mode 'internal-ange-ftp-mode) + (setq mode-name "Internal Ange-ftp") + (let ((proc (get-buffer-process (current-buffer)))) + (make-local-variable 'ange-ftp-process-string) + (setq ange-ftp-process-string "") + (make-local-variable 'ange-ftp-process-busy) + (make-local-variable 'ange-ftp-process-result) + (make-local-variable 'ange-ftp-process-msg) + (make-local-variable 'ange-ftp-process-multi-skip) + (make-local-variable 'ange-ftp-process-result-line) + (make-local-variable 'ange-ftp-process-continue) + (make-local-variable 'ange-ftp-hash-mark-count) + (make-local-variable 'ange-ftp-binary-hash-mark-size) + (make-local-variable 'ange-ftp-ascii-hash-mark-size) + (make-local-variable 'ange-ftp-hash-mark-unit) + (make-local-variable 'ange-ftp-xfer-size) + (make-local-variable 'ange-ftp-last-percent) + (setq ange-ftp-hash-mark-count 0) + (setq ange-ftp-xfer-size 0) + (setq ange-ftp-process-result-line "") + + (setq comint-prompt-regexp "^ftp> ") + (make-local-variable 'comint-password-prompt-regexp) + ;; This is a regexp that can't match anything. + ;; ange-ftp has its own ways of handling passwords. + (setq comint-password-prompt-regexp "^a\\'z") + (make-local-variable 'paragraph-start) + (setq paragraph-start comint-prompt-regexp))) + +(defun ange-ftp-smart-login (host user pass account proc) + "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT. +PROC is the FTP-client's process. This routine uses the smart-gateway +host specified in ``ange-ftp-gateway-host''." + (let ((result (ange-ftp-raw-send-cmd + proc + (format "open %s %s" + (ange-ftp-nslookup-host ange-ftp-gateway-host) + ange-ftp-smart-gateway-port) + (format "Opening FTP connection to %s via %s" + host + ange-ftp-gateway-host)))) + (or (car result) + (ange-ftp-error host user + (concat "OPEN request failed: " + (cdr result)))) + (setq result (ange-ftp-raw-send-cmd + proc (format "user \"%s\"@%s %s %s" + user + (ange-ftp-nslookup-host host) + pass + account) + (format "Logging in as user %s@%s" + user host))) + (or (car result) + (progn + (ange-ftp-set-passwd host user nil) ; reset password + (ange-ftp-set-account host user nil) ; reset account + (ange-ftp-error host user + (concat "USER request failed: " + (cdr result))))))) + +(defun ange-ftp-normal-login (host user pass account proc) + "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT. +PROC is the process to the FTP-client. HOST may have an optional +suffix of the form #PORT to specify a non-default port" + (save-match-data + (string-match "^\\([^#]+\\)\\(#\\([0-9]+\\)\\)?\\'" host) + (let* ((nshost (ange-ftp-nslookup-host (match-string 1 host))) + (port (match-string 3 host)) + (result (ange-ftp-raw-send-cmd + proc + (if port + (format "open %s %s" nshost port) + (format "open %s" nshost)) + (format "Opening FTP connection to %s" host)))) + (or (car result) + (ange-ftp-error host user + (concat "OPEN request failed: " + (cdr result)))) + (setq result (ange-ftp-raw-send-cmd + proc + (if (and (ange-ftp-use-smart-gateway-p host) + ange-ftp-gateway-host) + (format "user \"%s\"@%s %s %s" user nshost pass account) + (format "user \"%s\" %s %s" user pass account)) + (format "Logging in as user %s@%s" user host))) + (or (car result) + (progn + (ange-ftp-set-passwd host user nil) ;reset password. + (ange-ftp-set-account host user nil) ;reset account. + (ange-ftp-error host user + (concat "USER request failed: " + (cdr result)))))))) + +;; ange@hplb.hpl.hp.com says this should not be changed. +(defvar ange-ftp-hash-mark-msgs + "[hH]ash mark [^0-9]*\\([0-9]+\\)" + "*Regexp matching the FTP client's output upon doing a HASH command.") + +(defun ange-ftp-guess-hash-mark-size (proc) + (if ange-ftp-send-hash + (save-excursion + (set-buffer (process-buffer proc)) + (let* ((status (ange-ftp-raw-send-cmd proc "hash")) + (result (car status)) + (line (cdr status))) + (save-match-data + (if (string-match ange-ftp-hash-mark-msgs line) + (let ((size (string-to-int + (substring line + (match-beginning 1) + (match-end 1))))) + (setq ange-ftp-ascii-hash-mark-size size + ange-ftp-hash-mark-unit (ash size -4)) + + ;; if a default value for this is set, use that value. + (or ange-ftp-binary-hash-mark-size + (setq ange-ftp-binary-hash-mark-size size))))))))) + +(defun ange-ftp-get-process (host user) + "Return an FTP subprocess connected to HOST and logged in as USER. +Create a new process if needed." + (let* ((name (ange-ftp-ftp-process-buffer host user)) + (proc (get-process name))) + (if (and proc (memq (process-status proc) '(run open))) + proc + ;; Must delete dead process so that new process can reuse the name. + (if proc (delete-process proc)) + (let ((pass (ange-ftp-quote-string + (ange-ftp-get-passwd host user))) + (account (ange-ftp-quote-string + (ange-ftp-get-account host user)))) + ;; grab a suitable process. + (setq proc (ange-ftp-start-process host user name)) + + ;; login to FTP server. + (if (and (ange-ftp-use-smart-gateway-p host) + ange-ftp-gateway-host) + (ange-ftp-smart-login host user pass account proc) + (ange-ftp-normal-login host user pass account proc)) + + ;; Tell client to send back hash-marks as progress. It isn't usually + ;; fatal if this command fails. + (ange-ftp-guess-hash-mark-size proc) + + ;; Guess at the host type. + (ange-ftp-guess-host-type host user) + + ;; Try to use passive mode if asked to. + (when ange-ftp-try-passive-mode + (let ((answer (cdr (ange-ftp-raw-send-cmd + proc "passive" "Trying passive mode..." nil)))) + (if (string-match "\\?\\|refused" answer) + (message "Trying passive mode...ok") + (message "Trying passive mode...failed")))) + + ;; Run any user-specified hooks. Note that proc, host and user are + ;; dynamically bound at this point. + (run-hooks 'ange-ftp-process-startup-hook)) + proc))) + +;; Variables for caching host and host-type +(defvar ange-ftp-host-cache nil) +(defvar ange-ftp-host-type-cache nil) + +;; If ange-ftp-host-type is called with the optional user +;; argument, it will attempt to guess the host type by connecting +;; as user, if necessary. For efficiency, I have tried to give this +;; optional second argument only when necessary. Have I missed any calls +;; to ange-ftp-host-type where it should have been supplied? + +(defun ange-ftp-host-type (host &optional user) + "Return a symbol which represents the type of the HOST given. +If the optional argument USER is given, attempts to guess the +host-type by logging in as USER." + (cond ((null host) 'unix) + ;; Return `unix' if HOST is nil, since that's the most vanilla + ;; possible return value. + ((eq host ange-ftp-host-cache) + ange-ftp-host-type-cache) + ;; Trigger an ftp connection, in case we need to guess at the host type. + ((and user (ange-ftp-get-process host user) (eq host ange-ftp-host-cache)) + ange-ftp-host-type-cache) + (t + (setq ange-ftp-host-cache host + ange-ftp-host-type-cache + (cond ((ange-ftp-dumb-unix-host host) + 'dumb-unix) + ;; ((and (fboundp 'ange-ftp-vos-host) + ;; (ange-ftp-vos-host host)) + ;; 'vos) + ((and (fboundp 'ange-ftp-vms-host) + (ange-ftp-vms-host host)) + 'vms) + ((and (fboundp 'ange-ftp-mts-host) + (ange-ftp-mts-host host)) + 'mts) + ((and (fboundp 'ange-ftp-cms-host) + (ange-ftp-cms-host host)) + 'cms) + (t + 'unix)))))) + +;; It would be nice to abstract the functions ange-ftp-TYPE-host and +;; ange-ftp-add-TYPE-host. The trick is to abstract these functions +;; without sacrificing speed. Also, having separate variables +;; ange-ftp-TYPE-regexp is more user friendly then requiring the user to +;; set an alist to indicate that a host is of a given type. Even with +;; automatic host type recognition, setting a regexp is still a good idea +;; (for efficiency) if you log into a particular non-UNIX host frequently. + +(defvar ange-ftp-fix-name-func-alist nil + "Alist saying how to convert file name to the host's syntax. +Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine +which can change a UNIX file name into a name more suitable for a host of type +TYPE.") + +(defvar ange-ftp-fix-dir-name-func-alist nil + "Alist saying how to convert directory name to the host's syntax. +Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine +which can change UNIX directory name into a directory name more suitable +for a host of type TYPE.") + +;; *** Perhaps the sense of this variable should be inverted, since there +;; *** is only 1 host type that can take ls-style listing options. +(defvar ange-ftp-dumb-host-types '(dumb-unix) + "List of host types that can't take UNIX ls-style listing options.") + +(defun ange-ftp-send-cmd (host user cmd &optional msg cont nowait) + "Find an ftp process connected to HOST logged in as USER and send it CMD. +MSG is an optional status message to be output before and after issuing the +command. +See the documentation for ange-ftp-raw-send-cmd for a description of CONT +and NOWAIT." + ;; Handle conversion to remote file name syntax and remote ls option + ;; capability. + (let ((cmd0 (car cmd)) + (cmd1 (nth 1 cmd)) + (ange-ftp-this-user user) + (ange-ftp-this-host host) + (ange-ftp-this-msg msg) + cmd2 cmd3 host-type fix-name-func) + + (cond + + ;; pwd case (We don't care what host-type.) + ((null cmd1)) + + ;; cmd == 'dir "remote-name" "local-name" "ls-switches" + ((progn + (setq cmd2 (nth 2 cmd) + host-type (ange-ftp-host-type host user)) + ;; This will trigger an FTP login, if one doesn't exist + (eq cmd0 'dir)) + (setq cmd1 (funcall + (or (cdr (assq host-type ange-ftp-fix-dir-name-func-alist)) + 'identity) + cmd1) + cmd3 (nth 3 cmd)) + ;; Need to deal with the HP-UX ftp bug. This should also allow + ;; us to resolve symlinks to directories on SysV machines. (Sebastian will + ;; be happy.) + (and (eq host-type 'unix) + (string-match "/$" cmd1) + (not (string-match "R" cmd3)) + (setq cmd1 (concat cmd1 "."))) + + ;; If the dir name contains a space, some ftp servers will + ;; refuse to list it. We instead change directory to the + ;; directory in question and ls ".". + (when (string-match " " cmd1) + (ange-ftp-cd host user (nth 1 cmd)) + (setq cmd1 ".")) + + ;; If the remote ls can take switches, put them in + (or (memq host-type ange-ftp-dumb-host-types) + (setq cmd0 'ls + cmd1 (format "\"%s %s\"" cmd3 cmd1)))) + + ;; First argument is the remote name + ((progn + (setq fix-name-func (or (cdr (assq host-type + ange-ftp-fix-name-func-alist)) + 'identity)) + (memq cmd0 '(get delete mkdir rmdir cd))) + (setq cmd1 (funcall fix-name-func cmd1))) + + ;; Second argument is the remote name + ((memq cmd0 '(append put chmod)) + (setq cmd2 (funcall fix-name-func cmd2))) + + ;; Both arguments are remote names + ((eq cmd0 'rename) + (setq cmd1 (funcall fix-name-func cmd1) + cmd2 (funcall fix-name-func cmd2)))) + + ;; Turn the command into one long string + (setq cmd0 (symbol-name cmd0)) + (setq cmd (concat cmd0 + (and cmd1 (concat " " cmd1)) + (and cmd2 (concat " " cmd2)))) + + ;; Actually send the resulting command. + (let (afsc-result + afsc-line) + (ange-ftp-raw-send-cmd + (ange-ftp-get-process host user) + cmd + msg + (list + (function (lambda (result line host user + cmd msg cont nowait) + (or cont + (setq afsc-result result + afsc-line line)) + (if result + (ange-ftp-call-cont cont result line) + (ange-ftp-raw-send-cmd + (ange-ftp-get-process host user) + cmd + msg + (list + (function (lambda (result line cont) + (or cont + (setq afsc-result result + afsc-line line)) + (ange-ftp-call-cont cont result line))) + cont) + nowait)))) + host user cmd msg cont nowait) + nowait) + + (if nowait + nil + (if cont + nil + (cons afsc-result afsc-line)))))) + +;; It might be nice to message users about the host type identified, +;; but there is so much other messaging going on, it would not be +;; seen. No point in slowing things down just so users can read +;; a host type message. + +(defconst ange-ftp-cms-name-template + (concat + "^[-A-Z0-9$*][-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?" + "[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?\\.[0-9][0-9][0-9A-Z]$")) +(defconst ange-ftp-vms-name-template + "^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$") +(defconst ange-ftp-mts-name-template + "^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$") + +(defun ange-ftp-guess-host-type (host user) + "Guess at the the host type of HOST. +Works by doing a pwd and examining the directory syntax." + (let ((host-type (ange-ftp-host-type host)) + (key (concat host "/" user "/~"))) + (if (eq host-type 'unix) + ;; Note that ange-ftp-host-type returns unix as the default value. + (save-match-data + (let* ((result (ange-ftp-get-pwd host user)) + (dir (car result)) + fix-name-func) + (cond ((null dir) + (message "Warning! Unable to get home directory") + (sit-for 1) + (if (string-match + "^450 No current working directory defined$" + (cdr result)) + + ;; We'll assume that if pwd bombs with this + ;; error message, then it's CMS. + (progn + (ange-ftp-add-cms-host host) + (setq ange-ftp-host-cache host + ange-ftp-host-type-cache 'cms)))) + + ;; try for VMS + ((string-match ange-ftp-vms-name-template dir) + (ange-ftp-add-vms-host host) + ;; The add-host functions clear the host type cache. + ;; Therefore, need to set the cache afterwards. + (setq ange-ftp-host-cache host + ange-ftp-host-type-cache 'vms)) + + ;; try for MTS + ((string-match ange-ftp-mts-name-template dir) + (ange-ftp-add-mts-host host) + (setq ange-ftp-host-cache host + ange-ftp-host-type-cache 'mts)) + + ;; try for CMS + ((string-match ange-ftp-cms-name-template dir) + (ange-ftp-add-cms-host host) + (setq ange-ftp-host-cache host + ange-ftp-host-type-cache 'cms)) + + ;; assume UN*X + (t + (setq ange-ftp-host-cache host + ange-ftp-host-type-cache 'unix))) + + ;; Now that we have done a pwd, might as well put it in + ;; the expand-dir hashtable. + (let ((ange-ftp-this-user user) + (ange-ftp-this-host host)) + (setq fix-name-func (cdr (assq ange-ftp-host-type-cache + ange-ftp-fix-name-func-alist))) + (if fix-name-func + (setq dir (funcall fix-name-func dir 'reverse)))) + (ange-ftp-put-hash-entry key dir + ange-ftp-expand-dir-hashtable)))) + + ;; In the special case of CMS make sure that know the + ;; expansion of the home minidisk now, because we will + ;; be doing a lot of cd's. + (if (and (eq host-type 'cms) + (not (ange-ftp-hash-entry-exists-p + key ange-ftp-expand-dir-hashtable))) + (let ((dir (car (ange-ftp-get-pwd host user)))) + (if dir + (ange-ftp-put-hash-entry key (concat "/" dir) + ange-ftp-expand-dir-hashtable) + (message "Warning! Unable to get home directory") + (sit-for 1)))))) + + +;;;; ------------------------------------------------------------ +;;;; Remote file and directory listing support. +;;;; ------------------------------------------------------------ + +;; Returns whether HOST's FTP server doesn't like \'ls\' or \'dir\' commands +;; to take switch arguments. +(defun ange-ftp-dumb-unix-host (host) + (and host ange-ftp-dumb-unix-host-regexp + (save-match-data + (string-match ange-ftp-dumb-unix-host-regexp host)))) + +(defun ange-ftp-add-dumb-unix-host (host) + "Interactively adds a given HOST to ange-ftp-dumb-unix-host-regexp." + (interactive + (list (read-string "Host: " + (let ((name (or (buffer-file-name) default-directory))) + (and name (car (ange-ftp-ftp-name name))))))) + (if (not (ange-ftp-dumb-unix-host host)) + (setq ange-ftp-dumb-unix-host-regexp + (concat "^" (regexp-quote host) "$" + (and ange-ftp-dumb-unix-host-regexp "\\|") + ange-ftp-dumb-unix-host-regexp) + ange-ftp-host-cache nil))) + +(defvar ange-ftp-parse-list-func-alist nil + "Alist saying how to parse directory listings for certain OS types. +Association list of \( TYPE \. FUNC \) pairs. The FUNC is a routine +which can parse the output from a DIR listing for a host of type TYPE.") + +;; With no-error nil, this function returns: +;; an error if file is not an ange-ftp-name +;; (This should never happen.) +;; an error if either the listing is unreadable or there is an ftp error. +;; the listing (a string), if everything works. +;; +;; With no-error t, it returns: +;; an error if not an ange-ftp-name +;; error if listing is unreadable (most likely caused by a slow connection) +;; nil if ftp error (this is because although asking to list a nonexistent +;; directory on a remote unix machine usually (except +;; maybe for dumb hosts) returns an ls error, but no +;; ftp error, if the same is done on a VMS machine, +;; an ftp error is returned. Need to trap the error +;; so we can go on and try to list the parent.) +;; the listing, if everything works. + +;; If WILDCARD is non-nil, then this implements the guts of insert-directory +;; in the wildcard case. Then we make a relative directory listing +;; of FILE within the directory specified by `default-directory'. + +(defvar ange-ftp-before-parse-ls-hook nil + "Normal hook run before parsing the text of an ftp directory listing.") + +(defun ange-ftp-ls (file lsargs parse &optional no-error wildcard) + "Return the output of an `DIR' or `ls' command done over ftp. +FILE is the full name of the remote file, LSARGS is any args to pass to the +`ls' command, and PARSE specifies that the output should be parsed and stored +away in the internal cache." + ;; If parse is t, we assume that file is a directory. i.e. we only parse + ;; full directory listings. + (let* ((ange-ftp-this-file (ange-ftp-expand-file-name file)) + (parsed (ange-ftp-ftp-name ange-ftp-this-file))) + (if parsed + (let* ((host (nth 0 parsed)) + (user (nth 1 parsed)) + (name (ange-ftp-quote-string (nth 2 parsed))) + (key (directory-file-name ange-ftp-this-file)) + (host-type (ange-ftp-host-type host user)) + (dumb (memq host-type ange-ftp-dumb-host-types)) + result + temp + lscmd parse-func) + (if (string-equal name "") + (setq name + (ange-ftp-real-file-name-as-directory + (ange-ftp-expand-dir host user "~")))) + (if (and ange-ftp-ls-cache-file + (string-equal key ange-ftp-ls-cache-file) + ;; Don't care about lsargs for dumb hosts. + (or dumb (string-equal lsargs ange-ftp-ls-cache-lsargs))) + ange-ftp-ls-cache-res + (setq temp (ange-ftp-make-tmp-name host)) + (if wildcard + (progn + (ange-ftp-cd host user (file-name-directory name)) + (setq lscmd (list 'dir file temp lsargs))) + (setq lscmd (list 'dir name temp lsargs))) + (unwind-protect + (if (car (setq result (ange-ftp-send-cmd + host + user + lscmd + (format "Listing %s" + (ange-ftp-abbreviate-filename + ange-ftp-this-file))))) + (save-excursion + (set-buffer (get-buffer-create + ange-ftp-data-buffer-name)) + (erase-buffer) + (if (ange-ftp-real-file-readable-p temp) + (ange-ftp-real-insert-file-contents temp) + (sleep-for ange-ftp-retry-time) + ;wait for file to possibly appear + (if (ange-ftp-real-file-readable-p temp) + ;; Try again. + (ange-ftp-real-insert-file-contents temp) + (ange-ftp-error host user + (format + "list data file %s not readable" + temp)))) + (run-hooks 'ange-ftp-before-parse-ls-hook) + (if parse + (ange-ftp-set-files + ange-ftp-this-file + (if (setq + parse-func + (cdr (assq host-type + ange-ftp-parse-list-func-alist))) + (funcall parse-func) + (ange-ftp-parse-dired-listing lsargs)))) + (setq ange-ftp-ls-cache-file key + ange-ftp-ls-cache-lsargs lsargs + ; For dumb hosts-types this is + ; meaningless but harmless. + ange-ftp-ls-cache-res (buffer-string)) + ;; (kill-buffer (current-buffer)) + ange-ftp-ls-cache-res) + (if no-error + nil + (ange-ftp-error host user + (concat "DIR failed: " (cdr result))))) + (ange-ftp-del-tmp-name temp)))) + (error "Should never happen. Please report. Bug ref. no.: 1")))) + +;;;; ------------------------------------------------------------ +;;;; Directory information caching support. +;;;; ------------------------------------------------------------ + +(defconst ange-ftp-date-regexp + (let* ((l "\\([A-Za-z]\\|[^\0-\177]\\)") + ;; In some locales, month abbreviations are as short as 2 letters, + ;; and they can be padded on the right with spaces. + ;; weiand: changed: month ends with . or , or ., +;;old (month (concat l l "+ *")) + (month (concat l l "+[.]?,? *")) + ;; Recognize any non-ASCII character. + ;; The purpose is to match a Kanji character. + (k "[^\0-\177]") + (s " ") + (mm "[ 0-1][0-9]") + ;; weiand: changed: day ends with . +;;old (dd "[ 0-3][0-9]") + (dd "[ 0-3][0-9][.]?") + (western (concat "\\(" month s dd "\\|" dd s month "\\)")) + (japanese (concat mm k s dd k))) + ;; Require the previous column to end in a digit. + ;; This avoids recognizing `1 may 1997' as a date in the line: + ;; -r--r--r-- 1 may 1997 1168 Oct 19 16:49 README + (concat "[0-9]" s "\\(" western "\\|" japanese "\\)" s)) + "Regular expression to match up to the column before the file name in a +directory listing. This regular expression is designed to recognize dates +regardless of the language.") + +(defvar ange-ftp-add-file-entry-alist nil + "Alist saying how to add file entries on certain OS types. +Association list of pairs \( TYPE \. FUNC \), where FUNC +is a function to be used to add a file entry for the OS TYPE. The +main reason for this alist is to deal with file versions in VMS.") + +(defvar ange-ftp-delete-file-entry-alist nil + "Alist saying how to delete files on certain OS types. +Association list of pairs \( TYPE \. FUNC \), where FUNC +is a function to be used to delete a file entry for the OS TYPE. +The main reason for this alist is to deal with file versions in VMS.") + +(defun ange-ftp-add-file-entry (name &optional dir-p) + "Add a file entry for file NAME, if its directory info exists." + (funcall (or (cdr (assq (ange-ftp-host-type + (car (ange-ftp-ftp-name name))) + ange-ftp-add-file-entry-alist)) + 'ange-ftp-internal-add-file-entry) + name dir-p) + (setq ange-ftp-ls-cache-file nil)) + +(defun ange-ftp-delete-file-entry (name &optional dir-p) + "Delete the file entry for file NAME, if its directory info exists." + (funcall (or (cdr (assq (ange-ftp-host-type + (car (ange-ftp-ftp-name name))) + ange-ftp-delete-file-entry-alist)) + 'ange-ftp-internal-delete-file-entry) + name dir-p) + (setq ange-ftp-ls-cache-file nil)) + +(defmacro ange-ftp-parse-filename () + ;;Extract the filename from the current line of a dired-like listing. + (` (let ((eol (progn (end-of-line) (point)))) + (beginning-of-line) + (if (re-search-forward ange-ftp-date-regexp eol t) + (progn + (skip-chars-forward " ") + (skip-chars-forward "^ " eol) + (skip-chars-forward " " eol) + ;; We bomb on filenames starting with a space. + (buffer-substring (point) eol)))))) + +;; This deals with the F switch. Should also do something about +;; unquoting names obtained with the SysV b switch and the GNU Q +;; switch. See Sebastian's dired-get-filename. + +(defmacro ange-ftp-ls-parser () + ;; Note that switches is dynamically bound. + ;; Meant to be called by ange-ftp-parse-dired-listing + (` (let ((tbl (ange-ftp-make-hashtable)) + (used-F (and (stringp switches) + (string-match "F" switches))) + file-type symlink directory file) + (while (setq file (ange-ftp-parse-filename)) + (beginning-of-line) + (skip-chars-forward "\t 0-9") + (setq file-type (following-char) + directory (eq file-type ?d)) + (if (eq file-type ?l) + (if (string-match " -> " file) + (setq symlink (substring file (match-end 0)) + file (substring file 0 (match-beginning 0))) + ;; Shouldn't happen + (setq symlink "")) + (setq symlink nil)) + ;; Only do a costly regexp search if the F switch was used. + (if (and used-F + (not (string-equal file "")) + (looking-at + ".[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)")) + (let ((socket (eq file-type ?s)) + (executable + (and (not symlink) ; x bits don't mean a thing for symlinks + (string-match "[xst]" + (concat + (buffer-substring + (match-beginning 1) + (match-end 1)) + (buffer-substring + (match-beginning 2) + (match-end 2)) + (buffer-substring + (match-beginning 3) + (match-end 3))))))) + ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX) + ;; and others don't. (sigh...) Beware, that some Unix's don't + ;; seem to believe in the F-switch + (if (or (and symlink (string-match "@$" file)) + (and directory (string-match "/$" file)) + (and executable (string-match "*$" file)) + (and socket (string-match "=$" file))) + (setq file (substring file 0 -1))))) + (ange-ftp-put-hash-entry file (or symlink directory) tbl) + (forward-line 1)) + (ange-ftp-put-hash-entry "." t tbl) + (ange-ftp-put-hash-entry ".." t tbl) + tbl))) + +;;; The dl stuff for descriptive listings + +(defvar ange-ftp-dl-dir-regexp nil + "Regexp matching directories which are listed in dl format. +This regexp should not be anchored with a trailing `$', because it should +match subdirectories as well.") + +(defun ange-ftp-add-dl-dir (dir) + "Interactively adds a DIR to ange-ftp-dl-dir-regexp." + (interactive + (list (read-string "Directory: " + (let ((name (or (buffer-file-name) default-directory))) + (and name (ange-ftp-ftp-name name) + (file-name-directory name)))))) + (if (not (and ange-ftp-dl-dir-regexp + (string-match ange-ftp-dl-dir-regexp dir))) + (setq ange-ftp-dl-dir-regexp + (concat "^" (regexp-quote dir) + (and ange-ftp-dl-dir-regexp "\\|") + ange-ftp-dl-dir-regexp)))) + +(defmacro ange-ftp-dl-parser () + ;; Parse the current buffer, which is assumed to be a descriptive + ;; listing, and return a hashtable. + (` (let ((tbl (ange-ftp-make-hashtable))) + (while (not (eobp)) + (ange-ftp-put-hash-entry + (buffer-substring (point) + (progn + (skip-chars-forward "^ /\n") + (point))) + (eq (following-char) ?/) + tbl) + (forward-line 1)) + (ange-ftp-put-hash-entry "." t tbl) + (ange-ftp-put-hash-entry ".." t tbl) + tbl))) + +;; Parse the current buffer which is assumed to be in a dired-like listing +;; format, and return a hashtable as the result. If the listing is not really +;; a listing, then return nil. + +(defun ange-ftp-parse-dired-listing (&optional switches) + (save-match-data + (cond + ((looking-at "^total [0-9]+$") + (forward-line 1) + ;; Some systems put in a blank line here. + (if (eolp) (forward-line 1)) + (ange-ftp-ls-parser)) + ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") + ;; It's an ls error message. + nil) + ((eobp) ; i.e. (zerop (buffer-size)) + ;; This could be one of: + ;; (1) An Ultrix ls error message + ;; (2) A listing with the A switch of an empty directory + ;; on a machine which doesn't give a total line. + ;; (3) The twilight zone. + ;; We'll assume (1) for now. + nil) + ((re-search-forward ange-ftp-date-regexp nil t) + (beginning-of-line) + (ange-ftp-ls-parser)) + ((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t) + ;; It's a dl listing (I hope). + ;; file is bound by the call to ange-ftp-ls + (ange-ftp-add-dl-dir ange-ftp-this-file) + (beginning-of-line) + (ange-ftp-dl-parser)) + (t nil)))) + +(defun ange-ftp-set-files (directory files) + "For a given DIRECTORY, set or change the associated FILES hashtable." + (and files (ange-ftp-put-hash-entry (file-name-as-directory directory) + files ange-ftp-files-hashtable))) + +(defun ange-ftp-get-files (directory &optional no-error) + "Given a given DIRECTORY, return a hashtable of file entries. +This will give an error or return nil, depending on the value of +NO-ERROR, if a listing for DIRECTORY cannot be obtained." + (setq directory (file-name-as-directory directory)) ;normalize + (or (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable) + (save-match-data + (and (ange-ftp-ls directory + ;; This is an efficiency hack. We try to + ;; anticipate what sort of listing dired + ;; might want, and cache just such a listing. + (if (and (boundp 'dired-actual-switches) + (stringp dired-actual-switches) + ;; We allow the A switch, which lists + ;; all files except "." and "..". + ;; This is OK because we manually + ;; insert these entries + ;; in the hash table. + (string-match + "[aA]" dired-actual-switches) + (string-match + "l" dired-actual-switches) + (not (string-match + "R" dired-actual-switches))) + dired-actual-switches + (if (and (boundp 'dired-listing-switches) + (stringp dired-listing-switches) + (string-match + "[aA]" dired-listing-switches) + (string-match + "l" dired-listing-switches) + (not (string-match + "R" dired-listing-switches))) + dired-listing-switches + "-al")) + t no-error) + (ange-ftp-get-hash-entry + directory ange-ftp-files-hashtable))))) + +;; Given NAME, return the file part that can be used for looking up the +;; file's entry in a hashtable. +(defmacro ange-ftp-get-file-part (name) + (` (let ((file (file-name-nondirectory (, name)))) + (if (string-equal file "") + "." + file)))) + +;; Return whether ange-ftp-file-entry-p and ange-ftp-get-file-entry are +;; allowed to determine if NAME is a sub-directory by listing it directly, +;; rather than listing its parent directory. This is used for efficiency so +;; that a wasted listing is not done: +;; 1. When looking for a .dired file in dired-x.el. +;; 2. The syntax of FILE and DIR make it impossible that FILE could be a valid +;; subdirectory. This is of course an OS dependent judgement. + +(defmacro ange-ftp-allow-child-lookup (dir file) + (` (not + (let* ((efile (, file)) ; expand once. + (edir (, dir)) + (parsed (ange-ftp-ftp-name edir)) + (host-type (ange-ftp-host-type + (car parsed)))) + (or + ;; Deal with dired + (and (boundp 'dired-local-variables-file) ; in the dired-x package + (stringp dired-local-variables-file) + (string-equal dired-local-variables-file efile)) + ;; No dots in dir names in vms. + (and (eq host-type 'vms) + (string-match "\\." efile)) + ;; No subdirs in mts of cms. + (and (memq host-type '(mts cms)) + (not (string-equal "/" (nth 2 parsed))))))))) + +(defun ange-ftp-file-entry-p (name) + "Given NAME, return whether there is a file entry for it." + (let* ((name (directory-file-name name)) + (dir (file-name-directory name)) + (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable)) + (file (ange-ftp-get-file-part name))) + (if ent + (ange-ftp-hash-entry-exists-p file ent) + (or (and (ange-ftp-allow-child-lookup dir file) + (setq ent (ange-ftp-get-files name t)) + ;; Try a child lookup. i.e. try to list file as a + ;; subdirectory of dir. This is a good idea because + ;; we may not have read permission for file's parent. Also, + ;; people tend to work down directory trees anyway. We use + ;; no-error ;; because if file does not exist as a subdir., + ;; then dumb hosts will give an ftp error. Smart unix hosts + ;; will simply send back the ls + ;; error message. + (ange-ftp-get-hash-entry "." ent)) + ;; Child lookup failed, so try the parent. + (let ((table (ange-ftp-get-files dir))) + ;; If the dir doesn't exist, don't use it as a hash table. + (and table + (ange-ftp-hash-entry-exists-p file + table))))))) + +(defun ange-ftp-get-file-entry (name) + "Given NAME, return the given file entry. +The entry will be either t for a directory, nil for a normal file, +or a string for a symlink. If the file isn't in the hashtable, +this also returns nil." + (let* ((name (directory-file-name name)) + (dir (file-name-directory name)) + (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable)) + (file (ange-ftp-get-file-part name))) + (if ent + (ange-ftp-get-hash-entry file ent) + (or (and (ange-ftp-allow-child-lookup dir file) + (setq ent (ange-ftp-get-files name t)) + (ange-ftp-get-hash-entry "." ent)) + ;; i.e. it's a directory by child lookup + (ange-ftp-get-hash-entry file + (ange-ftp-get-files dir)))))) + +(defun ange-ftp-internal-delete-file-entry (name &optional dir-p) + (if dir-p + (progn + (setq name (file-name-as-directory name)) + (ange-ftp-del-hash-entry name ange-ftp-files-hashtable) + (setq name (directory-file-name name)))) + ;; Note that file-name-as-directory followed by directory-file-name + ;; serves to canonicalize directory file names to their unix form. + ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO + (let ((files (ange-ftp-get-hash-entry (file-name-directory name) + ange-ftp-files-hashtable))) + (if files + (ange-ftp-del-hash-entry (ange-ftp-get-file-part name) + files)))) + +(defun ange-ftp-internal-add-file-entry (name &optional dir-p) + (and dir-p + (setq name (directory-file-name name))) + (let ((files (ange-ftp-get-hash-entry (file-name-directory name) + ange-ftp-files-hashtable))) + (if files + (ange-ftp-put-hash-entry (ange-ftp-get-file-part name) + dir-p + files)))) + +(defun ange-ftp-wipe-file-entries (host user) + "Get rid of entry for HOST, USER pair from file entry information hashtable." + (let ((new-tbl (ange-ftp-make-hashtable (length ange-ftp-files-hashtable)))) + (ange-ftp-map-hashtable + (function + (lambda (key val) + (let ((parsed (ange-ftp-ftp-name key))) + (if parsed + (let ((h (nth 0 parsed)) + (u (nth 1 parsed))) + (or (and (equal host h) (equal user u)) + (ange-ftp-put-hash-entry key val new-tbl))))))) + ange-ftp-files-hashtable) + (setq ange-ftp-files-hashtable new-tbl))) + +;;;; ------------------------------------------------------------ +;;;; File transfer mode support. +;;;; ------------------------------------------------------------ + +(defun ange-ftp-set-binary-mode (host user) + "Tell the ftp process for the given HOST & USER to switch to binary mode." + (let ((result (ange-ftp-send-cmd host user '(type "binary")))) + (if (not (car result)) + (ange-ftp-error host user (concat "BINARY failed: " (cdr result))) + (save-excursion + (set-buffer (process-buffer (ange-ftp-get-process host user))) + (and ange-ftp-binary-hash-mark-size + (setq ange-ftp-hash-mark-unit + (ash ange-ftp-binary-hash-mark-size -4))))))) + +(defun ange-ftp-set-ascii-mode (host user) + "Tell the ftp process for the given HOST & USER to switch to ascii mode." + (let ((result (ange-ftp-send-cmd host user '(type "ascii")))) + (if (not (car result)) + (ange-ftp-error host user (concat "ASCII failed: " (cdr result))) + (save-excursion + (set-buffer (process-buffer (ange-ftp-get-process host user))) + (and ange-ftp-ascii-hash-mark-size + (setq ange-ftp-hash-mark-unit + (ash ange-ftp-ascii-hash-mark-size -4))))))) + +(defun ange-ftp-cd (host user dir) + (let ((result (ange-ftp-send-cmd host user (list 'cd dir) "Doing CD"))) + (or (car result) + (ange-ftp-error host user (concat "CD failed: " (cdr result)))))) + +(defun ange-ftp-get-pwd (host user) + "Attempts to get the current working directory for the given HOST/USER pair. +Returns \( DIR . LINE \) where DIR is either the directory or nil if not found, +and LINE is the relevant success or fail line from the FTP-client." + (let* ((result (ange-ftp-send-cmd host user '(pwd) "Getting PWD")) + (line (cdr result)) + dir) + (if (car result) + (save-match-data + (and (or (string-match "\"\\([^\"]*\\)\"" line) + (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers! + (setq dir (substring line + (match-beginning 1) + (match-end 1)))))) + (cons dir line))) + +;;; ------------------------------------------------------------ +;;; expand-file-name and friends...which currently don't work +;;; ------------------------------------------------------------ + +(defun ange-ftp-expand-dir (host user dir) + "Return the result of doing a PWD in the current FTP session. +Use the connection to machine HOST +logged in as user USER and cd'd to directory DIR." + (let* ((host-type (ange-ftp-host-type host user)) + ;; It is more efficient to call ange-ftp-host-type + ;; before binding res, because ange-ftp-host-type sometimes + ;; adds to the info in the expand-dir-hashtable. + (fix-name-func + (cdr (assq host-type ange-ftp-fix-name-func-alist))) + (key (concat host "/" user "/" dir)) + (res (ange-ftp-get-hash-entry key ange-ftp-expand-dir-hashtable))) + (or res + (progn + (or + (string-equal user "anonymous") + (string-equal user "ftp") + (not (eq host-type 'unix)) + (let* ((ange-ftp-good-msgs (concat ange-ftp-expand-dir-regexp + "\\|" + ange-ftp-good-msgs)) + (result (ange-ftp-send-cmd host user + (list 'get dir null-device) + (format "expanding %s" dir))) + (line (cdr result))) + (setq res + (if (string-match ange-ftp-expand-dir-regexp line) + (substring line + (match-beginning 1) + (match-end 1)))))) + (or res + (if (string-equal dir "~") + (setq res (car (ange-ftp-get-pwd host user))) + (let ((home (ange-ftp-expand-dir host user "~"))) + (unwind-protect + (and (ange-ftp-cd host user dir) + (setq res (car (ange-ftp-get-pwd host user)))) + (ange-ftp-cd host user home))))) + (if res + (let ((ange-ftp-this-user user) + (ange-ftp-this-host host)) + (if fix-name-func + (setq res (funcall fix-name-func res 'reverse))) + (ange-ftp-put-hash-entry + key res ange-ftp-expand-dir-hashtable))) + res)))) + +(defun ange-ftp-canonize-filename (n) + "Take a string and short-circuit //, /. and /.." + (if (string-match "[^:]+//" n) ;don't upset Apollo users + (setq n (substring n (1- (match-end 0))))) + (let ((parsed (ange-ftp-ftp-name n))) + (if parsed + (let ((host (car parsed)) + (user (nth 1 parsed)) + (name (nth 2 parsed))) + + ;; See if remote name is absolute. If so then just expand it and + ;; replace the name component of the overall name. + (cond ((string-match "^/" name) + name) + + ;; Name starts with ~ or ~user. Resolve that part of the name + ;; making it absolute then re-expand it. + ((string-match "^~[^/]*" name) + (let* ((tilda (substring name + (match-beginning 0) + (match-end 0))) + (rest (substring name (match-end 0))) + (dir (ange-ftp-expand-dir host user tilda))) + (if dir + (setq name (concat dir rest)) + (error "User \"%s\" is not known" + (substring tilda 1))))) + + ;; relative name. Tack on homedir and re-expand. + (t + (let ((dir (ange-ftp-expand-dir host user "~"))) + (if dir + (setq name (concat + (ange-ftp-real-file-name-as-directory dir) + name)) + (error "Unable to obtain CWD"))))) + + ;; If name starts with //, preserve that, for apollo system. + (if (not (string-match "^//" name)) + (progn + (if (not (eq system-type 'windows-nt)) + (setq name (ange-ftp-real-expand-file-name name)) + ;; Windows UNC default dirs do not make sense for ftp. + (if (string-match "^//" default-directory) + (setq name (ange-ftp-real-expand-file-name name "c:/")) + (setq name (ange-ftp-real-expand-file-name name))) + ;; Strip off possible drive specifier. + (if (string-match "^[a-zA-Z]:" name) + (setq name (substring name 2)))) + (if (string-match "^//" name) + (setq name (substring name 1))))) + + ;; Now substitute the expanded name back into the overall filename. + (ange-ftp-replace-name-component n name)) + + ;; non-ange-ftp name. Just expand normally. + (if (eq (string-to-char n) ?/) + (ange-ftp-real-expand-file-name n) + (ange-ftp-real-expand-file-name + (ange-ftp-real-file-name-nondirectory n) + (ange-ftp-real-file-name-directory n)))))) + +(defun ange-ftp-expand-file-name (name &optional default) + "Documented as original." + (save-match-data + (setq default (or default default-directory)) + (cond ((eq (string-to-char name) ?~) + (ange-ftp-real-expand-file-name name)) + ((eq (string-to-char name) ?/) + (ange-ftp-canonize-filename name)) + ((and (eq system-type 'windows-nt) + (eq (string-to-char name) ?\\)) + (ange-ftp-canonize-filename name)) + ((and (eq system-type 'windows-nt) + (or (string-match "^[a-zA-Z]:" name) + (string-match "^[a-zA-Z]:" default))) + (ange-ftp-real-expand-file-name name default)) + ((zerop (length name)) + (ange-ftp-canonize-filename default)) + ((ange-ftp-canonize-filename + (concat (file-name-as-directory default) name)))))) + +;;; These are problems--they are currently not enabled. + +(defvar ange-ftp-file-name-as-directory-alist nil + "Association list of \( TYPE \. FUNC \) pairs. +FUNC converts a filename to a directory name for the operating +system TYPE.") + +(defun ange-ftp-file-name-as-directory (name) + "Documented as original." + (let ((parsed (ange-ftp-ftp-name name))) + (if parsed + (if (string-equal (nth 2 parsed) "") + name + (funcall (or (cdr (assq + (ange-ftp-host-type (car parsed)) + ange-ftp-file-name-as-directory-alist)) + 'ange-ftp-real-file-name-as-directory) + name)) + (ange-ftp-real-file-name-as-directory name)))) + +(defun ange-ftp-file-name-directory (name) + "Documented as original." + (let ((parsed (ange-ftp-ftp-name name))) + (if parsed + (let ((filename (nth 2 parsed))) + (if (save-match-data + (string-match "^~[^/]*$" filename)) + name + (ange-ftp-replace-name-component + name + (ange-ftp-real-file-name-directory filename)))) + (ange-ftp-real-file-name-directory name)))) + +(defun ange-ftp-file-name-nondirectory (name) + "Documented as original." + (let ((parsed (ange-ftp-ftp-name name))) + (if parsed + (let ((filename (nth 2 parsed))) + (if (save-match-data + (string-match "^~[^/]*$" filename)) + "" + (ange-ftp-real-file-name-nondirectory filename))) + (ange-ftp-real-file-name-nondirectory name)))) + +(defun ange-ftp-directory-file-name (dir) + "Documented as original." + (let ((parsed (ange-ftp-ftp-name dir))) + (if parsed + (ange-ftp-replace-name-component + dir + (ange-ftp-real-directory-file-name (nth 2 parsed))) + (ange-ftp-real-directory-file-name dir)))) + + +;;; Hooks that handle Emacs primitives. + +;; Returns non-nil if should transfer FILE in binary mode. +(defun ange-ftp-binary-file (file) + (save-match-data + (string-match ange-ftp-binary-file-name-regexp file))) + +(defun ange-ftp-write-region (start end filename &optional append visit) + (setq filename (expand-file-name filename)) + (let ((parsed (ange-ftp-ftp-name filename))) + (if parsed + (let* ((host (nth 0 parsed)) + (user (nth 1 parsed)) + (name (ange-ftp-quote-string (nth 2 parsed))) + (temp (ange-ftp-make-tmp-name host)) + ;; What we REALLY need here is a way to determine if the mode + ;; of the transfer is irrelevant, i.e. we can use binary mode + ;; regardless. Maybe a system-type to host-type lookup? + (binary (or (ange-ftp-binary-file filename) + (memq (ange-ftp-host-type host user) + '(unix dumb-unix)))) + (cmd (if append 'append 'put)) + (abbr (ange-ftp-abbreviate-filename filename)) + ;; we need to reset `last-coding-system-used' to its + ;; value immediately after calling the real write-region, + ;; so that `basic-save-buffer' doesn't see whatever value + ;; might be used when communicating with the ftp process. + (coding-system-used last-coding-system-used)) + (unwind-protect + (progn + (let ((executing-kbd-macro t) + (filename (buffer-file-name)) + (mod-p (buffer-modified-p))) + (unwind-protect + (ange-ftp-real-write-region start end temp nil visit) + ;; cleanup forms + (setq buffer-file-name filename) + (set-buffer-modified-p mod-p))) + ;; save value used by the real write-region + (setq coding-system-used last-coding-system-used) + (if binary + (ange-ftp-set-binary-mode host user)) + + ;; tell the process filter what size the transfer will be. + (let ((attr (file-attributes temp))) + (if attr + (ange-ftp-set-xfer-size host user (nth 7 attr)))) + + ;; put or append the file. + (let ((result (ange-ftp-send-cmd host user + (list cmd temp name) + (format "Writing %s" abbr)))) + (or (car result) + (signal 'ftp-error + (list + "Opening output file" + (format "FTP Error: \"%s\"" (cdr result)) + filename))))) + (ange-ftp-del-tmp-name temp) + (if binary + (ange-ftp-set-ascii-mode host user))) + (if (eq visit t) + (progn + (set-visited-file-modtime '(0 0)) + (ange-ftp-set-buffer-mode) + (setq buffer-file-name filename) + (set-buffer-modified-p nil))) + ;; ensure `last-coding-system-used' has an appropriate value + (setq last-coding-system-used coding-system-used) + (ange-ftp-message "Wrote %s" abbr) + (ange-ftp-add-file-entry filename)) + (ange-ftp-real-write-region start end filename append visit)))) + +(defun ange-ftp-insert-file-contents (filename &optional visit beg end replace) + (barf-if-buffer-read-only) + (setq filename (expand-file-name filename)) + (let ((parsed (ange-ftp-ftp-name filename))) + (if parsed + (progn + (if visit + (setq buffer-file-name filename)) + (if (or (file-exists-p filename) + (progn + (setq ange-ftp-ls-cache-file nil) + (ange-ftp-del-hash-entry (file-name-directory filename) + ange-ftp-files-hashtable) + (file-exists-p filename))) + (let* ((host (nth 0 parsed)) + (user (nth 1 parsed)) + (name (ange-ftp-quote-string (nth 2 parsed))) + (temp (ange-ftp-make-tmp-name host)) + (binary (or (ange-ftp-binary-file filename) + (memq (ange-ftp-host-type host user) + '(unix dumb-unix)))) + (abbr (ange-ftp-abbreviate-filename filename)) + (coding-system-used last-coding-system-used) + size) + (unwind-protect + (progn + (if binary + (ange-ftp-set-binary-mode host user)) + (let ((result (ange-ftp-send-cmd host user + (list 'get name temp) + (format "Retrieving %s" abbr)))) + (or (car result) + (signal 'ftp-error + (list + "Opening input file" + (format "FTP Error: \"%s\"" (cdr result)) + filename)))) + (if (or (ange-ftp-real-file-readable-p temp) + (sleep-for ange-ftp-retry-time) + ;; Wait for file to hopefully appear. + (ange-ftp-real-file-readable-p temp)) + (setq + size + (nth 1 (ange-ftp-real-insert-file-contents + temp visit beg end replace)) + coding-system-used last-coding-system-used + ;; override autodetection of buffer file type + ;; to ensure buffer is saved in DOS format + buffer-file-type binary) + (signal 'ftp-error + (list + "Opening input file:" + (format + "FTP Error: %s not arrived or readable" + filename))))) + (if binary + ;; We must keep `last-coding-system-used' + ;; unchanged. + (let (last-coding-system-used) + (ange-ftp-set-ascii-mode host user))) + (ange-ftp-del-tmp-name temp)) + (if visit + (progn + (set-visited-file-modtime '(0 0)) + (setq buffer-file-name filename))) + (setq last-coding-system-used coding-system-used) + (list filename size)) + (signal 'file-error + (list + "Opening input file" + filename)))) + (ange-ftp-real-insert-file-contents filename visit beg end replace)))) + +(defun ange-ftp-expand-symlink (file dir) + (if (file-name-absolute-p file) + (ange-ftp-replace-name-component dir file) + (expand-file-name file dir))) + +(defun ange-ftp-file-symlink-p (file) + ;; call ange-ftp-expand-file-name rather than the normal + ;; expand-file-name to stop loops when using a package that + ;; redefines both file-symlink-p and expand-file-name. + (setq file (ange-ftp-expand-file-name file)) + (if (ange-ftp-ftp-name file) + (let ((file-ent + (ange-ftp-get-hash-entry + (ange-ftp-get-file-part file) + (ange-ftp-get-files (file-name-directory file))))) + (if (stringp file-ent) + (if (file-name-absolute-p file-ent) + (ange-ftp-replace-name-component + (file-name-directory file) file-ent) + file-ent))) + (ange-ftp-real-file-symlink-p file))) + +(defun ange-ftp-file-exists-p (name) + (setq name (expand-file-name name)) + (if (ange-ftp-ftp-name name) + (if (ange-ftp-file-entry-p name) + (let ((file-ent (ange-ftp-get-file-entry name))) + (if (stringp file-ent) + (file-exists-p + (ange-ftp-expand-symlink file-ent + (file-name-directory + (directory-file-name name)))) + t))) + (ange-ftp-real-file-exists-p name))) + +(defun ange-ftp-file-directory-p (name) + (setq name (expand-file-name name)) + (if (ange-ftp-ftp-name name) + ;; We do a file-name-as-directory on name here because some + ;; machines (VMS) use a .DIR to indicate the filename associated + ;; with a directory. This needs to be canonicalized. + (let ((file-ent (ange-ftp-get-file-entry + (ange-ftp-file-name-as-directory name)))) + (if (stringp file-ent) + (file-directory-p + (ange-ftp-expand-symlink file-ent + (file-name-directory + (directory-file-name name)))) + file-ent)) + (ange-ftp-real-file-directory-p name))) + +(defun ange-ftp-directory-files (directory &optional full match + &rest v19-args) + (setq directory (expand-file-name directory)) + (if (ange-ftp-ftp-name directory) + (progn + (ange-ftp-barf-if-not-directory directory) + (let ((tail (ange-ftp-hash-table-keys + (ange-ftp-get-files directory))) + files f) + (setq directory (file-name-as-directory directory)) + (save-match-data + (while tail + (setq f (car tail) + tail (cdr tail)) + (if (or (not match) (string-match match f)) + (setq files + (cons (if full (concat directory f) f) files))))) + (nreverse files))) + (apply 'ange-ftp-real-directory-files directory full match v19-args))) + +(defun ange-ftp-file-attributes (file) + (setq file (expand-file-name file)) + (let ((parsed (ange-ftp-ftp-name file))) + (if parsed + (let ((part (ange-ftp-get-file-part file)) + (files (ange-ftp-get-files (file-name-directory file)))) + (if (ange-ftp-hash-entry-exists-p part files) + (let ((host (nth 0 parsed)) + (user (nth 1 parsed)) + (name (nth 2 parsed)) + (dirp (ange-ftp-get-hash-entry part files)) + (inode (ange-ftp-get-hash-entry + file ange-ftp-inodes-hashtable))) + (unless inode + (setq inode ange-ftp-next-inode-number + ange-ftp-next-inode-number (1+ inode)) + (ange-ftp-put-hash-entry file inode ange-ftp-inodes-hashtable)) + (list (if (and (stringp dirp) (file-name-absolute-p dirp)) + (ange-ftp-expand-symlink dirp + (file-name-directory file)) + dirp) ;0 file type + -1 ;1 link count + -1 ;2 uid + -1 ;3 gid + '(0 0) ;4 atime + '(0 0) ;5 mtime + '(0 0) ;6 ctime + -1 ;7 size + (concat (if (stringp dirp) "l" (if dirp "d" "-")) + "?????????") ;8 mode + nil ;9 gid weird + inode ;10 "inode number". + -1 ;11 device number [v19 only] + )))) + (ange-ftp-real-file-attributes file)))) + +(defun ange-ftp-file-writable-p (file) + (setq file (expand-file-name file)) + (if (ange-ftp-ftp-name file) + (or (file-exists-p file) ;guess here for speed + (file-directory-p (file-name-directory file))) + (ange-ftp-real-file-writable-p file))) + +(defun ange-ftp-file-readable-p (file) + (setq file (expand-file-name file)) + (if (ange-ftp-ftp-name file) + (file-exists-p file) + (ange-ftp-real-file-readable-p file))) + +(defun ange-ftp-file-executable-p (file) + (setq file (expand-file-name file)) + (if (ange-ftp-ftp-name file) + (file-exists-p file) + (ange-ftp-real-file-executable-p file))) + +(defun ange-ftp-delete-file (file) + (interactive "fDelete file: ") + (setq file (expand-file-name file)) + (let ((parsed (ange-ftp-ftp-name file))) + (if parsed + (let* ((host (nth 0 parsed)) + (user (nth 1 parsed)) + (name (ange-ftp-quote-string (nth 2 parsed))) + (abbr (ange-ftp-abbreviate-filename file)) + (result (ange-ftp-send-cmd host user + (list 'delete name) + (format "Deleting %s" abbr)))) + (or (car result) + (signal 'ftp-error + (list + "Removing old name" + (format "FTP Error: \"%s\"" (cdr result)) + file))) + (ange-ftp-delete-file-entry file)) + (ange-ftp-real-delete-file file)))) + +(defun ange-ftp-verify-visited-file-modtime (buf) + (let ((name (buffer-file-name buf))) + (if (and (stringp name) (ange-ftp-ftp-name name)) + t + (ange-ftp-real-verify-visited-file-modtime buf)))) + +;;;; ------------------------------------------------------------ +;;;; File copying support... totally re-written 6/24/92. +;;;; ------------------------------------------------------------ + +(defun ange-ftp-barf-or-query-if-file-exists (absname querystring interactive) + (if (file-exists-p absname) + (if (not interactive) + (signal 'file-already-exists (list absname)) + (if (not (yes-or-no-p (format "File %s already exists; %s anyway? " + absname querystring))) + (signal 'file-already-exists (list absname)))))) + +;; async local copy commented out for now since I don't seem to get +;; the process sentinel called for some processes. +;; +;; (defun ange-ftp-copy-file-locally (filename newname ok-if-already-exists +;; keep-date cont) +;; "Kludge to copy a local file and call a continuation when the copy +;; finishes." +;; ;; check to see if we can overwrite +;; (if (or (not ok-if-already-exists) +;; (numberp ok-if-already-exists)) +;; (ange-ftp-barf-or-query-if-file-exists newname "copy to it" +;; (numberp ok-if-already-exists))) +;; (let ((proc (start-process " *copy*" +;; (generate-new-buffer "*copy*") +;; "cp" +;; filename +;; newname)) +;; res) +;; (set-process-sentinel proc (function ange-ftp-copy-file-locally-sentinel)) +;; (process-kill-without-query proc) +;; (save-excursion +;; (set-buffer (process-buffer proc)) +;; (make-variable-buffer-local 'copy-cont) +;; (setq copy-cont cont)))) +;; +;; (defun ange-ftp-copy-file-locally-sentinel (proc status) +;; (save-excursion +;; (set-buffer (process-buffer proc)) +;; (let ((cont copy-cont) +;; (result (buffer-string))) +;; (unwind-protect +;; (if (and (string-equal status "finished\n") +;; (zerop (length result))) +;; (ange-ftp-call-cont cont t nil) +;; (ange-ftp-call-cont cont +;; nil +;; (if (zerop (length result)) +;; (substring status 0 -1) +;; (substring result 0 -1)))) +;; (kill-buffer (current-buffer)))))) + +;; this is the extended version of ange-ftp-copy-file-internal that works +;; asynchronously if asked nicely. +(defun ange-ftp-copy-file-internal (filename newname ok-if-already-exists + keep-date &optional msg cont nowait) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + + ;; canonicalize newname if a directory. + (if (file-directory-p newname) + (setq newname (expand-file-name (file-name-nondirectory filename) newname))) + + (let ((f-parsed (ange-ftp-ftp-name filename)) + (t-parsed (ange-ftp-ftp-name newname))) + + ;; local file to local file copy? + (if (and (not f-parsed) (not t-parsed)) + (progn + (ange-ftp-real-copy-file filename newname ok-if-already-exists + keep-date) + (if cont + (ange-ftp-call-cont cont t "Copied locally"))) + ;; one or both files are remote. + (let* ((f-host (and f-parsed (nth 0 f-parsed))) + (f-user (and f-parsed (nth 1 f-parsed))) + (f-name (and f-parsed (ange-ftp-quote-string (nth 2 f-parsed)))) + (f-abbr (ange-ftp-abbreviate-filename filename)) + (t-host (and t-parsed (nth 0 t-parsed))) + (t-user (and t-parsed (nth 1 t-parsed))) + (t-name (and t-parsed (ange-ftp-quote-string (nth 2 t-parsed)))) + (t-abbr (ange-ftp-abbreviate-filename newname filename)) + (binary (or (ange-ftp-binary-file filename) + (ange-ftp-binary-file newname) + (and (memq (ange-ftp-host-type f-host f-user) + '(unix dumb-unix)) + (memq (ange-ftp-host-type t-host t-user) + '(unix dumb-unix))))) + temp1 + temp2) + + ;; check to see if we can overwrite + (if (or (not ok-if-already-exists) + (numberp ok-if-already-exists)) + (ange-ftp-barf-or-query-if-file-exists newname "copy to it" + (numberp ok-if-already-exists))) + + ;; do the copying. + (if f-parsed + + ;; filename was remote. + (progn + (if (or (ange-ftp-use-gateway-p f-host) + t-parsed) + ;; have to use intermediate file if we are getting via + ;; gateway machine or we are doing a remote to remote copy. + (setq temp1 (ange-ftp-make-tmp-name f-host))) + + (if binary + (ange-ftp-set-binary-mode f-host f-user)) + + (ange-ftp-send-cmd + f-host + f-user + (list 'get f-name (or temp1 (ange-ftp-quote-string newname))) + (or msg + (if (and temp1 t-parsed) + (format "Getting %s" f-abbr) + (format "Copying %s to %s" f-abbr t-abbr))) + (list (function ange-ftp-cf1) + filename newname binary msg + f-parsed f-host f-user f-name f-abbr + t-parsed t-host t-user t-name t-abbr + temp1 temp2 cont nowait) + nowait)) + + ;; filename wasn't remote. newname must be remote. call the + ;; function which does the remainder of the copying work. + (ange-ftp-cf1 t nil + filename newname binary msg + f-parsed f-host f-user f-name f-abbr + t-parsed t-host t-user t-name t-abbr + nil nil cont nowait)))))) + +(defvar ange-ftp-waiting-flag nil) + +;; next part of copying routine. +(defun ange-ftp-cf1 (result line + filename newname binary msg + f-parsed f-host f-user f-name f-abbr + t-parsed t-host t-user t-name t-abbr + temp1 temp2 cont nowait) + (if line + ;; filename must have been remote, and we must have just done a GET. + (unwind-protect + (or result + ;; GET failed for some reason. Clean up and get out. + (progn + (and temp1 (ange-ftp-del-tmp-name temp1)) + (or cont + (if ange-ftp-waiting-flag + (throw 'ftp-error t) + (signal 'ftp-error + (list "Opening input file" + (format "FTP Error: \"%s\"" line) + filename)))))) + ;; cleanup + (if binary + (ange-ftp-set-ascii-mode f-host f-user)))) + + (if result + ;; We now have to copy either temp1 or filename to newname. + (if t-parsed + + ;; newname was remote. + (progn + (if (ange-ftp-use-gateway-p t-host) + (setq temp2 (ange-ftp-make-tmp-name t-host))) + + ;; make sure data is moved into the right place for the + ;; outgoing transfer. gateway temporary files complicate + ;; things nicely. + (if temp1 + (if temp2 + (if (string-equal temp1 temp2) + (setq temp1 nil) + (ange-ftp-real-copy-file temp1 temp2 t)) + (setq temp2 temp1 temp1 nil)) + (if temp2 + (ange-ftp-real-copy-file filename temp2 t))) + + (if binary + (ange-ftp-set-binary-mode t-host t-user)) + + ;; tell the process filter what size the file is. + (let ((attr (file-attributes (or temp2 filename)))) + (if attr + (ange-ftp-set-xfer-size t-host t-user (nth 7 attr)))) + + (ange-ftp-send-cmd + t-host + t-user + (list 'put (or temp2 filename) t-name) + (or msg + (if (and temp2 f-parsed) + (format "Putting %s" newname) + (format "Copying %s to %s" f-abbr t-abbr))) + (list (function ange-ftp-cf2) + newname t-host t-user binary temp1 temp2 cont) + nowait)) + + ;; newname wasn't remote. + (ange-ftp-cf2 t nil newname t-host t-user binary temp1 temp2 cont)) + + ;; first copy failed, tell caller + (ange-ftp-call-cont cont result line))) + +;; last part of copying routine. +(defun ange-ftp-cf2 (result line newname t-host t-user binary temp1 temp2 cont) + (unwind-protect + (if line + ;; result from doing a local to remote copy. + (unwind-protect + (progn + (or result + (or cont + (if ange-ftp-waiting-flag + (throw 'ftp-error t) + (signal 'ftp-error + (list "Opening output file" + (format "FTP Error: \"%s\"" line) + newname))))) + + (ange-ftp-add-file-entry newname)) + + ;; cleanup. + (if binary + (ange-ftp-set-ascii-mode t-host t-user))) + + ;; newname was local. + (if temp1 + (ange-ftp-real-copy-file temp1 newname t))) + + ;; clean up + (and temp1 (ange-ftp-del-tmp-name temp1)) + (and temp2 (ange-ftp-del-tmp-name temp2)) + (ange-ftp-call-cont cont result line))) + +(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists + keep-date) + (interactive "fCopy file: \nFCopy %s to file: \np") + (ange-ftp-copy-file-internal filename + newname + ok-if-already-exists + keep-date + nil + nil + (interactive-p))) + +;;;; ------------------------------------------------------------ +;;;; File renaming support. +;;;; ------------------------------------------------------------ + +(defun ange-ftp-rename-remote-to-remote (filename newname f-parsed t-parsed) + "Rename remote file FILE to remote file NEWNAME." + (let ((f-host (nth 0 f-parsed)) + (f-user (nth 1 f-parsed)) + (t-host (nth 0 t-parsed)) + (t-user (nth 1 t-parsed))) + (if (and (string-equal f-host t-host) + (string-equal f-user t-user)) + (let* ((f-name (ange-ftp-quote-string (nth 2 f-parsed))) + (t-name (ange-ftp-quote-string (nth 2 t-parsed))) + (cmd (list 'rename f-name t-name)) + (fabbr (ange-ftp-abbreviate-filename filename)) + (nabbr (ange-ftp-abbreviate-filename newname filename)) + (result (ange-ftp-send-cmd f-host f-user cmd + (format "Renaming %s to %s" + fabbr + nabbr)))) + (or (car result) + (signal 'ftp-error + (list + "Renaming" + (format "FTP Error: \"%s\"" (cdr result)) + filename + newname))) + (ange-ftp-add-file-entry newname) + (ange-ftp-delete-file-entry filename)) + (ange-ftp-copy-file-internal filename newname t nil) + (delete-file filename)))) + +(defun ange-ftp-rename-local-to-remote (filename newname) + "Rename local FILENAME to remote file NEWNAME." + (let* ((fabbr (ange-ftp-abbreviate-filename filename)) + (nabbr (ange-ftp-abbreviate-filename newname filename)) + (msg (format "Renaming %s to %s" fabbr nabbr))) + (ange-ftp-copy-file-internal filename newname t nil msg) + (let (ange-ftp-process-verbose) + (delete-file filename)))) + +(defun ange-ftp-rename-remote-to-local (filename newname) + "Rename remote file FILENAME to local file NEWNAME." + (let* ((fabbr (ange-ftp-abbreviate-filename filename)) + (nabbr (ange-ftp-abbreviate-filename newname filename)) + (msg (format "Renaming %s to %s" fabbr nabbr))) + (ange-ftp-copy-file-internal filename newname t nil msg) + (let (ange-ftp-process-verbose) + (delete-file filename)))) + +(defun ange-ftp-rename-file (filename newname &optional ok-if-already-exists) + (interactive "fRename file: \nFRename %s to file: \np") + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + (let* ((f-parsed (ange-ftp-ftp-name filename)) + (t-parsed (ange-ftp-ftp-name newname))) + (if (and (or f-parsed t-parsed) + (or (not ok-if-already-exists) + (numberp ok-if-already-exists))) + (ange-ftp-barf-or-query-if-file-exists + newname + "rename to it" + (numberp ok-if-already-exists))) + (if f-parsed + (if t-parsed + (ange-ftp-rename-remote-to-remote filename newname f-parsed + t-parsed) + (ange-ftp-rename-remote-to-local filename newname)) + (if t-parsed + (ange-ftp-rename-local-to-remote filename newname) + (ange-ftp-real-rename-file filename newname ok-if-already-exists))))) + +;;;; ------------------------------------------------------------ +;;;; File name completion support. +;;;; ------------------------------------------------------------ + +;; If the file entry SYM is a symlink, returns whether its file exists. +;; Note that `ange-ftp-this-dir' is used as a free variable. +(defun ange-ftp-file-entry-active-p (sym) + (let ((val (get sym 'val))) + (or (not (stringp val)) + (file-exists-p (ange-ftp-expand-symlink val ange-ftp-this-dir))))) + +;; If the file entry is not a directory (nor a symlink pointing to a directory) +;; returns whether the file (or file pointed to by the symlink) is ignored +;; by completion-ignored-extensions. +;; Note that `ange-ftp-this-dir' and `ange-ftp-completion-ignored-pattern' +;; are used as free variables. +(defun ange-ftp-file-entry-not-ignored-p (sym) + (let ((val (get sym 'val)) + (symname (symbol-name sym))) + (if (stringp val) + (let ((file (ange-ftp-expand-symlink val ange-ftp-this-dir))) + (or (file-directory-p file) + (and (file-exists-p file) + (not (string-match ange-ftp-completion-ignored-pattern + symname))))) + (or val ; is a directory name + (not (string-match ange-ftp-completion-ignored-pattern symname)))))) + +(defun ange-ftp-file-name-all-completions (file dir) + (let ((ange-ftp-this-dir (expand-file-name dir))) + (if (ange-ftp-ftp-name ange-ftp-this-dir) + (progn + (ange-ftp-barf-if-not-directory ange-ftp-this-dir) + (setq ange-ftp-this-dir + (ange-ftp-real-file-name-as-directory ange-ftp-this-dir)) + (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir)) + (completions + (all-completions file tbl + (function ange-ftp-file-entry-active-p)))) + + ;; see whether each matching file is a directory or not... + (mapcar + (function + (lambda (file) + (let ((ent (ange-ftp-get-hash-entry file tbl))) + (if (and ent + (or (not (stringp ent)) + (file-directory-p + (ange-ftp-expand-symlink ent + ange-ftp-this-dir)))) + (concat file "/") + file)))) + completions))) + + (if (or (and (eq system-type 'windows-nt) + (string-match "^[a-zA-Z]:[/\\]$" ange-ftp-this-dir)) + (string-equal "/" ange-ftp-this-dir)) + (nconc (all-completions file (ange-ftp-generate-root-prefixes)) + (ange-ftp-real-file-name-all-completions file + ange-ftp-this-dir)) + (ange-ftp-real-file-name-all-completions file ange-ftp-this-dir))))) + +(defun ange-ftp-file-name-completion (file dir) + (let ((ange-ftp-this-dir (expand-file-name dir))) + (if (ange-ftp-ftp-name ange-ftp-this-dir) + (progn + (ange-ftp-barf-if-not-directory ange-ftp-this-dir) + (if (equal file "") + "" + (setq ange-ftp-this-dir + (ange-ftp-real-file-name-as-directory ange-ftp-this-dir)) ;real? + (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir)) + (ange-ftp-completion-ignored-pattern + (mapconcat (function + (lambda (s) (if (stringp s) + (concat (regexp-quote s) "$") + "/"))) ; / never in filename + completion-ignored-extensions + "\\|"))) + (save-match-data + (or (ange-ftp-file-name-completion-1 + file tbl ange-ftp-this-dir + (function ange-ftp-file-entry-not-ignored-p)) + (ange-ftp-file-name-completion-1 + file tbl ange-ftp-this-dir + (function ange-ftp-file-entry-active-p))))))) + + (if (or (and (eq system-type 'windows-nt) + (string-match "^[a-zA-Z]:[/\\]$" ange-ftp-this-dir)) + (string-equal "/" ange-ftp-this-dir)) + (try-completion + file + (nconc (ange-ftp-generate-root-prefixes) + (mapcar 'list + (ange-ftp-real-file-name-all-completions + file ange-ftp-this-dir)))) + (ange-ftp-real-file-name-completion file ange-ftp-this-dir))))) + + +(defun ange-ftp-file-name-completion-1 (file tbl dir predicate) + (let ((bestmatch (try-completion file tbl predicate))) + (if bestmatch + (if (eq bestmatch t) + (if (file-directory-p (expand-file-name file dir)) + (concat file "/") + t) + (if (and (eq (try-completion bestmatch tbl predicate) t) + (file-directory-p + (expand-file-name bestmatch dir))) + (concat bestmatch "/") + bestmatch))))) + +;; Put these lines uncommmented in your .emacs if you want C-r to refresh +;; ange-ftp's cache whilst doing filename completion. +;; +;;(define-key minibuffer-local-completion-map "\C-r" 'ange-ftp-re-read-dir) +;;(define-key minibuffer-local-must-match-map "\C-r" 'ange-ftp-re-read-dir) + +;; The autoload cookie is to make sure the doc is always available. +;;;###autoload (defalias 'ange-ftp-re-read-dir 'ange-ftp-reread-dir) +;;;###autoload +(defun ange-ftp-reread-dir (&optional dir) + "Reread remote directory DIR to update the directory cache. +The implementation of remote ftp file names caches directory contents +for speed. Therefore, when new remote files are created, Emacs +may not know they exist. You can use this command to reread a specific +directory, so that Emacs will know its current contents." + (interactive) + (if dir + (setq dir (expand-file-name dir)) + (setq dir (file-name-directory (expand-file-name (buffer-string))))) + (if (ange-ftp-ftp-name dir) + (progn + (setq ange-ftp-ls-cache-file nil) + (ange-ftp-del-hash-entry dir ange-ftp-files-hashtable) + (ange-ftp-get-files dir t)))) + +(defun ange-ftp-make-directory (dir &optional parents) + (interactive (list (expand-file-name (read-file-name "Make directory: ")))) + (if parents + (let ((parent (file-name-directory (directory-file-name dir)))) + (or (file-exists-p parent) + (ange-ftp-make-directory parent parents)))) + (if (file-exists-p dir) + (error "Cannot make directory %s: file already exists" dir) + (let ((parsed (ange-ftp-ftp-name dir))) + (if parsed + (let* ((host (nth 0 parsed)) + (user (nth 1 parsed)) + ;; Some ftp's on unix machines (at least on Suns) + ;; insist that mkdir take a filename, and not a + ;; directory-name name as an arg. Argh!! This is a bug. + ;; Non-unix machines will probably always insist + ;; that mkdir takes a directory-name as an arg + ;; (as the ftp man page says it should). + (name (ange-ftp-quote-string + (if (eq (ange-ftp-host-type host) 'unix) + (ange-ftp-real-directory-file-name (nth 2 parsed)) + (ange-ftp-real-file-name-as-directory + (nth 2 parsed))))) + (abbr (ange-ftp-abbreviate-filename dir)) + (result (ange-ftp-send-cmd host user + (list 'mkdir name) + (format "Making directory %s" + abbr)))) + (or (car result) + (ange-ftp-error host user + (format "Could not make directory %s: %s" + dir + (cdr result)))) + (ange-ftp-add-file-entry dir t)) + (ange-ftp-real-make-directory dir))))) + +(defun ange-ftp-delete-directory (dir) + (if (file-directory-p dir) + (let ((parsed (ange-ftp-ftp-name dir))) + (if parsed + (let* ((host (nth 0 parsed)) + (user (nth 1 parsed)) + ;; Some ftp's on unix machines (at least on Suns) + ;; insist that rmdir take a filename, and not a + ;; directory-name name as an arg. Argh!! This is a bug. + ;; Non-unix machines will probably always insist + ;; that rmdir takes a directory-name as an arg + ;; (as the ftp man page says it should). + (name (ange-ftp-quote-string + (if (eq (ange-ftp-host-type host) 'unix) + (ange-ftp-real-directory-file-name + (nth 2 parsed)) + (ange-ftp-real-file-name-as-directory + (nth 2 parsed))))) + (abbr (ange-ftp-abbreviate-filename dir)) + (result (ange-ftp-send-cmd host user + (list 'rmdir name) + (format "Removing directory %s" + abbr)))) + (or (car result) + (ange-ftp-error host user + (format "Could not remove directory %s: %s" + dir + (cdr result)))) + (ange-ftp-delete-file-entry dir t)) + (ange-ftp-real-delete-directory dir))) + (error "Not a directory: %s" dir))) + +;; Make a local copy of FILE and return its name. + +(defun ange-ftp-file-local-copy (file) + (let* ((fn1 (expand-file-name file)) + (pa1 (ange-ftp-ftp-name fn1))) + (if pa1 + (let ((tmp1 (ange-ftp-make-tmp-name (car pa1)))) + (ange-ftp-copy-file-internal fn1 tmp1 t nil + (format "Getting %s" fn1)) + tmp1)))) + +(defun ange-ftp-load (file &optional noerror nomessage nosuffix) + (if (ange-ftp-ftp-name file) + (let ((tryfiles (if nosuffix + (list file) + (list (concat file ".elc") (concat file ".el") file))) + ;; make sure there are no references to temp files + (load-force-doc-strings t) + copy) + (while (and tryfiles (not copy)) + (catch 'ftp-error + (let ((ange-ftp-waiting-flag t)) + (condition-case error + (setq copy (ange-ftp-file-local-copy (car tryfiles))) + (ftp-error nil)))) + (setq tryfiles (cdr tryfiles))) + (if copy + (unwind-protect + (funcall 'load copy noerror nomessage nosuffix) + (delete-file copy)) + (or noerror + (signal 'file-error (list "Cannot open load file" file))) + nil)) + (ange-ftp-real-load file noerror nomessage nosuffix))) + +;; Calculate default-unhandled-directory for a given ange-ftp buffer. +(defun ange-ftp-unhandled-file-name-directory (filename) + (file-name-directory ange-ftp-tmp-name-template)) + + +;; Need the following functions for making filenames of compressed +;; files, because some OS's (unlike UNIX) do not allow a filename to +;; have two extensions. + +(defvar ange-ftp-make-compressed-filename-alist nil + "Alist of host-type-specific functions to process file names for compression. +Each element has the form (TYPE . FUNC). +FUNC should take one argument, a file name, and return a list +of the form (COMPRESSING NEWNAME). +COMPRESSING should be t if the specified file should be compressed, +and nil if it should be uncompressed (that is, if it is a compressed file). +NEWNAME should be the name to give the new compressed or uncompressed file.") + +(defun ange-ftp-dired-compress-file (name) + (let ((parsed (ange-ftp-ftp-name name)) + conversion-func) + (if (and parsed + (setq conversion-func + (cdr (assq (ange-ftp-host-type (car parsed)) + ange-ftp-make-compressed-filename-alist)))) + (let* ((decision + (save-match-data (funcall conversion-func name))) + (compressing (car decision)) + (newfile (nth 1 decision))) + (if compressing + (ange-ftp-compress name newfile) + (ange-ftp-uncompress name newfile))) + (let (file-name-handler-alist) + (dired-compress-file name))))) + +;; Copy FILE to this machine, compress it, and copy out to NFILE. +(defun ange-ftp-compress (file nfile) + (let* ((parsed (ange-ftp-ftp-name file)) + (tmp1 (ange-ftp-make-tmp-name (car parsed))) + (tmp2 (ange-ftp-make-tmp-name (car parsed))) + (abbr (ange-ftp-abbreviate-filename file)) + (nabbr (ange-ftp-abbreviate-filename nfile)) + (msg1 (format "Getting %s" abbr)) + (msg2 (format "Putting %s" nabbr))) + (unwind-protect + (progn + (ange-ftp-copy-file-internal file tmp1 t nil msg1) + (and ange-ftp-process-verbose + (ange-ftp-message "Compressing %s..." abbr)) + (call-process-region (point) + (point) + shell-file-name + nil + t + nil + "-c" + (format "compress -f -c < %s > %s" tmp1 tmp2)) + (and ange-ftp-process-verbose + (ange-ftp-message "Compressing %s...done" abbr)) + (if (zerop (buffer-size)) + (progn + (let (ange-ftp-process-verbose) + (delete-file file)) + (ange-ftp-copy-file-internal tmp2 nfile t nil msg2)))) + (ange-ftp-del-tmp-name tmp1) + (ange-ftp-del-tmp-name tmp2)))) + +;; Copy FILE to this machine, uncompress it, and copy out to NFILE. +(defun ange-ftp-uncompress (file nfile) + (let* ((parsed (ange-ftp-ftp-name file)) + (tmp1 (ange-ftp-make-tmp-name (car parsed))) + (tmp2 (ange-ftp-make-tmp-name (car parsed))) + (abbr (ange-ftp-abbreviate-filename file)) + (nabbr (ange-ftp-abbreviate-filename nfile)) + (msg1 (format "Getting %s" abbr)) + (msg2 (format "Putting %s" nabbr)) +;; ;; Cheap hack because of problems with binary file transfers from +;; ;; VMS hosts. +;; (gbinary (not (eq 'vms (ange-ftp-host-type (car parsed))))) + ) + (unwind-protect + (progn + (ange-ftp-copy-file-internal file tmp1 t nil msg1) + (and ange-ftp-process-verbose + (ange-ftp-message "Uncompressing %s..." abbr)) + (call-process-region (point) + (point) + shell-file-name + nil + t + nil + "-c" + (format "uncompress -c < %s > %s" tmp1 tmp2)) + (and ange-ftp-process-verbose + (ange-ftp-message "Uncompressing %s...done" abbr)) + (if (zerop (buffer-size)) + (progn + (let (ange-ftp-process-verbose) + (delete-file file)) + (ange-ftp-copy-file-internal tmp2 nfile t nil msg2)))) + (ange-ftp-del-tmp-name tmp1) + (ange-ftp-del-tmp-name tmp2)))) + +(defun ange-ftp-find-backup-file-name (fn) + ;; Either return the ordinary backup name, etc., + ;; or return nil meaning don't make a backup. + (if ange-ftp-make-backup-files + (ange-ftp-real-find-backup-file-name fn))) + +;;; Define the handler for special file names +;;; that causes ange-ftp to be invoked. + +;;;###autoload +(defun ange-ftp-hook-function (operation &rest args) + (let ((fn (get operation 'ange-ftp))) + (if fn (apply fn args) + (ange-ftp-run-real-handler operation args)))) + + +;;; This regexp takes care of real ange-ftp file names (with a slash +;;; and colon). +;;; Don't allow the host name to end in a period--some systems use /.: +;;;###autoload +(or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist) + (setq file-name-handler-alist + (cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function) + file-name-handler-alist))) + +;;; This regexp recognizes absolute filenames with only one component, +;;; for the sake of hostname completion. +;;;###autoload +(or (assoc "^/[^/:]*\\'" file-name-handler-alist) + (setq file-name-handler-alist + (cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function) + file-name-handler-alist))) + +;;; This regexp recognizes absolute filenames with only one component +;;; on Windows, for the sake of hostname completion. +;;; NB. Do not mark this as autoload, because it is very common to +;;; do completions in the root directory of drives on Windows. +(and (memq system-type '(ms-dos windows-nt)) + (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist) + (setq file-name-handler-alist + (cons '("^[a-zA-Z]:/[^/:]*\\'" . + ange-ftp-completion-hook-function) + file-name-handler-alist)))) + +;;; The above two forms are sufficient to cause this file to be loaded +;;; if the user ever uses a file name with a colon in it. + +;;; This sets the mode +(or (memq 'ange-ftp-set-buffer-mode find-file-hooks) + (setq find-file-hooks + (cons 'ange-ftp-set-buffer-mode find-file-hooks))) + +;;; Now say where to find the handlers for particular operations. + +(put 'file-name-directory 'ange-ftp 'ange-ftp-file-name-directory) +(put 'file-name-nondirectory 'ange-ftp 'ange-ftp-file-name-nondirectory) +(put 'file-name-as-directory 'ange-ftp 'ange-ftp-file-name-as-directory) +(put 'directory-file-name 'ange-ftp 'ange-ftp-directory-file-name) +(put 'expand-file-name 'ange-ftp 'ange-ftp-expand-file-name) +(put 'make-directory 'ange-ftp 'ange-ftp-make-directory) +(put 'delete-directory 'ange-ftp 'ange-ftp-delete-directory) +(put 'insert-file-contents 'ange-ftp 'ange-ftp-insert-file-contents) +(put 'directory-files 'ange-ftp 'ange-ftp-directory-files) +(put 'file-directory-p 'ange-ftp 'ange-ftp-file-directory-p) +(put 'file-writable-p 'ange-ftp 'ange-ftp-file-writable-p) +(put 'file-readable-p 'ange-ftp 'ange-ftp-file-readable-p) +(put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p) +(put 'file-symlink-p 'ange-ftp 'ange-ftp-file-symlink-p) +(put 'delete-file 'ange-ftp 'ange-ftp-delete-file) +(put 'read-file-name-internal 'ange-ftp 'ange-ftp-read-file-name-internal) +(put 'verify-visited-file-modtime 'ange-ftp + 'ange-ftp-verify-visited-file-modtime) +(put 'file-exists-p 'ange-ftp 'ange-ftp-file-exists-p) +(put 'write-region 'ange-ftp 'ange-ftp-write-region) +(put 'backup-buffer 'ange-ftp 'ange-ftp-backup-buffer) +(put 'copy-file 'ange-ftp 'ange-ftp-copy-file) +(put 'rename-file 'ange-ftp 'ange-ftp-rename-file) +(put 'file-attributes 'ange-ftp 'ange-ftp-file-attributes) +(put 'file-name-all-completions 'ange-ftp 'ange-ftp-file-name-all-completions) +(put 'file-name-completion 'ange-ftp 'ange-ftp-file-name-completion) +(put 'insert-directory 'ange-ftp 'ange-ftp-insert-directory) +(put 'file-local-copy 'ange-ftp 'ange-ftp-file-local-copy) +(put 'unhandled-file-name-directory 'ange-ftp + 'ange-ftp-unhandled-file-name-directory) +(put 'file-name-sans-versions 'ange-ftp 'ange-ftp-file-name-sans-versions) +(put 'dired-uncache 'ange-ftp 'ange-ftp-dired-uncache) +(put 'dired-compress-file 'ange-ftp 'ange-ftp-dired-compress-file) +(put 'load 'ange-ftp 'ange-ftp-load) +(put 'find-backup-file-name 'ange-ftp 'ange-ftp-find-backup-file-name) + +;; Turn off truename processing to save time. +;; Treat each name as its own truename. +(put 'file-truename 'ange-ftp 'identity) + +;; Turn off RCS/SCCS processing to save time. +;; This returns nil for any file name as argument. +(put 'vc-registered 'ange-ftp 'null) + +(put 'dired-call-process 'ange-ftp 'ange-ftp-dired-call-process) +(put 'shell-command 'ange-ftp 'ange-ftp-shell-command) + +;;; Define ways of getting at unmodified Emacs primitives, +;;; turning off our handler. + +(defun ange-ftp-run-real-handler (operation args) + (let ((inhibit-file-name-handlers + (cons 'ange-ftp-hook-function + (cons 'ange-ftp-completion-hook-function + (and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers)))) + (inhibit-file-name-operation operation)) + (apply operation args))) + +(defun ange-ftp-real-file-name-directory (&rest args) + (ange-ftp-run-real-handler 'file-name-directory args)) +(defun ange-ftp-real-file-name-nondirectory (&rest args) + (ange-ftp-run-real-handler 'file-name-nondirectory args)) +(defun ange-ftp-real-file-name-as-directory (&rest args) + (ange-ftp-run-real-handler 'file-name-as-directory args)) +(defun ange-ftp-real-directory-file-name (&rest args) + (ange-ftp-run-real-handler 'directory-file-name args)) +(defun ange-ftp-real-expand-file-name (&rest args) + (ange-ftp-run-real-handler 'expand-file-name args)) +(defun ange-ftp-real-make-directory (&rest args) + (ange-ftp-run-real-handler 'make-directory args)) +(defun ange-ftp-real-delete-directory (&rest args) + (ange-ftp-run-real-handler 'delete-directory args)) +(defun ange-ftp-real-insert-file-contents (&rest args) + (ange-ftp-run-real-handler 'insert-file-contents args)) +(defun ange-ftp-real-directory-files (&rest args) + (ange-ftp-run-real-handler 'directory-files args)) +(defun ange-ftp-real-file-directory-p (&rest args) + (ange-ftp-run-real-handler 'file-directory-p args)) +(defun ange-ftp-real-file-writable-p (&rest args) + (ange-ftp-run-real-handler 'file-writable-p args)) +(defun ange-ftp-real-file-readable-p (&rest args) + (ange-ftp-run-real-handler 'file-readable-p args)) +(defun ange-ftp-real-file-executable-p (&rest args) + (ange-ftp-run-real-handler 'file-executable-p args)) +(defun ange-ftp-real-file-symlink-p (&rest args) + (ange-ftp-run-real-handler 'file-symlink-p args)) +(defun ange-ftp-real-delete-file (&rest args) + (ange-ftp-run-real-handler 'delete-file args)) +(defun ange-ftp-real-read-file-name-internal (&rest args) + (ange-ftp-run-real-handler 'read-file-name-internal args)) +(defun ange-ftp-real-verify-visited-file-modtime (&rest args) + (ange-ftp-run-real-handler 'verify-visited-file-modtime args)) +(defun ange-ftp-real-file-exists-p (&rest args) + (ange-ftp-run-real-handler 'file-exists-p args)) +(defun ange-ftp-real-write-region (&rest args) + (ange-ftp-run-real-handler 'write-region args)) +(defun ange-ftp-real-backup-buffer (&rest args) + (ange-ftp-run-real-handler 'backup-buffer args)) +(defun ange-ftp-real-copy-file (&rest args) + (ange-ftp-run-real-handler 'copy-file args)) +(defun ange-ftp-real-rename-file (&rest args) + (ange-ftp-run-real-handler 'rename-file args)) +(defun ange-ftp-real-file-attributes (&rest args) + (ange-ftp-run-real-handler 'file-attributes args)) +(defun ange-ftp-real-file-name-all-completions (&rest args) + (ange-ftp-run-real-handler 'file-name-all-completions args)) +(defun ange-ftp-real-file-name-completion (&rest args) + (ange-ftp-run-real-handler 'file-name-completion args)) +(defun ange-ftp-real-insert-directory (&rest args) + (ange-ftp-run-real-handler 'insert-directory args)) +(defun ange-ftp-real-file-name-sans-versions (&rest args) + (ange-ftp-run-real-handler 'file-name-sans-versions args)) +(defun ange-ftp-real-shell-command (&rest args) + (ange-ftp-run-real-handler 'shell-command args)) +(defun ange-ftp-real-load (&rest args) + (ange-ftp-run-real-handler 'load args)) +(defun ange-ftp-real-find-backup-file-name (&rest args) + (ange-ftp-run-real-handler 'find-backup-file-name args)) + +;; Here we support using dired on remote hosts. +;; I have turned off the support for using dired on foreign directory formats. +;; That involves too many unclean hooks. +;; It would be cleaner to support such operations by +;; converting the foreign directory format to something dired can understand; +;; something close to ls -l output. +;; The logical place to do this is in the functions ange-ftp-parse-...-listing. + +;; Some of the old dired hooks would still be needed even if this is done. +;; I have preserved (and modernized) those hooks. +;; So the format conversion should be all that is needed. + +(defun ange-ftp-insert-directory (file switches &optional wildcard full) + (let ((short (ange-ftp-abbreviate-filename file)) + (parsed (ange-ftp-ftp-name (expand-file-name file)))) + (if parsed + (insert + (if wildcard + (let ((default-directory (file-name-directory file))) + (ange-ftp-ls (file-name-nondirectory file) switches nil nil t)) + (ange-ftp-ls file switches full))) + (ange-ftp-real-insert-directory file switches wildcard full)))) + +(defun ange-ftp-dired-uncache (dir) + (if (ange-ftp-ftp-name (expand-file-name dir)) + (setq ange-ftp-ls-cache-file nil))) + +(defvar ange-ftp-sans-version-alist nil + "Alist of mapping host type into function to remove file version numbers.") + +(defun ange-ftp-file-name-sans-versions (file keep-backup-version) + (let* ((short (ange-ftp-abbreviate-filename file)) + (parsed (ange-ftp-ftp-name short)) + host-type func) + (if parsed + (setq host-type (ange-ftp-host-type (car parsed)) + func (cdr (assq (ange-ftp-host-type (car parsed)) + ange-ftp-sans-version-alist)))) + (if func (funcall func file keep-backup-version) + (ange-ftp-real-file-name-sans-versions file keep-backup-version)))) + +;; This is the handler for shell-command. +(defun ange-ftp-shell-command (command &optional output-buffer error-buffer) + (let* ((parsed (ange-ftp-ftp-name default-directory)) + (host (nth 0 parsed)) + (user (nth 1 parsed)) + (name (nth 2 parsed))) + (if (not parsed) + (ange-ftp-real-shell-command command output-buffer error-buffer) + (if (> (length name) 0) ; else it's $HOME + (setq command (concat "cd " name "; " command))) + (setq command + (format "%s %s \"%s\"" ; remsh -l USER does not work well + ; on a hp-ux machine I tried + remote-shell-program host command)) + (ange-ftp-message "Remote command '%s' ..." command) + ;; Cannot call ange-ftp-real-dired-run-shell-command here as it + ;; would prepend "cd default-directory" --- which bombs because + ;; default-directory is in ange-ftp syntax for remote file names. + (ange-ftp-real-shell-command command output-buffer error-buffer)))) + +;;; This is the handler for call-process. +(defun ange-ftp-dired-call-process (program discard &rest arguments) + ;; PROGRAM is always one of those below in the cond in dired.el. + ;; The ARGUMENTS are (nearly) always files. + (if (ange-ftp-ftp-name default-directory) + ;; Can't use ange-ftp-dired-host-type here because the current + ;; buffer is *dired-check-process output* + (condition-case oops + (cond ((equal dired-chmod-program program) + (ange-ftp-call-chmod arguments)) + ;; ((equal "chgrp" program)) + ;; ((equal dired-chown-program program)) + (t (error "Unknown remote command: %s" program))) + (ftp-error (insert (format "%s: %s, %s\n" + (nth 1 oops) + (nth 2 oops) + (nth 3 oops))) + ;; Caller expects nonzero value to mean failure. + 1) + (error (insert (format "%s\n" (nth 1 oops))) + 1)) + (apply 'call-process program nil (not discard) nil arguments))) + +(defvar ange-ftp-remote-shell "rsh" + "Remote shell to use for chmod, if FTP server rejects the `chmod' command.") + +;; Handle an attempt to run chmod on a remote file +;; by using the ftp chmod command. +(defun ange-ftp-call-chmod (args) + (if (< (length args) 2) + (error "ange-ftp-call-chmod: missing mode and/or filename: %s" args)) + (let ((mode (car args)) + (rest (cdr args))) + (if (equal "--" (car rest)) + (setq rest (cdr rest))) + (mapcar + (function + (lambda (file) + (setq file (expand-file-name file)) + (let ((parsed (ange-ftp-ftp-name file))) + (if parsed + (let* ((host (nth 0 parsed)) + (user (nth 1 parsed)) + (name (ange-ftp-quote-string (nth 2 parsed))) + (abbr (ange-ftp-abbreviate-filename file)) + (result (ange-ftp-send-cmd host user + (list 'chmod mode name) + (format "doing chmod %s" + abbr)))) + (or (car result) + (call-process + ange-ftp-remote-shell + nil t nil host dired-chmod-program mode name))))))) + rest)) + (setq ange-ftp-ls-cache-file nil) ;Stop confusing Dired. + 0) + +;;; This is turned off because it has nothing properly to do +;;; with dired. It could be reasonable to adapt this to +;;; replace ange-ftp-copy-file. + +;;;;; ------------------------------------------------------------ +;;;;; Noddy support for async copy-file within dired. +;;;;; ------------------------------------------------------------ + +;;(defun ange-ftp-dired-copy-file (from to ok-flag &optional cont nowait) +;; "Documented as original." +;; (dired-handle-overwrite to) +;; (ange-ftp-copy-file-internal from to ok-flag dired-copy-preserve-time nil +;; cont nowait)) + +;;(defun ange-ftp-dired-do-create-files (op-symbol file-creator operation arg +;; &optional marker-char op1 +;; how-to) +;; "Documented as original." +;; ;; we need to let ange-ftp-dired-create-files know that we indirectly +;; ;; called it rather than somebody else. +;; (let ((ange-ftp-dired-do-create-files t)) ; tell who caller is +;; (ange-ftp-real-dired-do-create-files op-symbol file-creator operation +;; arg marker-char op1 how-to))) + +;;(defun ange-ftp-dired-create-files (file-creator operation fn-list name-constructor +;; &optional marker-char) +;; "Documented as original." +;; (if (and (boundp 'ange-ftp-dired-do-create-files) +;; ;; called from ange-ftp-dired-do-create-files? +;; ange-ftp-dired-do-create-files +;; ;; any files worth copying? +;; fn-list +;; ;; we only support async copy-file at the mo. +;; (eq file-creator 'dired-copy-file) +;; ;; it is only worth calling the alternative function for remote files +;; ;; as we tie ourself in recursive knots otherwise. +;; (or (ange-ftp-ftp-name (car fn-list)) +;; ;; we can only call the name constructor for dired-do-create-files +;; ;; since the one for regexps starts prompting here, there and +;; ;; everywhere. +;; (ange-ftp-ftp-name (funcall name-constructor (car fn-list))))) +;; ;; use the process-filter driven routine rather than the iterative one. +;; (ange-ftp-dcf-1 file-creator +;; operation +;; fn-list +;; name-constructor +;; (and (boundp 'target) target) ;dynamically bound +;; marker-char +;; (current-buffer) +;; nil ;overwrite-query +;; nil ;overwrite-backup-query +;; nil ;failures +;; nil ;skipped +;; 0 ;success-count +;; (length fn-list) ;total +;; ) +;; ;; normal case... use the interactive routine... much cheaper. +;; (ange-ftp-real-dired-create-files file-creator operation fn-list +;; name-constructor marker-char))) + +;;(defun ange-ftp-dcf-1 (file-creator operation fn-list name-constructor +;; target marker-char buffer overwrite-query +;; overwrite-backup-query failures skipped +;; success-count total) +;; (let ((old-buf (current-buffer))) +;; (unwind-protect +;; (progn +;; (set-buffer buffer) +;; (if (null fn-list) +;; (ange-ftp-dcf-3 failures operation total skipped +;; success-count buffer) + +;; (let* ((from (car fn-list)) +;; (to (funcall name-constructor from))) +;; (if (equal to from) +;; (progn +;; (setq to nil) +;; (dired-log "Cannot %s to same file: %s\n" +;; (downcase operation) from))) +;; (if (not to) +;; (ange-ftp-dcf-1 file-creator +;; operation +;; (cdr fn-list) +;; name-constructor +;; target +;; marker-char +;; buffer +;; overwrite-query +;; overwrite-backup-query +;; failures +;; (cons (dired-make-relative from) skipped) +;; success-count +;; total) +;; (let* ((overwrite (file-exists-p to)) +;; (overwrite-confirmed ; for dired-handle-overwrite +;; (and overwrite +;; (let ((help-form '(format "\ +;;Type SPC or `y' to overwrite file `%s', +;;DEL or `n' to skip to next, +;;ESC or `q' to not overwrite any of the remaining files, +;;`!' to overwrite all remaining files with no more questions." to))) +;; (dired-query 'overwrite-query +;; "Overwrite `%s'?" to)))) +;; ;; must determine if FROM is marked before file-creator +;; ;; gets a chance to delete it (in case of a move). +;; (actual-marker-char +;; (cond ((integerp marker-char) marker-char) +;; (marker-char (dired-file-marker from)) ; slow +;; (t nil)))) +;; (condition-case err +;; (funcall file-creator from to overwrite-confirmed +;; (list (function ange-ftp-dcf-2) +;; nil ;err +;; file-creator operation fn-list +;; name-constructor +;; target +;; marker-char actual-marker-char +;; buffer to from +;; overwrite +;; overwrite-confirmed +;; overwrite-query +;; overwrite-backup-query +;; failures skipped success-count +;; total) +;; t) +;; (file-error ; FILE-CREATOR aborted +;; (ange-ftp-dcf-2 nil ;result +;; nil ;line +;; err +;; file-creator operation fn-list +;; name-constructor +;; target +;; marker-char actual-marker-char +;; buffer to from +;; overwrite +;; overwrite-confirmed +;; overwrite-query +;; overwrite-backup-query +;; failures skipped success-count +;; total)))))))) +;; (set-buffer old-buf)))) + +;;(defun ange-ftp-dcf-2 (result line err +;; file-creator operation fn-list +;; name-constructor +;; target +;; marker-char actual-marker-char +;; buffer to from +;; overwrite +;; overwrite-confirmed +;; overwrite-query +;; overwrite-backup-query +;; failures skipped success-count +;; total) +;; (let ((old-buf (current-buffer))) +;; (unwind-protect +;; (progn +;; (set-buffer buffer) +;; (if (or err (not result)) +;; (progn +;; (setq failures (cons (dired-make-relative from) failures)) +;; (dired-log "%s `%s' to `%s' failed:\n%s\n" +;; operation from to (or err line))) +;; (if overwrite +;; ;; If we get here, file-creator hasn't been aborted +;; ;; and the old entry (if any) has to be deleted +;; ;; before adding the new entry. +;; (dired-remove-file to)) +;; (setq success-count (1+ success-count)) +;; (message "%s: %d of %d" operation success-count total) +;; (dired-add-file to actual-marker-char)) + +;; (ange-ftp-dcf-1 file-creator operation (cdr fn-list) +;; name-constructor +;; target +;; marker-char +;; buffer +;; overwrite-query +;; overwrite-backup-query +;; failures skipped success-count +;; total)) +;; (set-buffer old-buf)))) + +;;(defun ange-ftp-dcf-3 (failures operation total skipped success-count +;; buffer) +;; (let ((old-buf (current-buffer))) +;; (unwind-protect +;; (progn +;; (set-buffer buffer) +;; (cond +;; (failures +;; (dired-log-summary +;; (message "%s failed for %d of %d file%s %s" +;; operation (length failures) total +;; (dired-plural-s total) failures))) +;; (skipped +;; (dired-log-summary +;; (message "%s: %d of %d file%s skipped %s" +;; operation (length skipped) total +;; (dired-plural-s total) skipped))) +;; (t +;; (message "%s: %s file%s." +;; operation success-count (dired-plural-s success-count)))) +;; (dired-move-to-filename)) +;; (set-buffer old-buf)))) + +;;;; ----------------------------------------------- +;;;; Unix Descriptive Listing (dl) Support +;;;; ----------------------------------------------- + +;; This is turned off because nothing uses it currently +;; and because I don't understand what it's supposed to be for. --rms. + +;;(defconst ange-ftp-dired-dl-re-dir +;; "^. [^ /]+/[ \n]" +;; "Regular expression to use to search for dl directories.") + +;;(or (assq 'unix:dl ange-ftp-dired-re-dir-alist) +;; (setq ange-ftp-dired-re-dir-alist +;; (cons (cons 'unix:dl ange-ftp-dired-dl-re-dir) +;; ange-ftp-dired-re-dir-alist))) + +;;(defun ange-ftp-dired-dl-move-to-filename (&optional raise-error eol) +;; "In dired, move to the first character of the filename on this line." +;; ;; This is the Unix dl version. +;; (or eol (setq eol (progn (end-of-line) (point)))) +;; (let (case-fold-search) +;; (beginning-of-line) +;; (if (looking-at ". [^ ]+ +\\([0-9]+\\|-\\|=\\) ") +;; (goto-char (+ (point) 2)) +;; (if raise-error +;; (error "No file on this line") +;; nil)))) + +;;(or (assq 'unix:dl ange-ftp-dired-move-to-filename-alist) +;; (setq ange-ftp-dired-move-to-filename-alist +;; (cons '(unix:dl . ange-ftp-dired-dl-move-to-filename) +;; ange-ftp-dired-move-to-filename-alist))) + +;;(defun ange-ftp-dired-dl-move-to-end-of-filename (&optional no-error eol) +;; ;; Assumes point is at beginning of filename. +;; ;; So, it should be called only after (dired-move-to-filename t). +;; ;; On failure, signals an error or returns nil. +;; ;; This is the Unix dl version. +;; (let ((opoint (point)) +;; case-fold-search hidden) +;; (or eol (setq eol (save-excursion (end-of-line) (point)))) +;; (setq hidden (and selective-display +;; (save-excursion +;; (search-forward "\r" eol t)))) +;; (if hidden +;; (if no-error +;; nil +;; (error +;; (substitute-command-keys +;; "File line is hidden, type \\[dired-hide-subdir] to unhide"))) +;; (skip-chars-forward "^ /" eol) +;; (if (eq opoint (point)) +;; (if no-error +;; nil +;; (error "No file on this line")) +;; (point))))) + +;;(or (assq 'unix:dl ange-ftp-dired-move-to-end-of-filename-alist) +;; (setq ange-ftp-dired-move-to-end-of-filename-alist +;; (cons '(unix:dl . ange-ftp-dired-dl-move-to-end-of-filename) +;; ange-ftp-dired-move-to-end-of-filename-alist))) + +;;;; ------------------------------------------------------------ +;;;; VOS support (VOS support is probably broken, +;;;; but I don't know anything about VOS.) +;;;; ------------------------------------------------------------ +; +;(defun ange-ftp-fix-name-for-vos (name &optional reverse) +; (setq name (copy-sequence name)) +; (let ((from (if reverse ?\> ?\/)) +; (to (if reverse ?\/ ?\>)) +; (i (1- (length name)))) +; (while (>= i 0) +; (if (= (aref name i) from) +; (aset name i to)) +; (setq i (1- i))) +; name)) +; +;(or (assq 'vos ange-ftp-fix-name-func-alist) +; (setq ange-ftp-fix-name-func-alist +; (cons '(vos . ange-ftp-fix-name-for-vos) +; ange-ftp-fix-name-func-alist))) +; +;(or (memq 'vos ange-ftp-dumb-host-types) +; (setq ange-ftp-dumb-host-types +; (cons 'vos ange-ftp-dumb-host-types))) +; +;(defun ange-ftp-fix-dir-name-for-vos (dir-name) +; (ange-ftp-fix-name-for-vos +; (concat dir-name +; (if (eq ?/ (aref dir-name (1- (length dir-name)))) +; "" "/") +; "*"))) +; +;(or (assq 'vos ange-ftp-fix-dir-name-func-alist) +; (setq ange-ftp-fix-dir-name-func-alist +; (cons '(vos . ange-ftp-fix-dir-name-for-vos) +; ange-ftp-fix-dir-name-func-alist))) +; +;(defvar ange-ftp-vos-host-regexp nil +; "If a host matches this regexp then it is assumed to be running VOS.") +; +;(defun ange-ftp-vos-host (host) +; (and ange-ftp-vos-host-regexp +; (save-match-data +; (string-match ange-ftp-vos-host-regexp host)))) +; +;(defun ange-ftp-parse-vos-listing () +; "Parse the current buffer which is assumed to be in VOS list -all +;format, and return a hashtable as the result." +; (let ((tbl (ange-ftp-make-hashtable)) +; (type-list +; '(("^Files: [0-9]+ +Blocks: [0-9]+\n+" nil 40) +; ("^Dirs: [0-9]+\n+" t 30))) +; type-regexp type-is-dir type-col file) +; (goto-char (point-min)) +; (save-match-data +; (while type-list +; (setq type-regexp (car (car type-list)) +; type-is-dir (nth 1 (car type-list)) +; type-col (nth 2 (car type-list)) +; type-list (cdr type-list)) +; (if (re-search-forward type-regexp nil t) +; (while (eq (char-after (point)) ? ) +; (move-to-column type-col) +; (setq file (buffer-substring (point) +; (progn +; (end-of-line 1) +; (point)))) +; (ange-ftp-put-hash-entry file type-is-dir tbl) +; (forward-line 1)))) +; (ange-ftp-put-hash-entry "." 'vosdir tbl) +; (ange-ftp-put-hash-entry ".." 'vosdir tbl)) +; tbl)) +; +;(or (assq 'vos ange-ftp-parse-list-func-alist) +; (setq ange-ftp-parse-list-func-alist +; (cons '(vos . ange-ftp-parse-vos-listing) +; ange-ftp-parse-list-func-alist))) + +;;;; ------------------------------------------------------------ +;;;; VMS support. +;;;; ------------------------------------------------------------ + +;; Convert NAME from UNIX-ish to VMS. If REVERSE given then convert from VMS +;; to UNIX-ish. +(defun ange-ftp-fix-name-for-vms (name &optional reverse) + (save-match-data + (if reverse + (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name) + (let (drive dir file) + (if (match-beginning 1) + (setq drive (substring name + (match-beginning 1) + (match-end 1)))) + (if (match-beginning 2) + (setq dir + (substring name (match-beginning 2) (match-end 2)))) + (if (match-beginning 3) + (setq file + (substring name (match-beginning 3) (match-end 3)))) + (and dir + (setq dir (apply (function concat) + (mapcar (function + (lambda (char) + (if (= char ?.) + (vector ?/) + (vector char)))) + (substring dir 1 -1))))) + (concat (and drive + (concat "/" drive "/")) + dir (and dir "/") + file)) + (error "name %s didn't match" name)) + (let (drive dir file tmp) + (if (string-match "^/[^:]+:/" name) + (setq drive (substring name 1 + (1- (match-end 0))) + name (substring name (match-end 0)))) + (setq tmp (file-name-directory name)) + (if tmp + (setq dir (apply (function concat) + (mapcar (function + (lambda (char) + (if (= char ?/) + (vector ?.) + (vector char)))) + (substring tmp 0 -1))))) + (setq file (file-name-nondirectory name)) + (concat drive + (and dir (concat "[" (if drive nil ".") dir "]")) + file))))) + +;; (ange-ftp-fix-name-for-vms "/PUB$:/ANONYMOUS/SDSCPUB/NEXT/Readme.txt;1") +;; (ange-ftp-fix-name-for-vms "/PUB$:[ANONYMOUS.SDSCPUB.NEXT]Readme.txt;1" t) + +(or (assq 'vms ange-ftp-fix-name-func-alist) + (setq ange-ftp-fix-name-func-alist + (cons '(vms . ange-ftp-fix-name-for-vms) + ange-ftp-fix-name-func-alist))) + +(or (memq 'vms ange-ftp-dumb-host-types) + (setq ange-ftp-dumb-host-types + (cons 'vms ange-ftp-dumb-host-types))) + +;; It is important that this function barf for directories for which we know +;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/". +;; This is because it saves an unnecessary FTP error, or possibly the listing +;; might succeed, but give erroneous info. This last case is particularly +;; likely for OS's (like MTS) for which we need to use a wildcard in order +;; to list a directory. + +;; Convert name from UNIX-ish to VMS ready for a DIRectory listing. +(defun ange-ftp-fix-dir-name-for-vms (dir-name) + ;; Should there be entries for .. -> [-] and . -> [] below. Don't + ;; think so, because expand-filename should have already short-circuited + ;; them. + (cond ((string-equal dir-name "/") + (error "Cannot get listing for fictitious \"/\" directory.")) + ((string-match "^/[-A-Z0-9_$]+:/$" dir-name) + (error "Cannot get listing for device.")) + ((ange-ftp-fix-name-for-vms dir-name)))) + +(or (assq 'vms ange-ftp-fix-dir-name-func-alist) + (setq ange-ftp-fix-dir-name-func-alist + (cons '(vms . ange-ftp-fix-dir-name-for-vms) + ange-ftp-fix-dir-name-func-alist))) + +(defvar ange-ftp-vms-host-regexp nil) + +;; Return non-nil if HOST is running VMS. +(defun ange-ftp-vms-host (host) + (and ange-ftp-vms-host-regexp + (save-match-data + (string-match ange-ftp-vms-host-regexp host)))) + +;; Because some VMS ftp servers convert filenames to lower case +;; we allow a-z in the filename regexp. I'm not too happy about this. + +(defconst ange-ftp-vms-filename-regexp + (concat + "\\(\\([_A-Za-z0-9$]?\\|[_A-Za-z0-9$][-_A-Za-z0-9$]*\\)\\." + "[-_A-Za-z0-9$]*;+[0-9]*\\)") + "Regular expression to match for a valid VMS file name in Dired buffer. +Stupid freaking bug! Position of _ and $ shouldn't matter but they do. +Having [A-Z0-9$_] bombs on filename _$$CHANGE_LOG$.TXT$ and $CHANGE_LOG$.TX +Other orders of $ and _ seem to all work just fine.") + +;; These parsing functions are as general as possible because the syntax +;; of ftp listings from VMS hosts is a bit erratic. What saves us is that +;; the VMS filename syntax is so rigid. If they bomb on a listing in the +;; standard VMS Multinet format, then this is a bug. If they bomb on a listing +;; from vms.weird.net, then too bad. + +;; Extract the next filename from a VMS dired-like listing. +(defun ange-ftp-parse-vms-filename () + (if (re-search-forward + ange-ftp-vms-filename-regexp + nil t) + (buffer-substring (match-beginning 0) (match-end 0)))) + +;; Parse the current buffer which is assumed to be in MultiNet FTP dir +;; format, and return a hashtable as the result. +(defun ange-ftp-parse-vms-listing () + (let ((tbl (ange-ftp-make-hashtable)) + file) + (goto-char (point-min)) + (save-match-data + (while (setq file (ange-ftp-parse-vms-filename)) + (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file) + ;; deal with directories + (ange-ftp-put-hash-entry + (substring file 0 (match-beginning 0)) t tbl) + (ange-ftp-put-hash-entry file nil tbl) + (if (string-match ";[0-9]+$" file) ; deal with extension + ;; sans extension + (ange-ftp-put-hash-entry + (substring file 0 (match-beginning 0)) nil tbl))) + (forward-line 1)) + ;; Would like to look for a "Total" line, or a "Directory" line to + ;; make sure that the listing isn't complete garbage before putting + ;; in "." and "..", but we can't even count on all VAX's giving us + ;; either of these. + (ange-ftp-put-hash-entry "." t tbl) + (ange-ftp-put-hash-entry ".." t tbl)) + tbl)) + +(or (assq 'vms ange-ftp-parse-list-func-alist) + (setq ange-ftp-parse-list-func-alist + (cons '(vms . ange-ftp-parse-vms-listing) + ange-ftp-parse-list-func-alist))) + +;; This version only deletes file entries which have +;; explicit version numbers, because that is all VMS allows. + +;; Can the following two functions be speeded up using file +;; completion functions? + +(defun ange-ftp-vms-delete-file-entry (name &optional dir-p) + (if dir-p + (ange-ftp-internal-delete-file-entry name t) + (save-match-data + (let ((file (ange-ftp-get-file-part name))) + (if (string-match ";[0-9]+$" file) + ;; In VMS you can't delete a file without an explicit + ;; version number, or wild-card (e.g. FOO;*) + ;; For now, we give up on wildcards. + (let ((files (ange-ftp-get-hash-entry + (file-name-directory name) + ange-ftp-files-hashtable))) + (if files + (let* ((root (substring file 0 + (match-beginning 0))) + (regexp (concat "^" + (regexp-quote root) + ";[0-9]+$")) + versions) + (ange-ftp-del-hash-entry file files) + ;; Now we need to check if there are any + ;; versions left. If not, then delete the + ;; root entry. + (mapatoms + '(lambda (sym) + (and (string-match regexp (get sym 'key)) + (setq versions t))) + files) + (or versions + (ange-ftp-del-hash-entry root files)))))))))) + +(or (assq 'vms ange-ftp-delete-file-entry-alist) + (setq ange-ftp-delete-file-entry-alist + (cons '(vms . ange-ftp-vms-delete-file-entry) + ange-ftp-delete-file-entry-alist))) + +(defun ange-ftp-vms-add-file-entry (name &optional dir-p) + (if dir-p + (ange-ftp-internal-add-file-entry name t) + (let ((files (ange-ftp-get-hash-entry + (file-name-directory name) + ange-ftp-files-hashtable))) + (if files + (let ((file (ange-ftp-get-file-part name))) + (save-match-data + (if (string-match ";[0-9]+$" file) + (ange-ftp-put-hash-entry + (substring file 0 (match-beginning 0)) + nil files) + ;; Need to figure out what version of the file + ;; is being added. + (let ((regexp (concat "^" + (regexp-quote file) + ";\\([0-9]+\\)$")) + (version 0)) + (mapatoms + '(lambda (sym) + (let ((name (get sym 'key))) + (and (string-match regexp name) + (setq version + (max version + (string-to-int + (substring name + (match-beginning 1) + (match-end 1)))))))) + files) + (setq version (1+ version)) + (ange-ftp-put-hash-entry + (concat file ";" (int-to-string version)) + nil files)))) + (ange-ftp-put-hash-entry file nil files)))))) + +(or (assq 'vms ange-ftp-add-file-entry-alist) + (setq ange-ftp-add-file-entry-alist + (cons '(vms . ange-ftp-vms-add-file-entry) + ange-ftp-add-file-entry-alist))) + + +(defun ange-ftp-add-vms-host (host) + "Mark HOST as the name of a machine running VMS." + (interactive + (list (read-string "Host: " + (let ((name (or (buffer-file-name) default-directory))) + (and name (car (ange-ftp-ftp-name name))))))) + (if (not (ange-ftp-vms-host host)) + (setq ange-ftp-vms-host-regexp + (concat "^" (regexp-quote host) "$" + (and ange-ftp-vms-host-regexp "\\|") + ange-ftp-vms-host-regexp) + ange-ftp-host-cache nil))) + + +(defun ange-ftp-vms-file-name-as-directory (name) + (save-match-data + (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name) + (setq name (substring name 0 (match-beginning 0)))) + (ange-ftp-real-file-name-as-directory name))) + +(or (assq 'vms ange-ftp-file-name-as-directory-alist) + (setq ange-ftp-file-name-as-directory-alist + (cons '(vms . ange-ftp-vms-file-name-as-directory) + ange-ftp-file-name-as-directory-alist))) + +;;; Tree dired support: + +;; For this code I have borrowed liberally from Sebastian Kremer's +;; dired-vms.el + + +;;;; These regexps must be anchored to beginning of line. +;;;; Beware that the ftpd may put the device in front of the filename. + +;;(defconst ange-ftp-dired-vms-re-exe "^. [^ \t.]+\\.\\(EXE\\|exe\\)[; ]" +;; "Regular expression to use to search for VMS executable files.") + +;;(defconst ange-ftp-dired-vms-re-dir "^. [^ \t.]+\\.\\(DIR\\|dir\\)[; ]" +;; "Regular expression to use to search for VMS directories.") + +;;(or (assq 'vms ange-ftp-dired-re-exe-alist) +;; (setq ange-ftp-dired-re-exe-alist +;; (cons (cons 'vms ange-ftp-dired-vms-re-exe) +;; ange-ftp-dired-re-exe-alist))) + +;;(or (assq 'vms ange-ftp-dired-re-dir-alist) +;; (setq ange-ftp-dired-re-dir-alist +;; (cons (cons 'vms ange-ftp-dired-vms-re-dir) +;; ange-ftp-dired-re-dir-alist))) + +;;(defun ange-ftp-dired-vms-insert-headerline (dir) +;; ;; VMS inserts a headerline. I would prefer the headerline +;; ;; to be in ange-ftp format. This version tries to +;; ;; be careful, because we can't count on a headerline +;; ;; over ftp, and we wouldn't want to delete anything +;; ;; important. +;; (save-excursion +;; (if (looking-at "^ wildcard ") +;; (forward-line 1)) +;; (if (looking-at "^[ \n\t]*[^\n]+\\][ \t]*\n") +;; (delete-region (point) (match-end 0)))) +;; (ange-ftp-real-dired-insert-headerline dir)) + +;;(or (assq 'vms ange-ftp-dired-insert-headerline-alist) +;; (setq ange-ftp-dired-insert-headerline-alist +;; (cons '(vms . ange-ftp-dired-vms-insert-headerline) +;; ange-ftp-dired-insert-headerline-alist))) + +;;(defun ange-ftp-dired-vms-move-to-filename (&optional raise-error eol) +;; "In dired, move to first char of filename on this line. +;;Returns position (point) or nil if no filename on this line." +;; ;; This is the VMS version. +;; (let (case-fold-search) +;; (or eol (setq eol (progn (end-of-line) (point)))) +;; (beginning-of-line) +;; (if (re-search-forward ange-ftp-vms-filename-regexp eol t) +;; (goto-char (match-beginning 1)) +;; (if raise-error +;; (error "No file on this line") +;; nil)))) + +;;(or (assq 'vms ange-ftp-dired-move-to-filename-alist) +;; (setq ange-ftp-dired-move-to-filename-alist +;; (cons '(vms . ange-ftp-dired-vms-move-to-filename) +;; ange-ftp-dired-move-to-filename-alist))) + +;;(defun ange-ftp-dired-vms-move-to-end-of-filename (&optional no-error eol) +;; ;; Assumes point is at beginning of filename. +;; ;; So, it should be called only after (dired-move-to-filename t). +;; ;; case-fold-search must be nil, at least for VMS. +;; ;; On failure, signals an error or returns nil. +;; ;; This is the VMS version. +;; (let (opoint hidden case-fold-search) +;; (setq opoint (point)) +;; (or eol (setq eol (save-excursion (end-of-line) (point)))) +;; (setq hidden (and selective-display +;; (save-excursion (search-forward "\r" eol t)))) +;; (if hidden +;; nil +;; (re-search-forward ange-ftp-vms-filename-regexp eol t)) +;; (or no-error +;; (not (eq opoint (point))) +;; (error +;; (if hidden +;; (substitute-command-keys +;; "File line is hidden, type \\[dired-hide-subdir] to unhide") +;; "No file on this line"))) +;; (if (eq opoint (point)) +;; nil +;; (point)))) + +;;(or (assq 'vms ange-ftp-dired-move-to-end-of-filename-alist) +;; (setq ange-ftp-dired-move-to-end-of-filename-alist +;; (cons '(vms . ange-ftp-dired-vms-move-to-end-of-filename) +;; ange-ftp-dired-move-to-end-of-filename-alist))) + +;;(defun ange-ftp-dired-vms-between-files () +;; (save-excursion +;; (beginning-of-line) +;; (or (equal (following-char) 10) ; newline +;; (equal (following-char) 9) ; tab +;; (progn (forward-char 2) +;; (or (looking-at "Total of") +;; (equal (following-char) 32)))))) + +;;(or (assq 'vms ange-ftp-dired-between-files-alist) +;; (setq ange-ftp-dired-between-files-alist +;; (cons '(vms . ange-ftp-dired-vms-between-files) +;; ange-ftp-dired-between-files-alist))) + +;; Beware! In VMS filenames must be of the form "FILE.TYPE". +;; Therefore, we cannot just append a ".Z" to filenames for +;; compressed files. Instead, we turn "FILE.TYPE" into +;; "FILE.TYPE-Z". Hope that this is a reasonable thing to do. + +(defun ange-ftp-vms-make-compressed-filename (name &optional reverse) + (cond + ((string-match "-Z;[0-9]+$" name) + (list nil (substring name 0 (match-beginning 0)))) + ((string-match ";[0-9]+$" name) + (list nil (substring name 0 (match-beginning 0)))) + ((string-match "-Z$" name) + (list nil (substring name 0 -2))) + (t + (list t + (if (string-match ";[0-9]+$" name) + (concat (substring name 0 (match-beginning 0)) + "-Z") + (concat name "-Z")))))) + +(or (assq 'vms ange-ftp-make-compressed-filename-alist) + (setq ange-ftp-make-compressed-filename-alist + (cons '(vms . ange-ftp-vms-make-compressed-filename) + ange-ftp-make-compressed-filename-alist))) + +;;;; When the filename is too long, VMS will use two lines to list a file +;;;; (damn them!) This will confuse dired. To solve this, need to convince +;;;; Sebastian to use a function dired-go-to-end-of-file-line, instead of +;;;; (forward-line 1). This would require a number of changes to dired.el. +;;;; If dired gets confused, revert-buffer will fix it. + +;;(defun ange-ftp-dired-vms-ls-trim () +;; (goto-char (point-min)) +;; (let ((case-fold-search nil)) +;; (re-search-forward ange-ftp-vms-filename-regexp)) +;; (beginning-of-line) +;; (delete-region (point-min) (point)) +;; (forward-line 1) +;; (delete-region (point) (point-max))) + + +;;(or (assq 'vms ange-ftp-dired-ls-trim-alist) +;; (setq ange-ftp-dired-ls-trim-alist +;; (cons '(vms . ange-ftp-dired-vms-ls-trim) +;; ange-ftp-dired-ls-trim-alist))) + +(defun ange-ftp-vms-sans-version (name &rest args) + (save-match-data + (if (string-match ";[0-9]+$" name) + (substring name 0 (match-beginning 0)) + name))) + +(or (assq 'vms ange-ftp-sans-version-alist) + (setq ange-ftp-sans-version-alist + (cons '(vms . ange-ftp-vms-sans-version) + ange-ftp-sans-version-alist))) + +;;(defvar ange-ftp-file-version-alist) + +;;;;; The vms version of clean-directory has 2 more optional args +;;;;; than the usual dired version. This is so that it can be used by +;;;;; ange-ftp-dired-vms-flag-backup-files. + +;;(defun ange-ftp-dired-vms-clean-directory (keep &optional marker msg) +;; "Flag numerical backups for deletion. +;;Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest. +;;Positive prefix arg KEEP overrides `dired-kept-versions'; +;;Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive. + +;;To clear the flags on these files, you can use \\[dired-flag-backup-files] +;;with a prefix argument." +;;; (interactive "P") ; Never actually called interactively. +;; (setq keep (max 1 (if keep (prefix-numeric-value keep) dired-kept-versions))) +;; (let ((early-retention (if (< keep 0) (- keep) kept-old-versions)) +;; ;; late-retention must NEVER be allowed to be less than 1 in VMS! +;; ;; This could wipe ALL copies of the file. +;; (late-retention (max 1 (if (<= keep 0) dired-kept-versions keep))) +;; (action (or msg "Cleaning")) +;; (ange-ftp-trample-marker (or marker dired-del-marker)) +;; (ange-ftp-file-version-alist ())) +;; (message (concat action +;; " numerical backups (keeping %d late, %d old)...") +;; late-retention early-retention) +;; ;; Look at each file. +;; ;; If the file has numeric backup versions, +;; ;; put on ange-ftp-file-version-alist an element of the form +;; ;; (FILENAME . VERSION-NUMBER-LIST) +;; (dired-map-dired-file-lines (function +;; ange-ftp-dired-vms-collect-file-versions)) +;; ;; Sort each VERSION-NUMBER-LIST, +;; ;; and remove the versions not to be deleted. +;; (let ((fval ange-ftp-file-version-alist)) +;; (while fval +;; (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<))) +;; (v-count (length sorted-v-list))) +;; (if (> v-count (+ early-retention late-retention)) +;; (rplacd (nthcdr early-retention sorted-v-list) +;; (nthcdr (- v-count late-retention) +;; sorted-v-list))) +;; (rplacd (car fval) +;; (cdr sorted-v-list))) +;; (setq fval (cdr fval)))) +;; ;; Look at each file. If it is a numeric backup file, +;; ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. +;; (dired-map-dired-file-lines +;; (function +;; ange-ftp-dired-vms-trample-file-versions mark)) +;; (message (concat action " numerical backups...done")))) + +;;(or (assq 'vms ange-ftp-dired-clean-directory-alist) +;; (setq ange-ftp-dired-clean-directory-alist +;; (cons '(vms . ange-ftp-dired-vms-clean-directory) +;; ange-ftp-dired-clean-directory-alist))) + +;;(defun ange-ftp-dired-vms-collect-file-versions (fn) +;; ;; "If it looks like file FN has versions, return a list of the versions. +;; ;;That is a list of strings which are file names. +;; ;;The caller may want to flag some of these files for deletion." +;;(let ((name (nth 2 (ange-ftp-ftp-name fn)))) +;; (if (string-match ";[0-9]+$" name) +;; (let* ((name (substring name 0 (match-beginning 0))) +;; (fn (ange-ftp-replace-name-component fn name))) +;; (if (not (assq fn ange-ftp-file-version-alist)) +;; (let* ((base-versions +;; (concat (file-name-nondirectory name) ";")) +;; (bv-length (length base-versions)) +;; (possibilities (file-name-all-completions +;; base-versions +;; (file-name-directory fn))) +;; (versions (mapcar +;; '(lambda (arg) +;; (if (and (string-match +;; "[0-9]+$" arg bv-length) +;; (= (match-beginning 0) bv-length)) +;; (string-to-int (substring arg bv-length)) +;; 0)) +;; possibilities))) +;; (if versions +;; (setq +;; ange-ftp-file-version-alist +;; (cons (cons fn versions) +;; ange-ftp-file-version-alist))))))))) + +;;(defun ange-ftp-dired-vms-trample-file-versions (fn) +;; (let* ((start-vn (string-match ";[0-9]+$" fn)) +;; base-version-list) +;; (and start-vn +;; (setq base-version-list ; there was a base version to which +;; (assoc (substring fn 0 start-vn) ; this looks like a +;; ange-ftp-file-version-alist)) ; subversion +;; (not (memq (string-to-int (substring fn (1+ start-vn))) +;; base-version-list)) ; this one doesn't make the cut +;; (progn (beginning-of-line) +;; (delete-char 1) +;; (insert ange-ftp-trample-marker))))) + +;;(defun ange-ftp-dired-vms-flag-backup-files (&optional unflag-p) +;; (let ((dired-kept-versions 1) +;; (kept-old-versions 0) +;; marker msg) +;; (if unflag-p +;; (setq marker ?\040 msg "Unflagging") +;; (setq marker dired-del-marker msg "Cleaning")) +;; (ange-ftp-dired-vms-clean-directory nil marker msg))) + +;;(or (assq 'vms ange-ftp-dired-flag-backup-files-alist) +;; (setq ange-ftp-dired-flag-backup-files-alist +;; (cons '(vms . ange-ftp-dired-vms-flag-backup-files) +;; ange-ftp-dired-flag-backup-files-alist))) + +;;(defun ange-ftp-dired-vms-backup-diff (&optional switches) +;; (let ((file (dired-get-filename 'no-dir)) +;; bak) +;; (if (and (string-match ";[0-9]+$" file) +;; ;; Find most recent previous version. +;; (let ((root (substring file 0 (match-beginning 0))) +;; (ver +;; (string-to-int (substring file (1+ (match-beginning 0))))) +;; found) +;; (setq ver (1- ver)) +;; (while (and (> ver 0) (not found)) +;; (setq bak (concat root ";" (int-to-string ver))) +;; (and (file-exists-p bak) (setq found t)) +;; (setq ver (1- ver))) +;; found)) +;; (if switches +;; (diff (expand-file-name bak) (expand-file-name file) switches) +;; (diff (expand-file-name bak) (expand-file-name file))) +;; (error "No previous version found for %s" file)))) + +;;(or (assq 'vms ange-ftp-dired-backup-diff-alist) +;; (setq ange-ftp-dired-backup-diff-alist +;; (cons '(vms . ange-ftp-dired-vms-backup-diff) +;; ange-ftp-dired-backup-diff-alist))) + + +;;;; ------------------------------------------------------------ +;;;; MTS support +;;;; ------------------------------------------------------------ + + +;; Convert NAME from UNIX-ish to MTS. If REVERSE given then convert from +;; MTS to UNIX-ish. +(defun ange-ftp-fix-name-for-mts (name &optional reverse) + (save-match-data + (if reverse + (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name) + (let (acct file) + (if (match-beginning 1) + (setq acct (substring name 0 (match-end 1)))) + (if (match-beginning 2) + (setq file (substring name + (match-beginning 2) (match-end 2)))) + (concat (and acct (concat "/" acct "/")) + file)) + (error "name %s didn't match" name)) + (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" name) + (concat (substring name 1 (match-end 1)) + (substring name (match-beginning 2) (match-end 2))) + ;; Let's hope that mts will recognize it anyway. + name)))) + +(or (assq 'mts ange-ftp-fix-name-func-alist) + (setq ange-ftp-fix-name-func-alist + (cons '(mts . ange-ftp-fix-name-for-mts) + ange-ftp-fix-name-func-alist))) + +;; Convert name from UNIX-ish to MTS ready for a DIRectory listing. +;; Remember that there are no directories in MTS. +(defun ange-ftp-fix-dir-name-for-mts (dir-name) + (if (string-equal dir-name "/") + (error "Cannot get listing for fictitious \"/\" directory.") + (let ((dir-name (ange-ftp-fix-name-for-mts dir-name))) + (cond + ((string-equal dir-name "") + "?") + ((string-match ":$" dir-name) + (concat dir-name "?")) + (dir-name))))) ; It's just a single file. + +(or (assq 'mts ange-ftp-fix-dir-name-func-alist) + (setq ange-ftp-fix-dir-name-func-alist + (cons '(mts . ange-ftp-fix-dir-name-for-mts) + ange-ftp-fix-dir-name-func-alist))) + +(or (memq 'mts ange-ftp-dumb-host-types) + (setq ange-ftp-dumb-host-types + (cons 'mts ange-ftp-dumb-host-types))) + +(defvar ange-ftp-mts-host-regexp nil) + +;; Return non-nil if HOST is running MTS. +(defun ange-ftp-mts-host (host) + (and ange-ftp-mts-host-regexp + (save-match-data + (string-match ange-ftp-mts-host-regexp host)))) + +;; Parse the current buffer which is assumed to be in mts ftp dir format. +(defun ange-ftp-parse-mts-listing () + (let ((tbl (ange-ftp-make-hashtable))) + (goto-char (point-min)) + (save-match-data + (while (re-search-forward ange-ftp-date-regexp nil t) + (end-of-line) + (skip-chars-backward " ") + (let ((end (point))) + (skip-chars-backward "-A-Z0-9_.!") + (ange-ftp-put-hash-entry (buffer-substring (point) end) nil tbl)) + (forward-line 1))) + ;; Don't need to bother with .. + (ange-ftp-put-hash-entry "." t tbl) + tbl)) + +(or (assq 'mts ange-ftp-parse-list-func-alist) + (setq ange-ftp-parse-list-func-alist + (cons '(mts . ange-ftp-parse-mts-listing) + ange-ftp-parse-list-func-alist))) + +(defun ange-ftp-add-mts-host (host) + "Mark HOST as the name of a machine running MTS." + (interactive + (list (read-string "Host: " + (let ((name (or (buffer-file-name) default-directory))) + (and name (car (ange-ftp-ftp-name name))))))) + (if (not (ange-ftp-mts-host host)) + (setq ange-ftp-mts-host-regexp + (concat "^" (regexp-quote host) "$" + (and ange-ftp-mts-host-regexp "\\|") + ange-ftp-mts-host-regexp) + ange-ftp-host-cache nil))) + +;;; Tree dired support: + +;;;; There aren't too many systems left that use MTS. This dired support will +;;;; work for the implementation of ftp on mtsg.ubc.ca. I hope other mts systems +;;;; implement ftp in the same way. If not, it might be necessary to make the +;;;; following more flexible. + +;;(defun ange-ftp-dired-mts-move-to-filename (&optional raise-error eol) +;; "In dired, move to first char of filename on this line. +;;Returns position (point) or nil if no filename on this line." +;; ;; This is the MTS version. +;; (or eol (setq eol (progn (end-of-line) (point)))) +;; (beginning-of-line) +;; (if (re-search-forward +;; ange-ftp-date-regexp eol t) +;; (progn +;; (skip-chars-forward " ") ; Eat blanks after date +;; (skip-chars-forward "0-9:" eol) ; Eat time or year +;; (skip-chars-forward " " eol) ; one space before filename +;; ;; When listing an account other than the users own account it appends +;; ;; ACCT: to the beginning of the filename. Skip over this. +;; (and (looking-at "[A-Z0-9_.]+:") +;; (goto-char (match-end 0))) +;; (point)) +;; (if raise-error +;; (error "No file on this line") +;; nil))) + +;;(or (assq 'mts ange-ftp-dired-move-to-filename-alist) +;; (setq ange-ftp-dired-move-to-filename-alist +;; (cons '(mts . ange-ftp-dired-mts-move-to-filename) +;; ange-ftp-dired-move-to-filename-alist))) + +;;(defun ange-ftp-dired-mts-move-to-end-of-filename (&optional no-error eol) +;; ;; Assumes point is at beginning of filename. +;; ;; So, it should be called only after (dired-move-to-filename t). +;; ;; On failure, signals an error or returns nil. +;; ;; This is the MTS version. +;; (let (opoint hidden case-fold-search) +;; (setq opoint (point) +;; eol (save-excursion (end-of-line) (point)) +;; hidden (and selective-display +;; (save-excursion (search-forward "\r" eol t)))) +;; (if hidden +;; nil +;; (skip-chars-forward "-A-Z0-9._!" eol)) +;; (or no-error +;; (not (eq opoint (point))) +;; (error +;; (if hidden +;; (substitute-command-keys +;; "File line is hidden, type \\[dired-hide-subdir] to unhide") +;; "No file on this line"))) +;; (if (eq opoint (point)) +;; nil +;; (point)))) + +;;(or (assq 'mts ange-ftp-dired-move-to-end-of-filename-alist) +;; (setq ange-ftp-dired-move-to-end-of-filename-alist +;; (cons '(mts . ange-ftp-dired-mts-move-to-end-of-filename) +;; ange-ftp-dired-move-to-end-of-filename-alist))) + +;;;; ------------------------------------------------------------ +;;;; CMS support +;;;; ------------------------------------------------------------ + +;; Since CMS doesn't have any full file name syntax, we have to fudge +;; things with cd's. We actually send too many cd's, but it's dangerous +;; to try to remember the current minidisk, because if the connection +;; is closed and needs to be reopened, we will find ourselves back in +;; the default minidisk. This is fairly likely since CMS ftp servers +;; usually close the connection after 5 minutes of inactivity. + +;; Have I got the filename character set right? + +(defun ange-ftp-fix-name-for-cms (name &optional reverse) + (save-match-data + (if reverse + ;; Since we only convert output from a pwd in this direction, + ;; we'll assume that it's a minidisk, and make it into a + ;; directory file name. Note that the expand-dir-hashtable + ;; stores directories without the trailing /. Is this + ;; consistent? + (concat "/" name) + (if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" + name) + (let ((minidisk (substring name 1 (match-end 1)))) + (if (match-beginning 2) + (let ((file (substring name (match-beginning 2) + (match-end 2))) + (cmd (concat "cd " minidisk)) + + ;; Note that host and user are bound in the call + ;; to ange-ftp-send-cmd + (proc (ange-ftp-get-process ange-ftp-this-host + ange-ftp-this-user))) + + ;; Must use ange-ftp-raw-send-cmd here to avoid + ;; an infinite loop. + (if (car (ange-ftp-raw-send-cmd proc cmd ange-ftp-this-msg)) + file + ;; failed... try ONCE more. + (setq proc (ange-ftp-get-process ange-ftp-this-host + ange-ftp-this-user)) + (let ((result (ange-ftp-raw-send-cmd proc cmd + ange-ftp-this-msg))) + (if (car result) + file + ;; failed. give up. + (ange-ftp-error ange-ftp-this-host ange-ftp-this-user + (format "cd to minidisk %s failed: %s" + minidisk (cdr result))))))) + ;; return the minidisk + minidisk)) + (error "Invalid CMS filename"))))) + +(or (assq 'cms ange-ftp-fix-name-func-alist) + (setq ange-ftp-fix-name-func-alist + (cons '(cms . ange-ftp-fix-name-for-cms) + ange-ftp-fix-name-func-alist))) + +(or (memq 'cms ange-ftp-dumb-host-types) + (setq ange-ftp-dumb-host-types + (cons 'cms ange-ftp-dumb-host-types))) + +;; Convert name from UNIX-ish to CMS ready for a DIRectory listing. +(defun ange-ftp-fix-dir-name-for-cms (dir-name) + (cond + ((string-equal "/" dir-name) + (error "Cannot get listing for fictitious \"/\" directory.")) + ((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-name) + (let* ((minidisk (substring dir-name (match-beginning 1) (match-end 1))) + ;; host and user are bound in the call to ange-ftp-send-cmd + (proc (ange-ftp-get-process ange-ftp-this-host ange-ftp-this-user)) + (cmd (concat "cd " minidisk)) + (file (if (match-beginning 2) + ;; it's a single file + (substring dir-name (match-beginning 2) + (match-end 2)) + ;; use the wild-card + "*"))) + (if (car (ange-ftp-raw-send-cmd proc cmd)) + file + ;; try again... + (setq proc (ange-ftp-get-process ange-ftp-this-host + ange-ftp-this-user)) + (let ((result (ange-ftp-raw-send-cmd proc cmd))) + (if (car result) + file + ;; give up + (ange-ftp-error ange-ftp-this-host ange-ftp-this-user + (format "cd to minidisk %s failed: %s" + minidisk (cdr result)))))))) + (t (error "Invalid CMS file name")))) + +(or (assq 'cms ange-ftp-fix-dir-name-func-alist) + (setq ange-ftp-fix-dir-name-func-alist + (cons '(cms . ange-ftp-fix-dir-name-for-cms) + ange-ftp-fix-dir-name-func-alist))) + +(defvar ange-ftp-cms-host-regexp nil + "Regular expression to match hosts running the CMS operating system.") + +;; Return non-nil if HOST is running CMS. +(defun ange-ftp-cms-host (host) + (and ange-ftp-cms-host-regexp + (save-match-data + (string-match ange-ftp-cms-host-regexp host)))) + +(defun ange-ftp-add-cms-host (host) + "Mark HOST as the name of a CMS host." + (interactive + (list (read-string "Host: " + (let ((name (or (buffer-file-name) default-directory))) + (and name (car (ange-ftp-ftp-name name))))))) + (if (not (ange-ftp-cms-host host)) + (setq ange-ftp-cms-host-regexp + (concat "^" (regexp-quote host) "$" + (and ange-ftp-cms-host-regexp "\\|") + ange-ftp-cms-host-regexp) + ange-ftp-host-cache nil))) + +(defun ange-ftp-parse-cms-listing () + ;; Parse the current buffer which is assumed to be a CMS directory listing. + ;; If we succeed in getting a listing, then we will assume that the minidisk + ;; exists. file is bound by the call to ange-ftp-ls. This doesn't work + ;; because ange-ftp doesn't know that the root hashtable has only part of + ;; the info. It will assume that if a minidisk isn't in it, then it doesn't + ;; exist. It would be nice if completion worked for minidisks, as we + ;; discover them. +; (let* ((dir-file (directory-file-name file)) +; (root (file-name-directory dir-file)) +; (minidisk (ange-ftp-get-file-part dir-file)) +; (root-tbl (ange-ftp-get-hash-entry root ange-ftp-files-hashtable))) +; (if root-tbl +; (ange-ftp-put-hash-entry minidisk t root-tbl) +; (setq root-tbl (ange-ftp-make-hashtable)) +; (ange-ftp-put-hash-entry minidisk t root-tbl) +; (ange-ftp-put-hash-entry "." t root-tbl) +; (ange-ftp-set-files root root-tbl))) + ;; Now do the usual parsing + (let ((tbl (ange-ftp-make-hashtable))) + (goto-char (point-min)) + (save-match-data + (while + (re-search-forward + "^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t) + (ange-ftp-put-hash-entry + (concat (buffer-substring (match-beginning 1) + (match-end 1)) + "." + (buffer-substring (match-beginning 2) + (match-end 2))) + nil tbl) + (forward-line 1)) + (ange-ftp-put-hash-entry "." t tbl)) + tbl)) + +(or (assq 'cms ange-ftp-parse-list-func-alist) + (setq ange-ftp-parse-list-func-alist + (cons '(cms . ange-ftp-parse-cms-listing) + ange-ftp-parse-list-func-alist))) + +;;;;; Tree dired support: + +;;(defconst ange-ftp-dired-cms-re-exe +;; "^. [-A-Z0-9$_]+ +EXEC " +;; "Regular expression to use to search for CMS executables.") + +;;(or (assq 'cms ange-ftp-dired-re-exe-alist) +;; (setq ange-ftp-dired-re-exe-alist +;; (cons (cons 'cms ange-ftp-dired-cms-re-exe) +;; ange-ftp-dired-re-exe-alist))) + + +;;(defun ange-ftp-dired-cms-insert-headerline (dir) +;; ;; CMS has no total line, so we insert a blank line for +;; ;; aesthetics. +;; (insert "\n") +;; (forward-char -1) +;; (ange-ftp-real-dired-insert-headerline dir)) + +;;(or (assq 'cms ange-ftp-dired-insert-headerline-alist) +;; (setq ange-ftp-dired-insert-headerline-alist +;; (cons '(cms . ange-ftp-dired-cms-insert-headerline) +;; ange-ftp-dired-insert-headerline-alist))) + +;;(defun ange-ftp-dired-cms-move-to-filename (&optional raise-error eol) +;; "In dired, move to the first char of filename on this line." +;; ;; This is the CMS version. +;; (or eol (setq eol (progn (end-of-line) (point)))) +;; (let (case-fold-search) +;; (beginning-of-line) +;; (if (re-search-forward " [-A-Z0-9$_]+ +[-A-Z0-9$_]+ +[VF] +[0-9]+ " eol t) +;; (goto-char (1+ (match-beginning 0))) +;; (if raise-error +;; (error "No file on this line") +;; nil)))) + +;;(or (assq 'cms ange-ftp-dired-move-to-filename-alist) +;; (setq ange-ftp-dired-move-to-filename-alist +;; (cons '(cms . ange-ftp-dired-cms-move-to-filename) +;; ange-ftp-dired-move-to-filename-alist))) + +;;(defun ange-ftp-dired-cms-move-to-end-of-filename (&optional no-error eol) +;; ;; Assumes point is at beginning of filename. +;; ;; So, it should be called only after (dired-move-to-filename t). +;; ;; case-fold-search must be nil, at least for VMS. +;; ;; On failure, signals an error or returns nil. +;; ;; This is the CMS version. +;; (let ((opoint (point)) +;; case-fold-search hidden) +;; (or eol (setq eol (save-excursion (end-of-line) (point)))) +;; (setq hidden (and selective-display +;; (save-excursion +;; (search-forward "\r" eol t)))) +;; (if hidden +;; (if no-error +;; nil +;; (error +;; (substitute-command-keys +;; "File line is hidden, type \\[dired-hide-subdir] to unhide"))) +;; (skip-chars-forward "-A-Z0-9$_" eol) +;; (skip-chars-forward " " eol) +;; (skip-chars-forward "-A-Z0-9$_" eol) +;; (if (eq opoint (point)) +;; (if no-error +;; nil +;; (error "No file on this line")) +;; (point))))) + +;;(or (assq 'cms ange-ftp-dired-move-to-end-of-filename-alist) +;; (setq ange-ftp-dired-move-to-end-of-filename-alist +;; (cons '(cms . ange-ftp-dired-cms-move-to-end-of-filename) +;; ange-ftp-dired-move-to-end-of-filename-alist))) + +(defun ange-ftp-cms-make-compressed-filename (name &optional reverse) + (if (string-match "-Z$" name) + (list nil (substring name 0 -2)) + (list t (concat name "-Z")))) + +(or (assq 'cms ange-ftp-make-compressed-filename-alist) + (setq ange-ftp-make-compressed-filename-alist + (cons '(cms . ange-ftp-cms-make-compressed-filename) + ange-ftp-make-compressed-filename-alist))) + +;;(defun ange-ftp-dired-cms-get-filename (&optional localp no-error-if-not-filep) +;; (let ((name (ange-ftp-real-dired-get-filename localp no-error-if-not-filep))) +;; (and name +;; (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" name) +;; (concat (substring name 0 (match-end 1)) +;; "." +;; (substring name (match-beginning 2) (match-end 2))) +;; name)))) + +;;(or (assq 'cms ange-ftp-dired-get-filename-alist) +;; (setq ange-ftp-dired-get-filename-alist +;; (cons '(cms . ange-ftp-dired-cms-get-filename) +;; ange-ftp-dired-get-filename-alist))) + +;;;; ------------------------------------------------------------ +;;;; Finally provide package. +;;;; ------------------------------------------------------------ + +(provide 'ange-ftp) + +;;; ange-ftp.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/browse-url.el Mon Mar 20 13:12:14 2000 +0000 @@ -0,0 +1,1033 @@ +;;; browse-url.el --- Pass a URL to a WWW browser + +;; Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. + +;; Author: Denis Howe <dbh@doc.ic.ac.uk> +;; Maintainer: Dave Love <fx@gnu.org> +;; Created: 03 Apr 1995 +;; Keywords: hypertext, hypermedia, mouse + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package provides functions which read a URL (Uniform Resource +;; Locator) from the minibuffer, defaulting to the URL around point, +;; and ask a World-Wide Web browser to load it. It can also load the +;; URL associated with the current buffer. Different browsers use +;; different methods of remote control so there is one function for +;; each supported browser. If the chosen browser is not running, it +;; is started. Currently there is support for: + +;; Function Browser Earliest version +;; browse-url-netscape Netscape 1.1b1 +;; browse-url-mosaic XMosaic/mMosaic <= 2.4 +;; browse-url-cci XMosaic 2.5 +;; browse-url-w3 w3 0 +;; browse-url-w3-gnudoit w3 remotely +;; browse-url-iximosaic IXI Mosaic ? +;; browse-url-lynx-* Lynx 0 +;; browse-url-grail Grail 0.3b1 +;; browse-url-mmm MMM ? +;; browse-url-generic arbitrary + +;; [A version of the Netscape browser is now free software +;; <URL:http://www.mozilla.org/>, albeit not GPLed, so it is +;; reasonable to have that as the default.] + +;; Note that versions of Netscape before 1.1b1 did not have remote +;; control. <URL:http://www.netscape.com/newsref/std/x-remote.html>. + +;; Browsers can cache Web pages so it may be necessary to tell them to +;; reload the current page if it has changed (e.g. if you have edited +;; it). There is currently no perfect automatic solution to this. + +;; Netscape allows you to specify the id of the window you want to +;; control but which window DO you want to control and how do you +;; discover its id? + +;; If using XMosaic before version 2.5, check the definition of +;; browse-url-usr1-signal below. +;; <URL:http://www.ncsa.uiuc.edu/SDG/Software/XMosaic/remote-control.html> + +;; XMosaic version 2.5 introduced Common Client Interface allowing you +;; to control mosaic through Unix sockets. +;; <URL:http://www.ncsa.uiuc.edu/SDG/Software/XMosaic/CCI/cci-spec.html> + +;; William M. Perry's excellent "w3" WWW browser for +;; Emacs <URL:ftp://cs.indiana.edu/pub/elisp/w3/> +;; has a function w3-follow-url-at-point, but that +;; doesn't let you edit the URL like browse-url. +;; The `gnuserv' package that can be used to control it in another +;; Emacs process is available from +;; <URL:ftp://ftp.splode.com/pub/users/friedman/packages/>. + +;; Grail is the freely available WWW browser implemented in Python, a +;; cool object-oriented freely available interpreted language. Grail +;; 0.3b1 was the first version to have remote control as distributed. +;; For more information on Grail see +;; <URL:http://grail.cnri.reston.va.us/> and for more information on +;; Python see <url:http://www.python.org/>. Grail support in +;; browse-url.el written by Barry Warsaw <bwarsaw@python.org>. + +;; MMM is a semi-free WWW browser implemented in Objective Caml, an +;; interesting impure functional programming language. See +;; <URL:http://pauillac.inria.fr/%7Erouaix/mmm/>. + +;; Lynx is now distributed by the FSF. See also +;; <URL:http://lynx.browser.org/>. + +;; Free graphical browsers that could be used by `browse-url-generic' +;; include Chimera <URL:ftp://ftp.cs.unlv.edu/pub/chimera> and +;; <URL:http://www.unlv.edu/chimera/>, Arena +;; <URL:ftp://ftp.yggdrasil.com/pub/dist/web/arena> and Amaya +;; <URL:ftp://ftp.w3.org/pub/amaya>. mMosaic +;; <URL:ftp://sig.enst.fr/pub/multicast/mMosaic/>, +;; <URL:http://sig.enst.fr/~dauphin/mMosaic/> (with development +;; support for Java applets and multicast) can be used like Mosaic by +;; setting `browse-url-mosaic-program' appropriately. + +;; I [Denis Howe, not Dave Love] recommend Nelson Minar +;; <nelson@santafe.edu>'s excellent html-helper-mode.el for editing +;; HTML and thank Nelson for his many useful comments on this code. +;; <URL:http://www.santafe.edu/%7Enelson/hhm-beta/> + +;; See also hm--html-menus <URL:http://www.tnt.uni-hannover.de/%7Emuenkel/ +;; software/own/hm--html-menus/>. For composing correct HTML see also +;; PSGML the general SGML structure editor package +;; <URL:ftp://ftp.lysator.liu.se/pub/sgml>; hm--html-menus can be used +;; with this. + +;; This package generalises function html-previewer-process in Marc +;; Andreessen's html-mode (LCD modes/html-mode.el.Z). See also the +;; ffap.el package. The huge hyperbole package also contains similar +;; functions. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Help! + +;; Can you write and test some code for the Macintrash and Windoze +;; Netscape remote control APIs? (See the URL above). + +;; Do any other browsers have remote control? + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Usage + +;; To display the URL at or before point: +;; M-x browse-url-at-point RET +;; or, similarly but with the opportunity to edit the URL extracted from +;; the buffer, use: +;; M-x browse-url + +;; To display a URL by shift-clicking on it, put this in your ~/.emacs +;; file: +;; (global-set-key [S-mouse-2] 'browse-url-at-mouse) +;; (Note that using Shift-mouse-1 is not desirable because +;; that event has a standard meaning in Emacs.) + +;; To display the current buffer in a web browser: +;; M-x browse-url-of-buffer RET + +;; To display the current region in a web browser: +;; M-x browse-url-of-region RET + +;; In Dired, to display the file named on the current line: +;; M-x browse-url-of-dired-file RET + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Customisation (~/.emacs) + +;; To see what variables are available for customization, type +;; `M-x set-variable browse-url TAB'. Better, use +;; `M-x customize-group browse-url'. + +;; Bind the browse-url commands to keys with the `C-c C-z' prefix +;; (as used by html-helper-mode): +;; (global-set-key "\C-c\C-z." 'browse-url-at-point) +;; (global-set-key "\C-c\C-zb" 'browse-url-of-buffer) +;; (global-set-key "\C-c\C-zr" 'browse-url-of-region) +;; (global-set-key "\C-c\C-zu" 'browse-url) +;; (global-set-key "\C-c\C-zv" 'browse-url-of-file) +;; (add-hook 'dired-mode-hook +;; (lambda () +;; (local-set-key "\C-c\C-zf" 'browse-url-of-dired-file))) + +;; Browse URLs in mail messages by clicking mouse-2: +;; (add-hook 'rmail-mode-hook (lambda () ; rmail-mode startup +;; (define-key rmail-mode-map [mouse-2] 'browse-url-at-mouse))) + +;; Browse URLs in Usenet messages by clicking mouse-2: +;; (eval-after-load "gnus" +;; '(define-key gnus-article-mode-map [mouse-2] 'browse-url-at-mouse)) +;; [The current version of Gnus provides a standard feature to +;; activate URLs in article buffers for invocation of browse-url with +;; mouse-2.] + +;; Use the Emacs w3 browser when not running under X11: +;; (or (eq window-system 'x) +;; (setq browse-url-browser-function 'browse-url-w3)) + +;; To always save modified buffers before displaying the file in a browser: +;; (setq browse-url-save-file t) + +;; To get round the Netscape caching problem, you could EITHER have +;; write-file in html-helper-mode make Netscape reload the document: +;; +;; (autoload 'browse-url-netscape-reload "browse-url" +;; "Ask a WWW browser to redisplay the current file." t) +;; (add-hook 'html-helper-mode-hook +;; (lambda () +;; (add-hook 'local-write-file-hooks +;; (lambda () +;; (let ((local-write-file-hooks)) +;; (save-buffer)) +;; (browse-url-netscape-reload) +;; t) ; => file written by hook +;; t))) ; append to l-w-f-hooks +;; +;; OR have browse-url-of-file ask Netscape to load and then reload the +;; file: +;; +;; (add-hook 'browse-url-of-file-hook 'browse-url-netscape-reload) + +;; You may also want to customise browse-url-netscape-arguments, e.g. +;; (setq browse-url-netscape-arguments '("-install")) +;; +;; or similarly for the other browsers. + +;; To invoke different browsers for different URLs: +;; (setq browse-url-browser-function '(("^mailto:" . browse-url-mail) +;; ("." . browse-url-netscape))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Code: + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Variables + +(eval-when-compile (require 'thingatpt) + (require 'term) + (require 'dired) + (require 'w3-auto nil t)) + +(defgroup browse-url nil + "Use a web browser to look at a URL." + :prefix "browse-url-" + :group 'hypermedia) + +;;;###autoload +(defcustom browse-url-browser-function + (if (eq system-type 'windows-nt) + 'browse-url-default-windows-browser + 'browse-url-netscape) + "*Function to display the current buffer in a WWW browser. +This is used by the `browse-url-at-point', `browse-url-at-mouse', and +`browse-url-of-file' commands. + +If the value is not a function it should be a list of pairs +(REGEXP . FUNCTION). In this case the function called will be the one +associated with the first REGEXP which matches the current URL. The +function is passed the URL and any other args of `browse-url'. The last +regexp should probably be \".\" to specify a default browser." + :type '(choice + (function-item :tag "Emacs W3" :value browse-url-w3) + (function-item :tag "W3 in another Emacs via `gnudoit'" + :value browse-url-w3-gnudoit) + (function-item :tag "Netscape" :value browse-url-netscape) + (function-item :tag "Mosaic" :value browse-url-mosaic) + (function-item :tag "Mosaic using CCI" :value browse-url-cci) + (function-item :tag "IXI Mosaic" :value browse-url-iximosaic) + (function-item :tag "Lynx in an xterm window" + :value browse-url-lynx-xterm) + (function-item :tag "Lynx in an Emacs window" + :value browse-url-lynx-emacs) + (function-item :tag "Grail" :value browse-url-grail) + (function-item :tag "MMM" :value browse-url-mmm) + (function-item :tag "Specified by `Browse Url Generic Program'" + :value browse-url-generic) + (function-item :tag "Default Windows browser" + :value browse-url-default-windows-browser) + (function :tag "Your own function")) + :version "20.4" + :group 'browse-url) + +(defcustom browse-url-netscape-program "netscape" + ;; Info about netscape-remote from Karl Berry. + "The name by which to invoke Netscape. + +The free program `netscape-remote' from +<URL:http://home.netscape.com/newsref/std/remote.c> is said to start +up very much quicker than `netscape'. Reported to compile on a GNU +system, given vroot.h from the same directory, with cc flags + -DSTANDALONE -L/usr/X11R6/lib -lXmu -lX11." + :type 'string + :group 'browse-url) + +(defcustom browse-url-netscape-arguments nil + "A list of strings to pass to Netscape as arguments." + :type '(repeat (string :tag "Argument")) + :group 'browse-url) + +(defcustom browse-url-netscape-startup-arguments browse-url-netscape-arguments + "A list of strings to pass to Netscape when it starts up. +Defaults to the value of `browse-url-netscape-arguments' at the time +`browse-url' is loaded." + :type '(repeat (string :tag "Argument")) + :group 'browse-url) + +;;;###autoload +(defcustom browse-url-new-window-p nil + "*If non-nil, always open a new browser window with appropriate browsers. +Passing an interactive argument to \\[browse-url], or specific browser +commands reverses the effect of this variable. Requires Netscape version +1.1N or later or XMosaic version 2.5 or later if using those browsers." + :type 'boolean + :group 'browse-url) + +;;;###autoload +(defcustom browse-url-netscape-display nil + "*The X display for running Netscape, if not same as Emacs'." + :type '(choice string (const :tag "Default" nil)) + :group 'browse-url) + +(defcustom browse-url-mosaic-program "xmosaic" + "The name by which to invoke Mosaic (or mMosaic)." + :type 'string + :version "20.3" + :group 'browse-url) + +(defcustom browse-url-mosaic-arguments nil + "A list of strings to pass to Mosaic as arguments." + :type '(repeat (string :tag "Argument")) + :group 'browse-url) + +(defcustom browse-url-filename-alist + '(("^/\\(ftp@\\|anonymous@\\)?\\([^:]+\\):/*" . "ftp://\\2/") + ;; The above loses the username to avoid the browser prompting for + ;; it in anonymous cases. If it's not anonymous the next regexp + ;; applies. + ("^/\\([^:@]+@\\)?\\([^:]+\\):/*" . "ftp://\\1\\2/") + ("^/+" . "file:/")) + "An alist of (REGEXP . STRING) pairs used by `browse-url-of-file'. +Any substring of a filename matching one of the REGEXPs is replaced by +the corresponding STRING using `replace-match', not treating STRING +literally. All pairs are applied in the order given. The default +value converts ange-ftp/EFS-style paths into ftp URLs and prepends +`file:' to any path beginning with `/'. + +For example, adding to the default a specific translation of an ange-ftp +address to an HTTP URL: + + (setq browse-url-filename-alist + '((\"/webmaster@webserver:/home/www/html/\" . + \"http://www.acme.co.uk/\") + (\"^/\\(ftp@\\|anonymous@\\)?\\([^:]+\\):/*\" . \"ftp://\\2/\") + (\"^/\\([^:@]+@\\)?\\([^:]+\\):/*\" . \"ftp://\\1\\2/\") + (\"^/+\" . \"file:/\"))) +" + :type '(repeat (cons :format "%v" + (regexp :tag "Regexp") + (string :tag "Replacement"))) + :version "20.3" + :group 'browse-url) + +;;;###autoload +(defcustom browse-url-save-file nil + "*If non-nil, save the buffer before displaying its file. +Used by the `browse-url-of-file' command." + :type 'boolean + :group 'browse-url) + +(defcustom browse-url-of-file-hook nil + "Run after `browse-url-of-file' has asked a browser to load a file. + +Set this to `browse-url-netscape-reload' to force Netscape to load the +file rather than displaying a cached copy." + :type 'hook + :options '(browse-url-netscape-reload) + :group 'browse-url) + +(defvar browse-url-usr1-signal + (if (and (boundp 'emacs-major-version) + (or (> emacs-major-version 19) (>= emacs-minor-version 29))) + 'SIGUSR1 ; Why did I think this was in lower case before? + 30) ; Check /usr/include/signal.h. + "The argument to `signal-process' for sending SIGUSR1 to XMosaic. +Emacs 19.29 accepts 'SIGUSR1, earlier versions require an integer +which is 30 on SunOS and 16 on HP-UX and Solaris.") + +(defcustom browse-url-CCI-port 3003 + "Port to access XMosaic via CCI. +This can be any number between 1024 and 65535 but must correspond to +the value set in the browser." + :type 'integer + :group 'browse-url) + +(defcustom browse-url-CCI-host "localhost" + "*Host to access XMosaic via CCI. +This should be the host name of the machine running XMosaic with CCI +enabled. The port number should be set in `browse-url-CCI-port'." + :type 'string + :group 'browse-url) + +(defvar browse-url-temp-file-name nil) +(make-variable-buffer-local 'browse-url-temp-file-name) + +(defcustom browse-url-xterm-program "xterm" + "The name of the terminal emulator used by `browse-url-lynx-xterm'. +This might, for instance, be a separate colour version of xterm." + :type 'string + :group 'browse-url) + +(defcustom browse-url-xterm-args nil + "*A list of strings defining options for `browse-url-xterm-program'. +These might set its size, for instance." + :type '(repeat (string :tag "Argument")) + :group 'browse-url) + +(defcustom browse-url-lynx-emacs-args (and (not window-system) + '("-show_cursor")) + "A list of strings defining options for Lynx in an Emacs buffer. + +The default is none in a window system, otherwise `-show_cursor' to +indicate the position of the current link in the absence of +highlighting, assuming the normal default for showing the cursor." + :type '(repeat (string :tag "Argument")) + :version "20.3" + :group 'browse-url) + +(defcustom browse-url-gnudoit-program "gnudoit" + "The name of the `gnudoit' program used by `browse-url-w3-gnudoit'." + :type 'string + :group 'browse-url) + +(defcustom browse-url-gnudoit-args '("-q") + "*A list of strings defining options for `browse-url-gnudoit-program'. +These might set the port, for instance." + :type '(repeat (string :tag "Argument")) + :group 'browse-url) + +;;;###autoload +(defcustom browse-url-generic-program nil + "*The name of the browser program used by `browse-url-generic'." + :type '(choice string (const :tag "None" nil)) + :group 'browse-url) + +(defcustom browse-url-generic-args nil + "*A list of strings defining options for `browse-url-generic-program'." + :type '(repeat (string :tag "Argument")) + :group 'browse-url) + +(defcustom browse-url-temp-dir temporary-file-directory + "The name of a directory for browse-url's temporary files. +Such files are generated by functions like `browse-url-of-region'. +You might want to set this to somewhere with restricted read permissions +for privacy's sake." + :type 'string + :group 'browse-url) + +(defcustom browse-url-netscape-version + 3 + "The version of Netscape you are using. +This affects how URL reloading is done; the mechanism changed +incompatibly at version 4." + :type 'number + :group 'browse-url) + +(defcustom browse-url-lynx-input-field 'avoid + "*Action on selecting an existing Lynx buffer at an input field. +What to do when sending a new URL to an existing Lynx buffer in Emacs +if the Lynx cursor is on an input field (in which case the `g' command +would be entered as data). Such fields are recognized by the +underlines ____. Allowed values: nil: disregard it, 'warn: warn the +user and don't emit the URL, 'avoid: try to avoid the field by moving +down (this *won't* always work)." + :type '(choice (const :tag "Move to try to avoid field" :value avoid) + (const :tag "Disregard" :value nil) + (const :tag "Warn, don't emit URL" :value warn)) + :version "20.3" + :group 'browse-url) + +(defvar browse-url-lynx-input-attempts 10 + "*How many times to try to move down from a series of lynx input fields.") + +(defcustom browse-url-lynx-input-delay 0.2 + "How many seconds to wait for lynx between moves down from an input field.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URL input + +(defun browse-url-url-at-point () + (let ((url (thing-at-point 'url))) + (set-text-properties 0 (length url) nil url) + url)) + +;; Having this as a separate function called by the browser-specific +;; functions allows them to be stand-alone commands, making it easier +;; to switch between browsers. + +(defun browse-url-interactive-arg (prompt) + "Read a URL from the minibuffer, prompting with PROMPT. +Default to the URL at or before point. If invoked with a mouse button, +set point to the position clicked first. Return a list for use in +`interactive' containing the URL and `browse-url-new-window-p' or its +negation if a prefix argument was given." + (let ((event (elt (this-command-keys) 0))) + (and (listp event) (mouse-set-point event))) + (list (read-string prompt (browse-url-url-at-point)) + (not (eq (null browse-url-new-window-p) + (null current-prefix-arg))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Browse current buffer + +;;;###autoload +(defun browse-url-of-file (&optional file) + "Ask a WWW browser to display FILE. +Display the current buffer's file if FILE is nil or if called +interactively. Turn the filename into a URL with function +`browse-url-file-url'. Pass the URL to a browser using the +`browse-url' function then run `browse-url-of-file-hook'." + (interactive) + (or file + (setq file (buffer-file-name)) + (error "Current buffer has no file")) + (let ((buf (get-file-buffer file))) + (if buf + (save-excursion + (set-buffer buf) + (cond ((not (buffer-modified-p))) + (browse-url-save-file (save-buffer)) + (t (message "%s modified since last save" file)))))) + (browse-url (browse-url-file-url file)) + (run-hooks 'browse-url-of-file-hook)) + +(defun browse-url-file-url (file) + "Return the URL corresponding to FILE. +Use variable `browse-url-filename-alist' to map filenames to URLs." + ;; URL-encode special chars, do % first + (let ((s 0)) + (while (setq s (string-match "%" file s)) + (setq file (replace-match "%25" t t file) + s (1+ s)))) + (while (string-match "[*\"()',=;? ]" file) + (let ((enc (format "%%%x" (aref file (match-beginning 0))))) + (setq file (replace-match enc t t file)))) + (let ((maps browse-url-filename-alist)) + (while maps + (let* ((map (car maps)) + (from-re (car map)) + (to-string (cdr map))) + (setq maps (cdr maps)) + (and (string-match from-re file) + (setq file (replace-match to-string t nil file)))))) + file) + +;;;###autoload +(defun browse-url-of-buffer (&optional buffer) + "Ask a WWW browser to display BUFFER. +Display the current buffer if BUFFER is nil. Display only the +currently visible part of BUFFER (from a temporary file) if buffer is +narrowed." + (interactive) + (save-excursion + (and buffer (set-buffer buffer)) + (let ((file-name + ;; Ignore real name if restricted + (and (= (- (point-max) (point-min)) (buffer-size)) + (or buffer-file-name + (and (boundp 'dired-directory) dired-directory))))) + (or file-name + (progn + (or browse-url-temp-file-name + (setq browse-url-temp-file-name + (convert-standard-filename + (make-temp-file + (expand-file-name "burl" browse-url-temp-dir))))) + (setq file-name browse-url-temp-file-name) + (write-region (point-min) (point-max) file-name nil 'no-message))) + (browse-url-of-file file-name)))) + +(defun browse-url-delete-temp-file (&optional temp-file-name) + ;; Delete browse-url-temp-file-name from the file system + ;; If optional arg TEMP-FILE-NAME is non-nil, delete it instead + (let ((file-name (or temp-file-name browse-url-temp-file-name))) + (if (and file-name (file-exists-p file-name)) + (delete-file file-name)))) + +(add-hook 'kill-buffer-hook 'browse-url-delete-temp-file) + +;;;###autoload +(defun browse-url-of-dired-file () + "In Dired, ask a WWW browser to display the file named on this line." + (interactive) + (browse-url-of-file (dired-get-filename))) + +;;;###autoload +(defun browse-url-of-region (min max) + "Ask a WWW browser to display the current region." + (interactive "r") + (save-excursion + (save-restriction + (narrow-to-region min max) + (browse-url-of-buffer)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Browser-independent commands + +;; A generic command to call the current browse-url-browser-function + +;;;###autoload +(defun browse-url (url &rest args) + "Ask a WWW browser to load URL. +Prompts for a URL, defaulting to the URL at or before point. Variable +`browse-url-browser-function' says which browser to use." + (interactive (browse-url-interactive-arg "URL: ")) + (if (functionp browse-url-browser-function) + (apply browse-url-browser-function url args) + ;; The `function' can be an alist; look down it for first match + ;; and apply the function (which might be a lambda). + (catch 'done + (mapcar + (lambda (bf) + (when (string-match (car bf) url) + (apply (cdr bf) url args) + (throw 'done t))) + browse-url-browser-function) + (error "No browser in browse-url-browser-function matching URL %s" + url)))) + +;;;###autoload +(defun browse-url-at-point () + "Ask a WWW browser to load the URL at or before point. +Doesn't let you edit the URL like `browse-url'. Variable +`browse-url-browser-function' says which browser to use." + (interactive) + (browse-url (browse-url-url-at-point))) + +(defun browse-url-event-buffer (event) + (window-buffer (posn-window (event-start event)))) + +(defun browse-url-event-point (event) + (posn-point (event-start event))) + +;;;###autoload +(defun browse-url-at-mouse (event) + "Ask a WWW browser to load a URL clicked with the mouse. +The URL is the one around or before the position of the mouse click +but point is not changed. Doesn't let you edit the URL like +`browse-url'. Variable `browse-url-browser-function' says which browser +to use." + (interactive "e") + (save-excursion + (set-buffer (browse-url-event-buffer event)) + (goto-char (browse-url-event-point event)) + (let ((url (browse-url-url-at-point))) + (if (string-equal url "") + (error "No URL found")) + (browse-url url browse-url-new-window-p)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Browser-specific commands + +;; --- Default MS-Windows browser --- + +(defun browse-url-default-windows-browser (url &optional new-window) + (interactive (browse-url-interactive-arg "URL: ")) + (w32-shell-execute "open" url)) + +;; --- Netscape --- + +(defun browse-url-process-environment () + "Set DISPLAY in the environment to the X display Netscape is running on. +This is either the value of variable `browse-url-netscape-display' if +non-nil, or the same display as Emacs if different from the current +environment, otherwise just use the current environment." + (let ((display (or browse-url-netscape-display (browse-url-emacs-display)))) + (if display + (cons (concat "DISPLAY=" display) process-environment) + process-environment))) + +(defun browse-url-emacs-display () + "Return the X display Emacs is running on. +This is nil if the display is the same as the DISPLAY environment variable. + +Actually Emacs could be using several displays; this just returns the +one showing the selected frame." + (let ((display (cdr-safe (assq 'display (frame-parameters))))) + (and (not (equal display (getenv "DISPLAY"))) + display))) + +;;;###autoload +(defun browse-url-netscape (url &optional new-window) + "Ask the Netscape WWW browser to load URL. + +Default to the URL around or before point. The strings in variable +`browse-url-netscape-arguments' are also passed to Netscape. + +When called interactively, if variable `browse-url-new-window-p' is +non-nil, load the document in a new Netscape window, otherwise use a +random existing one. A non-nil interactive prefix argument reverses +the effect of `browse-url-new-window-p'. + +When called non-interactively, optional second argument NEW-WINDOW is +used instead of `browse-url-new-window-p'." + (interactive (browse-url-interactive-arg "Netscape URL: ")) + ;; URL encode any `confusing' characters in the URL. This needs to + ;; include at least commas; presumably also close parens. + (while (string-match "[,)]" url) + (setq url (replace-match + (format "%%%x" (string-to-char (match-string 0 url))) t t url))) + (let* ((process-environment (browse-url-process-environment)) + (process (apply 'start-process + (concat "netscape " url) nil + browse-url-netscape-program + (append + browse-url-netscape-arguments + (if (eq window-system 'w32) + (list url) + (append + (if new-window '("-noraise")) + (list "-remote" + (concat "openURL(" url + (if new-window ",new-window") + ")")))))))) + (set-process-sentinel process + (list 'lambda '(process change) + (list 'browse-url-netscape-sentinel 'process url))))) + +(defun browse-url-netscape-sentinel (process url) + "Handle a change to the process communicating with Netscape." + (or (eq (process-exit-status process) 0) + (let* ((process-environment (browse-url-process-environment))) + ;; Netscape not running - start it + (message "Starting Netscape...") + (apply 'start-process (concat "netscape" url) nil + browse-url-netscape-program + (append browse-url-netscape-startup-arguments (list url)))))) + +(defun browse-url-netscape-reload () + "Ask Netscape to reload its current document. +How depends on `browse-url-netscape-version'." + (interactive) + ;; Backwards incompatibility reported by + ;; <peter.kruse@psychologie.uni-regensburg.de>. + (browse-url-netscape-send (if (>= browse-url-netscape-version 4) + "xfeDoCommand(reload)" + "reload"))) + +(defun browse-url-netscape-send (command) + "Send a remote control command to Netscape." + (let* ((process-environment (browse-url-process-environment))) + (apply 'start-process "netscape" nil + browse-url-netscape-program + (append browse-url-netscape-arguments + (list "-remote" command))))) + +;; --- Mosaic --- + +;;;###autoload +(defun browse-url-mosaic (url &optional new-window) + "Ask the XMosaic WWW browser to load URL. + +Default to the URL around or before point. The strings in variable +`browse-url-mosaic-arguments' are also passed to Mosaic and the +program is invoked according to the variable +`browse-url-mosaic-program'. + +When called interactively, if variable `browse-url-new-window-p' is +non-nil, load the document in a new Mosaic window, otherwise use a +random existing one. A non-nil interactive prefix argument reverses +the effect of `browse-url-new-window-p'. + +When called non-interactively, optional second argument NEW-WINDOW is +used instead of `browse-url-new-window-p'." + (interactive (browse-url-interactive-arg "Mosaic URL: ")) + (let ((pidfile (expand-file-name "~/.mosaicpid")) + pid) + (if (file-readable-p pidfile) + (save-excursion + (find-file pidfile) + (goto-char (point-min)) + (setq pid (read (current-buffer))) + (kill-buffer nil))) + (if (and pid (zerop (signal-process pid 0))) ; Mosaic running + (save-excursion + (find-file (format "/tmp/Mosaic.%d" pid)) + (erase-buffer) + (insert (if new-window + "newwin\n" + "goto\n") + url "\n") + (save-buffer) + (kill-buffer nil) + ;; Send signal SIGUSR to Mosaic + (message "Signalling Mosaic...") + (signal-process pid browse-url-usr1-signal) + ;; Or you could try: + ;; (call-process "kill" nil 0 nil "-USR1" (int-to-string pid)) + (message "Signalling Mosaic...done") + ) + ;; Mosaic not running - start it + (message "Starting Mosaic...") + (apply 'start-process "xmosaic" nil browse-url-mosaic-program + (append browse-url-mosaic-arguments (list url))) + (message "Starting Mosaic...done")))) + +;; --- Grail --- + +;;;###autoload +(defvar browse-url-grail + (concat (or (getenv "GRAILDIR") "~/.grail") "/user/rcgrail.py") + "Location of Grail remote control client script `rcgrail.py'. +Typically found in $GRAILDIR/rcgrail.py, or ~/.grail/user/rcgrail.py.") + +;;;###autoload +(defun browse-url-grail (url &optional new-window) + "Ask the Grail WWW browser to load URL. +Default to the URL around or before point. Runs the program in the +variable `browse-url-grail'." + (interactive (browse-url-interactive-arg "Grail URL: ")) + (message "Sending URL to Grail...") + (save-excursion + (set-buffer (get-buffer-create " *Shell Command Output*")) + (erase-buffer) + ;; don't worry about this failing. + (if new-window + (call-process browse-url-grail nil 0 nil "-b" url) + (call-process browse-url-grail nil 0 nil url)) + (message "Sending URL to Grail... done"))) + +;; --- Mosaic using CCI --- + +;;;###autoload +(defun browse-url-cci (url &optional new-window) + "Ask the XMosaic WWW browser to load URL. +Default to the URL around or before point. + +This function only works for XMosaic version 2.5 or later. You must +select `CCI' from XMosaic's File menu, set the CCI Port Address to the +value of variable `browse-url-CCI-port', and enable `Accept requests'. + +When called interactively, if variable `browse-url-new-window-p' is +non-nil, load the document in a new browser window, otherwise use a +random existing one. A non-nil interactive prefix argument reverses +the effect of `browse-url-new-window-p'. + +When called non-interactively, optional second argument NEW-WINDOW is +used instead of `browse-url-new-window-p'." + (interactive (browse-url-interactive-arg "Mosaic URL: ")) + (open-network-stream "browse-url" " *browse-url*" + browse-url-CCI-host browse-url-CCI-port) + ;; Todo: start browser if fails + (process-send-string "browse-url" + (concat "get url (" url ") output " + (if new-window + "new" + "current") + "\r\n")) + (process-send-string "browse-url" "disconnect\r\n") + (delete-process "browse-url")) + +;; --- IXI Mosaic --- + +;;;###autoload +(defun browse-url-iximosaic (url &optional new-window) + ;; new-window ignored + "Ask the IXIMosaic WWW browser to load URL. +Default to the URL around or before point." + (interactive (browse-url-interactive-arg "IXI Mosaic URL: ")) + (start-process "tellw3b" nil "tellw3b" + "-service WWW_BROWSER ixi_showurl " url)) + +;; --- W3 --- + +;;;###autoload +(defun browse-url-w3 (url &optional new-window) + "Ask the w3 WWW browser to load URL. +Default to the URL around or before point. + +When called interactively, if variable `browse-url-new-window-p' is +non-nil, load the document in a new window. A non-nil interactive +prefix argument reverses the effect of `browse-url-new-window-p'. + +When called non-interactively, optional second argument NEW-WINDOW is +used instead of `browse-url-new-window-p'." + (interactive (browse-url-interactive-arg "W3 URL: ")) + (require 'w3) ; w3-fetch-other-window not autoloaded + (if new-window + (w3-fetch-other-window url) + (w3-fetch url))) + +;;;###autoload +(defun browse-url-w3-gnudoit (url &optional new-window) + ;; new-window ignored + "Ask another Emacs running gnuserv to load the URL using the W3 browser. +The `browse-url-gnudoit-program' program is used with options given by +`browse-url-gnudoit-args'. Default to the URL around or before point." + (interactive (browse-url-interactive-arg "W3 URL: ")) + (apply 'start-process (concat "gnudoit:" url) nil + browse-url-gnudoit-program + (append browse-url-gnudoit-args (list (concat "(w3-fetch \"" url "\")") "(raise-frame)")))) + +;; --- Lynx in an xterm --- + +;;;###autoload +(defun browse-url-lynx-xterm (url &optional new-window) + ;; new-window ignored + "Ask the Lynx WWW browser to load URL. +Default to the URL around or before point. A new Lynx process is run +in an Xterm window using the Xterm program named by `browse-url-xterm-program' +with possible additional arguments `browse-url-xterm-args'." + (interactive (browse-url-interactive-arg "Lynx URL: ")) + (apply #'start-process `(,(concat "lynx" url) nil ,browse-url-xterm-program + ,@browse-url-xterm-args "-e" "lynx" ,url))) + +;; --- Lynx in an Emacs "term" window --- + +;;;###autoload +(defun browse-url-lynx-emacs (url &optional new-buffer) + "Ask the Lynx WWW browser to load URL. +Default to the URL around or before point. With a prefix argument, run +a new Lynx process in a new buffer. + +When called interactively, if variable `browse-url-new-window-p' is +non-nil, load the document in a new lynx in a new term window, +otherwise use any existing one. A non-nil interactive prefix argument +reverses the effect of `browse-url-new-window-p'. + +When called non-interactively, optional second argument NEW-WINDOW is +used instead of `browse-url-new-window-p'." + (interactive (browse-url-interactive-arg "Lynx URL: ")) + (let* ((system-uses-terminfo t) ; Lynx uses terminfo + ;; (term-term-name "vt100") ; ?? + (buf (get-buffer "*lynx*")) + (proc (and buf (get-buffer-process buf))) + (n browse-url-lynx-input-attempts)) + (if (and new-buffer buf) + ;; Rename away the OLD buffer. This isn't very polite, but + ;; term insists on working in a buffer named *lynx* and would + ;; choke on *lynx*<1> + (progn (set-buffer buf) + (rename-uniquely))) + (if (or new-buffer + (not buf) + (not proc) + (not (memq (process-status proc) '(run stop)))) + ;; start a new lynx + (progn + (setq buf + (apply #'make-term + `("lynx" "lynx" nil ,@browse-url-lynx-emacs-args ,url))) + (switch-to-buffer buf) + (term-char-mode) + (set-process-sentinel + (get-buffer-process buf) + ;; Don't leave around a dead one (especially because of its + ;; munged keymap.) + (lambda (process event) + (if (not (memq (process-status process) '(run stop))) + (let ((buf (process-buffer process))) + (if buf (kill-buffer buf))))))) + ;; send the url to lynx in the old buffer + (let ((win (get-buffer-window buf t))) + (if win + (select-window win) + (switch-to-buffer buf))) + (if (eq (following-char) ?_) + (cond ((eq browse-url-lynx-input-field 'warn) + (error "Please move out of the input field first.")) + ((eq browse-url-lynx-input-field 'avoid) + (while (and (eq (following-char) ?_) (> n 0)) + (term-send-down) ; down arrow + (sit-for browse-url-lynx-input-delay)) + (if (eq (following-char) ?_) + (error "Cannot move out of the input field, sorry."))))) + (term-send-string proc (concat "g" ; goto + "\C-u" ; kill default url + url + "\r"))))) + +;; --- MMM --- + +;;;###autoload +(defun browse-url-mmm (url &optional new-window) + "Ask the MMM WWW browser to load URL. +Default to the URL around or before point." + (interactive (browse-url-interactive-arg "MMM URL: ")) + (message "Sending URL to MMM...") + (save-excursion + (set-buffer (get-buffer-create " *Shell Command Output*")) + (erase-buffer) + ;; mmm_remote just SEGVs if the file isn't there... + (if (or (file-exists-p (expand-file-name "~/.mmm_remote")) + ;; location in v 0.4: + (file-exists-p (expand-file-name "~/.mmm/remote"))) + (call-process "mmm_remote" nil 0 nil url) + (call-process "mmm" nil 0 nil "-external" url)) + (message "Sending URL to MMM... done"))) + +;; --- mailto --- + +;;;###autoload +(defun browse-url-mail (url &optional new-window) + "Open a new mail message buffer within Emacs. +Default to using the mailto: URL around or before point as the +recipient's address. Supplying a non-nil interactive prefix argument +will cause the mail to be composed in another window rather than the +current one. + +When called interactively, if variable `browse-url-new-window-p' is +non-nil use `compose-mail-other-window', otherwise `compose-mail'. A +non-nil interactive prefix argument reverses the effect of +`browse-url-new-window-p'. + +When called non-interactively, optional second argument NEW-WINDOW is +used instead of `browse-url-new-window-p'." + (interactive (browse-url-interactive-arg "Mailto URL: ")) + (save-excursion + (let ((to (if (string-match "^mailto:" url) + (substring url 7) + url))) + (if new-window + (compose-mail-other-window to nil nil nil + (list 'insert-buffer (current-buffer))) + (compose-mail to nil nil nil nil + (list 'insert-buffer (current-buffer))))))) + +;; --- Random browser --- + +;;;###autoload +(defun browse-url-generic (url &optional new-window) + ;; new-window ignored + "Ask the WWW browser defined by `browse-url-generic-program' to load URL. +Default to the URL around or before point. A fresh copy of the +browser is started up in a new process with possible additional arguments +`browse-url-generic-args'. This is appropriate for browsers which +don't offer a form of remote control." + (interactive (browse-url-interactive-arg "URL: ")) + (if (not browse-url-generic-program) + (error "No browser defined (`browse-url-generic-program')")) + (apply 'start-process (concat browse-url-generic-program url) nil + browse-url-generic-program + (append browse-url-generic-args (list url)))) + +(provide 'browse-url) + +;;; browse-url.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/goto-addr.el Mon Mar 20 13:12:14 2000 +0000 @@ -0,0 +1,234 @@ +;;; goto-addr.el --- click to browse URL or to send to e-mail address + +;; Copyright (C) 1995 Free Software Foundation, Inc. + +;; Author: Eric Ding <ericding@mit.edu> +;; Maintainer: Eric Ding <ericding@mit.edu> +;; Created: 15 Aug 1995 +;; Keywords: mh-e, www, mouse, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package allows you to click or hit a key sequence while on a +;; URL or e-mail address, and either load the URL into a browser of +;; your choice using the browse-url package, or if it's an e-mail +;; address, to send an e-mail to that address. By default, we bind to +;; the [mouse-2] and the [C-c return] key sequences. + +;; INSTALLATION +;; +;; To use goto-address in a particular mode (for example, while +;; reading mail in mh-e), add something like this in your .emacs file: +;; +;; (add-hook 'mh-show-mode-hook 'goto-address) +;; +;; The mouse click method is bound to [mouse-2] on highlighted URL's or +;; e-mail addresses only; it functions normally everywhere else. To bind +;; another mouse click to the function, add the following to your .emacs +;; (for example): +;; +;; (setq goto-address-highlight-keymap +;; (let ((m (make-sparse-keymap))) +;; (define-key m [S-mouse-2] 'goto-address-at-mouse) +;; m)) +;; + +;; BUG REPORTS +;; +;; Please send bug reports to me at ericding@mit.edu. + +;; Known bugs/features: +;; * goto-address-mail-regexp only catches foo@bar.org style addressing, +;; not stuff like X.400 addresses, etc. +;; * regexp also catches Message-Id line, since it is in the format of +;; an Internet e-mail address (like Compuserve addresses) +;; * If show buffer is fontified after goto-address-fontify is run +;; (say, using font-lock-fontify-buffer), then font-lock face will +;; override goto-address faces. + +;;; Code: + +(require 'browse-url) + +(defgroup goto-address nil + "Click to browse URL or to send to e-mail address." + :group 'mouse + :group 'hypermedia) + + +;;; I don't expect users to want fontify'ing without highlighting. +(defcustom goto-address-fontify-p t + "*If t, URL's and e-mail addresses in buffer are fontified. +But only if `goto-address-highlight-p' is also non-nil." + :type 'boolean + :group 'goto-address) + +(defcustom goto-address-highlight-p t + "*If t, URL's and e-mail addresses in buffer are highlighted." + :type 'boolean + :group 'goto-address) + +(defcustom goto-address-fontify-maximum-size 30000 + "*Maximum size of file in which to fontify and/or highlight URL's." + :type 'integer + :group 'goto-address) + +(defvar goto-address-mail-regexp + "[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" + "A regular expression probably matching an e-mail address.") + +(defvar goto-address-url-regexp + (concat "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|" + "telnet\\|wais\\):\\(//[-a-zA-Z0-9_.]+:" + "[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*" + "[-a-zA-Z0-9_=#$@~`%&*+|\\/]") + "A regular expression probably matching a URL.") + +(defvar goto-address-highlight-keymap + (let ((m (make-sparse-keymap))) + (define-key m [mouse-2] 'goto-address-at-mouse) + m) + "keymap to hold goto-addr's mouse key defs under highlighted URLs.") + +(defcustom goto-address-url-face 'bold + "*Face to use for URLs." + :type 'face + :group 'goto-address) + +(defcustom goto-address-url-mouse-face 'highlight + "*Face to use for URLs when the mouse is on them." + :type 'face + :group 'goto-address) + +(defcustom goto-address-mail-face 'italic + "*Face to use for e-mail addresses." + :type 'face + :group 'goto-address) + +(defcustom goto-address-mail-mouse-face 'secondary-selection + "*Face to use for e-mail addresses when the mouse is on them." + :type 'face + :group 'goto-address) + +(defun goto-address-fontify () + "Fontify the URL's and e-mail addresses in the current buffer. +This function implements `goto-address-highlight-p' +and `goto-address-fontify-p'." + (save-excursion + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t) + (modified (buffer-modified-p))) + (goto-char (point-min)) + (if (< (- (point-max) (point)) goto-address-fontify-maximum-size) + (progn + (while (re-search-forward goto-address-url-regexp nil t) + (let* ((s (match-beginning 0)) + (e (match-end 0)) + (this-overlay (make-overlay s e))) + (and goto-address-fontify-p + (overlay-put this-overlay 'face goto-address-url-face)) + (overlay-put this-overlay + 'mouse-face goto-address-url-mouse-face) + (overlay-put this-overlay + 'local-map goto-address-highlight-keymap))) + (goto-char (point-min)) + (while (re-search-forward goto-address-mail-regexp nil t) + (let* ((s (match-beginning 0)) + (e (match-end 0)) + (this-overlay (make-overlay s e))) + (and goto-address-fontify-p + (overlay-put this-overlay 'face goto-address-mail-face)) + (overlay-put this-overlay 'mouse-face + goto-address-mail-mouse-face) + (overlay-put this-overlay + 'local-map goto-address-highlight-keymap))))) + (and (buffer-modified-p) + (not modified) + (set-buffer-modified-p nil))))) + +;;; code to find and goto addresses; much of this has been blatantly +;;; snarfed from browse-url.el + +;;;###autoload +(defun goto-address-at-mouse (event) + "Send to the e-mail address or load the URL clicked with the mouse. +Send mail to address at position of mouse click. See documentation for +`goto-address-find-address-at-point'. If no address is found +there, then load the URL at or before the position of the mouse click." + (interactive "e") + (save-excursion + (let ((posn (event-start event))) + (set-buffer (window-buffer (posn-window posn))) + (goto-char (posn-point posn)) + (let ((address + (save-excursion (goto-address-find-address-at-point)))) + (if (string-equal address "") + (let ((url (browse-url-url-at-point))) + (if (string-equal url "") + (error "No e-mail address or URL found") + (browse-url url))) + (compose-mail address)))))) + +;;;###autoload +(defun goto-address-at-point () + "Send to the e-mail address or load the URL at point. +Send mail to address at point. See documentation for +`goto-address-find-address-at-point'. If no address is found +there, then load the URL at or before point." + (interactive) + (save-excursion + (let ((address (save-excursion (goto-address-find-address-at-point)))) + (if (string-equal address "") + (let ((url (browse-url-url-at-point))) + (if (string-equal url "") + (error "No e-mail address or URL found") + (browse-url url))) + (compose-mail address))))) + +(defun goto-address-find-address-at-point () + "Find e-mail address around or before point. +Then search backwards to beginning of line for the start of an e-mail +address. If no e-mail address found, return the empty string." + (let ((bol (save-excursion (beginning-of-line) (point)))) + (re-search-backward "[^-_A-z0-9.@]" bol 'lim) + (if (or (looking-at goto-address-mail-regexp) ; already at start + (let ((eol (save-excursion (end-of-line) (point)))) + (and (re-search-forward goto-address-mail-regexp eol 'lim) + (goto-char (match-beginning 0))))) + (buffer-substring (match-beginning 0) (match-end 0)) + "")))m + +;;;###autoload +(defun goto-address () + "Sets up goto-address functionality in the current buffer. +Allows user to use mouse/keyboard command to click to go to a URL +or to send e-mail. +By default, goto-address binds to mouse-2 and C-c RET. + +Also fontifies the buffer appropriately (see `goto-address-fontify-p' and +`goto-address-highlight-p' for more information)." + (interactive) + (local-set-key "\C-c\r" 'goto-address-at-point) + (if goto-address-highlight-p + (goto-address-fontify))) + +(provide 'goto-addr) + +;;; goto-addr.el ends here.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/net-utils.el Mon Mar 20 13:12:14 2000 +0000 @@ -0,0 +1,858 @@ +;;; net-utils.el --- Network functions + +;; Author: Peter Breton <pbreton@cs.umb.edu> +;; Created: Sun Mar 16 1997 +;; Keywords: network communications +;; Time-stamp: <1999-11-13 10:19:01 pbreton> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; There are three main areas of functionality: +;; +;; * Wrap common network utility programs (ping, traceroute, netstat, +;; nslookup, arp, route). Note that these wrappers are of the diagnostic +;; functions of these programs only. +;; +;; * Implement some very basic protocols in Emacs Lisp (finger and whois) +;; +;; * Support connections to HOST/PORT, generally for debugging and the like. +;; In other words, for doing much the same thing as "telnet HOST PORT", and +;; then typing commands. +;; +;; PATHS +;; +;; On some systems, some of these programs are not in normal user path, +;; but rather in /sbin, /usr/sbin, and so on. + + +;;; Code: +(eval-when-compile + (require 'comint)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Customization Variables +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgroup net-utils nil + "Network utility functions." + :prefix "net-utils-" + :group 'comm + :version "20.3" + ) + +(defcustom net-utils-remove-ctl-m + (member system-type (list 'windows-nt 'msdos)) + "If non-nil, remove control-Ms from output." + :group 'net-utils + :type 'boolean + ) + +(defcustom traceroute-program + (if (eq system-type 'windows-nt) + "tracert" + "traceroute") + "Program to trace network hops to a destination." + :group 'net-utils + :type 'string + ) + +(defcustom traceroute-program-options nil + "Options for the traceroute program." + :group 'net-utils + :type '(repeat string) + ) + +(defcustom ping-program "ping" + "Program to send network test packets to a host." + :group 'net-utils + :type 'string + ) + +;; On Linux and Irix, the system's ping program seems to send packets +;; indefinitely unless told otherwise +(defcustom ping-program-options + (and (memq system-type (list 'linux 'gnu/linux 'irix)) + (list "-c" "4")) + "Options for the ping program. +These options can be used to limit how many ICMP packets are emitted." + :group 'net-utils + :type '(repeat string) + ) + +(defcustom ipconfig-program + (if (eq system-type 'windows-nt) + "ipconfig" + "ifconfig") + "Program to print network configuration information." + :group 'net-utils + :type 'string + ) + +(defcustom ipconfig-program-options + (list + (if (eq system-type 'windows-nt) + "/all" "-a")) + "Options for ipconfig-program." + :group 'net-utils + :type '(repeat string) + ) + +(defcustom netstat-program "netstat" + "Program to print network statistics." + :group 'net-utils + :type 'string + ) + +(defcustom netstat-program-options + (list "-a") + "Options for netstat-program." + :group 'net-utils + :type '(repeat string) + ) + +(defcustom arp-program "arp" + "Program to print IP to address translation tables." + :group 'net-utils + :type 'string + ) + +(defcustom arp-program-options + (list "-a") + "Options for arp-program." + :group 'net-utils + :type '(repeat string) + ) + +(defcustom route-program + (if (eq system-type 'windows-nt) + "route" + "netstat") + "Program to print routing tables." + :group 'net-utils + :type 'string + ) + +(defcustom route-program-options + (if (eq system-type 'windows-nt) + (list "print") + (list "-r")) + "Options for route-program." + :group 'net-utils + :type '(repeat string) + ) + +(defcustom nslookup-program "nslookup" + "Program to interactively query DNS information." + :group 'net-utils + :type 'string + ) + +(defcustom nslookup-program-options nil + "List of options to pass to the nslookup program." + :group 'net-utils + :type '(repeat string) + ) + +(defcustom nslookup-prompt-regexp "^> " + "Regexp to match the nslookup prompt." + :group 'net-utils + :type 'regexp + ) + +(defcustom dig-program "dig" + "Program to query DNS information." + :group 'net-utils + :type 'string + ) + +(defcustom ftp-program "ftp" + "Progam to run to do FTP transfers." + :group 'net-utils + :type 'string + ) + +(defcustom ftp-program-options nil + "List of options to pass to the FTP program." + :group 'net-utils + :type '(repeat string) + ) + +(defcustom ftp-prompt-regexp "^ftp>" + "Regexp which matches the FTP program's prompt." + :group 'net-utils + :type 'regexp + ) + +(defcustom smbclient-program "smbclient" + "Smbclient program." + :group 'net-utils + :type 'string + ) + +(defcustom smbclient-program-options nil + "List of options to pass to the smbclient program." + :group 'net-utils + :type '(repeat string) + ) + +(defcustom smbclient-prompt-regexp "^smb: \>" + "Regexp which matches the smbclient program's prompt." + :group 'net-utils + :type 'regexp + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Nslookup goodies +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst nslookup-font-lock-keywords + (and window-system + (progn + (require 'font-lock) + (list + (list nslookup-prompt-regexp 0 font-lock-reference-face) + (list "^[A-Za-z0-9 _]+:" 0 font-lock-type-face) + (list "\\<\\(SOA\\|NS\\|MX\\|A\\|CNAME\\)\\>" + 1 font-lock-keyword-face) + ;; Dotted quads + (list + (mapconcat 'identity + (make-list 4 "[0-9]+") + "\\.") + 0 font-lock-variable-name-face) + ;; Host names + (list + (let ((host-expression "[-A-Za-z0-9]+")) + (concat + (mapconcat 'identity + (make-list 2 host-expression) + "\\.") + "\\(\\." host-expression "\\)*") + ) + 0 font-lock-variable-name-face) + ))) + "Expressions to font-lock for nslookup.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; FTP goodies +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst ftp-font-lock-keywords + (and window-system + (progn + (require 'font-lock) + (list + (list ftp-prompt-regexp 0 font-lock-reference-face))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; smbclient goodies +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst smbclient-font-lock-keywords + (and window-system + (progn + (require 'font-lock) + (list + (list smbclient-prompt-regexp 0 font-lock-reference-face))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utility functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Simplified versions of some at-point functions from ffap.el. +;; It's not worth loading all of ffap just for these. +(defun net-utils-machine-at-point () + (let ((pt (point))) + (buffer-substring-no-properties + (save-excursion + (skip-chars-backward "-a-zA-Z0-9.") + (point)) + (save-excursion + (skip-chars-forward "-a-zA-Z0-9.") + (skip-chars-backward "." pt) + (point))))) + +(defun net-utils-url-at-point () + (let ((pt (point))) + (buffer-substring-no-properties + (save-excursion + (skip-chars-backward "--:=&?$+@-Z_a-z~#,%") + (skip-chars-forward "^A-Za-z0-9" pt) + (point)) + (save-excursion + (skip-chars-forward "--:=&?$+@-Z_a-z~#,%") + (skip-chars-backward ":;.,!?" pt) + (point))))) + + +(defun net-utils-remove-ctrl-m-filter (process output-string) + "Remove trailing control Ms." + (let ((old-buffer (current-buffer)) + (filtered-string output-string)) + (unwind-protect + (let ((moving)) + (set-buffer (process-buffer process)) + (setq moving (= (point) (process-mark process))) + + (while (string-match "\r" filtered-string) + (setq filtered-string + (replace-match "" nil nil filtered-string))) + + (save-excursion + ;; Insert the text, moving the process-marker. + (goto-char (process-mark process)) + (insert filtered-string) + (set-marker (process-mark process) (point))) + (if moving (goto-char (process-mark process)))) + (set-buffer old-buffer)))) + +(defmacro net-utils-run-program (name header program &rest args) + "Run a network information program." + ` (let ((buf (get-buffer-create (concat "*" ,name "*")))) + (set-buffer buf) + (erase-buffer) + (insert ,header "\n") + (set-process-filter + (apply 'start-process ,name buf ,program ,@args) + 'net-utils-remove-ctrl-m-filter) + (display-buffer buf))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Wrappers for external network programs +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;###autoload +(defun traceroute (target) + "Run traceroute program for TARGET." + (interactive "sTarget: ") + (let ((options + (if traceroute-program-options + (append traceroute-program-options (list target)) + (list target)))) + (net-utils-run-program + (concat "Traceroute" " " target) + (concat "** Traceroute ** " traceroute-program " ** " target) + traceroute-program + options + ))) + +;;;###autoload +(defun ping (host) + "Ping HOST. +If your system's ping continues until interrupted, you can try setting +`ping-program-options'." + (interactive + (list (read-from-minibuffer "Ping host: " (net-utils-machine-at-point)))) + (let ((options + (if ping-program-options + (append ping-program-options (list host)) + (list host)))) + (net-utils-run-program + (concat "Ping" " " host) + (concat "** Ping ** " ping-program " ** " host) + ping-program + options + ))) + +;;;###autoload +(defun ipconfig () + "Run ipconfig program." + (interactive) + (net-utils-run-program + "Ipconfig" + (concat "** Ipconfig ** " ipconfig-program " ** ") + ipconfig-program + ipconfig-program-options + )) + +;; This is the normal name on most Unixes. +;;;###autoload +(defalias 'ifconfig 'ipconfig) + +;;;###autoload +(defun netstat () + "Run netstat program." + (interactive) + (net-utils-run-program + "Netstat" + (concat "** Netstat ** " netstat-program " ** ") + netstat-program + netstat-program-options + )) + +;;;###autoload +(defun arp () + "Run the arp program." + (interactive) + (net-utils-run-program + "Arp" + (concat "** Arp ** " arp-program " ** ") + arp-program + arp-program-options + )) + +;;;###autoload +(defun route () + "Run the route program." + (interactive) + (net-utils-run-program + "Route" + (concat "** Route ** " route-program " ** ") + route-program + route-program-options + )) + +;; FIXME -- Needs to be a process filter +;; (defun netstat-with-filter (filter) +;; "Run netstat program." +;; (interactive "sFilter: ") +;; (netstat) +;; (set-buffer (get-buffer "*Netstat*")) +;; (goto-char (point-min)) +;; (delete-matching-lines filter) +;; ) + +;;;###autoload +(defun nslookup-host (host) + "Lookup the DNS information for HOST." + (interactive + (list (read-from-minibuffer "Lookup host: " (net-utils-machine-at-point)))) + (let ((options + (if nslookup-program-options + (append nslookup-program-options (list host)) + (list host)))) + (net-utils-run-program + "Nslookup" + (concat "** " + (mapconcat 'identity + (list "Nslookup" host nslookup-program) + " ** ")) + nslookup-program + options + ))) + + +;;;###autoload +(defun nslookup () + "Run nslookup program." + (interactive) + (require 'comint) + (comint-run nslookup-program) + (set-process-filter (get-buffer-process "*nslookup*") + 'net-utils-remove-ctrl-m-filter) + (nslookup-mode) + ) + +;; Using a derived mode gives us keymaps, hooks, etc. +(define-derived-mode + nslookup-mode comint-mode "Nslookup" + "Major mode for interacting with the nslookup program." + (set + (make-local-variable 'font-lock-defaults) + '((nslookup-font-lock-keywords))) + (setq local-abbrev-table nslookup-mode-abbrev-table) + (abbrev-mode t) + (make-local-variable 'comint-prompt-regexp) + (setq comint-prompt-regexp nslookup-prompt-regexp) + (make-local-variable 'comint-input-autoexpand) + (setq comint-input-autoexpand t) + ) + +(define-key nslookup-mode-map "\t" 'comint-dynamic-complete) + +(define-abbrev nslookup-mode-abbrev-table "e" "exit") +(define-abbrev nslookup-mode-abbrev-table "f" "finger") +(define-abbrev nslookup-mode-abbrev-table "h" "help") +(define-abbrev nslookup-mode-abbrev-table "lse" "lserver") +(define-abbrev nslookup-mode-abbrev-table "q" "exit") +(define-abbrev nslookup-mode-abbrev-table "r" "root") +(define-abbrev nslookup-mode-abbrev-table "s" "set") +(define-abbrev nslookup-mode-abbrev-table "se" "server") +(define-abbrev nslookup-mode-abbrev-table "v" "viewer") + +;;;###autoload +(defun dig (host) + "Run dig program." + (interactive + (list + (progn + (require 'ffap) + (read-from-minibuffer + "Lookup host: " + (or (ffap-string-at-point 'machine) ""))))) + (net-utils-run-program + "Dig" + (concat "** " + (mapconcat 'identity + (list "Dig" host dig-program) + " ** ")) + dig-program + (list host) + )) + +;; This is a lot less than ange-ftp, but much simpler. +;;;###autoload +(defun ftp (host) + "Run ftp program." + (interactive + (list + (read-from-minibuffer + "Ftp to Host: " (net-utils-machine-at-point)))) + (require 'comint) + (let ((buf (get-buffer-create (concat "*ftp [" host "]*")))) + (set-buffer buf) + (comint-mode) + (comint-exec buf (concat "ftp-" host) ftp-program nil + (if ftp-program-options + (append (list host) ftp-program-options) + (list host))) + (ftp-mode) + (switch-to-buffer-other-window buf) + )) + +(define-derived-mode + ftp-mode comint-mode "FTP" + "Major mode for interacting with the ftp program." + + (set + (make-local-variable 'font-lock-defaults) + '((ftp-font-lock-keywords))) + + (make-local-variable 'comint-prompt-regexp) + (setq comint-prompt-regexp ftp-prompt-regexp) + + (make-local-variable 'comint-input-autoexpand) + (setq comint-input-autoexpand t) + + ;; Already buffer local! + (setq comint-output-filter-functions + (list 'comint-watch-for-password-prompt)) + + (setq local-abbrev-table ftp-mode-abbrev-table) + (abbrev-mode t) + ) + +(define-abbrev ftp-mode-abbrev-table "q" "quit") +(define-abbrev ftp-mode-abbrev-table "g" "get") +(define-abbrev ftp-mode-abbrev-table "p" "prompt") +(define-abbrev ftp-mode-abbrev-table "anon" "anonymous") + +;; Occasionally useful +(define-key ftp-mode-map "\t" 'comint-dynamic-complete) + +(defun smbclient (host service) + "Connect to SERVICE on HOST via SMB." + (interactive + (list + (read-from-minibuffer + "Connect to Host: " (net-utils-machine-at-point)) + (read-from-minibuffer "SMB Service: "))) + (require 'comint) + (let* ((name (format "smbclient [%s\\%s]" host service)) + (buf (get-buffer-create (concat "*" name "*"))) + (service-name (concat "\\\\" host "\\" service))) + (set-buffer buf) + (comint-mode) + (comint-exec buf name smbclient-program nil + (if smbclient-program-options + (append (list service-name) smbclient-program-options) + (list service-name))) + (smbclient-mode) + (switch-to-buffer-other-window buf) + )) + +(defun smbclient-list-shares (host) + "List services on HOST." + (interactive + (list + (read-from-minibuffer + "Connect to Host: " (net-utils-machine-at-point)) + )) + (let ((buf (get-buffer-create (format "*SMB Shares on %s*" host)))) + (set-buffer buf) + (comint-mode) + (comint-exec + buf + "smbclient-list-shares" + smbclient-program + nil + (list "-L" host) + ) + (smbclient-mode) + (switch-to-buffer-other-window buf))) + +(define-derived-mode + smbclient-mode comint-mode "smbclient" + "Major mode for interacting with the smbclient program." + + (set + (make-local-variable 'font-lock-defaults) + '((smbclient-font-lock-keywords))) + + (make-local-variable 'comint-prompt-regexp) + (setq comint-prompt-regexp smbclient-prompt-regexp) + + (make-local-variable 'comint-input-autoexpand) + (setq comint-input-autoexpand t) + + ;; Already buffer local! + (setq comint-output-filter-functions + (list 'comint-watch-for-password-prompt)) + + (setq local-abbrev-table smbclient-mode-abbrev-table) + (abbrev-mode t) + ) + +(define-abbrev smbclient-mode-abbrev-table "q" "quit") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Network Connections +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Full list is available at: +;; ftp://ftp.isi.edu/in-notes/iana/assignments/port-numbers +(defvar network-connection-service-alist + (list + (cons 'echo 7) + (cons 'active-users 11) + (cons 'daytime 13) + (cons 'chargen 19) + (cons 'ftp 21) + (cons 'telnet 23) + (cons 'smtp 25) + (cons 'time 37) + (cons 'whois 43) + (cons 'gopher 70) + (cons 'finger 79) + (cons 'www 80) + (cons 'pop2 109) + (cons 'pop3 110) + (cons 'sun-rpc 111) + (cons 'nntp 119) + (cons 'ntp 123) + (cons 'netbios-name 137) + (cons 'netbios-data 139) + (cons 'irc 194) + (cons 'https 443) + (cons 'rlogin 513) + ) + "Alist of services and associated TCP port numbers. +This list in not complete.") + +;; Workhorse macro +(defmacro run-network-program (process-name host port + &optional initial-string) + ` + (let ((tcp-connection) + (buf) + ) + (setq buf (get-buffer-create (concat "*" ,process-name "*"))) + (set-buffer buf) + (or + (setq tcp-connection + (open-network-stream + ,process-name + buf + ,host + ,port + )) + (error "Could not open connection to %s" ,host)) + (erase-buffer) + (set-marker (process-mark tcp-connection) (point-min)) + (set-process-filter tcp-connection 'net-utils-remove-ctrl-m-filter) + (and ,initial-string + (process-send-string tcp-connection + (concat ,initial-string "\r\n"))) + (display-buffer buf))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Simple protocols +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Finger protocol +;;;###autoload +(defun finger (user host) + "Finger USER on HOST." + ;; One of those great interactive statements that's actually + ;; longer than the function call! The idea is that if the user + ;; uses a string like "pbreton@cs.umb.edu", we won't ask for the + ;; host name. If we don't see an "@", we'll prompt for the host. + (interactive + (let* ((answer (read-from-minibuffer "Finger User: " + (net-utils-url-at-point))) + (index (string-match (regexp-quote "@") answer))) + (if index + (list + (substring answer 0 index) + (substring answer (1+ index))) + (list + answer + (read-from-minibuffer "At Host: " (net-utils-machine-at-point)))))) + (let* ( + (user-and-host (concat user "@" host)) + (process-name + (concat "Finger [" user-and-host "]")) + ) + (run-network-program + process-name + host + (cdr (assoc 'finger network-connection-service-alist)) + user-and-host + ))) + +(defcustom whois-server-name "rs.internic.net" + "Default host name for the whois service." + :group 'net-utils + :type 'string + ) + +(defcustom whois-server-list + '(("whois.arin.net") ; Networks, ASN's, and related POC's (numbers) + ("rs.internic.net") ; domain related info + ("whois.abuse.net") + ("whois.apnic.net") + ("nic.ddn.mil") + ("whois.nic.mil") + ("whois.nic.gov") + ("whois.ripe.net")) + "A list of whois servers that can be queried." + :group 'net-utils + :type '(repeat (list string))) + +(defcustom whois-server-tld + '(("rs.internic.net" . "com") + ("rs.internic.net" . "org") + ("whois.ripe.net" . "be") + ("whois.ripe.net" . "de") + ("whois.ripe.net" . "dk") + ("whois.ripe.net" . "it") + ("whois.ripe.net" . "fi") + ("whois.ripe.net" . "fr") + ("whois.ripe.net" . "uk") + ("whois.apnic.net" . "au") + ("whois.apnic.net" . "ch") + ("whois.apnic.net" . "hk") + ("whois.apnic.net" . "jp") + ("whois.nic.gov" . "gov") + ("whois.nic.mil" . "mil")) + "Alist to map top level domains to whois servers." + :group 'net-utils + :type '(repeat (cons string string))) + +(defcustom whois-guess-server t + "If non-nil then whois will try to deduce the appropriate whois +server from the query. If the query doesn't look like a domain or hostname +then the server named by whois-server-name is used." + :group 'net-utils + :type 'boolean) + +(defun whois-get-tld (host) + "Return the top level domain of `host', or nil if it isn't a domain name." + (let ((i (1- (length host))) + (max-len (- (length host) 5))) + (while (not (or (= i max-len) (char-equal (aref host i) ?.))) + (setq i (1- i))) + (if (= i max-len) + nil + (substring host (1+ i))))) + +;; Whois protocol +;;;###autoload +(defun whois (arg search-string) + "Send SEARCH-STRING to server defined by the `whois-server-name' variable. +If `whois-guess-server' is non-nil, then try to deduce the correct server +from SEARCH-STRING. With argument, prompt for whois server." + (interactive "P\nsWhois: ") + (let* ((whois-apropos-host (if whois-guess-server + (rassoc (whois-get-tld search-string) + whois-server-tld) + nil)) + (server-name (if whois-apropos-host + (car whois-apropos-host) + whois-server-name)) + (host + (if arg + (completing-read "Whois server name: " + whois-server-list nil nil "whois.") + server-name))) + (run-network-program + "Whois" + host + (cdr (assoc 'whois network-connection-service-alist)) + search-string + ))) + +(defcustom whois-reverse-lookup-server "whois.arin.net" + "Server which provides inverse DNS mapping." + :group 'net-utils + :type 'string + ) + +;;;###autoload +(defun whois-reverse-lookup () + (interactive) + (let ((whois-server-name whois-reverse-lookup-server)) + (call-interactively 'whois))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; General Network connection +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;###autoload +(defun network-connection-to-service (host service) + "Open a network connection to SERVICE on HOST." + (interactive + (list + (read-from-minibuffer "Host: " (net-utils-machine-at-point)) + (completing-read "Service: " + (mapcar + (function + (lambda (elt) + (list (symbol-name (car elt))))) + network-connection-service-alist)))) + (network-connection + host + (cdr (assoc (intern service) network-connection-service-alist))) + ) + +;;;###autoload +(defun network-connection (host port) + "Open a network connection to HOST on PORT." + (interactive "sHost: \nnPort: ") + (network-service-connection host (number-to-string port))) + +(defun network-service-connection (host service) + "Open a network connection to SERVICE on HOST." + (require 'comint) + (let ( + (process-name (concat "Network Connection [" host " " service "]")) + (portnum (string-to-number service)) + ) + (or (zerop portnum) (setq service portnum)) + (make-comint + process-name + (cons host service)) + (pop-to-buffer (get-buffer (concat "*" process-name "*"))) + )) + +(provide 'net-utils) + +;;; net-utils.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/quickurl.el Mon Mar 20 13:12:14 2000 +0000 @@ -0,0 +1,552 @@ +;;; quickurl.el --- Insert an URL based on text at point in buffer. + +;; Copyright (C) 1999 Free Software Foundation, Inc. + +;; Author: Dave Pearson <davep@hagbard.demon.co.uk> +;; Maintainer: Dave Pearson <davep@hagbard.demon.co.uk> +;; Created: 1999-05-28 +;; Keywords: hypermedia + +;; This file is part of GNU emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; This package provides a simple method of inserting an URL based on the +;; text at point in the current buffer. This is part of an on-going effort +;; to increase the information I provide people while reducing the ammount +;; of typing I need to do. No-doubt there are undiscovered Emacs packages +;; out there that do all of this and do it better, feel free to point me to +;; them, in the mean time I'm having fun playing with Emacs Lisp. +;; +;; The URLs are stored in an external file as a list of either cons cells, +;; or lists. A cons cell entry looks like this: +;; +;; (<Lookup> . <URL>) +;; +;; where <Lookup> is a string that acts as the keyword lookup and <URL> is +;; the URL associated with it. An example might be: +;; +;; ("GNU" . "http://www.gnu.org/") +;; +;; A list entry looks like: +;; +;; (<Lookup> <URL> <Comment>) +;; +;; where <Lookup> and <URL> are the same as with the cons cell and <Comment> +;; is any text you like that describes the URL. This description will be +;; used when presenting a list of URLS using `quickurl-list'. An example +;; might be: +;; +;; ("FSF" "http://www.fsf.org/" "The Free Software Foundation") +;; +;; Given the above, your quickurl file might look like: +;; +;; (("GNU" . "http://www.gnu.org/") +;; ("FSF" "http://www.fsf.org/" "The Free Software Foundation") +;; ("emacs" . "http://www.emacs.org/") +;; ("hagbard" "http://www.hagbard.demon.co.uk" "Hagbard's World")) +;; +;; In case you're wondering about the mixture of cons cells and lists, +;; quickurl started life using just the cons cells, there were no comments. +;; URL comments are a later addition and so there is a mixture to keep +;; backward compatibility with existing URL lists. +;; +;; The name and location of the file is up to you, the default name used by +;; `quickurl' is stored in `quickurl-url-file'. +;; +;; quickurl is always available from: +;; +;; <URL:http://www.hagbard.demon.co.uk/archives/quickurl.el> +;; <URL:http://www.acemake.com/hagbard/archives/quickurl.el> + +;;; TODO: +;; +;; o The quickurl-browse-url* functions pretty much duplicate their non +;; browsing friends. It would feel better if a more generic solution could +;; be found. + +;;; Code: + +;; Things we need: + +(eval-when-compile + (require 'cl)) +(require 'thingatpt) +(require 'pp) +(require 'browse-url) + +;; Attempt to handle older/other emacs. +(eval-and-compile + ;; If customize isn't available just use defvar instead. + (unless (fboundp 'defgroup) + (defmacro defgroup (&rest rest) nil) + (defmacro defcustom (symbol init docstring &rest rest) + `(defvar ,symbol ,init ,docstring)))) + +;; Customize options. + +(defgroup quickurl nil + "Insert an URL based on text at point in buffer." + :version "21.1" + :group 'abbrev + :prefix "quickurl-") + +(defcustom quickurl-url-file "~/.quickurls" + "*File that contains the URL list." + :type 'file + :group 'quickurl) + +(defcustom quickurl-format-function (lambda (url) (format "<URL:%s>" url)) + "*Function to format the URL before insertion into the current buffer." + :type 'function + :group 'quickurl) + +(defcustom quickurl-sort-function (lambda (list) + (sort list + (lambda (x y) + (string< + (downcase (quickurl-url-description x)) + (downcase (quickurl-url-description y)))))) + "*Function to sort the URL list." + :type 'function + :group 'quickurl) + +(defcustom quickurl-grab-lookup-function #'current-word + "*Function to grab the thing to lookup." + :type 'function + :group 'quickurl) + +(defcustom quickurl-assoc-function #'assoc-ignore-case + "*Function to use for alist lookup into `quickurl-urls'." + :type 'function + :group 'quickurl) + +(defcustom quickurl-completion-ignore-case t + "*Should `quickurl-ask' ignore case when doing the input lookup?" + :type 'boolean + :group 'quickurl) + +(defcustom quickurl-prefix ";; -*- lisp -*-\n\n" + "*Text to write to `quickurl-url-file' before writing the URL list." + :type 'string + :group 'quickurl) + +(defcustom quickurl-postfix "" + "*Text to write to `quickurl-url-file' after writing the URL list. + +See the constant `quickurl-reread-hook-postfix' for some example text that +could be used here." + :type 'string + :group 'quickurl) + +(defcustom quickurl-list-mode-hook nil + "*Hooks for `quickurl-list-mode'." + :type 'hook + :group 'quickurl) + +;; Constants. + +;;;###autoload +(defconst quickurl-reread-hook-postfix + " +;; Local Variables: +;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil))) +;; End: +" + "Example `quickurl-postfix' text that adds a local variable to the +`quickurl-url-file' so that if you edit it by hand it will ensure that +`quickurl-urls' is updated with the new URL list. + +To make use of this do something like: + + (setq quickurl-postfix quickurl-reread-hook-postfix) + +in your ~/.emacs (after loading/requiring quickurl).") + +;; Non-customize variables. + +(defvar quickurl-urls nil + "URL alist for use with `quickurl' and `quickurl-ask'.") + +(defvar quickurl-list-mode-map nil + "Local keymap for a `quickurl-list-mode' buffer.") + +(defvar quickurl-list-buffer-name "*quickurl-list*" + "Name for the URL listinig buffer.") + +(defvar quickurl-list-last-buffer nil + "`current-buffer' when `quickurl-list' was called.") + +;; Functions for working with an URL entry. + +(defun quickurl-url-commented-p (url) + "Does the URL have a comment?" + (listp (cdr url))) + +(defun quickurl-make-url (keyword url &optional comment) + "Create an URL from KEYWORD, URL and (optionaly) COMMENT." + (if (and comment (not (zerop (length comment)))) + (list keyword url comment) + (cons keyword url))) + +(defun quickurl-url-keyword (url) + "Return the keyword for the URL. + +Note that this function is a setfable place." + (car url)) + +(defsetf quickurl-url-keyword (url) (store) + `(setf (car ,url) ,store)) + +(defun quickurl-url-url (url) + "Return the actual URL of the URL. + +Note that this function is a setfable place." + (if (quickurl-url-commented-p url) + (cadr url) + (cdr url))) + +(defsetf quickurl-url-url (url) (store) + ` + (if (quickurl-url-commented-p ,url) + (setf (cadr ,url) ,store) + (setf (cdr ,url) ,store))) + +(defun quickurl-url-comment (url) + "Get the comment from an URL. + +If the URL has no comment an empty string is returned. Also note that this +function is a setfable place." + (if (quickurl-url-commented-p url) + (nth 2 url) + "")) + +(defsetf quickurl-url-comment (url) (store) + ` + (if (quickurl-url-commented-p ,url) + (if (zerop (length ,store)) + (setf (cdr ,url) (cadr ,url)) + (setf (nth 2 ,url) ,store)) + (unless (zerop (length ,store)) + (setf (cdr ,url) (list (cdr ,url) ,store))))) + +(defun quickurl-url-description (url) + "Return a description for the URL. + +If the URL has a comment then this is returned, otherwise the keyword is +returned." + (let ((desc (quickurl-url-comment url))) + (if (zerop (length desc)) + (quickurl-url-keyword url) + desc))) + +;; Main code: + +(defun* quickurl-read (&optional (buffer (current-buffer))) + "`read' the URL list from BUFFER into `quickurl-urls'. + +Note that this function moves point to `point-min' before doing the `read' +It also restores point after the `read'." + (save-excursion + (setf (point) (point-min)) + (setq quickurl-urls (funcall quickurl-sort-function (read buffer))))) + +(defun quickurl-load-urls () + "Load the contents of `quickurl-url-file' into `quickurl-urls'." + (when (file-exists-p quickurl-url-file) + (with-temp-buffer + (insert-file-contents quickurl-url-file) + (quickurl-read)))) + +(defun quickurl-save-urls () + "Save the contents of `quickurl-urls' to `quickurl-url-file'." + (with-temp-buffer + (let ((standard-output (current-buffer))) + (princ quickurl-prefix) + (pp quickurl-urls) + (princ quickurl-postfix) + (write-region (point-min) (point-max) quickurl-url-file nil 0)))) + +(defun quickurl-find-url (lookup) + "Return URL associated with key LOOKUP. + +The lookup is done by looking in the alist `quickurl-urls' and the `cons' +for the URL is returned. The actual method used to look into the alist +depends on the setting of the variable `quickurl-assoc-function'." + (funcall quickurl-assoc-function lookup quickurl-urls)) + +(defun quickurl-insert (url &optional silent) + "Insert URL, formatted using `quickurl-format-function'. + +Also display a `message' saying what the URL was unless SILENT is non-nil." + (insert (funcall quickurl-format-function (quickurl-url-url url))) + (unless silent + (message "Found %s" (quickurl-url-url url)))) + +;;;###autoload +(defun* quickurl (&optional (lookup (funcall quickurl-grab-lookup-function))) + "Insert an URL based on LOOKUP. + +If not supplied LOOKUP is taken to be the word at point in the current +buffer, this default action can be modifed via +`quickurl-grab-lookup-function'." + (interactive) + (when lookup + (quickurl-load-urls) + (let ((url (quickurl-find-url lookup))) + (if (null url) + (error "No URL associated with \"%s\"" lookup) + (when (looking-at "\\w") + (skip-syntax-forward "\\w")) + (insert " ") + (quickurl-insert url))))) + +;;;###autoload +(defun quickurl-ask (lookup) + "Insert an URL, with `completing-read' prompt, based on LOOKUP." + (interactive + (list + (progn + (quickurl-load-urls) + (let ((completion-ignore-case quickurl-completion-ignore-case)) + (completing-read "Lookup: " quickurl-urls nil t))))) + (let ((url (quickurl-find-url lookup))) + (when url + (quickurl-insert url)))) + +(defun quickurl-grab-url () + "Attempt to grab a word/url pair from point in the current buffer. + +Point should be somewhere on the URL and the word is taken to be the thing +that is returned from calling `quickurl-grab-lookup-function' once a +`backward-word' has been issued at the start of the URL. + +It is assumed that the URL is either \"unguarded\" or is wrapped inside an +<URL:...> wrapper." + (let ((url (thing-at-point 'url))) + (when url + (save-excursion + (beginning-of-thing 'url) + ;; `beginning-of-thing' doesn't take you to the start of a marked-up + ;; URL, only to the start of the URL within the "markup". So, we + ;; need to do a little more work to get to where we want to be. + (when (thing-at-point-looking-at thing-at-point-markedup-url-regexp) + (search-backward "<URL:")) + (backward-word 1) + (let ((word (funcall quickurl-grab-lookup-function))) + (when word + (quickurl-make-url + ;; The grab function may return the word with properties. I don't + ;; want the properties. I couldn't find a method of stripping + ;; them from a "string" so this will have to do. If you know of + ;; a better method of doing this I'd love to know. + (with-temp-buffer + (insert word) + (buffer-substring-no-properties (point-min) (point-max))) + url))))))) + +;;;###autoload +(defun quickurl-add-url (word url comment) + "Allow the user to interactively add a new URL associated with WORD. + +See `quickurl-grab-url' for details on how the default word/url combination +is decided." + (interactive (let ((word-url (quickurl-grab-url))) + (list (read-string "Word: " (quickurl-url-keyword word-url)) + (read-string "URL: " (quickurl-url-url word-url)) + (read-string "Comment: " (quickurl-url-comment word-url))))) + (if (zerop (length word)) + (error "You must specify a WORD for lookup") + (quickurl-load-urls) + (let* ((current-url (quickurl-find-url word)) + (add-it (if current-url + (if (interactive-p) + (y-or-n-p (format "\"%s\" exists, replace URL? " word)) + t) + t))) + (when add-it + (if current-url + (progn + (setf (quickurl-url-url current-url) url) + (setf (quickurl-url-comment current-url) comment)) + (push (quickurl-make-url word url comment) quickurl-urls)) + (setq quickurl-urls (funcall quickurl-sort-function quickurl-urls)) + (quickurl-save-urls) + (when (get-buffer quickurl-list-buffer-name) + (quickurl-list-populate-buffer)) + (when (interactive-p) + (message "Added %s" url)))))) + +;;;###autoload +(defun* quickurl-browse-url (&optional (lookup (funcall quickurl-grab-lookup-function))) + "Browse the URL associated with LOOKUP. + +If not supplied LOOKUP is taken to be the word at point in the +current buffer, this default action can be modifed via +`quickurl-grab-lookup-function'." + (interactive) + (when lookup + (quickurl-load-urls) + (let ((url (quickurl-find-url lookup))) + (if url + (browse-url (quickurl-url-url url)) + (error "No URL associated with \"%s\"" lookup))))) + +;;;###autoload +(defun quickurl-browse-url-ask (lookup) + "Browse the URL, with `completing-read' prompt, associated with LOOKUP." + (interactive (list + (progn + (quickurl-load-urls) + (completing-read "Browse: " quickurl-urls nil t)))) + (let ((url (quickurl-find-url lookup))) + (when url + (browse-url (quickurl-url-url url))))) + +;;;###autoload +(defun quickurl-edit-urls () + "Pull `quickurl-url-file' into a buffer for hand editing." + (interactive) + (find-file quickurl-url-file)) + +;; quickurl-list mode. + +(unless quickurl-list-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map t) + (define-key map "a" #'quickurl-list-add-url) + (define-key map [(control m)] #'quickurl-list-insert-url) + (define-key map "u" #'quickurl-list-insert-naked-url) + (define-key map " " #'quickurl-list-insert-with-lookup) + (define-key map "l" #'quickurl-list-insert-lookup) + (define-key map "d" #'quickurl-list-insert-with-desc) + (define-key map [(control g)] #'quickurl-list-quit) + (define-key map "q" #'quickurl-list-quit) + (define-key map [mouse-2] #'quickurl-list-mouse-select) + (define-key map "?" #'describe-mode) + (setq quickurl-list-mode-map map))) + +(put 'quickurl-list-mode 'mode-class 'special) + +;;;###autoload +(defun quickurl-list-mode () + "A mode for browsing the quickurl URL list. + +The key bindings for `quickurl-list-mode' are: + +\\{quickurl-list-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map quickurl-list-mode-map) + (setq major-mode 'quickurl-list-mode + mode-name "quickurl list") + (run-hooks 'quickurl-list-mode-hook) + (setq buffer-read-only t + truncate-lines t)) + +;;;###autoload +(defun quickurl-list () + "Display `quickurl-list' as a formatted list using `quickurl-list-mode'." + (interactive) + (quickurl-load-urls) + (unless (string= (buffer-name) quickurl-list-buffer-name) + (setq quickurl-list-last-buffer (current-buffer))) + (pop-to-buffer quickurl-list-buffer-name) + (quickurl-list-populate-buffer) + (quickurl-list-mode)) + +(defun quickurl-list-populate-buffer () + "Populate the `quickurl-list' buffer." + (with-current-buffer (get-buffer quickurl-list-buffer-name) + (let ((buffer-read-only nil) + (fmt (format "%%-%ds %%s\n" + (apply #'max (or (loop for url in quickurl-urls + collect (length (quickurl-url-description url))) + (list 20)))))) + (setf (buffer-string) "") + (loop for url in quickurl-urls + do (let ((start (point))) + (insert (format fmt (quickurl-url-description url) + (quickurl-url-url url))) + (put-text-property start (1- (point)) + 'mouse-face 'highlight))) + (setf (point) (point-min))))) + +(defun quickurl-list-add-url (word url comment) + "Wrapper for `quickurl-add-url' that doesn't guess the parameters." + (interactive "sWord: \nsURL: \nsComment: ") + (quickurl-add-url word url comment)) + +(defun quickurl-list-quit () + "Kill the buffer named `quickurl-list-buffer-name'." + (interactive) + (kill-buffer quickurl-list-buffer-name) + (switch-to-buffer quickurl-list-last-buffer) + (delete-other-windows)) + +(defun quickurl-list-mouse-select (event) + "Select the URL under the mouse click." + (interactive "e") + (setf (point) (posn-point (event-end event))) + (quickurl-list-insert-url)) + +(defun quickurl-list-insert (type) + "Insert the URL under cursor into `quickurl-list-last-buffer'. +TYPE dictates what will be inserted, options are: + `url' - Insert the URL as <URL:url> + `naked-url' - Insert the URL with no formatting + `with-lookup' - Insert \"lookup <URL:url>\" + `with-desc' - Insert \"description <URL:url>\" + `lookup' - Insert the lookup for that URL" + (let ((url (nth (save-excursion + (beginning-of-line) + (count-lines (point-min) (point))) + quickurl-urls))) + (if url + (with-current-buffer quickurl-list-last-buffer + (insert + (case type + ('url (format "<URL:%s>" (quickurl-url-url url))) + ('naked-url (quickurl-url-url url)) + ('with-lookup (format "%s <URL:%s>" + (quickurl-url-keyword url) + (quickurl-url-url url))) + ('with-desc (format "%S <URL:%s>" + (quickurl-url-description url) + (quickurl-url-url url))) + ('lookup (quickurl-url-keyword url))))) + (error "No URL details on that line")) + url)) + +(defmacro quickurl-list-make-inserter (type) + "Macro to make a key-response function for use in `quickurl-list-mode-map'." + `(defun ,(intern (format "quickurl-list-insert-%S" type)) () + ,(format "Insert the result of calling `quickurl-list-insert' with `%s'." type) + (interactive) + (when (quickurl-list-insert ',type) + (quickurl-list-quit)))) + +(quickurl-list-make-inserter url) +(quickurl-list-make-inserter naked-url) +(quickurl-list-make-inserter with-lookup) +(quickurl-list-make-inserter with-desc) +(quickurl-list-make-inserter lookup) + +(provide 'quickurl) + +;;; quickurl.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/rcompile.el Mon Mar 20 13:12:14 2000 +0000 @@ -0,0 +1,179 @@ +;;; rcompile.el --- run a compilation on a remote machine + +;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. + +;; Author: Albert <alon@milcse.rtsg.mot.com> +;; Maintainer: FSF +;; Created: 1993 Oct 6 +;; Keywords: tools, processes + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package is for running a remote compilation and using emacs to parse +;; the error messages. It works by rsh'ing the compilation to a remote host +;; and parsing the output. If the file visited at the time remote-compile was +;; called was loaded remotely (ange-ftp), the host and user name are obtained +;; by the calling ange-ftp-ftp-name on the current directory. In this case the +;; next-error command will also ange-ftp the files over. This is achieved +;; automatically because the compilation-parse-errors function uses +;; default-directory to build its file names. If however the file visited was +;; loaded locally, remote-compile prompts for a host and user and assumes the +;; files mounted locally (otherwise, how was the visited file loaded). + +;; See the user defined variables section for more info. + +;; I was contemplating redefining "compile" to "remote-compile" automatically +;; if the file visited was ange-ftp'ed but decided against it for now. If you +;; feel this is a good idea, let me know and I'll consider it again. + +;; Installation: + +;; To use rcompile, you also need to give yourself permission to connect to +;; the remote host. You do this by putting lines like: + +;; monopoly alon +;; vme33 +;; +;; in a file named .rhosts in the home directory (of the remote machine). +;; Be careful what you put in this file. A line like: +;; +;; + +;; +;; Will allow anyone access to your account without a password. I suggest you +;; read the rhosts(5) manual page before you edit this file (if you are not +;; familiar with it already) + +;;; Code: + +(provide 'rcompile) +(require 'compile) +;;; The following should not be needed. +;;; (eval-when-compile (require 'ange-ftp)) + +;;;; user defined variables + +(defgroup remote-compile nil + "Run a compilation on a remote machine" + :group 'processes + :group 'tools) + + +(defcustom remote-compile-host nil + "*Host for remote compilations." + :type '(choice string (const nil)) + :group 'remote-compile) + +(defcustom remote-compile-user nil + "User for remote compilations. +nil means use the value returned by \\[user-login-name]." + :type '(choice string (const nil)) + :group 'remote-compile) + +(defcustom remote-compile-run-before nil + "*Command to run before compilation. +This can be used for setting up environment variables, +since rsh does not invoke the shell as a login shell and files like .login +\(tcsh\) and .bash_profile \(bash\) are not run. +nil means run no commands." + :type '(choice string (const nil)) + :group 'remote-compile) + +(defcustom remote-compile-prompt-for-host nil + "*Non-nil means prompt for host if not available from filename." + :type 'boolean + :group 'remote-compile) + +(defcustom remote-compile-prompt-for-user nil + "*Non-nil means prompt for user if not available from filename." + :type 'boolean + :group 'remote-compile) + +;;;; internal variables + +;; History of remote compile hosts and users +(defvar remote-compile-host-history nil) +(defvar remote-compile-user-history nil) + + +;;;; entry point + +;;;###autoload +(defun remote-compile (host user command) + "Compile the the current buffer's directory on HOST. Log in as USER. +See \\[compile]." + (interactive + (let ((parsed (or (and (featurep 'ange-ftp) + (ange-ftp-ftp-name default-directory)))) + host user command prompt) + (if parsed + (setq host (nth 0 parsed) + user (nth 1 parsed)) + (setq prompt (if (stringp remote-compile-host) + (format "Compile on host (default %s): " + remote-compile-host) + "Compile on host: ") + host (if (or remote-compile-prompt-for-host + (null remote-compile-host)) + (read-from-minibuffer prompt + "" nil nil + 'remote-compile-host-history) + remote-compile-host) + user (if remote-compile-prompt-for-user + (read-from-minibuffer (format + "Compile by user (default %s)" + (or remote-compile-user + (user-login-name))) + "" nil nil + 'remote-compile-user-history) + remote-compile-user))) + (setq command (read-from-minibuffer "Compile command: " + compile-command nil nil + '(compile-history . 1))) + (list (if (string= host "") remote-compile-host host) + (if (string= user "") remote-compile-user user) + command))) + (setq compile-command command) + (cond (user + (setq remote-compile-user user)) + ((null remote-compile-user) + (setq remote-compile-user (user-login-name)))) + (let* ((parsed (and (featurep 'ange-ftp) + (ange-ftp-ftp-name default-directory))) + (compile-command + (format "%s %s -l %s \"(%scd %s; %s)\"" + remote-shell-program + host + remote-compile-user + (if remote-compile-run-before + (concat remote-compile-run-before "; ") + "") + (if parsed (nth 2 parsed) default-directory) + compile-command))) + (setq remote-compile-host host) + (save-some-buffers nil nil) + (compile-internal compile-command "No more errors") + ;; Set comint-file-name-prefix in the compilation buffer so + ;; compilation-parse-errors will find referenced files by ange-ftp. + (save-excursion + (set-buffer compilation-last-buffer) + (make-variable-buffer-local 'comint-file-name-prefix) + (setq comint-file-name-prefix (concat "/" host ":"))))) + +;;; rcompile.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/rlogin.el Mon Mar 20 13:12:14 2000 +0000 @@ -0,0 +1,373 @@ +;;; rlogin.el --- remote login interface + +;; Copyright (C) 1992, 93, 94, 95, 97, 1998 Free Software Foundation, Inc. + +;; Author: Noah Friedman +;; Maintainer: Noah Friedman <friedman@splode.com> +;; Keywords: unix, comm + +;; $Id: rlogin.el,v 1.45 2000/01/31 18:07:17 fx Exp $ + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Support for remote logins using `rlogin'. +;; This program is layered on top of shell.el; the code here only accounts +;; for the variations needed to handle a remote process, e.g. directory +;; tracking and the sending of some special characters. + +;; If you wish for rlogin mode to prompt you in the minibuffer for +;; passwords when a password prompt appears, just enter m-x send-invisible +;; and type in your line, or add `comint-watch-for-password-prompt' to +;; `comint-output-filter-functions'. + +;;; Code: + +(require 'comint) +(require 'shell) + +(defgroup rlogin nil + "Remote login interface" + :group 'processes + :group 'unix) + +(defcustom rlogin-program "rlogin" + "*Name of program to invoke rlogin" + :type 'string + :group 'rlogin) + +(defcustom rlogin-explicit-args nil + "*List of arguments to pass to rlogin on the command line." + :type '(repeat (string :tag "Argument")) + :group 'rlogin) + +(defcustom rlogin-mode-hook nil + "*Hooks to run after setting current buffer to rlogin-mode." + :type 'hook + :group 'rlogin) + +(defcustom rlogin-process-connection-type + (save-match-data + ;; Solaris 2.x `rlogin' will spew a bunch of ioctl error messages if + ;; stdin isn't a tty. + (cond ((and (boundp 'system-configuration) + (stringp system-configuration) + (string-match "-solaris2" system-configuration)) + t) + (t nil))) + "*If non-`nil', use a pty for the local rlogin process. +If `nil', use a pipe (if pipes are supported on the local system). + +Generally it is better not to waste ptys on systems which have a static +number of them. On the other hand, some implementations of `rlogin' assume +a pty is being used, and errors will result from using a pipe instead." + :type '(choice (const :tag "pipes" nil) + (other :tag "ptys" t)) + :group 'rlogin) + +(defcustom rlogin-directory-tracking-mode 'local + "*Control whether and how to do directory tracking in an rlogin buffer. + +nil means don't do directory tracking. + +t means do so using an ftp remote file name. + +Any other value means do directory tracking using local file names. +This works only if the remote machine and the local one +share the same directories (through NFS). This is the default. + +This variable becomes local to a buffer when set in any fashion for it. + +It is better to use the function of the same name to change the behavior of +directory tracking in an rlogin session once it has begun, rather than +simply setting this variable, since the function does the necessary +re-synching of directories." + :type '(choice (const :tag "off" nil) + (const :tag "ftp" t) + (other :tag "local" local)) + :group 'rlogin) + +(make-variable-buffer-local 'rlogin-directory-tracking-mode) + +(defcustom rlogin-host nil + "*The name of the remote host. This variable is buffer-local." + :type '(choice (const nil) string) + :group 'rlogin) + +(defcustom rlogin-remote-user nil + "*The username used on the remote host. +This variable is buffer-local and defaults to your local user name. +If rlogin is invoked with the `-l' option to specify the remote username, +this variable is set from that." + :type '(choice (const nil) string) + :group 'rlogin) + +;; Initialize rlogin mode map. +(defvar rlogin-mode-map '()) +(cond + ((null rlogin-mode-map) + (setq rlogin-mode-map (if (consp shell-mode-map) + (cons 'keymap shell-mode-map) + (copy-keymap shell-mode-map))) + (define-key rlogin-mode-map "\C-c\C-c" 'rlogin-send-Ctrl-C) + (define-key rlogin-mode-map "\C-c\C-d" 'rlogin-send-Ctrl-D) + (define-key rlogin-mode-map "\C-c\C-z" 'rlogin-send-Ctrl-Z) + (define-key rlogin-mode-map "\C-c\C-\\" 'rlogin-send-Ctrl-backslash) + (define-key rlogin-mode-map "\C-d" 'rlogin-delchar-or-send-Ctrl-D) + (define-key rlogin-mode-map "\C-i" 'rlogin-tab-or-complete))) + + +;;;###autoload (add-hook 'same-window-regexps "^\\*rlogin-.*\\*\\(\\|<[0-9]+>\\)") + +(defvar rlogin-history nil) + +;;;###autoload +(defun rlogin (input-args &optional buffer) + "Open a network login connection via `rlogin' with args INPUT-ARGS. +INPUT-ARGS should start with a host name; it may also contain +other arguments for `rlogin'. + +Input is sent line-at-a-time to the remote connection. + +Communication with the remote host is recorded in a buffer `*rlogin-HOST*' +\(or `*rlogin-USER@HOST*' if the remote username differs\). +If a prefix argument is given and the buffer `*rlogin-HOST*' already exists, +a new buffer with a different connection will be made. + +When called from a program, if the optional second argument BUFFER is +a string or buffer, it specifies the buffer to use. + +The variable `rlogin-program' contains the name of the actual program to +run. It can be a relative or absolute path. + +The variable `rlogin-explicit-args' is a list of arguments to give to +the rlogin when starting. They are added after any arguments given in +INPUT-ARGS. + +If the default value of `rlogin-directory-tracking-mode' is t, then the +default directory in that buffer is set to a remote (FTP) file name to +access your home directory on the remote machine. Occasionally this causes +an error, if you cannot access the home directory on that machine. This +error is harmless as long as you don't try to use that default directory. + +If `rlogin-directory-tracking-mode' is neither t nor nil, then the default +directory is initially set up to your (local) home directory. +This is useful if the remote machine and your local machine +share the same files via NFS. This is the default. + +If you wish to change directory tracking styles during a session, use the +function `rlogin-directory-tracking-mode' rather than simply setting the +variable." + (interactive (list + (read-from-minibuffer "rlogin arguments (hostname first): " + nil nil nil 'rlogin-history) + current-prefix-arg)) + + (let* ((process-connection-type rlogin-process-connection-type) + (args (if rlogin-explicit-args + (append (rlogin-parse-words input-args) + rlogin-explicit-args) + (rlogin-parse-words input-args))) + (host (car args)) + (user (or (car (cdr (member "-l" args))) + (user-login-name))) + (buffer-name (if (string= user (user-login-name)) + (format "*rlogin-%s*" host) + (format "*rlogin-%s@%s*" user host))) + proc) + + (cond ((null buffer)) + ((stringp buffer) + (setq buffer-name buffer)) + ((bufferp buffer) + (setq buffer-name (buffer-name buffer))) + ((numberp buffer) + (setq buffer-name (format "%s<%d>" buffer-name buffer))) + (t + (setq buffer-name (generate-new-buffer-name buffer-name)))) + + (setq buffer (get-buffer-create buffer-name)) + (pop-to-buffer buffer-name) + + (cond + ((comint-check-proc buffer-name)) + (t + (comint-exec buffer buffer-name rlogin-program nil args) + (setq proc (get-buffer-process buffer)) + ;; Set process-mark to point-max in case there is text in the + ;; buffer from a previous exited process. + (set-marker (process-mark proc) (point-max)) + + ;; comint-output-filter-functions is treated like a hook: it is + ;; processed via run-hooks or run-hooks-with-args in later versions + ;; of emacs. + ;; comint-output-filter-functions should already have a + ;; permanent-local property, at least in emacs 19.27 or later. + (cond + ((fboundp 'make-local-hook) + (make-local-hook 'comint-output-filter-functions) + (add-hook 'comint-output-filter-functions 'rlogin-carriage-filter + nil t)) + (t + (make-local-variable 'comint-output-filter-functions) + (add-hook 'comint-output-filter-functions 'rlogin-carriage-filter))) + + (rlogin-mode) + + (make-local-variable 'rlogin-host) + (setq rlogin-host host) + (make-local-variable 'rlogin-remote-user) + (setq rlogin-remote-user user) + + (condition-case () + (cond ((eq rlogin-directory-tracking-mode t) + ;; Do this here, rather than calling the tracking mode + ;; function, to avoid a gratuitous resync check; the default + ;; should be the user's home directory, be it local or remote. + (setq comint-file-name-prefix + (concat "/" rlogin-remote-user "@" rlogin-host ":")) + (cd-absolute comint-file-name-prefix)) + ((null rlogin-directory-tracking-mode)) + (t + (cd-absolute (concat comint-file-name-prefix "~/")))) + (error nil)))))) + +(put 'rlogin-mode 'mode-class 'special) + +(defun rlogin-mode () + "Set major-mode for rlogin sessions. +If `rlogin-mode-hook' is set, run it." + (interactive) + (kill-all-local-variables) + (shell-mode) + (setq major-mode 'rlogin-mode) + (setq mode-name "rlogin") + (use-local-map rlogin-mode-map) + (setq shell-dirtrackp rlogin-directory-tracking-mode) + (make-local-variable 'comint-file-name-prefix) + (run-hooks 'rlogin-mode-hook)) + +(defun rlogin-directory-tracking-mode (&optional prefix) + "Do remote or local directory tracking, or disable entirely. + +If called with no prefix argument or a unspecified prefix argument (just +``\\[universal-argument]'' with no number) do remote directory tracking via +ange-ftp. If called as a function, give it no argument. + +If called with a negative prefix argument, disable directory tracking +entirely. + +If called with a positive, numeric prefix argument, e.g. +``\\[universal-argument] 1 M-x rlogin-directory-tracking-mode\'', +then do directory tracking but assume the remote filesystem is the same as +the local system. This only works in general if the remote machine and the +local one share the same directories (through NFS)." + (interactive "P") + (cond + ((or (null prefix) + (consp prefix)) + (setq rlogin-directory-tracking-mode t) + (setq shell-dirtrackp t) + (setq comint-file-name-prefix + (concat "/" rlogin-remote-user "@" rlogin-host ":"))) + ((< prefix 0) + (setq rlogin-directory-tracking-mode nil) + (setq shell-dirtrackp nil)) + (t + (setq rlogin-directory-tracking-mode 'local) + (setq comint-file-name-prefix "") + (setq shell-dirtrackp t))) + (cond + (shell-dirtrackp + (let* ((proc (get-buffer-process (current-buffer))) + (proc-mark (process-mark proc)) + (current-input (buffer-substring proc-mark (point-max))) + (orig-point (point)) + (offset (and (>= orig-point proc-mark) + (- (point-max) orig-point)))) + (unwind-protect + (progn + (delete-region proc-mark (point-max)) + (goto-char (point-max)) + (shell-resync-dirs)) + (goto-char proc-mark) + (insert current-input) + (if offset + (goto-char (- (point-max) offset)) + (goto-char orig-point))))))) + + +;; Parse a line into its constituent parts (words separated by +;; whitespace). Return a list of the words. +(defun rlogin-parse-words (line) + (let ((list nil) + (posn 0) + (match-data (match-data))) + (while (string-match "[^ \t\n]+" line posn) + (setq list (cons (substring line (match-beginning 0) (match-end 0)) + list)) + (setq posn (match-end 0))) + (set-match-data (match-data)) + (nreverse list))) + +(defun rlogin-carriage-filter (string) + (let* ((point-marker (point-marker)) + (end (process-mark (get-buffer-process (current-buffer)))) + (beg (or (and (boundp 'comint-last-output-start) + comint-last-output-start) + (- end (length string))))) + (goto-char beg) + (while (search-forward "\C-m" end t) + (delete-char -1)) + (goto-char point-marker))) + +(defun rlogin-send-Ctrl-C () + (interactive) + (process-send-string nil "\C-c")) + +(defun rlogin-send-Ctrl-D () + (interactive) + (process-send-string nil "\C-d")) + +(defun rlogin-send-Ctrl-Z () + (interactive) + (process-send-string nil "\C-z")) + +(defun rlogin-send-Ctrl-backslash () + (interactive) + (process-send-string nil "\C-\\")) + +(defun rlogin-delchar-or-send-Ctrl-D (arg) + "\ +Delete ARG characters forward, or send a C-d to process if at end of buffer." + (interactive "p") + (if (eobp) + (rlogin-send-Ctrl-D) + (delete-char arg))) + +(defun rlogin-tab-or-complete () + "Complete file name if doing directory tracking, or just insert TAB." + (interactive) + (if rlogin-directory-tracking-mode + (comint-dynamic-complete) + (insert "\C-i"))) + +(provide 'rlogin) + +;;; rlogin.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/snmp-mode.el Mon Mar 20 13:12:14 2000 +0000 @@ -0,0 +1,716 @@ +;;; snmp-mode.el --- SNMP & SNMPv2 MIB major mode. + +;; Copyright (C) 1995,1998 Free Software Foundation, Inc. + +;; Author: Paul D. Smith <psmith@BayNetworks.com> +;; Keywords: data + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; INTRODUCTION +;; ------------ +;; This package provides a major mode for editing SNMP MIBs. It +;; provides all the modern Emacs 19 bells and whistles: default +;; fontification via font-lock, imenu search functions, etc. +;; +;; SNMP mode also uses tempo, a textual boilerplate insertion package +;; distributed with Emacs, to add in boilerplate SNMP MIB structures. +;; See tempo.el for more details about tempo. +;; +;; If you want to change or add new tempo templates, use the tempo tag +;; list `snmp-tempo-tags' (or `snmpv2-tempo-tags'): this list is +;; automatically installed when snmp-mode (or snmpv2-mode) is entered. +;; +;; The SNMPv2 mode in this version has been enhanced thanks to popular +;; demand. +;; +;; I'm very interested in new tempo macros for both v1 and v2, and any +;; other suggestions for enhancements (different syntax table items, new +;; keybindings, etc.) +;; +;; +;; USAGE +;; ----- +;; Mostly, use it as you would any other mode. There's a very +;; simplistic auto-indent feature; hopefully it'll help more than get in +;; your way. For the most part it tries to indent to the same level as +;; the previous line. It will try to recognize some very simple tokens +;; on the previous line that tell it to use extra indent or outdent. +;; +;; Templates +;; --------- +;; To use the Tempo templates, type the Tempo tag (or a unique prefix) +;; and use C-c C-i (C-c TAB) to complete it; if you don't have +;; tempo-interactive set to nil it will ask you to fill in values. +;; Fields with predefined values (SYNTAX, STATUS, etc.) will do +;; completing-reads on a list of valid values; use the normal SPC or TAB +;; to complete. +;; +;; Currently the following templates are available: +;; +;; objectType -- Defines an OBJECT-TYPE macro. +;; +;; tableType -- Defines both a Table and Entry OBJECT-TYPE, and a +;; SEQUENCE for the ASN.1 Entry definition. +;; +;; Once the template is done, you can use C-cC-f and C-cC-b to move back +;; and forth between the Tempo sequence points to fill in the rest of +;; the information. +;; +;; Font Lock +;; ------------ +;; +;; If you want font-lock in your MIB buffers, add this: +;; +;; (add-hook 'snmp-common-mode-hook 'turn-on-font-lock) +;; +;; Enabling global-font-lock-mode is also sufficient. +;; + +;;;---------------------------------------------------------------------------- +;; +;; Customize these: +;; +;;;---------------------------------------------------------------------------- + +(defgroup snmp nil + "Mode for editing SNMP MIB files." + :group 'data + :version "20.4") + +(defcustom snmp-special-indent t + "*If non-nil, use a simple heuristic to try to guess the right indentation. +If nil, then no special indentation is attempted." + :type 'boolean + :group 'snmp) + +(defcustom snmp-indent-level 4 + "*Indentation level for SNMP MIBs." + :type 'integer + :group 'snmp) + +(defcustom snmp-tab-always-indent nil + "*Non-nil means TAB should always reindent the current line. +A value of nil means reindent if point is within the initial line indentation; +otherwise insert a TAB." + :type 'boolean + :group 'snmp) + +(defcustom snmp-completion-ignore-case t + "*Non-nil means that case differences are ignored during completion. +A value of nil means that case is significant. +This is used during Tempo template completion." + :type 'boolean + :group 'snmp) + +(defcustom snmp-common-mode-hook nil + "*Hook(s) evaluated when a buffer enters either SNMP or SNMPv2 mode." + :type 'hook + :group 'snmp) + +(defcustom snmp-mode-hook nil + "*Hook(s) evaluated when a buffer enters SNMP mode." + :type 'hook + :group 'snmp) + +(defcustom snmpv2-mode-hook nil + "*Hook(s) evaluated when a buffer enters SNMPv2 mode." + :type 'hook + :group 'snmp) + +(defvar snmp-tempo-tags nil + "*Tempo tags for SNMP mode.") + +(defvar snmpv2-tempo-tags nil + "*Tempo tags for SNMPv2 mode.") + + +;; Enable fontification for SNMP MIBs +;; + +;; These are pretty basic fontifications. Note we assume these macros +;; are first on a line (except whitespace), to speed up fontification. +;; +(defvar snmp-font-lock-keywords-1 + (list + ;; OBJECT-TYPE, TRAP-TYPE, and OBJECT-IDENTIFIER macros + '("^[ \t]*\\([a-z][-a-zA-Z0-9]+\\)[ \t]+\\(\\(MODULE-\\(COMPLIANCE\\|IDENTITY\\)\\|OBJECT-\\(COMPLIANCE\\|GROUP\\|IDENTITY\\|TYPE\\)\\|TRAP-\\(GROUP\\|TYPE\\)\\)\\|\\(OBJECT\\)[ \t]+\\(IDENTIFIER\\)[ \t]*::=\\)" + (1 font-lock-variable-name-face) (3 font-lock-keyword-face nil t) + (7 font-lock-keyword-face nil t) (8 font-lock-keyword-face nil t)) + + ;; DEFINITIONS clause + '("^[ \t]*\\([A-Z][-a-zA-Z0-9]+\\)[ \t]+\\(DEFINITIONS\\)[ \t]*::=" + (1 font-lock-function-name-face) (2 font-lock-keyword-face)) + ) + "Basic SNMP MIB mode expression highlighting.") + +(defvar snmp-font-lock-keywords-2 + (append + '(("ACCESS\\|BEGIN\\|DE\\(FVAL\\|SCRIPTION\\)\\|END\\|FROM\\|I\\(MPORTS\\|NDEX\\)\\|S\\(TATUS\\|YNTAX\\)" + (0 font-lock-keyword-face))) + snmp-font-lock-keywords-1) + "Medium SNMP MIB mode expression highlighting.") + +(defvar snmp-font-lock-keywords-3 + (append + '(("\\([^\n]+\\)[ \t]+::=[ \t]+\\(SEQUENCE\\)[ \t]+{" + (1 font-lock-reference-face) (2 font-lock-keyword-face)) + ("::=[ \t]*{[ \t]*\\([a-z0-9].*[ \t]+\\)?\\([0-9]+\\)[ \t]*}" + (1 font-lock-reference-face nil t) (2 font-lock-variable-name-face))) + snmp-font-lock-keywords-2) + "Gaudy SNMP MIB mode expression highlighting.") + +(defvar snmp-font-lock-keywords snmp-font-lock-keywords-1 + "Default SNMP MIB mode expression highlighting.") + + +;; These lists are used for the completion capabilities in the tempo +;; templates. +;; + +(defvar snmp-mode-syntax-list nil + "Predefined types for SYNTAX clauses.") + +(defvar snmp-rfc1155-types + '(("INTEGER") ("OCTET STRING") ("OBJECT IDENTIFIER") ("NULL") ("IpAddress") + ("NetworkAddress") ("Counter") ("Gauge") ("TimeTicks") ("Opaque")) + "Types from RFC 1155 v1 SMI.") + +(defvar snmp-rfc1213-types + '(("DisplayString")) + "Types from RFC 1213 MIB-II.") + +(defvar snmp-rfc1902-types + '(("INTEGER") ("OCTET STRING") ("OBJECT IDENTIFIER") ("Integer32") + ("IpAddress") ("Counter32") ("Gauge32") ("Unsigned32") ("TimeTicks") + ("Opaque") ("Counter64")) + "Types from RFC 1902 v2 SMI.") + +(defvar snmp-rfc1903-types + '(("DisplayString") ("PhysAddress") ("MacAddress") ("TruthValue") + ("TestAndIncr") ("AutonomousType") ("InstancePointer") + ("VariablePointer") ("RowPointer") ("RowStatus") ("TimeStamp") + ("TimeInterval") ("DateAndTime") ("StorageType") ("TDomain") + ("TAddress")) + "Types from RFC 1903 Textual Conventions.") + + +(defvar snmp-mode-access-list nil + "Predefined values for ACCESS clauses.") + +(defvar snmp-rfc1155-access + '(("read-only") ("read-write") ("write-only") ("not-accessible")) + "ACCESS values from RFC 1155 v1 SMI.") + +(defvar snmp-rfc1902-access + '(("read-only") ("read-write") ("read-create") ("not-accessible") + ("accessible-for-notify")) + "ACCESS values from RFC 1155 v1 SMI.") + + +(defvar snmp-mode-status-list nil + "Predefined values for STATUS clauses.") + +(defvar snmp-rfc1212-status + '(("mandatory") ("obsolete") ("deprecated")) + "STATUS values from RFC 1212 v1 SMI.") + +(defvar snmp-rfc1902-status + '(("current") ("obsolete") ("deprecated")) + "STATUS values from RFC 1902 v2 SMI.") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;---------------------------------------------------------------------------- +;; +;; Nothing to customize below here. +;; +;;;---------------------------------------------------------------------------- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; Need this stuff when compiling for imenu macros, etc. +;; +(eval-when-compile + (require 'cl) + (require 'imenu)) + + +;; Create abbrev table for SNMP MIB mode +;; +(defvar snmp-mode-abbrev-table nil + "Abbrev table in use in SNMP mode.") +(define-abbrev-table 'snmp-mode-abbrev-table ()) + + +;; Create abbrev table for SNMPv2 mode +;; +(defvar snmpv2-mode-abbrev-table nil + "Abbrev table in use in SNMPv2 mode.") +(define-abbrev-table 'snmpv2-mode-abbrev-table ()) + + +;; Set up our keymap +;; +(defvar snmp-mode-map (make-sparse-keymap) + "Keymap used in SNMP mode.") + +(define-key snmp-mode-map "\t" 'snmp-indent-command) +(define-key snmp-mode-map "\177" 'backward-delete-char-untabify) + +(define-key snmp-mode-map "\C-c\C-i" 'tempo-complete-tag) +(define-key snmp-mode-map "\C-c\C-f" 'tempo-forward-mark) +(define-key snmp-mode-map "\C-c\C-b" 'tempo-backward-mark) + + +;; Set up our syntax table +;; +(defvar snmp-mode-syntax-table nil + "Syntax table used for buffers in SNMP mode.") + +(if snmp-mode-syntax-table + () + (setq snmp-mode-syntax-table (make-syntax-table)) + (modify-syntax-entry ?\\ "\\" snmp-mode-syntax-table) + (modify-syntax-entry ?- "_ 1234" snmp-mode-syntax-table) + (modify-syntax-entry ?\n ">" snmp-mode-syntax-table) + (modify-syntax-entry ?\^m ">" snmp-mode-syntax-table) + (modify-syntax-entry ?_ "." snmp-mode-syntax-table) + (modify-syntax-entry ?: "." snmp-mode-syntax-table) + (modify-syntax-entry ?= "." snmp-mode-syntax-table)) + +;; Set up the stuff that's common between snmp-mode and snmpv2-mode +;; +(defun snmp-common-mode (name mode abbrev font-keywords imenu-index tempo-tags) + (kill-all-local-variables) + + ;; Become the current major mode + (setq mode-name name) + (setq major-mode mode) + + ;; Activate keymap, syntax table, and abbrev table + (use-local-map snmp-mode-map) + (set-syntax-table snmp-mode-syntax-table) + (setq local-abbrev-table abbrev) + + ;; Set up paragraphs (?) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat "$\\|" page-delimiter)) + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + (make-local-variable 'paragraph-ignore-fill-prefix) + (setq paragraph-ignore-fill-prefix t) + + ;; Set up comments + (make-local-variable 'comment-start) + (setq comment-start "-- ") + (make-local-variable 'comment-start-skip) + (setq comment-start-skip "--+[ \t]*") + (make-local-variable 'comment-column) + (setq comment-column 40) + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments t) + + ;; Set up indentation + (make-local-variable 'indent-line-function) + (setq indent-line-function (if snmp-special-indent + 'snmp-indent-line + 'indent-to-left-margin)) + + ;; Font Lock + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults (cons font-keywords '(nil nil ((?- . "w 1234"))))) + + ;; Imenu + (make-local-variable 'imenu-create-index-function) + (setq imenu-create-index-function imenu-index) + + ;; Tempo + (tempo-use-tag-list tempo-tags) + (make-local-variable 'tempo-match-finder) + (setq tempo-match-finder "\\b\\(.+\\)\\=") + (make-local-variable 'tempo-interactive) + (setq tempo-interactive t) + + ;; Miscellaneous customization + (make-local-variable 'require-final-newline) + (setq require-final-newline t)) + + +;; SNMPv1 MIB Editing Mode. +;; +;;;###autoload +(defun snmp-mode () + "Major mode for editing SNMP MIBs. +Expression and list commands understand all C brackets. +Tab indents for C code. +Comments start with -- and end with newline or another --. +Delete converts tabs to spaces as it moves back. +\\{snmp-mode-map} +Turning on snmp-mode runs the hooks in `snmp-common-mode-hook', then +`snmp-mode-hook'." + (interactive) + + (snmp-common-mode "SNMP" 'snmp-mode + snmp-mode-abbrev-table + '(snmp-font-lock-keywords + snmp-font-lock-keywords-1 + snmp-font-lock-keywords-2 + snmp-font-lock-keywords-3) + 'snmp-mode-imenu-create-index + 'snmp-tempo-tags) + + ;; Completion lists + (make-local-variable 'snmp-mode-syntax-list) + (setq snmp-mode-syntax-list (append snmp-rfc1155-types + snmp-rfc1213-types + snmp-mode-syntax-list)) + (make-local-variable 'snmp-mode-access-list) + (setq snmp-mode-access-list snmp-rfc1155-access) + (make-local-variable 'snmp-mode-status-list) + (setq snmp-mode-status-list snmp-rfc1212-status) + + ;; Run hooks + (run-hooks 'snmp-common-mode-hook) + (run-hooks 'snmp-mode-hook)) + + +;;;###autoload +(defun snmpv2-mode () + "Major mode for editing SNMPv2 MIBs. +Expression and list commands understand all C brackets. +Tab indents for C code. +Comments start with -- and end with newline or another --. +Delete converts tabs to spaces as it moves back. +\\{snmp-mode-map} +Turning on snmp-mode runs the hooks in `snmp-common-mode-hook', +then `snmpv2-mode-hook'." + (interactive) + + (snmp-common-mode "SNMPv2" 'snmpv2-mode + snmpv2-mode-abbrev-table + '(snmp-font-lock-keywords + snmp-font-lock-keywords-1 + snmp-font-lock-keywords-2 + snmp-font-lock-keywords-3) + 'snmp-mode-imenu-create-index + 'snmpv2-tempo-tags) + + ;; Completion lists + (make-local-variable 'snmp-mode-syntax-list) + (setq snmp-mode-syntax-list (append snmp-rfc1902-types + snmp-rfc1903-types + snmp-mode-syntax-list)) + (make-local-variable 'snmp-mode-access-list) + (setq snmp-mode-access-list snmp-rfc1902-access) + (make-local-variable 'snmp-mode-status-list) + (setq snmp-mode-status-list snmp-rfc1902-status) + + ;; Run hooks + (run-hooks 'snmp-common-mode-hook) + (run-hooks 'snmpv2-mode-hook)) + + +;;;---------------------------------------------------------------------------- +;; +;; Indentation Setup +;; +;;;---------------------------------------------------------------------------- + +(defvar snmp-macro-open + "[a-zA-Z][-a-zA-Z0-9]*[ \t]*\\(OBJECT\\|TRAP\\)-\\(TYPE\\|GROUP\\)\ +\\|DESCRIPTION\\|IMPORTS\\|MODULE\\(-IDENTITY\\|-COMPLIANCE\\)\ +\\|.*::=[ \t]*\\(BEGIN\\|TEXTUAL-CONVENTION\\)[ \t]*$") + +(defvar snmp-macro-close + "::=[ \t]*{\\|\\(END\\|.*[;\"]\\)[ \t]*$") + +(defun snmp-calculate-indent () + "Calculate the current line indentation in SNMP MIB code. + +We use a very simple scheme: if the previous non-empty line was a \"macro +open\" string, add `snmp-indent-level' to it. If it was a \"macro close\" +string, subtract `snmp-indent-level'. Otherwise, use the same indentation +as the previous non-empty line. Note comments are considered empty +lines for the purposes of this function." + (let ((empty (concat "\\([ \t]*\\)\\(" comment-start-skip "\\|$\\)")) + (case-fold-search nil)) ; keywords must be in uppercase + (save-excursion + (while (and (>= (forward-line -1) 0) + (looking-at empty))) + (skip-chars-forward " \t") + (+ (current-column) + ;; Are we looking at a macro open string? If so, add more. + (cond ((looking-at snmp-macro-open) + snmp-indent-level) + ;; macro close string? If so, remove some. + ((looking-at snmp-macro-close) + (- snmp-indent-level)) + ;; Neither; just stay here. + (t 0)))))) + +(defun snmp-indent-line () + "Indent current line as SNMP MIB code." + (let ((indent (snmp-calculate-indent)) + (pos (- (point-max) (point))) + shift-amt beg end) + (beginning-of-line) + (setq beg (point)) + (skip-chars-forward " \t") + (setq shift-amt (- indent (current-column))) + (if (zerop shift-amt) + nil + (delete-region beg (point)) + (indent-to indent)) + ;; If initial point was within line's indentation, + ;; position after the indentation. Else stay at same point in text. + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos))))) + +(defun snmp-indent-command () + "Indent current line as SNMP MIB code, or sometimes insert a TAB. +If `snmp-tab-always-indent' is t, always reindent the current line when +this command is run. +If `snmp-tab-always-indent' is nil, reindent the current line if point is +in the initial indentation. Otherwise, insert a TAB." + (interactive) + (if (and (not snmp-tab-always-indent) + (save-excursion + (skip-chars-backward " \t") + (not (bolp)))) + (insert-tab) + (snmp-indent-line))) + + +;;;---------------------------------------------------------------------------- +;; +;; Imenu Setup +;; +;;;---------------------------------------------------------------------------- + +(defvar snmp-clause-regexp + "^[ \t]*\\([a-zA-Z][-a-zA-Z0-9]*\\)[ \t\n]*\ +\\(TRAP-TYPE\\|::=\\|OBJECT\\(-TYPE[ \t\n]+SYNTAX\\|[ \t\n]+IDENTIFIER[ \t\n]*::=\\)\\)") + +(defun snmp-mode-imenu-create-index () + (let ((index-alist '()) + (index-oid-alist '()) + (index-tc-alist '()) + (index-table-alist '()) + (index-trap-alist '()) + (case-fold-search nil) ; keywords must be uppercase + prev-pos token marker end) + (goto-char (point-min)) + (imenu-progress-message prev-pos 0) + ;; Search for a useful MIB item (that's not in a comment) + (save-match-data + (while (re-search-forward snmp-clause-regexp nil t) + (imenu-progress-message prev-pos) + (setq + end (match-end 0) + token (cons (buffer-substring (match-beginning 1) (match-end 1)) + (set-marker (make-marker) (match-beginning 1)))) + (goto-char (match-beginning 2)) + (cond ((looking-at "OBJECT-TYPE[ \t\n]+SYNTAX") + (push token index-alist)) + ((looking-at "OBJECT[ \t\n]+IDENTIFIER[ \t\n]*::=") + (push token index-oid-alist)) + ((looking-at "::=[ \t\n]*SEQUENCE[ \t\n]*{") + (push token index-table-alist)) + ((looking-at "TRAP-TYPE") + (push token index-trap-alist)) + ((looking-at "::=") + (push token index-tc-alist))) + (goto-char end))) + ;; Create the menu + (imenu-progress-message prev-pos 100) + (setq index-alist (nreverse index-alist)) + (and index-tc-alist + (push (cons "Textual Conventions" (nreverse index-tc-alist)) + index-alist)) + (and index-trap-alist + (push (cons "Traps" (nreverse index-trap-alist)) + index-alist)) + (and index-table-alist + (push (cons "Tables" (nreverse index-table-alist)) + index-alist)) + (and index-oid-alist + (push (cons "Object IDs" (nreverse index-oid-alist)) + index-alist)) + index-alist)) + + +;;;---------------------------------------------------------------------------- +;; +;; Tempo Setup +;; +;;;---------------------------------------------------------------------------- + +(require 'tempo) + +;; Perform a completing-read with info given +;; +(defun snmp-completing-read (prompt table &optional pred require init hist) + "Read from the minibuffer, with completion. +Like `completing-read', but the variable `snmp-completion-ignore-case' +controls whether case is significant." + (let ((completion-ignore-case snmp-completion-ignore-case)) + (completing-read prompt table pred require init hist))) + +;; OBJECT-TYPE macro template +;; +(tempo-define-template "snmp-object-type" + '(> (P "Object Label: ") " OBJECT-TYPE" n> + "SYNTAX " + (if tempo-interactive + (snmp-completing-read "Syntax: " snmp-mode-syntax-list nil nil) + p) n> + "ACCESS " + (if tempo-interactive + (snmp-completing-read "Access: " snmp-mode-access-list nil t) + p) n> + "STATUS " + (if tempo-interactive + (snmp-completing-read "Status: " snmp-mode-status-list nil t) + p) n> + "DESCRIPTION" n> "\"" p "\"" n> + (P "Default Value: " defval t) + (if (string= "" (tempo-lookup-named 'defval)) + nil + '(l "DEFVAL { " (s defval) " }" n>)) + "::= { " (p "OID: ") " }" n) + "objectType" + "Insert an OBJECT-TYPE macro." + 'snmp-tempo-tags) + +;; Table macro template +;; +(tempo-define-template "snmp-table-type" + ;; First the table OBJECT-TYPE + '(> (P "Table Name: " table) + (P "Entry Name: " entry t) + (let* ((entry (tempo-lookup-named 'entry)) + (seq (copy-sequence entry))) + (aset entry 0 (downcase (aref entry 0))) + (aset seq 0 (upcase (aref seq 0))) + (tempo-save-named 'obj-entry entry) + (tempo-save-named 'seq-entry seq) + nil) + " OBJECT-TYPE" n> + "SYNTAX SEQUENCE OF " + (s seq-entry) n> + "ACCESS not-accessible" n> + "STATUS mandatory" n> + "DESCRIPTION" n> "\"" p "\"" n> + "::= { " (p "OID: ") " }" n n> + ;; Next the row OBJECT-TYPE + (s obj-entry) " OBJECT-TYPE" n> + "SYNTAX " (s seq-entry) n> + "ACCESS not-accessible" n> + "STATUS mandatory" n> + "DESCRIPTION" n> "\"" p "\"" n> + "INDEX { " (p "Index List: ") " }" n> + "::= {" (s table) " 1 }" n n> + ;; Finally the SEQUENCE type + (s seq-entry) " ::= SEQUENCE {" n> p n> "}" n) + "tableType" + "Insert an SNMP table." + 'snmp-tempo-tags) + + +;; v2 SMI OBJECT-TYPE macro template +;; +(tempo-define-template "snmpv2-object-type" + '(> (P "Object Label: ") " OBJECT-TYPE" n> + "SYNTAX " + (if tempo-interactive + (snmp-completing-read "Syntax: " snmp-mode-syntax-list nil nil) + p) n> + "MAX-ACCESS " + (if tempo-interactive + (snmp-completing-read "Max Access: " snmp-mode-access-list nil t) + p) n> + "STATUS " + (if tempo-interactive + (snmp-completing-read "Status: " snmp-mode-status-list nil t) + p) n> + "DESCRIPTION" n> "\"" p "\"" n> + (P "Default Value: " defval t) + (if (string= "" (tempo-lookup-named 'defval)) + nil + '(l "DEFVAL { " (s defval) " }" n>)) + "::= { " (p "OID: ") " }" n) + "objectType" + "Insert an v2 SMI OBJECT-TYPE macro." + 'snmpv2-tempo-tags) + +;; v2 SMI Table macro template +;; +(tempo-define-template "snmpv2-table-type" + ;; First the table OBJECT-TYPE + '(> (P "Table Name: " table) + (P "Entry Name: " entry t) + (let* ((entry (tempo-lookup-named 'entry)) + (seq (copy-sequence entry))) + (aset entry 0 (downcase (aref entry 0))) + (aset seq 0 (upcase (aref seq 0))) + (tempo-save-named 'obj-entry entry) + (tempo-save-named 'seq-entry seq) + nil) + " OBJECT-TYPE" n> + "SYNTAX SEQUENCE OF " + (s seq-entry) n> + "MAX-ACCESS not-accessible" n> + "STATUS current" n> + "DESCRIPTION" n> "\"" p "\"" n> + "::= { " (p "OID: ") " }" n n> + ;; Next the row OBJECT-TYPE + (s obj-entry) " OBJECT-TYPE" n> + "SYNTAX " (s seq-entry) n> + "MAX-ACCESS not-accessible" n> + "STATUS current" n> + "DESCRIPTION" n> "\"" p "\"" n> + "INDEX { " (p "Index List: ") " }" n> + "::= { " (s table) " 1 }" n n> + ;; Finally the SEQUENCE type + (s seq-entry) " ::= SEQUENCE {" n> p n> "}" n) + "tableType" + "Insert an v2 SMI SNMP table." + 'snmpv2-tempo-tags) + +;; v2 SMI TEXTUAL-CONVENTION macro template +;; +(tempo-define-template "snmpv2-textual-convention" + '(> (P "Texual Convention Type: ") " ::= TEXTUAL-CONVENTION" n> + "STATUS " + (if tempo-interactive + (snmp-completing-read "Status: " snmp-mode-status-list nil t) + p) n> + "DESCRIPTION" n> "\"" p "\"" n> + "SYNTAX " + (if tempo-interactive + (snmp-completing-read "Syntax: " snmp-mode-syntax-list nil nil) + p) n> ) + "textualConvention" + "Insert an v2 SMI TEXTUAL-CONVENTION macro." + 'snmpv2-tempo-tags) + + +(provide 'snmp-mode) + +;; snmp-mode.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/telnet.el Mon Mar 20 13:12:14 2000 +0000 @@ -0,0 +1,261 @@ +;;; telnet.el --- run a telnet session from within an Emacs buffer + +;; Copyright (C) 1985, 1988, 1992, 1994 Free Software Foundation, Inc. + +;; Author: William F. Schelter +;; Maintainer: FSF + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This mode is intended to be used for telnet or rsh to a remote host; +;; `telnet' and `rsh' are the two entry points. Multiple telnet or rsh +;; sessions are supported. +;; +;; Normally, input is sent to the remote telnet/rsh line-by-line, as you +;; type RET or LFD. C-c C-c sends a C-c to the remote immediately; +;; C-c C-z sends C-z immediately. C-c C-q followed by any character +;; sends that character immediately. +;; +;; All RET characters are filtered out of the output coming back from the +;; remote system. The mode tries to do other useful translations based +;; on what it sees coming back from the other system before the password +;; query. It knows about UNIX, ITS, TOPS-20 and Explorer systems. +;; +;; You can use the global telnet-host-properties to associate a telnet +;; program and login name with each host you regularly telnet to. + +;;; Code: + +;; to do fix software types for lispm: +;; to eval current expression. Also to try to send escape keys correctly. +;; essentially we'll want the rubout-handler off. + +;; filter is simplistic but should be okay for typical shell usage. +;; needs hacking if it is going to deal with asynchronous output in a sane +;; manner + +(require 'comint) + +(defvar telnet-host-properties () + "Specify which telnet program to use for particular hosts. +Each element has the form (HOSTNAME PROGRAM [LOGIN-NAME]) +HOSTNAME says which machine the element applies to. +PROGRAM says which program to run, to talk to that machine. +LOGIN-NAME, which is optional, says what to log in as on that machine.") + +(defvar telnet-new-line "\r") +(defvar telnet-mode-map nil) +(defvar telnet-prompt-pattern "^[^#$%>\n]*[#$%>] *") +(defvar telnet-replace-c-g nil) +(make-variable-buffer-local + (defvar telnet-remote-echoes t + "True if the telnet process will echo input.")) +(make-variable-buffer-local + (defvar telnet-interrupt-string "\C-c" "String sent by C-c.")) + +(defvar telnet-count 0 + "Number of output strings from telnet process while looking for password.") +(make-variable-buffer-local 'telnet-count) + +(defvar telnet-program "telnet" + "Program to run to open a telnet connection.") + +(defvar telnet-initial-count -50 + "Initial value of `telnet-count'. Should be set to the negative of the +number of terminal writes telnet will make setting up the host connection.") + +(defvar telnet-maximum-count 4 + "Maximum value `telnet-count' can have. +After this many passes, we stop looking for initial setup data. +Should be set to the number of terminal writes telnet will make +rejecting one login and prompting again for a username and password.") + +(defun telnet-interrupt-subjob () + (interactive) + "Interrupt the program running through telnet on the remote host." + (send-string nil telnet-interrupt-string)) + +(defun telnet-c-z () + (interactive) + (send-string nil "\C-z")) + +(defun send-process-next-char () + (interactive) + (send-string nil + (char-to-string + (let ((inhibit-quit t)) + (prog1 (read-char) + (setq quit-flag nil)))))) + +; initialization on first load. +(if telnet-mode-map + nil + (setq telnet-mode-map (nconc (make-sparse-keymap) comint-mode-map)) + (define-key telnet-mode-map "\C-m" 'telnet-send-input) +; (define-key telnet-mode-map "\C-j" 'telnet-send-input) + (define-key telnet-mode-map "\C-c\C-q" 'send-process-next-char) + (define-key telnet-mode-map "\C-c\C-c" 'telnet-interrupt-subjob) + (define-key telnet-mode-map "\C-c\C-z" 'telnet-c-z)) + +;;maybe should have a flag for when have found type +(defun telnet-check-software-type-initialize (string) + "Tries to put correct initializations in. Needs work." + (let ((case-fold-search t)) + (cond ((string-match "unix" string) + (setq telnet-prompt-pattern comint-prompt-regexp) + (setq telnet-new-line "\n")) + ((string-match "tops-20" string) ;;maybe add telnet-replace-c-g + (setq telnet-prompt-pattern "[@>]*")) + ((string-match "its" string) + (setq telnet-prompt-pattern "^[^*>\n]*[*>] *")) + ((string-match "explorer" string) ;;explorer telnet needs work + (setq telnet-replace-c-g ?\n)))) + (setq comint-prompt-regexp telnet-prompt-pattern)) + +(defun telnet-initial-filter (proc string) + ;For reading up to and including password; also will get machine type. + (save-current-buffer + (set-buffer (process-buffer proc)) + (let ((case-fold-search t)) + (cond ((string-match "No such host" string) + (kill-buffer (process-buffer proc)) + (error "No such host")) + ((string-match "passw" string) + (telnet-filter proc string) + (setq telnet-count 0) + (send-string proc (concat (comint-read-noecho "Password: " t) + telnet-new-line)) + (clear-this-command-keys)) + (t (telnet-check-software-type-initialize string) + (telnet-filter proc string) + (cond ((> telnet-count telnet-maximum-count) + (set-process-filter proc 'telnet-filter)) + (t (setq telnet-count (1+ telnet-count))))))))) + +;; Identical to comint-simple-send, except that it sends telnet-new-line +;; instead of "\n". +(defun telnet-simple-send (proc string) + (comint-send-string proc string) + (comint-send-string proc telnet-new-line)) + +(defun telnet-filter (proc string) + (save-excursion + (set-buffer (process-buffer proc)) + (let* ((last-insertion (marker-position (process-mark proc))) + (delta (- (point) last-insertion)) + (ie (and comint-last-input-end + (marker-position comint-last-input-end))) + (w (get-buffer-window (current-buffer))) + (ws (and w (window-start w)))) + (goto-char last-insertion) + (insert-before-markers string) + (set-marker comint-last-output-start last-insertion) + (set-marker (process-mark proc) (point)) + (if ws (set-window-start w ws t)) + (if ie (set-marker comint-last-input-end ie)) + (while (progn (skip-chars-backward "^\C-m" last-insertion) + (> (point) last-insertion)) + (delete-region (1- (point)) (point))) + (goto-char (process-mark proc)) + (and telnet-replace-c-g + (subst-char-in-region last-insertion (point) ?\C-g + telnet-replace-c-g t)) + ;; If point is after the insertion place, move it + ;; along with the text. + (if (> delta 0) + (goto-char (+ (process-mark proc) delta)))))) + +(defun telnet-send-input () + (interactive) +; (comint-send-input telnet-new-line telnet-remote-echoes) + (comint-send-input) + (if telnet-remote-echoes + (delete-region comint-last-input-start + comint-last-input-end))) + +;;;###autoload (add-hook 'same-window-regexps "\\*telnet-.*\\*\\(\\|<[0-9]+>\\)") + +;;;###autoload +(defun telnet (host) + "Open a network login connection to host named HOST (a string). +Communication with HOST is recorded in a buffer `*PROGRAM-HOST*' +where PROGRAM is the telnet program being used. This program +is controlled by the contents of the global variable `telnet-host-properties', +falling back on the value of the global variable `telnet-program'. +Normally input is edited in Emacs and sent a line at a time." + (interactive "sOpen connection to host: ") + (let* ((comint-delimiter-argument-list '(?\ ?\t)) + (properties (cdr (assoc host telnet-host-properties))) + (telnet-program (if properties (car properties) telnet-program)) + (name (concat telnet-program "-" (comint-arguments host 0 nil) )) + (buffer (get-buffer (concat "*" name "*"))) + (telnet-options (if (cdr properties) (cons "-l" (cdr properties)))) + process) + (if (and buffer (get-buffer-process buffer)) + (pop-to-buffer (concat "*" name "*")) + (pop-to-buffer + (apply 'make-comint name telnet-program nil telnet-options)) + (setq process (get-buffer-process (current-buffer))) + (set-process-filter process 'telnet-initial-filter) + ;; Don't send the `open' cmd till telnet is ready for it. + (accept-process-output process) + (erase-buffer) + (send-string process (concat "open " host "\n")) + (telnet-mode) + (setq comint-input-sender 'telnet-simple-send) + (setq telnet-count telnet-initial-count)))) + +(put 'telnet-mode 'mode-class 'special) + +(defun telnet-mode () + "This mode is for using telnet (or rsh) from a buffer to another host. +It has most of the same commands as comint-mode. +There is a variable ``telnet-interrupt-string'' which is the character +sent to try to stop execution of a job on the remote host. +Data is sent to the remote host when RET is typed. + +\\{telnet-mode-map} +" + (interactive) + (comint-mode) + (setq major-mode 'telnet-mode + mode-name "Telnet" + comint-prompt-regexp telnet-prompt-pattern) + (use-local-map telnet-mode-map) + (run-hooks 'telnet-mode-hook)) + +;;;###autoload (add-hook 'same-window-regexps "\\*rsh-[^-]*\\*\\(\\|<[0-9]*>\\)") + +;;;###autoload +(defun rsh (host) + "Open a network login connection to host named HOST (a string). +Communication with HOST is recorded in a buffer `*rsh-HOST*'. +Normally input is edited in Emacs and sent a line at a time." + (interactive "sOpen rsh connection to host: ") + (require 'shell) + (let ((name (concat "rsh-" host ))) + (pop-to-buffer (make-comint name remote-shell-program nil host)) + (set-process-filter (get-process name) 'telnet-initial-filter) + (telnet-mode) + (setq telnet-count -16))) + +(provide 'telnet) + +;;; telnet.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/webjump.el Mon Mar 20 13:12:14 2000 +0000 @@ -0,0 +1,403 @@ +;;; webjump.el --- programmable Web hotlist + +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. + +;; Author: Neil W. Van Dyke <nwv@acm.org> +;; Created: 09-Aug-1996 +;; Keywords: comm www + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; WebJump provides a sort of ``programmable hotlist'' of Web sites that can +;; quickly be invoked in your Web browser. Each Web site in the hotlist has a +;; name, and you select the desired site name via a completing string prompt in +;; the minibuffer. The URL for each Web site is defined as a static string or +;; a built-in or custom function, allowing interactive prompting for +;; site-specific queries and options. + +;; Note that WebJump was originally intended to complement your conventional +;; browser-based hotlist, not replace it. (Though there's no reason you +;; couldn't use WebJump for your entire hotlist if you were so inclined.) + +;; The `webjump-sites' variable, which defines the hotlist, defaults to some +;; example sites. You'll probably want to override it with your own favorite +;; sites. The documentation for the variable describes the syntax. + +;; You may wish to add something like the following to your `.emacs' file: +;; +;; (require 'webjump) +;; (global-set-key "\C-cj" 'webjump) +;; (setq webjump-sites +;; (append '( +;; ("My Home Page" . "www.someisp.net/users/joebobjr/") +;; ("Pop's Site" . "www.joebob-and-son.com/") +;; ) +;; webjump-sample-sites)) +;; +;; The above loads this package, binds `C-c j' to invoke WebJump, and adds your +;; personal favorite sites to the hotlist. + +;; The `webjump-sample-sites' variable mostly contains some site entries that +;; are expected to be generally relevant to many users, but excluding +;; those that the GNU project would not want to recommend. + +;; The `browse-url' package is used to submit URLs to the browser, so any +;; browser-specific configuration should be done there. + +;;; Code: + +;;-------------------------------------------------------- Package Dependencies + +(require 'browse-url) + +;;------------------------------------------------------------------- Constants + +(defvar webjump-sample-sites + '( + + ;; FSF, not including Emacs-specific. + ("GNU Project FTP Archive" . + [mirrors "ftp://ftp.gnu.org/pub/gnu/" + ;; ASIA: + "ftp://ftp.cs.titech.ac.jp" + "ftp://tron.um.u-tokyo.ac.jp/pub/GNU/prep" + "ftp://cair-archive.kaist.ac.kr/pub/gnu" + "ftp://ftp.nectec.or.th/pub/mirrors/gnu" + ;; AUSTRALIA: + "ftp://archie.au/gnu" + "ftp://archie.oz/gnu" + "ftp://archie.oz.au/gnu" + ;; AFRICA: + "ftp://ftp.sun.ac.za/pub/gnu" + ;; MIDDLE-EAST: + "ftp://ftp.technion.ac.il/pub/unsupported/gnu" + ;; EUROPE: + "ftp://irisa.irisa.fr/pub/gnu" + "ftp://ftp.univ-lyon1.fr/pub/gnu" + "ftp://ftp.mcc.ac.uk" + "ftp://unix.hensa.ac.uk/mirrors/uunet/systems/gnu" + "ftp://src.doc.ic.ac.uk/gnu" + "ftp://ftp.ieunet.ie/pub/gnu" + "ftp://ftp.eunet.ch" + "ftp://nic.switch.ch/mirror/gnu" + "ftp://ftp.informatik.rwth-aachen.de/pub/gnu" + "ftp://ftp.informatik.tu-muenchen.de" + "ftp://ftp.win.tue.nl/pub/gnu" + "ftp://ftp.nl.net" + "ftp://ftp.etsimo.uniovi.es/pub/gnu" + "ftp://ftp.funet.fi/pub/gnu" + "ftp://ftp.denet.dk" + "ftp://ftp.stacken.kth.se" + "ftp://isy.liu.se" + "ftp://ftp.luth.se/pub/unix/gnu" + "ftp://ftp.sunet.se/pub/gnu" + "ftp://archive.eu.net" + ;; SOUTH AMERICA: + "ftp://ftp.inf.utfsm.cl/pub/gnu" + "ftp://ftp.unicamp.br/pub/gnu" + ;; WESTERN CANADA: + "ftp://ftp.cs.ubc.ca/mirror2/gnu" + ;; USA: + "ftp://wuarchive.wustl.edu/systems/gnu" + "ftp://labrea.stanford.edu" + "ftp://ftp.digex.net/pub/gnu" + "ftp://ftp.kpc.com/pub/mirror/gnu" + "ftp://f.ms.uky.edu/pub3/gnu" + "ftp://jaguar.utah.edu/gnustuff" + "ftp://ftp.hawaii.edu/mirrors/gnu" + "ftp://uiarchive.cso.uiuc.edu/pub/gnu" + "ftp://ftp.cs.columbia.edu/archives/gnu/prep" + "ftp://gatekeeper.dec.com/pub/GNU" + "ftp://ftp.uu.net/systems/gnu"]) + ("GNU Project Home Page" . "www.gnu.org") + + ;; Emacs. + ("Emacs Lisp Archive" . + "ftp://ftp.emacs.org/pub/") + + ;; Internet search engines. + ("AltaVista" . + [simple-query + "www.altavista.digital.com" + "www.altavista.digital.com/cgi-bin/query?pg=aq&what=web&fmt=.&q=" + "&r=&d0=&d1="]) + ("Archie" . + [simple-query "hoohoo.ncsa.uiuc.edu/cgi-bin/AA.pl" + "hoohoo.ncsa.uiuc.edu/cgi-bin/AA.pl?query=" ""]) + ("Lycos" . + [simple-query "www.lycos.com" + "www.lycos.com/cgi-bin/pursuit?cat=lycos&query=" ""]) + ("Yahoo" . + [simple-query "www.yahoo.com" "search.yahoo.com/bin/search?p=" ""]) + + ;; Misc. general interest. + ("Interactive Weather Information Network" . webjump-to-iwin) + ("Usenet FAQs" . + [simple-query "www.cis.ohio-state.edu/hypertext/faq/usenet/FAQ-List.html" + "www.cis.ohio-state.edu/htbin/search-usenet-faqs/form?find=" + ""]) + ("RTFM Usenet FAQs by Group" . + "ftp://rtfm.mit.edu/pub/usenet-by-group/") + ("RTFM Usenet FAQs by Hierachy" . + "ftp://rtfm.mit.edu/pub/usenet-by-hierarchy/") + ("X Consortium Archive" . "ftp.x.org") + ("Yahoo: Reference" . "www.yahoo.com/Reference/") + + ;; Computer social issues, privacy, professionalism. + ("Association for Computing Machinery" . "www.acm.org") + ("Computer Professionals for Social Responsibility" . "www.cpsr.org/dox/") + ("Electronic Frontier Foundation" . "www.eff.org") + ("IEEE Computer Society" . "www.computer.org") + ("Risks Digest" . webjump-to-risks) + + ;; Fun. + ("Bastard Operator from Hell" . "www.replay.com/bofh/") + + ) + "Sample hotlist for WebJump. See the documentation for the `webjump' +function and the `webjump-sites' variable.") + +(defvar webjump-state-to-postal-alist + '(("Alabama" . "al") ("Alaska" . "ak") ("Arizona" . "az") ("Arkansas" . "ar") + ("California" . "ca") ("Colorado" . "co") ("Connecticut" . "ct") + ("Delaware" . "de") ("Florida" . "fl") ("Georgia" . "ga") ("Hawaii" . "hi") + ("Idaho" . "id") ("Illinois" . "il") ("Indiana" . "in") ("Iowa" . "ia") + ("Kansas" . "ks") ("Kentucky" . "ky") ("Louisiana" . "la") ("Maine" . "me") + ("Maryland" . "md") ("Massachusetts" . "ma") ("Michigan" . "mi") + ("Minnesota" . "mn") ("Mississippi" . "ms") ("Missouri" . "mo") + ("Montana" . "mt") ("Nebraska" . "ne") ("Nevada" . "nv") + ("New Hampshire" . "nh") ("New Jersey" . "nj") ("New Mexico" . "nm") + ("New York" . "ny") ("North Carolina" . "nc") ("North Dakota" . "nd") + ("Ohio" . "oh") ("Oklahoma" . "ok") ("Oregon" . "or") + ("Pennsylvania" . "pa") ("Rhode Island" . "ri") ("South Carolina" . "sc") + ("South Dakota" . "sd") ("Tennessee" . "tn") ("Texas" . "tx") + ("Utah" . "ut") ("Vermont" . "vt") ("Virginia" . "va") + ("Washington" . "wa") ("West Virginia" . "wv") ("Wisconsin" . "wi") + ("Wyoming" . "wy"))) + +;;------------------------------------------------------------ Option Variables + +(defvar webjump-sites + webjump-sample-sites + "*Hotlist for WebJump. + +The hotlist is represented as an association list, with the CAR of each cell +being the name of the Web site, and the CDR being the definition for the URL of +that site. The URL definition can be a string (the URL), a vector (specifying +a special \"builtin\" which returns a URL), a symbol (name of a function which +returns a URL), or a list (which when `eval'ed yields a URL). + +If the URL definition is a vector, then a \"builtin\" is used. A builtin has a +Lisp-like syntax, with the name as the first element of the vector, and any +arguments as the following elements. The three current builtins are `name', +which returns the name of the site as the URL, `simple-query', which +returns a URL that is a function of a query entered by the user, and `mirrors', +which allows the user to select from among multiple mirror sites for the same +content. + +The first argument to the `simple-query' builtin is a static URL to use if the +user enters a blank query. The second and third arguments are the prefix and +suffix, respectively, to add to the encoded query the user enters. This +builtin covers Web sites that have single-string searches with the query +embedded in the URL. + +The arguments to the `mirrors' builtin are URLs of mirror sites. + +If the symbol of a function is given, then the function will be called with the +Web site name (the one you specified in the CAR of the alist cell) as a +parameter. This might come in handy for various kludges. + +For convenience, if the `http://', `ftp://', or `file://' prefix is missing +from a URL, WebJump will make a guess at what you wanted and prepend it before +submitting the URL.") + +;;------------------------------------------------------- Sample Site Functions + +(defun webjump-to-iwin (name) + (let ((prefix "http://iwin.nws.noaa.gov/") + (state (webjump-read-choice name "state" + (append '(("Puerto Rico" . "pr")) + webjump-state-to-postal-alist)))) + (if state + (concat prefix "iwin/" state "/" + (webjump-read-choice name "option" + '(("Hourly Report" . "hourly") + ("State Forecast" . "state") + ("Local Forecast" . "local") + ("Zone Forecast" . "zone") + ("Short-Term Forecast" . "shortterm") + ("Weather Summary" . "summary") + ("Public Information" . "public") + ("Climatic Data" . "climate") + ("Aviation Products" . "aviation") + ("Hydro Products" . "hydro") + ("Special Weather" . "special") + ("Watches and Warnings" . "warnings")) + "zone") + ".html") + prefix))) + +(defun webjump-to-risks (name) + (let (issue volume) + (if (and (setq volume (webjump-read-number (concat name " volume"))) + (setq issue (webjump-read-number (concat name " issue")))) + (format "catless.ncl.ac.uk/Risks/%d.%02d.html" volume issue) + "catless.ncl.ac.uk/Risks/"))) + +;;-------------------------------------------------------------- Core Functions + +;;;###autoload +(defun webjump () + "Jumps to a Web site from a programmable hotlist. + +See the documentation for the `webjump-sites' variable for how to customize the +hotlist. + +Please submit bug reports and other feedback to the author, Neil W. Van Dyke +<nwv@acm.org>." + (interactive) + (let* ((completion-ignore-case t) + (item (assoc-ignore-case + (completing-read "WebJump to site: " webjump-sites nil t) + webjump-sites)) + (name (car item)) + (expr (cdr item))) + (browse-url (webjump-url-fix + (cond ((not expr) "") + ((stringp expr) expr) + ((vectorp expr) (webjump-builtin expr name)) + ((listp expr) (eval expr)) + ((symbolp expr) + (if (fboundp expr) + (funcall expr name) + (error "WebJump URL function \"%s\" undefined." + expr))) + (t (error "WebJump URL expression for \"%s\" invalid." + name))))))) + +(defun webjump-builtin (expr name) + (if (< (length expr) 1) + (error "WebJump URL builtin for \"%s\" empty." name)) + (let ((builtin (aref expr 0))) + (cond + ((eq builtin 'mirrors) + (if (= (length expr) 1) + (error + "WebJump URL builtin \"mirrors\" for \"%s\" needs at least 1 arg.")) + (webjump-choose-mirror name (cdr (append expr nil)))) + ((eq builtin 'name) + name) + ((eq builtin 'simple-query) + (webjump-builtin-check-args expr name 3) + (webjump-do-simple-query name (aref expr 1) (aref expr 2) (aref expr 3))) + (t (error "WebJump URL builtin \"%s\" for \"%s\" invalid." + builtin name))))) + +(defun webjump-builtin-check-args (expr name count) + (or (= (length expr) (1+ count)) + (error "WebJump URL builtin \"%s\" for \"%s\" needs %d args." + (aref expr 0) name count))) + +(defun webjump-choose-mirror (name urls) + (webjump-read-url-choice (concat name " mirror") + urls + (webjump-mirror-default urls))) + +(defun webjump-do-simple-query (name noquery-url query-prefix query-suffix) + (let ((query (webjump-read-string (concat name " query")))) + (if query + (concat query-prefix (webjump-url-encode query) query-suffix) + noquery-url))) + +(defun webjump-mirror-default (urls) + ;; Note: This should be modified to apply some simple kludges/heuristics to + ;; pick a site which is likely "close". As a tie-breaker among candidates + ;; judged equally desirable, randomness might be used. + (car urls)) + +(defun webjump-read-choice (name what choices &optional default) + (let* ((completion-ignore-case t) + (choice (completing-read (concat name " " what ": ") choices nil t))) + (if (webjump-null-or-blank-string-p choice) + default + (cdr (assoc choice choices))))) + +(defun webjump-read-number (prompt) + ;; Note: I should make this more robust someday. + (let ((input (webjump-read-string prompt))) + (if input (string-to-number input)))) + +(defun webjump-read-string (prompt) + (let ((input (read-string (concat prompt ": ")))) + (if (webjump-null-or-blank-string-p input) nil input))) + +(defun webjump-read-url-choice (what urls &optional default) + ;; Note: Convert this to use `webjump-read-choice' someday. + (let* ((completions (mapcar (function (lambda (n) (cons n n))) + urls)) + (input (completing-read (concat what + ;;(if default " (RET for default)" "") + ": ") + completions + nil + t))) + (if (webjump-null-or-blank-string-p input) + default + (car (assoc input completions))))) + +(defun webjump-null-or-blank-string-p (str) + (or (null str) (string-match "^[ \t]*$" str))) + +(defun webjump-url-encode (str) + (mapconcat '(lambda (c) + (cond ((= c 32) "+") + ((or (and (>= c ?a) (<= c ?z)) + (and (>= c ?A) (<= c ?Z)) + (and (>= c ?0) (<= c ?9))) + (char-to-string c)) + (t (upcase (format "%%%02x" c))))) + str + "")) + +(defun webjump-url-fix (url) + (if (webjump-null-or-blank-string-p url) + "" + (webjump-url-fix-trailing-slash + (cond + ((string-match "^[a-zA-Z]+:" url) url) + ((string-match "^/" url) (concat "file://" url)) + ((string-match "^\\([^\\./]+\\)" url) + (concat (if (string= (downcase (match-string 1 url)) "ftp") + "ftp" + "http") + "://" + url)) + (t url))))) + +(defun webjump-url-fix-trailing-slash (url) + (if (string-match "^[a-zA-Z]+://[^/]+$" url) + (concat url "/") + url)) + +;;----------------------------------------------------------------------------- + +(provide 'webjump) + +;; webjump.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/zone-mode.el Mon Mar 20 13:12:14 2000 +0000 @@ -0,0 +1,117 @@ +;;; zone-mode.el -- major mode for editing DNS zone files. + +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: John Heidemann <johnh@isi.edu> +;; Keywords: DNS, languages + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; +;;; See the comments in ``define-derived-mode zone-mode'' +;;; (the last function in this file) +;;; for what this mode is and how to use it automatically. +;;; + +;;; +;;; Credits: +;;; Zone-mode was written by John Heidemann <johnh@isi.edu>, +;;; with bug fixes from Simon Leinen <simon@limmat.switch.ch>. +;;; + +;;; Code: + +(defun zone-mode-update-serial () + "Update the serial number in a zone." + (interactive) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "\\b\\([0-9]+\\)\\([0-9][0-9]\\)\\([ \t]+;[ \t]+[Ss]erial\\)" (point-max) t) + (let* ((old-date (match-string 1)) + (old-seq (match-string 2)) + (old-seq-num (string-to-number (match-string 2))) + (old-flag (match-string 3)) + (cur-date (format-time-string "%Y%m%d")) + (new-seq + (cond + ((not (string= old-date cur-date)) + "00") ;; reset sequeence number + ((>= old-seq-num 99) + (error "Serial number's sequenece cannot increment beyond 99.")) + (t + (format "%02d" (1+ old-seq-num))))) + (old-serial (concat old-date old-seq)) + (new-serial (concat cur-date new-seq))) + (if (string-lessp new-serial old-serial) + (error (format "Serial numbers want to move backwards from %s to %s!" old-serial new-serial)) + (replace-match (concat cur-date new-seq old-flag) t t)))))) + +;;;###autoload +(defun zone-mode-update-serial-hook () + "Update the serial number in a zone if the file was modified" + (interactive) + (if (buffer-modified-p (current-buffer)) + (zone-mode-update-serial)) + nil ;; so we can run from write-file-hooks + ) + +(defvar zone-mode-syntax-table nil + "Zone-mode's syntax table.") + +(defun zone-mode-load-time-setup () + "init zone-mode stuff" + (setq zone-mode-syntax-table (make-syntax-table)) + (modify-syntax-entry ?\; "<" zone-mode-syntax-table) + (modify-syntax-entry ?\n ">" zone-mode-syntax-table)) + +;;;###autoload +(define-derived-mode zone-mode fundamental-mode "zone" + "A mode for editing DNS zone files. + +Zone-mode does two things: + + - automatically update the serial number for a zone + when saving the file + + - fontification" + + (make-local-hook 'write-file-hooks) + (add-hook 'write-file-hooks 'zone-mode-update-serial-hook) + + (if (null zone-mode-syntax-table) + (zone-mode-load-time-setup)) ;; should have been run at load-time + + ;; font-lock support: + (set-syntax-table zone-mode-syntax-table) + (make-local-variable 'comment-start) + (setq comment-start ";") + (make-local-variable 'comment-start-skip) + ;; Look within the line for a ; following an even number of backslashes + ;; after either a non-backslash or the line beginning. + (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*") + (make-local-variable 'comment-column) + (setq comment-column 40) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + '(nil nil nil nil beginning-of-line))) + +(zone-mode-load-time-setup) + +(provide 'zone-mode) + +;;; zone-mode.el ends here