;;; 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, 2006, 2007, 2008, 2009
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1989-1996, 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Andy Norman (ange@hplb.hpl.hp.com)
;; Maintainer: FSF
;;; Code:
(require 'comint)
-;; Silence compiler:
-(eval-when-compile
- (require 'dired)
- (defvar comint-last-output-start nil)
- (defvar comint-last-input-start nil)
- (defvar comint-last-input-end nil))
;;;; ------------------------------------------------------------
;;;; User customization variables.
"Accessing remote files and directories using FTP
made as simple and transparent as possible."
:group 'files
+ :group 'comm
:prefix "ange-ftp-")
(defcustom ange-ftp-name-format
"^Connected \\|^$\\|^Remote system\\|^Using\\|^ \\|Password:\\|"
"^Data connection \\|"
"^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye\\|"
- "^500 .*AUTH \\(KERBEROS\\|GSSAPI\\)\\|^KERBEROS\\|"
+ "^500 .*AUTH\\|^KERBEROS\\|"
+ "^504 Unknown security mechanism\\|"
"^530 Please login with USER and PASS\\|" ; non kerberised vsFTPd
"^534 Kerberos Authentication not enabled\\|"
"^22[789] .*[Pp]assive\\|^200 EPRT\\|^500 .*EPRT")
;;;; ------------------------------------------------------------
(defmacro ange-ftp-generate-passwd-key (host user)
- `(concat (downcase ,host) "/" ,user))
+ `(and (stringp ,host) (stringp ,user) (concat (downcase ,host) "/" ,user)))
(defmacro ange-ftp-lookup-passwd (host user)
`(gethash (ange-ftp-generate-passwd-key ,host ,user)
ange-ftp-gateway-tmp-name-template
ange-ftp-tmp-name-template)))
-(defalias 'ange-ftp-del-tmp-name 'delete-file)
+(defun ange-ftp-del-tmp-name (filename)
+ "Force to delete temporary file."
+ (delete-file filename))
+
\f
;;;; ------------------------------------------------------------
;;;; Interactive gateway program support.
;; Second argument is the remote name
((or (memq cmd0 '(append put chmod))
- (and (eq cmd0 'quote) (string= cmd1 "mdtm")))
+ (and (eq cmd0 'quote) (member cmd1 '("mdtm" "size"))))
(setq cmd2 (funcall fix-name-func cmd2)))
;; Both arguments are remote names
((eq cmd0 'rename)
(defmacro ange-ftp-parse-filename ()
;;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 directory-listing-before-filename-regexp eol t)
- (buffer-substring (point) eol))))
+ `(save-match-data
+ (let ((eol (progn (end-of-line) (point))))
+ (beginning-of-line)
+ (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
(defun ange-ftp-set-binary-mode (host user)
"Tell the FTP process for the given HOST & USER to switch to binary mode."
+ ;; FIXME: We should keep track of the current mode, so as to avoid
+ ;; unnecessary roundtrips.
(let ((result (ange-ftp-send-cmd host user '(type "binary"))))
(if (not (car result))
(ange-ftp-error host user (concat "BINARY failed: " (cdr result)))
(defun ange-ftp-set-ascii-mode (host user)
"Tell the FTP process for the given HOST & USER to switch to ASCII mode."
+ ;; FIXME: We should keep track of the current mode, so as to avoid
+ ;; unnecessary roundtrips.
(let ((result (ange-ftp-send-cmd host user '(type "ascii"))))
(if (not (car result))
(ange-ftp-error host user (concat "ASCII failed: " (cdr result)))
(nreverse files)))
(apply 'ange-ftp-real-directory-files directory full match v19-args)))
+(defun ange-ftp-directory-files-and-attributes
+ (directory &optional full match nosort id-format)
+ (setq directory (expand-file-name directory))
+ (if (ange-ftp-ftp-name directory)
+ (mapcar
+ (lambda (file)
+ (cons file (file-attributes (expand-file-name file directory))))
+ (ange-ftp-directory-files directory full match nosort))
+ (ange-ftp-real-directory-files-and-attributes
+ directory full match nosort id-format)))
+
(defun ange-ftp-file-attributes (file &optional id-format)
(setq file (expand-file-name file))
(let ((parsed (ange-ftp-ftp-name file)))
'(0 0) ;4 atime
(ange-ftp-file-modtime file) ;5 mtime
'(0 0) ;6 ctime
- -1 ;7 size
+ (ange-ftp-file-size file) ;7 size
(concat (if (stringp dirp) "l" (if dirp "d" "-"))
"?????????") ;8 mode
nil ;9 gid weird
(file-exists-p file)
(ange-ftp-real-file-executable-p file))))
-(defun ange-ftp-delete-file (file)
- (interactive "fDelete file: ")
+(defun ange-ftp-delete-file (file &optional trash)
+ (interactive (list (read-file-name "Delete file: " nil default-directory)
+ (null current-prefix-arg)))
(setq file (expand-file-name file))
(let ((parsed (ange-ftp-ftp-name file)))
(if parsed
(format "FTP Error: \"%s\"" (cdr result))
file)))
(ange-ftp-delete-file-entry file))
- (ange-ftp-real-delete-file file))))
+ (ange-ftp-real-delete-file file trash))))
(defun ange-ftp-file-modtime (file)
"Return the modification time of remote file FILE.
(or (zerop (car file-mdtm))
(<= (float-time file-mdtm) (float-time buf-mdtm))))
(ange-ftp-real-verify-visited-file-modtime buf))))
+
+(defun ange-ftp-file-size (file &optional ascii-mode)
+ "Return the size of remote file FILE. Return -1 if can't get it.
+If ascii-mode is non-nil, return the size with the extra octets that
+need to be inserted, one at the end of each line, to provide correct
+end-of-line semantics for a transfer using TYPE=A. The default is nil,
+so return the size on the remote host exactly. See RFC 3659."
+ (let* ((parsed (ange-ftp-ftp-name file))
+ (host (nth 0 parsed))
+ (user (nth 1 parsed))
+ (name (ange-ftp-quote-string (nth 2 parsed)))
+ ;; At least one FTP server (wu-ftpd) can return a "226
+ ;; Transfer complete" before the "213 SIZE". Let's skip
+ ;; that.
+ (ange-ftp-skip-msgs (concat ange-ftp-skip-msgs "\\|^226"))
+ (res (unwind-protect
+ (progn
+ (unless ascii-mode
+ (ange-ftp-set-binary-mode host user))
+ (ange-ftp-send-cmd host user (list 'quote "size" name)))
+ (unless ascii-mode
+ (ange-ftp-set-ascii-mode host user))))
+ (line (cdr res)))
+ (if (string-match "^213 \\([0-9]+\\)$" line)
+ (string-to-number (match-string 1 line))
+ -1)))
+
\f
;;;; ------------------------------------------------------------
;;;; File copying support... totally re-written 6/24/92.
(ange-ftp-call-cont cont result line)))
(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists
- keep-date preserve-uid-gid)
+ keep-date preserve-uid-gid
+ preserve-selinux-context)
(interactive "fCopy file: \nFCopy %s to file: \np")
(ange-ftp-copy-file-internal filename
newname
keep-date
nil
nil
- (interactive-p)))
+ (called-interactively-p 'interactive)))
(defun ange-ftp-copy-files-async (okay-p line verbose-p files)
"Copy some files in the background.
(defun ange-ftp-delete-directory (dir &optional recursive)
(if (file-directory-p dir)
(let ((parsed (ange-ftp-ftp-name dir)))
+ (if recursive
+ (mapc
+ (lambda (file)
+ (if (file-directory-p file)
+ (ange-ftp-delete-directory file recursive)
+ (delete-file file)))
+ ;; We do not want to delete "." and "..".
+ (directory-files
+ dir 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
(if parsed
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
(ange-ftp-real-file-name-as-directory
(nth 2 parsed)))))
(abbr (ange-ftp-abbreviate-filename dir))
- ;; TODO: handle RECURSIVE.
- (result (ange-ftp-send-cmd host user
- (list 'rmdir name)
- (format "Removing directory %s"
- abbr))))
+ (result
+ (progn
+ ;; CWD must not in this directory.
+ (ange-ftp-cd host user "/" 'noerror)
+ (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"
(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 'directory-files-and-attributes 'ange-ftp
+ 'ange-ftp-directory-files-and-attributes)
(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)
(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-directory-files-and-attributes (&rest args)
+ (ange-ftp-run-real-handler 'directory-files-and-attributes 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)
;; 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)
- "")))))))
+ (let ((beg (point))
+ (end (point-marker)))
+ (set-marker-insertion-type end t)
+ (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))))
+ (setq file (directory-file-name file))
+ (let* ((dirlist (ange-ftp-ls (or (file-name-directory file) ".")
+ switches 'parse))
+ (filename (file-name-nondirectory 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)
+ "")))))
+
+ ;; Insert " " for dired's alignment sanity.
+ (goto-char beg)
+ (while (re-search-forward "^\\(\\S-\\)" end 'move)
+ (replace-match " \\1"))
+
+ ;; The inserted file could be from somewhere else.
+ (when (and (not wildcard) (not full)
+ (search-backward
+ (if (zerop (length (file-name-nondirectory
+ (expand-file-name file))))
+ "."
+ (file-name-nondirectory file))
+ nil 'noerror))
+ (replace-match (file-relative-name (expand-file-name file)) t)
+ (goto-char end))
+
+ (set-marker end nil))))
(defun ange-ftp-dired-uncache (dir)
(if (ange-ftp-ftp-name (expand-file-name dir))
;; Can't use ange-ftp-dired-host-type here because the current
;; buffer is *dired-check-process output*
(condition-case oops
- (cond ((equal dired-chmod-program program)
+ (cond ((equal (or (bound-and-true-p dired-chmod-program) "chmod")
+ program)
(ange-ftp-call-chmod arguments))
;; ((equal "chgrp" program))
;; ((equal dired-chown-program program))
;; ;; This is the Unix dl version.
;; (let ((opoint (point))
;; case-fold-search hidden)
-;; (or eol (setq eol (save-excursion (end-of-line) (point))))
+;; (or eol (setq eol (line-end-position)))
;; (setq hidden (and selective-display
;; (save-excursion
;; (search-forward "\r" eol t))))
;; ;; This is the VMS version.
;; (let (opoint hidden case-fold-search)
;; (setq opoint (point))
-;; (or eol (setq eol (save-excursion (end-of-line) (point))))
+;; (or eol (setq eol (line-end-position)))
;; (setq hidden (and selective-display
;; (save-excursion (search-forward "\r" eol t))))
;; (if hidden
;; ;; This is the MTS version.
;; (let (opoint hidden case-fold-search)
;; (setq opoint (point)
-;; eol (save-excursion (end-of-line) (point))
+;; eol (line-end-position)
;; hidden (and selective-display
;; (save-excursion (search-forward "\r" eol t))))
;; (if hidden
;; ;; This is the CMS version.
;; (let ((opoint (point))
;; case-fold-search hidden)
-;; (or eol (setq eol (save-excursion (end-of-line) (point))))
+;; (or eol (setq eol (line-end-position)))
;; (setq hidden (and selective-display
;; (save-excursion
;; (search-forward "\r" eol t))))
(provide 'ange-ftp)
-;; arch-tag: 2987ef88-cb56-4ec1-87a9-79132572e316
;;; ange-ftp.el ends here
HCoop / bpt / emacs.git / blobdiff