;;; ange-ftp.el --- transparent FTP support for GNU Emacs
-;;; Copyright (C) 1989, 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;;; Copyright (C) 1989,90,91,92,93,94,95 Free Software Foundation, Inc.
;;;
;; Author: Andy Norman (ange@hplb.hpl.hp.com)
;; Keywords: comm
;;; 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
+;;; the value of `user-mail-address' is used; if nil then the user
;;; is prompted for a password as normal.
;;; "Dumb" UNIX hosts:
;;; 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:
;;; If you have a "smart" ftp program that allows you to issue commands like
;;; "USER foo@bar" which do nice proxy things, then look at the variables
;;; ange-ftp-smart-gateway and ange-ftp-smart-gateway-port.
+;;;
+;;; Otherwise, if there is an alternate ftp program that implements proxy in
+;;; a transparent way (i.e. w/o specifying the proxy host), that will
+;;; connect you directly to the desired destination host:
+;;; Set ange-ftp-gateway-ftp-program-name to that program's name.
+;;; Set ange-ftp-local-host-regexp to a value as stated earlier on.
+;;; Leave ange-ftp-gateway-host set to nil.
+;;; Set ange-ftp-smart-gateway to t.
;;; Tips for using ange-ftp:
;;;
;;; 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
;;; 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
-;;; should get things back in synch.
+;;; ange-ftp-kill-ftp-process can restart the ftp process, which
+;;; should get things back in sync.
;;;
;;; 3. Ange-ftp does not check to make sure that when creating a new file,
;;; you provide a valid filename for the remote operating system.
;; 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
(defvar ange-ftp-skip-msgs
(concat "^200 \\(PORT\\|Port\\) \\|^331 \\|^150 \\|^350 \\|^[0-9]+ bytes \\|"
"^Connected \\|^$\\|^Remote system\\|^Using\\|^ \\|Password:\\|"
+ "^Data connection \\|"
"^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye")
- "*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)"
"*Account password to use when the user is the same as ange-ftp-default-user.")
(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.")
+ "*If t, use value of `user-mail-address' as password for anonymous ftp.
+If a string, then use that string as the password.
+If nil, prompt the user for a password.")
(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 "\\.[zZ]$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|"
"\\.dvi$\\|\\.ps$\\|\\.elc$\\|TAGS$\\|\\.gif$\\|"
- "\\.EXE\\(;[0-9]+\\)?$\\|\\.[zZ]-part-..$\\|\\.gz$")
+ "\\.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\'
-instead.")
+ "*Regexp selecting hosts which can be reached directly with ftp.
+For other hosts the FTP process is started on \`ange-ftp-gateway-host\'
+instead, and/or reached via \`ange-ftp-gateway-ftp-program-name\'.")
(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.")
-
-(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.")
-
-(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
+ "*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 remote-shell-program
+ "*Name of program to spawn a shell on the gateway machine.
+Valid candidates are rsh (remsh on some systems), telnet and rlogin. See
+also the gateway variable above.")
+
+(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 and/or the gateway ftp program is smart.
+Don't bother telnetting, etc., already connected to desired host transparently,
+or just issue a user@host command in case \`ange-ftp-gateway-host\' is non-nil.")
(defvar ange-ftp-smart-gateway-port "21"
"*Port on gateway machine to use when smart gateway is in operation.")
"*Name of FTP program to run.")
(defvar ange-ftp-gateway-ftp-program-name "ftp"
- "*Name of FTP program to run on gateway machine.
+ "*Name of FTP program to run when accessing non-local hosts.
Some AT&T folks claim to use something called `pftp' here.")
(defvar ange-ftp-ftp-program-args '("-i" "-n" "-g" "-v")
"*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.
;;;; Internal variables.
;;;; ------------------------------------------------------------
-(defconst ange-ftp-version "$Revision: 1.23 $")
-
(defvar ange-ftp-data-buffer-name " *ftp data*"
"Buffer name to hold directory listing data received from ftp process.")
;; (put 'ftp-error 'error-message "FTP error")
\f
;;; ------------------------------------------------------------
-;;; Match-data support (stolen from Kyle I think)
-;;; ------------------------------------------------------------
-
-(defmacro ange-ftp-save-match-data (&rest body)
- "Execute the BODY forms, restoring the global value of the match data.
-Also makes matching case-sensitive within BODY."
- (let ((original (make-symbol "match-data"))
- case-fold-search)
- (list
- 'let (list (list original '(match-data)))
- (list 'unwind-protect
- (cons 'progn body)
- (list 'store-match-data original)))))
-
-(put 'ange-ftp-save-match-data 'lisp-indent-hook 0)
-(put 'ange-ftp-save-match-data 'edebug-form-hook '(&rest form))
-\f
-;;; ------------------------------------------------------------
;;; Enhanced message support.
;;; ------------------------------------------------------------
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)
- (setq msg (concat "> " (substring msg (- 3 max)))))
- (message "%s" msg)))
+ (if noninteractive
+ msg
+ (if (>= (length msg) max)
+ ;; Take just the last MAX - 3 chars of the string.
+ (setq msg (concat "> " (substring msg (- 3 max)))))
+ (message "%s" msg))))
(defun ange-ftp-abbreviate-filename (file &optional new)
"Abbreviate the file name FILE relative to the default-directory.
If the optional parameter NEW is given and the non-directory parts match,
only return the directory part of FILE."
- (ange-ftp-save-match-data
+ (save-match-data
(if (and default-directory
(string-match (concat "^"
(regexp-quote default-directory)
(if (ange-ftp-lookup-passwd host user)
(throw 'found-one host))))
ange-ftp-user-hashtable)
- (ange-ftp-save-match-data
+ (save-match-data
(ange-ftp-map-hashtable
(function
(lambda (key value)
"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))
ange-ftp-generate-anonymous-password)
(if (stringp ange-ftp-generate-anonymous-password)
ange-ftp-generate-anonymous-password
- (concat (user-login-name) "@" (system-name))))
+ user-mail-address))
;; see if same user has logged in to other hosts; if so then prompt
;; with the password that was used there.
(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"
- (point-max) 'end 2) (point)))
+ (end (save-excursion
+ (if (looking-at "machine\\>")
+ ;; Skip `machine' and the machine name that follows.
+ (progn
+ (skip-chars-forward "^ \t\n")
+ (skip-chars-forward " \t\n")
+ (skip-chars-forward "^ \t\n"))
+ ;; Skip `default'.
+ (skip-chars-forward "^ \t\n"))
+ ;; Find start of the next `machine' or `default'
+ ;; or the end of the buffer.
+ (if (re-search-forward "machine\\>\\|default\\>" nil t)
+ (match-beginning 0)
+ (point-max))))
machine login password account)
- (goto-char start)
(setq machine (ange-ftp-parse-netrc-token "machine" end)
login (ange-ftp-parse-netrc-token "login" end)
password (ange-ftp-parse-netrc-token "password" end)
(setq ange-ftp-default-account account)))))
(goto-char end)))
-(defun ange-ftp-parse-netrc ()
- "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."
+;; Read in ~/.netrc, if one exists. If ~/.netrc file exists and has
+;; the correct permissions then extract the \`machine\', \`login\',
+;; \`password\' and \`account\' information from within.
+(defun ange-ftp-parse-netrc ()
;; We set this before actually doing it to avoid the possibility
;; of an infinite loop if ange-ftp-netrc-filename is an FTP file.
(interactive)
- (let* ((file (ange-ftp-chase-symlinks
- (ange-ftp-real-expand-file-name ange-ftp-netrc-filename)))
- (attr (ange-ftp-real-file-attributes file)))
+ (let (file attr)
+ (let ((default-directory "/"))
+ (setq file (ange-ftp-chase-symlinks
+ (ange-ftp-real-expand-file-name ange-ftp-netrc-filename)))
+ (setq attr (ange-ftp-real-file-attributes file)))
(if (and attr ; file exists.
(not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed
- (ange-ftp-save-match-data
+ (save-match-data
(if (or ange-ftp-disable-netrc-security-check
(and (eq (nth 2 attr) (user-uid)) ; Same uids.
(string-match ".r..------" (nth 8 attr))))
(mapcar 'funcall find-file-hooks)
(setq buffer-file-name nil)
(goto-char (point-min))
+ (skip-chars-forward " \t\n")
(while (not (eobp))
(ange-ftp-parse-netrc-group))
(kill-buffer (current-buffer)))
(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
+ (save-match-data
(let (res)
(ange-ftp-map-hashtable
(function
(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)
- "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."
(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-name-format) name)
+ (save-match-data
+ (if (posix-string-match (car ange-ftp-name-format) name)
(let* ((ns (cdr ange-ftp-name-format))
(host (ange-ftp-ftp-name-component 0 ns name))
(user (ange-ftp-ftp-name-component 1 ns name))
(list host user name))
nil)))))
+;; Take a FULLNAME that matches according to ange-ftp-name-format and
+;; replace the name component with NAME.
(defun ange-ftp-replace-name-component (fullname name)
- "Take a FULLNAME that matches according to ange-ftp-name-format and
-replace the name component with NAME."
- (ange-ftp-save-match-data
- (if (string-match (car ange-ftp-name-format) fullname)
+ (save-match-data
+ (if (posix-string-match (car ange-ftp-name-format) fullname)
(let* ((ns (cdr ange-ftp-name-format))
(elt (nth 2 ns)))
(concat (substring fullname 0 (match-beginning elt))
"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
"Set correct modes for the current buffer if visiting a remote file."
(if (and (stringp buffer-file-name)
(ange-ftp-ftp-name buffer-file-name))
- (progn
- (make-local-variable 'make-backup-files)
- (setq make-backup-files ange-ftp-make-backup-files)
- (auto-save-mode ange-ftp-auto-save))))
+ (auto-save-mode ange-ftp-auto-save)))
(defun ange-ftp-kill-ftp-process (buffer)
"Kill the FTP process associated with BUFFER.
;;;; ------------------------------------------------------------
(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 t
ange-ftp-process-result-line line))
+ ;; Check this before checking for errors.
+ ;; Otherwise the last line of these three seems to be an error:
+ ;; 230-see a significant impact from the move. For those of you who can't
+ ;; 230-use DNS to resolve hostnames and get an error message like
+ ;; 230-"ftp.stsci.edu: unknown host", the new IP address will be...
+ ((string-match ange-ftp-multi-msgs line)
+ (setq ange-ftp-process-multi-skip t))
((string-match ange-ftp-fatal-msgs line)
(delete-process proc)
(setq ange-ftp-process-busy nil
ange-ftp-process-result-line line))
- ((string-match ange-ftp-multi-msgs line)
- (setq ange-ftp-process-multi-skip t))
(ange-ftp-process-multi-skip
t)
(t
(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-hash-mark-count (+ (- (match-end 0)
(match-beginning 0))
ange-ftp-hash-mark-count))
- (and ange-ftp-process-msg
+ (and ange-ftp-hash-mark-unit
+ ange-ftp-process-msg
ange-ftp-process-verbose
(not (eq (selected-window) (minibuffer-window)))
(not (boundp 'search-message)) ;screws up isearch otherwise
(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)))
;; see if the buffer is still around... it could have been deleted.
(if (buffer-name buffer)
(unwind-protect
- (ange-ftp-save-match-data
+ (progn
(set-buffer (process-buffer proc))
;; handle hash mark printing
- (and ange-ftp-hash-mark-unit
- ange-ftp-process-busy
+ (and 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)
+ ;; Replace STR by the result of the comint processing.
+ (setq str (buffer-substring comint-last-output-start
+ (process-mark proc)))
(if ange-ftp-process-busy
(progn
(setq ange-ftp-process-string (concat ange-ftp-process-string
(defun ange-ftp-process-sentinel (proc str)
"When ftp process changes state, nuke all file-entries in cache."
- (ange-ftp-save-match-data
- (let ((name (process-name proc)))
- (if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)*" name)
- (let ((user (substring name (match-beginning 1) (match-end 1)))
- (host (substring name (match-beginning 2) (match-end 2))))
- (ange-ftp-wipe-file-entries host user))))
- (setq ange-ftp-ls-cache-file nil)))
+ (let ((name (process-name proc)))
+ (if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name)
+ (let ((user (substring name (match-beginning 1) (match-end 1)))
+ (host (substring name (match-beginning 2) (match-end 2))))
+ (ange-ftp-wipe-file-entries host user))))
+ (setq ange-ftp-ls-cache-file nil))
\f
;;;; ------------------------------------------------------------
;;;; Gateway support.
;; yes, I know that I could simplify the following expression, but it is
;; clearer (to me at least) this way.
(and (not ange-ftp-smart-gateway)
- (ange-ftp-save-match-data
+ (save-match-data
(not (string-match ange-ftp-local-host-regexp host)))))
(defun ange-ftp-use-smart-gateway-p (host)
"Returns whether to access this host via a smart gateway."
(and ange-ftp-smart-gateway
- (ange-ftp-save-match-data
+ (save-match-data
(not (string-match ange-ftp-local-host-regexp host)))))
\f
(setq ange-ftp-gwp-running nil))
(defun ange-ftp-gwp-filter (proc str)
- (ange-ftp-save-match-data
- (ange-ftp-process-log-string proc str)
- (cond ((string-match "login: *$" str)
- (send-string proc
- (concat
- (let ((ange-ftp-default-user t))
- (ange-ftp-get-user ange-ftp-gateway-host))
- "\n")))
- ((string-match "Password: *$" str)
- (send-string proc
- (concat
- (ange-ftp-get-passwd ange-ftp-gateway-host
- (ange-ftp-get-user
- ange-ftp-gateway-host))
- "\n")))
- ((string-match ange-ftp-gateway-fatal-msgs str)
- (delete-process proc)
- (setq ange-ftp-gwp-running nil))
- ((string-match ange-ftp-gateway-prompt-pattern str)
- (setq ange-ftp-gwp-running nil
- ange-ftp-gwp-status t)))))
+ (comint-output-filter proc str)
+ (save-excursion
+ (set-buffer (process-buffer proc))
+ ;; Replace STR by the result of the comint processing.
+ (setq str (buffer-substring comint-last-output-start (process-mark proc))))
+ (cond ((string-match "login: *$" str)
+ (send-string proc
+ (concat
+ (let ((ange-ftp-default-user t))
+ (ange-ftp-get-user ange-ftp-gateway-host))
+ "\n")))
+ ((string-match "Password: *$" str)
+ (send-string proc
+ (concat
+ (ange-ftp-get-passwd ange-ftp-gateway-host
+ (ange-ftp-get-user
+ ange-ftp-gateway-host))
+ "\n")))
+ ((string-match ange-ftp-gateway-fatal-msgs str)
+ (delete-process proc)
+ (setq ange-ftp-gwp-running nil))
+ ((string-match ange-ftp-gateway-prompt-pattern str)
+ (setq ange-ftp-gwp-running nil
+ ange-ftp-gwp-status t))))
(defun ange-ftp-gwp-start (host user name args)
"Login to the gateway machine and fire up an ftp process."
(let* ((gw-user (ange-ftp-get-user ange-ftp-gateway-host))
- (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))
(set-process-filter proc (function ange-ftp-gwp-filter))
- (set-marker (process-mark proc) (point))
+ (save-excursion
+ (set-buffer (process-buffer proc))
+ (internal-ange-ftp-mode)
+ (set-marker (process-mark proc) (point)))
(setq ange-ftp-gwp-running t
ange-ftp-gwp-status nil)
(ange-ftp-message "Connecting to gateway %s..." ange-ftp-gateway-host)
(goto-char (point-max))
(move-marker comint-last-input-start (point))
;; don't insert the password into the buffer on the USER command.
- (ange-ftp-save-match-data
+ (save-match-data
(if (string-match "^user \"[^\"]*\"" cmd)
(insert (substring cmd 0 (match-end 0)) " Turtle Power!\n")
(insert cmd)))
"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
If HOST is only ftp-able through a gateway machine then spawn a shell
on the gateway machine to do the ftp instead."
(let* ((use-gateway (ange-ftp-use-gateway-p host))
- (ftp-prog (if use-gateway
+ (use-smart-ftp (and (not ange-ftp-gateway-host)
+ (ange-ftp-use-smart-gateway-p host)))
+ (ftp-prog (if (or use-gateway
+ use-smart-ftp)
ange-ftp-gateway-ftp-program-name
ange-ftp-ftp-program-name))
(args (append (list ftp-prog) ange-ftp-ftp-program-args))
+ ;; Without the following binding, ange-ftp-start-process
+ ;; recurses on file-accessible-directory-p, since it needs to
+ ;; restart its process in order to determine anything about
+ ;; default-directory.
+ (file-name-handler-alist)
+ (default-directory
+ (if (file-accessible-directory-p default-directory)
+ default-directory
+ exec-directory))
proc)
- (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)
+ (process-environment process-environment))
+ ;; This tells GNU ftp not to output any fancy escape sequences.
+ (setenv "TERM" "dumb")
+ (if use-gateway
+ (if ange-ftp-gateway-program-interactive
+ (setq proc (ange-ftp-gwp-start host user name args))
+ (setq proc (apply 'start-process name name
+ (append (list ange-ftp-gateway-program
+ ange-ftp-gateway-host)
+ args))))
+ (setq proc (apply 'start-process name name args))))
(process-kill-without-query proc)
(save-excursion
(set-buffer (process-buffer proc))
proc))
(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)
(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 'comint-password-prompt-regexp)
+ ;; This is a regexp that can't match anything.
+ ;; ange-ftp has its own ways of handling passwords.
+ (setq comint-password-prompt-regexp "^a\\'z")
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start comint-prompt-regexp)))
(defun ange-ftp-smart-login (host user pass account proc)
"Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT.
(defun ange-ftp-normal-login (host user pass account proc)
"Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT.
PROC is the process to the FTP-client."
- (let ((result (ange-ftp-raw-send-cmd
+ (let* ((nshost (ange-ftp-nslookup-host host))
+ (result (ange-ftp-raw-send-cmd
proc
- (format "open %s" (ange-ftp-nslookup-host host))
+ (format "open %s" nshost)
(format "Opening FTP connection to %s" host))))
(or (car result)
(ange-ftp-error host user
(cdr result))))
(setq result (ange-ftp-raw-send-cmd
proc
- (format "user \"%s\" %s %s" user pass account)
+ (if (ange-ftp-use-smart-gateway-p host)
+ (format "user \"%s\"@%s %s %s" user nshost pass account)
+ (format "user \"%s\" %s %s" user pass account))
(format "Logging in as user %s@%s" user host)))
(or (car result)
(progn
(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.")
(let* ((status (ange-ftp-raw-send-cmd proc "hash"))
(result (car status))
(line (cdr status)))
- (ange-ftp-save-match-data
+ (save-match-data
(if (string-match ange-ftp-hash-mark-msgs line)
(let ((size (string-to-int
(substring line
(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)))
(setq proc (ange-ftp-start-process host user name))
;; login to FTP server.
- (if (ange-ftp-use-smart-gateway-p host)
+ (if (and (ange-ftp-use-smart-gateway-p host)
+ ange-ftp-gateway-host)
(ange-ftp-smart-login host user pass account proc)
(ange-ftp-normal-login host user pass account proc))
;; (for efficiency) if you log into a particular non-UNIX host frequently.
(defvar ange-ftp-fix-name-func-alist nil
- "Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
+ "Alist saying how to convert file name to the host's syntax.
+Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
which can change a UNIX file name into a name more suitable for a host of type
TYPE.")
(defvar ange-ftp-fix-dir-name-func-alist nil
- "Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
+ "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.")
;; capability.
(let ((cmd0 (car cmd))
(cmd1 (nth 1 cmd))
+ (ange-ftp-this-user user)
+ (ange-ftp-this-host host)
+ (ange-ftp-this-msg msg)
cmd2 cmd3 host-type fix-name-func)
(cond
cmd1 (format "\"%s %s\"" cmd3 cmd1))))
;; First argument is the remote name
- ((let ((ange-ftp-this-user user)
- (ange-ftp-this-host host)
- (ange-ftp-this-msg msg))
+ ((progn
(setq fix-name-func (or (cdr (assq host-type
ange-ftp-fix-name-func-alist))
'identity))
"^[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)
;; Note that ange-ftp-host-type returns unix as the default value.
- (ange-ftp-save-match-data
+ (save-match-data
(let* ((result (ange-ftp-get-pwd host user))
(dir (car result))
fix-name-func)
;;;; 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
+ (and host ange-ftp-dumb-unix-host-regexp
+ (save-match-data
(string-match ange-ftp-dumb-unix-host-regexp host))))
(defun ange-ftp-add-dumb-unix-host (host)
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:
;;
;; With no-error t, it returns:
;; an error if not an ange-ftp-name
-;; error if listing is unreable (most likely caused by a slow connection)
+;; error if listing is unreadable (most likely caused by a slow connection)
;; nil if ftp error (this is because although asking to list a nonexistent
;; directory on a remote unix machine usually (except
;; maybe for dumb hosts) returns an ls error, but no
"\\|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 (name &optional dir-p)
"Add a file entry for file NAME, if its directory info exists."
;;; 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 DIR to ange-ftp-dl-dir-regexp."
(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
+ (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.
NO-ERROR, if a listing for DIRECTORY cannot be obtained."
(setq directory (file-name-as-directory directory)) ;normalize
(or (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable)
- (ange-ftp-save-match-data
+ (save-match-data
(and (ange-ftp-ls directory
;; This is an efficiency hack. We try to
;; anticipate what sort of listing dired
(ange-ftp-get-hash-entry
directory ange-ftp-files-hashtable)))))
+;; Given NAME, return the file part that can be used for looking up the
+;; file's entry in a hashtable.
(defmacro ange-ftp-get-file-part (name)
- "Given NAME, return the file part that can be used for looking up the
-file's entry in a hashtable."
(` (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 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."
(` (not
(let* ((efile (, file)) ; expand once.
(edir (, dir))
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
(ange-ftp-error host user (concat "BINARY failed: " (cdr result)))
(save-excursion
(set-buffer (process-buffer (ange-ftp-get-process host user)))
- (setq ange-ftp-hash-mark-unit (ash ange-ftp-binary-hash-mark-size -4))))))
+ (and ange-ftp-binary-hash-mark-size
+ (setq ange-ftp-hash-mark-unit
+ (ash ange-ftp-binary-hash-mark-size -4)))))))
(defun ange-ftp-set-ascii-mode (host user)
"Tell the ftp process for the given HOST & USER to switch to ascii mode."
(ange-ftp-error host user (concat "ASCII failed: " (cdr result)))
(save-excursion
(set-buffer (process-buffer (ange-ftp-get-process host user)))
- (setq ange-ftp-hash-mark-unit (ash ange-ftp-ascii-hash-mark-size -4))))))
+ (and ange-ftp-ascii-hash-mark-size
+ (setq ange-ftp-hash-mark-unit
+ (ash ange-ftp-ascii-hash-mark-size -4)))))))
\f
(defun ange-ftp-cd (host user dir)
(let ((result (ange-ftp-send-cmd host user (list 'cd dir) "Doing CD")))
(line (cdr result))
dir)
(if (car result)
- (ange-ftp-save-match-data
+ (save-match-data
(and (or (string-match "\"\\([^\"]*\\)\"" line)
(string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers!
(setq dir (substring line
;;; ------------------------------------------------------------
(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
(defun ange-ftp-canonize-filename (n)
"Take a string and short-circuit //, /. and /.."
- (if (string-match ".+//" n) ;don't upset Apollo users
+ (if (string-match "[^:]+//" n) ;don't upset Apollo users
(setq n (substring n (1- (match-end 0)))))
(let ((parsed (ange-ftp-ftp-name n)))
(if parsed
name))
(error "Unable to obtain CWD")))))
- (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 "^//" name)
- (setq name (substring name 1)))
+ ;; If name starts with //, preserve that, for apollo system.
+ (if (not (string-match "^//" name))
+ (progn
+ (setq name (ange-ftp-real-expand-file-name name))
+
+ (if (string-match "^//" name)
+ (setq name (substring name 1)))))
;; Now substitute the expanded name back into the overall filename.
(ange-ftp-replace-name-component n name))
(defun ange-ftp-expand-file-name (name &optional default)
"Documented as original."
- (ange-ftp-save-match-data
+ (save-match-data
(if (eq (string-to-char name) ?/)
- (while (cond ((string-match ".+//" name) ;don't upset Apollo users
+ (while (cond ((string-match "[^:]+//" name) ;don't upset Apollo users
(setq name (substring name (1- (match-end 0)))))
((string-match "/~" name)
(setq name (substring name (1- (match-end 0))))))))
;;; 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.")
(let ((parsed (ange-ftp-ftp-name name)))
(if parsed
(let ((filename (nth 2 parsed)))
- (if (ange-ftp-save-match-data
+ (if (save-match-data
(string-match "^~[^/]*$" filename))
name
(ange-ftp-replace-name-component
(let ((parsed (ange-ftp-ftp-name name)))
(if parsed
(let ((filename (nth 2 parsed)))
- (if (ange-ftp-save-match-data
+ (if (save-match-data
(string-match "^~[^/]*$" filename))
""
(ange-ftp-real-file-name-nondirectory name)))
;; Returns non-nil if should transfer FILE in binary mode.
(defun ange-ftp-binary-file (file)
- (ange-ftp-save-match-data
+ (save-match-data
(string-match ange-ftp-binary-file-name-regexp file)))
(defun ange-ftp-write-region (start end filename &optional append visit)
(user (nth 1 parsed))
(name (ange-ftp-quote-string (nth 2 parsed)))
(temp (ange-ftp-make-tmp-name host))
- (binary (ange-ftp-binary-file filename))
+ (binary (or (ange-ftp-binary-file filename)
+ (eq (ange-ftp-host-type host user) 'unix)))
(cmd (if append 'append 'put))
(abbr (ange-ftp-abbreviate-filename filename)))
(unwind-protect
(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)
+(defun ange-ftp-insert-file-contents (filename &optional visit beg end replace)
(barf-if-buffer-read-only)
(setq filename (expand-file-name filename))
(let ((parsed (ange-ftp-ftp-name filename)))
(user (nth 1 parsed))
(name (ange-ftp-quote-string (nth 2 parsed)))
(temp (ange-ftp-make-tmp-name host))
- (binary (ange-ftp-binary-file filename))
+ (binary (or (ange-ftp-binary-file filename)
+ (eq (ange-ftp-host-type host user) 'unix)))
(abbr (ange-ftp-abbreviate-filename filename))
size)
(unwind-protect
(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-expand-symlink (file dir)
(if (file-name-absolute-p file)
(ange-ftp-get-files directory)))
files f)
(setq directory (file-name-as-directory directory))
- (ange-ftp-save-match-data
+ (save-match-data
(while tail
(setq f (car tail)
tail (cdr tail))
(file-exists-p file)
(ange-ftp-real-file-readable-p file)))
+(defun ange-ftp-file-executable-p (file)
+ (setq file (expand-file-name file))
+ (if (ange-ftp-ftp-name file)
+ (file-exists-p file)
+ (ange-ftp-real-file-executable-p file)))
+
(defun ange-ftp-delete-file (file)
(interactive "fDelete file: ")
(setq file (expand-file-name file))
;; (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)
(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-binary-file newname)
+ (and (eq (ange-ftp-host-type f-host f-user) 'unix)
+ (eq (ange-ftp-host-type t-host t-user) 'unix))))
temp1
temp2)
;;;; File renaming support.
;;;; ------------------------------------------------------------
-(defun ange-ftp-rename-remote-to-remote (filename newname f-parsed t-parsed
- binary)
+(defun ange-ftp-rename-remote-to-remote (filename newname f-parsed t-parsed)
"Rename remote file FILE to remote file NEWNAME."
(let ((f-host (nth 0 f-parsed))
(f-user (nth 1 f-parsed))
(setq filename (expand-file-name filename))
(setq newname (expand-file-name newname))
(let* ((f-parsed (ange-ftp-ftp-name filename))
- (t-parsed (ange-ftp-ftp-name newname))
- (binary (if (or f-parsed t-parsed) (ange-ftp-binary-file filename))))
+ (t-parsed (ange-ftp-ftp-name newname)))
(if (and (or f-parsed t-parsed)
(or (not ok-if-already-exists)
(numberp ok-if-already-exists)))
(if f-parsed
(if t-parsed
(ange-ftp-rename-remote-to-remote filename newname f-parsed
- t-parsed binary)
+ t-parsed)
(ange-ftp-rename-remote-to-local filename newname))
(if t-parsed
(ange-ftp-rename-local-to-remote filename newname)
"/"))) ; / never in filename
completion-ignored-extensions
"\\|")))
- (ange-ftp-save-match-data
+ (save-match-data
(or (ange-ftp-file-name-completion-1
file tbl ange-ftp-this-dir
(function ange-ftp-file-entry-not-ignored-p))
(ange-ftp-del-hash-entry dir ange-ftp-files-hashtable)
(ange-ftp-get-files dir t))))
\f
-(defun ange-ftp-make-directory (dir)
+(defun ange-ftp-make-directory (dir &optional parents)
(interactive (list (expand-file-name (read-file-name "Make directory: "))))
+ (if parents
+ (let ((parent (file-name-directory (directory-file-name dir))))
+ (or (file-exists-p parent)
+ (ange-ftp-make-directory parent parents))))
(if (file-exists-p dir)
(error "Cannot make directory %s: file already exists" dir)
(let ((parsed (ange-ftp-ftp-name dir)))
(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)))
+ (let ((tmp1 (ange-ftp-make-tmp-name (car pa1))))
(ange-ftp-copy-file-internal fn1 tmp1 t nil
(format "Getting %s" fn1))
tmp1))))
-(defun ange-ftp-load (file)
+(defun ange-ftp-load (file &optional noerror nomessage nosuffix)
(if (ange-ftp-ftp-name file)
- (let ((copy (ange-ftp-file-local-copy file)))
- (unwind-protect
- (load copy)
- (delete-file copy)))
- (ange-ftp-real-load 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))
+ (setq tryfiles (cdr tryfiles)))
+ (if copy
+ (unwind-protect
+ (funcall 'load copy noerror nomessage nosuffix)
+ (delete-file copy))
+ (or noerror
+ (signal 'file-error (list "Cannot open load file" file)))))
+ (ange-ftp-real-load file noerror nomessage nosuffix)))
;; Calculate default-unhandled-directory for a given ange-ftp buffer.
(defun ange-ftp-unhandled-file-name-directory (filename)
(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)))
+ (save-match-data (funcall conversion-func name)))
(compressing (car decision))
(newfile (nth 1 decision)))
(if compressing
(ange-ftp-copy-file-internal tmp2 nfile t nil msg2))))
(ange-ftp-del-tmp-name tmp1)
(ange-ftp-del-tmp-name tmp2))))
+
+(defun ange-ftp-find-backup-file-name (fn)
+ ;; Either return the ordinary backup name, etc.,
+ ;; or return nil meaning don't make a backup.
+ (if ange-ftp-make-backup-files
+ (ange-ftp-real-find-backup-file-name fn)))
\f
;;; Define the handler for special file names
;;; that causes ange-ftp to be invoked.
(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)))))
+ (ange-ftp-run-real-handler operation args))))
+
+;;; This regexp takes care of real ange-ftp file names (with a slash
+;;; and colon).
+;;; Don't allow the host name to end in a period--some systems use /.:
;;;###autoload
-(or (assoc "^/[^/:]+:" file-name-handler-alist)
+(or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist)
(setq file-name-handler-alist
- (cons '("^/[^/:]+:" . ange-ftp-hook-function)
+ (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
(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 'dired-uncache 'ange-ftp 'ange-ftp-dired-uncache)
(put 'dired-compress-file 'ange-ftp 'ange-ftp-dired-compress-file)
(put 'load 'ange-ftp 'ange-ftp-load)
+(put 'find-backup-file-name 'ange-ftp 'ange-ftp-find-backup-file-name)
;; Turn off truename processing to save time.
;; Treat each name as its own truename.
;;; 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)
- (let (file-name-handler-alist)
- (apply 'file-name-directory args)))
+ (ange-ftp-run-real-handler 'file-name-directory args))
(defun ange-ftp-real-file-name-nondirectory (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-name-nondirectory args)))
+ (ange-ftp-run-real-handler '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)))
+ (ange-ftp-run-real-handler 'file-name-as-directory args))
(defun ange-ftp-real-directory-file-name (&rest args)
- (let (file-name-handler-alist)
- (apply 'directory-file-name args)))
+ (ange-ftp-run-real-handler 'directory-file-name args))
(defun ange-ftp-real-expand-file-name (&rest args)
- (let (file-name-handler-alist)
- (apply 'expand-file-name args)))
+ (ange-ftp-run-real-handler 'expand-file-name args))
(defun ange-ftp-real-make-directory (&rest args)
- (let (file-name-handler-alist)
- (apply 'make-directory args)))
+ (ange-ftp-run-real-handler 'make-directory args))
(defun ange-ftp-real-delete-directory (&rest args)
- (let (file-name-handler-alist)
- (apply 'delete-directory args)))
+ (ange-ftp-run-real-handler 'delete-directory args))
(defun ange-ftp-real-insert-file-contents (&rest args)
- (let (file-name-handler-alist)
- (apply 'insert-file-contents args)))
+ (ange-ftp-run-real-handler 'insert-file-contents args))
(defun ange-ftp-real-directory-files (&rest args)
- (let (file-name-handler-alist)
- (apply 'directory-files args)))
+ (ange-ftp-run-real-handler 'directory-files args))
(defun ange-ftp-real-file-directory-p (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-directory-p args)))
+ (ange-ftp-run-real-handler 'file-directory-p args))
(defun ange-ftp-real-file-writable-p (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-writable-p args)))
+ (ange-ftp-run-real-handler 'file-writable-p args))
(defun ange-ftp-real-file-readable-p (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-readable-p 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)
- (let (file-name-handler-alist)
- (apply 'file-symlink-p args)))
+ (ange-ftp-run-real-handler 'file-symlink-p args))
(defun ange-ftp-real-delete-file (&rest args)
- (let (file-name-handler-alist)
- (apply 'delete-file args)))
+ (ange-ftp-run-real-handler 'delete-file args))
(defun ange-ftp-real-read-file-name-internal (&rest args)
- (let (file-name-handler-alist)
- (apply 'read-file-name-internal args)))
+ (ange-ftp-run-real-handler '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)))
+ (ange-ftp-run-real-handler 'verify-visited-file-modtime args))
(defun ange-ftp-real-file-exists-p (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-exists-p args)))
+ (ange-ftp-run-real-handler 'file-exists-p args))
(defun ange-ftp-real-write-region (&rest args)
- (let (file-name-handler-alist)
- (apply 'write-region args)))
+ (ange-ftp-run-real-handler 'write-region args))
(defun ange-ftp-real-backup-buffer (&rest args)
- (let (file-name-handler-alist)
- (apply 'backup-buffer args)))
+ (ange-ftp-run-real-handler 'backup-buffer args))
(defun ange-ftp-real-copy-file (&rest args)
- (let (file-name-handler-alist)
- (apply 'copy-file args)))
+ (ange-ftp-run-real-handler 'copy-file args))
(defun ange-ftp-real-rename-file (&rest args)
- (let (file-name-handler-alist)
- (apply 'rename-file args)))
+ (ange-ftp-run-real-handler 'rename-file args))
(defun ange-ftp-real-file-attributes (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-attributes args)))
+ (ange-ftp-run-real-handler 'file-attributes args))
(defun ange-ftp-real-file-name-all-completions (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-name-all-completions args)))
+ (ange-ftp-run-real-handler 'file-name-all-completions args))
(defun ange-ftp-real-file-name-completion (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-name-completion args)))
+ (ange-ftp-run-real-handler 'file-name-completion args))
(defun ange-ftp-real-insert-directory (&rest args)
- (let (file-name-handler-alist)
- (apply 'insert-directory args)))
+ (ange-ftp-run-real-handler 'insert-directory args))
(defun ange-ftp-real-file-name-sans-versions (&rest args)
- (let (file-name-handler-alist)
- (apply 'file-name-sans-versions args)))
+ (ange-ftp-run-real-handler 'file-name-sans-versions args))
(defun ange-ftp-real-shell-command (&rest args)
- (let (file-name-handler-alist)
- (apply 'shell-command args)))
+ (ange-ftp-run-real-handler 'shell-command args))
(defun ange-ftp-real-load (&rest args)
- (let (file-name-handler-alist)
- (apply 'load args)))
+ (ange-ftp-run-real-handler 'load args))
+(defun ange-ftp-real-find-backup-file-name (&rest args)
+ (ange-ftp-run-real-handler 'find-backup-file-name args))
\f
;; Here we support using dired on remote hosts.
;; I have turned off the support for using dired on foreign directory formats.
(defun ange-ftp-insert-directory (file switches &optional wildcard full)
(let ((short (ange-ftp-abbreviate-filename file))
- (parsed (ange-ftp-ftp-name file)))
+ (parsed (ange-ftp-ftp-name (expand-file-name file))))
(if parsed
(insert
(if wildcard
(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))
+ (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.")
(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)
(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))
+ remote-shell-program host command))
(ange-ftp-message "Remote command '%s' ..." command)
;; Cannot call ange-ftp-real-dired-run-shell-command here as it
;; would prepend "cd default-directory" --- which bombs because
;; 0 ;success-count
;; (length fn-list) ;total
;; )
-;; ;; normal case... use the interative routine... much cheaper.
+;; ;; 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-vos-host (host)
; (and ange-ftp-vos-host-regexp
-; (ange-ftp-save-match-data
+; (save-match-data
; (string-match ange-ftp-vos-host-regexp host))))
;
;(defun ange-ftp-parse-vos-listing ()
; ("^Dirs: [0-9]+\n+" t 30)))
; type-regexp type-is-dir type-col file)
; (goto-char (point-min))
-; (ange-ftp-save-match-data
+; (save-match-data
; (while type-list
; (setq type-regexp (car (car type-list))
; type-is-dir (nth 1 (car type-list))
;; 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
+ (save-match-data
(if reverse
(if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name)
(let (drive dir file)
;; Return non-nil if HOST is running VMS.
(defun ange-ftp-vms-host (host)
(and ange-ftp-vms-host-regexp
- (ange-ftp-save-match-data
+ (save-match-data
(string-match ange-ftp-vms-host-regexp host))))
;; Because some VMS ftp servers convert filenames to lower case
(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
(let ((tbl (ange-ftp-make-hashtable))
file)
(goto-char (point-min))
- (ange-ftp-save-match-data
+ (save-match-data
(while (setq file (ange-ftp-parse-vms-filename))
(if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file)
;; deal with directories
(defun ange-ftp-vms-delete-file-entry (name &optional dir-p)
(if dir-p
(ange-ftp-internal-delete-file-entry name t)
- (ange-ftp-save-match-data
+ (save-match-data
(let ((file (ange-ftp-get-file-part name)))
(if (string-match ";[0-9]+$" file)
;; In VMS you can't delete a file without an explicit
ange-ftp-files-hashtable)))
(if files
(let ((file (ange-ftp-get-file-part name)))
- (ange-ftp-save-match-data
+ (save-match-data
(if (string-match ";[0-9]+$" file)
(ange-ftp-put-hash-entry
(substring file 0 (match-beginning 0))
(defun ange-ftp-vms-file-name-as-directory (name)
- (ange-ftp-save-match-data
+ (save-match-data
(if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name)
(setq name (substring name 0 (match-beginning 0))))
(ange-ftp-real-file-name-as-directory name)))
;; (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
+(defun ange-ftp-vms-sans-version (name &rest args)
+ (save-match-data
(if (string-match ";[0-9]+$" name)
(substring name 0 (match-beginning 0))
name)))
;; 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
+ (save-match-data
(if reverse
(if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name)
(let (acct file)
;; Return non-nil if HOST is running MTS.
(defun ange-ftp-mts-host (host)
(and ange-ftp-mts-host-regexp
- (ange-ftp-save-match-data
+ (save-match-data
(string-match ange-ftp-mts-host-regexp host))))
;; Parse the current buffer which is assumed to be in mts ftp dir format.
(defun ange-ftp-parse-mts-listing ()
(let ((tbl (ange-ftp-make-hashtable)))
(goto-char (point-min))
- (ange-ftp-save-match-data
+ (save-match-data
(while (re-search-forward ange-ftp-date-regexp nil t)
(end-of-line)
(skip-chars-backward " ")
;;;; ------------------------------------------------------------
;; 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 is dangerous
+;; 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-name-for-cms (name &optional reverse)
- (ange-ftp-save-match-data
+ (save-match-data
(if reverse
;; Since we only convert output from a pwd in this direction,
;; we'll assume that it's a minidisk, and make it into a
;; Return non-nil if HOST is running CMS.
(defun ange-ftp-cms-host (host)
(and ange-ftp-cms-host-regexp
- (ange-ftp-save-match-data
+ (save-match-data
(string-match ange-ftp-cms-host-regexp host))))
(defun ange-ftp-add-cms-host (host)
;; Now do the usual parsing
(let ((tbl (ange-ftp-make-hashtable)))
(goto-char (point-min))
- (ange-ftp-save-match-data
+ (save-match-data
(while
(re-search-forward
"^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t)