-;; -*-Emacs-Lisp-*-
-;;; This needs to be changed to use comint as the mode for the FTP buffer.
-;; Description: transparent FTP support for GNU Emacs
+;;; ange-ftp.el --- transparent FTP support for GNU Emacs
-;;; Copyright (C) 1989, 1990, 1991, 1992 Free Software Foundation, Inc.
+;;; Copyright (C) 1989,90,91,92,93,94 Free Software Foundation, Inc.
;;;
-;;; Author: Andy Norman (ange@hplb.hpl.hp.com)
+;; Author: Andy Norman (ange@hplb.hpl.hp.com)
+;; Keywords: comm
;;;
;;; This program 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 1, or (at your option)
+;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
;;; 02139, USA.
-;;; Description:
+;;; 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.
-;;; Installation:
-;;;
-;;; Byte-compile ange-ftp.el to ange-ftp.elc and put them both in a directory
-;;; on your load-path. Load the package from your .emacs file with:
-;;;
-;;; (require 'ange-ftp).
-;;;
-;;; ange-ftp can't sensibly be auto-loaded; you are either using it, or you
-;;; ain't.
-
;;; 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:path' then it will spawn an FTP process connecting to machine
-;;; 'host' as account 'user' and perform its operation on the file 'path'.
+;;; '/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 will spawn an FTP process, connect to the host 'anorman' as
+;;; 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
-;;; needed a password to connect then it would prompt the user in the
-;;; minibuffer.
+;;; needs a password to connect then it reads one in the echo area.
;;; Extended filename syntax:
;;;
-;;; The default extended filename syntax is '/user@host:path', where the
+;;; 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-path-format. There are limitations.
+;;; extent by changing ange-ftp-name-format. There are limitations.
;;;
-;;; If the user part is omitted then ange-ftp will generate a default user
+;;; 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. This will be prompted
-;;; for when needed, unless already set by calling ange-ftp-set-passwd, or
-;;; specified in a *valid* ~/.netrc file.
+;;; 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, then a password is created from the name of the user and the
-;;; hostname of the machine on which GNU Emacs is running; if nil (the
-;;; default) then the user is prompted for a password as normal.
+;;; 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
+;;; a password is created from the name of the user and the hostname
+;;; of the machine on which GNU Emacs is running; if nil then the user
+;;; is prompted for a password as normal.
;;; "Dumb" UNIX hosts:
;;;
;;; time, but ange-ftp should be able to quietly reconnect the next time that
;;; the process is needed.
;;;
-;;; The FTP process will be killed should the associated "*ftp user@host*"
-;;; buffer be deleted. This should not cause ange-ftp any grief.
+;;; 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 will transfer files in ASCII mode. If a file being
-;;; transferred matches the value of ange-ftp-binary-file-name-regexp then the
-;;; FTP process will be toggled into BINARY mode before the transfer and back
-;;; to ASCII mode after the transfer.
+;;; 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:
;;;
;;; Gateways:
;;;
-;;; Sometimes it is neccessary for the FTP process to be run on a different
+;;; 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.
;;;
;;;
;;; 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 neccessary for temporary files created by ange-ftp.
+;;; 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:
;;; 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 youself into this situation then editing
+;;; 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
;;; VMS support:
;;;
-;;; Ange-ftp has full support for VMS hosts, including tree dired support. It
+;;; 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
;;; 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 tree dired "f"
+;;; 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 $$. There is a bug in EMACS, in that it neglects to quote the
-;;; $'s in the default directory when it writes it in the minibuffer. You
-;;; must edit the minibuffer to quote the $'s manually. Hopefully, this bug
-;;; will be fixed in EMACS 19. If you use Sebastian Kremer's gmhist (V 4.26
-;;; or newer), you will not have this problem.
+;;; by typing $$.
;;; MTS support:
;;;
-;;; Ange-ftp has full support, including tree dired support, for hosts running
+;;; 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
;;; 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 path fashion as
+;;; 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
;;; CMS support:
;;;
-;;; Ange-ftp has full support, including tree dired support, for hosts running
+;;; 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
;;; 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 particulary important when logging in as the root user.
+;;; 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-process can be used to restart the ftp process, which
+;;; ange-ftp-kill-ftp-process can restart the ftp process, which
;;; should get things back in synch.
;;;
;;; 3. Ange-ftp does not check to make sure that when creating a new file,
;;; containing spaces, but beware that the remote ftpd may not like them
;;; much.
;;;
-;;; 12. No classic dired support for non-UNIX systems. Tree dired was enough.
+;;; 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
;;; Technical information on this package:
;;; -----------------------------------------------------------
-;;; The following GNU Emacs functions are replaced by this package:
-;;;
-;;; write-region
-;;; insert-file-contents
-;;; dired-readin
-;;; dired-revert
-;;; dired-call-process
-;;; diff
-;;; delete-file
-;;; read-file-name-internal
-;;; verify-visited-file-modtime
-;;; directory-files
-;;; backup-buffer
-;;; file-directory-p
-;;; file-writable-p
-;;; file-exists-p
-;;; file-readable-p
-;;; file-symlink-p
-;;; file-attributes
-;;; copy-file
-;;; rename-file
-;;; file-name-as-directory
-;;; file-name-directory
-;;; file-name-nondirectory
-;;; file-name-completion
-;;; directory-file-name
-;;; expand-file-name
-;;; file-name-all-completions
-
-;;; LISPDIR ENTRY for the Elisp Archive
-;;;
-;;; LCD Archive Entry:
-;;; ange-ftp|Andy Norman|ange@hplb.hpl.hp.com
-;;; |transparent FTP Support for GNU Emacs
-;;; |$Date: 92/08/14 17:04:34 $|$Revision: 4.20 $|
+;;; 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-path-for-TYPE
-;;; ange-ftp-fix-dir-path-for-TYPE
+;;; 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-host-type
;;; ange-ftp-guess-host-type
;;; ange-ftp-allow-child-lookup
-;;;
-;;; For Tree Dired support:
-;;;
-;;; ange-ftp-dired-TYPE-insert-headerline
-;;; ange-ftp-dired-TYPE-move-to-filename
-;;; ange-ftp-dired-TYPE-move-to-end-of-filename
-;;; ange-ftp-dired-TYPE-get-filename
-;;; ange-ftp-dired-TYPE-between-files
-;;; ange-ftp-TYPE-make-compressed-filename
-;;; ange-ftp-dired-TYPE-ls-trim
-;;; ange-ftp-TYPE-bob-version
-;;; ange-ftp-dired-TYPE-clean-directory
-;;; ange-ftp-dired-TYPE-flag-backup-files
-;;; ange-ftp-dired-TYPE-backup-diff
-;;;
-;;; Variables for dired:
-;;;
-;;; ange-ftp-dired-TYPE-re-exe
-;;; ange-ftp-dired-TYPE-re-dir
;;; Host type conventions:
;;;
;;;
;;; 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
+;;; 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.
;;; Thanks to Ken Laprade for improved .netrc parsing, password reading, and
;;; dired / shell auto-loading.
;;;
-;;; Thanks to Sebastian Kremer for tree dired support and for many ideas and
+;;; 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,
;;; whose names I've forgotten who have helped to debug and fix problems with
;;; ange-ftp.el.
\f
+
+;;; Code:
+(require 'comint)
+
;;;; ------------------------------------------------------------
;;;; User customization variables.
;;;; ------------------------------------------------------------
-(defvar ange-ftp-path-format
+(defvar ange-ftp-name-format
'("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*\\):\\(.*\\)" . (3 2 4))
- "*Format of a fully expanded remote pathname. This is a cons
-\(REGEXP . \(HOST USER PATH\)\), where REGEXP is a regular expression matching
-the full remote pathname, and HOST, USER, and PATH are the numbers of
+ "*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).")
;; ange-ftp-multi-skip-msgs should only match ###-, where ### is one of
;; Otherwise, ange-ftp will go into multi-skip mode, and never come out.
(defvar ange-ftp-multi-msgs
- "^220-\\|^230-\\|^226\\|^25.-\\|^221-\\|^200-\\|^530-\\|^4[25]1-"
- "*Regular expression matching messages from the ftp process that start
-a multiline reply.")
+ "^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 messages from the ftp process that indicate
-that the action that was initiated has completed successfully.")
+ "*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
(concat "^200 \\(PORT\\|Port\\) \\|^331 \\|^150 \\|^350 \\|^[0-9]+ bytes \\|"
"^Connected \\|^$\\|^Remote system\\|^Using\\|^ \\|Password:\\|"
"^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye")
- "*Regular expression matching messages from the ftp process that can be
-ignored.")
+ "*Regular expression matching ftp messages that can be ignored.")
(defvar ange-ftp-fatal-msgs
(concat "^ftp: \\|^Not connected\\|^530 \\|^4[25]1 \\|rcmd: \\|"
"^No control connection\\|unknown host\\|^lost connection")
- "*Regular expression matching messages from the FTP process that indicate
-something has gone drastically wrong attempting the action that was
-initiated and that the FTP process should (or already has) been killed.")
+ "*Regular expression matching ftp messages that indicate serious errors.
+These mean that the FTP process should (or already has) been killed.")
(defvar ange-ftp-gateway-fatal-msgs
"No route to host\\|Connection closed\\|No such host\\|Login incorrect"
- "*Regular expression matching messages from the rlogin / telnet process that
-indicates that logging in to the gateway machine has gone wrong.")
+ "*Regular expression matching login failure messages from rlogin/telnet.")
(defvar ange-ftp-xfer-size-msgs
"^150 .* connection for .* (\\([0-9]+\\) bytes)"
"*If non-nil avoid checking permissions on the .netrc file.")
(defvar ange-ftp-default-user nil
- "*User name to use when none is specied in a pathname.
+ "*User name to use when none is specied in a file name.
If nil, then the name under which the user is logged in is used.
If non-nil but not a string, the user is prompted for the name.")
(defvar ange-ftp-default-account nil
"*Account password to use when the user is the same as ange-ftp-default-user.")
-(defvar ange-ftp-generate-anonymous-password nil
+(defvar ange-ftp-generate-anonymous-password t
"*If t, use a password of user@host when logging in as the anonymous user.
If a string then use that as the password.
If nil then prompt the user for a password.")
(defvar ange-ftp-dumb-unix-host-regexp nil
- "*If non-nil, if the host being ftp'd to matches this regexp then the FTP
-process uses the \'dir\' command to get directory information.")
+ "*If non-nil, regexp matching hosts on which `dir' command lists directory.")
(defvar ange-ftp-binary-file-name-regexp
- (concat "\\.Z$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|"
+ (concat "\\.[zZ]$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|"
"\\.dvi$\\|\\.ps$\\|\\.elc$\\|TAGS$\\|\\.gif$\\|"
- "\\.EXE\\(;[0-9]+\\)?$\\|\\.Z-part-..$")
+ "\\.EXE\\(;[0-9]+\\)?$\\|\\.[zZ]-part-..$\\|\\.gz$\\|"
+ "\\.taz$\\|\\.tgz$")
"*If a file matches this regexp then it is transferred in binary mode.")
(defvar ange-ftp-gateway-host nil
"*Name of host to use as gateway machine when local FTP isn't possible.")
(defvar ange-ftp-local-host-regexp ".*"
- "*If a host being FTP'd to matches this regexp then the ftp process is started
-locally, otherwise the FTP process is started on \`ange-ftp-gateway-host\'
+ "*Regexp selecting hosts which can be reached directly with ftp.
+For other hosts the FTP process is started on \`ange-ftp-gateway-host\'
instead.")
(defvar ange-ftp-gateway-program-interactive nil
- "*If non-nil then the gateway program is expected to connect to the gateway
-machine and eventually give a shell prompt. Both telnet and rlogin do something
-like this.")
+ "*If non-nil then the gateway program should give a shell prompt.
+Both telnet and rlogin do something like this.")
(defvar ange-ftp-gateway-program (if (eq system-type 'hpux) "remsh" "rsh")
- "*Name of program to spawn a shell on the gateway machine. Valid candidates
-are rsh (remsh on hp-ux), telnet and rlogin. See also the gateway variable
-above.")
+ "*Name of program to spawn a shell on the gateway machine.
+Valid candidates are rsh (remsh on hp-ux), telnet and rlogin. See
+also the gateway variable above.")
-(defvar ange-ftp-gateway-prompt-pattern "^[^#$%>;]*[#$%>;] *"
- "*Regexp used to detect that the logging-in sequence is completed on the
-gateway machine and that the shell is now awaiting input. Make this regexp as
+(defvar 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.")
(if (eq system-type 'hpux)
"stty -onlcr -echo\n"
"stty -echo nl\n")
- "*Command to use after logging in to the gateway machine to stop the terminal
-echoing each command and to strip out trailing ^M characters.")
+ "*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.")
(defvar ange-ftp-smart-gateway nil
- "*If the gateway FTP is smart enough to use proxy server, then don't bother
-telnetting etc, just issue a user@host command instead.")
+ "*Non-nil means the ftp gateway is smart.
+Don't bother telnetting, etc., just issue a user@host command instead.")
(defvar ange-ftp-smart-gateway-port "21"
"*Port on gateway machine to use when smart gateway is in operation.")
"*If non-NIL then a string naming nslookup program." )
(defvar ange-ftp-make-backup-files ()
- "*A list of operating systems for which ange-ftp will make Emacs backup
-files files on the remote host. For example, '\(unix\) makes sense, but
-'\(unix vms\) or '\(vms\) would be silly, since vms makes its own backups.")
+ "*Non-nil means make backup files for \"magic\" remote files.")
(defvar ange-ftp-retry-time 5
- "*Number of seconds to wait before retrying if a file or listing
-doesn't arrive. This might need to be increased for very slow connections.")
+ "*Number of seconds to wait before retry if file or listing doesn't arrive.
+This might need to be increased for very slow connections.")
(defvar ange-ftp-auto-save 0
"If 1, allows ange-ftp files to be auto-saved.
(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 the hashtable, as strings."
+ "Return a sorted list of all the active keys in TABLE, as strings."
(sort (all-completions "" tbl)
(function string-lessp)))
\f
;;;; Internal variables.
;;;; ------------------------------------------------------------
-(defconst ange-ftp-version "$Revision: 4.20 $")
+(defconst ange-ftp-version "$Revision: 1.50 $")
(defvar ange-ftp-data-buffer-name " *ftp data*"
"Buffer name to hold directory listing data received from ftp process.")
(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)
\f
(defmacro ange-ftp-save-match-data (&rest body)
"Execute the BODY forms, restoring the global value of the match data.
-Before executing BODY, case-fold-search is locally bound to nil."
+Also makes matching case-sensitive within BODY."
(let ((original (make-symbol "match-data"))
case-fold-search)
(list
;;; ------------------------------------------------------------
(defun ange-ftp-message (fmt &rest args)
- "Output the given message, but truncate to the size of the minibuffer
-window."
+ "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 (>= (length msg) max)
(message "%s" msg)))
(defun ange-ftp-abbreviate-filename (file &optional new)
- "Abbreviate the given filename relative to the default-directory. If the
-optional parameter NEW is given and the non-directory parts match, only return
-the directory part of the file."
+ "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."
(ange-ftp-save-match-data
(if (and default-directory
(string-match (concat "^"
(if (> (length pass) 0)
(setq pass (substring pass 0 -1))))))
(message "")
-;; (ange-ftp-repaint-minibuffer)
+ (ange-ftp-repaint-minibuffer)
pass))
(defmacro ange-ftp-generate-passwd-key (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 overriden the
+ ;; look up password in the hash table first; user might have overridden the
;; defaults.
(cond ((ange-ftp-lookup-passwd host user))
;;;; ------------------------------------------------------------
(defun ange-ftp-chase-symlinks (file)
- "Return the filename that FILENAME references, following all symbolic links."
+ "Return the filename that FILE references, following all symbolic links."
(let (temp)
(while (setq temp (ange-ftp-real-file-symlink-p file))
(setq file
(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)
- "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."
(if (search-forward token limit t)
(let (beg)
(skip-chars-forward ", \t\r\n" limit)
(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 ()
- "Extract the values for the tokens \`machine\', \`login\', \`password\'
-and \`account\' in the current buffer. If successful, record the information
-found."
(beginning-of-line)
(let ((start (point))
(end (progn (re-search-forward "machine\\|default"
(setq ange-ftp-default-account account)))))
(goto-char end)))
-(defun ange-ftp-parse-netrc ()
- "If ~/.netrc file exists and has the correct permissions then extract the
-\`machine\', \`login\', \`password\' and \`account\' information from within."
+;; 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)
(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 ()
- "Return a list of prefixes of the form 'user@host:' to be used when
-completion is done in the root directory."
(ange-ftp-parse-netrc)
(ange-ftp-save-match-data
(let (res)
(or res (list nil)))))
\f
;;;; ------------------------------------------------------------
-;;;; Remote pathname syntax support.
+;;;; Remote file name syntax support.
;;;; ------------------------------------------------------------
-(defmacro ange-ftp-ftp-path-component (n ns path)
- "Extract the Nth ftp path component from NS."
+(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 (, path) (match-beginning elt) (match-end elt))))))
-
-(defvar ange-ftp-ftp-path-arg "")
-(defvar ange-ftp-ftp-path-res nil)
-
-(defun ange-ftp-ftp-path (path)
- "Parse PATH according to ange-ftp-path-format (which see).
-Returns a list (HOST USER PATH), or nil if PATH does not match the format."
- (if (string-equal path ange-ftp-ftp-path-arg)
- ange-ftp-ftp-path-res
- (setq ange-ftp-ftp-path-arg path
- ange-ftp-ftp-path-res
+ (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
(ange-ftp-save-match-data
- (if (string-match (car ange-ftp-path-format) path)
- (let* ((ns (cdr ange-ftp-path-format))
- (host (ange-ftp-ftp-path-component 0 ns path))
- (user (ange-ftp-ftp-path-component 1 ns path))
- (path (ange-ftp-ftp-path-component 2 ns path)))
+ (if (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 path))
+ (list host user name))
nil)))))
-(defun ange-ftp-replace-path-component (fullpath path)
- "Take a FULLPATH that matches according to ange-ftp-path-format and
-replace the path component with PATH."
+;; 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)
(ange-ftp-save-match-data
- (if (string-match (car ange-ftp-path-format) fullpath)
- (let* ((ns (cdr ange-ftp-path-format))
+ (if (string-match (car ange-ftp-name-format) fullname)
+ (let* ((ns (cdr ange-ftp-name-format))
(elt (nth 2 ns)))
- (concat (substring fullpath 0 (match-beginning elt))
- path
- (substring fullpath (match-end elt)))))))
+ (concat (substring fullname 0 (match-beginning elt))
+ name
+ (substring fullname (match-end elt)))))))
\f
;;;; ------------------------------------------------------------
;;;; 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 ()
-;; "Gross hack to set minibuf_message = 0, so that the contents of the
-;; minibuffer will show."
-;; (if (eq (selected-window) (minibuffer-window))
-;; (if (fboundp 'allocate-event)
-;; ;; lemacs
-;; (let ((unread-command-event (character-to-event ?\C-m
-;; (allocate-event)))
-;; (enable-recursive-minibuffers t))
-;; (read-from-minibuffer "" nil ange-ftp-tmp-keymap nil))
-;; ;; v18 GNU Emacs
-;; (let ((unread-command-char ?\C-m)
-;; (enable-recursive-minibuffers t))
-;; (read-from-minibuffer "" nil ange-ftp-tmp-keymap nil)))))
+(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)
- "Return the name of the buffer that collects output from the ftp process
-connected to the given HOST and USER pair."
(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)
- "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."
(let ((cur (selected-window))
(pop-up-windows t))
(pop-to-buffer
(signal 'ftp-error (list (format "FTP Error: %s" msg))))
(defun ange-ftp-set-buffer-mode ()
- "Set the correct modes for the current buffer if it is visiting a remote
-file."
+ "Set correct modes for the current buffer if visiting a remote file."
(if (and (stringp buffer-file-name)
- (ange-ftp-ftp-path buffer-file-name))
+ (ange-ftp-ftp-name buffer-file-name))
(progn
- (auto-save-mode ange-ftp-auto-save)
- (make-variable-buffer-local 'revert-buffer-function)
- (setq revert-buffer-function 'ange-ftp-revert-buffer))))
+ (make-local-variable 'make-backup-files)
+ (setq make-backup-files ange-ftp-make-backup-files)
+ (auto-save-mode ange-ftp-auto-save))))
(defun ange-ftp-kill-ftp-process (buffer)
- "If the BUFFER's visited filename or default-directory is an ftp filename
+ "Kill the FTP process associated with BUFFER.
+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)))
(let ((file (or (buffer-file-name) default-directory)))
(if file
- (let ((parsed (ange-ftp-ftp-path (expand-file-name file))))
+ (let ((parsed (ange-ftp-ftp-name (expand-file-name file))))
(if parsed
(let ((host (nth 0 parsed))
(user (nth 1 parsed)))
;;;; ------------------------------------------------------------
(defun ange-ftp-process-handle-line (line proc)
- "Look at the given LINE from the ftp process PROC. Try to catagorize it
-into one of four categories: good, skip, fatal, or unknown."
+ "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
(setq ange-ftp-process-busy nil
ange-ftp-process-result-line line))))
-(defun ange-ftp-process-log-string (proc str)
- "For a given PROCESS, log the given STRING at the end of its
-associated buffer."
- (let ((old-buffer (current-buffer)))
- (unwind-protect
- (let (moving)
- (set-buffer (process-buffer proc))
- (setq moving (= (point) (process-mark proc)))
- (save-excursion
- ;; Insert the text, moving the process-marker.
- (goto-char (process-mark proc))
- (insert str)
- (set-marker (process-mark proc) (point)))
- (if moving (goto-char (process-mark proc))))
- (set-buffer old-buffer))))
-
(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)))
(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)
- "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."
(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)
- "Build up a complete line of output from the ftp PROCESS and pass it
-on to ange-ftp-process-handle-line to deal with."
(let ((buffer (process-buffer proc))
(old-buffer (current-buffer)))
ange-ftp-process-busy
(string-match "^#+$" str)
(setq str (ange-ftp-process-handle-hash str)))
- (ange-ftp-process-log-string proc str)
+ (comint-output-filter proc str)
(if ange-ftp-process-busy
(progn
(setq ange-ftp-process-string (concat ange-ftp-process-string
ange-ftp-process-result)
(progn
(ange-ftp-message "%s...done" ange-ftp-process-msg)
-;; (ange-ftp-repaint-minibuffer)
+ (ange-ftp-repaint-minibuffer)
(setq ange-ftp-process-msg nil)))
;; is there a continuation we should be calling? if so,
(defun ange-ftp-gwp-filter (proc str)
(ange-ftp-save-match-data
- (ange-ftp-process-log-string proc str)
+ (comint-output-filter proc str)
(cond ((string-match "login: *$" str)
(send-string proc
(concat
(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))
- (proc (start-process name name
- ange-ftp-gateway-program
- 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))
(save-excursion
(set-buffer (process-buffer proc))
(while ange-ftp-process-busy
- (accept-process-output))
+ ;; 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))
+ (accept-process-output)))
(setq ange-ftp-process-string ""
ange-ftp-process-result-line ""
ange-ftp-process-busy t
cmd (concat cmd "\n"))
(and msg ange-ftp-process-verbose (ange-ftp-message "%s..." msg))
(goto-char (point-max))
- (move-marker last-input-start (point))
+ (move-marker comint-last-input-start (point))
;; don't insert the password into the buffer on the USER command.
(ange-ftp-save-match-data
(if (string-match "^user \"[^\"]*\"" cmd)
(insert (substring cmd 0 (match-end 0)) " Turtle Power!\n")
(insert cmd)))
- (move-marker last-input-end (point))
+ (move-marker comint-last-input-end (point))
(send-string proc cmd)
(set-marker (process-mark proc) (point))
(if nowait
nil
;; hang around for command to complete
(while ange-ftp-process-busy
- (accept-process-output proc))
+ ;; This is a kludge to let user quit in case ftp gets hung.
+ ;; It matters because this function can be called from the filter.
+ (let ((quit-flag nil)
+ (inhibit-quit nil))
+ (accept-process-output proc)))
(if cont
nil ;cont has already been called
(cons ange-ftp-process-result ange-ftp-process-result-line))))))
"Attempt to resolve the given HOSTNAME using nslookup if possible."
(interactive "sHost: ")
(if ange-ftp-nslookup-program
- (let ((proc (start-process " *nslookup*" " *nslookup*"
- ange-ftp-nslookup-program host))
+ (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
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)
- (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)))
+ ;; 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))
+ (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))))
(process-kill-without-query proc)
- ;; ??? Here is the place to put the ftp buffer in some appropriate mode.
(save-excursion
(set-buffer (process-buffer proc))
- (ange-ftp-make-buffer-variables))
+ (internal-ange-ftp-mode))
(set-process-sentinel proc (function ange-ftp-process-sentinel))
(set-process-filter proc (function ange-ftp-process-filter))
(accept-process-output proc) ;wait for ftp startup message
proc))
-(defun ange-ftp-make-buffer-variables ()
+(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 'last-input-start)
- (setq last-input-start (make-marker))
- (make-local-variable 'last-input-end)
- (setq last-input-end (make-marker))
(goto-char (point-max))
(set-marker (process-mark proc) (point))
(make-local-variable 'ange-ftp-process-string)
(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 ange-ftp-process-result-line "")
+
+ (setq comint-prompt-regexp "^ftp> ")
+ (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.
(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.")
(setq ange-ftp-binary-hash-mark-size size)))))))))
(defun ange-ftp-get-process (host user)
- "Return the process object for a FTP process connected to HOST and
-logged in as USER. Create a new process if needed."
+ "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)))
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-vos-host)
+;; (ange-ftp-vos-host host))
+;; 'vos)
((and (fboundp 'ange-ftp-vms-host)
(ange-ftp-vms-host host))
'vms)
;; 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-path-func-alist nil
- "Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
-which can change a UNIX path into a path more suitable for a host of type
+(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-path-func-alist nil
- "Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
-which can change UNIX directory path into a directory path more suitable
+(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
command.
See the documentation for ange-ftp-raw-send-cmd for a description of CONT
and NOWAIT."
- ;; Handle conversion to remote pathname syntax and remote ls option
+ ;; Handle conversion to remote file name syntax and remote ls option
;; capability.
(let ((cmd0 (car cmd))
(cmd1 (nth 1 cmd))
- cmd2 cmd3 host-type fix-pathname-func)
+ (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-path" "local-path" "ls-switches"
+ ;; 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-path-func-alist))
+ (or (cdr (assq host-type ange-ftp-fix-dir-name-func-alist))
'identity)
cmd1)
cmd3 (nth 3 cmd))
(setq cmd0 'ls
cmd1 (format "\"%s %s\"" cmd3 cmd1))))
- ;; First argument is the remote pathname
- ((let ((ange-ftp-this-user user)
- (ange-ftp-this-host host))
- (setq fix-pathname-func (or (cdr (assq host-type
- ange-ftp-fix-path-func-alist))
- 'identity))
+ ;; 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-pathname-func cmd1)))
+ (setq cmd1 (funcall fix-name-func cmd1)))
- ;; Second argument is the remote pathname
+ ;; Second argument is the remote name
((memq cmd0 '(append put chmod))
- (setq cmd2 (funcall fix-pathname-func cmd2)))
+ (setq cmd2 (funcall fix-name-func cmd2)))
- ;; Both arguments are remote pathnames
+ ;; Both arguments are remote names
((eq cmd0 'rename)
- (setq cmd1 (funcall fix-pathname-func cmd1)
- cmd2 (funcall fix-pathname-func cmd2))))
+ (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))
;; seen. No point in slowing things down just so users can read
;; a host type message.
-(defconst ange-ftp-cms-path-template
+(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-path-template
+(defconst ange-ftp-vms-name-template
"^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$")
-(defconst ange-ftp-mts-path-template
+(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 by doing a pwd, and examining
-the directory syntax."
+ "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)
(ange-ftp-save-match-data
(let* ((result (ange-ftp-get-pwd host user))
(dir (car result))
- fix-path-func)
+ fix-name-func)
(cond ((null dir)
(message "Warning! Unable to get home directory")
(sit-for 1)
ange-ftp-host-type-cache 'cms))))
;; try for VMS
- ((string-match ange-ftp-vms-path-template dir)
+ ((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.
ange-ftp-host-type-cache 'vms))
;; try for MTS
- ((string-match ange-ftp-mts-path-template dir)
+ ((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-path-template dir)
+ ((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))
;; the expand-dir hashtable.
(let ((ange-ftp-this-user user)
(ange-ftp-this-host host))
- (setq fix-path-func (cdr (assq ange-ftp-host-type-cache
- ange-ftp-fix-path-func-alist)))
- (if fix-path-func
- (setq dir (funcall fix-path-func dir 'reverse))))
+ (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))))
;;;; 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)
- "Returns whether HOST's FTP server doesn't like \'ls\' or \'dir\' commands
-to take switch arguments."
(and ange-ftp-dumb-unix-host-regexp
(ange-ftp-save-match-data
(string-match ange-ftp-dumb-unix-host-regexp host))))
"Interactively adds a given HOST to ange-ftp-dumb-unix-host-regexp."
(interactive
(list (read-string "Host: "
- (let ((name (or (buffer-file-name)
- (and (eq major-mode 'dired-mode)
- dired-directory))))
- (and name (car (ange-ftp-ftp-path name)))))))
+ (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) "$"
ange-ftp-host-cache nil)))
(defvar ange-ftp-parse-list-func-alist nil
- "Association list of \( TYPE \. FUNC \) pairs. The FUNC is a routine
+ "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-path
+;; 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-path
+;; an error if not an ange-ftp-name
;; error if listing is unreable (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
;; so we can go on and try to list the parent.)
;; the listing, if everything works.
-(defun ange-ftp-ls (file lsargs parse &optional no-error)
+;; 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'.
+
+(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
;; 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-path ange-ftp-this-file)))
+ (parsed (ange-ftp-ftp-name ange-ftp-this-file)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
- (path (ange-ftp-quote-string (nth 2 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 path "")
- (setq path
+ (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
(or dumb (string-equal lsargs ange-ftp-ls-cache-lsargs)))
ange-ftp-ls-cache-res
(setq temp (ange-ftp-make-tmp-name host))
- (setq lscmd (list 'dir path temp lsargs))
+ (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
"\\|Nov\\|Dec\\) +[0-3]?[0-9] "))
(defvar ange-ftp-add-file-entry-alist nil
- "Association list of pairs \( TYPE \. FUNC \), where FUNC
+ "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
- "Association list of pairs \( TYPE \. FUNC \), where FUNC
+ "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.")
+The main reason for this alist is to deal with file versions in VMS.")
-(defun ange-ftp-add-file-entry (path &optional dir-p)
- "Given a PATH, add the file entry for it, if its directory
-info exists."
+(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-path path)))
+ (car (ange-ftp-ftp-name name)))
ange-ftp-add-file-entry-alist))
'ange-ftp-internal-add-file-entry)
- path dir-p)
+ name dir-p)
(setq ange-ftp-ls-cache-file nil))
-(defun ange-ftp-delete-file-entry (path &optional dir-p)
- "Given a PATH, delete the file entry for it, if its directory
-info exists."
+(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-path path)))
+ (car (ange-ftp-ftp-name name)))
ange-ftp-delete-file-entry-alist))
'ange-ftp-internal-delete-file-entry)
- path dir-p)
+ name dir-p)
(setq ange-ftp-ls-cache-file nil))
(defmacro ange-ftp-parse-filename ()
;;; The dl stuff for descriptive listings
(defvar ange-ftp-dl-dir-regexp nil
- "Regexp matching directories which are listed in dl format. This regexp
-shouldn't be anchored with a trailing $ so that it will match subdirectories
-as well.")
+ "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 given directory to ange-ftp-dl-dir-regexp."
+ "Interactively adds a DIR to ange-ftp-dl-dir-regexp."
(interactive
(list (read-string "Directory: "
- (let ((name (or (buffer-file-name)
- (and (eq major-mode 'dired-mode)
- dired-directory))))
- (and name (ange-ftp-ftp-path name)
+ (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)))
(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)
- "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."
(ange-ftp-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.
(ange-ftp-get-hash-entry
directory ange-ftp-files-hashtable)))))
-(defmacro ange-ftp-get-file-part (path)
- "Given PATH, return the file part that can be used for looking up the
-file's entry in a hashtable."
- (` (let ((file (file-name-nondirectory (, path))))
+;; 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)
- "Return whether ange-ftp-file-entry-p and ange-ftp-get-file-entry are
-allowed to determine if PATH 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."
(` (not
(let* ((efile (, file)) ; expand once.
(edir (, dir))
- (parsed (ange-ftp-ftp-path edir))
+ (parsed (ange-ftp-ftp-name edir))
(host-type (ange-ftp-host-type
(car parsed))))
(or
- ;; Deal with dired
- (and (boundp 'dired-local-variables-file)
- (stringp dired-local-variables-file)
- (string-equal dired-local-variables-file efile))
+;;; This variable seems not to exist in Emacs 19 -- rms.
+;;; ;; Deal with dired
+;;; (and (boundp 'dired-local-variables-file)
+;;; (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))
(and (memq host-type '(mts cms))
(not (string-equal "/" (nth 2 parsed)))))))))
-(defun ange-ftp-file-entry-p (path)
- "Given PATH, return whether there is a file entry for it."
- (let* ((path (directory-file-name path))
- (dir (file-name-directory path))
+(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 path)))
+ (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 path t))
+ (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,
(ange-ftp-hash-entry-exists-p file
(ange-ftp-get-files dir))))))
-(defun ange-ftp-get-file-entry (path)
- "Given PATH, return the given file entry which 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* ((path (directory-file-name path))
- (dir (file-name-directory path))
+(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 path)))
+ (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 path t))
+ (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 (path &optional dir-p)
+(defun ange-ftp-internal-delete-file-entry (name &optional dir-p)
(if dir-p
(progn
- (setq path (file-name-as-directory path))
- (ange-ftp-del-hash-entry path ange-ftp-files-hashtable)
- (setq path (directory-file-name path))))
+ (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 path)
+ (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 path)
+ (ange-ftp-del-hash-entry (ange-ftp-get-file-part name)
files))))
-(defun ange-ftp-internal-add-file-entry (path &optional dir-p)
+(defun ange-ftp-internal-add-file-entry (name &optional dir-p)
(and dir-p
- (setq path (directory-file-name path)))
- (let ((files (ange-ftp-get-hash-entry (file-name-directory path)
+ (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 path)
+ (ange-ftp-put-hash-entry (ange-ftp-get-file-part name)
dir-p
files))))
(defun ange-ftp-wipe-file-entries (host user)
- "Replace the file entry information hashtable with one that doesn't have any
-entries for the given HOST, USER pair."
+ "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-path key)))
+ (let ((parsed (ange-ftp-ftp-name key)))
(if parsed
(let ((h (nth 0 parsed))
(u (nth 1 parsed)))
;;; ------------------------------------------------------------
(defun ange-ftp-expand-dir (host user dir)
- "Return the result of doing a PWD in the current FTP session to machine HOST
+ "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-pathname-func
- (cdr (assq host-type ange-ftp-fix-path-func-alist)))
+ (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
(if res
(let ((ange-ftp-this-user user)
(ange-ftp-this-host host))
- (if fix-pathname-func
- (setq res (funcall fix-pathname-func res 'reverse)))
+ (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))))
"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-path n)))
+ (let ((parsed (ange-ftp-ftp-name n)))
(if parsed
(let ((host (car parsed))
(user (nth 1 parsed))
- (path (nth 2 parsed)))
+ (name (nth 2 parsed)))
- ;; See if remote path is absolute. If so then just expand it and
- ;; replace the path component of the overall path.
- (cond ((string-match "^/" path)
- path)
+ ;; 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)
- ;; Path starts with ~ or ~user. Resolve that part of the path
+ ;; Name starts with ~ or ~user. Resolve that part of the name
;; making it absolute then re-expand it.
- ((string-match "^~[^/]*" path)
- (let* ((tilda (substring path
+ ((string-match "^~[^/]*" name)
+ (let* ((tilda (substring name
(match-beginning 0)
(match-end 0)))
- (rest (substring path (match-end 0)))
+ (rest (substring name (match-end 0)))
(dir (ange-ftp-expand-dir host user tilda)))
(if dir
- (setq path (concat dir rest))
+ (setq name (concat dir rest))
(error "User \"%s\" is not known"
(substring tilda 1)))))
- ;; relative path. Tack on homedir and re-expand.
+ ;; relative name. Tack on homedir and re-expand.
(t
(let ((dir (ange-ftp-expand-dir host user "~")))
(if dir
- (setq path (concat
+ (setq name (concat
(ange-ftp-real-file-name-as-directory dir)
- path))
+ name))
(error "Unable to obtain CWD")))))
- (setq path (ange-ftp-real-expand-file-name path))
+ (setq name (ange-ftp-real-expand-file-name name))
;; see if hit real expand-file-name bug... this will probably annoy
;; some Apollo people. I'll wait until they shout, however.
- (if (string-match "^//" path)
- (setq path (substring path 1)))
+ (if (string-match "^//" name)
+ (setq name (substring name 1)))
- ;; Now substitute the expanded path back into the overall filename.
- (ange-ftp-replace-path-component n path))
+ ;; Now substitute the expanded name back into the overall filename.
+ (ange-ftp-replace-name-component n name))
- ;; non-ange-ftp path. Just expand normally.
+ ;; 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
;;; These are problems--they are currently not enabled.
(defvar ange-ftp-file-name-as-directory-alist nil
- "Association list of \( TYPE \. FUNC \) pairs, where
+ "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-path name)))
+ (let ((parsed (ange-ftp-ftp-name name)))
(if parsed
(if (string-equal (nth 2 parsed) "")
name
(defun ange-ftp-file-name-directory (name)
"Documented as original."
- (let ((parsed (ange-ftp-ftp-path name)))
+ (let ((parsed (ange-ftp-ftp-name name)))
(if parsed
- (let ((path (nth 2 parsed)))
+ (let ((filename (nth 2 parsed)))
(if (ange-ftp-save-match-data
- (string-match "^~[^/]*$" path))
+ (string-match "^~[^/]*$" filename))
name
- (ange-ftp-replace-path-component
+ (ange-ftp-replace-name-component
name
- (ange-ftp-real-file-name-directory path))))
+ (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-path name)))
+ (let ((parsed (ange-ftp-ftp-name name)))
(if parsed
- (let ((path (nth 2 parsed)))
+ (let ((filename (nth 2 parsed)))
(if (ange-ftp-save-match-data
- (string-match "^~[^/]*$" path))
+ (string-match "^~[^/]*$" filename))
""
- (ange-ftp-real-file-name-nondirectory path)))
+ (ange-ftp-real-file-name-nondirectory name)))
(ange-ftp-real-file-name-nondirectory name))))
(defun ange-ftp-directory-file-name (dir)
"Documented as original."
- (let ((parsed (ange-ftp-ftp-path dir)))
+ (let ((parsed (ange-ftp-ftp-name dir)))
(if parsed
- (ange-ftp-replace-path-component
+ (ange-ftp-replace-name-component
dir
(ange-ftp-real-directory-file-name (nth 2 parsed)))
(ange-ftp-real-directory-file-name dir))))
\f
;;; Hooks that handle Emacs primitives.
+;; Returns non-nil if should transfer FILE in binary mode.
(defun ange-ftp-binary-file (file)
- "Returns whether the given FILE is to be considered as a binary file for
-ftp transfers."
(ange-ftp-save-match-data
(string-match ange-ftp-binary-file-name-regexp file)))
(defun ange-ftp-write-region (start end filename &optional append visit)
- "Documented as original."
- (interactive "r\nFWrite region to file: ")
(setq filename (expand-file-name filename))
- (let ((parsed (ange-ftp-ftp-path filename)))
+ (let ((parsed (ange-ftp-ftp-name filename)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
- (path (ange-ftp-quote-string (nth 2 parsed)))
+ (name (ange-ftp-quote-string (nth 2 parsed)))
(temp (ange-ftp-make-tmp-name host))
(binary (ange-ftp-binary-file filename))
(cmd (if append 'append 'put))
;; put or append the file.
(let ((result (ange-ftp-send-cmd host user
- (list cmd temp path)
+ (list cmd temp name)
(format "Writing %s" abbr))))
(or (car result)
(signal 'ftp-error
(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)))
(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)
- "Documented as original."
+(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-path filename)))
+ (let ((parsed (ange-ftp-ftp-name filename)))
(if parsed
(progn
(if visit
(file-exists-p filename)))
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
- (path (ange-ftp-quote-string (nth 2 parsed)))
+ (name (ange-ftp-quote-string (nth 2 parsed)))
(temp (ange-ftp-make-tmp-name host))
(binary (ange-ftp-binary-file filename))
(abbr (ange-ftp-abbreviate-filename filename))
(if binary
(ange-ftp-set-binary-mode host user))
(let ((result (ange-ftp-send-cmd host user
- (list 'get path temp)
+ (list 'get name temp)
(format "Retrieving %s" abbr))))
(or (car result)
(signal 'ftp-error
(ange-ftp-real-file-readable-p temp))
(setq
size
- (nth 1 (ange-ftp-real-insert-file-contents temp
- visit)))
+ (nth 1 (ange-ftp-real-insert-file-contents
+ temp visit beg end replace)))
(signal 'ftp-error
(list
"Opening input file:"
(ange-ftp-set-ascii-mode host user))
(ange-ftp-del-tmp-name temp))
(if visit
- (setq buffer-file-name filename))
+ (progn
+ (set-visited-file-modtime '(0 0))
+ (setq buffer-file-name filename)))
(list filename size))
(signal 'file-error
(list
"Opening input file"
filename))))
- (ange-ftp-real-insert-file-contents filename visit))))
+ (ange-ftp-real-insert-file-contents filename visit beg end replace))))
-(defun ange-ftp-revert-buffer (arg noconfirm)
- "Revert this buffer from a remote file using ftp."
- (let ((opoint (point)))
- (cond ((null buffer-file-name)
- (error "Buffer does not seem to be associated with any file"))
- ((or noconfirm
- (yes-or-no-p (format "Revert buffer from file %s? "
- buffer-file-name)))
- (let ((buffer-read-only nil))
- ;; Set buffer-file-name to nil
- ;; so that we don't try to lock the file.
- (let ((buffer-file-name nil))
- (unlock-buffer)
- (erase-buffer))
- (insert-file-contents buffer-file-name t))
- (goto-char (min opoint (point-max)))
- (after-find-file nil)
- t))))
-
(defun ange-ftp-expand-symlink (file dir)
(if (file-name-absolute-p file)
- (ange-ftp-replace-path-component dir file)
+ (ange-ftp-replace-name-component dir file)
(expand-file-name file dir)))
(defun ange-ftp-file-symlink-p (file)
- "Documented as original."
;; 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-path 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-path-component
+ (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 (path)
- "Documented as original."
- (setq path (expand-file-name path))
- (if (ange-ftp-ftp-path path)
- (if (ange-ftp-file-entry-p path)
- (let ((file-ent (ange-ftp-get-file-entry path)))
+(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 path))))
+ (directory-file-name name))))
t)))
- (ange-ftp-real-file-exists-p path)))
+ (ange-ftp-real-file-exists-p name)))
-(defun ange-ftp-file-directory-p (path)
- "Documented as original."
- (setq path (expand-file-name path))
- (if (ange-ftp-ftp-path path)
- ;; We do a file-name-as-directory on path here because some
+(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 path))))
+ (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 path))))
+ (directory-file-name name))))
file-ent))
- (ange-ftp-real-file-directory-p path)))
+ (ange-ftp-real-file-directory-p name)))
(defun ange-ftp-directory-files (directory &optional full match
&rest v19-args)
- "Documented as original."
(setq directory (expand-file-name directory))
- (if (ange-ftp-ftp-path directory)
+ (if (ange-ftp-ftp-name directory)
(progn
(ange-ftp-barf-if-not-directory directory)
(let ((tail (ange-ftp-hash-table-keys
(apply 'ange-ftp-real-directory-files directory full match v19-args)))
(defun ange-ftp-file-attributes (file)
- "Documented as original."
(setq file (expand-file-name file))
- (let ((parsed (ange-ftp-ftp-path 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))
- (path (nth 2 parsed))
+ (name (nth 2 parsed))
(dirp (ange-ftp-get-hash-entry part files)))
(list (if (and (stringp dirp) (file-name-absolute-p dirp))
(ange-ftp-expand-symlink dirp
(apply '+ (nconc (mapcar 'identity host)
(mapcar 'identity user)
(mapcar 'identity
- (directory-file-name path))))
+ (directory-file-name name))))
-1 ;11 device number [v19 only]
))))
(ange-ftp-real-file-attributes file))))
(defun ange-ftp-file-writable-p (file)
- "Documented as original."
(setq file (expand-file-name file))
- (if (ange-ftp-ftp-path 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)
- "Documented as original."
(setq file (expand-file-name file))
- (if (ange-ftp-ftp-path 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)
- "Documented as original."
(interactive "fDelete file: ")
(setq file (expand-file-name file))
- (let ((parsed (ange-ftp-ftp-path file)))
+ (let ((parsed (ange-ftp-ftp-name file)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
- (path (ange-ftp-quote-string (nth 2 parsed)))
+ (name (ange-ftp-quote-string (nth 2 parsed)))
(abbr (ange-ftp-abbreviate-filename file))
(result (ange-ftp-send-cmd host user
- (list 'delete path)
+ (list 'delete name)
(format "Deleting %s" abbr))))
(or (car result)
(signal 'ftp-error
(ange-ftp-real-delete-file file))))
(defun ange-ftp-verify-visited-file-modtime (buf)
- "Documented as original."
(let ((name (buffer-file-name buf)))
- (if (and (stringp name) (ange-ftp-ftp-path name))
+ (if (and (stringp name) (ange-ftp-ftp-name name))
t
(ange-ftp-real-verify-visited-file-modtime buf))))
-
-(defun ange-ftp-backup-buffer ()
- "Documented as original."
- (let (parsed)
- (if (and
- (listp ange-ftp-make-backup-files)
- (stringp buffer-file-name)
- (setq parsed (ange-ftp-ftp-path buffer-file-name))
- (or
- (null ange-ftp-make-backup-files)
- (not
- (memq
- (ange-ftp-host-type
- (car parsed))
- ange-ftp-make-backup-files))))
- nil
- (ange-ftp-real-backup-buffer))))
\f
;;;; ------------------------------------------------------------
;;;; File copying support... totally re-written 6/24/92.
;; (kill-buffer (current-buffer))))))
;; this is the extended version of ange-ftp-copy-file-internal that works
-;; asyncronously if asked nicely.
+;; 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)
(if (file-directory-p newname)
(setq newname (expand-file-name (file-name-nondirectory filename) newname)))
- (let ((f-parsed (ange-ftp-ftp-path filename))
- (t-parsed (ange-ftp-ftp-path 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))
;; 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-path (and f-parsed (ange-ftp-quote-string (nth 2 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-path (and t-parsed (ange-ftp-quote-string (nth 2 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)))
(ange-ftp-send-cmd
f-host
f-user
- (list 'get f-path (or temp1 newname))
+ (list 'get f-name (or temp1 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-path f-abbr
- t-parsed t-host t-user t-path t-abbr
+ 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))
;; 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-path f-abbr
- t-parsed t-host t-user t-path t-abbr
+ f-parsed f-host f-user f-name f-abbr
+ t-parsed t-host t-user t-name t-abbr
nil nil cont nowait))))))
;; next part of copying routine.
(defun ange-ftp-cf1 (result line
filename newname binary msg
- f-parsed f-host f-user f-path f-abbr
- t-parsed t-host t-user t-path t-abbr
+ 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.
(ange-ftp-send-cmd
t-host
t-user
- (list 'put (or temp2 filename) t-path)
+ (list 'put (or temp2 filename) t-name)
(or msg
(if (and temp2 f-parsed)
(format "Putting %s" newname)
(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists
keep-date)
- "Documented as original."
(interactive "fCopy file: \nFCopy %s to file: \np")
(ange-ftp-copy-file-internal filename
newname
(t-user (nth 1 t-parsed)))
(if (and (string-equal f-host t-host)
(string-equal f-user t-user))
- (let* ((f-path (ange-ftp-quote-string (nth 2 f-parsed)))
- (t-path (ange-ftp-quote-string (nth 2 t-parsed)))
- (cmd (list 'rename f-path t-path))
+ (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
(delete-file filename))))
(defun ange-ftp-rename-local-to-remote (filename newname)
- "Rename local FILE to remote file 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)))
(delete-file filename))))
(defun ange-ftp-rename-remote-to-local (filename newname)
- "Rename remote file FILE to local file 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)))
(delete-file filename))))
(defun ange-ftp-rename-file (filename newname &optional ok-if-already-exists)
- "Documented as original."
(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-path filename))
- (t-parsed (ange-ftp-ftp-path newname))
+ (let* ((f-parsed (ange-ftp-ftp-name filename))
+ (t-parsed (ange-ftp-ftp-name newname))
(binary (if (or f-parsed t-parsed) (ange-ftp-binary-file filename))))
(if (and (or f-parsed t-parsed)
(or (not 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)
- "If the file entry is a symlink, returns whether the file pointed to exists.
-Note that `ange-ftp-this-dir' is used as a free variable."
(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)
- "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."
(let ((val (get sym 'val))
(symname (symbol-name sym)))
(if (stringp val)
(not (string-match ange-ftp-completion-ignored-pattern symname))))))
(defun ange-ftp-file-name-all-completions (file dir)
- "Documented as original."
(let ((ange-ftp-this-dir (expand-file-name dir)))
- (if (ange-ftp-ftp-path ange-ftp-this-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-all-completions file ange-ftp-this-dir)))))
(defun ange-ftp-file-name-completion (file dir)
- "Documented as original."
(let ((ange-ftp-this-dir (expand-file-name dir)))
- (if (ange-ftp-ftp-path ange-ftp-this-dir)
+ (if (ange-ftp-ftp-name ange-ftp-this-dir)
(progn
(ange-ftp-barf-if-not-directory ange-ftp-this-dir)
(if (equal file "")
(defun ange-ftp-file-name-completion-1 (file tbl dir predicate)
- "Internal subroutine for ange-ftp-file-name-completion. Do not call this."
(let ((bestmatch (try-completion file tbl predicate)))
(if bestmatch
(if (eq bestmatch t)
(concat bestmatch "/")
bestmatch)))))
-(defun ange-ftp-quote-filename (file)
- "Quote `$' as `$$' in FILE to get it past function `substitute-in-file-name.'"
- (let ((pos 0))
- (while (setq pos (string-match "\\$" file pos))
- (setq file (concat (substring file 0 pos)
- "$";; precede by escape character (also a $)
- (substring file pos))
- ;; add 2 instead 1 since another $ was inserted
- pos (+ 2 pos)))
- file))
-
-(defun ange-ftp-read-file-name-internal (string dir action)
- "Documented as original."
- (let (name realdir)
- (if (eq action 'lambda)
- (if (> (length string) 0)
- (file-exists-p (substitute-in-file-name string)))
- (if (zerop (length string))
- (setq name string realdir dir)
- (setq string (substitute-in-file-name string)
- name (file-name-nondirectory string)
- realdir (file-name-directory string))
- (setq realdir (if realdir (expand-file-name realdir dir) dir)))
- (if action
- (file-name-all-completions name realdir)
- (let ((specdir (file-name-directory string))
- (val (file-name-completion name realdir)))
- (if (and specdir (stringp val))
- (ange-ftp-quote-filename (concat specdir val))
- val))))))
-
;; 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)
+;; Force a re-read of the directory DIR. If DIR is omitted then it defaults
+;; to the directory part of the contents of the current buffer.
(defun ange-ftp-re-read-dir (&optional dir)
- "Forces a re-read of the directory DIR. If DIR is omitted then it defaults
-to the directory part of the contents of the current buffer."
(interactive)
(if dir
(setq dir (expand-file-name dir))
(setq dir (file-name-directory (expand-file-name (buffer-string)))))
- (if (ange-ftp-ftp-path dir)
+ (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))))
\f
-;;; Define the handler for special file names
-;;; that causes ange-ftp to be invoked.
-
-;;; omitted:
-;;; diff
-
-(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-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)
-
-;;; Now define ways of getting at the unmodified Emacs primitive,
-;;; turning off the hooks.
-(defun ange-ftp-real-file-name-directory (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-name-directory args)))
-(defun ange-ftp-real-file-name-nondirectory (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-name-nondirectory args)))
-(defun ange-ftp-real-file-name-as-directory (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-name-as-directory args)))
-(defun ange-ftp-real-directory-file-name (&rest args)
- (let (file-name-handler-alist)
- (apply 'directory-file-name args)))
-(defun ange-ftp-real-expand-file-name (&rest args)
- (let (file-name-handler-alist)
- (apply 'expand-file-name args)))
-(defun ange-ftp-real-make-directory (&rest args)
- (let (file-name-handler-alist)
- (apply 'make-directory args)))
-(defun ange-ftp-real-delete-directory (&rest args)
- (let (file-name-handler-alist)
- (apply 'delete-directory args)))
-(defun ange-ftp-real-insert-file-contents (&rest args)
- (let (file-name-handler-alist)
- (apply 'insert-file-contents args)))
-(defun ange-ftp-real-directory-files (&rest args)
- (let (file-name-handler-alist)
- (apply 'directory-files args)))
-(defun ange-ftp-real-file-directory-p (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-directory-p args)))
-(defun ange-ftp-real-file-writable-p (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-writable-p args)))
-(defun ange-ftp-real-file-readable-p (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-readable-p args)))
-(defun ange-ftp-real-file-symlink-p (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-symlink-p args)))
-(defun ange-ftp-real-delete-file (&rest args)
- (let (file-name-handler-alist)
- (apply 'delete-file args)))
-(defun ange-ftp-real-read-file-name-internal (&rest args)
- (let (file-name-handler-alist)
- (apply 'read-file-name-internal args)))
-(defun ange-ftp-real-verify-visited-file-modtime (&rest args)
- (let (file-name-handler-alist)
- (apply 'verify-visited-file-modtime args)))
-(defun ange-ftp-real-file-exists-p (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-exists-p args)))
-(defun ange-ftp-real-write-region (&rest args)
- (let (file-name-handler-alist)
- (apply 'write-region args)))
-(defun ange-ftp-real-backup-buffer (&rest args)
- (let (file-name-handler-alist)
- (apply 'backup-buffer args)))
-(defun ange-ftp-real-copy-file (&rest args)
- (let (file-name-handler-alist)
- (apply 'copy-file args)))
-(defun ange-ftp-real-rename-file (&rest args)
- (let (file-name-handler-alist)
- (apply 'rename-file args)))
-(defun ange-ftp-real-file-attributes (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-attributes args)))
-(defun ange-ftp-real-file-name-all-completions (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-name-all-completions args)))
-(defun ange-ftp-real-file-name-completion (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-name-completion args)))
-
-(defun ange-ftp-hook-function (operation &rest args)
- (let ((fn (get operation 'ange-ftp)))
- (if fn (apply fn args)
- (let (file-name-handler-alist)
- (apply operation args)))))
-
-(or (assoc ":" file-name-handler-alist)
- (setq file-name-handler-alist
- (cons '(":" . ange-ftp-hook-function)
- file-name-handler-alist)))
-
-(or (memq 'ange-ftp-set-buffer-mode find-file-hooks)
- (setq find-file-hooks
- (cons 'ange-ftp-set-buffer-mode find-file-hooks)))
-
-\f
-;;; This is obsolete and won't work
-
-;; Attention!
-;; It would be nice if ange-ftp-add-hook was generalized to
-;; (defun ange-ftp-add-hook (hook-var hook-function &optional postpend),
-;; where the optional postpend variable stipulates that hook-function
-;; should be post-pended to the hook-var, rather than prepended.
-;; Then, maybe we should overwrite dired with
-;; (ange-ftp-add-hook 'dired-load-hook 'ange-ftp-overwrite-dired t).
-;; This is because dired-load-hook is commonly used to add the dired extras
-;; features (dired-x.el, dired-trns.el, dired-nstd.el, ...). Some of these
-;; extras features overwrite functions in dired.el with fancier versions.
-;; The "extras" overwrites would then clobber the ange-ftp overwrites.
-;; As long as the ange-ftp overwrites are carefully written to use
-;; ange-ftp-real-... when the directory is local, then doing the ange-ftp
-;; overwrites after the extras overwites should be OK.
-;; At the moment, I think that there aren't any conflicts between the extras
-;; overwrites, and the ange-ftp overwrites. This may not last though.
-
-(defun ange-ftp-add-hook (hook-var hook-function)
- "Prepend hook-function to hook-var's value, if it is not already an element.
-hook-var's value may be a single function or a list of functions."
- (if (boundp hook-var)
- (let ((value (symbol-value hook-var)))
- (if (and (listp value) (not (eq (car value) 'lambda)))
- (and (not (memq hook-function value))
- (set hook-var
- (if value (cons hook-function value) hook-function)))
- (and (not (eq hook-function value))
- (set hook-var
- (list hook-function value)))))
- (set hook-var hook-function)))
-
-;; To load ange-ftp and not dired (leaving it to autoload), define
-;; dired-load-hook and make sure dired.el ends with:
-;; (run-hooks 'dired-load-hook)
-;;
-(if (and (boundp 'dired-load-hook)
- (not (featurep 'dired)))
- (ange-ftp-add-hook 'dired-load-hook 'ange-ftp-overwrite-dired)
- (require 'dired)
- (ange-ftp-overwrite-dired))
-
-(defun ange-ftp-overwrite-dired ()
- (if (not (fboundp 'dired-ls)) ;dired should have been loaded by now
- (ange-ftp-overwrite-fn 'dired-readin) ; classic dired
- (ange-ftp-overwrite-fn 'make-directory) ; tree dired and v19 stuff
- (ange-ftp-overwrite-fn 'remove-directory)
- (ange-ftp-overwrite-fn 'diff)
- (ange-ftp-overwrite-fn 'dired-run-shell-command)
- (ange-ftp-overwrite-fn 'dired-ls)
- (ange-ftp-overwrite-fn 'dired-call-process)
- ;; Can't use (fset 'ange-ftp-dired-readin 'ange-ftp-tree-dired-readin)
- ;; here because it confuses ange-ftp-overwrite-fn.
- (fset 'ange-ftp-dired-readin (symbol-function 'ange-ftp-tree-dired-readin))
- (ange-ftp-overwrite-fn 'dired-readin)
- (ange-ftp-overwrite-fn 'dired-insert-headerline)
- (ange-ftp-overwrite-fn 'dired-move-to-filename)
- (ange-ftp-overwrite-fn 'dired-move-to-end-of-filename)
- (ange-ftp-overwrite-fn 'dired-get-filename)
- (ange-ftp-overwrite-fn 'dired-between-files)
- (ange-ftp-overwrite-fn 'dired-clean-directory)
- (ange-ftp-overwrite-fn 'dired-flag-backup-files)
- (ange-ftp-overwrite-fn 'dired-backup-diff)
- (if (fboundp 'dired-do-create-files)
- ;; dired 6.0 or later.
- (progn
- (ange-ftp-overwrite-fn 'dired-copy-file)
- (ange-ftp-overwrite-fn 'dired-create-files)
- (ange-ftp-overwrite-fn 'dired-do-create-files)))
- (if (fboundp 'dired-compress-make-compressed-filename)
- ;; it's V5.255 or later
- (ange-ftp-overwrite-fn 'dired-compress-make-compressed-filename)
- ;; ange-ftp-overwrite-fn confuses dired-mark-map here.
- (fset 'ange-ftp-real-dired-compress (symbol-function 'dired-compress))
- (fset 'dired-compress 'ange-ftp-dired-compress)
- (fset 'ange-ftp-real-dired-uncompress (symbol-function 'dired-uncompress))
- (fset 'dired-uncompress 'ange-ftp-dired-uncompress)))
-
- (ange-ftp-overwrite-fn 'dired-find-file)
- (ange-ftp-overwrite-fn 'dired-revert))
-\f
-;;;; ------------------------------------------------------------
-;;;; Classic Dired support.
-;;;; ------------------------------------------------------------
-
-(defvar ange-ftp-dired-host-type nil
- "The host type associated with a dired buffer. (buffer local)")
-(make-variable-buffer-local 'ange-ftp-dired-host-type)
-
-(defun ange-ftp-dired-readin (dirname buffer)
- "Documented as original."
- (let ((file (ange-ftp-abbreviate-filename dirname))
- (parsed (ange-ftp-ftp-path dirname)))
- (save-excursion
- (ange-ftp-message "Reading directory %s..." file)
- (set-buffer buffer)
- (let ((buffer-read-only nil))
- (widen)
- (erase-buffer)
- (setq dirname (expand-file-name dirname))
- (if parsed
- (let ((host-type (ange-ftp-host-type (car parsed))))
- (setq ange-ftp-dired-host-type host-type)
- (insert (ange-ftp-ls dirname dired-listing-switches t)))
- (if (ange-ftp-real-file-directory-p dirname)
- (call-process "ls" nil buffer nil
- dired-listing-switches dirname)
- (let ((default-directory
- (ange-ftp-real-file-name-directory dirname)))
- (call-process
- shell-file-name nil buffer nil
- "-c" (concat
- "ls " dired-listing-switches " "
- (ange-ftp-real-file-name-nondirectory dirname))))))
- (goto-char (point-min))
- (while (not (eobp))
- (insert " ")
- (forward-line 1))
- (goto-char (point-min))))
- (ange-ftp-message "Reading directory %s...done" file)))
-
-(defun ange-ftp-dired-revert (&optional arg noconfirm)
- "Documented as original."
- (if (and dired-directory
- (ange-ftp-ftp-path (expand-file-name dired-directory)))
- (setq ange-ftp-ls-cache-file nil))
- (ange-ftp-real-dired-revert arg noconfirm))
-\f
-;;;; ------------------------------------------------------------
-;;;; Tree Dired support (ange & Sebastian Kremer)
-;;;; ------------------------------------------------------------
-
-(defvar ange-ftp-dired-re-exe-alist nil
- "Association list of regexps \(strings\) which match file lines of
- executable files.")
-
-(defvar ange-ftp-dired-re-dir-alist nil
- "Association list of regexps \(strings\) which match file lines of
- subdirectories.")
-
-(defvar ange-ftp-dired-insert-headerline-alist nil
- "Association list of \(TYPE \. FUNC \) pairs, where FUNC is
-the function to be used by dired to insert the headerline of
-the dired buffer.")
-
-(defvar ange-ftp-dired-move-to-filename-alist nil
- "Association list of \(TYPE \. FUNC \) pairs, where FUNC is
-the function to be used by dired to move to the beginning of a
-filename.")
-
-(defvar ange-ftp-dired-move-to-end-of-filename-alist nil
- "Association list of \(TYPE \. FUNC \) pairs, where FUNC is
-the function to be used by dired to move to the end of a
-filename.")
-
-(defvar ange-ftp-dired-get-filename-alist nil
- "Association list of \(TYPE \. FUNC \) pairs, where FUNC is
-the function to be used by dired to get a filename from the
-current line.")
-
-(defvar ange-ftp-dired-between-files-alist nil
- "Association list of \(TYPE \. FUNC \) pairs, where FUNC is
-the function to be used by dired to determine when the point
-is on a line between files.")
-
-(defvar ange-ftp-dired-ls-trim-alist nil
- "Association list of \( TYPE \. FUNC \) pairs, where FUNC is
-a function which trims extraneous lines from a directory listing.")
-
-(defvar ange-ftp-dired-clean-directory-alist nil
- "Association list of \( TYPE \. FUNC \) pairs, where FUNC is
-a function which cleans out old versions of files in the OS TYPE.")
-
-(defvar ange-ftp-dired-flag-backup-files-alist nil
- "Association list of \( TYPE \. FUNC \) pairs, where FUNC is
-a functions which flags the backup files for deletion in the OS TYPE.")
-
-(defvar ange-ftp-dired-backup-diff-alist nil
- "Association list of \( TYPE \. FUNC \) pairs, where FUNC diffs
-a file with its backup. The backup file is determined according to
-the OS TYPE.")
-
-;; Could use dired-before-readin-hook here, instead of overloading
-;; dired-readin. However, if people change this hook after ange-ftp
-;; is loaded, they'll break things.
-;; Also, why overload dired-readin rather than dired-mode?
-;; Because I don't want to muck up virtual dired (see dired-x.el).
-
-(defun ange-ftp-tree-dired-readin (dirname buffer)
- "Documented as original."
- (let ((parsed (ange-ftp-ftp-path dirname)))
- (if parsed
- (save-excursion
- (set-buffer buffer)
- (setq ange-ftp-dired-host-type
- (ange-ftp-host-type (car parsed)))
- (and ange-ftp-dl-dir-regexp
- (eq ange-ftp-dired-host-type 'unix)
- (string-match ange-ftp-dl-dir-regexp dirname)
- (setq ange-ftp-dired-host-type 'unix:dl))
- (let ((eentry (assq ange-ftp-dired-host-type
- ange-ftp-dired-re-exe-alist))
- (dentry (assq ange-ftp-dired-host-type
- ange-ftp-dired-re-dir-alist)))
- (if eentry
- (set (make-local-variable 'dired-re-exe) (cdr eentry)))
- (if dentry
- (set (make-local-variable 'dired-re-dir) (cdr dentry)))
- ;; No switches are sent to dumb hosts, so don't confuse dired.
- ;; I hope that dired doesn't get excited if it doesn't see the l
- ;; switch. If it does, then maybe fake things by setting this to
- ;; "-Al".
- (if (memq ange-ftp-dired-host-type ange-ftp-dumb-host-types)
- (setq dired-actual-switches "-Al"))))))
- (ange-ftp-real-dired-readin dirname buffer))
-
-(defun ange-ftp-dired-insert-headerline (dir)
- "Documented as original."
- (funcall (or (and ange-ftp-dired-host-type
- (cdr (assq ange-ftp-dired-host-type
- ange-ftp-dired-insert-headerline-alist)))
- 'ange-ftp-real-dired-insert-headerline)
- dir))
-
-(defun ange-ftp-dired-move-to-filename (&optional raise-error eol)
- "Documented as original."
- (funcall (or (and ange-ftp-dired-host-type
- (cdr (assq ange-ftp-dired-host-type
- ange-ftp-dired-move-to-filename-alist)))
- 'ange-ftp-real-dired-move-to-filename)
- raise-error eol))
-
-(defun ange-ftp-dired-move-to-end-of-filename (&optional no-error)
- "Documented as original."
- (funcall (or (and ange-ftp-dired-host-type
- (cdr (assq ange-ftp-dired-host-type
- ange-ftp-dired-move-to-end-of-filename-alist)))
- 'ange-ftp-real-dired-move-to-end-of-filename)
- no-error))
-
-(defun ange-ftp-dired-get-filename (&optional localp no-error-if-not-filep)
- "Documented as original."
- (funcall (or (and ange-ftp-dired-host-type
- (cdr (assq ange-ftp-dired-host-type
- ange-ftp-dired-get-filename-alist)))
- 'ange-ftp-real-dired-get-filename)
- localp no-error-if-not-filep))
-
-(defun ange-ftp-dired-between-files ()
- "Documented as original."
- (funcall (or (and ange-ftp-dired-host-type
- (cdr (assq ange-ftp-dired-host-type
- ange-ftp-dired-between-files-alist)))
- 'ange-ftp-real-dired-between-files)))
-
-(defvar ange-ftp-bob-version-alist nil
- "Association list of pairs \( TYPE \. FUNC \), where FUNC is
-a function to be used to bob the version number off of a filename
-in OS TYPE.")
-
-(defun ange-ftp-dired-find-file ()
- "Documented as original."
- (interactive)
- (find-file (funcall (or (and ange-ftp-dired-host-type
- (cdr (assq ange-ftp-dired-host-type
- ange-ftp-bob-version-alist)))
- 'identity)
- (dired-get-filename))))
-
-;; 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-dired-compress-make-compressed-filename-alist nil
- "Association list of \( TYPE \. FUNC \) pairs, where FUNC converts a
-filename to the filename of the associated compressed file.")
-
-(defun ange-ftp-dired-compress-make-compressed-filename (name &optional reverse)
- "Converts a filename to the filename of the associated compressed
-file. With an optional reverse argument, the reverse conversion is done."
- (let ((parsed (ange-ftp-ftp-path name))
- conversion-func)
- (if (and parsed
- (setq conversion-func
- (cdr (assq (ange-ftp-host-type (car parsed))
- ange-ftp-dired-compress-make-compressed-filename-alist))))
- (funcall conversion-func name reverse)
- (if reverse
- (if (string-match "\\.Z$" name)
- (substring name 0 (match-beginning 0))
- name)
- (concat name ".Z")))))
-
-(defun ange-ftp-dired-clean-directory (keep)
- "Documented as original."
- (interactive "P")
- (funcall (or (and ange-ftp-dired-host-type
- (cdr (assq ange-ftp-dired-host-type
- ange-ftp-dired-clean-directory-alist)))
- 'ange-ftp-real-dired-clean-directory)
- keep))
-
-(defun ange-ftp-dired-backup-diff (&optional switches)
- "Documented as original."
- (interactive (list (if (fboundp 'diff-read-switches)
- (diff-read-switches "Diff with switches: "))))
- (funcall (or (and ange-ftp-dired-host-type
- (cdr (assq ange-ftp-dired-host-type
- ange-ftp-dired-backup-diff-alist)))
- 'ange-ftp-real-dired-backup-diff)
- switches))
-
-
-(defun ange-ftp-dired-fixup-subdirs (start file)
- "Turn each subdir name into a valid ange-ftp filename."
-
- ;; We haven't indented the listing yet.
- ;; Must be careful about filelines ending in a colon: exclude spaces!
- (let ((subdir-regexp "^\\([^ \n\r]+\\)\\(:\\)[\n\r]"))
- (save-restriction
- (save-excursion
- (narrow-to-region start (point))
- (goto-char start)
- (while (re-search-forward subdir-regexp nil t)
- (goto-char (match-beginning 1))
- (let ((name (buffer-substring (point)
- (match-end 1))))
- (delete-region (point) (match-end 1))
- (insert (ange-ftp-replace-path-component
- file
- name))))))))
-
-(defun ange-ftp-dired-ls (file switches &optional wildcard full-directory-p)
- "Documented as original."
- (let ((parsed (ange-ftp-ftp-path file)))
- (if parsed
- (let* ((pt (point))
- (path (nth 2 parsed))
- (host-type (ange-ftp-host-type (car parsed)))
- (dumb (memq host-type ange-ftp-dumb-host-types))
- trim-func case-fold-search)
- ;; Make sure that case-fold-search is nil
- ;; so that we can look at the switches.
- (if wildcard
- (if (not (memq host-type '(unix dumb-unix)))
- (insert (ange-ftp-ls file switches nil))
- ;; Prevent ls from inserting subdirs, as the subdir header
- ;; line format would be wrong (it would have no "/user@host:"
- ;; prefix)
- (insert (ange-ftp-ls file (concat switches "d") nil))
-
- ;; Quoting the path part of the file name seems to be a good
- ;; idea (using dired.el's shell-quote function), but ftpd
- ;; always globs ls args before passing them to /bin/ls or even
- ;; doing the ls formatting itself. --> So wildcard characters
- ;; in FILE lose. Sigh...
-
- ;; When using wildcards, some ftpd's put the whole directory
- ;; name in front of each filename. Walk down the listing
- ;; generated and remove this stuff.
- (let ((dir (ange-ftp-real-file-name-directory path)))
- (if dir
- (let ((dirq (regexp-quote dir)))
- (save-restriction
- (save-excursion
- (narrow-to-region pt (point))
- (goto-char pt)
- (while (not (eobp))
- (if (dired-move-to-filename)
- (if (re-search-forward dirq nil t)
- (replace-match "")))
- (forward-line 1))))))))
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; Big issue here Andy! ;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; In tree dired V5.245 Sebastian has used the following
- ;; trick to resolve symbolic links to directories. This causes
- ;; havoc with ange-ftp, because ange-ftp expands dots, with
- ;; expand-file-name before it sends them. This means that this
- ;; trick currently fails for remote SysV machines. But worse,
- ;; /vms:/DEV:/FOO/. expands to /vms:/DEV:/FOO, which converts
- ;; to DEV:FOO and not DEV:[FOO]. i.e it is only in UNIX that
- ;; we can play fast and loose with the difference between
- ;; directory names and their associated filenames.
- ;; My temporary fix is to knock Sebastian's dot off.
- ;; Maybe things can be made real clever in
- ;; the future, so that Sebastian can have his way with remote
- ;; SysV machines.
- ;; Sebastian in dired-readin-insert says:
-
- ;; On SysV derived system, symbolic links to
- ;; directories are not resolved, while on BSD
- ;; derived it suffices to let DIRNAME end in slash.
- ;; We always let it end in "/." since it does no
- ;; harm on BSD and makes Dired work on such links on
- ;; SysV.
-
- (if (string-match "/\\.$" path)
- (setq
- file
- (ange-ftp-replace-path-component
- file (substring path 0 -1))))
- (if (string-match "R" switches)
- (progn
- (insert (ange-ftp-ls file switches nil))
- ;; fix up the subdirectory names in the recursive
- ;; listing.
- (ange-ftp-dired-fixup-subdirs pt file))
- (insert
- (ange-ftp-ls file
- switches
- (and (or dumb (string-match "[aA]" switches))
- full-directory-p))))
- (if (and (null full-directory-p)
- (setq trim-func
- (cdr (assq host-type
- ange-ftp-dired-ls-trim-alist))))
- ;; If full-directory-p and wild-card are null, then only one
- ;; line per file must be inserted.
- ;; Some OS's (like VMS) insert other crap. Clean it out.
- (save-restriction
- (narrow-to-region pt (point))
- (funcall trim-func)))))
- (ange-ftp-real-dired-ls file switches wildcard full-directory-p))))
-
-(defvar ange-ftp-remote-shell-file-name
- (if (memq system-type '(hpux usg-unix-v)) ; hope that's right
- "remsh"
- "rsh")
- "Remote shell used by ange-ftp.")
-
-(defun ange-ftp-dired-run-shell-command (command &optional in-background)
- "Documented as original."
- (let* ((parsed (ange-ftp-ftp-path default-directory))
- (host (nth 0 parsed))
- (user (nth 1 parsed))
- (path (nth 2 parsed)))
- (if (not parsed)
- (ange-ftp-real-dired-run-shell-command command in-background)
- (if (> (length path) 0) ; else it's $HOME
- (setq command (concat "cd " path "; " command)))
- (setq command
- (format "%s %s \"%s\"" ; remsh -l USER does not work well
- ; on a hp-ux machine I tried
- ange-ftp-remote-shell-file-name 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 path names.
- (if in-background
- (comint::background command)
- (shell-command command)))))
-
-(defun ange-ftp-make-directory (dir)
- "Documented as original."
+(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-path dir)))
+ (let ((parsed (ange-ftp-ftp-name dir)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
;; Non-unix machines will probably always insist
;; that mkdir takes a directory-name as an arg
;; (as the ftp man page says it should).
- (path (ange-ftp-quote-string
+ (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 path)
+ (list 'mkdir name)
(format "Making directory %s"
abbr))))
(or (car result)
(ange-ftp-add-file-entry dir t))
(ange-ftp-real-make-directory dir)))))
-(defun ange-ftp-remove-directory (dir)
- "Documented as original."
- (interactive
- (list (expand-file-name (read-file-name "Remove directory: "
- nil nil 'confirm))))
+(defun ange-ftp-delete-directory (dir)
(if (file-directory-p dir)
- (let ((parsed (ange-ftp-ftp-path dir)))
+ (let ((parsed (ange-ftp-ftp-name dir)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
;; Non-unix machines will probably always insist
;; that rmdir takes a directory-name as an arg
;; (as the ftp man page says it should).
- (path (ange-ftp-quote-string
+ (name (ange-ftp-quote-string
(if (eq (ange-ftp-host-type host) 'unix)
(ange-ftp-real-directory-file-name
(nth 2 parsed))
(nth 2 parsed)))))
(abbr (ange-ftp-abbreviate-filename dir))
(result (ange-ftp-send-cmd host user
- (list 'rmdir path)
+ (list 'rmdir name)
(format "Removing directory %s"
abbr))))
(or (car result)
(ange-ftp-delete-file-entry dir t))
(ange-ftp-real-delete-directory dir)))
(error "Not a directory: %s" dir)))
+\f
+;; 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)))
+ (bin1 (ange-ftp-binary-file fn1)))
+ (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)))
+ copy)
+ (while (and tryfiles (not copy))
+ (condition-case error
+ (setq copy (ange-ftp-file-local-copy (car tryfiles)))
+ (ftp-error nil)))
+ (if copy
+ (unwind-protect
+ (funcall 'load copy noerror nomessage nosuffix)
+ (delete-file copy))
+ (or noerror
+ (signal 'file-error (list "Cannot open load file" file)))))
+ (ange-ftp-real-load file noerror nomessage nosuffix)))
-(defun ange-ftp-diff (fn1 fn2 &optional switches)
- "Documented as original."
- (interactive (diff-read-args "Diff: " "Diff %s with: "
- "Diff with switches: "))
- (or (and (stringp fn1)
- (stringp fn2))
- (error "diff: arguments must be strings: %s %s" fn1 fn2))
- (or switches
- (setq switches (if (stringp diff-switches)
- diff-switches
- (if (listp diff-switches)
- (mapconcat 'identity diff-switches " ")
- ""))))
- (let* ((fn1 (expand-file-name fn1))
- (fn2 (expand-file-name fn2))
- (pa1 (ange-ftp-ftp-path fn1))
- (pa2 (ange-ftp-ftp-path fn2)))
- (if (or pa1 pa2)
- (let* ((tmp1 (and pa1 (ange-ftp-make-tmp-name (car pa1))))
- (tmp2 (and pa2 (ange-ftp-make-tmp-name (car pa2))))
- (bin1 (and pa1 (ange-ftp-binary-file fn1)))
- (bin2 (and pa2 (ange-ftp-binary-file fn2)))
- (dir1 (file-directory-p fn1))
- (dir2 (file-directory-p fn2))
- (old-dir default-directory)
- (default-directory "/tmp")) ;fool FTP-smart compile.el
- (unwind-protect
- (progn
- (if (and dir1 dir2)
- (error "can't compare remote directories"))
- (if dir1
- (setq fn1 (expand-file-name (file-name-nondirectory fn2)
- fn1)
- pa1 (ange-ftp-ftp-path fn1)
- bin1 (ange-ftp-binary-file fn1)))
- (if dir2
- (setq fn2 (expand-file-name (file-name-nondirectory fn1)
- fn2)
- pa2 (ange-ftp-ftp-path fn2)
- bin2 (ange-ftp-binary-file fn2)))
- (and pa1 (ange-ftp-copy-file-internal fn1 tmp1 t nil
- (format "Getting %s" fn1)))
- (and pa2 (ange-ftp-copy-file-internal fn2 tmp2 t nil
- (format "Getting %s" fn2)))
- (and ange-ftp-process-verbose
- (ange-ftp-message "doing diff..."))
- (sit-for 0)
- (ange-ftp-real-diff (or tmp1 fn1) (or tmp2 fn2) switches)
- (cond ((boundp 'compilation-process)
- (while (and compilation-process
- (eq (process-status compilation-process)
- 'run))
- (accept-process-output compilation-process)))
- ((boundp 'compilation-last-buffer)
- (while (and compilation-last-buffer
- (buffer-name compilation-last-buffer)
- (get-buffer-process
- compilation-last-buffer)
- (eq (process-status
- (get-buffer-process
- compilation-last-buffer))
- 'run))
- (accept-process-output))))
- (and ange-ftp-process-verbose
- (ange-ftp-message "doing diff...done"))
- (save-excursion
- (set-buffer (get-buffer-create "*compilation*"))
-
- ;; replace the default directory that we munged earlier.
- (goto-char (point-min))
- (if (search-forward (concat "cd " default-directory) nil t)
- (replace-match (concat "cd " old-dir)))
- (setq default-directory old-dir)
-
- ;; massage the diff output, replacing the temporary file-
- ;; names with their original names.
- (if tmp1
- (let ((q1 (shell-quote tmp1)))
- (goto-char (point-min))
- (while (search-forward q1 nil t)
- (replace-match fn1))))
- (if tmp2
- (let ((q2 (shell-quote tmp2)))
- (goto-char (point-min))
- (while (search-forward q2 nil t)
- (replace-match fn2))))))
- (and tmp1 (ange-ftp-del-tmp-name tmp1))
- (and tmp2 (ange-ftp-del-tmp-name tmp2))))
- (ange-ftp-real-diff fn1 fn2 switches))))
-
-(defun ange-ftp-dired-call-process (program discard &rest arguments)
- "Documented as original."
- ;; PROGRAM is always one of those below in the cond in dired.el.
- ;; The ARGUMENTS are (nearly) always files.
- (if (ange-ftp-ftp-path 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 "compress" program)
- (ange-ftp-call-compress arguments))
- ((equal "uncompress" program)
- (ange-ftp-call-uncompress arguments))
- ((equal "chmod" 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))))
- (error (insert (format "%s\n" (nth 1 oops)))))
- (apply 'call-process program nil (not discard) nil arguments)))
+;; 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))
+
+\f
+;; 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
+ (ange-ftp-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)))))
-(defun ange-ftp-call-compress (args)
- "Perform a compress command on a remote file.
-Works by taking a copy of the file, compressing it and copying the file
-back."
- (if (or (not (= (length args) 2))
- (not (string-equal "-f" (car args))))
- (error
- "ange-ftp-call-compress: missing -f flag and/or missing filename: %s"
- args))
- (let* ((file (nth 1 args))
- (parsed (ange-ftp-ftp-path file))
+;; 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))
- (nfile (ange-ftp-dired-compress-make-compressed-filename file))
(nabbr (ange-ftp-abbreviate-filename nfile))
(msg1 (format "Getting %s" abbr))
(msg2 (format "Putting %s" nabbr)))
(ange-ftp-del-tmp-name tmp1)
(ange-ftp-del-tmp-name tmp2))))
-(defun ange-ftp-call-uncompress (args)
- "Perform an uncompress command on a remote file.
-Works by taking a copy of the file, uncompressing it and copying the file
-back."
- (if (not (= (length args) 1))
- (error "ange-ftp-call-uncompress: missing filename: %s" args))
- (let* ((file (car args))
- (parsed (ange-ftp-ftp-path file))
+;; 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))
- (nfile (ange-ftp-dired-compress-make-compressed-filename file 'reverse))
(nabbr (ange-ftp-abbreviate-filename nfile))
(msg1 (format "Getting %s" abbr))
(msg2 (format "Putting %s" nabbr))
(ange-ftp-copy-file-internal tmp2 nfile t nil msg2))))
(ange-ftp-del-tmp-name tmp1)
(ange-ftp-del-tmp-name tmp2))))
+\f
+;;; 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).
+;;;###autoload
+(or (assoc "^/[^/:]*[^/:]:" file-name-handler-alist)
+ (setq file-name-handler-alist
+ (cons '("^/[^/:]*[^/:]:" . ange-ftp-hook-function)
+ file-name-handler-alist)))
+
+;;; This regexp recognizes and 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)))
+
+;;; 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)
+
+;; 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)
+\f
+;;; 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))
+\f
+;; 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 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)
+ (setq file (ange-ftp-abbreviate-filename file))
+ (let ((parsed (ange-ftp-ftp-name file))
+ 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))))
+
+(defvar ange-ftp-remote-shell-file-name
+ (if (memq system-type '(hpux usg-unix-v)) ; hope that's right
+ "remsh"
+ "rsh")
+ "Name of command to run a remote shell, for ange-ftp.")
+
+;;; This doesn't work yet; a new hook needs to be created.
+;;; Maybe the new hook should be in call-process.
+(defun ange-ftp-shell-command (command)
+ (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)
+ (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
+ ange-ftp-remote-shell-file-name 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))))
+
+;;; Thisis not hooked up yet.
+(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 "chmod" 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))))
+ (error (insert (format "%s\n" (nth 1 oops)))))
+ (apply 'call-process program nil (not discard) nil arguments)))
+
+;;; This currently does not work; it is never called.
(defun ange-ftp-call-chmod (args)
(if (< (length args) 2)
(error "ange-ftp-call-chmod: missing mode and/or filename: %s" args))
(function
(lambda (file)
(setq file (expand-file-name file))
- (let ((parsed (ange-ftp-ftp-path file)))
+ (let ((parsed (ange-ftp-ftp-name file)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
- (path (ange-ftp-quote-string (nth 2 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 path)
+ (list 'chmod mode name)
(format "doing chmod %s"
abbr))))
(or (car result)
(cdr result)))))))))
(cdr args)))
(setq ange-ftp-ls-cache-file nil)) ;stop confusing dired
-
-;; Need to abstract the way dired computes the names of compressed files.
-;; I feel badly about these two overloads.
-
-(defun ange-ftp-dired-compress ()
- ;; Compress current file. Return nil for success, offending filename else.
- (let* (buffer-read-only
- (from-file (dired-get-filename))
- (to-file (ange-ftp-dired-compress-make-compressed-filename from-file)))
- (cond ((save-excursion (beginning-of-line)
- (looking-at dired-re-sym))
- (dired-log (concat "Attempt to compress a symbolic link:\n"
- from-file))
- (dired-make-relative from-file))
- ((dired-check-process (concat "Compressing " from-file)
- "compress" "-f" from-file)
- ;; errors from the process are already logged by
- ;; dired-check-process
- (dired-make-relative from-file))
- (t
- (dired-update-file-line to-file)
- nil))))
-
-(defun ange-ftp-dired-uncompress ()
- ;; Uncompress current file. Return nil for success,
- ;; offending filename else.
- (let* (buffer-read-only
- (from-file (dired-get-filename))
- (to-file (ange-ftp-dired-compress-make-compressed-filename from-file 'reverse)))
- (if (dired-check-process (concat "Uncompressing " from-file)
- "uncompress" from-file)
- (dired-make-relative from-file)
- (dired-update-file-line to-file)
- nil)))
-
-(defun ange-ftp-dired-flag-backup-files (&optional unflag-p)
- "Documented as original."
- (interactive "P")
- (funcall (or (and ange-ftp-dired-host-type
- (cdr (assq ange-ftp-dired-host-type
- ange-ftp-dired-flag-backup-files-alist)))
- 'ange-ftp-real-dired-flag-backup-files)
- unflag-p))
\f
-;;; ------------------------------------------------------------
-;;; 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-path (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-path (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 interative 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)
+;;; 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))
+;; (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))))
+;; (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))))
\f
;;;; -----------------------------------------------
;;;; Unix Descriptive Listing (dl) Support
;;;; -----------------------------------------------
-(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)))
+;; 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)))
\f
;;;; ------------------------------------------------------------
;;;; VOS support (VOS support is probably broken,
;;;; but I don't know anything about VOS.)
;;;; ------------------------------------------------------------
;
-;(defun ange-ftp-fix-path-for-vos (path &optional reverse)
-; (setq path (copy-sequence path))
+;(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 path))))
+; (i (1- (length name))))
; (while (>= i 0)
-; (if (= (aref path i) from)
-; (aset path i to))
+; (if (= (aref name i) from)
+; (aset name i to))
; (setq i (1- i)))
-; path))
+; name))
;
-;(or (assq 'vos ange-ftp-fix-path-func-alist)
-; (setq ange-ftp-fix-path-func-alist
-; (cons '(vos . ange-ftp-fix-path-for-vos)
-; ange-ftp-fix-path-func-alist)))
+;(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-path-for-vos (dir-path)
-; (ange-ftp-fix-path-for-vos
-; (concat dir-path
-; (if (eq ?/ (aref dir-path (1- (length dir-path))))
+;(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-path-func-alist)
-; (setq ange-ftp-fix-dir-path-func-alist
-; (cons '(vos . ange-ftp-fix-dir-path-for-vos)
-; ange-ftp-fix-dir-path-func-alist)))
+;(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.")
;;;; VMS support.
;;;; ------------------------------------------------------------
-(defun ange-ftp-fix-path-for-vms (path &optional reverse)
- "Convert PATH from UNIX-ish to VMS. If REVERSE given then convert from VMS
-to UNIX-ish."
+;; 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)
(ange-ftp-save-match-data
(if reverse
- (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" path)
+ (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name)
(let (drive dir file)
(if (match-beginning 1)
- (setq drive (substring path
+ (setq drive (substring name
(match-beginning 1)
(match-end 1))))
(if (match-beginning 2)
(setq dir
- (substring path (match-beginning 2) (match-end 2))))
+ (substring name (match-beginning 2) (match-end 2))))
(if (match-beginning 3)
(setq file
- (substring path (match-beginning 3) (match-end 3))))
+ (substring name (match-beginning 3) (match-end 3))))
(and dir
(setq dir (apply (function concat)
(mapcar (function
(concat "/" drive "/"))
dir (and dir "/")
file))
- (error "path %s didn't match" path))
+ (error "name %s didn't match" name))
(let (drive dir file tmp)
- (if (string-match "^/[^:]+:/" path)
- (setq drive (substring path 1
+ (if (string-match "^/[^:]+:/" name)
+ (setq drive (substring name 1
(1- (match-end 0)))
- path (substring path (match-end 0))))
- (setq tmp (file-name-directory path))
+ name (substring name (match-end 0))))
+ (setq tmp (file-name-directory name))
(if tmp
(setq dir (apply (function concat)
(mapcar (function
(vector ?.)
(vector char))))
(substring tmp 0 -1)))))
- (setq file (file-name-nondirectory path))
+ (setq file (file-name-nondirectory name))
(concat drive
(and dir (concat "[" (if drive nil ".") dir "]"))
file)))))
-;; (ange-ftp-fix-path-for-vms "/PUB$:/ANONYMOUS/SDSCPUB/NEXT/Readme.txt;1")
-;; (ange-ftp-fix-path-for-vms "/PUB$:[ANONYMOUS.SDSCPUB.NEXT]Readme.txt;1" t)
+;; (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-path-func-alist)
- (setq ange-ftp-fix-path-func-alist
- (cons '(vms . ange-ftp-fix-path-for-vms)
- ange-ftp-fix-path-func-alist)))
+(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
;; likely for OS's (like MTS) for which we need to use a wildcard in order
;; to list a directory.
-(defun ange-ftp-fix-dir-path-for-vms (dir-path)
- "Convert path from UNIX-ish to VMS ready for a DIRectory listing."
+;; 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-path "/")
+ (cond ((string-equal dir-name "/")
(error "Cannot get listing for fictitious \"/\" directory."))
- ((string-match "^/[-A-Z0-9_$]+:/$" dir-path)
+ ((string-match "^/[-A-Z0-9_$]+:/$" dir-name)
(error "Cannot get listing for device."))
- ((ange-ftp-fix-path-for-vms dir-path))))
+ ((ange-ftp-fix-name-for-vms dir-name))))
-(or (assq 'vms ange-ftp-fix-dir-path-func-alist)
- (setq ange-ftp-fix-dir-path-func-alist
- (cons '(vms . ange-ftp-fix-dir-path-for-vms)
- ange-ftp-fix-dir-path-func-alist)))
+(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)
- "Return whether HOST is running VMS."
(and ange-ftp-vms-host-regexp
(ange-ftp-save-match-data
(string-match ange-ftp-vms-host-regexp host))))
(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]*\\)")
+ "\\(\\([_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
;; 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 ()
- "Extract the next filename from a VMS dired-like listing."
(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 ()
- "Parse the current buffer which is assumed to be in MultiNet FTP dir
-format, and return a hashtable as the result."
(let ((tbl (ange-ftp-make-hashtable))
file)
(goto-char (point-min))
;; Can the following two functions be speeded up using file
;; completion functions?
-(defun ange-ftp-vms-delete-file-entry (path &optional dir-p)
+(defun ange-ftp-vms-delete-file-entry (name &optional dir-p)
(if dir-p
- (ange-ftp-internal-delete-file-entry path t)
+ (ange-ftp-internal-delete-file-entry name t)
(ange-ftp-save-match-data
- (let ((file (ange-ftp-get-file-part path)))
+ (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 path)
+ (file-name-directory name)
ange-ftp-files-hashtable)))
(if files
(let* ((root (substring file 0
(cons '(vms . ange-ftp-vms-delete-file-entry)
ange-ftp-delete-file-entry-alist)))
-(defun ange-ftp-vms-add-file-entry (path &optional dir-p)
+(defun ange-ftp-vms-add-file-entry (name &optional dir-p)
(if dir-p
- (ange-ftp-internal-add-file-entry path t)
+ (ange-ftp-internal-add-file-entry name t)
(let ((files (ange-ftp-get-hash-entry
- (file-name-directory path)
+ (file-name-directory name)
ange-ftp-files-hashtable)))
(if files
- (let ((file (ange-ftp-get-file-part path)))
+ (let ((file (ange-ftp-get-file-part name)))
(ange-ftp-save-match-data
(if (string-match ";[0-9]+$" file)
(ange-ftp-put-hash-entry
(defun ange-ftp-add-vms-host (host)
- "Interactively adds a given HOST to ange-ftp-vms-host-regexp."
+ "Mark HOST as the name of a machine running VMS."
(interactive
(list (read-string "Host: "
- (let ((name (or (buffer-file-name)
- (and (eq major-mode 'dired-mode)
- dired-directory))))
- (and name (car (ange-ftp-ftp-path name)))))))
+ (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) "$"
;; 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)))
+;;;; 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
;; "FILE.TYPE-Z". Hope that this is a reasonable thing to do.
(defun ange-ftp-vms-make-compressed-filename (name &optional reverse)
- (if reverse
- (cond
- ((string-match "-Z;[0-9]+$" name)
- (substring name 0 (match-beginning 0)))
- ((string-match ";[0-9]+$" name)
- (substring name 0 (match-beginning 0)))
- ((string-match "-Z$" name)
- (substring name 0 -2))
- (t name))
- (if (string-match ";[0-9]+$" name)
- (concat (substring name 0 (match-beginning 0))
- "-Z")
- (concat name "-Z"))))
-
-(or (assq 'vms ange-ftp-dired-compress-make-compressed-filename-alist)
- (setq ange-ftp-dired-compress-make-compressed-filename-alist
+ (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-dired-compress-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-bob-version (name)
+ 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)
(ange-ftp-save-match-data
(if (string-match ";[0-9]+$" name)
(substring name 0 (match-beginning 0))
name)))
-(or (assq 'vms ange-ftp-bob-version-alist)
- (setq ange-ftp-bob-version-alist
- (cons '(vms . ange-ftp-vms-bob-version)
- ange-ftp-bob-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 ((path (nth 2 (ange-ftp-ftp-path fn))))
- (if (string-match ";[0-9]+$" path)
- (let* ((path (substring path 0 (match-beginning 0)))
- (fn (ange-ftp-replace-path-component fn path)))
- (if (not (assq fn ange-ftp-file-version-alist))
- (let* ((base-versions
- (concat (file-name-nondirectory path) ";"))
- (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)))
+(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)))
\f
;;;; ------------------------------------------------------------
;;;; ------------------------------------------------------------
-(defun ange-ftp-fix-path-for-mts (path &optional reverse)
- "Convert PATH from UNIX-ish to MTS. If REVERSE given then convert from
-MTS to UNIX-ish."
+;; 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)
(ange-ftp-save-match-data
(if reverse
- (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" path)
+ (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name)
(let (acct file)
(if (match-beginning 1)
- (setq acct (substring path 0 (match-end 1))))
+ (setq acct (substring name 0 (match-end 1))))
(if (match-beginning 2)
- (setq file (substring path
+ (setq file (substring name
(match-beginning 2) (match-end 2))))
(concat (and acct (concat "/" acct "/"))
file))
- (error "path %s didn't match" path))
- (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" path)
- (concat (substring path 1 (match-end 1))
- (substring path (match-beginning 2) (match-end 2)))
+ (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.
- path))))
+ name))))
-(or (assq 'mts ange-ftp-fix-path-func-alist)
- (setq ange-ftp-fix-path-func-alist
- (cons '(mts . ange-ftp-fix-path-for-mts)
- ange-ftp-fix-path-func-alist)))
+(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)))
-(defun ange-ftp-fix-dir-path-for-mts (dir-path)
- "Convert path from UNIX-ish to MTS ready for a DIRectory listing.
-Remember that there are no directories in MTS."
- (if (string-equal dir-path "/")
+;; 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-path (ange-ftp-fix-path-for-mts dir-path)))
+ (let ((dir-name (ange-ftp-fix-name-for-mts dir-name)))
(cond
- ((string-equal dir-path "")
+ ((string-equal dir-name "")
"?")
- ((string-match ":$" dir-path)
- (concat dir-path "?"))
- (dir-path))))) ; It's just a single file.
+ ((string-match ":$" dir-name)
+ (concat dir-name "?"))
+ (dir-name))))) ; It's just a single file.
-(or (assq 'mts ange-ftp-fix-dir-path-func-alist)
- (setq ange-ftp-fix-dir-path-func-alist
- (cons '(mts . ange-ftp-fix-dir-path-for-mts)
- ange-ftp-fix-dir-path-func-alist)))
+(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
(defvar ange-ftp-mts-host-regexp nil)
+;; Return non-nil if HOST is running MTS.
(defun ange-ftp-mts-host (host)
- "Return whether HOST is running MTS."
(and ange-ftp-mts-host-regexp
(ange-ftp-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 ()
- "Parse the current buffer which is assumed to be in
-mts ftp dir format."
(let ((tbl (ange-ftp-make-hashtable)))
(goto-char (point-min))
(ange-ftp-save-match-data
ange-ftp-parse-list-func-alist)))
(defun ange-ftp-add-mts-host (host)
- "Interactively adds a given HOST to ange-ftp-mts-host-regexp."
+ "Mark HOST as the name of a machine running MTS."
(interactive
(list (read-string "Host: "
- (let ((name (or (buffer-file-name)
- (and (eq major-mode 'dired-mode)
- dired-directory))))
- (and name (car (ange-ftp-ftp-path name)))))))
+ (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) "$"
;;; 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)))
+;;;; 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)))
\f
;;;; ------------------------------------------------------------
;;;; CMS support
;;;; ------------------------------------------------------------
-;; Since CMS doesn't have any full pathname syntax, we have to fudge
-;; things with cd's. We actually send too many cd's, but is dangerous
+;; 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
;; Have I got the filename character set right?
-(defun ange-ftp-fix-path-for-cms (path &optional reverse)
- "Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert
-from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax,
-so we fudge things by sending cd's."
+(defun ange-ftp-fix-name-for-cms (name &optional reverse)
(ange-ftp-save-match-data
(if reverse
;; Since we only convert output from a pwd in this direction,
;; directory file name. Note that the expand-dir-hashtable
;; stores directories without the trailing /. Is this
;; consistent?
- (concat "/" path)
+ (concat "/" name)
(if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$"
- path)
- (let ((minidisk (substring path 1 (match-end 1))))
+ name)
+ (let ((minidisk (substring name 1 (match-end 1))))
(if (match-beginning 2)
- (let ((file (substring path (match-beginning 2)
+ (let ((file (substring name (match-beginning 2)
(match-end 2)))
(cmd (concat "cd " minidisk))
;; Must use ange-ftp-raw-send-cmd here to avoid
;; an infinite loop.
- (if (car (ange-ftp-raw-send-cmd proc cmd msg))
+ (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 msg)))
+ (let ((result (ange-ftp-raw-send-cmd proc cmd
+ ange-ftp-this-msg)))
(if (car result)
file
;; failed. give up.
minidisk))
(error "Invalid CMS filename")))))
-(or (assq 'cms ange-ftp-fix-path-func-alist)
- (setq ange-ftp-fix-path-func-alist
- (cons '(cms . ange-ftp-fix-path-for-cms)
- ange-ftp-fix-path-func-alist)))
+(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)))
-(defun ange-ftp-fix-dir-path-for-cms (dir-path)
- "Convert path from UNIX-ish to VMS ready for a DIRectory listing."
+;; 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-path)
+ ((string-equal "/" dir-name)
(error "Cannot get listing for fictitious \"/\" directory."))
- ((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-path)
- (let* ((minidisk (substring dir-path (match-beginning 1) (match-end 1)))
+ ((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 host user))
+ (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 path (match-beginning 2)
+ (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 host user))
+ (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 host user
+ (ange-ftp-error ange-ftp-this-host ange-ftp-this-user
(format "cd to minidisk %s failed: "
minidisk (cdr result))))))))
- (t (error "Invalid CMS pathname"))))
+ (t (error "Invalid CMS file name"))))
-(or (assq 'cms ange-ftp-fix-dir-path-func-alist)
- (setq ange-ftp-fix-dir-path-func-alist
- (cons '(cms . ange-ftp-fix-dir-path-for-cms)
- ange-ftp-fix-dir-path-func-alist)))
+(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)
- "Return whether the host is running CMS."
(and ange-ftp-cms-host-regexp
(ange-ftp-save-match-data
(string-match ange-ftp-cms-host-regexp host))))
(defun ange-ftp-add-cms-host (host)
- "Interactively adds a given HOST to ange-ftp-cms-host-regexp."
+ "Mark HOST as the name of a CMS host."
(interactive
(list (read-string "Host: "
- (let ((name (or (buffer-file-name)
- (and (eq major-mode 'dired-mode)
- dired-directory))))
- (and name (car (ange-ftp-ftp-path name)))))))
+ (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) "$"
ange-ftp-host-cache nil)))
(defun ange-ftp-parse-cms-listing ()
- "Parse the current buffer which is assumed to be a CMS directory 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
(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)))
+;;;;; 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 reverse
- (if (string-match "-Z$" name)
- (substring name 0 -2)
- name)
- (concat name "-Z")))
-
-(or (assq 'cms ange-ftp-dired-compress-make-compressed-filename-alist)
- (setq ange-ftp-dired-compress-make-compressed-filename-alist
+ (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-dired-compress-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)))
+ 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)))
\f
;;;; ------------------------------------------------------------
;;;; Finally provide package.
;;;; ------------------------------------------------------------
(provide 'ange-ftp)
+
+;;; ange-ftp.el ends here