;;; ange-ftp.el --- transparent FTP support for GNU Emacs
;; Copyright (C) 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1998,
-;; 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
;; Author: Andy Norman (ange@hplb.hpl.hp.com)
;; Maintainer: FSF
:prefix "ange-ftp-")
(defcustom ange-ftp-name-format
- '("^/\\(\\([^/:]*\\)@\\)?\\([^@/:]*[^@/:.]\\):\\(.*\\)" . (3 2 4))
+ '("\\`/\\(\\([^/:]*\\)@\\)?\\([^@/:]*[^@/:.]\\):\\(.*\\)" . (3 2 4))
"*Format of a fully expanded remote file name.
This is a list of the form \(REGEXP HOST USER NAME\),
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$")
+ (concat "TAGS\\'\\|\\.\\(?:"
+ (eval-when-compile
+ (regexp-opt '("z" "Z" "lzh" "arc" "zip" "zoo" "tar" "dvi"
+ "ps" "elc" "gif" "gz" "taz" "tgz")))
+ "\\|EXE\\(;[0-9]+\\)?\\|[zZ]-part-..\\)\\'")
"*If a file matches this regexp then it is transferred in binary mode."
:group 'ange-ftp
:type 'regexp)
only return the directory part of FILE."
(save-match-data
(if (and default-directory
- (string-match (concat "^"
+ (string-match (concat "\\`"
(regexp-quote default-directory)
".") file))
(setq file (substring file (1- (match-end 0)))))
(save-match-data
(maphash
(lambda (key value)
- (if (string-match "^[^/]*\\(/\\).*$" key)
+ (if (string-match "\\`[^/]*\\(/\\).*\\'" key)
(let ((host (substring key 0 (match-beginning 1))))
(if (and (string-equal user (substring key (match-end 1)))
value)
(setq file
(if (file-name-absolute-p temp)
temp
+ ;; Wouldn't `expand-file-name' be better than `concat' ?
+ ;; It would fail when `a/b/..' != `a', tho. --Stef
(concat (file-name-directory file) temp)))))
file)
(if (or ange-ftp-disable-netrc-security-check
(and (eq (nth 2 attr) (user-uid)) ; Same uids.
(string-match ".r..------" (nth 8 attr))))
- (save-excursion
+ (with-current-buffer
;; we are cheating a bit here. I'm trying to do the equivalent
;; of find-file on the .netrc file, but then nuke it afterwards.
;; with the bit of logic below we should be able to have
;; encrypted .netrc files.
- (set-buffer (generate-new-buffer "*ftp-.netrc*"))
+ (generate-new-buffer "*ftp-.netrc*")
(ange-ftp-real-insert-file-contents file)
(setq buffer-file-name file)
(setq default-directory (file-name-directory file))
(let (res)
(maphash
(lambda (key value)
- (if (string-match "^[^/]*\\(/\\).*$" key)
+ (if (string-match "\\`[^/]*\\(/\\).*\\'" key)
(let ((host (substring key 0 (match-beginning 1)))
(user (substring key (match-end 1))))
(push (concat user "@" host ":") res))))
(setq buffer (current-buffer))
(setq buffer (get-buffer buffer)))
(let ((file (or (buffer-file-name buffer)
- (save-excursion (set-buffer buffer) default-directory))))
+ (with-current-buffer buffer default-directory))))
(if file
(let ((parsed (ange-ftp-ftp-name (expand-file-name file))))
(if parsed
(if proc
(let ((buf (process-buffer proc)))
(if buf
- (save-excursion
- (set-buffer buf)
+ (with-current-buffer buf
(setq ange-ftp-xfer-size
;; For very large files, BYTES can be a float.
(if (integerp bytes)
;; 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)
- (process-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)))
- (seen-prompt nil))
- (setq ange-ftp-process-string (substring ange-ftp-process-string
- (match-end 0)))
- (while (string-match "^ftp> *" line)
- (setq seen-prompt t)
- (setq line (substring line (match-end 0))))
- (if (not (and seen-prompt ange-ftp-pending-error-line))
- (ange-ftp-process-handle-line line proc)
- ;; If we've seen a potential error message and it
- ;; hasn't been cancelled by a good message before
- ;; seeing a propt, then the error was real.
- (delete-process proc)
- (setq ange-ftp-process-busy nil
- ange-ftp-process-result-line ange-ftp-pending-error-line))))
-
- ;; 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)))))
+ ;; 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.
+ (when (buffer-live-p (process-buffer proc))
+ (with-current-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)
+ (process-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)))
+ (seen-prompt nil))
+ (setq ange-ftp-process-string (substring ange-ftp-process-string
+ (match-end 0)))
+ (while (string-match "\\`ftp> *" line)
+ (setq seen-prompt t)
+ (setq line (substring line (match-end 0))))
+ (if (not (and seen-prompt ange-ftp-pending-error-line))
+ (ange-ftp-process-handle-line line proc)
+ ;; If we've seen a potential error message and it
+ ;; hasn't been cancelled by a good message before
+ ;; seeing a propt, then the error was real.
+ (delete-process proc)
+ (setq ange-ftp-process-busy nil
+ ange-ftp-process-result-line ange-ftp-pending-error-line))))
+
+ ;; 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))))))))
(defun ange-ftp-process-sentinel (proc str)
"When ftp process changes state, nuke all file-entries in cache."
(defun ange-ftp-gwp-filter (proc str)
(comint-output-filter proc str)
- (save-excursion
- (set-buffer (process-buffer proc))
+ (with-current-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)
(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,
+ (let* (;; 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))
(set-process-query-on-exit-flag proc nil)
(set-process-sentinel proc 'ange-ftp-gwp-sentinel)
(set-process-filter proc 'ange-ftp-gwp-filter)
- (save-excursion
- (set-buffer (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
(goto-char (point-max))
(set-marker (process-mark proc) (point)))
(setq ange-ftp-gwp-running t
(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)
+ (if (string-match "\\`user \"[^\"]*\"" cmd)
(insert (substring cmd 0 (match-end 0)) " Turtle Power!\n")
(insert cmd)))
(move-marker comint-last-input-end (point))
ange-ftp-nslookup-program host)))
(res host))
(set-process-query-on-exit-flag proc nil)
- (save-excursion
- (set-buffer (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
(while (memq (process-status proc) '(run open))
(accept-process-output proc))
(goto-char (point-min))
;; Copy this so we don't alter it permanently.
(process-environment (copy-tree process-environment))
(buffer (get-buffer-create name)))
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(internal-ange-ftp-mode))
;; This tells GNU ftp not to output any fancy escape sequences.
(setenv "TERM" "dumb")
ange-ftp-gateway-host)
args))))
(setq proc (apply 'start-process name name args))))
- (save-excursion
- (set-buffer (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
(goto-char (point-max))
(set-marker (process-mark proc) (point)))
(set-process-query-on-exit-flag proc nil)
PROC is the process to the FTP-client. HOST may have an optional
suffix of the form #PORT to specify a non-default port"
(save-match-data
- (string-match "^\\([^#]+\\)\\(#\\([0-9]+\\)\\)?\\'" host)
+ (string-match "\\`\\([^#]+\\)\\(#\\([0-9]+\\)\\)?\\'" host)
(let* ((nshost (ange-ftp-nslookup-host (match-string 1 host)))
(port (match-string 3 host))
(result (ange-ftp-raw-send-cmd
(defun ange-ftp-guess-hash-mark-size (proc)
(if ange-ftp-send-hash
- (save-excursion
- (set-buffer (process-buffer proc))
+ (with-current-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)
(or ange-ftp-binary-hash-mark-size
(setq ange-ftp-binary-hash-mark-size size)))))))))
+(defvar ange-ftp-process-startup-hook nil)
+
(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."
;; resolve symlinks to directories on SysV machines. (Sebastian will
;; be happy.)
(and (eq host-type 'unix)
- (string-match "/$" cmd1)
+ (string-match "/\\'" cmd1)
(not (string-match "R" cmd3))
(setq cmd1 (concat cmd1 ".")))
+ ;; Using "ls -flags foo" has several problems:
+ ;; - if foo is a symlink, we may get a single line showing the symlink
+ ;; rather than the listing of the directory it points to.
+ ;; - if "foo" has spaces, the parsing of the command may be done wrong.
+ ;; - some version of netbsd's ftpd only accept a single argument after
+ ;; `ls', which can either be the directory or the flags.
+ ;; So to work around those problems, we use "cd foo; ls -flags".
+
;; If the dir name contains a space, some ftp servers will
;; refuse to list it. We instead change directory to the
;; directory in question and ls ".".
(unless (memq host-type ange-ftp-dumb-host-types)
(setq cmd0 'ls)
;; We cd and then use `ls' with no directory argument.
- ;; This works around a misfeature of some versions of netbsd ftpd.
+ ;; This works around a misfeature of some versions of netbsd ftpd
+ ;; where `ls' can only take one argument: either one set of flags
+ ;; or a file/directory name.
+ ;; If we're trying to `ls' a single file, this fails since we
+ ;; can't cd to a file. We can't fix this problem here, tho, because
+ ;; at this point we don't know whether the argument is a file or
+ ;; a directory. Such an `ls' is only ever used (apparently) from
+ ;; `insert-directory' when the `full-directory-p' argument is nil
+ ;; (which seems to only be used by dired when updating its display
+ ;; after operating on a set of files). So we've changed
+ ;; `ange-ftp-insert-directory' such that in this case it gets
+ ;; a full listing of the directory and extracting the line
+ ;; corresponding to the requested file.
(unless (equal cmd1 ".")
- (setq result (ange-ftp-cd host user
- ;; Make sure the target to which
- ;; `cd' is performed is a directory.
- (file-name-directory (nth 1 cmd))
- 'noerror)))
- ;; Concatenate the switches and the target to be used with `ls'.
- (setq cmd1 (concat "\"" cmd3 " " cmd1 "\""))))
+ (setq result (ange-ftp-cd host user (nth 1 cmd) 'noerror)))
+ (setq cmd1 cmd3)))
;; First argument is the remote name
((progn
(format "Listing %s"
(ange-ftp-abbreviate-filename
ange-ftp-this-file)))))
- (save-excursion
- (set-buffer (get-buffer-create
- ange-ftp-data-buffer-name))
+ (with-current-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)
;;;; Directory information caching support.
;;;; ------------------------------------------------------------
-(defconst ange-ftp-date-regexp
- (let* ((l "\\([A-Za-z]\\|[^\0-\177]\\)")
- ;; In some locales, month abbreviations are as short as 2 letters,
- ;; and they can be padded on the right with spaces.
- ;; weiand: changed: month ends with . or , or .,
-;;old (month (concat l l "+ *"))
- (month (concat l l "+[.]?,? *"))
- ;; Recognize any non-ASCII character.
- ;; The purpose is to match a Kanji character.
- (k "[^\0-\177]")
- (s " ")
- (mm "[ 0-1][0-9]")
- ;; weiand: changed: day ends with .
-;;old (dd "[ 0-3][0-9]")
- (dd "[ 0-3][0-9][.]?")
- (western (concat "\\(" month s dd "\\|" dd s month "\\)"))
- (japanese (concat mm k s dd k)))
- ;; Require the previous column to end in a digit.
- ;; This avoids recognizing `1 may 1997' as a date in the line:
- ;; -r--r--r-- 1 may 1997 1168 Oct 19 16:49 README
- (concat "[0-9]" s "\\(" western "\\|" japanese "\\)" s))
- "Regular expression to match up to the column before the file name in a
-directory listing. This regular expression is designed to recognize dates
-regardless of the language.")
-
(defvar ange-ftp-add-file-entry-alist nil
"Alist saying how to add file entries on certain OS types.
Association list of pairs \( TYPE \. FUNC \), where FUNC
;;Extract the filename from the current line of a dired-like listing.
`(let ((eol (progn (end-of-line) (point))))
(beginning-of-line)
- (if (re-search-forward ange-ftp-date-regexp eol t)
- (progn
- (skip-chars-forward " ")
- (skip-chars-forward "^ " eol)
- (skip-chars-forward " " eol)
- ;; We bomb on filenames starting with a space.
- (buffer-substring (point) eol)))))
+ (if (re-search-forward directory-listing-before-filename-regexp eol t)
+ (buffer-substring (point) eol))))
;; This deals with the F switch. Should also do something about
;; unquoting names obtained with the SysV b switch and the GNU Q
;; Some ls's with the F switch mark symlinks with an @ (ULTRIX)
;; and others don't. (sigh...) Beware, that some Unix's don't
;; seem to believe in the F-switch
- (if (or (and symlink (string-match "@$" file))
- (and directory (string-match "/$" file))
- (and executable (string-match "*$" file))
- (and socket (string-match "=$" file)))
+ (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)))))
(puthash file (or symlink directory) tbl)
(forward-line 1))
;; (3) The twilight zone.
;; We'll assume (1) for now.
nil)
- ((re-search-forward ange-ftp-date-regexp nil t)
+ ((re-search-forward directory-listing-before-filename-regexp nil t)
(beginning-of-line)
(ange-ftp-ls-parser switches))
((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t)
(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)))
+ (with-current-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)))))))
(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)))
+ (with-current-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)))))))
;; See if remote name is absolute. If so then just expand it and
;; replace the name component of the overall name.
- (cond ((string-match "^/" name)
+ (cond ((string-match "\\`/" name)
name)
;; Name starts with ~ or ~user. Resolve that part of the name
;; making it absolute then re-expand it.
- ((string-match "^~[^/]*" name)
+ ((string-match "\\`~[^/]*" name)
(let* ((tilda (match-string 0 name))
(rest (substring name (match-end 0)))
(dir (ange-ftp-expand-dir host user tilda)))
(if dir
- (setq name (cond ((string-equal rest "")
- dir)
- ((string-equal dir "/")
- rest)
- (t
- (concat dir rest))))
+ ;; C-x d /ftp:anonymous@ftp.gnu.org:~/ RET
+ ;; seems to cause `rest' to sometimes be empty.
+ ;; Maybe it's an error for `rest' to be empty here,
+ ;; but until we figure this out, this quick fix
+ ;; seems to do the trick.
+ (setq name (cond ((string-equal rest "") dir)
+ ((string-equal dir "/") rest)
+ (t (concat dir rest))))
(error "User \"%s\" is not known"
(substring tilda 1)))))
(error "Unable to obtain CWD")))))
;; If name starts with //, preserve that, for apollo system.
- (if (not (string-match "^//" name))
- (progn
- (if (not (eq system-type 'windows-nt))
- (setq name (ange-ftp-real-expand-file-name name))
- ;; Windows UNC default dirs do not make sense for ftp.
- (if (string-match "^//" default-directory)
- (setq name (ange-ftp-real-expand-file-name name "c:/"))
- (setq name (ange-ftp-real-expand-file-name name)))
- ;; Strip off possible drive specifier.
- (if (string-match "^[a-zA-Z]:" name)
- (setq name (substring name 2))))
- (if (string-match "^//" name)
- (setq name (substring name 1)))))
+ (unless (string-match "\\`//" name)
+ (if (not (eq system-type 'windows-nt))
+ (setq name (ange-ftp-real-expand-file-name name))
+ ;; Windows UNC default dirs do not make sense for ftp.
+ (setq name (if (string-match "\\`//" default-directory)
+ (ange-ftp-real-expand-file-name name "c:/")
+ (ange-ftp-real-expand-file-name name)))
+ ;; Strip off possible drive specifier.
+ (if (string-match "\\`[a-zA-Z]:" name)
+ (setq name (substring name 2))))
+ (if (string-match "\\`//" name)
+ (setq name (substring name 1))))
;; Now substitute the expanded name back into the overall filename.
(ange-ftp-replace-name-component n name))
(ange-ftp-real-file-name-directory n))))))
(defun ange-ftp-expand-file-name (name &optional default)
- "Documented as original."
+ "Documented as `expand-file-name'."
(save-match-data
(setq default (or default default-directory))
(cond ((eq (string-to-char name) ?~)
(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)))
+ (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))
(if parsed
(let ((filename (nth 2 parsed)))
(if (save-match-data
- (string-match "^~[^/]*$" filename))
+ (string-match "\\`~[^/]*\\'" filename))
name
(ange-ftp-replace-name-component
name
(if parsed
(let ((filename (nth 2 parsed)))
(if (save-match-data
- (string-match "^~[^/]*$" filename))
+ (string-match "\\`~[^/]*\\'" filename))
""
(ange-ftp-real-file-name-nondirectory filename)))
(ange-ftp-real-file-name-nondirectory name))))
;; cleanup forms
(setq coding-system-used last-coding-system-used)
(setq buffer-file-name filename)
- (set-buffer-modified-p mod-p)))
+ (restore-buffer-modified-p mod-p)))
(if binary
(ange-ftp-set-binary-mode host user))
(let ((file-ent (ange-ftp-get-file-entry
(ange-ftp-file-name-as-directory name))))
(if (stringp file-ent)
- (file-directory-p
+ ;; Calling file-directory-p doesn't work because ange-ftp
+ ;; is temporarily disabled for this operation.
+ (ange-ftp-file-directory-p
(ange-ftp-expand-symlink file-ent
(file-name-directory
(directory-file-name name))))
;; (set (make-local-variable 'copy-cont) cont))))
;;
;; (defun ange-ftp-copy-file-locally-sentinel (proc status)
-;; (save-excursion
-;; (set-buffer (process-buffer proc))
+;; (with-current-buffer (process-buffer proc)
;; (let ((cont copy-cont)
;; (result (buffer-string)))
;; (unwind-protect
;; Maybe we should use something more like
;; (equal dir (file-name-directory (directory-file-name dir))) -stef
(or (and (eq system-type 'windows-nt)
- (string-match "^[a-zA-Z]:[/\\]$" dir))
+ (string-match "\\`[a-zA-Z]:[/\\]\\'" dir))
(string-equal "/" dir)))
(defun ange-ftp-file-name-all-completions (file dir)
(let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))
(ange-ftp-completion-ignored-pattern
(mapconcat (lambda (s) (if (stringp s)
- (concat (regexp-quote s) "$")
- "/")) ; / never in filename
+ (concat (regexp-quote s) "$")
+ "/")) ; / never in filename
completion-ignored-extensions
"\\|")))
(save-match-data
;; `ange-ftp-ls' handles this.
(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)))
- tem)
- (if parsed
- (if (and (not wildcard)
- (setq tem (file-symlink-p (directory-file-name file))))
- (ange-ftp-insert-directory
- (ange-ftp-expand-symlink
- tem (file-name-directory (directory-file-name file)))
- switches wildcard full)
- (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))))
+ (if (not (ange-ftp-ftp-name (expand-file-name file)))
+ (ange-ftp-real-insert-directory file switches wildcard full)
+ ;; We used to follow symlinks on `file' here. Apparently it was done
+ ;; because some FTP servers react to "ls foo" by listing the symlink foo
+ ;; rather than the directory it points to. Now that ange-ftp-ls uses
+ ;; "cd foo; ls" instead, this is not necesssary any more.
+ (insert
+ (cond
+ (wildcard
+ (let ((default-directory (file-name-directory file)))
+ (ange-ftp-ls (file-name-nondirectory file) switches nil nil t)))
+ (full
+ (ange-ftp-ls file switches 'parse))
+ (t
+ ;; If `full' is nil we're going to do `ls' for a single file.
+ ;; Problem is that for various reasons, ange-ftp-ls needs to cd and
+ ;; then do an ls of current dir, which obviously won't work if we
+ ;; want to ls a file. So instead, we get a full listing of the
+ ;; parent directory and extract the line corresponding to `file'.
+ (when (string-match "d\\'" switches)
+ ;; Remove "d" which dired added to `switches'.
+ (setq switches (substring switches 0 (match-beginning 0))))
+ (let* ((dirlist (ange-ftp-ls (or (file-name-directory file) ".")
+ switches nil))
+ (filename (file-name-nondirectory (directory-file-name file)))
+ (case-fold-search nil))
+ ;; FIXME: This presumes a particular output format, which is
+ ;; basically Unix.
+ (if (string-match (concat "^.+[^ ] " (regexp-quote filename)
+ "\\( -> .*\\)?[@/*=]?\n") dirlist)
+ (match-string 0 dirlist)
+ "")))))))
(defun ange-ftp-dired-uncache (dir)
(if (ange-ftp-ftp-name (expand-file-name dir))
(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))))
+ (func (if parsed (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))))
;; target marker-char buffer overwrite-query
;; overwrite-backup-query failures skipped
;; success-count total)
-;; (let ((old-buf (current-buffer)))
-;; (unwind-protect
-;; (progn
-;; (set-buffer buffer)
+;; (with-current-buffer buffer
;; (if (null fn-list)
;; (ange-ftp-dcf-3 failures operation total skipped
;; success-count buffer)
;; overwrite-query
;; overwrite-backup-query
;; failures skipped success-count
-;; total))))))))
-;; (set-buffer old-buf))))
+;; total)))))))))
;;(defun ange-ftp-dcf-2 (result line err
;; file-creator operation fn-list
;; overwrite-backup-query
;; failures skipped success-count
;; total)
-;; (let ((old-buf (current-buffer)))
-;; (unwind-protect
-;; (progn
-;; (set-buffer buffer)
+;; (with-current-buffer buffer
;; (if (or err (not result))
;; (progn
;; (setq failures (cons (dired-make-relative from) failures))
;; overwrite-query
;; overwrite-backup-query
;; failures skipped success-count
-;; total))
-;; (set-buffer old-buf))))
+;; total)))
;;(defun ange-ftp-dcf-3 (failures operation total skipped success-count
;; buffer)
-;; (let ((old-buf (current-buffer)))
-;; (unwind-protect
-;; (progn
-;; (set-buffer buffer)
+;; (with-current-buffer buffer
;; (cond
;; (failures
;; (dired-log-summary
;; (t
;; (message "%s: %s file%s."
;; operation success-count (dired-plural-s success-count))))
-;; (dired-move-to-filename))
-;; (set-buffer old-buf))))
+;; (dired-move-to-filename)))
\f
;;;; -----------------------------------------------
;;;; Unix Descriptive Listing (dl) Support
(defun ange-ftp-fix-name-for-vms (name &optional reverse)
(save-match-data
(if reverse
- (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name)
+ (if (string-match "\\`\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)\\'" name)
(let (drive dir file)
(setq drive (match-string 1 name))
(setq dir (match-string 2 name))
file))
(error "name %s didn't match" name))
(let (drive dir file tmp)
- (if (string-match "^/[^:]+:/" name)
+ (if (string-match "\\`/[^:]+:/" name)
(setq drive (substring name 1
(1- (match-end 0)))
name (substring name (match-end 0))))
;; them.
(cond ((string-equal dir-name "/")
(error "Cannot get listing for fictitious \"/\" directory"))
- ((string-match "^/[-A-Z0-9_$]+:/$" dir-name)
+ ((string-match "\\`/[-A-Z0-9_$]+:/\\'" dir-name)
(error "Cannot get listing for device"))
((ange-ftp-fix-name-for-vms dir-name))))
;; deal with directories
(puthash (substring file 0 (match-beginning 0)) t tbl)
(puthash file nil tbl)
- (if (string-match ";[0-9]+$" file) ; deal with extension
+ (if (string-match ";[0-9]+\\'" file) ; deal with extension
;; sans extension
(puthash (substring file 0 (match-beginning 0)) nil tbl)))
(forward-line 1))
(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)
+ (if (string-match ";[0-9]+\\'" file)
;; In VMS you can't delete a file without an explicit
;; version number, or wild-card (e.g. FOO;*)
;; For now, we give up on wildcards.
(if files
(let ((file (ange-ftp-get-file-part name)))
(save-match-data
- (if (string-match ";[0-9]+$" file)
+ (if (string-match ";[0-9]+\\'" file)
(puthash (substring file 0 (match-beginning 0)) nil files)
;; Need to figure out what version of the file
;; is being added.
(defun ange-ftp-vms-file-name-as-directory (name)
(save-match-data
- (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name)
+ (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?\\'" name)
(setq name (substring name 0 (match-beginning 0))))
(ange-ftp-real-file-name-as-directory name)))
(defun ange-ftp-vms-make-compressed-filename (name &optional reverse)
(cond
- ((string-match "-Z;[0-9]+$" name)
+ ((string-match "-Z;[0-9]+\\'" name)
(list nil (substring name 0 (match-beginning 0))))
- ((string-match ";[0-9]+$" name)
+ ((string-match ";[0-9]+\\'" name)
(list nil (substring name 0 (match-beginning 0))))
- ((string-match "-Z$" name)
+ ((string-match "-Z\\'" name)
(list nil (substring name 0 -2)))
(t
(list t
- (if (string-match ";[0-9]+$" name)
+ (if (string-match ";[0-9]+\\'" name)
(concat (substring name 0 (match-beginning 0))
"-Z")
(concat name "-Z"))))))
(defun ange-ftp-vms-sans-version (name &rest args)
(save-match-data
- (if (string-match ";[0-9]+$" name)
+ (if (string-match ";[0-9]+\\'" name)
(substring name 0 (match-beginning 0))
name)))
(defun ange-ftp-fix-name-for-mts (name &optional reverse)
(save-match-data
(if reverse
- (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name)
+ (if (string-match "\\`\\([^:]+:\\)?\\(.*\\)\\'" name)
(let (acct file)
(setq acct (match-string 1 name))
(setq file (match-string 2 name))
(concat (and acct (concat "/" acct "/"))
file))
(error "name %s didn't match" name))
- (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" name)
+ (if (string-match "\\`/\\([^:]+:\\)/\\(.*\\)\\'" name)
(concat (match-string 1 name) (match-string 2 name))
;; Let's hope that mts will recognize it anyway.
name))))
(cond
((string-equal dir-name "")
"?")
- ((string-match ":$" dir-name)
+ ((string-match ":\\'" dir-name)
(concat dir-name "?"))
(dir-name))))) ; It's just a single file.
(let ((tbl (make-hash-table :test 'equal)))
(goto-char (point-min))
(save-match-data
- (while (re-search-forward ange-ftp-date-regexp nil t)
+ (while (re-search-forward directory-listing-before-filename-regexp nil t)
(end-of-line)
(skip-chars-backward " ")
(let ((end (point)))
;; stores directories without the trailing /. Is this
;; consistent?
(concat "/" name)
- (if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$"
+ (if (string-match "\\`/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?\\'"
name)
(let ((minidisk (match-string 1 name)))
(if (match-beginning 2)
(cond
((string-equal "/" dir-name)
(error "Cannot get listing for fictitious \"/\" directory"))
- ((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-name)
+ ((string-match "\\`/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?\\'" dir-name)
(let* ((minidisk (match-string 1 dir-name))
;; host and user are bound in the call to ange-ftp-send-cmd
(proc (ange-ftp-get-process ange-ftp-this-host ange-ftp-this-user))
;; ange-ftp-dired-move-to-end-of-filename-alist)))
(defun ange-ftp-cms-make-compressed-filename (name &optional reverse)
- (if (string-match "-Z$" name)
+ (if (string-match "-Z\\'" name)
(list nil (substring name 0 -2))
(list t (concat name "-Z"))))
(provide 'ange-ftp)
-;;; arch-tag: 2987ef88-cb56-4ec1-87a9-79132572e316
+;; arch-tag: 2987ef88-cb56-4ec1-87a9-79132572e316
;;; ange-ftp.el ends here