;;; tramp-gvfs.el --- Tramp access functions for GVFS daemon
-;; Copyright (C) 2009-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
;; discovered during development time, is given in respective
;; comments.
-;; The customer option `tramp-gvfs-methods' contains the list of
-;; supported connection methods. Per default, these are "dav",
+;; The custom option `tramp-gvfs-methods' contains the list of
+;; supported connection methods. Per default, these are "afp", "dav",
;; "davs", "obex", "sftp" and "synce". Note that with "obex" it might
;; be necessary to pair with the other bluetooth device, if it hasn't
;; been done already. There might be also some few seconds delay in
;; For hostname completion, information is retrieved either from the
;; bluez daemon (for the "obex" method), the hal daemon (for the
-;; "synce" method), or from the zeroconf daemon (for the "dav",
+;; "synce" method), or from the zeroconf daemon (for the "afp", "dav",
;; "davs", and "sftp" methods). The zeroconf daemon is pre-configured
;; to discover services in the "local" domain. If another domain
-;; shall be used for discovering services, the customer option
+;; shall be used for discovering services, the custom option
;; `tramp-gvfs-zeroconf-domain' can be set accordingly.
;; Restrictions:
-;; * The current GVFS implementation does not allow to write on the
+;; * The current GVFS implementation does not allow writing on the
;; remote bluetooth device via OBEX.
;;
;; * Two shares of the same SMB server cannot be mounted in parallel.
(require 'custom))
;;;###tramp-autoload
-(defcustom tramp-gvfs-methods '("dav" "davs" "obex" "sftp" "synce")
+(defcustom tramp-gvfs-methods '("afp" "dav" "davs" "obex" "sftp" "synce")
"List of methods for remote files, accessed with GVFS."
:group 'tramp
- :version "23.2"
- :type '(repeat (choice (const "dav")
+ :version "25.1"
+ :type '(repeat (choice (const "afp")
+ (const "dav")
(const "davs")
(const "ftp")
(const "obex")
;;;###tramp-autoload
(add-to-list 'tramp-default-user-alist '("\\`synce\\'" nil nil))
+;;;###tramp-autoload
(defcustom tramp-gvfs-zeroconf-domain "local"
"Zeroconf domain to be used for discovering services, like host names."
:group 'tramp
;; ARRAY BYTE mount_prefix
;; ARRAY
;; STRUCT mount_spec_item
-;; STRING key (server, share, type, user, host, port)
+;; STRING key (type, user, domain, host, server,
+;; share, volume, port, ssl)
;; ARRAY BYTE value
;; ARRAY BYTE default_location Since GVFS 1.5 only !!!
;; </signal>
;; </interface>
+;;;###tramp-autoload
(defcustom tramp-bluez-discover-devices-timeout 60
"Defines seconds since last bluetooth device discovery before rescanning.
A value of 0 would require an immediate discovery during hostname
(directory-files . tramp-handle-directory-files)
(directory-files-and-attributes
. tramp-handle-directory-files-and-attributes)
- (dired-call-process . ignore)
(dired-compress-file . ignore)
(dired-uncache . tramp-handle-dired-uncache)
(expand-file-name . tramp-gvfs-handle-expand-file-name)
(file-acl . ignore)
(file-attributes . tramp-gvfs-handle-file-attributes)
(file-directory-p . tramp-gvfs-handle-file-directory-p)
- ;; `file-equal-p' performed by default handler.
+ (file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-gvfs-handle-file-executable-p)
(file-exists-p . tramp-handle-file-exists-p)
- ;; `file-in-directory-p' performed by default handler.
+ (file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-gvfs-handle-file-local-copy)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-gvfs-handle-file-name-all-completions)
(file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
(file-notify-add-watch . tramp-gvfs-handle-file-notify-add-watch)
(file-notify-rm-watch . tramp-handle-file-notify-rm-watch)
+ (file-notify-valid-p . tramp-handle-file-notify-valid-p)
(file-ownership-preserved-p . ignore)
(file-readable-p . tramp-gvfs-handle-file-readable-p)
(file-regular-p . tramp-handle-file-regular-p)
(shell-command . ignore)
(start-file-process . ignore)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
- (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
+ (unhandled-file-name-directory . ignore)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-gvfs-handle-write-region))
(put 'with-tramp-dbus-call-method 'lisp-indent-function 2)
(put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body))
-(tramp-compat-font-lock-add-keywords
- 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>"))
+(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>"))
(defvar tramp-gvfs-dbus-event-vector nil
"Current Tramp file name to be used, as vector.
\f
;; File name primitives.
+(defun tramp-gvfs-do-copy-or-rename-file
+ (op filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ "Copy or rename a remote file.
+OP must be `copy' or `rename' and indicates the operation to perform.
+FILENAME specifies the file to copy or rename, NEWNAME is the name of
+the new file (for copy) or the new name of the file (for rename).
+OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already.
+KEEP-DATE means to make sure that NEWNAME has the same timestamp
+as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
+the uid and gid if both files are on the same host.
+PRESERVE-EXTENDED-ATTRIBUTES is ignored.
+
+This function is invoked by `tramp-gvfs-handle-copy-file' and
+`tramp-gvfs-handle-rename-file'. It is an error if OP is neither
+of `copy' and `rename'. FILENAME and NEWNAME must be absolute
+file names."
+ (unless (memq op '(copy rename))
+ (error "Unknown operation `%s', must be `copy' or `rename'" op))
+
+ (let ((t1 (tramp-tramp-file-p filename))
+ (t2 (tramp-tramp-file-p newname))
+ (equal-remote (tramp-equal-remote filename newname))
+ (file-operation (intern (format "%s-file" op)))
+ (gvfs-operation (if (eq op 'copy) "gvfs-copy" "gvfs-move"))
+ (msg-operation (if (eq op 'copy) "Copying" "Renaming")))
+
+ (with-parsed-tramp-file-name (if t1 filename newname) nil
+ (when (and (not ok-if-already-exists) (file-exists-p newname))
+ (tramp-error
+ v 'file-already-exists "File %s already exists" newname))
+
+ (if (or (and equal-remote
+ (tramp-get-connection-property v "direct-copy-failed" nil))
+ (and t1 (not (tramp-gvfs-file-name-p filename)))
+ (and t2 (not (tramp-gvfs-file-name-p newname))))
+
+ ;; We cannot copy or rename directly.
+ ;; PRESERVE-EXTENDED-ATTRIBUTES has been introduced with
+ ;; Emacs 24.1 (as PRESERVE-SELINUX-CONTEXT), and renamed
+ ;; in Emacs 24.3.
+ (let ((tmpfile (tramp-compat-make-temp-file filename)))
+ (cond
+ (preserve-extended-attributes
+ (funcall
+ file-operation
+ filename tmpfile t keep-date preserve-uid-gid
+ preserve-extended-attributes))
+ (t
+ (funcall
+ file-operation filename tmpfile t keep-date preserve-uid-gid)))
+ (rename-file tmpfile newname ok-if-already-exists))
+
+ ;; Direct action.
+ (with-tramp-progress-reporter
+ v 0 (format "%s %s to %s" msg-operation filename newname)
+ (unless
+ (apply
+ 'tramp-gvfs-send-command v gvfs-operation
+ (append
+ (and (eq op 'copy) (or keep-date preserve-uid-gid)
+ (list "--preserve"))
+ (list
+ (tramp-gvfs-url-file-name filename)
+ (tramp-gvfs-url-file-name newname))))
+
+ (if (or (not equal-remote)
+ (and equal-remote
+ (tramp-get-connection-property
+ v "direct-copy-failed" nil)))
+ ;; Propagate the error.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (tramp-error-with-buffer
+ nil v 'file-error
+ "%s failed, see buffer `%s' for details."
+ msg-operation (buffer-name)))
+
+ ;; Some WebDAV server, like the one from QNAP, do not
+ ;; support direct copy/move. Try a fallback.
+ (tramp-set-connection-property v "direct-copy-failed" t)
+ (tramp-gvfs-do-copy-or-rename-file
+ op filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes))))
+
+ (when (and t1 (eq op 'rename))
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-file-property v localname)))
+
+ (when t2
+ (with-parsed-tramp-file-name newname nil
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-file-property v localname)))))))
+
(defun tramp-gvfs-handle-copy-file
(filename newname &optional ok-if-already-exists keep-date
preserve-uid-gid preserve-extended-attributes)
"Like `copy-file' for Tramp files."
- (with-parsed-tramp-file-name
- (if (tramp-tramp-file-p filename) filename newname) nil
-
- (when (and (not ok-if-already-exists) (file-exists-p newname))
- (tramp-error
- v 'file-already-exists "File %s already exists" newname))
-
- (if (or (and (tramp-tramp-file-p filename)
- (not (tramp-gvfs-file-name-p filename)))
- (and (tramp-tramp-file-p newname)
- (not (tramp-gvfs-file-name-p newname))))
-
- ;; We cannot call `copy-file' directly. Use
- ;; `tramp-compat-funcall' for backward compatibility (number
- ;; of arguments).
- (let ((tmpfile (tramp-compat-make-temp-file filename)))
- (cond
- (preserve-extended-attributes
- (tramp-compat-funcall
- 'copy-file
- filename tmpfile t keep-date preserve-uid-gid
- preserve-extended-attributes))
- (preserve-uid-gid
- (tramp-compat-funcall
- 'copy-file filename tmpfile t keep-date preserve-uid-gid))
- (t
- (copy-file filename tmpfile t keep-date)))
- (rename-file tmpfile newname ok-if-already-exists))
-
- ;; Direct copy.
- (with-tramp-progress-reporter
- v 0 (format "Copying %s to %s" filename newname)
- (unless
- (let ((args
- (append (if (or keep-date preserve-uid-gid)
- (list "--preserve")
- nil)
- (list
- (tramp-gvfs-url-file-name filename)
- (tramp-gvfs-url-file-name newname)))))
- (apply 'tramp-gvfs-send-command v "gvfs-copy" args))
- ;; Propagate the error.
- (with-current-buffer (tramp-get-connection-buffer v)
- (goto-char (point-min))
- (tramp-error-with-buffer
- nil v 'file-error
- "Copying failed, see buffer `%s' for details." (buffer-name)))))
-
- (when (tramp-tramp-file-p newname)
- (with-parsed-tramp-file-name newname nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname))))))
+ (setq filename (expand-file-name filename))
+ (setq newname (expand-file-name newname))
+ (cond
+ ;; At least one file a Tramp file?
+ ((or (tramp-tramp-file-p filename)
+ (tramp-tramp-file-p newname))
+ (tramp-gvfs-do-copy-or-rename-file
+ 'copy filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes))
+ ;; Compat section. PRESERVE-EXTENDED-ATTRIBUTES has been
+ ;; introduced with Emacs 24.1 (as PRESERVE-SELINUX-CONTEXT), and
+ ;; renamed in Emacs 24.3.
+ (preserve-extended-attributes
+ (tramp-run-real-handler
+ 'copy-file
+ (list filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)))
+ (t
+ (tramp-run-real-handler
+ 'copy-file
+ (list filename newname ok-if-already-exists keep-date preserve-uid-gid)))))
(defun tramp-gvfs-handle-delete-directory (directory &optional recursive trash)
"Like `delete-directory' for Tramp files."
(unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
(setq localname (concat "/" localname)))
;; We do not pass "/..".
- (if (string-equal "smb" method)
+ (if (string-match "^\\(afp\\|smb\\)$" method)
(when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname)
(setq localname (replace-match "/" t t localname 1)))
(when (string-match "^/\\.\\./?" localname)
(defun tramp-gvfs-handle-file-attributes (filename &optional id-format)
"Like `file-attributes' for Tramp files."
(unless id-format (setq id-format 'integer))
- ;; Don't modify `last-coding-system-used' by accident.
- (let ((last-coding-system-used last-coding-system-used)
- dirp res-symlink-target res-numlinks res-uid res-gid res-access
- res-mod res-change res-size res-filemodes res-inode res-device)
- (with-parsed-tramp-file-name filename nil
- (with-tramp-file-property
- v localname (format "file-attributes-%s" id-format)
- (tramp-message v 5 "file attributes: %s" localname)
- (tramp-gvfs-send-command
- v "gvfs-info" (tramp-gvfs-url-file-name filename))
- ;; Parse output ...
- (with-current-buffer (tramp-get-connection-buffer v)
- (goto-char (point-min))
- (when (re-search-forward "attributes:" nil t)
- ;; ... directory or symlink
- (goto-char (point-min))
- (setq dirp (if (re-search-forward "type:\\s-+directory" nil t) t))
- (goto-char (point-min))
- (setq res-symlink-target
- (if (re-search-forward
- "standard::symlink-target:\\s-+\\(\\S-+\\)" nil t)
- (match-string 1)))
- ;; ... number links
- (goto-char (point-min))
- (setq res-numlinks
- (if (re-search-forward "unix::nlink:\\s-+\\([0-9]+\\)" nil t)
- (string-to-number (match-string 1)) 0))
- ;; ... uid and gid
- (goto-char (point-min))
- (setq res-uid
- (or (if (eq id-format 'integer)
- (if (re-search-forward
- "unix::uid:\\s-+\\([0-9]+\\)" nil t)
- (string-to-number (match-string 1)))
- (if (re-search-forward
- "owner::user:\\s-+\\(\\S-+\\)" nil t)
- (match-string 1)))
- (tramp-get-local-uid id-format)))
- (setq res-gid
- (or (if (eq id-format 'integer)
- (if (re-search-forward
- "unix::gid:\\s-+\\([0-9]+\\)" nil t)
- (string-to-number (match-string 1)))
- (if (re-search-forward
- "owner::group:\\s-+\\(\\S-+\\)" nil t)
- (match-string 1)))
- (tramp-get-local-gid id-format)))
- ;; ... last access, modification and change time
- (goto-char (point-min))
- (setq res-access
- (if (re-search-forward
- "time::access:\\s-+\\([0-9]+\\)" nil t)
- (seconds-to-time (string-to-number (match-string 1)))
- '(0 0)))
- (goto-char (point-min))
- (setq res-mod
- (if (re-search-forward
- "time::modified:\\s-+\\([0-9]+\\)" nil t)
- (seconds-to-time (string-to-number (match-string 1)))
- '(0 0)))
- (goto-char (point-min))
- (setq res-change
- (if (re-search-forward
- "time::changed:\\s-+\\([0-9]+\\)" nil t)
- (seconds-to-time (string-to-number (match-string 1)))
- '(0 0)))
- ;; ... size
- (goto-char (point-min))
- (setq res-size
- (if (re-search-forward
- "standard::size:\\s-+\\([0-9]+\\)" nil t)
- (string-to-number (match-string 1)) 0))
- ;; ... file mode flags
- (goto-char (point-min))
- (setq res-filemodes
- (if (re-search-forward "unix::mode:\\s-+\\([0-9]+\\)" nil t)
- (tramp-file-mode-from-int
- (string-to-number (match-string 1)))
- (if dirp "drwx------" "-rwx------")))
- ;; ... inode and device
- (goto-char (point-min))
- (setq res-inode
- (if (re-search-forward "unix::inode:\\s-+\\([0-9]+\\)" nil t)
- (string-to-number (match-string 1))
- (tramp-get-inode v)))
+ (ignore-errors
+ ;; Don't modify `last-coding-system-used' by accident.
+ (let ((last-coding-system-used last-coding-system-used)
+ (process-environment (cons "LC_MESSAGES=C" process-environment))
+ dirp res-symlink-target res-numlinks res-uid res-gid res-access
+ res-mod res-change res-size res-filemodes res-inode res-device)
+ (with-parsed-tramp-file-name filename nil
+ (with-tramp-file-property
+ v localname (format "file-attributes-%s" id-format)
+ (tramp-message v 5 "file attributes: %s" localname)
+ (tramp-gvfs-send-command
+ v "gvfs-info" (tramp-gvfs-url-file-name filename))
+ ;; Parse output ...
+ (with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
- (setq res-device
- (if (re-search-forward "unix::device:\\s-+\\([0-9]+\\)" nil t)
- (string-to-number (match-string 1))
- (tramp-get-device v)))
-
- ;; Return data gathered.
- (list
- ;; 0. t for directory, string (name linked to) for
- ;; symbolic link, or nil.
- (or dirp res-symlink-target)
- ;; 1. Number of links to file.
- res-numlinks
- ;; 2. File uid.
- res-uid
- ;; 3. File gid.
- res-gid
- ;; 4. Last access time, as a list of integers.
- ;; 5. Last modification time, likewise.
- ;; 6. Last status change time, likewise.
- res-access res-mod res-change
- ;; 7. Size in bytes (-1, if number is out of range).
- res-size
- ;; 8. File modes.
- res-filemodes
- ;; 9. t if file's gid would change if file were deleted
- ;; and recreated.
- nil
- ;; 10. Inode number.
- res-inode
- ;; 11. Device number.
- res-device
- )))))))
+ (when (re-search-forward "attributes:" nil t)
+ ;; ... directory or symlink
+ (goto-char (point-min))
+ (setq dirp (if (re-search-forward "type: directory" nil t) t))
+ (goto-char (point-min))
+ (setq res-symlink-target
+ (if (re-search-forward
+ "standard::symlink-target: \\(.+\\)$" nil t)
+ (match-string 1)))
+ ;; ... number links
+ (goto-char (point-min))
+ (setq res-numlinks
+ (if (re-search-forward "unix::nlink: \\([0-9]+\\)" nil t)
+ (string-to-number (match-string 1)) 0))
+ ;; ... uid and gid
+ (goto-char (point-min))
+ (setq res-uid
+ (if (eq id-format 'integer)
+ (if (re-search-forward "unix::uid: \\([0-9]+\\)" nil t)
+ (string-to-number (match-string 1))
+ -1)
+ (if (re-search-forward "owner::user: \\(.+\\)$" nil t)
+ (match-string 1)
+ "UNKNOWN")))
+ (setq res-gid
+ (if (eq id-format 'integer)
+ (if (re-search-forward "unix::gid: \\([0-9]+\\)" nil t)
+ (string-to-number (match-string 1))
+ -1)
+ (if (re-search-forward "owner::group: \\(.+\\)$" nil t)
+ (match-string 1)
+ "UNKNOWN")))
+ ;; ... last access, modification and change time
+ (goto-char (point-min))
+ (setq res-access
+ (if (re-search-forward "time::access: \\([0-9]+\\)" nil t)
+ (seconds-to-time (string-to-number (match-string 1)))
+ '(0 0)))
+ (goto-char (point-min))
+ (setq res-mod
+ (if (re-search-forward "time::modified: \\([0-9]+\\)" nil t)
+ (seconds-to-time (string-to-number (match-string 1)))
+ '(0 0)))
+ (goto-char (point-min))
+ (setq res-change
+ (if (re-search-forward "time::changed: \\([0-9]+\\)" nil t)
+ (seconds-to-time (string-to-number (match-string 1)))
+ '(0 0)))
+ ;; ... size
+ (goto-char (point-min))
+ (setq res-size
+ (if (re-search-forward "standard::size: \\([0-9]+\\)" nil t)
+ (string-to-number (match-string 1)) 0))
+ ;; ... file mode flags
+ (goto-char (point-min))
+ (setq res-filemodes
+ (if (re-search-forward "unix::mode: \\([0-9]+\\)" nil t)
+ (tramp-file-mode-from-int
+ (string-to-number (match-string 1)))
+ (if dirp "drwx------" "-rwx------")))
+ ;; ... inode and device
+ (goto-char (point-min))
+ (setq res-inode
+ (if (re-search-forward "unix::inode: \\([0-9]+\\)" nil t)
+ (string-to-number (match-string 1))
+ (tramp-get-inode v)))
+ (goto-char (point-min))
+ (setq res-device
+ (if (re-search-forward "unix::device: \\([0-9]+\\)" nil t)
+ (string-to-number (match-string 1))
+ (tramp-get-device v)))
+
+ ;; Return data gathered.
+ (list
+ ;; 0. t for directory, string (name linked to) for
+ ;; symbolic link, or nil.
+ (or dirp res-symlink-target)
+ ;; 1. Number of links to file.
+ res-numlinks
+ ;; 2. File uid.
+ res-uid
+ ;; 3. File gid.
+ res-gid
+ ;; 4. Last access time, as a list of integers.
+ ;; 5. Last modification time, likewise.
+ ;; 6. Last status change time, likewise.
+ res-access res-mod res-change
+ ;; 7. Size in bytes (-1, if number is out of range).
+ res-size
+ ;; 8. File modes.
+ res-filemodes
+ ;; 9. t if file's gid would change if file were deleted
+ ;; and recreated.
+ nil
+ ;; 10. Inode number.
+ res-inode
+ ;; 11. Device number.
+ res-device
+ ))))))))
(defun tramp-gvfs-handle-file-directory-p (filename)
"Like `file-directory-p' for Tramp files."
(tramp-error
v 'file-error
"Cannot make local copy of non-existing file `%s'" filename))
- (copy-file filename tmpfile t t)
+ (copy-file filename tmpfile 'ok-if-already-exists 'keep-time)
tmpfile)))
(defun tramp-gvfs-handle-file-name-all-completions (filename directory)
(when cache-hit (list cache-hit))))
;; We cannot use a length of 0, because file properties
;; for "foo" and "foo/" are identical.
- (tramp-compat-number-sequence (length filename) 1 -1)))))
+ (number-sequence (length filename) 1 -1)))))
;; Cache expired or no matching cache entry found so we need
;; to perform a remote operation.
v (concat localname filename)
"file-name-all-completions" result))))))))
-(defun tramp-gvfs-handle-file-notify-add-watch (file-name _flags _callback)
+(defun tramp-gvfs-handle-file-notify-add-watch (file-name flags _callback)
"Like `file-notify-add-watch' for Tramp files."
(setq file-name (expand-file-name file-name))
(with-parsed-tramp-file-name file-name nil
- (let ((p (start-process
- "gvfs-monitor-file" (generate-new-buffer " *gvfs-monitor-file*")
- "gvfs-monitor-file" (tramp-gvfs-url-file-name file-name))))
+ ;; We cannot watch directories, because `gvfs-monitor-dir' is not
+ ;; supported for gvfs-mounted directories.
+ (when (file-directory-p file-name)
+ (tramp-error
+ v 'file-notify-error "Monitoring not supported for `%s'" file-name))
+ (let* ((default-directory (file-name-directory file-name))
+ (events
+ (cond
+ ((and (memq 'change flags) (memq 'attribute-change flags))
+ '(created changed changes-done-hint moved deleted
+ attribute-changed))
+ ((memq 'change flags)
+ '(created changed changes-done-hint moved deleted))
+ ((memq 'attribute-change flags) '(attribute-changed))))
+ (p (start-process
+ "gvfs-monitor-file" (generate-new-buffer " *gvfs-monitor-file*")
+ "gvfs-monitor-file" (tramp-gvfs-url-file-name file-name))))
(if (not (processp p))
(tramp-error
- v 'file-notify-error "gvfs-monitor-file failed to start")
+ v 'file-notify-error "Monitoring not supported for `%s'" file-name)
(tramp-message
v 6 "Run `%s', %S" (mapconcat 'identity (process-command p) " ") p)
(tramp-set-connection-property p "vector" v)
- (tramp-compat-set-process-query-on-exit-flag p nil)
- (set-process-filter p 'tramp-gvfs-file-gvfs-monitor-file-process-filter)
- (with-current-buffer (process-buffer p)
- (setq default-directory (file-name-directory file-name)))
+ (process-put p 'events events)
+ (process-put p 'watch-name localname)
+ (set-process-query-on-exit-flag p nil)
+ (set-process-filter p 'tramp-gvfs-monitor-file-process-filter)
+ ;; There might be an error if the monitor is not supported.
+ ;; Give the filter a chance to read the output.
+ (tramp-accept-process-output p 1)
+ (unless (memq (process-status p) '(run open))
+ (tramp-error
+ v 'file-notify-error "Monitoring not supported for `%s'" file-name))
p))))
-(defun tramp-gvfs-file-gvfs-monitor-file-process-filter (proc string)
- "Read output from \"gvfs-monitor-file\" and add corresponding file-notify events."
- (let* ((rest-string (tramp-compat-process-get proc 'rest-string))
+(defun tramp-gvfs-monitor-file-process-filter (proc string)
+ "Read output from \"gvfs-monitor-file\" and add corresponding \
+file-notify events."
+ (let* ((rest-string (process-get proc 'rest-string))
(dd (with-current-buffer (process-buffer proc) default-directory))
(ddu (regexp-quote (tramp-gvfs-url-file-name dd))))
(when rest-string
(tramp-message proc 6 "%S\n%s" proc string)
(setq string (concat rest-string string)
;; Attribute change is returned in unused wording.
- string (tramp-compat-replace-regexp-in-string
+ string (replace-regexp-in-string
"ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string))
+ (when (string-match "Monitoring not supported" string)
+ (delete-process proc))
(while (string-match
(concat "^[\n\r]*"
"File = \\([^\n\r]+\\)[\n\r]+"
"Event = \\([^[:blank:]]+\\)[\n\r]+")
string)
- (let ((action (intern-soft
- (tramp-compat-replace-regexp-in-string
- "_" "-" (downcase (match-string 2 string)))))
- (file (match-string 1 string)))
+ (let ((file (match-string 1 string))
+ (action (intern-soft
+ (replace-regexp-in-string
+ "_" "-" (downcase (match-string 2 string))))))
(setq string (replace-match "" nil nil string))
;; File names are returned as URL paths. We must convert them.
(when (string-match ddu file)
;; Save rest of the string.
(when (zerop (length string)) (setq string nil))
(when string (tramp-message proc 10 "Rest string:\n%s" string))
- (tramp-compat-process-put proc 'rest-string string)))
+ (process-put proc 'rest-string string)))
(defun tramp-gvfs-handle-file-readable-p (filename)
"Like `file-readable-p' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (with-tramp-file-property v localname "file-executable-p"
+ (with-tramp-file-property v localname "file-readable-p"
(tramp-check-cached-permissions v ?r))))
(defun tramp-gvfs-handle-file-writable-p (filename)
(defun tramp-gvfs-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
+ (setq dir (directory-file-name (expand-file-name dir)))
(with-parsed-tramp-file-name dir nil
- (unless
- (apply
- 'tramp-gvfs-send-command v "gvfs-mkdir"
- (if parents
- (list "-p" (tramp-gvfs-url-file-name dir))
- (list (tramp-gvfs-url-file-name dir))))
- ;; Propagate the error.
- (tramp-error v 'file-error "Couldn't make directory %s" dir))))
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-directory-property v localname)
+ (save-match-data
+ (let ((ldir (file-name-directory dir)))
+ ;; Make missing directory parts. "gvfs-mkdir -p ..." does not
+ ;; work robust.
+ (when (and parents (not (file-directory-p ldir)))
+ (make-directory ldir parents))
+ ;; Just do it.
+ (unless (tramp-gvfs-send-command
+ v "gvfs-mkdir" (tramp-gvfs-url-file-name dir))
+ (tramp-error v 'file-error "Couldn't make directory %s" dir))))))
(defun tramp-gvfs-handle-rename-file
(filename newname &optional ok-if-already-exists)
"Like `rename-file' for Tramp files."
- (with-parsed-tramp-file-name
- (if (tramp-tramp-file-p filename) filename newname) nil
-
- (when (and (not ok-if-already-exists) (file-exists-p newname))
- (tramp-error
- v 'file-already-exists "File %s already exists" newname))
-
- (if (or (and (tramp-tramp-file-p filename)
- (not (tramp-gvfs-file-name-p filename)))
- (and (tramp-tramp-file-p newname)
- (not (tramp-gvfs-file-name-p newname))))
-
- ;; We cannot move directly.
- (let ((tmpfile (tramp-compat-make-temp-file filename)))
- (rename-file filename tmpfile t)
- (rename-file tmpfile newname ok-if-already-exists))
-
- ;; Direct move.
- (with-tramp-progress-reporter
- v 0 (format "Renaming %s to %s" filename newname)
- (unless
- (tramp-gvfs-send-command
- v "gvfs-move"
- (tramp-gvfs-url-file-name filename)
- (tramp-gvfs-url-file-name newname))
- ;; Propagate the error.
- (with-current-buffer (tramp-get-buffer v)
- (goto-char (point-min))
- (tramp-error-with-buffer
- nil v 'file-error
- "Renaming failed, see buffer `%s' for details." (buffer-name)))))
-
- (when (tramp-tramp-file-p filename)
- (with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)))
-
- (when (tramp-tramp-file-p newname)
- (with-parsed-tramp-file-name newname nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname))))))
+ ;; Check if both files are local -- invoke normal rename-file.
+ ;; Otherwise, use Tramp from local system.
+ (setq filename (expand-file-name filename))
+ (setq newname (expand-file-name newname))
+ ;; At least one file a Tramp file?
+ (if (or (tramp-tramp-file-p filename)
+ (tramp-tramp-file-p newname))
+ (tramp-gvfs-do-copy-or-rename-file
+ 'rename filename newname ok-if-already-exists
+ 'keep-date 'preserve-uid-gid)
+ (tramp-run-real-handler
+ 'rename-file (list filename newname ok-if-already-exists))))
(defun tramp-gvfs-handle-write-region
(start end filename &optional append visit lockname confirm)
"Like `write-region' for Tramp files."
(with-parsed-tramp-file-name filename nil
- ;; XEmacs takes a coding system as the seventh argument, not `confirm'.
- (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename))
+ (when (and confirm (file-exists-p filename))
(unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename))
(tramp-error v 'file-error "File not overwritten")))
(defun tramp-gvfs-file-name (object-path)
"Retrieve file name from D-Bus OBJECT-PATH."
(dbus-unescape-from-identifier
- (tramp-compat-replace-regexp-in-string
- "^.*/\\([^/]+\\)$" "\\1" object-path)))
+ (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path)))
(defun tramp-bluez-address (device)
"Return bluetooth device address from a given bluetooth DEVICE name."
;; host signature.
(with-temp-buffer
;; Preserve message for `progress-reporter'.
- (tramp-compat-with-temp-message ""
+ (with-temp-message ""
(insert message)
(pop-to-buffer (current-buffer))
(setq choice (if (yes-or-no-p (concat (car choices) " ")) 0 1))
(cadr (assoc "port" (cadr mount-spec)))))
(ssl (tramp-gvfs-dbus-byte-array-to-string
(cadr (assoc "ssl" (cadr mount-spec)))))
- (prefix (concat (tramp-gvfs-dbus-byte-array-to-string
- (car mount-spec))
- (tramp-gvfs-dbus-byte-array-to-string
- (cadr (assoc "share" (cadr mount-spec)))))))
- (when (string-match "^smb" method)
- (setq method "smb"))
+ (prefix (concat
+ (tramp-gvfs-dbus-byte-array-to-string
+ (car mount-spec))
+ (tramp-gvfs-dbus-byte-array-to-string
+ (or (cadr (assoc "share" (cadr mount-spec)))
+ (cadr (assoc "volume" (cadr mount-spec))))))))
+ (when (string-match "^\\(afp\\|smb\\)" method)
+ (setq method (match-string 1 method)))
(when (string-equal "obex" method)
(setq host (tramp-bluez-device host)))
(when (and (string-equal "dav" method) (string-equal "true" ssl))
(cadr (assoc "port" (cadr mount-spec)))))
(ssl (tramp-gvfs-dbus-byte-array-to-string
(cadr (assoc "ssl" (cadr mount-spec)))))
- (prefix (concat (tramp-gvfs-dbus-byte-array-to-string
- (car mount-spec))
- (tramp-gvfs-dbus-byte-array-to-string
- (cadr (assoc "share" (cadr mount-spec)))))))
- (when (string-match "^smb" method)
- (setq method "smb"))
+ (prefix (concat
+ (tramp-gvfs-dbus-byte-array-to-string
+ (car mount-spec))
+ (tramp-gvfs-dbus-byte-array-to-string
+ (or
+ (cadr (assoc "share" (cadr mount-spec)))
+ (cadr (assoc "volume" (cadr mount-spec))))))))
+ (when (string-match "^\\(afp\\|smb\\)" method)
+ (setq method (match-string 1 method)))
(when (string-equal "obex" method)
(setq host (tramp-bluez-device host)))
(when (and (string-equal "dav" method) (string-equal "true" ssl))
(host (tramp-file-name-real-host vec))
(port (tramp-file-name-port vec))
(localname (tramp-file-name-localname vec))
- (ssl (if (string-match "^davs" method) "true" "false"))
+ (share (when (string-match "^/?\\([^/]+\\)" localname)
+ (match-string 1 localname)))
+ (ssl (when (string-match "^davs" method) "true" "false"))
(mount-spec
`(:array
,@(cond
((string-equal "smb" method)
- (string-match "^/?\\([^/]+\\)" localname)
(list (tramp-gvfs-mount-spec-entry "type" "smb-share")
(tramp-gvfs-mount-spec-entry "server" host)
- (tramp-gvfs-mount-spec-entry
- "share" (match-string 1 localname))))
+ (tramp-gvfs-mount-spec-entry "share" share)))
((string-equal "obex" method)
(list (tramp-gvfs-mount-spec-entry "type" method)
(tramp-gvfs-mount-spec-entry
(list (tramp-gvfs-mount-spec-entry "type" "dav")
(tramp-gvfs-mount-spec-entry "host" host)
(tramp-gvfs-mount-spec-entry "ssl" ssl)))
+ ((string-equal "afp" method)
+ (list (tramp-gvfs-mount-spec-entry "type" "afp-volume")
+ (tramp-gvfs-mount-spec-entry "host" host)
+ (tramp-gvfs-mount-spec-entry "volume" share)))
(t
(list (tramp-gvfs-mount-spec-entry "type" method)
(tramp-gvfs-mount-spec-entry "host" host))))
:name (tramp-buffer-name vec)
:buffer (tramp-get-connection-buffer vec)
:server t :host 'local :service t)))
- (tramp-compat-set-process-query-on-exit-flag p nil)))
+ (set-process-query-on-exit-flag p nil)))
(unless (tramp-gvfs-connection-mounted-p vec)
(let* ((method (tramp-file-name-method vec))
(string-equal localname "/"))
(tramp-error vec 'file-error "Filename must contain a Windows share"))
+ (when (and (string-equal method "afp")
+ (string-equal localname "/"))
+ (tramp-error vec 'file-error "Filename must contain an AFP volume"))
+
(with-tramp-progress-reporter
vec 3
(if (zerop (length user))
;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint"
;; file property.
(with-timeout
- ((or (tramp-get-method-parameter method 'tramp-connection-timeout)
+ ((or (tramp-get-method-parameter vec 'tramp-connection-timeout)
tramp-connection-timeout)
(if (zerop (length (tramp-file-name-user vec)))
(tramp-error
;; is marked with the fuse-mountpoint "/". We shall react.
(when (string-equal
(tramp-get-file-property vec "/" "fuse-mountpoint" "") "/")
- (tramp-error vec 'file-error "FUSE mount denied")))))
+ (tramp-error vec 'file-error "FUSE mount denied"))
+
+ ;; Mark it as connected.
+ (tramp-set-connection-property
+ (tramp-get-connection-process vec) "connected" t))))
;; In `tramp-check-cached-permissions', the connection properties
;; {uig,gid}-{integer,string} are used. We set them to their local
(defun tramp-gvfs-send-command (vec command &rest args)
"Send the COMMAND with its ARGS to connection VEC.
COMMAND is usually a command from the gvfs-* utilities.
-`call-process' is applied, and it returns `t' if the return code is zero."
+`call-process' is applied, and it returns t if the return code is zero."
(with-current-buffer (tramp-get-connection-buffer vec)
(tramp-gvfs-maybe-open-connection vec)
(erase-buffer)
\f
;; D-Bus zeroconf functions.
-(defun tramp-zeroconf-parse-workstation-device-names (_ignore)
- "Return a list of (user host) tuples allowed to access."
- (mapcar
- (lambda (x)
- (list nil (zeroconf-service-host x)))
- (zeroconf-list-services "_workstation._tcp")))
-
-(defun tramp-zeroconf-parse-webdav-device-names (_ignore)
+(defun tramp-zeroconf-parse-device-names (service)
"Return a list of (user host) tuples allowed to access."
(mapcar
(lambda (x)
(setq user (match-string 1 (car text))))
(setq text (cdr text)))
(list user host)))
- (zeroconf-list-services "_webdav._tcp")))
-
-;; Add completion function for SFTP, DAV and DAVS methods.
-(when (and tramp-gvfs-enabled
- (member zeroconf-service-avahi (dbus-list-known-names :system)))
+ (zeroconf-list-services service)))
+
+;; We use the TRIM argument of `split-string', which exist since Emacs
+;; 24.4. I mask this for older Emacs versions, there is no harm.
+(defun tramp-gvfs-parse-device-names (service)
+ "Return a list of (user host) tuples allowed to access.
+This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi."
+ (let ((result
+ (ignore-errors
+ (tramp-compat-funcall
+ 'split-string
+ (shell-command-to-string (format "avahi-browse -trkp %s" service))
+ "[\n\r]+" 'omit "^\\+;.*$"))))
+ (delete-dups
+ (mapcar
+ (lambda (x)
+ (let* ((list (split-string x ";"))
+ (host (nth 6 list))
+ (port (nth 8 list))
+ (text (tramp-compat-funcall
+ 'split-string (nth 9 list) "\" \"" 'omit "\""))
+ user)
+; (when (and port (not (string-equal port "0")))
+; (setq host (format "%s%s%s" host tramp-prefix-port-regexp port)))
+ ;; A user is marked in a TXT field like "u=guest".
+ (while text
+ (when (string-match "u=\\(.+\\)$" (car text))
+ (setq user (match-string 1 (car text))))
+ (setq text (cdr text)))
+ (list user host)))
+ result))))
+
+;; Add completion functions for AFP, DAV, DAVS, SFTP and SMB methods.
+(when tramp-gvfs-enabled
(zeroconf-init tramp-gvfs-zeroconf-domain)
- (tramp-set-completion-function
- "sftp" '((tramp-zeroconf-parse-workstation-device-names "")))
- (tramp-set-completion-function
- "dav" '((tramp-zeroconf-parse-webdav-device-names "")))
- (tramp-set-completion-function
- "davs" '((tramp-zeroconf-parse-webdav-device-names ""))))
+ (if (zeroconf-list-service-types)
+ (progn
+ (tramp-set-completion-function
+ "afp" '((tramp-zeroconf-parse-device-names "_afpovertcp._tcp")))
+ (tramp-set-completion-function
+ "dav" '((tramp-zeroconf-parse-device-names "_webdav._tcp")))
+ (tramp-set-completion-function
+ "davs" '((tramp-zeroconf-parse-device-names "_webdav._tcp")))
+ (tramp-set-completion-function
+ "sftp" '((tramp-zeroconf-parse-device-names "_ssh._tcp")
+ (tramp-zeroconf-parse-device-names "_workstation._tcp")))
+ (when (member "smb" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "smb" '((tramp-zeroconf-parse-device-names "_smb._tcp")))))
+
+ (when (executable-find "avahi-browse")
+ (tramp-set-completion-function
+ "afp" '((tramp-gvfs-parse-device-names "_afpovertcp._tcp")))
+ (tramp-set-completion-function
+ "dav" '((tramp-gvfs-parse-device-names "_webdav._tcp")))
+ (tramp-set-completion-function
+ "davs" '((tramp-gvfs-parse-device-names "_webdav._tcp")))
+ (tramp-set-completion-function
+ "sftp" '((tramp-gvfs-parse-device-names "_ssh._tcp")
+ (tramp-gvfs-parse-device-names "_workstation._tcp")))
+ (when (member "smb" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "smb" '((tramp-gvfs-parse-device-names "_smb._tcp")))))))
\f
;; D-Bus SYNCE functions.
;;; TODO:
-;; * Host name completion via smb-server or smb-network.
+;; * Host name completion via afp-server, smb-server or smb-network.
;; * Check how two shares of the same SMB server can be mounted in
;; parallel.
;; * Apply SDP on bluetooth devices, in order to filter out obex