[gnu.emacs] 'ange-ftp' -- ftp support for GNU Emacs
Andy Norman
ange at HPLB.HPL.HP.COM
Tue Oct 9 00:47:23 AEST 1990
Archive-name: ange-ftp/08-Oct-90
Original-posting-by: ange at HPLB.HPL.HP.COM (Andy Norman)
Original-subject: 'ange-ftp' -- ftp support for GNU Emacs
Reposted-by: emv at math.lsa.umich.edu (Edward Vielmetti)
[Reposted from gnu.emacs.
Comments on this service to emv at math.lsa.umich.edu (Edward Vielmetti).]
Some time ago I posted 'ange-ftp.el' -- a package which extended many of GNU
Emacs' file-handling routines to cope with (Unix) files and directories
available via ftp.
At the end of this posting I include the latest version of ange-ftp.el. To
use, just byte-compile then load. Once loaded, filenames that look like:
/user at host:/path
will be handled by ange-ftp as an ftp connection to machine 'host', logged in
as user 'user' and dealing with pathname 'path'. The 'user@' can be omitted
and a suitable default generated.
If the machine running GNU Emacs can't ftp, or can only ftp to a restricted
number of hosts, then a 'gateway' machine may be used instead as long as there
is a shared filesystem between the 2 machines.
If there are any problems, please e-mail me directly.
Enjoy...
-- ange --
ange at hplb.hpl.hp.com
--------------------------------------------------------------------------------
;; -*-Emacs-Lisp-*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; File: ange-ftp.el
;; RCS: $Header: ange-ftp.el,v 3.31 90/10/08 10:18:15 ange Exp $
;; Description: simple ftp access to files from GNU Emacs
;; Author: Andy Norman, ange at hplb.hpl.hp.com
;; Created: Thu Oct 12 14:00:05 1989
;; Modified: Mon Oct 8 10:16:29 1990 (Ange) ange at anorman
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (C) 1990 Andy Norman.
;;;
;;; Author: Andy Norman (ange at hplb.hpl.hp.com)
;;;
;;; 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)
;;; any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; A copy of the GNU General Public License can be obtained from this
;;; program's author (send electronic mail to ange at hplb.hpl.hp.com) or from
;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
;;; 02139, USA.
;;; This package attempts to make accessing files / directories using ftp from
;;; within GNU Emacs as simple as possible. A subset of the normal
;;; file-handling routines are extended to understand ftp.
;;;
;;; To read or write a file using ftp, or to read a directory using ftp, the
;;; only thing that a user needs to do is to specify the filename using a
;;; slighly extended syntax.
;;;
;;; The default syntax of ftp files is /user at host:path. This is customizable.
;;; See the variable ange-ftp-path-format for more details.
;;;
;;; 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.
;;;
;;; Ftp processes are left running for speed. They can easily be killed by
;;; killing their associated buffers.
;;;
;;; Full file name completion is supported on remote files.
;;;
;;; File transfers can be done in binary mode. See the documentation for the
;;; variable ange-ftp-binary-file-name-regexp for more details.
;;;
;;; The ftp process can be either be run locally, or run on a different machine.
;;; Sometimes this is neccessary when the local machine does not have full internet
;;; access. See the documentation for the variables ange-ftp-gateway-host,
;;; ange-ftp-local-host-regexp, ange-ftp-gateway-tmp-name-template,
;;; ange-ftp-gateway-program and ange-ftp-gateway-program-interactive for more
;;; details.
;;;
;;; WARNING, the following GNU Emacs functions are replaced by this program:
;;;
;;; write-region
;;; insert-file-contents
;;; dired-readin
;;; 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-attributes
;;; copy-file
;;;
;;; If you find any bugs or problems with this package, please e-mail the above
;;; author. Constructive comments are especially welcome.
;;;
;;; Many thanks to Roland McGrath <roland at ai.mit.edu> for improving the filename
;;; syntax handling, for suggesting many enhancements and for numerous cleanups
;;; to the code.
;;;
;;; Thanks also to Jamie Zawinski <jwz at lucid.com> for bugfixes and for ideas
;;; such as gateways.
;;;
;;;; ------------------------------------------------------------
;;;; User customization variables.
;;;; ------------------------------------------------------------
(defvar ange-ftp-path-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
parenthesized expressions in REGEXP for the components (in that order).")
(defvar ange-ftp-good-msgs
"^220 \\|^230 \\|^226 \\|^25. \\|^221 \\|^200 "
"*Regular expression matching messages from the ftp process that indicate
that the action that was initiated has completed successfully.")
(defvar ange-ftp-skip-msgs
(concat "^200 PORT \\|^331 \\|^2.0-\\|^150 \\|^[0-9]+ bytes \\|"
"^Connected \\|^$\\|^Remote system\\|^Using\\|^ ")
"*Regular expression matching messages from the ftp process that can be
ignored.")
(defvar ange-ftp-fatal-msgs "^ftp: \\|^Not connected\\|^530 \\|^421 \\|rcmd: "
"*Regular expression matching messages from the ftp process that indicate
something has gone drastically wrong attempting the action that was
initiated.")
(defvar ange-ftp-ls-follow-symbolic-links t
"*If non-nil, tell ls to always follow symbolic links.")
(defvar ange-ftp-tmp-name-template "/tmp/ange-ftp"
"*Template given to make-temp-name to create temporary files.")
(defvar ange-ftp-gateway-tmp-name-template "/tmp/ange-ftp"
"*Template given to make-temp-name to create temporary files when
ftp-ing through a gateway. Files starting with this prefix need to
be accessible from BOTH the local machine and the gateway machine,
and need to have the SAME name on both machines, that is, /tmp is probably
NOT what you want, since that is rarely cross-mounted.")
(defvar ange-ftp-copy-tmp-name-template "/tmp/ange-ftp-copy"
"*Template given to make-temp-name to to create temporary files when
copying files between one remote machine and another.
This should be different from \`ange-ftp-tmp-name-template\' and
\'ange-ftp-gateway-tmp-name-template\'.")
(defvar ange-ftp-netrc-filename "~/.netrc"
"*File in .netrc format to search for passwords.")
(defvar ange-ftp-default-user nil
"*User name to use when none is specied in a pathname.
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-generate-anonymous-password nil
"*If non-nil, by default use a password of user at host when logging
in as the anonymous user.")
(defvar ange-ftp-dumb-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.")
(defvar ange-ftp-binary-file-name-regexp
"\\.Z$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|\\.dvi$\\|\\.ps$"
"*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.")
(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 remsh (rsh 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.")
(defvar ange-ftp-gateway-setup-term-command "stty -onlcr -echo\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.")
;;;; ------------------------------------------------------------
;;;; Hash table support.
;;;; ------------------------------------------------------------
(defun ange-ftp-make-hashtable (&optional size)
"Make an obarray suitable for use as a hashtable.
SIZE, if supplied, should be a prime number."
(make-vector (or size 511) 0))
(defun ange-ftp-map-hashtable (fun tbl)
"Call FUNCTION on each key in HASHTABLE."
(mapatoms
(function
(lambda (sym)
(and (get sym 'active)
(funcall fun (get sym 'key)))))
tbl))
(defmacro ange-ftp-make-hash-key (key)
"Convert KEY into a suitable key for a hashtable."
(` (if (stringp (, key))
(, key)
(prin1-to-string (, key)))))
(defun ange-ftp-get-hash-entry (key tbl)
"Return the value associated with KEY in HASHTABLE."
(let ((sym (intern-soft (ange-ftp-make-hash-key key) tbl)))
(and sym
(get sym 'active)
(get sym 'val))))
(defun ange-ftp-put-hash-entry (key val tbl)
"Record an association between KEY and VALUE in HASHTABLE."
(let ((sym (intern (ange-ftp-make-hash-key key) tbl)))
(put sym 'val val)
(put sym 'key key)
(put sym 'active t)))
(defun ange-ftp-del-hash-entry (key tbl)
"Delete KEY from HASHTABLE."
(let ((sym (intern-soft (ange-ftp-make-hash-key key) tbl)))
(and sym (put sym 'active nil))))
(defun ange-ftp-hash-entry-exists-p (key tbl)
"Return whether there is an association for KEY in TABLE."
(let ((sym (intern-soft (ange-ftp-make-hash-key key) tbl)))
(and sym (get sym 'active))))
(defun ange-ftp-hash-table-keys (tbl)
"Return a sorted list of all the active keys in the hashtable, as strings."
(sort (all-completions ""
tbl
(function (lambda (x) (get x 'active))))
(function string-lessp)))
;;;; ------------------------------------------------------------
;;;; Internal variables.
;;;; ------------------------------------------------------------
(defvar ange-ftp-data-buffer-name "*ftp data*"
"Buffer name to hold data received from ftp process.")
(defvar ange-ftp-process-string ""
"Currently unprocessed output from the ftp process.")
(defvar ange-ftp-process-running nil
"Boolean indicates whether the ftp process is currently handling
an action.")
(defvar ange-ftp-process-status nil
"Set to t if an action sent to the ftp process succeeds.")
(defvar ange-ftp-have-read-netrc nil
"Boolean indicating whether the user's .netrc file has been read yet.")
(defvar ange-ftp-user-hashtable (ange-ftp-make-hashtable)
"Hash table holding associations between HOST, USER pairs.")
(defvar ange-ftp-passwd-hashtable (ange-ftp-make-hashtable)
"Mapping between a HOST, USER pair and a PASSWORD for it.")
(defvar ange-ftp-files-hashtable (ange-ftp-make-hashtable)
"Hash table for storing directories and their respective files.")
;;;; ------------------------------------------------------------
;;;; Password support.
;;;; ------------------------------------------------------------
(defun ange-ftp-read-passwd (prompt)
"Read a password from the user. Echos a . for each character typed.
End with RET, LFD, or ESC. DEL or C-h rubs out."
(let ((pass "")
(c 0)
(echo-keystrokes 0)
(cursor-in-echo-area t))
(while (and (/= c ?\r) (/= c ?\n) (/= c ?\e))
(message "%s%s"
prompt
(make-string (length pass) ?.))
(setq c (read-char))
(if (and (/= c ?\b) (/= c ?\177))
(setq pass (concat pass (char-to-string c)))
(if (> (length pass) 0)
(setq pass (substring pass 0 -1)))))
(substring pass 0 -1)))
(defun ange-ftp-set-user (host user)
"For a given HOST, set or change the default USER."
(interactive "sHost: \nsUser: ")
(ange-ftp-put-hash-entry host user ange-ftp-user-hashtable))
(defun ange-ftp-get-user (host)
"Given a HOST, return the default USER."
(or ange-ftp-have-read-netrc (ange-ftp-parse-netrc))
(let ((user (ange-ftp-get-hash-entry host ange-ftp-user-hashtable)))
(or user
(cond ((stringp ange-ftp-default-user)
;; We have a default name. Use it.
ange-ftp-default-user)
(ange-ftp-default-user
;; Ask the user and remember the response.
(let ((user (read-string (format "User for %s: " host)
(user-login-name))))
(ange-ftp-set-user host user)
user))
;; Default to the user's login name.
(t (user-login-name))))))
(defun ange-ftp-set-passwd (host user passwd)
"For a given HOST and USER, set or change the associated PASSWD."
(interactive (list (read-string "Host: ")
(read-string "User: ")
(ange-ftp-read-passwd "Password: ")))
(ange-ftp-put-hash-entry (concat host "/" user)
passwd
ange-ftp-passwd-hashtable))
(defun ange-ftp-get-passwd (host user)
"Given a HOST and USER, return the ftp password,
prompting if it was not previously set."
(or ange-ftp-have-read-netrc (ange-ftp-parse-netrc))
(let ((passwd (ange-ftp-get-hash-entry (concat host "/" user)
ange-ftp-passwd-hashtable)))
(or passwd
(and ange-ftp-generate-anonymous-password
(string-equal user "anonymous")
(concat (user-login-name) "@" (system-name)))
(let ((passwd (ange-ftp-read-passwd
(format "Password for %s@%s: " user host))))
(ange-ftp-set-passwd host user passwd)
passwd))))
;;;; ------------------------------------------------------------
;;;; ~/.netrc support
;;;; ------------------------------------------------------------
(defun ange-ftp-parse-field (field limit)
"Move along current line looking for the value of the FIELD. Valid
separators between FIELD and its value are commas and whitespace.
Second arg LIMIT is a limit for the search."
(if (search-forward field limit t)
(let (beg)
(skip-chars-forward ", \t" limit)
(if (looking-at "\"") ;quoted field value
(progn (forward-char 1)
(setq beg (point))
(skip-chars-forward "^\"" limit)
(forward-char 1)
(buffer-substring beg (1- (point))))
(setq beg (point))
(skip-chars-forward "^, \t" limit)
(buffer-substring beg (point))))))
(defun ange-ftp-parse-line ()
"Extract the values of the fields \`machine\', \`login\' and \`password\'
from the current line of the buffer. If successful, call ange-ftp-set-passwd
with the values found."
(let ((eol (progn (end-of-line) (point)))
machine login password)
(beginning-of-line)
(setq machine (ange-ftp-parse-field "machine" eol)
login (ange-ftp-parse-field "login" eol)
password (ange-ftp-parse-field "password" eol))
(and machine login
(progn
(ange-ftp-set-user machine login)
(ange-ftp-set-passwd machine login password)))))
(defun ange-ftp-parse-netrc ()
"If ~/.netrc file exists and has the correct security then extract the
\`machine\', \`login\' and \`password\' information from each line."
;; We set this before actually doing it to avoid the possibility
;; of an infinite loop if ange-ftp-netrc-filename is an ftp file.
(setq ange-ftp-have-read-netrc t)
(let* ((file (expand-file-name ange-ftp-netrc-filename))
(attr (file-attributes file)))
(if attr ; File exits.
(if (and (eq (nth 2 attr) (user-uid)) ; Same uids.
(string-match ".r..------" (nth 8 attr))) ; Readable by user only.
(progn
(set-buffer (generate-new-buffer "*ftp-.netrc*"))
(insert-file-contents file)
(goto-char (point-min))
(while (not (eobp))
(ange-ftp-parse-line)
(forward-line 1))
(kill-buffer (current-buffer)))
(message "skipping badly configured .netrc file")))))
;;;; ------------------------------------------------------------
;;;; Miscellaneous utils.
;;;; ------------------------------------------------------------
(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 "*"))
(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
(get-buffer-create
(ange-ftp-ftp-process-buffer host user)))
(goto-char (point-max))
(select-window cur))
(error "ange-ftp: %s" msg))
(defun ange-ftp-set-buffer-mode ()
"Set the correct modes for the current buffer if it is visiting a remote
file."
(if (ange-ftp-ftp-path buffer-file-name)
(progn
(auto-save-mode 0)
(make-variable-buffer-local 'revert-buffer-function)
(setq revert-buffer-function 'ange-ftp-revert-buffer))))
(defun ange-ftp-kill-ftp-process (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))))
(if parsed
(let ((host (nth 0 parsed))
(user (nth 1 parsed)))
(kill-buffer (ange-ftp-ftp-process-buffer host user))))))))
;;;; ------------------------------------------------------------
;;;; FTP process filter support.
;;;; ------------------------------------------------------------
(defun ange-ftp-process-handle-line (line)
"Look at the given LINE from the ftp process. Try to catagorize it
into one of four categories: good, skip, fatal, or unknown."
(cond ((string-match ange-ftp-skip-msgs line)
t)
((string-match ange-ftp-good-msgs line)
(setq ange-ftp-process-running nil
ange-ftp-process-status t))
((string-match ange-ftp-fatal-msgs line)
(delete-process proc)
(setq ange-ftp-process-running nil))
(t
(setq ange-ftp-process-running nil))))
(defun ange-ftp-process-log-string (proc str)
"For a given PROCESS, log the given STRING at the end of its
associated buffer."
(save-excursion
(set-buffer (process-buffer proc))
(goto-char (point-max))
(insert str)))
(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."
(setq ange-ftp-process-string (concat ange-ftp-process-string str))
(ange-ftp-process-log-string proc str)
(while (and ange-ftp-process-running
(string-match "\n" ange-ftp-process-string))
(let ((line (substring ange-ftp-process-string 0 (match-beginning 0))))
(setq ange-ftp-process-string (substring ange-ftp-process-string
(match-end 0)))
(while (string-match "^ftp> " line)
(setq line (substring line (match-end 0))))
(ange-ftp-process-handle-line line))))
(defun ange-ftp-process-sentinel (proc str)
"When ftp process changes state, nuke all file-entries in cache."
(let ((name (process-name proc)))
(if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)*" name)
(let ((user (substring name (match-beginning 1) (match-end 1)))
(host (substring name (match-beginning 2) (match-end 2))))
(ange-ftp-wipe-file-entries host user)))))
;;;; ------------------------------------------------------------
;;;; Gateway support.
;;;; ------------------------------------------------------------
(defun ange-ftp-use-gateway-p (host)
(not (string-match ange-ftp-local-host-regexp host)))
(defun ange-ftp-make-tmp-name (host)
(make-temp-name (if (ange-ftp-use-gateway-p host)
ange-ftp-gateway-tmp-name-template
ange-ftp-tmp-name-template)))
;;;; ------------------------------------------------------------
;;;; Interactive gateway program support.
;;;; ------------------------------------------------------------
(defvar ange-ftp-gwp-running t)
(defvar ange-ftp-gwp-status nil)
(defun ange-ftp-gwp-sentinel (proc str)
(setq ange-ftp-gwp-running nil))
(defun ange-ftp-gwp-filter (proc str)
(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 "Connection closed\\|No such host" 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))
(ftp (mapconcat (function (lambda (x) x)) args " ")))
(process-kill-without-query proc)
(set-process-sentinel proc (function ange-ftp-gwp-sentinel))
(set-process-filter proc (function ange-ftp-gwp-filter))
(setq ange-ftp-gwp-running t
ange-ftp-gwp-status nil)
(message "Connecting to gateway %s..." ange-ftp-gateway-host)
(while ange-ftp-gwp-running ;perform login sequence
(accept-process-output proc))
(if (not ange-ftp-gwp-status)
(ange-ftp-error host user "unable to login to gateway"))
(message "Connecting to gateway %s...done" ange-ftp-gateway-host)
(setq ange-ftp-gwp-running t
ange-ftp-gwp-status nil)
(process-send-string proc ange-ftp-gateway-setup-term-command)
(while ange-ftp-gwp-running ;zap ^M's and double echoing.
(accept-process-output proc))
(if (not ange-ftp-gwp-status)
(ange-ftp-error host user "unable to set terminal modes on gateway"))
(setq ange-ftp-gwp-running t
ange-ftp-gwp-status nil)
(process-send-string proc (concat "exec " ftp "\n")) ;spawn ftp process
proc))
;;;; ------------------------------------------------------------
;;;; Support for sending commands to the ftp process.
;;;; ------------------------------------------------------------
(defun ange-ftp-raw-send-cmd (proc cmd)
"Low-level routine to send the given ftp CMD to the ftp PROCESS.
Returns non-nil if successful."
(if (eq (process-status proc) 'run)
(save-excursion
(setq ange-ftp-process-string ""
ange-ftp-process-running t
ange-ftp-process-status nil)
(send-string proc (concat cmd "\n"))
(while ange-ftp-process-running
(accept-process-output proc))
ange-ftp-process-status)))
(defun ange-ftp-start-process (host user name)
"Spawn a new ftp process ready to connect to machine HOST and give it NAME.
If HOST is only ftp-able through a gateway machine then spawn a shell
on the gateway machine to do the ftp instead."
(let ((args '("ftp" "-i" "-n" "-g" "-v"))
proc)
(if (ange-ftp-use-gateway-p host)
(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)
(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-get-process (host user)
"Return the process object for a ftp process connected to HOST and
logged in as USER. Create a new proces if needed."
(let* ((name (ange-ftp-ftp-process-buffer host user))
(proc (get-process name)))
(if (and proc (eq (process-status proc) 'run))
proc
(let ((pass (ange-ftp-get-passwd host user)))
(setq proc (ange-ftp-start-process host user name))
(message "Opening FTP connection to %s..." host)
(or (ange-ftp-raw-send-cmd proc (format "open %s" host))
(ange-ftp-error host user "OPEN request failed"))
(message "Logging in as user %s@%s..." user host)
(or (ange-ftp-raw-send-cmd proc (format "user \"%s\" \"%s\"" user pass))
(progn
(ange-ftp-set-passwd host user nil) ;reset password.
(ange-ftp-error host user "USER request failed")))
(message "Logging in as user %s@%s...done" user host)
proc))))
(defun ange-ftp-send-cmd (host user cmd)
"Find an ftp process connected to HOST logged in as USER and send it CMD.
Returns whether successful."
(let ((proc (ange-ftp-get-process host user)))
(or (ange-ftp-raw-send-cmd proc cmd)
;; Failed, try once more.
(and (setq proc (ange-ftp-get-process host user))
(ange-ftp-raw-send-cmd proc cmd)))))
;;;; ------------------------------------------------------------
;;;; Remote pathname syntax support.
;;;; ------------------------------------------------------------
(defmacro ange-ftp-ftp-path-component (n)
"Extract the Nth ftp path component."
(` (let ((elt (nth (, n) ns)))
(substring path (match-beginning elt) (match-end elt)))))
(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-match (car ange-ftp-path-format) path)
(let* ((ns (cdr ange-ftp-path-format))
(host (ange-ftp-ftp-path-component 0))
(user (ange-ftp-ftp-path-component 1))
(path (ange-ftp-ftp-path-component 2)))
(if (zerop (length user))
(setq user (ange-ftp-get-user host)))
(if (zerop (length path))
(setq path "/"))
(list host user path))
nil))
;;;; ------------------------------------------------------------
;;;; Remote file and directory listing support.
;;;; ------------------------------------------------------------
(defun ange-ftp-dumb-host (host)
"Returns whether HOST's ftp daemon doesn't like \'ls\' or \'dir\' commands
to take switch arguments."
(and ange-ftp-dumb-host-regexp
(string-match ange-ftp-dumb-host-regexp host)))
(defun ange-ftp-ls (file lsargs &optional want-buffer)
"Return the output of an `ls' command done on a remote machine using ftp.
The first argument FILE is the full name of the remote file, the second arg
LSARGS is any args to pass to the `ls' command, and the optional third arg
WANT-BUFFER indicates that a buffer object should be returned rather than
a string object."
(let ((parsed (ange-ftp-ftp-path file)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
(path (nth 2 parsed))
(temp (ange-ftp-make-tmp-name host))
lscmd)
(if (ange-ftp-dumb-host host)
(setq lscmd (concat "dir " path " " temp))
(if ange-ftp-ls-follow-symbolic-links
(if (> (length lsargs) 0)
(setq lsargs (concat lsargs "L"))
(setq lsargs "-L")))
(setq lscmd (format "ls \"%s %s\" %s" lsargs path temp)))
(message "Listing %s..." file)
(if (ange-ftp-send-cmd host user lscmd)
(let (data)
(save-excursion
(set-buffer (get-buffer-create ange-ftp-data-buffer-name))
(erase-buffer)
(if (file-readable-p temp)
(insert-file-contents temp)
(ange-ftp-error host user
(format "list data file %s not readable"
temp)))
;; (ange-ftp-process-log-string ;debugging
;; (ange-ftp-get-process host user)
;; (buffer-substring (point-min) (point-max)))
(if want-buffer
(setq data (current-buffer))
(setq data (buffer-substring (point-min) (point-max)))
(kill-buffer (current-buffer)))
(condition-case () (delete-file temp) (error nil)))
(message "Listing %s...done" file)
data)
(ange-ftp-error host user "Unable to get a remote ls"))))))
;;;; ------------------------------------------------------------
;;;; Directory information caching support.
;;;; ------------------------------------------------------------
(defun ange-ftp-parse-filename ()
"Extract the filename from the current line of a dired-like listing."
(save-excursion
(let ((eol (progn (end-of-line) (point))))
(beginning-of-line)
(if (re-search-forward
"\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+"
eol t)
(progn (skip-chars-forward " ")
(skip-chars-forward "^ " eol)
(skip-chars-forward " " eol)
(let ((beg (point)))
(skip-chars-forward "^ \n")
;; (skip-chars-backward "*/@")
(buffer-substring beg (point))))))))
(defun ange-ftp-parse-dired-listing ()
"Parse the current buffer which is assumed to be in a dired-like listing
format, and return a hashtable as the result."
(let ((tbl (ange-ftp-make-hashtable)))
(goto-char (point-min))
(if (looking-at "[\t ]*total")
(progn
(forward-line 1) ;Skip over total byte count.
(let (file)
(while (setq file (ange-ftp-parse-filename))
(beginning-of-line)
;; (skip-chars-forward "\t 0-9")
(ange-ftp-put-hash-entry file (looking-at "d") tbl)
(forward-line 1)))
(ange-ftp-put-hash-entry "." t tbl)
(ange-ftp-put-hash-entry ".." t tbl)))
tbl))
(defun ange-ftp-set-files (directory files)
"For a given DIRECTORY, set or change the associated FILES hashtable."
(ange-ftp-put-hash-entry directory files ange-ftp-files-hashtable))
(defun ange-ftp-get-files (directory)
"Given a given DIRECTORY, return a hashtable of file entries."
(setq directory (file-name-as-directory directory)) ;normalize
(let ((files (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable)))
(or files
(save-excursion
(set-buffer (ange-ftp-ls directory "-al" t))
(let ((files (ange-ftp-parse-dired-listing)))
(ange-ftp-put-hash-entry directory
files
ange-ftp-files-hashtable)
(kill-buffer (current-buffer))
files)))))
(defun ange-ftp-parse-path (path)
"Break apart PATH into its directory and file parts."
(let ((directory (file-name-directory path))
(file (file-name-nondirectory path)))
(if (equal directory "/") ;file name syntax kludge
(progn
(setq directory (file-name-as-directory path))
(setq file "."))
(if (equal file "") ;kludge #2
(setq file ".")))
(cons directory file)))
(defun ange-ftp-get-file-entry (path)
"Given PATH, return whether the given file entry. At the moment
this returns whether PATH is a directory or not."
(let* ((parsed (ange-ftp-parse-path path))
(directory (car parsed))
(file (cdr parsed)))
(ange-ftp-get-hash-entry file (ange-ftp-get-files directory))))
(defun ange-ftp-file-entry-p (path)
"Given PATH, return whether there is a file entry for it."
(let* ((parsed (ange-ftp-parse-path path))
(directory (car parsed))
(file (cdr parsed)))
(ange-ftp-hash-entry-exists-p file (ange-ftp-get-files directory))))
(defun ange-ftp-delete-file-entry (path)
"Given a PATH, delete the file entry for it, if it exists."
(let* ((parsed (ange-ftp-parse-path path))
(directory (car parsed))
(file (cdr parsed))
(files (ange-ftp-get-hash-entry directory
ange-ftp-files-hashtable)))
(if files
(ange-ftp-del-hash-entry file files))))
(defun ange-ftp-add-file-entry (path &optional dir-p)
"Given a PATH, add the file entry for it, if its directory info exists."
(let* ((parsed (ange-ftp-parse-path path))
(directory (car parsed))
(file (cdr parsed))
(files (ange-ftp-get-hash-entry directory
ange-ftp-files-hashtable)))
(if files
(ange-ftp-put-hash-entry file dir-p files))))
(defun ange-ftp-wipe-file-entries (host user)
"Remove all file entry information for the given HOST, USER pair."
(ange-ftp-map-hashtable
(function
(lambda (key)
(let ((parsed (ange-ftp-ftp-path key)))
(if parsed
(let ((h (nth 0 parsed))
(u (nth 1 parsed)))
(if (and (equal host h) (equal user u))
(ange-ftp-del-hash-entry key
ange-ftp-files-hashtable)))))))
ange-ftp-files-hashtable))
;;;; ------------------------------------------------------------
;;;; File transfer mode support.
;;;; ------------------------------------------------------------
(defun ange-ftp-set-binary-mode (host user)
"Tell the ftp process for the given HOST & USER to switch to binary mode."
(ange-ftp-send-cmd host user "binary"))
(defun ange-ftp-set-ascii-mode (host user)
"Tell the ftp process for the given HOST & USER to switch to ascii mode."
(ange-ftp-send-cmd host user "ascii"))
;;;; ------------------------------------------------------------
;;;; Redefinitions of standard GNU Emacs functions.
;;;; ------------------------------------------------------------
(defun ange-ftp-binary-file (file)
"Returns whether the given FILE is to be considered as a binary file for
ftp transfers."
(string-match ange-ftp-binary-file-name-regexp file))
(defun ange-ftp-write-region (start end filename &optional append visit)
"Write current region into specified file.
When called from a program, takes three arguments:
START, END and FILENAME. START and END are buffer positions.
Optional fourth argument APPEND if non-nil means
append to existing file contents (if any).
Optional fifth argument VISIT if t means
set last-save-file-modtime of buffer to this file's modtime
and mark buffer not modified.
If VISIT is neither t nor nil, it means do not print
the \"Wrote file\" message.
Note that this function has been extended to deal with remote files using ftp."
(interactive "r\nFWrite region to file: ")
(setq filename (expand-file-name filename))
(let ((parsed (ange-ftp-ftp-path filename)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
(path (nth 2 parsed))
(temp (ange-ftp-make-tmp-name host))
(binary (ange-ftp-binary-file filename))
(cmd (if append "append" "put")))
(ange-ftp-real-write-region start end temp nil 'nomsg)
(message "Writing %s..." filename)
(unwind-protect
(progn
(if binary
(ange-ftp-set-binary-mode host user))
(or (ange-ftp-send-cmd host user
(format "%s %s %s" cmd temp path))
(signal 'file-error
(list
"Opening output file"
(format "Unable to %s remote file" (upcase cmd))
filename))))
(delete-file temp)
(if binary
(ange-ftp-set-ascii-mode host user)))
(if (eq visit t)
(progn
(ange-ftp-set-buffer-mode)
(setq buffer-file-name filename)
(set-buffer-modified-p nil)))
(message "Wrote %s" filename)
(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)
"Insert contents of file FILENAME after point.
Returns list of absolute pathname and length of data inserted.
If second argument VISIT is non-nil, the buffer's visited filename
and last save file modtime are set, and it is marked unmodified.
If visiting and the file does not exist, visiting is completed
before the error is signaled.
Note this function has been extended to deal with remote files using ftp."
(barf-if-buffer-read-only)
(setq filename (expand-file-name filename))
(let ((parsed (ange-ftp-ftp-path filename)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
(path (nth 2 parsed))
(temp (ange-ftp-make-tmp-name host))
(binary (ange-ftp-binary-file filename))
result)
(if visit
(setq buffer-file-name filename))
(unwind-protect
(progn
(if binary
(ange-ftp-set-binary-mode host user))
(message "Retrieving %s..." filename)
(or (ange-ftp-send-cmd host user
(format "get %s %s" path temp))
(signal 'file-error
(list
"Opening input file"
"Unable to GET remote file"
filename)))
(setq result (ange-ftp-real-insert-file-contents temp visit))
(message "Retrieving %s...done" filename))
(condition-case () (delete-file temp) (error nil))
(if binary
(ange-ftp-set-ascii-mode host user)))
(if visit
(setq buffer-file-name filename))
result)
(ange-ftp-real-insert-file-contents filename visit))))
(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-file-exists-p (file)
"Return t if FILE exists."
(setq file (expand-file-name file))
(if (ange-ftp-ftp-path file)
(ange-ftp-file-entry-p file)
(ange-ftp-real-file-exists-p file)))
(defun ange-ftp-file-directory-p (file)
"Return t if FILENAME is the name of a directory as a file.
A directory name spec may be given instead; then the value is t
if the directory so specified exists and really is a directory.
Note that this function has been extended to deal with remote files using ftp."
(setq file (expand-file-name file))
(if (ange-ftp-ftp-path file)
(ange-ftp-get-file-entry file)
(ange-ftp-real-file-directory-p file)))
(defun ange-ftp-directory-files (directory &optional full match)
"Return a list of names of files in DIRECTORY.
If FULL is non-NIL, absolute pathnames of the files are returned.
If MATCH is non-NIL, only pathnames containing that regexp are returned.
Note that this function has been extended to deal with remote files using ftp."
(setq directory (expand-file-name directory))
(if (ange-ftp-ftp-path directory)
(let (files)
(setq directory (file-name-as-directory directory))
(mapcar (function
(lambda (f)
(if full
(setq f (concat directory f)))
(if match
(if (string-match match f)
(setq files (cons f files)))
(setq files (cons f files)))))
(ange-ftp-hash-table-keys (ange-ftp-get-files directory)))
(nreverse files))
(ange-ftp-real-directory-files directory full match)))
(defun ange-ftp-file-attributes (file)
"Return a list of attributes of file FILENAME.
Value is nil if specified file cannot be opened.
Otherwise, list elements are:
0. t for directory, string (name linked to) for symbolic link, or nil.
1. Number of links to file.
2. File uid.
3. File gid.
4. Last access time, as a list of two integers.
First integer has high-order 16 bits of time, second has low 16 bits.
5. Last modification time, likewise.
6. Last status change time, likewise.
7. Size in bytes.
8. File modes, as a string of ten letters or dashes as in ls -l.
9. t iff file's gid would change if file were deleted and recreated.
10. inode number.
Note that this function has been extended to deal with remote files using ftp."
(setq file (expand-file-name file))
(if (ange-ftp-ftp-path file)
(if (ange-ftp-file-entry-p file)
(list (ange-ftp-get-file-entry file) ;0
nil ;1
nil ;2
nil ;3
nil ;4
nil ;5
nil ;6
nil ;7
nil ;8
nil ;9
nil ;10
))
(ange-ftp-real-file-attributes file)))
(defun ange-ftp-file-writable-p (file)
"Return t if file FILENAME can be written or created by you.
Note that this function has been extended to deal with remote files using ftp."
(setq file (expand-file-name file))
(or (ange-ftp-ftp-path file)
(ange-ftp-real-file-writable-p file)))
(defun ange-ftp-file-readable-p (file)
"Return t if file FILENAME exists and can be read by you.
Note that this function has been extended to deal with remote files using ftp."
(setq file (expand-file-name file))
(or (ange-ftp-ftp-path file)
(ange-ftp-real-file-readable-p file)))
(defun ange-ftp-delete-file (file)
"Delete specified file. One argument, a file name string.
If file has multiple names, it continues to exist with the other names.
Note that this function has been extended to deal with remote files using ftp."
(interactive "fDelete file: ")
(setq file (expand-file-name file))
(let ((parsed (ange-ftp-ftp-path file)))
(if parsed
(let ((host (nth 0 parsed))
(user (nth 1 parsed))
(path (nth 2 parsed)))
(message "Deleting %s..." file)
(or (ange-ftp-send-cmd host user (concat "delete " path))
(signal 'file-error
(list
"Removing old name"
"Unable to execute remote DELETE command"
path)))
(message "Deleting %s...done" file)
(ange-ftp-delete-file-entry file))
(ange-ftp-real-delete-file file))))
(defun ange-ftp-verify-visited-file-modtime (buf)
"Return t if last mod time of BUF's visited file matches what BUF records.
This means that the file has not been changed since it was visited or saved.
Note that this function has been extended to deal with remote files using ftp."
(let ((name (buffer-file-name buf)))
(if (and (stringp name) (ange-ftp-ftp-path name))
t
(ange-ftp-real-verify-visited-file-modtime buf))))
(defun ange-ftp-backup-buffer ()
"Make a backup of the disk file visited by the current buffer, if appropriate.
This is normally done before saving the buffer the first time.
If the value is non-nil, it is the result of `file-modes' on the original file;
this means that the caller, after saving the buffer, should change the modes
of the new file to agree with the old modes.
Note that this function has been extended to deal with remote files using ftp."
(if (and (stringp buffer-file-name) (ange-ftp-ftp-path buffer-file-name))
nil
(ange-ftp-real-backup-buffer)))
;;;; ------------------------------------------------------------
;;;; File copying support.
;;;; ------------------------------------------------------------
(defun ange-ftp-barf-or-query-if-file-exists (absname querystring interactive)
(if (file-exists-p absname)
(if (not interactive)
(signal 'file-already-exists (list absname))
(if (not (yes-or-no-p (format "File %s already exists; %s anyway? "
absname querystring)))
(signal 'file-already-exists (list absname))))))
(defun ange-ftp-copy-remote-to-local (remote local parsed)
"Copy REMOTE file to LOCAL file, where the former is on a remote machine."
(let ((host (nth 0 parsed))
(user (nth 1 parsed))
(path (nth 2 parsed))
(binary (ange-ftp-binary-file remote))
temp
cmd)
(if (not (ange-ftp-use-gateway-p host))
(setq cmd (format "get %s %s" path local))
(setq temp (ange-ftp-make-tmp-name host))
(setq cmd (format "get %s %s" path temp)))
(unwind-protect
(progn
(if binary
(ange-ftp-set-binary-mode host user))
(message "Copying %s to %s..." remote local)
(or (ange-ftp-send-cmd host user cmd)
(signal 'file-error
(list
"Opening output file"
"Unable to GET remote file"
remote)))
(if temp (copy-file temp local t))
(message "Copying %s to %s...done" remote local))
(if binary
(ange-ftp-set-ascii-mode host user))
(if temp (delete-file temp)))))
(defun ange-ftp-copy-local-to-remote (local remote parsed)
"Copy LOCAL file to REMOTE file where the latter is a file on a remote machine."
(let ((host (nth 0 parsed))
(user (nth 1 parsed))
(path (nth 2 parsed))
(binary (ange-ftp-binary-file local))
temp
cmd)
(if (not (ange-ftp-use-gateway-p host))
(setq cmd (format "put %s %s" local path))
(setq temp (ange-ftp-make-tmp-name host))
(setq cmd (format "put %s %s" temp path)))
(unwind-protect
(progn
(if binary
(ange-ftp-set-binary-mode host user))
(message "Copying %s to %s..." local remote)
(if temp (copy-file local temp t))
(or (ange-ftp-send-cmd host user cmd)
(signal 'file-error
(list
"Opening output file"
"Unable to PUT remote file"
remote)))
(message "Copying %s to %s...done" local remote))
(if binary
(ange-ftp-set-ascii-mode host user))
(if temp (delete-file temp)))
(ange-ftp-add-file-entry remote)))
(defun ange-ftp-copy-remote-to-remote (f-file t-file f-parsed t-parsed)
"Copy F-FILE to T-FILE, where both files are on remote machines."
(let ((temp (make-temp-name ange-ftp-copy-tmp-name-template)))
(unwind-protect
(progn
(ange-ftp-copy-remote-to-local f-file temp f-parsed)
(ange-ftp-copy-local-to-remote temp t-file t-parsed))
(delete-file temp))))
(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists
keep-date)
"Copy FILE to NEWNAME. Both args strings.
Signals a file-already-exists error if NEWNAME already exists,
unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
A number as third arg means request confirmation if NEWNAME already exists.
This is what happens in interactive use with M-x.
Fourth arg non-nil means give the new file the same last-modified time
that the old one has. (This works on only some systems.)
Note this function has been extended to deal with remote files using ftp."
(interactive "fCopy file: \nFCopy %s to file: \np")
(setq filename (expand-file-name filename)
newname (expand-file-name newname))
(let ((f-parsed (ange-ftp-ftp-path filename))
(t-parsed (ange-ftp-ftp-path newname)))
(if (and (or f-parsed t-parsed)
(or (not ok-if-already-exists)
(numberp ok-if-already-exists)))
(ange-ftp-barf-or-query-if-file-exists newname "copy to it"
(numberp ok-if-already-exists)))
(if f-parsed
(if t-parsed
(ange-ftp-copy-remote-to-remote filename newname f-parsed t-parsed)
(ange-ftp-copy-remote-to-local filename newname f-parsed))
(if t-parsed
(ange-ftp-copy-local-to-remote filename newname t-parsed)
(ange-ftp-real-copy-file filename newname ok-if-already-exists keep-date)))))
;;;; ------------------------------------------------------------
;;;; Simple Dired support.
;;;; ------------------------------------------------------------
(require 'dired)
(defun ange-ftp-dired-readin (dirname buffer)
"Emulation of dired-readin with support for remote files using ftp."
(save-excursion
(message "Reading directory %s..." dirname)
(set-buffer buffer)
(let ((buffer-read-only nil))
(widen)
(erase-buffer)
(setq dirname (expand-file-name dirname))
(if (ange-ftp-ftp-path dirname)
(progn (insert (ange-ftp-ls dirname dired-listing-switches))
(ange-ftp-set-files dirname (ange-ftp-parse-dired-listing)))
(if (file-directory-p dirname)
(call-process "ls" nil buffer nil
dired-listing-switches dirname)
(let ((default-directory (file-name-directory dirname)))
(call-process shell-file-name nil buffer nil
"-c" (concat "ls " dired-listing-switches " "
(file-name-nondirectory dirname))))))
(goto-char (point-min))
(while (not (eobp))
(insert " ")
(forward-line 1))
(goto-char (point-min))))
(message "Reading directory %s...done" dirname))
;;;; ------------------------------------------------------------
;;;; File name completion support.
;;;; ------------------------------------------------------------
(defun ange-ftp-file-name-all-completions (file dir)
"Return a list of all completions of file name FILE in directory DIR."
(if (ange-ftp-ftp-path dir)
(all-completions file (ange-ftp-get-files dir)
(function (lambda (sym) (get sym 'active))))
(file-name-all-completions file dir)))
(defun ange-ftp-file-name-completion (file dir)
"Complete file name FILE in directory DIR.
Returns the longest string common to all filenames in DIR that start with FILE.
If there is only one and FILE matches it exactly, returns t.
Returns nil if DIR contains no name starting with FILE."
(if (ange-ftp-ftp-path dir)
(try-completion file (ange-ftp-get-files dir)
(function (lambda (sym) (get sym 'active))))
(file-name-completion file dir)))
(defun ange-ftp-quote-filename (file)
"Quote $ as $$ to get it past substitute-in-file-name."
(let (res)
(mapcar
(function (lambda (char)
(if (= char ?$)
(setq res (cons char res)))
(setq res (cons char res))))
file)
(concat (nreverse res))))
(defun ange-ftp-read-file-name-internal (string dir action)
"Emulates read-file-name-internal for ftp."
(let (name realdir)
(if (eq action 'lambda)
(if (> (length string) 0)
(ange-ftp-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
(ange-ftp-file-name-all-completions name realdir)
(let ((specdir (file-name-directory string))
(val (ange-ftp-file-name-completion name realdir)))
(if (and specdir (stringp val))
(ange-ftp-quote-filename (concat specdir val))
val))))))
;;;; ------------------------------------------------------------
;;;; Bits and bobs to bolt ange-ftp into GNU Emacs.
;;;; ------------------------------------------------------------
(defun ange-ftp-overwrite-fn (fun)
"Replace FUN's function definition with ange-ftp-FUN's, saving the
original definition as ange-ftp-real-FUN."
(let* ((name (symbol-name fun))
(saved (intern (concat "ange-ftp-real-" name)))
(new (intern (concat "ange-ftp-" name))))
(or (fboundp saved)
(fset saved (symbol-function fun)))
(fset fun new)))
(ange-ftp-overwrite-fn 'insert-file-contents)
(ange-ftp-overwrite-fn 'dired-readin)
(ange-ftp-overwrite-fn 'directory-files)
(ange-ftp-overwrite-fn 'file-directory-p)
(ange-ftp-overwrite-fn 'file-writable-p)
(ange-ftp-overwrite-fn 'file-readable-p)
(ange-ftp-overwrite-fn 'delete-file)
(ange-ftp-overwrite-fn 'read-file-name-internal)
(ange-ftp-overwrite-fn 'verify-visited-file-modtime)
(ange-ftp-overwrite-fn 'file-exists-p)
(ange-ftp-overwrite-fn 'write-region)
(ange-ftp-overwrite-fn 'backup-buffer)
(ange-ftp-overwrite-fn 'copy-file)
(ange-ftp-overwrite-fn 'file-attributes)
(or (memq 'ange-ftp-set-buffer-mode find-file-hooks)
(setq find-file-hooks
(cons 'ange-ftp-set-buffer-mode find-file-hooks)))
;;;; ------------------------------------------------------------
;;;; Finally provide package.
;;;; ------------------------------------------------------------
(provide 'ange-ftp)
;;;; ------------------------------------------------------------
;;;; Stuff still to do (volunteers welcome!)
;;;; ------------------------------------------------------------
;;
;; - determine directory type even if parent directory is inaccessible
;; - hostname aliasing
;; - merge in explorer support
;; - write VMS support
;; - background copy
;; - decent documentation
More information about the Alt.sources
mailing list