(require 'comint)
(eval-when-compile
(defvar comint-last-output-start nil)
(defvar comint-last-input-start nil)
(defvar comint-last-input-end nil))
(defgroup ange-ftp nil
"Accessing remote files and directories using FTP
made as simple and transparent as possible."
:group 'files
:prefix "ange-ftp-")
(defcustom ange-ftp-name-format
'("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*[^@/:.]\\):\\(.*\\)" . (3 2 4))
"*Format of a fully expanded remote file name.
This is a list of the form \(REGEXP HOST USER NAME\),
where REGEXP is a regular expression matching
the full remote name, and HOST, USER, and NAME are the numbers of
parenthesized expressions in REGEXP for the components (in that order)."
:group 'ange-ftp
:type '(list regexp
(integer :tag "Host group")
(integer :tag "User group")
(integer :tag "Name group")))
(defvar ange-ftp-multi-msgs
"^220-\\|^230-\\|^226\\|^25.-\\|^221-\\|^200-\\|^331-\\|^4[25]1-\\|^530-"
"*Regular expression matching the start of a multiline ftp reply.")
(defvar ange-ftp-good-msgs
"^220 \\|^230 \\|^226 \\|^25. \\|^221 \\|^200 \\|^[Hh]ash mark"
"*Regular expression matching ftp \"success\" messages.")
(defcustom ange-ftp-skip-msgs
(concat "^200 \\(PORT\\|Port\\) \\|^331 \\|^150 \\|^350 \\|^[0-9]+ bytes \\|"
"^Connected \\|^$\\|^Remote system\\|^Using\\|^ \\|Password:\\|"
"^Data connection \\|"
"^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye\\|"
"^500 .*AUTH \\(KERBEROS\\|GSSAPI\\)\\|^KERBEROS\\|"
"^227 .*[Pp]assive")
"*Regular expression matching ftp messages that can be ignored."
:group 'ange-ftp
:type 'regexp)
(defcustom ange-ftp-fatal-msgs
(concat "^ftp: \\|^Not connected\\|^530 \\|^4[25]1 \\|rcmd: \\|"
"^No control connection\\|unknown host\\|^lost connection")
"*Regular expression matching ftp messages that indicate serious errors.
These mean that the FTP process should (or already has) been killed."
:group 'ange-ftp
:type 'regexp)
(defcustom ange-ftp-gateway-fatal-msgs
"No route to host\\|Connection closed\\|No such host\\|Login incorrect"
"*Regular expression matching login failure messages from rlogin/telnet."
:group 'ange-ftp
:type 'regexp)
(defcustom ange-ftp-xfer-size-msgs
"^150 .* connection for .* (\\([0-9]+\\) bytes)"
"*Regular expression used to determine the number of bytes in a FTP transfer."
:group 'ange-ftp
:type 'regexp)
(defcustom ange-ftp-tmp-name-template
(expand-file-name "ange-ftp" temporary-file-directory)
"*Template used to create temporary files."
:group 'ange-ftp
:type 'directory)
(defcustom ange-ftp-gateway-tmp-name-template "/tmp/ange-ftp"
"*Template used to create temporary files when ftp-ing through a gateway.
Files starting with this prefix need to be accessible from BOTH the local
machine and the gateway machine, and need to have the SAME name on both
machines, that is, /tmp is probably NOT what you want, since that is rarely
cross-mounted."
:group 'ange-ftp
:type 'directory)
(defcustom ange-ftp-netrc-filename "~/.netrc"
"*File in .netrc format to search for passwords."
:group 'ange-ftp
:type 'file)
(defcustom ange-ftp-disable-netrc-security-check (eq system-type 'windows-nt)
"*If non-nil avoid checking permissions on the .netrc file."
:group 'ange-ftp
:type 'boolean)
(defcustom ange-ftp-default-user nil
"*User name to use when none is specified in a file name.
If non-nil but not a string, you are prompted for the name.
If nil, the value of `ange-ftp-netrc-default-user' is used.
If that is nil too, then your login name is used.
Once a connection to a given host has been initiated, the user name
and password information for that host are cached and re-used by
ange-ftp. Use \\[ange-ftp-set-user] to change the cached values,
since setting `ange-ftp-default-user' directly does not affect
the cached information."
:group 'ange-ftp
:type '(choice (const :tag "Default" nil)
string
(other :tag "Prompt" t)))
(defcustom ange-ftp-netrc-default-user nil
"Alternate default user name to use when none is specified.
This variable is set from the `default' command in your `.netrc' file,
if there is one."
:group 'ange-ftp
:type '(choice (const :tag "Default" nil)
string))
(defcustom ange-ftp-default-password nil
"*Password to use when the user name equals `ange-ftp-default-user'."
:group 'ange-ftp
:type '(choice (const :tag "Default" nil)
string))
(defcustom ange-ftp-default-account nil
"*Account to use when the user name equals `ange-ftp-default-user'."
:group 'ange-ftp
:type '(choice (const :tag "Default" nil)
string))
(defcustom ange-ftp-netrc-default-password nil
"*Password to use when the user name equals `ange-ftp-netrc-default-user'."
:group 'ange-ftp
:type '(choice (const :tag "Default" nil)
string))
(defcustom ange-ftp-netrc-default-account nil
"*Account to use when the user name equals `ange-ftp-netrc-default-user'."
:group 'ange-ftp
:type '(choice (const :tag "Default" nil)
string))
(defcustom ange-ftp-generate-anonymous-password t
"*If t, use value of `user-mail-address' as password for anonymous ftp.
If a string, then use that string as the password.
If nil, prompt the user for a password."
:group 'ange-ftp
:type '(choice (const :tag "Prompt" nil)
string
(other :tag "User address" t)))
(defcustom ange-ftp-dumb-unix-host-regexp nil
"*If non-nil, regexp matching hosts on which `dir' command lists directory."
:group 'ange-ftp
:type '(choice (const :tag "Default" nil)
string))
(defcustom ange-ftp-binary-file-name-regexp
(concat "\\.[zZ]$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|"
"\\.dvi$\\|\\.ps$\\|\\.elc$\\|TAGS$\\|\\.gif$\\|"
"\\.EXE\\(;[0-9]+\\)?$\\|\\.[zZ]-part-..$\\|\\.gz$\\|"
"\\.taz$\\|\\.tgz$")
"*If a file matches this regexp then it is transferred in binary mode."
:group 'ange-ftp
:type 'regexp)
(defcustom ange-ftp-gateway-host nil
"*Name of host to use as gateway machine when local FTP isn't possible."
:group 'ange-ftp
:type '(choice (const :tag "Default" nil)
string))
(defcustom ange-ftp-local-host-regexp ".*"
"*Regexp selecting hosts which can be reached directly with ftp.
For other hosts the FTP process is started on \`ange-ftp-gateway-host\'
instead, and/or reached via \`ange-ftp-gateway-ftp-program-name\'."
:group 'ange-ftp
:type 'regexp)
(defcustom ange-ftp-gateway-program-interactive nil
"*If non-nil then the gateway program should give a shell prompt.
Both telnet and rlogin do something like this."
:group 'ange-ftp
:type 'boolean)
(defcustom ange-ftp-gateway-program remote-shell-program
"*Name of program to spawn a shell on the gateway machine.
Valid candidates are rsh (remsh on some systems), telnet and rlogin. See
also the gateway variable above."
:group 'ange-ftp
:type '(choice (const "rsh")
(const "telnet")
(const "rlogin")
string))
(defcustom ange-ftp-gateway-prompt-pattern "^[^#$%>;\n]*[#$%>;] *"
"*Regexp matching prompt after complete login sequence on gateway machine.
A match for this means the shell is now awaiting input. Make this regexp as
strict as possible; it shouldn't match *anything* at all except the user's
initial prompt. The above string will fail under most SUN-3's since it
matches the login banner."
:group 'ange-ftp
:type 'regexp)
(defvar ange-ftp-gateway-setup-term-command
(if (eq system-type 'hpux)
"stty -onlcr -echo\n"
"stty -echo nl\n")
"*Set up terminal after logging in to the gateway machine.
This command should stop the terminal from echoing each command, and
arrange to strip out trailing ^M characters.")
(defcustom ange-ftp-smart-gateway nil
"*Non-nil means the ftp gateway and/or the gateway ftp program is smart.
Don't bother telnetting, etc., already connected to desired host transparently,
or just issue a user@host command in case \`ange-ftp-gateway-host\' is non-nil."
:group 'ange-ftp
:type 'boolean)
(defcustom ange-ftp-smart-gateway-port "21"
"*Port on gateway machine to use when smart gateway is in operation."
:group 'ange-ftp
:type 'string)
(defcustom ange-ftp-send-hash t
"*If non-nil, send the HASH command to the FTP client."
:group 'ange-ftp
:type 'boolean)
(defcustom ange-ftp-binary-hash-mark-size nil
"*Default size, in bytes, between hash-marks when transferring a binary file.
If nil, this variable will be locally overridden if the FTP client outputs a
suitable response to the HASH command. If non-nil, this value takes
precedence over the local value."
:group 'ange-ftp
:type '(choice (const :tag "Overridden" nil)
integer))
(defcustom ange-ftp-ascii-hash-mark-size 1024
"*Default size, in bytes, between hash-marks when transferring an ASCII file.
This variable is buffer-local and will be locally overridden if the FTP client
outputs a suitable response to the HASH command."
:group 'ange-ftp
:type 'integer)
(defcustom ange-ftp-process-verbose t
"*If non-nil then be chatty about interaction with the FTP process."
:group 'ange-ftp
:type 'boolean)
(defcustom ange-ftp-ftp-program-name "ftp"
"*Name of FTP program to run."
:group 'ange-ftp
:type 'string)
(defcustom ange-ftp-gateway-ftp-program-name "ftp"
"*Name of FTP program to run when accessing non-local hosts.
Some AT&T folks claim to use something called `pftp' here."
:group 'ange-ftp
:type 'string)
(defcustom ange-ftp-ftp-program-args '("-i" "-n" "-g" "-v")
"*A list of arguments passed to the FTP program when started."
:group 'ange-ftp
:type '(repeat string))
(defcustom ange-ftp-nslookup-program nil
"*If non-nil, this is a string naming the nslookup program."
:group 'ange-ftp
:type '(choice (const :tag "None" nil)
string))
(defcustom ange-ftp-make-backup-files ()
"*Non-nil means make backup files for \"magic\" remote files."
:group 'ange-ftp
:type 'boolean)
(defcustom ange-ftp-retry-time 5
"*Number of seconds to wait before retry if file or listing doesn't arrive.
This might need to be increased for very slow connections."
:group 'ange-ftp
:type 'integer)
(defcustom ange-ftp-auto-save 0
"If 1, allow ange-ftp files to be auto-saved.
If 0, inhibit auto-saving of ange-ftp files.
Don't use any other value."
:group 'ange-ftp
:type '(choice (const :tag "Suppress" 0)
(const :tag "Allow" 1)))
(require 'backquote)
(defun ange-ftp-make-hashtable (&optional size)
"Make an obarray suitable for use as a hashtable.
SIZE, if supplied, should be a prime number."
(make-vector (or size 31) 0))
(defun ange-ftp-map-hashtable (fun tbl)
"Call FUNCTION on each key and value in HASHTABLE."
(mapatoms
(function
(lambda (sym)
(funcall fun (get sym 'key) (get sym 'val))))
tbl))
(defmacro ange-ftp-make-hash-key (key)
"Convert KEY into a suitable key for a hashtable."
(` (if (stringp (, key))
(, key)
(prin1-to-string (, key)))))
(defun ange-ftp-get-hash-entry (key tbl)
"Return the value associated with KEY in HASHTABLE."
(let ((sym (intern-soft (ange-ftp-make-hash-key key) tbl)))
(and sym (get sym 'val))))
(defun ange-ftp-put-hash-entry (key val tbl)
"Record an association between KEY and VALUE in HASHTABLE."
(let ((sym (intern (ange-ftp-make-hash-key key) tbl)))
(put sym 'val val)
(put sym 'key key)))
(defun ange-ftp-del-hash-entry (key tbl)
"Copy all symbols except KEY in HASHTABLE and return modified hashtable."
(let* ((len (length tbl))
(new-tbl (ange-ftp-make-hashtable len))
(i (1- len)))
(ange-ftp-map-hashtable
(function
(lambda (k v)
(or (equal k key)
(ange-ftp-put-hash-entry k v new-tbl))))
tbl)
(while (>= i 0)
(aset tbl i (aref new-tbl i))
(setq i (1- i)))
tbl))
(defun ange-ftp-hash-entry-exists-p (key tbl)
"Return whether there is an association for KEY in TABLE."
(intern-soft (ange-ftp-make-hash-key key) tbl))
(defun ange-ftp-hash-table-keys (tbl)
"Return a sorted list of all the active keys in TABLE, as strings."
(sort (all-completions "" tbl)
(function string-lessp)))
(defvar ange-ftp-data-buffer-name " *ftp data*"
"Buffer name to hold directory listing data received from ftp process.")
(defvar ange-ftp-netrc-modtime nil
"Last modified time of the netrc file from file-attributes.")
(defvar ange-ftp-user-hashtable (ange-ftp-make-hashtable)
"Hash table holding associations between HOST, USER pairs.")
(defvar ange-ftp-passwd-hashtable (ange-ftp-make-hashtable)
"Mapping between a HOST, USER pair and a PASSWORD for them.
All HOST values should be in lower case.")
(defvar ange-ftp-account-hashtable (ange-ftp-make-hashtable)
"Mapping between a HOST, USER pair and a ACCOUNT password for them.")
(defvar ange-ftp-files-hashtable (ange-ftp-make-hashtable 97)
"Hash table for storing directories and their respective files.")
(defvar ange-ftp-inodes-hashtable (ange-ftp-make-hashtable 97)
"Hash table for storing file names and their \"inode numbers\".")
(defvar ange-ftp-next-inode-number 1
"Next \"inode number\" value. We give each file name a unique number.")
(defvar ange-ftp-ls-cache-lsargs nil
"Last set of args used by ange-ftp-ls.")
(defvar ange-ftp-ls-cache-file nil
"Last file passed to ange-ftp-ls.")
(defvar ange-ftp-ls-cache-res nil
"Last result returned from ange-ftp-ls.")
(defconst ange-ftp-expand-dir-hashtable (ange-ftp-make-hashtable))
(defconst ange-ftp-expand-dir-regexp "^5.0 \\([^: ]+\\):")
(defvar ange-ftp-hash-mark-unit nil)
(defvar ange-ftp-hash-mark-count nil)
(defvar ange-ftp-xfer-size nil)
(defvar ange-ftp-process-string nil)
(defvar ange-ftp-process-result-line nil)
(defvar ange-ftp-process-busy nil)
(defvar ange-ftp-process-result nil)
(defvar ange-ftp-process-multi-skip nil)
(defvar ange-ftp-process-msg nil)
(defvar ange-ftp-process-continue nil)
(defvar ange-ftp-last-percent nil)
(defvar ange-ftp-this-file)
(defvar ange-ftp-this-dir)
(defvar ange-ftp-this-user)
(defvar ange-ftp-this-host)
(defvar ange-ftp-this-msg)
(defvar ange-ftp-completion-ignored-pattern)
(defvar ange-ftp-trample-marker)
(put 'ftp-error 'error-conditions '(ftp-error file-error error))
(defun ange-ftp-message (fmt &rest args)
"Display message in echo area, but indicate if truncated.
Args are as in `message': a format string, plus arguments to be formatted."
(let ((msg (apply (function format) fmt args))
(max (window-width (minibuffer-window))))
(if noninteractive
msg
(if (>= (length msg) max)
(setq msg (concat "> " (substring msg (- 3 max)))))
(message "%s" msg))))
(defun ange-ftp-abbreviate-filename (file &optional new)
"Abbreviate the file name FILE relative to the default-directory.
If the optional parameter NEW is given and the non-directory parts match,
only return the directory part of FILE."
(save-match-data
(if (and default-directory
(string-match (concat "^"
(regexp-quote default-directory)
".") file))
(setq file (substring file (1- (match-end 0)))))
(if (and new
(string-equal (file-name-nondirectory file)
(file-name-nondirectory new)))
(setq file (file-name-directory file)))
(or file "./")))
(defun ange-ftp-set-user (host user)
"For a given HOST, set or change the default USER."
(interactive "sHost: \nsUser: ")
(ange-ftp-put-hash-entry host user ange-ftp-user-hashtable))
(defun ange-ftp-get-user (host)
"Given a HOST, return the default USER."
(ange-ftp-parse-netrc)
(let ((user (ange-ftp-get-hash-entry host ange-ftp-user-hashtable)))
(or user
(prog1
(setq user
(cond ((stringp ange-ftp-default-user)
ange-ftp-default-user)
(ange-ftp-default-user
(let ((enable-recursive-minibuffers t))
(read-string (format "User for %s: " host)
(user-login-name))))
(ange-ftp-netrc-default-user)
(t
(user-login-name))))
(ange-ftp-set-user host user)))))
(defmacro ange-ftp-generate-passwd-key (host user)
(` (concat (downcase (, host)) "/" (, user))))
(defmacro ange-ftp-lookup-passwd (host user)
(` (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key (, host) (, user))
ange-ftp-passwd-hashtable)))
(defun ange-ftp-set-passwd (host user passwd)
"For a given HOST and USER, set or change the associated PASSWORD."
(interactive (list (read-string "Host: ")
(read-string "User: ")
(read-passwd "Password: ")))
(ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user)
passwd
ange-ftp-passwd-hashtable))
(defun ange-ftp-get-host-with-passwd (user)
"Given a USER, return a host we know the password for."
(ange-ftp-parse-netrc)
(catch 'found-one
(ange-ftp-map-hashtable
(function (lambda (host val)
(if (ange-ftp-lookup-passwd host user)
(throw 'found-one host))))
ange-ftp-user-hashtable)
(save-match-data
(ange-ftp-map-hashtable
(function
(lambda (key value)
(if (string-match "^[^/]*\\(/\\).*$" key)
(let ((host (substring key 0 (match-beginning 1))))
(if (and (string-equal user (substring key (match-end 1)))
value)
(throw 'found-one host))))))
ange-ftp-passwd-hashtable))
nil))
(defun ange-ftp-get-passwd (host user)
"Return the password for specified HOST and USER, asking user if necessary."
(ange-ftp-parse-netrc)
(cond ((ange-ftp-lookup-passwd host user))
((and (stringp ange-ftp-default-user)
ange-ftp-default-password
(string-equal user ange-ftp-default-user))
ange-ftp-default-password)
((and (stringp ange-ftp-netrc-default-user)
ange-ftp-netrc-default-password
(string-equal user ange-ftp-netrc-default-user))
ange-ftp-netrc-default-password)
((and (or (string-equal user "anonymous")
(string-equal user "ftp"))
ange-ftp-generate-anonymous-password)
(if (stringp ange-ftp-generate-anonymous-password)
ange-ftp-generate-anonymous-password
user-mail-address))
(t
(let* ((other (ange-ftp-get-host-with-passwd user))
(passwd (if other
(read-passwd
(format "passwd for %s@%s (default same as %s@%s): "
user host user other)
nil
(ange-ftp-lookup-passwd other user))
(read-passwd
(format "Password for %s@%s: " user host)))))
(ange-ftp-set-passwd host user passwd)
passwd))))
(defun ange-ftp-set-account (host user account)
"For a given HOST and USER, set or change the associated ACCOUNT password."
(interactive (list (read-string "Host: ")
(read-string "User: ")
(read-passwd "Account password: ")))
(ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user)
account
ange-ftp-account-hashtable))
(defun ange-ftp-get-account (host user)
"Given a HOST and USER, return the FTP account."
(ange-ftp-parse-netrc)
(or (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key host user)
ange-ftp-account-hashtable)
(and (stringp ange-ftp-default-user)
(string-equal user ange-ftp-default-user)
ange-ftp-default-account)
(and (stringp ange-ftp-netrc-default-user)
(string-equal user ange-ftp-netrc-default-user)
ange-ftp-netrc-default-account)))
(defun ange-ftp-chase-symlinks (file)
"Return the filename that FILE references, following all symbolic links."
(let (temp)
(while (setq temp (ange-ftp-real-file-symlink-p file))
(setq file
(if (file-name-absolute-p temp)
temp
(concat (file-name-directory file) temp)))))
file)
(defun ange-ftp-parse-netrc-token (token limit)
(if (search-forward token limit t)
(let (beg)
(skip-chars-forward ", \t\r\n" limit)
(if (eq (following-char) ?\") ;quoted token value
(progn (forward-char 1)
(setq beg (point))
(skip-chars-forward "^\"" limit)
(forward-char 1)
(buffer-substring beg (1- (point))))
(setq beg (point))
(skip-chars-forward "^, \t\r\n" limit)
(buffer-substring beg (point))))))
(defun ange-ftp-parse-netrc-group ()
(let ((start (point))
(end (save-excursion
(if (looking-at "machine\\>")
(progn
(skip-chars-forward "^ \t\r\n")
(skip-chars-forward " \t\r\n")
(skip-chars-forward "^ \t\r\n"))
(skip-chars-forward "^ \t\r\n"))
(if (re-search-forward "machine\\>\\|default\\>" nil t)
(match-beginning 0)
(point-max))))
machine login password account)
(setq machine (ange-ftp-parse-netrc-token "machine" end)
login (ange-ftp-parse-netrc-token "login" end)
password (ange-ftp-parse-netrc-token "password" end)
account (ange-ftp-parse-netrc-token "account" end))
(if (and machine login)
(progn
(ange-ftp-set-user machine login)
(ange-ftp-set-passwd machine login password)
(and account
(ange-ftp-set-account machine login account)))
(goto-char start)
(if (search-forward "default" end t)
(progn
(setq login (ange-ftp-parse-netrc-token "login" end)
password (ange-ftp-parse-netrc-token "password" end)
account (ange-ftp-parse-netrc-token "account" end))
(and login
(setq ange-ftp-netrc-default-user login))
(and password
(setq ange-ftp-netrc-default-password password))
(and account
(setq ange-ftp-netrc-default-account account)))))
(goto-char end)))
(defun ange-ftp-parse-netrc ()
(interactive)
(let (file attr)
(let ((default-directory "/"))
(setq file (ange-ftp-chase-symlinks
(ange-ftp-real-expand-file-name ange-ftp-netrc-filename)))
(setq attr (ange-ftp-real-file-attributes file)))
(if (and attr (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) (save-match-data
(if (or ange-ftp-disable-netrc-security-check
(and (eq (nth 2 attr) (user-uid)) (string-match ".r..------" (nth 8 attr))))
(save-excursion
(set-buffer (generate-new-buffer "*ftp-.netrc*"))
(ange-ftp-real-insert-file-contents file)
(setq buffer-file-name file)
(setq default-directory (file-name-directory file))
(normal-mode t)
(mapcar 'funcall find-file-hooks)
(setq buffer-file-name nil)
(goto-char (point-min))
(skip-chars-forward " \t\r\n")
(while (not (eobp))
(ange-ftp-parse-netrc-group))
(kill-buffer (current-buffer)))
(ange-ftp-message "%s either not owned by you or badly protected."
ange-ftp-netrc-filename)
(sit-for 1))
(setq ange-ftp-netrc-modtime (nth 5 attr))))))
(defun ange-ftp-generate-root-prefixes ()
(ange-ftp-parse-netrc)
(save-match-data
(let (res)
(ange-ftp-map-hashtable
(function
(lambda (key value)
(if (string-match "^[^/]*\\(/\\).*$" key)
(let ((host (substring key 0 (match-beginning 1)))
(user (substring key (match-end 1))))
(setq res (cons (list (concat user "@" host ":"))
res))))))
ange-ftp-passwd-hashtable)
(ange-ftp-map-hashtable
(function (lambda (host user)
(setq res (cons (list (concat host ":"))
res))))
ange-ftp-user-hashtable)
(or res (list nil)))))
(defmacro ange-ftp-ftp-name-component (n ns name)
"Extract the Nth ftp file name component from NS."
(` (let ((elt (nth (, n) (, ns))))
(if (match-beginning elt)
(substring (, name) (match-beginning elt) (match-end elt))))))
(defvar ange-ftp-ftp-name-arg "")
(defvar ange-ftp-ftp-name-res nil)
(defun ange-ftp-ftp-name (name)
(if (string-equal name ange-ftp-ftp-name-arg)
ange-ftp-ftp-name-res
(setq ange-ftp-ftp-name-arg name
ange-ftp-ftp-name-res
(save-match-data
(if (posix-string-match (car ange-ftp-name-format) name)
(let* ((ns (cdr ange-ftp-name-format))
(host (ange-ftp-ftp-name-component 0 ns name))
(user (ange-ftp-ftp-name-component 1 ns name))
(name (ange-ftp-ftp-name-component 2 ns name)))
(if (zerop (length user))
(setq user (ange-ftp-get-user host)))
(list host user name))
nil)))))
(defun ange-ftp-replace-name-component (fullname name)
(save-match-data
(if (posix-string-match (car ange-ftp-name-format) fullname)
(let* ((ns (cdr ange-ftp-name-format))
(elt (nth 2 ns)))
(concat (substring fullname 0 (match-beginning elt))
name
(substring fullname (match-end elt)))))))
(defun ange-ftp-repaint-minibuffer ()
"Clear any existing minibuffer message; let the minibuffer contents show."
(message nil))
(defun ange-ftp-ftp-process-buffer (host user)
(concat "*ftp " user "@" host "*"))
(defun ange-ftp-error (host user msg)
(let ((cur (selected-window))
(pop-up-windows t))
(pop-to-buffer
(get-buffer-create
(ange-ftp-ftp-process-buffer host user)))
(goto-char (point-max))
(select-window cur))
(signal 'ftp-error (list (format "FTP Error: %s" msg))))
(defun ange-ftp-set-buffer-mode ()
"Set correct modes for the current buffer if visiting a remote file."
(if (and (stringp buffer-file-name)
(ange-ftp-ftp-name buffer-file-name))
(auto-save-mode ange-ftp-auto-save)))
(defun ange-ftp-kill-ftp-process (&optional buffer)
"Kill the FTP process associated with BUFFER (the current buffer, if nil).
If the BUFFER's visited filename or default-directory is an ftp filename
then kill the related ftp process."
(interactive "bKill FTP process associated with buffer: ")
(if (null buffer)
(setq buffer (current-buffer))
(setq buffer (get-buffer buffer)))
(let ((file (or (buffer-file-name buffer)
(save-excursion (set-buffer buffer) default-directory))))
(if file
(let ((parsed (ange-ftp-ftp-name (expand-file-name file))))
(if parsed
(let ((host (nth 0 parsed))
(user (nth 1 parsed)))
(kill-buffer (get-buffer (ange-ftp-ftp-process-buffer host user)))))))))
(defun ange-ftp-quote-string (string)
"Quote any characters in STRING that may confuse the ftp process."
(apply (function concat)
(mapcar (function
(lambda (char)
(if (or (<= char ? )
(> char ?\~)
(= char ?\")
(= char ?\\))
(vector ?\\ char)
(vector char))))
string)))
(defun ange-ftp-barf-if-not-directory (directory)
(or (file-directory-p directory)
(signal 'file-error
(list "Opening directory"
(if (file-exists-p directory)
"not a directory"
"no such file or directory")
directory))))
;;;; ------------------------------------------------------------
;;;; FTP process filter support.
;;;; ------------------------------------------------------------
(defun ange-ftp-process-handle-line (line proc)
"Look at the given LINE from the ftp process PROC.
Try to categorize it into one of four categories:
good, skip, fatal, or unknown."
(cond ((string-match ange-ftp-xfer-size-msgs line)
(setq ange-ftp-xfer-size
(ash (string-to-int (substring line
(match-beginning 1)
(match-end 1)))
-10)))
((string-match ange-ftp-skip-msgs line)
t)
((string-match ange-ftp-good-msgs line)
(setq ange-ftp-process-busy nil
ange-ftp-process-result t
ange-ftp-process-result-line line))
;; Check this before checking for errors.
;; Otherwise the last line of these three seems to be an error:
;; 230-see a significant impact from the move. For those of you who can't
;; 230-use DNS to resolve hostnames and get an error message like
;; 230-"ftp.stsci.edu: unknown host", the new IP address will be...
((string-match ange-ftp-multi-msgs line)
(setq ange-ftp-process-multi-skip t))
((string-match ange-ftp-fatal-msgs line)
(delete-process proc)
(setq ange-ftp-process-busy nil
ange-ftp-process-result-line line))
(ange-ftp-process-multi-skip
t)
(t
(setq ange-ftp-process-busy nil
ange-ftp-process-result-line line))))
(defun ange-ftp-set-xfer-size (host user bytes)
"Set the size of the next FTP transfer in bytes."
(let ((proc (ange-ftp-get-process host user)))
(if proc
(let ((buf (process-buffer proc)))
(if buf
(save-excursion
(set-buffer buf)
(setq ange-ftp-xfer-size (ash bytes -10))))))))
(defun ange-ftp-process-handle-hash (str)
"Remove hash marks from STRING and display count so far."
(setq str (concat (substring str 0 (match-beginning 0))
(substring str (match-end 0)))
ange-ftp-hash-mark-count (+ (- (match-end 0)
(match-beginning 0))
ange-ftp-hash-mark-count))
(and ange-ftp-hash-mark-unit
ange-ftp-process-msg
ange-ftp-process-verbose
(not (eq (selected-window) (minibuffer-window)))
(not (boundp 'search-message)) ;screws up isearch otherwise
(not cursor-in-echo-area) ;screws up y-or-n-p otherwise
(let ((kbytes (ash (* ange-ftp-hash-mark-unit
ange-ftp-hash-mark-count)
-6)))
(if (zerop ange-ftp-xfer-size)
(ange-ftp-message "%s...%dk" ange-ftp-process-msg kbytes)
(let ((percent (/ (* 100 kbytes) ange-ftp-xfer-size)))
;; cut out the redisplay of identical %-age messages.
(if (not (eq percent ange-ftp-last-percent))
(progn
(setq ange-ftp-last-percent percent)
(ange-ftp-message "%s...%d%%" ange-ftp-process-msg percent)))))))
str)
;; Call the function specified by CONT. CONT can be either a function
;; or a list of a function and some args. The first two parameters
;; passed to the function will be RESULT and LINE. The remaining args
;; will be taken from CONT if a list was passed.
(defun ange-ftp-call-cont (cont result line)
(if cont
(if (and (listp cont)
(not (eq (car cont) 'lambda)))
(apply (car cont) result line (cdr cont))
(funcall cont result line))))
;; Build up a complete line of output from the ftp PROCESS and pass it
;; on to ange-ftp-process-handle-line to deal with.
(defun ange-ftp-process-filter (proc str)
(let ((buffer (process-buffer proc))
(old-buffer (current-buffer)))
;; Eliminate nulls.
(while (string-match "\000+" str)
(setq str (replace-match "" nil nil str)))
;; see if the buffer is still around... it could have been deleted.
(if (buffer-name buffer)
(unwind-protect
(progn
(set-buffer (process-buffer proc))
;; handle hash mark printing
(and ange-ftp-process-busy
(string-match "^#+$" str)
(setq str (ange-ftp-process-handle-hash str)))
(comint-output-filter proc str)
;; Replace STR by the result of the comint processing.
(setq str (buffer-substring comint-last-output-start
(process-mark proc)))
(if ange-ftp-process-busy
(progn
(setq ange-ftp-process-string (concat ange-ftp-process-string
str))
;; if we gave an empty password to the USER command earlier
;; then we should send a null password now.
(if (string-match "Password: *$" ange-ftp-process-string)
(send-string proc "\n"))))
(while (and ange-ftp-process-busy
(string-match "\n" ange-ftp-process-string))
(let ((line (substring ange-ftp-process-string
0
(match-beginning 0))))
(setq ange-ftp-process-string (substring ange-ftp-process-string
(match-end 0)))
(while (string-match "^ftp> *" line)
(setq line (substring line (match-end 0))))
(ange-ftp-process-handle-line line proc)))
;; has the ftp client finished? if so then do some clean-up
;; actions.
(if (not ange-ftp-process-busy)
(progn
;; reset the xfer size
(setq ange-ftp-xfer-size 0)
;; issue the "done" message since we've finished.
(if (and ange-ftp-process-msg
ange-ftp-process-verbose
ange-ftp-process-result)
(progn
(ange-ftp-message "%s...done" ange-ftp-process-msg)
(ange-ftp-repaint-minibuffer)
(setq ange-ftp-process-msg nil)))
;; is there a continuation we should be calling? if so,
;; we'd better call it, making sure we only call it once.
(if ange-ftp-process-continue
(let ((cont ange-ftp-process-continue))
(setq ange-ftp-process-continue nil)
(ange-ftp-call-cont cont
ange-ftp-process-result
ange-ftp-process-result-line))))))
(set-buffer old-buffer)))))
(defun ange-ftp-process-sentinel (proc str)
"When ftp process changes state, nuke all file-entries in cache."
(let ((name (process-name proc)))
(if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name)
(let ((user (substring name (match-beginning 1) (match-end 1)))
(host (substring name (match-beginning 2) (match-end 2))))
(ange-ftp-wipe-file-entries host user))))
(setq ange-ftp-ls-cache-file nil))
;;;; ------------------------------------------------------------
;;;; Gateway support.
;;;; ------------------------------------------------------------
(defun ange-ftp-use-gateway-p (host)
"Returns whether to access this host via a normal (non-smart) gateway."
;; yes, I know that I could simplify the following expression, but it is
;; clearer (to me at least) this way.
(and (not ange-ftp-smart-gateway)
(save-match-data
(not (string-match ange-ftp-local-host-regexp host)))))
(defun ange-ftp-use-smart-gateway-p (host)
"Returns whether to access this host via a smart gateway."
(and ange-ftp-smart-gateway
(save-match-data
(not (string-match ange-ftp-local-host-regexp host)))))
;;; ------------------------------------------------------------
;;; Temporary file location and deletion...
;;; ------------------------------------------------------------
(defvar ange-ftp-tmp-name-files ())
(defvar ange-ftp-tmp-name-hashtable (ange-ftp-make-hashtable 10))
(defvar ange-ftp-pid nil)
(defun ange-ftp-get-pid ()
"Half-hearted attempt to get the current process's id."
(setq ange-ftp-pid (substring (make-temp-name "") 1)))
(defun ange-ftp-make-tmp-name (host)
"This routine will return the name of a new file."
(let* ((template (if (ange-ftp-use-gateway-p host)
ange-ftp-gateway-tmp-name-template
ange-ftp-tmp-name-template))
(pid (or ange-ftp-pid (ange-ftp-get-pid)))
(start ?a)
file entry)
(while
(progn
(setq file (format "%s%c%s" template start pid))
(setq entry (intern file ange-ftp-tmp-name-hashtable))
(or (memq entry ange-ftp-tmp-name-files)
(ange-ftp-real-file-exists-p file)))
(if (> (setq start (1+ start)) ?z)
(progn
(setq template (concat template "X"))
(setq start ?a))))
(setq ange-ftp-tmp-name-files
(cons entry ange-ftp-tmp-name-files))
file))
(defun ange-ftp-del-tmp-name (temp)
(setq ange-ftp-tmp-name-files
(delq (intern temp ange-ftp-tmp-name-hashtable)
ange-ftp-tmp-name-files))
(condition-case ()
(ange-ftp-real-delete-file temp)
(error nil)))
;;;; ------------------------------------------------------------
;;;; Interactive gateway program support.
;;;; ------------------------------------------------------------
(defvar ange-ftp-gwp-running t)
(defvar ange-ftp-gwp-status nil)
(defun ange-ftp-gwp-sentinel (proc str)
(setq ange-ftp-gwp-running nil))
(defun ange-ftp-gwp-filter (proc str)
(comint-output-filter proc str)
(save-excursion
(set-buffer (process-buffer proc))
;; Replace STR by the result of the comint processing.
(setq str (buffer-substring comint-last-output-start (process-mark proc))))
(cond ((string-match "login: *$" str)
(send-string proc
(concat
(let ((ange-ftp-default-user t))
(ange-ftp-get-user ange-ftp-gateway-host))
"\n")))
((string-match "Password: *$" str)
(send-string proc
(concat
(ange-ftp-get-passwd ange-ftp-gateway-host
(ange-ftp-get-user
ange-ftp-gateway-host))
"\n")))
((string-match ange-ftp-gateway-fatal-msgs str)
(delete-process proc)
(setq ange-ftp-gwp-running nil))
((string-match ange-ftp-gateway-prompt-pattern str)
(setq ange-ftp-gwp-running nil
ange-ftp-gwp-status t))))
(defun ange-ftp-gwp-start (host user name args)
"Login to the gateway machine and fire up an ftp process."
(let* ((gw-user (ange-ftp-get-user ange-ftp-gateway-host))
;; It would be nice to make process-connection-type nil,
;; but that doesn't work: ftp never responds.
;; Can anyone find a fix for that?
(proc (let ((process-connection-type t))
(start-process name name
ange-ftp-gateway-program
ange-ftp-gateway-host)))
(ftp (mapconcat (function identity) args " ")))
(process-kill-without-query proc)
(set-process-sentinel proc (function ange-ftp-gwp-sentinel))
(set-process-filter proc (function ange-ftp-gwp-filter))
(save-excursion
(set-buffer (process-buffer proc))
(goto-char (point-max))
(set-marker (process-mark proc) (point)))
(setq ange-ftp-gwp-running t
ange-ftp-gwp-status nil)
(ange-ftp-message "Connecting to gateway %s..." ange-ftp-gateway-host)
(while ange-ftp-gwp-running ;perform login sequence
(accept-process-output proc))
(if (not ange-ftp-gwp-status)
(ange-ftp-error host user "unable to login to gateway"))
(ange-ftp-message "Connecting to gateway %s...done" ange-ftp-gateway-host)
(setq ange-ftp-gwp-running t
ange-ftp-gwp-status nil)
(process-send-string proc ange-ftp-gateway-setup-term-command)
(while ange-ftp-gwp-running ;zap ^M's and double echoing.
(accept-process-output proc))
(if (not ange-ftp-gwp-status)
(ange-ftp-error host user "unable to set terminal modes on gateway"))
(setq ange-ftp-gwp-running t
ange-ftp-gwp-status nil)
(process-send-string proc (concat "exec " ftp "\n")) ;spawn ftp process
proc))
;;;; ------------------------------------------------------------
;;;; Support for sending commands to the ftp process.
;;;; ------------------------------------------------------------
(defun ange-ftp-raw-send-cmd (proc cmd &optional msg cont nowait)
"Low-level routine to send the given ftp CMD to the ftp PROCESS.
MSG is an optional message to output before and after the command.
If CONT is non-nil then it is either a function or a list of function and
some arguments. The function will be called when the ftp command has completed.
If CONT is nil then this routine will return \( RESULT . LINE \) where RESULT
is whether the command was successful, and LINE is the line from the FTP
process that caused the command to complete.
If NOWAIT is given then the routine will return immediately the command has
been queued with no result. CONT will still be called, however."
(if (memq (process-status proc) '(run open))
(save-excursion
(set-buffer (process-buffer proc))
(ange-ftp-wait-not-busy proc)
(setq ange-ftp-process-string ""
ange-ftp-process-result-line ""
ange-ftp-process-busy t
ange-ftp-process-result nil
ange-ftp-process-multi-skip nil
ange-ftp-process-msg msg
ange-ftp-process-continue cont
ange-ftp-hash-mark-count 0
ange-ftp-last-percent -1
cmd (concat cmd "\n"))
(and msg ange-ftp-process-verbose (ange-ftp-message "%s..." msg))
(goto-char (point-max))
(move-marker comint-last-input-start (point))
;; don't insert the password into the buffer on the USER command.
(save-match-data
(if (string-match "^user \"[^\"]*\"" cmd)
(insert (substring cmd 0 (match-end 0)) " Turtle Power!\n")
(insert cmd)))
(move-marker comint-last-input-end (point))
(send-string proc cmd)
(set-marker (process-mark proc) (point))
(if nowait
nil
(ange-ftp-wait-not-busy proc)
(if cont
nil (cons ange-ftp-process-result ange-ftp-process-result-line))))))
(defun ange-ftp-wait-not-busy (proc)
(save-excursion
(set-buffer (process-buffer proc))
(condition-case nil
(let ((quit-flag nil)
(inhibit-quit nil))
(while ange-ftp-process-busy
(accept-process-output proc)))
(quit
(delete-process proc)
(signal 'quit nil)))))
(defun ange-ftp-nslookup-host (host)
"Attempt to resolve the given HOSTNAME using nslookup if possible."
(interactive "sHost: ")
(if ange-ftp-nslookup-program
(let ((default-directory
(if (file-accessible-directory-p default-directory)
default-directory
exec-directory))
(proc (let ((process-connection-type t))
(start-process " *nslookup*" " *nslookup*"
ange-ftp-nslookup-program host)))
(res host))
(process-kill-without-query proc)
(save-excursion
(set-buffer (process-buffer proc))
(while (memq (process-status proc) '(run open))
(accept-process-output proc))
(goto-char (point-min))
(if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
(setq res (buffer-substring (match-beginning 1)
(match-end 1))))
(kill-buffer (current-buffer)))
res)
host))
(defun ange-ftp-start-process (host user name)
"Spawn a new ftp process ready to connect to machine HOST and give it NAME.
If HOST is only ftp-able through a gateway machine then spawn a shell
on the gateway machine to do the ftp instead."
(let* ((use-gateway (ange-ftp-use-gateway-p host))
(use-smart-ftp (and (not ange-ftp-gateway-host)
(ange-ftp-use-smart-gateway-p host)))
(ftp-prog (if (or use-gateway
use-smart-ftp)
ange-ftp-gateway-ftp-program-name
ange-ftp-ftp-program-name))
(args (append (list ftp-prog) ange-ftp-ftp-program-args))
(file-name-handler-alist)
(default-directory
(if (file-accessible-directory-p default-directory)
default-directory
exec-directory))
proc)
(let ((process-connection-type t)
(process-environment process-environment)
(buffer (get-buffer-create name)))
(save-excursion
(set-buffer buffer)
(internal-ange-ftp-mode))
(setenv "TERM" "dumb")
(if use-gateway
(if ange-ftp-gateway-program-interactive
(setq proc (ange-ftp-gwp-start host user name args))
(setq proc (apply 'start-process name name
(append (list ange-ftp-gateway-program
ange-ftp-gateway-host)
args))))
(setq proc (apply 'start-process name name args))))
(save-excursion
(set-buffer (process-buffer proc))
(goto-char (point-max))
(set-marker (process-mark proc) (point)))
(process-kill-without-query proc)
(set-process-sentinel proc (function ange-ftp-process-sentinel))
(set-process-filter proc (function ange-ftp-process-filter))
(when (eq system-type 'windows-nt)
(set-process-coding-system proc 'raw-text-dos)
(process-send-string proc "help foo\n"))
(accept-process-output proc) proc))
(put 'internal-ange-ftp-mode 'mode-class 'special)
(defun internal-ange-ftp-mode ()
"Major mode for interacting with the FTP process.
\\{comint-mode-map}"
(interactive)
(comint-mode)
(setq major-mode 'internal-ange-ftp-mode)
(setq mode-name "Internal Ange-ftp")
(let ((proc (get-buffer-process (current-buffer))))
(make-local-variable 'ange-ftp-process-string)
(setq ange-ftp-process-string "")
(make-local-variable 'ange-ftp-process-busy)
(make-local-variable 'ange-ftp-process-result)
(make-local-variable 'ange-ftp-process-msg)
(make-local-variable 'ange-ftp-process-multi-skip)
(make-local-variable 'ange-ftp-process-result-line)
(make-local-variable 'ange-ftp-process-continue)
(make-local-variable 'ange-ftp-hash-mark-count)
(make-local-variable 'ange-ftp-binary-hash-mark-size)
(make-local-variable 'ange-ftp-ascii-hash-mark-size)
(make-local-variable 'ange-ftp-hash-mark-unit)
(make-local-variable 'ange-ftp-xfer-size)
(make-local-variable 'ange-ftp-last-percent)
(setq ange-ftp-hash-mark-count 0)
(setq ange-ftp-xfer-size 0)
(setq ange-ftp-process-result-line "")
(setq comint-prompt-regexp "^ftp> ")
(make-local-variable 'comint-password-prompt-regexp)
(setq comint-password-prompt-regexp "^a\\'z")
(make-local-variable 'paragraph-start)
(setq paragraph-start comint-prompt-regexp)))
(defun ange-ftp-smart-login (host user pass account proc)
"Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT.
PROC is the FTP-client's process. This routine uses the smart-gateway
host specified in ``ange-ftp-gateway-host''."
(let ((result (ange-ftp-raw-send-cmd
proc
(format "open %s %s"
(ange-ftp-nslookup-host ange-ftp-gateway-host)
ange-ftp-smart-gateway-port)
(format "Opening FTP connection to %s via %s"
host
ange-ftp-gateway-host))))
(or (car result)
(ange-ftp-error host user
(concat "OPEN request failed: "
(cdr result))))
(setq result (ange-ftp-raw-send-cmd
proc (format "user \"%s\"@%s %s %s"
user
(ange-ftp-nslookup-host host)
pass
account)
(format "Logging in as user %s@%s"
user host)))
(or (car result)
(progn
(ange-ftp-set-passwd host user nil) (ange-ftp-set-account host user nil) (ange-ftp-error host user
(concat "USER request failed: "
(cdr result)))))))
(defun ange-ftp-normal-login (host user pass account proc)
"Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT.
PROC is the process to the FTP-client."
(let* ((nshost (ange-ftp-nslookup-host host))
(result (ange-ftp-raw-send-cmd
proc
(format "open %s" nshost)
(format "Opening FTP connection to %s" host))))
(or (car result)
(ange-ftp-error host user
(concat "OPEN request failed: "
(cdr result))))
(setq result (ange-ftp-raw-send-cmd
proc
(if (and (ange-ftp-use-smart-gateway-p host)
ange-ftp-gateway-host)
(format "user \"%s\"@%s %s %s" user nshost pass account)
(format "user \"%s\" %s %s" user pass account))
(format "Logging in as user %s@%s" user host)))
(or (car result)
(progn
(ange-ftp-set-passwd host user nil) (ange-ftp-set-account host user nil) (ange-ftp-error host user
(concat "USER request failed: "
(cdr result)))))))
(defvar ange-ftp-hash-mark-msgs
"[hH]ash mark [^0-9]*\\([0-9]+\\)"
"*Regexp matching the FTP client's output upon doing a HASH command.")
(defun ange-ftp-guess-hash-mark-size (proc)
(if ange-ftp-send-hash
(save-excursion
(set-buffer (process-buffer proc))
(let* ((status (ange-ftp-raw-send-cmd proc "hash"))
(result (car status))
(line (cdr status)))
(save-match-data
(if (string-match ange-ftp-hash-mark-msgs line)
(let ((size (string-to-int
(substring line
(match-beginning 1)
(match-end 1)))))
(setq ange-ftp-ascii-hash-mark-size size
ange-ftp-hash-mark-unit (ash size -4))
(or ange-ftp-binary-hash-mark-size
(setq ange-ftp-binary-hash-mark-size size)))))))))
(defun ange-ftp-get-process (host user)
"Return an FTP subprocess connected to HOST and logged in as USER.
Create a new process if needed."
(let* ((name (ange-ftp-ftp-process-buffer host user))
(proc (get-process name)))
(if (and proc (memq (process-status proc) '(run open)))
proc
(if proc (delete-process proc))
(let ((pass (ange-ftp-quote-string
(ange-ftp-get-passwd host user)))
(account (ange-ftp-quote-string
(ange-ftp-get-account host user))))
(setq proc (ange-ftp-start-process host user name))
(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))
(ange-ftp-guess-hash-mark-size proc)
(ange-ftp-guess-host-type host user)
(run-hooks 'ange-ftp-process-startup-hook))
proc)))
(defvar ange-ftp-host-cache nil)
(defvar ange-ftp-host-type-cache nil)
(defun ange-ftp-host-type (host &optional user)
"Return a symbol which represents the type of the HOST given.
If the optional argument USER is given, attempts to guess the
host-type by logging in as USER."
(cond ((null host) 'unix)
((eq host ange-ftp-host-cache)
ange-ftp-host-type-cache)
((and user (ange-ftp-get-process host user) (eq host ange-ftp-host-cache))
ange-ftp-host-type-cache)
(t
(setq ange-ftp-host-cache host
ange-ftp-host-type-cache
(cond ((ange-ftp-dumb-unix-host host)
'dumb-unix)
((and (fboundp 'ange-ftp-vms-host)
(ange-ftp-vms-host host))
'vms)
((and (fboundp 'ange-ftp-mts-host)
(ange-ftp-mts-host host))
'mts)
((and (fboundp 'ange-ftp-cms-host)
(ange-ftp-cms-host host))
'cms)
(t
'unix))))))
(defvar ange-ftp-fix-name-func-alist nil
"Alist saying how to convert file name to the host's syntax.
Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
which can change a UNIX file name into a name more suitable for a host of type
TYPE.")
(defvar ange-ftp-fix-dir-name-func-alist nil
"Alist saying how to convert directory name to the host's syntax.
Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
which can change UNIX directory name into a directory name more suitable
for a host of type TYPE.")
(defvar ange-ftp-dumb-host-types '(dumb-unix)
"List of host types that can't take UNIX ls-style listing options.")
(defun ange-ftp-send-cmd (host user cmd &optional msg cont nowait)
"Find an ftp process connected to HOST logged in as USER and send it CMD.
MSG is an optional status message to be output before and after issuing the
command.
See the documentation for ange-ftp-raw-send-cmd for a description of CONT
and NOWAIT."
(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
((null cmd1))
((progn
(setq cmd2 (nth 2 cmd)
host-type (ange-ftp-host-type host user))
(eq cmd0 'dir))
(setq cmd1 (funcall
(or (cdr (assq host-type ange-ftp-fix-dir-name-func-alist))
'identity)
cmd1)
cmd3 (nth 3 cmd))
(and (eq host-type 'unix)
(string-match "/$" cmd1)
(not (string-match "R" cmd3))
(setq cmd1 (concat cmd1 ".")))
(when (string-match " " cmd1)
(ange-ftp-cd host user (nth 1 cmd))
(setq cmd1 "."))
(or (memq host-type ange-ftp-dumb-host-types)
(setq cmd0 'ls
cmd1 (format "\"%s %s\"" cmd3 cmd1))))
((progn
(setq fix-name-func (or (cdr (assq host-type
ange-ftp-fix-name-func-alist))
'identity))
(memq cmd0 '(get delete mkdir rmdir cd)))
(setq cmd1 (funcall fix-name-func cmd1)))
((memq cmd0 '(append put chmod))
(setq cmd2 (funcall fix-name-func cmd2)))
((eq cmd0 'rename)
(setq cmd1 (funcall fix-name-func cmd1)
cmd2 (funcall fix-name-func cmd2))))
(setq cmd0 (symbol-name cmd0))
(setq cmd (concat cmd0
(and cmd1 (concat " " cmd1))
(and cmd2 (concat " " cmd2))))
(let (afsc-result
afsc-line)
(ange-ftp-raw-send-cmd
(ange-ftp-get-process host user)
cmd
msg
(list
(function (lambda (result line host user
cmd msg cont nowait)
(or cont
(setq afsc-result result
afsc-line line))
(if result
(ange-ftp-call-cont cont result line)
(ange-ftp-raw-send-cmd
(ange-ftp-get-process host user)
cmd
msg
(list
(function (lambda (result line cont)
(or cont
(setq afsc-result result
afsc-line line))
(ange-ftp-call-cont cont result line)))
cont)
nowait))))
host user cmd msg cont nowait)
nowait)
(if nowait
nil
(if cont
nil
(cons afsc-result afsc-line))))))
(defconst ange-ftp-cms-name-template
(concat
"^[-A-Z0-9$*][-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?"
"[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?\\.[0-9][0-9][0-9A-Z]$"))
(defconst ange-ftp-vms-name-template
"^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$")
(defconst ange-ftp-mts-name-template
"^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$")
(defun ange-ftp-guess-host-type (host user)
"Guess at the the host type of HOST.
Works by doing a pwd and examining the directory syntax."
(let ((host-type (ange-ftp-host-type host))
(key (concat host "/" user "/~")))
(if (eq host-type 'unix)
(save-match-data
(let* ((result (ange-ftp-get-pwd host user))
(dir (car result))
fix-name-func)
(cond ((null dir)
(message "Warning! Unable to get home directory")
(sit-for 1)
(if (string-match
"^450 No current working directory defined$"
(cdr result))
(progn
(ange-ftp-add-cms-host host)
(setq ange-ftp-host-cache host
ange-ftp-host-type-cache 'cms))))
((string-match ange-ftp-vms-name-template dir)
(ange-ftp-add-vms-host host)
(setq ange-ftp-host-cache host
ange-ftp-host-type-cache 'vms))
((string-match ange-ftp-mts-name-template dir)
(ange-ftp-add-mts-host host)
(setq ange-ftp-host-cache host
ange-ftp-host-type-cache 'mts))
((string-match ange-ftp-cms-name-template dir)
(ange-ftp-add-cms-host host)
(setq ange-ftp-host-cache host
ange-ftp-host-type-cache 'cms))
(t
(setq ange-ftp-host-cache host
ange-ftp-host-type-cache 'unix)))
(let ((ange-ftp-this-user user)
(ange-ftp-this-host host))
(setq fix-name-func (cdr (assq ange-ftp-host-type-cache
ange-ftp-fix-name-func-alist)))
(if fix-name-func
(setq dir (funcall fix-name-func dir 'reverse))))
(ange-ftp-put-hash-entry key dir
ange-ftp-expand-dir-hashtable))))
(if (and (eq host-type 'cms)
(not (ange-ftp-hash-entry-exists-p
key ange-ftp-expand-dir-hashtable)))
(let ((dir (car (ange-ftp-get-pwd host user))))
(if dir
(ange-ftp-put-hash-entry key (concat "/" dir)
ange-ftp-expand-dir-hashtable)
(message "Warning! Unable to get home directory")
(sit-for 1))))))
(defun ange-ftp-dumb-unix-host (host)
(and host ange-ftp-dumb-unix-host-regexp
(save-match-data
(string-match ange-ftp-dumb-unix-host-regexp host))))
(defun ange-ftp-add-dumb-unix-host (host)
"Interactively adds a given HOST to ange-ftp-dumb-unix-host-regexp."
(interactive
(list (read-string "Host: "
(let ((name (or (buffer-file-name) default-directory)))
(and name (car (ange-ftp-ftp-name name)))))))
(if (not (ange-ftp-dumb-unix-host host))
(setq ange-ftp-dumb-unix-host-regexp
(concat "^" (regexp-quote host) "$"
(and ange-ftp-dumb-unix-host-regexp "\\|")
ange-ftp-dumb-unix-host-regexp)
ange-ftp-host-cache nil)))
(defvar ange-ftp-parse-list-func-alist nil
"Alist saying how to parse directory listings for certain OS types.
Association list of \( TYPE \. FUNC \) pairs. The FUNC is a routine
which can parse the output from a DIR listing for a host of type TYPE.")
(defvar ange-ftp-before-parse-ls-hook nil
"Normal hook run before parsing the text of an ftp directory listing.")
(defun ange-ftp-ls (file lsargs parse &optional no-error wildcard)
"Return the output of an `DIR' or `ls' command done over ftp.
FILE is the full name of the remote file, LSARGS is any args to pass to the
`ls' command, and PARSE specifies that the output should be parsed and stored
away in the internal cache."
(let* ((ange-ftp-this-file (ange-ftp-expand-file-name file))
(parsed (ange-ftp-ftp-name ange-ftp-this-file)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
(name (ange-ftp-quote-string (nth 2 parsed)))
(key (directory-file-name ange-ftp-this-file))
(host-type (ange-ftp-host-type host user))
(dumb (memq host-type ange-ftp-dumb-host-types))
result
temp
lscmd parse-func)
(if (string-equal name "")
(setq name
(ange-ftp-real-file-name-as-directory
(ange-ftp-expand-dir host user "~"))))
(if (and ange-ftp-ls-cache-file
(string-equal key ange-ftp-ls-cache-file)
(or dumb (string-equal lsargs ange-ftp-ls-cache-lsargs)))
ange-ftp-ls-cache-res
(setq temp (ange-ftp-make-tmp-name host))
(if wildcard
(progn
(ange-ftp-cd host user (file-name-directory name))
(setq lscmd (list 'dir file temp lsargs)))
(setq lscmd (list 'dir name temp lsargs)))
(unwind-protect
(if (car (setq result (ange-ftp-send-cmd
host
user
lscmd
(format "Listing %s"
(ange-ftp-abbreviate-filename
ange-ftp-this-file)))))
(save-excursion
(set-buffer (get-buffer-create
ange-ftp-data-buffer-name))
(erase-buffer)
(if (ange-ftp-real-file-readable-p temp)
(ange-ftp-real-insert-file-contents temp)
(sleep-for ange-ftp-retry-time)
(if (ange-ftp-real-file-readable-p temp)
(ange-ftp-real-insert-file-contents temp)
(ange-ftp-error host user
(format
"list data file %s not readable"
temp))))
(run-hooks 'ange-ftp-before-parse-ls-hook)
(if parse
(ange-ftp-set-files
ange-ftp-this-file
(if (setq
parse-func
(cdr (assq host-type
ange-ftp-parse-list-func-alist)))
(funcall parse-func)
(ange-ftp-parse-dired-listing lsargs))))
(setq ange-ftp-ls-cache-file key
ange-ftp-ls-cache-lsargs lsargs
ange-ftp-ls-cache-res (buffer-string))
ange-ftp-ls-cache-res)
(if no-error
nil
(ange-ftp-error host user
(concat "DIR failed: " (cdr result)))))
(ange-ftp-del-tmp-name temp))))
(error "Should never happen. Please report. Bug ref. no.: 1"))))
(defconst ange-ftp-date-regexp
(let* ((l "\\([A-Za-z]\\|[^\0-\177]\\)")
(month (concat l l "+ *"))
(k "[^\0-\177]")
(s " ")
(mm "[ 0-1][0-9]")
(dd "[ 0-3][0-9]")
(western (concat "\\(" month s dd "\\|" dd s month "\\)"))
(japanese (concat mm k s dd k)))
(concat "[0-9]" s "\\(" western "\\|" japanese "\\)" s))
"Regular expression to match up to the column before the file name in a
directory listing. This regular expression is designed to recognize dates
regardless of the language.")
(defvar ange-ftp-add-file-entry-alist nil
"Alist saying how to add file entries on certain OS types.
Association list of pairs \( TYPE \. FUNC \), where FUNC
is a function to be used to add a file entry for the OS TYPE. The
main reason for this alist is to deal with file versions in VMS.")
(defvar ange-ftp-delete-file-entry-alist nil
"Alist saying how to delete files on certain OS types.
Association list of pairs \( TYPE \. FUNC \), where FUNC
is a function to be used to delete a file entry for the OS TYPE.
The main reason for this alist is to deal with file versions in VMS.")
(defun ange-ftp-add-file-entry (name &optional dir-p)
"Add a file entry for file NAME, if its directory info exists."
(funcall (or (cdr (assq (ange-ftp-host-type
(car (ange-ftp-ftp-name name)))
ange-ftp-add-file-entry-alist))
'ange-ftp-internal-add-file-entry)
name dir-p)
(setq ange-ftp-ls-cache-file nil))
(defun ange-ftp-delete-file-entry (name &optional dir-p)
"Delete the file entry for file NAME, if its directory info exists."
(funcall (or (cdr (assq (ange-ftp-host-type
(car (ange-ftp-ftp-name name)))
ange-ftp-delete-file-entry-alist))
'ange-ftp-internal-delete-file-entry)
name dir-p)
(setq ange-ftp-ls-cache-file nil))
(defmacro ange-ftp-parse-filename ()
(` (let ((eol (progn (end-of-line) (point))))
(beginning-of-line)
(if (re-search-forward ange-ftp-date-regexp eol t)
(progn
(skip-chars-forward " ")
(skip-chars-forward "^ " eol)
(skip-chars-forward " " eol)
(buffer-substring (point) eol))))))
(defmacro ange-ftp-ls-parser ()
(` (let ((tbl (ange-ftp-make-hashtable))
(used-F (and (stringp switches)
(string-match "F" switches)))
file-type symlink directory file)
(while (setq file (ange-ftp-parse-filename))
(beginning-of-line)
(skip-chars-forward "\t 0-9")
(setq file-type (following-char)
directory (eq file-type ?d))
(if (eq file-type ?l)
(if (string-match " -> " file)
(setq symlink (substring file (match-end 0))
file (substring file 0 (match-beginning 0)))
(setq symlink ""))
(setq symlink nil))
(if (and used-F
(not (string-equal file ""))
(looking-at
".[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)"))
(let ((socket (eq file-type ?s))
(executable
(and (not symlink) (string-match "[xst]"
(concat
(buffer-substring
(match-beginning 1)
(match-end 1))
(buffer-substring
(match-beginning 2)
(match-end 2))
(buffer-substring
(match-beginning 3)
(match-end 3)))))))
(if (or (and symlink (string-match "@$" file))
(and directory (string-match "/$" file))
(and executable (string-match "*$" file))
(and socket (string-match "=$" file)))
(setq file (substring file 0 -1)))))
(ange-ftp-put-hash-entry file (or symlink directory) tbl)
(forward-line 1))
(ange-ftp-put-hash-entry "." t tbl)
(ange-ftp-put-hash-entry ".." t tbl)
tbl)))
(defvar ange-ftp-dl-dir-regexp nil
"Regexp matching directories which are listed in dl format.
This regexp should not be anchored with a trailing `$', because it should
match subdirectories as well.")
(defun ange-ftp-add-dl-dir (dir)
"Interactively adds a DIR to ange-ftp-dl-dir-regexp."
(interactive
(list (read-string "Directory: "
(let ((name (or (buffer-file-name) default-directory)))
(and name (ange-ftp-ftp-name name)
(file-name-directory name))))))
(if (not (and ange-ftp-dl-dir-regexp
(string-match ange-ftp-dl-dir-regexp dir)))
(setq ange-ftp-dl-dir-regexp
(concat "^" (regexp-quote dir)
(and ange-ftp-dl-dir-regexp "\\|")
ange-ftp-dl-dir-regexp))))
(defmacro ange-ftp-dl-parser ()
(` (let ((tbl (ange-ftp-make-hashtable)))
(while (not (eobp))
(ange-ftp-put-hash-entry
(buffer-substring (point)
(progn
(skip-chars-forward "^ /\n")
(point)))
(eq (following-char) ?/)
tbl)
(forward-line 1))
(ange-ftp-put-hash-entry "." t tbl)
(ange-ftp-put-hash-entry ".." t tbl)
tbl)))
(defun ange-ftp-parse-dired-listing (&optional switches)
(save-match-data
(cond
((looking-at "^total [0-9]+$")
(forward-line 1)
(if (eolp) (forward-line 1))
(ange-ftp-ls-parser))
((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'")
nil)
((eobp) nil)
((re-search-forward ange-ftp-date-regexp nil t)
(beginning-of-line)
(ange-ftp-ls-parser))
((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t)
(ange-ftp-add-dl-dir ange-ftp-this-file)
(beginning-of-line)
(ange-ftp-dl-parser))
(t nil))))
(defun ange-ftp-set-files (directory files)
"For a given DIRECTORY, set or change the associated FILES hashtable."
(and files (ange-ftp-put-hash-entry (file-name-as-directory directory)
files ange-ftp-files-hashtable)))
(defun ange-ftp-get-files (directory &optional no-error)
"Given a given DIRECTORY, return a hashtable of file entries.
This will give an error or return nil, depending on the value of
NO-ERROR, if a listing for DIRECTORY cannot be obtained."
(setq directory (file-name-as-directory directory)) (or (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable)
(save-match-data
(and (ange-ftp-ls directory
(if (and (boundp 'dired-actual-switches)
(stringp dired-actual-switches)
(string-match
"[aA]" dired-actual-switches)
(string-match
"l" dired-actual-switches)
(not (string-match
"R" dired-actual-switches)))
dired-actual-switches
(if (and (boundp 'dired-listing-switches)
(stringp dired-listing-switches)
(string-match
"[aA]" dired-listing-switches)
(string-match
"l" dired-listing-switches)
(not (string-match
"R" dired-listing-switches)))
dired-listing-switches
"-al"))
t no-error)
(ange-ftp-get-hash-entry
directory ange-ftp-files-hashtable)))))
(defmacro ange-ftp-get-file-part (name)
(` (let ((file (file-name-nondirectory (, name))))
(if (string-equal file "")
"."
file))))
(defmacro ange-ftp-allow-child-lookup (dir file)
(` (not
(let* ((efile (, file)) (edir (, dir))
(parsed (ange-ftp-ftp-name edir))
(host-type (ange-ftp-host-type
(car parsed))))
(or
(and (boundp 'dired-local-variables-file) (stringp dired-local-variables-file)
(string-equal dired-local-variables-file efile))
(and (eq host-type 'vms)
(string-match "\\." efile))
(and (memq host-type '(mts cms))
(not (string-equal "/" (nth 2 parsed)))))))))
(defun ange-ftp-file-entry-p (name)
"Given NAME, return whether there is a file entry for it."
(let* ((name (directory-file-name name))
(dir (file-name-directory name))
(ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable))
(file (ange-ftp-get-file-part name)))
(if ent
(ange-ftp-hash-entry-exists-p file ent)
(or (and (ange-ftp-allow-child-lookup dir file)
(setq ent (ange-ftp-get-files name t))
(ange-ftp-get-hash-entry "." ent))
(let ((table (ange-ftp-get-files dir)))
(and table
(ange-ftp-hash-entry-exists-p file
table)))))))
(defun ange-ftp-get-file-entry (name)
"Given NAME, return the given file entry.
The entry will be either t for a directory, nil for a normal file,
or a string for a symlink. If the file isn't in the hashtable,
this also returns nil."
(let* ((name (directory-file-name name))
(dir (file-name-directory name))
(ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable))
(file (ange-ftp-get-file-part name)))
(if ent
(ange-ftp-get-hash-entry file ent)
(or (and (ange-ftp-allow-child-lookup dir file)
(setq ent (ange-ftp-get-files name t))
(ange-ftp-get-hash-entry "." ent))
(ange-ftp-get-hash-entry file
(ange-ftp-get-files dir))))))
(defun ange-ftp-internal-delete-file-entry (name &optional dir-p)
(if dir-p
(progn
(setq name (file-name-as-directory name))
(ange-ftp-del-hash-entry name ange-ftp-files-hashtable)
(setq name (directory-file-name name))))
(let ((files (ange-ftp-get-hash-entry (file-name-directory name)
ange-ftp-files-hashtable)))
(if files
(ange-ftp-del-hash-entry (ange-ftp-get-file-part name)
files))))
(defun ange-ftp-internal-add-file-entry (name &optional dir-p)
(and dir-p
(setq name (directory-file-name name)))
(let ((files (ange-ftp-get-hash-entry (file-name-directory name)
ange-ftp-files-hashtable)))
(if files
(ange-ftp-put-hash-entry (ange-ftp-get-file-part name)
dir-p
files))))
(defun ange-ftp-wipe-file-entries (host user)
"Get rid of entry for HOST, USER pair from file entry information hashtable."
(let ((new-tbl (ange-ftp-make-hashtable (length ange-ftp-files-hashtable))))
(ange-ftp-map-hashtable
(function
(lambda (key val)
(let ((parsed (ange-ftp-ftp-name key)))
(if parsed
(let ((h (nth 0 parsed))
(u (nth 1 parsed)))
(or (and (equal host h) (equal user u))
(ange-ftp-put-hash-entry key val new-tbl)))))))
ange-ftp-files-hashtable)
(setq ange-ftp-files-hashtable new-tbl)))
(defun ange-ftp-set-binary-mode (host user)
"Tell the ftp process for the given HOST & USER to switch to binary mode."
(let ((result (ange-ftp-send-cmd host user '(type "binary"))))
(if (not (car result))
(ange-ftp-error host user (concat "BINARY failed: " (cdr result)))
(save-excursion
(set-buffer (process-buffer (ange-ftp-get-process host user)))
(and ange-ftp-binary-hash-mark-size
(setq ange-ftp-hash-mark-unit
(ash ange-ftp-binary-hash-mark-size -4)))))))
(defun ange-ftp-set-ascii-mode (host user)
"Tell the ftp process for the given HOST & USER to switch to ascii mode."
(let ((result (ange-ftp-send-cmd host user '(type "ascii"))))
(if (not (car result))
(ange-ftp-error host user (concat "ASCII failed: " (cdr result)))
(save-excursion
(set-buffer (process-buffer (ange-ftp-get-process host user)))
(and ange-ftp-ascii-hash-mark-size
(setq ange-ftp-hash-mark-unit
(ash ange-ftp-ascii-hash-mark-size -4)))))))
(defun ange-ftp-cd (host user dir)
(let ((result (ange-ftp-send-cmd host user (list 'cd dir) "Doing CD")))
(or (car result)
(ange-ftp-error host user (concat "CD failed: " (cdr result))))))
(defun ange-ftp-get-pwd (host user)
"Attempts to get the current working directory for the given HOST/USER pair.
Returns \( DIR . LINE \) where DIR is either the directory or nil if not found,
and LINE is the relevant success or fail line from the FTP-client."
(let* ((result (ange-ftp-send-cmd host user '(pwd) "Getting PWD"))
(line (cdr result))
dir)
(if (car result)
(save-match-data
(and (or (string-match "\"\\([^\"]*\\)\"" line)
(string-match " \\([^ ]+\\) " line)) (setq dir (substring line
(match-beginning 1)
(match-end 1))))))
(cons dir line)))
(defun ange-ftp-expand-dir (host user dir)
"Return the result of doing a PWD in the current FTP session.
Use the connection to machine HOST
logged in as user USER and cd'd to directory DIR."
(let* ((host-type (ange-ftp-host-type host user))
(fix-name-func
(cdr (assq host-type ange-ftp-fix-name-func-alist)))
(key (concat host "/" user "/" dir))
(res (ange-ftp-get-hash-entry key ange-ftp-expand-dir-hashtable)))
(or res
(progn
(or
(string-equal user "anonymous")
(string-equal user "ftp")
(not (eq host-type 'unix))
(let* ((ange-ftp-good-msgs (concat ange-ftp-expand-dir-regexp
"\\|"
ange-ftp-good-msgs))
(result (ange-ftp-send-cmd host user
(list 'get dir null-device)
(format "expanding %s" dir)))
(line (cdr result)))
(setq res
(if (string-match ange-ftp-expand-dir-regexp line)
(substring line
(match-beginning 1)
(match-end 1))))))
(or res
(if (string-equal dir "~")
(setq res (car (ange-ftp-get-pwd host user)))
(let ((home (ange-ftp-expand-dir host user "~")))
(unwind-protect
(and (ange-ftp-cd host user dir)
(setq res (car (ange-ftp-get-pwd host user))))
(ange-ftp-cd host user home)))))
(if res
(let ((ange-ftp-this-user user)
(ange-ftp-this-host host))
(if fix-name-func
(setq res (funcall fix-name-func res 'reverse)))
(ange-ftp-put-hash-entry
key res ange-ftp-expand-dir-hashtable)))
res))))
(defun ange-ftp-canonize-filename (n)
"Take a string and short-circuit //, /. and /.."
(if (string-match "[^:]+//" n) (setq n (substring n (1- (match-end 0)))))
(let ((parsed (ange-ftp-ftp-name n)))
(if parsed
(let ((host (car parsed))
(user (nth 1 parsed))
(name (nth 2 parsed)))
(cond ((string-match "^/" name)
name)
((string-match "^~[^/]*" name)
(let* ((tilda (substring name
(match-beginning 0)
(match-end 0)))
(rest (substring name (match-end 0)))
(dir (ange-ftp-expand-dir host user tilda)))
(if dir
(setq name (concat dir rest))
(error "User \"%s\" is not known"
(substring tilda 1)))))
(t
(let ((dir (ange-ftp-expand-dir host user "~")))
(if dir
(setq name (concat
(ange-ftp-real-file-name-as-directory dir)
name))
(error "Unable to obtain CWD")))))
(if (not (string-match "^//" name))
(progn
(if (not (eq system-type 'windows-nt))
(setq name (ange-ftp-real-expand-file-name name))
(if (string-match "^//" default-directory)
(setq name (ange-ftp-real-expand-file-name name "c:/"))
(setq name (ange-ftp-real-expand-file-name name)))
(if (string-match "^[a-zA-Z]:" name)
(setq name (substring name 2))))
(if (string-match "^//" name)
(setq name (substring name 1)))))
(ange-ftp-replace-name-component n name))
(if (eq (string-to-char n) ?/)
(ange-ftp-real-expand-file-name n)
(ange-ftp-real-expand-file-name
(ange-ftp-real-file-name-nondirectory n)
(ange-ftp-real-file-name-directory n))))))
(defun ange-ftp-expand-file-name (name &optional default)
"Documented as original."
(save-match-data
(setq default (or default default-directory))
(cond ((eq (string-to-char name) ?~)
(ange-ftp-real-expand-file-name name))
((eq (string-to-char name) ?/)
(ange-ftp-canonize-filename name))
((and (eq system-type 'windows-nt)
(eq (string-to-char name) ?\\))
(ange-ftp-canonize-filename name))
((and (eq system-type 'windows-nt)
(or (string-match "^[a-zA-Z]:" name)
(string-match "^[a-zA-Z]:" default)))
(ange-ftp-real-expand-file-name name default))
((zerop (length name))
(ange-ftp-canonize-filename default))
((ange-ftp-canonize-filename
(concat (file-name-as-directory default) name))))))
(defvar ange-ftp-file-name-as-directory-alist nil
"Association list of \( TYPE \. FUNC \) pairs.
FUNC converts a filename to a directory name for the operating
system TYPE.")
(defun ange-ftp-file-name-as-directory (name)
"Documented as original."
(let ((parsed (ange-ftp-ftp-name name)))
(if parsed
(if (string-equal (nth 2 parsed) "")
name
(funcall (or (cdr (assq
(ange-ftp-host-type (car parsed))
ange-ftp-file-name-as-directory-alist))
'ange-ftp-real-file-name-as-directory)
name))
(ange-ftp-real-file-name-as-directory name))))
(defun ange-ftp-file-name-directory (name)
"Documented as original."
(let ((parsed (ange-ftp-ftp-name name)))
(if parsed
(let ((filename (nth 2 parsed)))
(if (save-match-data
(string-match "^~[^/]*$" filename))
name
(ange-ftp-replace-name-component
name
(ange-ftp-real-file-name-directory filename))))
(ange-ftp-real-file-name-directory name))))
(defun ange-ftp-file-name-nondirectory (name)
"Documented as original."
(let ((parsed (ange-ftp-ftp-name name)))
(if parsed
(let ((filename (nth 2 parsed)))
(if (save-match-data
(string-match "^~[^/]*$" filename))
""
(ange-ftp-real-file-name-nondirectory name)))
(ange-ftp-real-file-name-nondirectory name))))
(defun ange-ftp-directory-file-name (dir)
"Documented as original."
(let ((parsed (ange-ftp-ftp-name dir)))
(if parsed
(ange-ftp-replace-name-component
dir
(ange-ftp-real-directory-file-name (nth 2 parsed)))
(ange-ftp-real-directory-file-name dir))))
(defun ange-ftp-binary-file (file)
(save-match-data
(string-match ange-ftp-binary-file-name-regexp file)))
(defun ange-ftp-write-region (start end filename &optional append visit)
(setq filename (expand-file-name filename))
(let ((parsed (ange-ftp-ftp-name filename)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
(name (ange-ftp-quote-string (nth 2 parsed)))
(temp (ange-ftp-make-tmp-name host))
(binary (or (ange-ftp-binary-file filename)
(memq (ange-ftp-host-type host user)
'(unix dumb-unix))))
(cmd (if append 'append 'put))
(abbr (ange-ftp-abbreviate-filename filename))
(coding-system-used last-coding-system-used))
(unwind-protect
(progn
(let ((executing-kbd-macro t)
(filename (buffer-file-name))
(mod-p (buffer-modified-p)))
(unwind-protect
(ange-ftp-real-write-region start end temp nil visit)
(setq buffer-file-name filename)
(set-buffer-modified-p mod-p)))
(setq coding-system-used last-coding-system-used)
(if binary
(ange-ftp-set-binary-mode host user))
(let ((attr (file-attributes temp)))
(if attr
(ange-ftp-set-xfer-size host user (nth 7 attr))))
(let ((result (ange-ftp-send-cmd host user
(list cmd temp name)
(format "Writing %s" abbr))))
(or (car result)
(signal 'ftp-error
(list
"Opening output file"
(format "FTP Error: \"%s\"" (cdr result))
filename)))))
(ange-ftp-del-tmp-name temp)
(if binary
(ange-ftp-set-ascii-mode host user)))
(if (eq visit t)
(progn
(set-visited-file-modtime '(0 0))
(ange-ftp-set-buffer-mode)
(setq buffer-file-name filename)
(set-buffer-modified-p nil)))
(setq last-coding-system-used coding-system-used)
(ange-ftp-message "Wrote %s" abbr)
(ange-ftp-add-file-entry filename))
(ange-ftp-real-write-region start end filename append visit))))
(defun ange-ftp-insert-file-contents (filename &optional visit beg end replace)
(barf-if-buffer-read-only)
(setq filename (expand-file-name filename))
(let ((parsed (ange-ftp-ftp-name filename)))
(if parsed
(progn
(if visit
(setq buffer-file-name filename))
(if (or (file-exists-p filename)
(progn
(setq ange-ftp-ls-cache-file nil)
(ange-ftp-del-hash-entry (file-name-directory filename)
ange-ftp-files-hashtable)
(file-exists-p filename)))
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
(name (ange-ftp-quote-string (nth 2 parsed)))
(temp (ange-ftp-make-tmp-name host))
(binary (or (ange-ftp-binary-file filename)
(memq (ange-ftp-host-type host user)
'(unix dumb-unix))))
(abbr (ange-ftp-abbreviate-filename filename))
(coding-system-used last-coding-system-used)
size)
(unwind-protect
(progn
(if binary
(ange-ftp-set-binary-mode host user))
(let ((result (ange-ftp-send-cmd host user
(list 'get name temp)
(format "Retrieving %s" abbr))))
(or (car result)
(signal 'ftp-error
(list
"Opening input file"
(format "FTP Error: \"%s\"" (cdr result))
filename))))
(if (or (ange-ftp-real-file-readable-p temp)
(sleep-for ange-ftp-retry-time)
(ange-ftp-real-file-readable-p temp))
(setq
size
(nth 1 (ange-ftp-real-insert-file-contents
temp visit beg end replace))
coding-system-used last-coding-system-used
buffer-file-type binary)
(signal 'ftp-error
(list
"Opening input file:"
(format
"FTP Error: %s not arrived or readable"
filename)))))
(if binary
(ange-ftp-set-ascii-mode host user))
(ange-ftp-del-tmp-name temp))
(if visit
(progn
(set-visited-file-modtime '(0 0))
(setq buffer-file-name filename)))
(setq last-coding-system-used coding-system-used)
(list filename size))
(signal 'file-error
(list
"Opening input file"
filename))))
(ange-ftp-real-insert-file-contents filename visit beg end replace))))
(defun ange-ftp-expand-symlink (file dir)
(if (file-name-absolute-p file)
(ange-ftp-replace-name-component dir file)
(expand-file-name file dir)))
(defun ange-ftp-file-symlink-p (file)
(setq file (ange-ftp-expand-file-name file))
(if (ange-ftp-ftp-name file)
(let ((file-ent
(ange-ftp-get-hash-entry
(ange-ftp-get-file-part file)
(ange-ftp-get-files (file-name-directory file)))))
(if (stringp file-ent)
(if (file-name-absolute-p file-ent)
(ange-ftp-replace-name-component
(file-name-directory file) file-ent)
file-ent)))
(ange-ftp-real-file-symlink-p file)))
(defun ange-ftp-file-exists-p (name)
(setq name (expand-file-name name))
(if (ange-ftp-ftp-name name)
(if (ange-ftp-file-entry-p name)
(let ((file-ent (ange-ftp-get-file-entry name)))
(if (stringp file-ent)
(file-exists-p
(ange-ftp-expand-symlink file-ent
(file-name-directory
(directory-file-name name))))
t)))
(ange-ftp-real-file-exists-p name)))
(defun ange-ftp-file-directory-p (name)
(setq name (expand-file-name name))
(if (ange-ftp-ftp-name name)
(let ((file-ent (ange-ftp-get-file-entry
(ange-ftp-file-name-as-directory name))))
(if (stringp file-ent)
(file-directory-p
(ange-ftp-expand-symlink file-ent
(file-name-directory
(directory-file-name name))))
file-ent))
(ange-ftp-real-file-directory-p name)))
(defun ange-ftp-directory-files (directory &optional full match
&rest v19-args)
(setq directory (expand-file-name directory))
(if (ange-ftp-ftp-name directory)
(progn
(ange-ftp-barf-if-not-directory directory)
(let ((tail (ange-ftp-hash-table-keys
(ange-ftp-get-files directory)))
files f)
(setq directory (file-name-as-directory directory))
(save-match-data
(while tail
(setq f (car tail)
tail (cdr tail))
(if (or (not match) (string-match match f))
(setq files
(cons (if full (concat directory f) f) files)))))
(nreverse files)))
(apply 'ange-ftp-real-directory-files directory full match v19-args)))
(defun ange-ftp-file-attributes (file)
(setq file (expand-file-name file))
(let ((parsed (ange-ftp-ftp-name file)))
(if parsed
(let ((part (ange-ftp-get-file-part file))
(files (ange-ftp-get-files (file-name-directory file))))
(if (ange-ftp-hash-entry-exists-p part files)
(let ((host (nth 0 parsed))
(user (nth 1 parsed))
(name (nth 2 parsed))
(dirp (ange-ftp-get-hash-entry part files))
(inode (ange-ftp-get-hash-entry
file ange-ftp-inodes-hashtable)))
(unless inode
(setq inode ange-ftp-next-inode-number
ange-ftp-next-inode-number (1+ inode))
(ange-ftp-put-hash-entry file inode ange-ftp-inodes-hashtable))
(list (if (and (stringp dirp) (file-name-absolute-p dirp))
(ange-ftp-expand-symlink dirp
(file-name-directory file))
dirp) -1 -1 -1 '(0 0) '(0 0) '(0 0) -1 (concat (if (stringp dirp) "l" (if dirp "d" "-"))
"?????????") nil inode -1 ))))
(ange-ftp-real-file-attributes file))))
(defun ange-ftp-file-writable-p (file)
(setq file (expand-file-name file))
(if (ange-ftp-ftp-name file)
(or (file-exists-p file) (file-directory-p (file-name-directory file)))
(ange-ftp-real-file-writable-p file)))
(defun ange-ftp-file-readable-p (file)
(setq file (expand-file-name file))
(if (ange-ftp-ftp-name file)
(file-exists-p file)
(ange-ftp-real-file-readable-p file)))
(defun ange-ftp-file-executable-p (file)
(setq file (expand-file-name file))
(if (ange-ftp-ftp-name file)
(file-exists-p file)
(ange-ftp-real-file-executable-p file)))
(defun ange-ftp-delete-file (file)
(interactive "fDelete file: ")
(setq file (expand-file-name file))
(let ((parsed (ange-ftp-ftp-name file)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
(name (ange-ftp-quote-string (nth 2 parsed)))
(abbr (ange-ftp-abbreviate-filename file))
(result (ange-ftp-send-cmd host user
(list 'delete name)
(format "Deleting %s" abbr))))
(or (car result)
(signal 'ftp-error
(list
"Removing old name"
(format "FTP Error: \"%s\"" (cdr result))
file)))
(ange-ftp-delete-file-entry file))
(ange-ftp-real-delete-file file))))
(defun ange-ftp-verify-visited-file-modtime (buf)
(let ((name (buffer-file-name buf)))
(if (and (stringp name) (ange-ftp-ftp-name name))
t
(ange-ftp-real-verify-visited-file-modtime buf))))
(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-file-internal (filename newname ok-if-already-exists
keep-date &optional msg cont nowait)
(setq filename (expand-file-name filename)
newname (expand-file-name newname))
(if (file-directory-p newname)
(setq newname (expand-file-name (file-name-nondirectory filename) newname)))
(let ((f-parsed (ange-ftp-ftp-name filename))
(t-parsed (ange-ftp-ftp-name newname)))
(if (and (not f-parsed) (not t-parsed))
(progn
(ange-ftp-real-copy-file filename newname ok-if-already-exists
keep-date)
(if cont
(ange-ftp-call-cont cont t "Copied locally")))
(let* ((f-host (and f-parsed (nth 0 f-parsed)))
(f-user (and f-parsed (nth 1 f-parsed)))
(f-name (and f-parsed (ange-ftp-quote-string (nth 2 f-parsed))))
(f-abbr (ange-ftp-abbreviate-filename filename))
(t-host (and t-parsed (nth 0 t-parsed)))
(t-user (and t-parsed (nth 1 t-parsed)))
(t-name (and t-parsed (ange-ftp-quote-string (nth 2 t-parsed))))
(t-abbr (ange-ftp-abbreviate-filename newname filename))
(binary (or (ange-ftp-binary-file filename)
(ange-ftp-binary-file newname)
(and (memq (ange-ftp-host-type f-host f-user)
'(unix dumb-unix))
(memq (ange-ftp-host-type t-host t-user)
'(unix dumb-unix)))))
temp1
temp2)
(if (or (not ok-if-already-exists)
(numberp ok-if-already-exists))
(ange-ftp-barf-or-query-if-file-exists newname "copy to it"
(numberp ok-if-already-exists)))
(if f-parsed
(progn
(if (or (ange-ftp-use-gateway-p f-host)
t-parsed)
(setq temp1 (ange-ftp-make-tmp-name f-host)))
(if binary
(ange-ftp-set-binary-mode f-host f-user))
(ange-ftp-send-cmd
f-host
f-user
(list 'get f-name (or temp1 newname))
(or msg
(if (and temp1 t-parsed)
(format "Getting %s" f-abbr)
(format "Copying %s to %s" f-abbr t-abbr)))
(list (function ange-ftp-cf1)
filename newname binary msg
f-parsed f-host f-user f-name f-abbr
t-parsed t-host t-user t-name t-abbr
temp1 temp2 cont nowait)
nowait))
(ange-ftp-cf1 t nil
filename newname binary msg
f-parsed f-host f-user f-name f-abbr
t-parsed t-host t-user t-name t-abbr
nil nil cont nowait))))))
(defvar ange-ftp-waiting-flag nil)
(defun ange-ftp-cf1 (result line
filename newname binary msg
f-parsed f-host f-user f-name f-abbr
t-parsed t-host t-user t-name t-abbr
temp1 temp2 cont nowait)
(if line
(unwind-protect
(or result
(progn
(and temp1 (ange-ftp-del-tmp-name temp1))
(or cont
(if ange-ftp-waiting-flag
(throw 'ftp-error t)
(signal 'ftp-error
(list "Opening input file"
(format "FTP Error: \"%s\"" line)
filename))))))
(if binary
(ange-ftp-set-ascii-mode f-host f-user))))
(if result
(if t-parsed
(progn
(if (ange-ftp-use-gateway-p t-host)
(setq temp2 (ange-ftp-make-tmp-name t-host)))
(if temp1
(if temp2
(if (string-equal temp1 temp2)
(setq temp1 nil)
(ange-ftp-real-copy-file temp1 temp2 t))
(setq temp2 temp1 temp1 nil))
(if temp2
(ange-ftp-real-copy-file filename temp2 t)))
(if binary
(ange-ftp-set-binary-mode t-host t-user))
(let ((attr (file-attributes (or temp2 filename))))
(if attr
(ange-ftp-set-xfer-size t-host t-user (nth 7 attr))))
(ange-ftp-send-cmd
t-host
t-user
(list 'put (or temp2 filename) t-name)
(or msg
(if (and temp2 f-parsed)
(format "Putting %s" newname)
(format "Copying %s to %s" f-abbr t-abbr)))
(list (function ange-ftp-cf2)
newname t-host t-user binary temp1 temp2 cont)
nowait))
(ange-ftp-cf2 t nil newname t-host t-user binary temp1 temp2 cont))
(ange-ftp-call-cont cont result line)))
(defun ange-ftp-cf2 (result line newname t-host t-user binary temp1 temp2 cont)
(unwind-protect
(if line
(unwind-protect
(progn
(or result
(or cont
(if ange-ftp-waiting-flag
(throw 'ftp-error t)
(signal 'ftp-error
(list "Opening output file"
(format "FTP Error: \"%s\"" line)
newname)))))
(ange-ftp-add-file-entry newname))
(if binary
(ange-ftp-set-ascii-mode t-host t-user)))
(if temp1
(ange-ftp-real-copy-file temp1 newname t)))
(and temp1 (ange-ftp-del-tmp-name temp1))
(and temp2 (ange-ftp-del-tmp-name temp2))
(ange-ftp-call-cont cont result line)))
(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists
keep-date)
(interactive "fCopy file: \nFCopy %s to file: \np")
(ange-ftp-copy-file-internal filename
newname
ok-if-already-exists
keep-date
nil
nil
(interactive-p)))
(defun ange-ftp-rename-remote-to-remote (filename newname f-parsed t-parsed)
"Rename remote file FILE to remote file NEWNAME."
(let ((f-host (nth 0 f-parsed))
(f-user (nth 1 f-parsed))
(t-host (nth 0 t-parsed))
(t-user (nth 1 t-parsed)))
(if (and (string-equal f-host t-host)
(string-equal f-user t-user))
(let* ((f-name (ange-ftp-quote-string (nth 2 f-parsed)))
(t-name (ange-ftp-quote-string (nth 2 t-parsed)))
(cmd (list 'rename f-name t-name))
(fabbr (ange-ftp-abbreviate-filename filename))
(nabbr (ange-ftp-abbreviate-filename newname filename))
(result (ange-ftp-send-cmd f-host f-user cmd
(format "Renaming %s to %s"
fabbr
nabbr))))
(or (car result)
(signal 'ftp-error
(list
"Renaming"
(format "FTP Error: \"%s\"" (cdr result))
filename
newname)))
(ange-ftp-add-file-entry newname)
(ange-ftp-delete-file-entry filename))
(ange-ftp-copy-file-internal filename newname t nil)
(delete-file filename))))
(defun ange-ftp-rename-local-to-remote (filename newname)
"Rename local FILENAME to remote file NEWNAME."
(let* ((fabbr (ange-ftp-abbreviate-filename filename))
(nabbr (ange-ftp-abbreviate-filename newname filename))
(msg (format "Renaming %s to %s" fabbr nabbr)))
(ange-ftp-copy-file-internal filename newname t nil msg)
(let (ange-ftp-process-verbose)
(delete-file filename))))
(defun ange-ftp-rename-remote-to-local (filename newname)
"Rename remote file FILENAME to local file NEWNAME."
(let* ((fabbr (ange-ftp-abbreviate-filename filename))
(nabbr (ange-ftp-abbreviate-filename newname filename))
(msg (format "Renaming %s to %s" fabbr nabbr)))
(ange-ftp-copy-file-internal filename newname t nil msg)
(let (ange-ftp-process-verbose)
(delete-file filename))))
(defun ange-ftp-rename-file (filename newname &optional ok-if-already-exists)
(interactive "fRename file: \nFRename %s to file: \np")
(setq filename (expand-file-name filename))
(setq newname (expand-file-name newname))
(let* ((f-parsed (ange-ftp-ftp-name filename))
(t-parsed (ange-ftp-ftp-name newname)))
(if (and (or f-parsed t-parsed)
(or (not ok-if-already-exists)
(numberp ok-if-already-exists)))
(ange-ftp-barf-or-query-if-file-exists
newname
"rename to it"
(numberp ok-if-already-exists)))
(if f-parsed
(if t-parsed
(ange-ftp-rename-remote-to-remote filename newname f-parsed
t-parsed)
(ange-ftp-rename-remote-to-local filename newname))
(if t-parsed
(ange-ftp-rename-local-to-remote filename newname)
(ange-ftp-real-rename-file filename newname ok-if-already-exists)))))
(defun ange-ftp-file-entry-active-p (sym)
(let ((val (get sym 'val)))
(or (not (stringp val))
(file-exists-p (ange-ftp-expand-symlink val ange-ftp-this-dir)))))
(defun ange-ftp-file-entry-not-ignored-p (sym)
(let ((val (get sym 'val))
(symname (symbol-name sym)))
(if (stringp val)
(let ((file (ange-ftp-expand-symlink val ange-ftp-this-dir)))
(or (file-directory-p file)
(and (file-exists-p file)
(not (string-match ange-ftp-completion-ignored-pattern
symname)))))
(or val (not (string-match ange-ftp-completion-ignored-pattern symname))))))
(defun ange-ftp-file-name-all-completions (file dir)
(let ((ange-ftp-this-dir (expand-file-name dir)))
(if (ange-ftp-ftp-name ange-ftp-this-dir)
(progn
(ange-ftp-barf-if-not-directory ange-ftp-this-dir)
(setq ange-ftp-this-dir
(ange-ftp-real-file-name-as-directory ange-ftp-this-dir))
(let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))
(completions
(all-completions file tbl
(function ange-ftp-file-entry-active-p))))
(mapcar
(function
(lambda (file)
(let ((ent (ange-ftp-get-hash-entry file tbl)))
(if (and ent
(or (not (stringp ent))
(file-directory-p
(ange-ftp-expand-symlink ent
ange-ftp-this-dir))))
(concat file "/")
file))))
completions)))
(if (or (and (eq system-type 'windows-nt)
(string-match "^[a-zA-Z]:[/\\]$" ange-ftp-this-dir))
(string-equal "/" ange-ftp-this-dir))
(nconc (all-completions file (ange-ftp-generate-root-prefixes))
(ange-ftp-real-file-name-all-completions file
ange-ftp-this-dir))
(ange-ftp-real-file-name-all-completions file ange-ftp-this-dir)))))
(defun ange-ftp-file-name-completion (file dir)
(let ((ange-ftp-this-dir (expand-file-name dir)))
(if (ange-ftp-ftp-name ange-ftp-this-dir)
(progn
(ange-ftp-barf-if-not-directory ange-ftp-this-dir)
(if (equal file "")
""
(setq ange-ftp-this-dir
(ange-ftp-real-file-name-as-directory ange-ftp-this-dir)) (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))
(ange-ftp-completion-ignored-pattern
(mapconcat (function
(lambda (s) (if (stringp s)
(concat (regexp-quote s) "$")
"/"))) completion-ignored-extensions
"\\|")))
(save-match-data
(or (ange-ftp-file-name-completion-1
file tbl ange-ftp-this-dir
(function ange-ftp-file-entry-not-ignored-p))
(ange-ftp-file-name-completion-1
file tbl ange-ftp-this-dir
(function ange-ftp-file-entry-active-p)))))))
(if (or (and (eq system-type 'windows-nt)
(string-match "^[a-zA-Z]:[/\\]$" ange-ftp-this-dir))
(string-equal "/" ange-ftp-this-dir))
(try-completion
file
(nconc (ange-ftp-generate-root-prefixes)
(mapcar 'list
(ange-ftp-real-file-name-all-completions
file ange-ftp-this-dir))))
(ange-ftp-real-file-name-completion file ange-ftp-this-dir)))))
(defun ange-ftp-file-name-completion-1 (file tbl dir predicate)
(let ((bestmatch (try-completion file tbl predicate)))
(if bestmatch
(if (eq bestmatch t)
(if (file-directory-p (expand-file-name file dir))
(concat file "/")
t)
(if (and (eq (try-completion bestmatch tbl predicate) t)
(file-directory-p
(expand-file-name bestmatch dir)))
(concat bestmatch "/")
bestmatch)))))
(defun ange-ftp-reread-dir (&optional dir)
"Reread remote directory DIR to update the directory cache.
The implementation of remote ftp file names caches directory contents
for speed. Therefore, when new remote files are created, Emacs
may not know they exist. You can use this command to reread a specific
directory, so that Emacs will know its current contents."
(interactive)
(if dir
(setq dir (expand-file-name dir))
(setq dir (file-name-directory (expand-file-name (buffer-string)))))
(if (ange-ftp-ftp-name dir)
(progn
(setq ange-ftp-ls-cache-file nil)
(ange-ftp-del-hash-entry dir ange-ftp-files-hashtable)
(ange-ftp-get-files dir t))))
(defun ange-ftp-make-directory (dir &optional parents)
(interactive (list (expand-file-name (read-file-name "Make directory: "))))
(if parents
(let ((parent (file-name-directory (directory-file-name dir))))
(or (file-exists-p parent)
(ange-ftp-make-directory parent parents))))
(if (file-exists-p dir)
(error "Cannot make directory %s: file already exists" dir)
(let ((parsed (ange-ftp-ftp-name dir)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
(name (ange-ftp-quote-string
(if (eq (ange-ftp-host-type host) 'unix)
(ange-ftp-real-directory-file-name (nth 2 parsed))
(ange-ftp-real-file-name-as-directory
(nth 2 parsed)))))
(abbr (ange-ftp-abbreviate-filename dir))
(result (ange-ftp-send-cmd host user
(list 'mkdir name)
(format "Making directory %s"
abbr))))
(or (car result)
(ange-ftp-error host user
(format "Could not make directory %s: %s"
dir
(cdr result))))
(ange-ftp-add-file-entry dir t))
(ange-ftp-real-make-directory dir)))))
(defun ange-ftp-delete-directory (dir)
(if (file-directory-p dir)
(let ((parsed (ange-ftp-ftp-name dir)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
(name (ange-ftp-quote-string
(if (eq (ange-ftp-host-type host) 'unix)
(ange-ftp-real-directory-file-name
(nth 2 parsed))
(ange-ftp-real-file-name-as-directory
(nth 2 parsed)))))
(abbr (ange-ftp-abbreviate-filename dir))
(result (ange-ftp-send-cmd host user
(list 'rmdir name)
(format "Removing directory %s"
abbr))))
(or (car result)
(ange-ftp-error host user
(format "Could not remove directory %s: %s"
dir
(cdr result))))
(ange-ftp-delete-file-entry dir t))
(ange-ftp-real-delete-directory dir)))
(error "Not a directory: %s" dir)))
(defun ange-ftp-file-local-copy (file)
(let* ((fn1 (expand-file-name file))
(pa1 (ange-ftp-ftp-name fn1)))
(if pa1
(let ((tmp1 (ange-ftp-make-tmp-name (car pa1))))
(ange-ftp-copy-file-internal fn1 tmp1 t nil
(format "Getting %s" fn1))
tmp1))))
(defun ange-ftp-load (file &optional noerror nomessage nosuffix)
(if (ange-ftp-ftp-name file)
(let ((tryfiles (if nosuffix
(list file)
(list (concat file ".elc") (concat file ".el") file)))
(load-force-doc-strings t)
copy)
(while (and tryfiles (not copy))
(catch 'ftp-error
(let ((ange-ftp-waiting-flag t))
(condition-case error
(setq copy (ange-ftp-file-local-copy (car tryfiles)))
(ftp-error nil))))
(setq tryfiles (cdr tryfiles)))
(if copy
(unwind-protect
(funcall 'load copy noerror nomessage nosuffix)
(delete-file copy))
(or noerror
(signal 'file-error (list "Cannot open load file" file)))
nil))
(ange-ftp-real-load file noerror nomessage nosuffix)))
(defun ange-ftp-unhandled-file-name-directory (filename)
(file-name-directory ange-ftp-tmp-name-template))
(defvar ange-ftp-make-compressed-filename-alist nil
"Alist of host-type-specific functions to process file names for compression.
Each element has the form (TYPE . FUNC).
FUNC should take one argument, a file name, and return a list
of the form (COMPRESSING NEWNAME).
COMPRESSING should be t if the specified file should be compressed,
and nil if it should be uncompressed (that is, if it is a compressed file).
NEWNAME should be the name to give the new compressed or uncompressed file.")
(defun ange-ftp-dired-compress-file (name)
(let ((parsed (ange-ftp-ftp-name name))
conversion-func)
(if (and parsed
(setq conversion-func
(cdr (assq (ange-ftp-host-type (car parsed))
ange-ftp-make-compressed-filename-alist))))
(let* ((decision
(save-match-data (funcall conversion-func name)))
(compressing (car decision))
(newfile (nth 1 decision)))
(if compressing
(ange-ftp-compress name newfile)
(ange-ftp-uncompress name newfile)))
(let (file-name-handler-alist)
(dired-compress-file name)))))
(defun ange-ftp-compress (file nfile)
(let* ((parsed (ange-ftp-ftp-name file))
(tmp1 (ange-ftp-make-tmp-name (car parsed)))
(tmp2 (ange-ftp-make-tmp-name (car parsed)))
(abbr (ange-ftp-abbreviate-filename file))
(nabbr (ange-ftp-abbreviate-filename nfile))
(msg1 (format "Getting %s" abbr))
(msg2 (format "Putting %s" nabbr)))
(unwind-protect
(progn
(ange-ftp-copy-file-internal file tmp1 t nil msg1)
(and ange-ftp-process-verbose
(ange-ftp-message "Compressing %s..." abbr))
(call-process-region (point)
(point)
shell-file-name
nil
t
nil
"-c"
(format "compress -f -c < %s > %s" tmp1 tmp2))
(and ange-ftp-process-verbose
(ange-ftp-message "Compressing %s...done" abbr))
(if (zerop (buffer-size))
(progn
(let (ange-ftp-process-verbose)
(delete-file file))
(ange-ftp-copy-file-internal tmp2 nfile t nil msg2))))
(ange-ftp-del-tmp-name tmp1)
(ange-ftp-del-tmp-name tmp2))))
(defun ange-ftp-uncompress (file nfile)
(let* ((parsed (ange-ftp-ftp-name file))
(tmp1 (ange-ftp-make-tmp-name (car parsed)))
(tmp2 (ange-ftp-make-tmp-name (car parsed)))
(abbr (ange-ftp-abbreviate-filename file))
(nabbr (ange-ftp-abbreviate-filename nfile))
(msg1 (format "Getting %s" abbr))
(msg2 (format "Putting %s" nabbr))
)
(unwind-protect
(progn
(ange-ftp-copy-file-internal file tmp1 t nil msg1)
(and ange-ftp-process-verbose
(ange-ftp-message "Uncompressing %s..." abbr))
(call-process-region (point)
(point)
shell-file-name
nil
t
nil
"-c"
(format "uncompress -c < %s > %s" tmp1 tmp2))
(and ange-ftp-process-verbose
(ange-ftp-message "Uncompressing %s...done" abbr))
(if (zerop (buffer-size))
(progn
(let (ange-ftp-process-verbose)
(delete-file file))
(ange-ftp-copy-file-internal tmp2 nfile t nil msg2))))
(ange-ftp-del-tmp-name tmp1)
(ange-ftp-del-tmp-name tmp2))))
(defun ange-ftp-find-backup-file-name (fn)
(if ange-ftp-make-backup-files
(ange-ftp-real-find-backup-file-name fn)))
(defun ange-ftp-hook-function (operation &rest args)
(let ((fn (get operation 'ange-ftp)))
(if fn (apply fn args)
(ange-ftp-run-real-handler operation args))))
(or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist)
(setq file-name-handler-alist
(cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function)
file-name-handler-alist)))
(or (assoc "^/[^/:]*\\'" file-name-handler-alist)
(setq file-name-handler-alist
(cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function)
file-name-handler-alist)))
(and (memq system-type '(ms-dos windows-nt))
(or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist)
(setq file-name-handler-alist
(cons '("^[a-zA-Z]:/[^/:]*\\'" .
ange-ftp-completion-hook-function)
file-name-handler-alist))))
(or (memq 'ange-ftp-set-buffer-mode find-file-hooks)
(setq find-file-hooks
(cons 'ange-ftp-set-buffer-mode find-file-hooks)))
(put 'file-name-directory 'ange-ftp 'ange-ftp-file-name-directory)
(put 'file-name-nondirectory 'ange-ftp 'ange-ftp-file-name-nondirectory)
(put 'file-name-as-directory 'ange-ftp 'ange-ftp-file-name-as-directory)
(put 'directory-file-name 'ange-ftp 'ange-ftp-directory-file-name)
(put 'expand-file-name 'ange-ftp 'ange-ftp-expand-file-name)
(put 'make-directory 'ange-ftp 'ange-ftp-make-directory)
(put 'delete-directory 'ange-ftp 'ange-ftp-delete-directory)
(put 'insert-file-contents 'ange-ftp 'ange-ftp-insert-file-contents)
(put 'directory-files 'ange-ftp 'ange-ftp-directory-files)
(put 'file-directory-p 'ange-ftp 'ange-ftp-file-directory-p)
(put 'file-writable-p 'ange-ftp 'ange-ftp-file-writable-p)
(put 'file-readable-p 'ange-ftp 'ange-ftp-file-readable-p)
(put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p)
(put 'file-symlink-p 'ange-ftp 'ange-ftp-file-symlink-p)
(put 'delete-file 'ange-ftp 'ange-ftp-delete-file)
(put 'read-file-name-internal 'ange-ftp 'ange-ftp-read-file-name-internal)
(put 'verify-visited-file-modtime 'ange-ftp
'ange-ftp-verify-visited-file-modtime)
(put 'file-exists-p 'ange-ftp 'ange-ftp-file-exists-p)
(put 'write-region 'ange-ftp 'ange-ftp-write-region)
(put 'backup-buffer 'ange-ftp 'ange-ftp-backup-buffer)
(put 'copy-file 'ange-ftp 'ange-ftp-copy-file)
(put 'rename-file 'ange-ftp 'ange-ftp-rename-file)
(put 'file-attributes 'ange-ftp 'ange-ftp-file-attributes)
(put 'file-name-all-completions 'ange-ftp 'ange-ftp-file-name-all-completions)
(put 'file-name-completion 'ange-ftp 'ange-ftp-file-name-completion)
(put 'insert-directory 'ange-ftp 'ange-ftp-insert-directory)
(put 'file-local-copy 'ange-ftp 'ange-ftp-file-local-copy)
(put 'unhandled-file-name-directory 'ange-ftp
'ange-ftp-unhandled-file-name-directory)
(put 'file-name-sans-versions 'ange-ftp 'ange-ftp-file-name-sans-versions)
(put 'dired-uncache 'ange-ftp 'ange-ftp-dired-uncache)
(put 'dired-compress-file 'ange-ftp 'ange-ftp-dired-compress-file)
(put 'load 'ange-ftp 'ange-ftp-load)
(put 'find-backup-file-name 'ange-ftp 'ange-ftp-find-backup-file-name)
(put 'file-truename 'ange-ftp 'identity)
(put 'vc-registered 'ange-ftp 'null)
(put 'dired-call-process 'ange-ftp 'ange-ftp-dired-call-process)
(put 'shell-command 'ange-ftp 'ange-ftp-shell-command)
(defun ange-ftp-run-real-handler (operation args)
(let ((inhibit-file-name-handlers
(cons 'ange-ftp-hook-function
(cons 'ange-ftp-completion-hook-function
(and (eq inhibit-file-name-operation operation)
inhibit-file-name-handlers))))
(inhibit-file-name-operation operation))
(apply operation args)))
(defun ange-ftp-real-file-name-directory (&rest args)
(ange-ftp-run-real-handler 'file-name-directory args))
(defun ange-ftp-real-file-name-nondirectory (&rest args)
(ange-ftp-run-real-handler 'file-name-nondirectory args))
(defun ange-ftp-real-file-name-as-directory (&rest args)
(ange-ftp-run-real-handler 'file-name-as-directory args))
(defun ange-ftp-real-directory-file-name (&rest args)
(ange-ftp-run-real-handler 'directory-file-name args))
(defun ange-ftp-real-expand-file-name (&rest args)
(ange-ftp-run-real-handler 'expand-file-name args))
(defun ange-ftp-real-make-directory (&rest args)
(ange-ftp-run-real-handler 'make-directory args))
(defun ange-ftp-real-delete-directory (&rest args)
(ange-ftp-run-real-handler 'delete-directory args))
(defun ange-ftp-real-insert-file-contents (&rest args)
(ange-ftp-run-real-handler 'insert-file-contents args))
(defun ange-ftp-real-directory-files (&rest args)
(ange-ftp-run-real-handler 'directory-files args))
(defun ange-ftp-real-file-directory-p (&rest args)
(ange-ftp-run-real-handler 'file-directory-p args))
(defun ange-ftp-real-file-writable-p (&rest args)
(ange-ftp-run-real-handler 'file-writable-p args))
(defun ange-ftp-real-file-readable-p (&rest args)
(ange-ftp-run-real-handler 'file-readable-p args))
(defun ange-ftp-real-file-executable-p (&rest args)
(ange-ftp-run-real-handler 'file-executable-p args))
(defun ange-ftp-real-file-symlink-p (&rest args)
(ange-ftp-run-real-handler 'file-symlink-p args))
(defun ange-ftp-real-delete-file (&rest args)
(ange-ftp-run-real-handler 'delete-file args))
(defun ange-ftp-real-read-file-name-internal (&rest args)
(ange-ftp-run-real-handler 'read-file-name-internal args))
(defun ange-ftp-real-verify-visited-file-modtime (&rest args)
(ange-ftp-run-real-handler 'verify-visited-file-modtime args))
(defun ange-ftp-real-file-exists-p (&rest args)
(ange-ftp-run-real-handler 'file-exists-p args))
(defun ange-ftp-real-write-region (&rest args)
(ange-ftp-run-real-handler 'write-region args))
(defun ange-ftp-real-backup-buffer (&rest args)
(ange-ftp-run-real-handler 'backup-buffer args))
(defun ange-ftp-real-copy-file (&rest args)
(ange-ftp-run-real-handler 'copy-file args))
(defun ange-ftp-real-rename-file (&rest args)
(ange-ftp-run-real-handler 'rename-file args))
(defun ange-ftp-real-file-attributes (&rest args)
(ange-ftp-run-real-handler 'file-attributes args))
(defun ange-ftp-real-file-name-all-completions (&rest args)
(ange-ftp-run-real-handler 'file-name-all-completions args))
(defun ange-ftp-real-file-name-completion (&rest args)
(ange-ftp-run-real-handler 'file-name-completion args))
(defun ange-ftp-real-insert-directory (&rest args)
(ange-ftp-run-real-handler 'insert-directory args))
(defun ange-ftp-real-file-name-sans-versions (&rest args)
(ange-ftp-run-real-handler 'file-name-sans-versions args))
(defun ange-ftp-real-shell-command (&rest args)
(ange-ftp-run-real-handler 'shell-command args))
(defun ange-ftp-real-load (&rest args)
(ange-ftp-run-real-handler 'load args))
(defun ange-ftp-real-find-backup-file-name (&rest args)
(ange-ftp-run-real-handler 'find-backup-file-name args))
(defun ange-ftp-insert-directory (file switches &optional wildcard full)
(let ((short (ange-ftp-abbreviate-filename file))
(parsed (ange-ftp-ftp-name (expand-file-name file))))
(if parsed
(insert
(if wildcard
(let ((default-directory (file-name-directory file)))
(ange-ftp-ls (file-name-nondirectory file) switches nil nil t))
(ange-ftp-ls file switches full)))
(ange-ftp-real-insert-directory file switches wildcard full))))
(defun ange-ftp-dired-uncache (dir)
(if (ange-ftp-ftp-name (expand-file-name dir))
(setq ange-ftp-ls-cache-file nil)))
(defvar ange-ftp-sans-version-alist nil
"Alist of mapping host type into function to remove file version numbers.")
(defun ange-ftp-file-name-sans-versions (file keep-backup-version)
(let* ((short (ange-ftp-abbreviate-filename file))
(parsed (ange-ftp-ftp-name short))
host-type func)
(if parsed
(setq host-type (ange-ftp-host-type (car parsed))
func (cdr (assq (ange-ftp-host-type (car parsed))
ange-ftp-sans-version-alist))))
(if func (funcall func file keep-backup-version)
(ange-ftp-real-file-name-sans-versions file keep-backup-version))))
(defun ange-ftp-shell-command (command &optional output-buffer error-buffer)
(let* ((parsed (ange-ftp-ftp-name default-directory))
(host (nth 0 parsed))
(user (nth 1 parsed))
(name (nth 2 parsed)))
(if (not parsed)
(ange-ftp-real-shell-command command output-buffer error-buffer)
(if (> (length name) 0) (setq command (concat "cd " name "; " command)))
(setq command
(format "%s %s \"%s\"" remote-shell-program host command))
(ange-ftp-message "Remote command '%s' ..." command)
(ange-ftp-real-shell-command command output-buffer error-buffer))))
(defun ange-ftp-dired-call-process (program discard &rest arguments)
(if (ange-ftp-ftp-name default-directory)
(condition-case oops
(cond ((equal dired-chmod-program program)
(ange-ftp-call-chmod arguments))
(t (error "Unknown remote command: %s" program)))
(ftp-error (insert (format "%s: %s, %s\n"
(nth 1 oops)
(nth 2 oops)
(nth 3 oops)))
1)
(error (insert (format "%s\n" (nth 1 oops)))
1))
(apply 'call-process program nil (not discard) nil arguments)))
(defvar ange-ftp-remote-shell "rsh"
"Remote shell to use for chmod, if FTP server rejects the `chmod' command.")
(defun ange-ftp-call-chmod (args)
(if (< (length args) 2)
(error "ange-ftp-call-chmod: missing mode and/or filename: %s" args))
(let ((mode (car args))
(rest (cdr args)))
(if (equal "--" (car rest))
(setq rest (cdr rest)))
(mapcar
(function
(lambda (file)
(setq file (expand-file-name file))
(let ((parsed (ange-ftp-ftp-name file)))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
(name (ange-ftp-quote-string (nth 2 parsed)))
(abbr (ange-ftp-abbreviate-filename file))
(result (ange-ftp-send-cmd host user
(list 'chmod mode name)
(format "doing chmod %s"
abbr))))
(or (car result)
(call-process
ange-ftp-remote-shell
nil t nil host dired-chmod-program mode name)))))))
rest))
(setq ange-ftp-ls-cache-file nil) 0)
(defun ange-ftp-fix-name-for-vms (name &optional reverse)
(save-match-data
(if reverse
(if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name)
(let (drive dir file)
(if (match-beginning 1)
(setq drive (substring name
(match-beginning 1)
(match-end 1))))
(if (match-beginning 2)
(setq dir
(substring name (match-beginning 2) (match-end 2))))
(if (match-beginning 3)
(setq file
(substring name (match-beginning 3) (match-end 3))))
(and dir
(setq dir (apply (function concat)
(mapcar (function
(lambda (char)
(if (= char ?.)
(vector ?/)
(vector char))))
(substring dir 1 -1)))))
(concat (and drive
(concat "/" drive "/"))
dir (and dir "/")
file))
(error "name %s didn't match" name))
(let (drive dir file tmp)
(if (string-match "^/[^:]+:/" name)
(setq drive (substring name 1
(1- (match-end 0)))
name (substring name (match-end 0))))
(setq tmp (file-name-directory name))
(if tmp
(setq dir (apply (function concat)
(mapcar (function
(lambda (char)
(if (= char ?/)
(vector ?.)
(vector char))))
(substring tmp 0 -1)))))
(setq file (file-name-nondirectory name))
(concat drive
(and dir (concat "[" (if drive nil ".") dir "]"))
file)))))
(or (assq 'vms ange-ftp-fix-name-func-alist)
(setq ange-ftp-fix-name-func-alist
(cons '(vms . ange-ftp-fix-name-for-vms)
ange-ftp-fix-name-func-alist)))
(or (memq 'vms ange-ftp-dumb-host-types)
(setq ange-ftp-dumb-host-types
(cons 'vms ange-ftp-dumb-host-types)))
(defun ange-ftp-fix-dir-name-for-vms (dir-name)
(cond ((string-equal dir-name "/")
(error "Cannot get listing for fictitious \"/\" directory."))
((string-match "^/[-A-Z0-9_$]+:/$" dir-name)
(error "Cannot get listing for device."))
((ange-ftp-fix-name-for-vms dir-name))))
(or (assq 'vms ange-ftp-fix-dir-name-func-alist)
(setq ange-ftp-fix-dir-name-func-alist
(cons '(vms . ange-ftp-fix-dir-name-for-vms)
ange-ftp-fix-dir-name-func-alist)))
(defvar ange-ftp-vms-host-regexp nil)
(defun ange-ftp-vms-host (host)
(and ange-ftp-vms-host-regexp
(save-match-data
(string-match ange-ftp-vms-host-regexp host))))
(defconst ange-ftp-vms-filename-regexp
(concat
"\\(\\([_A-Za-z0-9$]?\\|[_A-Za-z0-9$][-_A-Za-z0-9$]*\\)\\."
"[-_A-Za-z0-9$]*;+[0-9]*\\)")
"Regular expression to match for a valid VMS file name in Dired buffer.
Stupid freaking bug! Position of _ and $ shouldn't matter but they do.
Having [A-Z0-9$_] bombs on filename _$$CHANGE_LOG$.TXT$ and $CHANGE_LOG$.TX
Other orders of $ and _ seem to all work just fine.")
(defun ange-ftp-parse-vms-filename ()
(if (re-search-forward
ange-ftp-vms-filename-regexp
nil t)
(buffer-substring (match-beginning 0) (match-end 0))))
(defun ange-ftp-parse-vms-listing ()
(let ((tbl (ange-ftp-make-hashtable))
file)
(goto-char (point-min))
(save-match-data
(while (setq file (ange-ftp-parse-vms-filename))
(if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file)
(ange-ftp-put-hash-entry
(substring file 0 (match-beginning 0)) t tbl)
(ange-ftp-put-hash-entry file nil tbl)
(if (string-match ";[0-9]+$" file) (ange-ftp-put-hash-entry
(substring file 0 (match-beginning 0)) nil tbl)))
(forward-line 1))
(ange-ftp-put-hash-entry "." t tbl)
(ange-ftp-put-hash-entry ".." t tbl))
tbl))
(or (assq 'vms ange-ftp-parse-list-func-alist)
(setq ange-ftp-parse-list-func-alist
(cons '(vms . ange-ftp-parse-vms-listing)
ange-ftp-parse-list-func-alist)))
(defun ange-ftp-vms-delete-file-entry (name &optional dir-p)
(if dir-p
(ange-ftp-internal-delete-file-entry name t)
(save-match-data
(let ((file (ange-ftp-get-file-part name)))
(if (string-match ";[0-9]+$" file)
(let ((files (ange-ftp-get-hash-entry
(file-name-directory name)
ange-ftp-files-hashtable)))
(if files
(let* ((root (substring file 0
(match-beginning 0)))
(regexp (concat "^"
(regexp-quote root)
";[0-9]+$"))
versions)
(ange-ftp-del-hash-entry file files)
(mapatoms
'(lambda (sym)
(and (string-match regexp (get sym 'key))
(setq versions t)))
files)
(or versions
(ange-ftp-del-hash-entry root files))))))))))
(or (assq 'vms ange-ftp-delete-file-entry-alist)
(setq ange-ftp-delete-file-entry-alist
(cons '(vms . ange-ftp-vms-delete-file-entry)
ange-ftp-delete-file-entry-alist)))
(defun ange-ftp-vms-add-file-entry (name &optional dir-p)
(if dir-p
(ange-ftp-internal-add-file-entry name t)
(let ((files (ange-ftp-get-hash-entry
(file-name-directory name)
ange-ftp-files-hashtable)))
(if files
(let ((file (ange-ftp-get-file-part name)))
(save-match-data
(if (string-match ";[0-9]+$" file)
(ange-ftp-put-hash-entry
(substring file 0 (match-beginning 0))
nil files)
(let ((regexp (concat "^"
(regexp-quote file)
";\\([0-9]+\\)$"))
(version 0))
(mapatoms
'(lambda (sym)
(let ((name (get sym 'key)))
(and (string-match regexp name)
(setq version
(max version
(string-to-int
(substring name
(match-beginning 1)
(match-end 1))))))))
files)
(setq version (1+ version))
(ange-ftp-put-hash-entry
(concat file ";" (int-to-string version))
nil files))))
(ange-ftp-put-hash-entry file nil files))))))
(or (assq 'vms ange-ftp-add-file-entry-alist)
(setq ange-ftp-add-file-entry-alist
(cons '(vms . ange-ftp-vms-add-file-entry)
ange-ftp-add-file-entry-alist)))
(defun ange-ftp-add-vms-host (host)
"Mark HOST as the name of a machine running VMS."
(interactive
(list (read-string "Host: "
(let ((name (or (buffer-file-name) default-directory)))
(and name (car (ange-ftp-ftp-name name)))))))
(if (not (ange-ftp-vms-host host))
(setq ange-ftp-vms-host-regexp
(concat "^" (regexp-quote host) "$"
(and ange-ftp-vms-host-regexp "\\|")
ange-ftp-vms-host-regexp)
ange-ftp-host-cache nil)))
(defun ange-ftp-vms-file-name-as-directory (name)
(save-match-data
(if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name)
(setq name (substring name 0 (match-beginning 0))))
(ange-ftp-real-file-name-as-directory name)))
(or (assq 'vms ange-ftp-file-name-as-directory-alist)
(setq ange-ftp-file-name-as-directory-alist
(cons '(vms . ange-ftp-vms-file-name-as-directory)
ange-ftp-file-name-as-directory-alist)))
(defun ange-ftp-vms-make-compressed-filename (name &optional reverse)
(cond
((string-match "-Z;[0-9]+$" name)
(list nil (substring name 0 (match-beginning 0))))
((string-match ";[0-9]+$" name)
(list nil (substring name 0 (match-beginning 0))))
((string-match "-Z$" name)
(list nil (substring name 0 -2)))
(t
(list t
(if (string-match ";[0-9]+$" name)
(concat (substring name 0 (match-beginning 0))
"-Z")
(concat name "-Z"))))))
(or (assq 'vms ange-ftp-make-compressed-filename-alist)
(setq ange-ftp-make-compressed-filename-alist
(cons '(vms . ange-ftp-vms-make-compressed-filename)
ange-ftp-make-compressed-filename-alist)))
(defun ange-ftp-vms-sans-version (name &rest args)
(save-match-data
(if (string-match ";[0-9]+$" name)
(substring name 0 (match-beginning 0))
name)))
(or (assq 'vms ange-ftp-sans-version-alist)
(setq ange-ftp-sans-version-alist
(cons '(vms . ange-ftp-vms-sans-version)
ange-ftp-sans-version-alist)))
(defun ange-ftp-fix-name-for-mts (name &optional reverse)
(save-match-data
(if reverse
(if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name)
(let (acct file)
(if (match-beginning 1)
(setq acct (substring name 0 (match-end 1))))
(if (match-beginning 2)
(setq file (substring name
(match-beginning 2) (match-end 2))))
(concat (and acct (concat "/" acct "/"))
file))
(error "name %s didn't match" name))
(if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" name)
(concat (substring name 1 (match-end 1))
(substring name (match-beginning 2) (match-end 2)))
name))))
(or (assq 'mts ange-ftp-fix-name-func-alist)
(setq ange-ftp-fix-name-func-alist
(cons '(mts . ange-ftp-fix-name-for-mts)
ange-ftp-fix-name-func-alist)))
(defun ange-ftp-fix-dir-name-for-mts (dir-name)
(if (string-equal dir-name "/")
(error "Cannot get listing for fictitious \"/\" directory.")
(let ((dir-name (ange-ftp-fix-name-for-mts dir-name)))
(cond
((string-equal dir-name "")
"?")
((string-match ":$" dir-name)
(concat dir-name "?"))
(dir-name)))))
(or (assq 'mts ange-ftp-fix-dir-name-func-alist)
(setq ange-ftp-fix-dir-name-func-alist
(cons '(mts . ange-ftp-fix-dir-name-for-mts)
ange-ftp-fix-dir-name-func-alist)))
(or (memq 'mts ange-ftp-dumb-host-types)
(setq ange-ftp-dumb-host-types
(cons 'mts ange-ftp-dumb-host-types)))
(defvar ange-ftp-mts-host-regexp nil)
(defun ange-ftp-mts-host (host)
(and ange-ftp-mts-host-regexp
(save-match-data
(string-match ange-ftp-mts-host-regexp host))))
(defun ange-ftp-parse-mts-listing ()
(let ((tbl (ange-ftp-make-hashtable)))
(goto-char (point-min))
(save-match-data
(while (re-search-forward ange-ftp-date-regexp nil t)
(end-of-line)
(skip-chars-backward " ")
(let ((end (point)))
(skip-chars-backward "-A-Z0-9_.!")
(ange-ftp-put-hash-entry (buffer-substring (point) end) nil tbl))
(forward-line 1)))
(ange-ftp-put-hash-entry "." t tbl)
tbl))
(or (assq 'mts ange-ftp-parse-list-func-alist)
(setq ange-ftp-parse-list-func-alist
(cons '(mts . ange-ftp-parse-mts-listing)
ange-ftp-parse-list-func-alist)))
(defun ange-ftp-add-mts-host (host)
"Mark HOST as the name of a machine running MTS."
(interactive
(list (read-string "Host: "
(let ((name (or (buffer-file-name) default-directory)))
(and name (car (ange-ftp-ftp-name name)))))))
(if (not (ange-ftp-mts-host host))
(setq ange-ftp-mts-host-regexp
(concat "^" (regexp-quote host) "$"
(and ange-ftp-mts-host-regexp "\\|")
ange-ftp-mts-host-regexp)
ange-ftp-host-cache nil)))
(defun ange-ftp-fix-name-for-cms (name &optional reverse)
(save-match-data
(if reverse
(concat "/" name)
(if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$"
name)
(let ((minidisk (substring name 1 (match-end 1))))
(if (match-beginning 2)
(let ((file (substring name (match-beginning 2)
(match-end 2)))
(cmd (concat "cd " minidisk))
(proc (ange-ftp-get-process ange-ftp-this-host
ange-ftp-this-user)))
(if (car (ange-ftp-raw-send-cmd proc cmd ange-ftp-this-msg))
file
(setq proc (ange-ftp-get-process ange-ftp-this-host
ange-ftp-this-user))
(let ((result (ange-ftp-raw-send-cmd proc cmd
ange-ftp-this-msg)))
(if (car result)
file
(ange-ftp-error ange-ftp-this-host ange-ftp-this-user
(format "cd to minidisk %s failed: %s"
minidisk (cdr result)))))))
minidisk))
(error "Invalid CMS filename")))))
(or (assq 'cms ange-ftp-fix-name-func-alist)
(setq ange-ftp-fix-name-func-alist
(cons '(cms . ange-ftp-fix-name-for-cms)
ange-ftp-fix-name-func-alist)))
(or (memq 'cms ange-ftp-dumb-host-types)
(setq ange-ftp-dumb-host-types
(cons 'cms ange-ftp-dumb-host-types)))
(defun ange-ftp-fix-dir-name-for-cms (dir-name)
(cond
((string-equal "/" dir-name)
(error "Cannot get listing for fictitious \"/\" directory."))
((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-name)
(let* ((minidisk (substring dir-name (match-beginning 1) (match-end 1)))
(proc (ange-ftp-get-process ange-ftp-this-host ange-ftp-this-user))
(cmd (concat "cd " minidisk))
(file (if (match-beginning 2)
(substring dir-name (match-beginning 2)
(match-end 2))
"*")))
(if (car (ange-ftp-raw-send-cmd proc cmd))
file
(setq proc (ange-ftp-get-process ange-ftp-this-host
ange-ftp-this-user))
(let ((result (ange-ftp-raw-send-cmd proc cmd)))
(if (car result)
file
(ange-ftp-error ange-ftp-this-host ange-ftp-this-user
(format "cd to minidisk %s failed: %s"
minidisk (cdr result))))))))
(t (error "Invalid CMS file name"))))
(or (assq 'cms ange-ftp-fix-dir-name-func-alist)
(setq ange-ftp-fix-dir-name-func-alist
(cons '(cms . ange-ftp-fix-dir-name-for-cms)
ange-ftp-fix-dir-name-func-alist)))
(defvar ange-ftp-cms-host-regexp nil
"Regular expression to match hosts running the CMS operating system.")
(defun ange-ftp-cms-host (host)
(and ange-ftp-cms-host-regexp
(save-match-data
(string-match ange-ftp-cms-host-regexp host))))
(defun ange-ftp-add-cms-host (host)
"Mark HOST as the name of a CMS host."
(interactive
(list (read-string "Host: "
(let ((name (or (buffer-file-name) default-directory)))
(and name (car (ange-ftp-ftp-name name)))))))
(if (not (ange-ftp-cms-host host))
(setq ange-ftp-cms-host-regexp
(concat "^" (regexp-quote host) "$"
(and ange-ftp-cms-host-regexp "\\|")
ange-ftp-cms-host-regexp)
ange-ftp-host-cache nil)))
(defun ange-ftp-parse-cms-listing ()
(let ((tbl (ange-ftp-make-hashtable)))
(goto-char (point-min))
(save-match-data
(while
(re-search-forward
"^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t)
(ange-ftp-put-hash-entry
(concat (buffer-substring (match-beginning 1)
(match-end 1))
"."
(buffer-substring (match-beginning 2)
(match-end 2)))
nil tbl)
(forward-line 1))
(ange-ftp-put-hash-entry "." t tbl))
tbl))
(or (assq 'cms ange-ftp-parse-list-func-alist)
(setq ange-ftp-parse-list-func-alist
(cons '(cms . ange-ftp-parse-cms-listing)
ange-ftp-parse-list-func-alist)))
(defun ange-ftp-cms-make-compressed-filename (name &optional reverse)
(if (string-match "-Z$" name)
(list nil (substring name 0 -2))
(list t (concat name "-Z"))))
(or (assq 'cms ange-ftp-make-compressed-filename-alist)
(setq ange-ftp-make-compressed-filename-alist
(cons '(cms . ange-ftp-cms-make-compressed-filename)
ange-ftp-make-compressed-filename-alist)))
(provide 'ange-ftp)