Mercurial > emacs
changeset 28211:1ebbd6d6b1d4
Moved to net subdir.
| author | Gerd Moellmann <gerd@gnu.org> |
|---|---|
| date | Mon, 20 Mar 2000 13:12:47 +0000 |
| parents | b56f9152e329 |
| children | 7252a5d43f22 |
| files | lisp/ange-ftp.el lisp/browse-url.el lisp/goto-addr.el lisp/net-utils.el lisp/quickurl.el lisp/rcompile.el lisp/rlogin.el lisp/snmp-mode.el lisp/telnet.el lisp/webjump.el lisp/zone-mode.el |
| diffstat | 11 files changed, 0 insertions(+), 10421 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ange-ftp.el Mon Mar 20 13:12:14 2000 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5695 +0,0 @@ -;;; 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
--- a/lisp/browse-url.el Mon Mar 20 13:12:14 2000 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1033 +0,0 @@ -;;; 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
--- a/lisp/goto-addr.el Mon Mar 20 13:12:14 2000 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,234 +0,0 @@ -;;; 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.
--- a/lisp/net-utils.el Mon Mar 20 13:12:14 2000 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,858 +0,0 @@ -;;; 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
--- a/lisp/quickurl.el Mon Mar 20 13:12:14 2000 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,552 +0,0 @@ -;;; 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
--- a/lisp/rcompile.el Mon Mar 20 13:12:14 2000 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,179 +0,0 @@ -;;; 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
--- a/lisp/rlogin.el Mon Mar 20 13:12:14 2000 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,373 +0,0 @@ -;;; 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.44 1998/10/03 00:44:26 friedman 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
--- a/lisp/snmp-mode.el Mon Mar 20 13:12:14 2000 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,716 +0,0 @@ -;;; 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
--- a/lisp/telnet.el Mon Mar 20 13:12:14 2000 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,261 +0,0 @@ -;;; 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
--- a/lisp/webjump.el Mon Mar 20 13:12:14 2000 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,403 +0,0 @@ -;;; 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
--- a/lisp/zone-mode.el Mon Mar 20 13:12:14 2000 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,117 +0,0 @@ -;;; 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