Commit eeb44655 authored by Michael Albinus's avatar Michael Albinus
Browse files

* net/tramp-gvfs.el: New package.

parent 60cf2f33
;;; tramp-gvfs.el --- Tramp access functions for GVFS daemon
;; Copyright (C) 2009 Free Software Foundation, Inc.
;; Author: Michael Albinus <>
;; Keywords: comm, processes
;; This file is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This file is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <>.
;;; Commentary:
;; Access functions for the GVFS daemon from Tramp. Tested with GVFS
;; 1.0.2 (Ubuntu 8.10, Gnome 2.24).
;; All actions to mount a remote location, and to retrieve mount
;; information, are performed by D-Bus messages. File operations
;; themselves are performed via the mounted filesystem in ~/.gvfs.
;; Consequently, GNU Emacs 23.0.90 with enabled D-Bus bindings is a
;; precondition.
;; The GVFS D-Bus interface is said to be instable. There are even no
;; introspection data. The interface, as 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", "davs"
;; and "obex". 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 discovering available
;; bluetooth devices.
;; Other possible connection methods are "ftp", "sftp" and "smb".
;; When one of these methods is added to the list, the remote access
;; for that method is performed via GVFS instead of the native Tramp
;; implementation.
;; GVFS offers even more connection methods. The complete list of
;; connection methods of the actual GVFS implementation can be
;; retrieved by:
;; (message
;; "%s"
;; (mapcar
;; 'car
;; (dbus-call-method
;; :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
;; tramp-gvfs-interface-mounttracker "listMountableInfo")))
;; Note that all other connection methods are not tested, beside the
;; ones offered for customization in `tramp-gvfs-methods'. If you
;; request an additional connection method to be supported, please
;; drop me a note.
;; For hostname completion, information is retrieved either from the
;; bluez daemon (for the "obex" method), or from the zeroconf daemon
;; (for the "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 `tramp-gvfs-zeroconf-domain' can be set accordingly.
;; Restrictions:
;; * The current GVFS implementation does not allow to write on the
;; remote bluetooth device via OBEX.
;; * Two shares of the same SMB server cannot be mounted in parallel.
;;; Code:
;; D-Bus support in the Emacs core can be disabled with configuration
;; option "--without-dbus". Declare used subroutines and variables.
(declare-function dbus-call-method "dbusbind.c")
(declare-function dbus-call-method-asynchronously "dbusbind.c")
(declare-function dbus-get-unique-name "dbusbind.c")
(declare-function dbus-register-method "dbusbind.c")
(declare-function dbus-register-signal "dbusbind.c")
;; Pacify byte-compiler
(require 'cl)
(require 'custom))
(require 'tramp)
(require 'dbus)
(require 'url-parse)
(require 'zeroconf)
(defcustom tramp-gvfs-methods '("dav" "davs" "obex")
"*List of methods for remote files, accessed with GVFS."
:group 'tramp
:type '(repeat (choice (const "dav")
(const "davs")
(const "ftp")
(const "obex")
(const "sftp")
(const "smb"))))
(defcustom tramp-gvfs-zeroconf-domain "local"
"*Zeroconf domain to be used for discovering services, like host names."
:group 'tramp
:type 'string)
;; Add the methods to `tramp-methods', in order to allow minibuffer
;; completion.
(eval-after-load "tramp-gvfs"
'(when (featurep 'tramp-gvfs)
(dolist (elt tramp-gvfs-methods)
(unless (assoc elt tramp-methods)
(add-to-list 'tramp-methods (cons elt nil))))))
(defconst tramp-gvfs-mount-point
(file-name-as-directory (expand-file-name ".gvfs" "~/"))
"The directory name, fuses mounts remote ressources.")
(defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp")
"The preceeding object path for own objects.")
(defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon"
"The well known name of the GVFS daemon.")
;; Check that GVFS is available.
(unless (dbus-ping :session tramp-gvfs-service-daemon)
(message "GVFS daemon not running")
(throw 'tramp-loading nil))
(defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker"
"The object path of the GVFS daemon.")
(defconst tramp-gvfs-interface-mounttracker "org.gtk.vfs.MountTracker"
"The mount tracking interface in the GVFS daemon.")
;; <interface name='org.gtk.vfs.MountTracker'>
;; <method name='listMounts'>
;; <arg name='mount_info_list'
;; type='a{sosssssbay{aya{say}}}'
;; direction='out'/>
;; </method>
;; <method name='mountLocation'>
;; <arg name='mount_spec' type='{aya{say}}' direction='in'/>
;; <arg name='dbus_id' type='s' direction='in'/>
;; <arg name='object_path' type='o' direction='in'/>
;; </method>
;; <signal name='mounted'>
;; <arg name='mount_info'
;; type='{sosssssbay{aya{say}}}'/>
;; </signal>
;; <signal name='unmounted'>
;; <arg name='mount_info'
;; type='{sosssssbay{aya{say}}}'/>
;; </signal>
;; </interface>
;; STRUCT mount_info
;; STRING dbus_id
;; OBJECT_PATH object_path
;; STRING display_name
;; STRING stable_name
;; STRING x_content_types
;; STRING icon
;; STRING prefered_filename_encoding
;; BOOLEAN user_visible
;; ARRAY BYTE fuse_mountpoint
;; STRUCT mount_spec
;; ARRAY BYTE mount_prefix
;; STRUCT mount_spec_item
;; STRING key (server, share, type, user, host, port)
;; ARRAY BYTE value
(defconst tramp-gvfs-interface-mountoperation "org.gtk.vfs.MountOperation"
"Used by the dbus-proxying implementation of GMountOperation.")
;; <interface name='org.gtk.vfs.MountOperation'>
;; <method name='askPassword'>
;; <arg name='message' type='s' direction='in'/>
;; <arg name='default_user' type='s' direction='in'/>
;; <arg name='default_domain' type='s' direction='in'/>
;; <arg name='flags' type='u' direction='in'/>
;; <arg name='handled' type='b' direction='out'/>
;; <arg name='aborted' type='b' direction='out'/>
;; <arg name='password' type='s' direction='out'/>
;; <arg name='username' type='s' direction='out'/>
;; <arg name='domain' type='s' direction='out'/>
;; <arg name='anonymous' type='b' direction='out'/>
;; <arg name='password_save' type='u' direction='out'/>
;; </method>
;; <method name='askQuestion'>
;; <arg name='message' type='s' direction='in'/>
;; <arg name='choices' type='as' direction='in'/>
;; <arg name='handled' type='b' direction='out'/>
;; <arg name='aborted' type='b' direction='out'/>
;; <arg name='choice' type='u' direction='out'/>
;; </method>
;; </interface>
;; The following flags are used in "askPassword". They are defined in
;; /usr/include/glib-2.0/gio/gioenums.h.
(defconst tramp-gvfs-password-need-password 1
"Operation requires a password.")
(defconst tramp-gvfs-password-need-username 2
"Operation requires a username.")
(defconst tramp-gvfs-password-need-domain 4
"Operation requires a domain.")
(defconst tramp-gvfs-password-saving-supported 8
"Operation supports saving settings.")
(defconst tramp-gvfs-password-anonymous-supported 16
"Operation supports anonymous users.")
(defconst tramp-bluez-service "org.bluez"
"The well known name of the BLUEZ service.")
(defconst tramp-bluez-interface-manager "org.bluez.Manager"
"The manager interface of the BLUEZ daemon.")
;; <interface name='org.bluez.Manager'>
;; <method name='DefaultAdapter'>
;; <arg type='o' direction='out'/>
;; </method>
;; <method name='FindAdapter'>
;; <arg type='s' direction='in'/>
;; <arg type='o' direction='out'/>
;; </method>
;; <method name='ListAdapters'>
;; <arg type='ao' direction='out'/>
;; </method>
;; <signal name='AdapterAdded'>
;; <arg type='o'/>
;; </signal>
;; <signal name='AdapterRemoved'>
;; <arg type='o'/>
;; </signal>
;; <signal name='DefaultAdapterChanged'>
;; <arg type='o'/>
;; </signal>
;; </interface>
(defconst tramp-bluez-interface-adapter "org.bluez.Adapter"
"The adapter interface of the BLUEZ daemon.")
;; <interface name='org.bluez.Adapter'>
;; <method name='GetProperties'>
;; <arg type='a{sv}' direction='out'/>
;; </method>
;; <method name='SetProperty'>
;; <arg type='s' direction='in'/>
;; <arg type='v' direction='in'/>
;; </method>
;; <method name='RequestMode'>
;; <arg type='s' direction='in'/>
;; </method>
;; <method name='ReleaseMode'/>
;; <method name='RequestSession'/>
;; <method name='ReleaseSession'/>
;; <method name='StartDiscovery'/>
;; <method name='StopDiscovery'/>
;; <method name='ListDevices'>
;; <arg type='ao' direction='out'/>
;; </method>
;; <method name='CreateDevice'>
;; <arg type='s' direction='in'/>
;; <arg type='o' direction='out'/>
;; </method>
;; <method name='CreatePairedDevice'>
;; <arg type='s' direction='in'/>
;; <arg type='o' direction='in'/>
;; <arg type='s' direction='in'/>
;; <arg type='o' direction='out'/>
;; </method>
;; <method name='CancelDeviceCreation'>
;; <arg type='s' direction='in'/>
;; </method>
;; <method name='RemoveDevice'>
;; <arg type='o' direction='in'/>
;; </method>
;; <method name='FindDevice'>
;; <arg type='s' direction='in'/>
;; <arg type='o' direction='out'/>
;; </method>
;; <method name='RegisterAgent'>
;; <arg type='o' direction='in'/>
;; <arg type='s' direction='in'/>
;; </method>
;; <method name='UnregisterAgent'>
;; <arg type='o' direction='in'/>
;; </method>
;; <signal name='DeviceCreated'>
;; <arg type='o'/>
;; </signal>
;; <signal name='DeviceRemoved'>
;; <arg type='o'/>
;; </signal>
;; <signal name='DeviceFound'>
;; <arg type='s'/>
;; <arg type='a{sv}'/>
;; </signal>
;; <signal name='PropertyChanged'>
;; <arg type='s'/>
;; <arg type='v'/>
;; </signal>
;; <signal name='DeviceDisappeared'>
;; <arg type='s'/>
;; </signal>
;; </interface>
(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
completion, nil means to use always cached values for discovered
:group 'tramp
:type '(choice (const nil) integer))
(defvar tramp-bluez-discovery nil
"Indicator for a running bluetooth device discovery.
It keeps the timestamp of last discovery.")
(defvar tramp-bluez-devices nil
"Alist of detected bluetooth devices.
Every entry is a list (NAME ADDRESS).")
;; New handlers should be added here.
(defconst tramp-gvfs-file-name-handler-alist
(access-file . ignore)
(add-name-to-file . tramp-gvfs-handle-copy-file)
;; `byte-compiler-base-file-name' performed by default handler
(copy-file . tramp-gvfs-handle-copy-file)
(delete-directory . tramp-gvfs-handle-delete-directory)
(delete-file . tramp-gvfs-handle-delete-file)
;; `diff-latest-backup-file' performed by default handler
(directory-file-name . tramp-handle-directory-file-name)
(directory-files . tramp-gvfs-handle-directory-files)
. tramp-gvfs-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-accessible-directory-p' performed by default handler
(file-attributes . tramp-gvfs-handle-file-attributes)
(file-directory-p . tramp-smb-handle-file-directory-p)
(file-executable-p . tramp-gvfs-handle-file-executable-p)
(file-exists-p . tramp-gvfs-handle-file-exists-p)
(file-local-copy . tramp-gvfs-handle-file-local-copy)
(file-remote-p . tramp-handle-file-remote-p)
;; `file-modes' performed by default handler
(file-name-all-completions . tramp-gvfs-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
(file-name-completion . tramp-handle-file-name-completion)
(file-name-directory . tramp-handle-file-name-directory)
(file-name-nondirectory . tramp-handle-file-name-nondirectory)
;; `file-name-sans-versions' performed by default handler
(file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
(file-ownership-preserved-p . ignore)
(file-readable-p . tramp-gvfs-handle-file-readable-p)
(file-regular-p . tramp-handle-file-regular-p)
(file-symlink-p . tramp-handle-file-symlink-p)
;; `file-truename' performed by default handler
(file-writable-p . tramp-gvfs-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
;; `find-file-noselect' performed by default handler
;; `get-file-buffer' performed by default handler
(insert-directory . tramp-gvfs-handle-insert-directory)
(insert-file-contents . tramp-gvfs-handle-insert-file-contents)
(load . tramp-handle-load)
(make-directory . tramp-gvfs-handle-make-directory)
(make-directory-internal . ignore)
(make-symbolic-link . ignore)
(rename-file . tramp-gvfs-handle-rename-file)
(set-file-modes . tramp-gvfs-handle-set-file-modes)
(set-visited-file-modtime . tramp-gvfs-handle-set-visited-file-modtime)
(shell-command . ignore)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
(vc-registered . ignore)
. tramp-gvfs-handle-verify-visited-file-modtime)
(write-region . tramp-gvfs-handle-write-region)
"Alist of handler functions for Tramp GVFS method.
Operations not mentioned here will be handled by the default Emacs primitives.")
(defun tramp-gvfs-file-name-p (filename)
"Check if it's a filename handled by the GVFS daemon."
(and (tramp-tramp-file-p filename)
(let ((method
(tramp-file-name-method (tramp-dissect-file-name filename))))
(and (stringp method) (member method tramp-gvfs-methods)))))
(defun tramp-gvfs-file-name-handler (operation &rest args)
"Invoke the GVFS related OPERATION.
First arg specifies the OPERATION, second arg is a list of arguments to
pass to the OPERATION."
(let ((fn (assoc operation tramp-gvfs-file-name-handler-alist)))
(if fn
(save-match-data (apply (cdr fn) args))
(tramp-run-real-handler operation args))))
;; This might be moved to tramp.el. It shall be the first file name
;; handler.
(add-to-list 'tramp-foreign-file-name-handler-alist
(cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler))
(defmacro with-tramp-dbus-call-method
(vec synchronous bus service path interface method &rest args)
"Apply a D-Bus call on bus BUS.
If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise,
it is an asynchronous call, with `ignore' as callback function.
The other arguments have the same meaning as with `dbus-call-method'
or `dbus-call-method-asynchronously'. Additionally, the call
will be traced by Tramp with trace level 6."
`(let ((func (if ,synchronous
'dbus-call-method 'dbus-call-method-asynchronously))
(args (append (list ,bus ,service ,path ,interface ,method)
(if ,synchronous (list ,@args) (list 'ignore ,@args))))
(tramp-message ,vec 6 "%s %s" func args)
(setq result (apply func args))
(tramp-message ,vec 6 "\n%s" result)
(put 'with-tramp-dbus-call-method 'lisp-indent-function 2)
(put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body))
(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>"))
(defmacro with-tramp-gvfs-error-message (filename handler &rest args)
"Apply a Tramp GVFS `handler'.
In case of an error, modify the error message by replacing
`filename' with its GVFS mounted name."
`(let ((fuse-file-name (regexp-quote (tramp-gvfs-fuse-file-name ,filename)))
(condition-case err
(apply ,handler (list ,@args))
(setq elt (cdr err))
(while elt
(when (and (stringp (car elt))
(string-match fuse-file-name (car elt)))
(setcar elt (replace-match ,filename t t (car elt))))
(setq elt (cdr elt)))
(signal (car err) (cdr err))))))
(put 'with-tramp-gvfs-error-message 'lisp-indent-function 2)
(put 'with-tramp-gvfs-error-message 'edebug-form-spec '(form symbolp body))
(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-gvfs-error-message\\>"))
(defvar tramp-gvfs-dbus-event-vector nil
"Current Tramp file name to be used, as vector.
It is needed when D-Bus signals or errors arrive, because there
is no information where to trace the message.")
(defun tramp-gvfs-dbus-event-error (event err)
"Called when a D-Bus error message arrives, see `dbus-event-error-hooks'."
; (tramp-cleanup-connection tramp-gvfs-dbus-event-vector)
(tramp-message tramp-gvfs-dbus-event-vector 1 "%S" event)
(tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err)))
(add-hook 'dbus-event-error-hooks 'tramp-gvfs-dbus-event-error)
;; File name primitives.
(defun tramp-gvfs-handle-copy-file
(filename newname &optional ok-if-already-exists keep-date preserve-uid-gid)
"Like `copy-file' for Tramp files."
(if (tramp-gvfs-file-name-p filename)
(tramp-gvfs-fuse-file-name filename)
(if (tramp-gvfs-file-name-p newname)
(tramp-gvfs-fuse-file-name newname)
ok-if-already-exists keep-date preserve-uid-gid))
(defun tramp-gvfs-handle-delete-directory (directory)
"Like `delete-directory' for Tramp files."
(delete-directory (tramp-gvfs-fuse-file-name directory)))
(defun tramp-gvfs-handle-delete-file (filename)
"Like `delete-file' for Tramp files."
(delete-file (tramp-gvfs-fuse-file-name filename)))
(defun tramp-gvfs-handle-directory-files
(directory &optional full match nosort)
"Like `directory-files' for Tramp files."
(let ((fuse-file-name (tramp-gvfs-fuse-file-name directory)))
(lambda (x)
(if (string-match fuse-file-name x)
(replace-match directory t t x)
(directory-files fuse-file-name full match nosort))))
(defun tramp-gvfs-handle-directory-files-and-attributes
(directory &optional full match nosort id-format)
"Like `directory-files-and-attributes' for Tramp files."
(let ((fuse-file-name (tramp-gvfs-fuse-file-name directory)))
(lambda (x)
(when (string-match fuse-file-name (car x))
(setcar x (replace-match directory t t (car x))))
fuse-file-name full match nosort id-format))))
(defun tramp-gvfs-handle-expand-file-name (name &optional dir)
"Like `expand-file-name' for Tramp files."
;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
(setq dir (or dir default-directory "/"))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
(setq name (concat (file-name-as-directory dir) name)))
;; If NAME is not a Tramp file, run the real handler.
(if (not (tramp-tramp-file-p name))
(tramp-run-real-handler 'expand-file-name (list name nil))
;; Dissect NAME.
(with-parsed-tramp-file-name name nil
;; Tilde expansion is not possible.
(when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
v 'file-error
"Cannot expand tilde in file `%s'" name))
(unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
(setq localname (concat "/" localname)))
;; We do not pass "/..".
(if (string-equal "smb" method)
(when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname)
(setq localname (replace-match "/" t t localname 1)))
(when (string-match "^/\\.\\./?" localname)
(setq localname (replace-match "/" t t localname))))
;; There might be a double slash. Remove this.
(while (string-match "//" localname)
(setq localname (replace-match "/" t t localname)))
;; No tilde characters in file name, do normal
;; `expand-file-name' (this does "/./" and "/../").
method user host
'expand-file-name (list localname))))))
(defun tramp-gvfs-handle-file-attributes (filename &optional id-format)
"Like `file-attributes' for Tramp files."
(file-attributes (tramp-gvfs-fuse-file-name filename) id-format))
(defun tramp-gvfs-handle-file-executable-p (filename)
"Like `file-executable-p' for Tramp files."
(file-executable-p (tramp-gvfs-fuse-file-name filename)))
(defun tramp-gvfs-handle-file-exists-p (filename)
"Like `file-exists-p' for Tramp files."
(file-exists-p (tramp-gvfs-fuse-file-name filename)))
(defun tramp-gvfs-handle-file-local-copy (filename)
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name filename nil
(let ((tmpfile (tramp-compat-make-temp-file filename)))
(unless (file-exists-p filename)
v 'file-error
"Cannot make local copy of non-existing file `%s'" filename))
(copy-file filename tmpfile t t)
(defun tramp-gvfs-handle-file-name-all-completions (filename directory)
"Like `file-name-all-completions' for Tramp files."
(unless (save-match-data (string-match "/" filename))
(file-name-all-completions filename (tramp-gvfs-fuse-file-name directory))))
(defun tramp-gvfs-handle-file-readable-p (filename)
"Like `file-readable-p' for Tramp files."
(file-readable-p (tramp-gvfs-fuse-file-name filename)))
(defun tramp-gvfs-handle-file-writable-p (filename)
"Like `file-writable-p' for Tramp files."
(file-writable-p (tramp-gvfs-fuse-file-name filename)))
(defun tramp-gvfs-handle-insert-directory
(filename switches &optional wildcard full-directory-p)
"Like `insert-directory' for Tramp files."
(tramp-gvfs-fuse-file-name filename) switches wildcard full-directory-p))
(defun tramp-gvfs-handle-insert-file-contents
(filename &optional visit beg end replace)
"Like `insert-file-contents' for Tramp files."
(let ((fuse-file-name (tramp-gvfs-fuse-file-name filename))
(tramp-gvfs-fuse-file-name filename) visit beg end replace)))
(when (string-match fuse-file-name (car result))
(setcar result (replace-match filename t t (car result))))
(setq buffer-file-name filename)))
(defun tramp-gvfs-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
(condition-case err
(with-tramp-gvfs-error-message dir 'make-directory
(tramp-gvfs-fuse-file-name dir) parents)
;; Error case. Let's try it with the GVFS utilities.
(with-parsed-tramp-file-name filename nil
(tramp-message v 4 "`make-directory' failed, trying `gvfs-mkdir'")
"gvfs-mkdir" nil (tramp-get-buffer v) nil
(tramp-gvfs-url-file-name filename)))
(signal (car err) (cdr err)))))))
(defun tramp-gvfs-handle-rename-file