lisp/net/tramp-gvfs.el

   1 ;;; tramp-gvfs.el --- Tramp access functions for GVFS daemon
   2
   3 ;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Michael Albinus <michael.albinus@gmx.de>
   6 ;; Keywords: comm, processes
   7 ;; Package: tramp
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Access functions for the GVFS daemon from Tramp.  Tested with GVFS
  27 ;; 1.0 (Ubuntu 8.10, Gnome 2.24).  It has been reported also to run
  28 ;; with GVFS 0.2.5 (Ubuntu 8.04, Gnome 2.22), but there is an
  29 ;; incompatibility with the mount_info structure, which has been
  30 ;; worked around.
  31
  32 ;; It has also been tested with GVFS 1.6 (Ubuntu 10.04, Gnome 2.30),
  33 ;; where the default_location has been added to mount_info (see
  34 ;; <https://bugzilla.gnome.org/show_bug.cgi?id=561998>.
  35
  36 ;; With GVFS 1.14 (Ubuntu 12.10, Gnome 3.6) the interfaces have been
  37 ;; changed, again.  So we must introspect the D-Bus interfaces.
  38
  39 ;; All actions to mount a remote location, and to retrieve mount
  40 ;; information, are performed by D-Bus messages.  File operations
  41 ;; themselves are performed via the mounted filesystem in ~/.gvfs.
  42 ;; Consequently, GNU Emacs 23.1 with enabled D-Bus bindings is a
  43 ;; precondition.
  44
  45 ;; The GVFS D-Bus interface is said to be unstable.  There were even
  46 ;; no introspection data before GVFS 1.14.  The interface, as
  47 ;; discovered during development time, is given in respective
  48 ;; comments.
  49
  50 ;; The custom option `tramp-gvfs-methods' contains the list of
  51 ;; supported connection methods.  Per default, these are "afp", "dav",
  52 ;; "davs", "gdrive", "obex", "sftp" and "synce".  Note that with
  53 ;; "obex" it might be necessary to pair with the other bluetooth
  54 ;; device, if it hasn't been done already.  There might be also some
  55 ;; few seconds delay in discovering available bluetooth devices.
  56
  57 ;; Other possible connection methods are "ftp" and "smb".  When one of
  58 ;; these methods is added to the list, the remote access for that
  59 ;; method is performed via GVFS instead of the native Tramp
  60 ;; implementation.
  61
  62 ;; GVFS offers even more connection methods.  The complete list of
  63 ;; connection methods of the actual GVFS implementation can be
  64 ;; retrieved by:
  65 ;;
  66 ;; (message
  67 ;;  "%s"
  68 ;;  (mapcar
  69 ;;   'car
  70 ;;   (dbus-call-method
  71 ;;    :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
  72 ;;    tramp-gvfs-interface-mounttracker "listMountableInfo")))
  73
  74 ;; Note that all other connection methods are not tested, beside the
  75 ;; ones offered for customization in `tramp-gvfs-methods'.  If you
  76 ;; request an additional connection method to be supported, please
  77 ;; drop me a note.
  78
  79 ;; For hostname completion, information is retrieved either from the
  80 ;; bluez daemon (for the "obex" method), the hal daemon (for the
  81 ;; "synce" method), or from the zeroconf daemon (for the "afp", "dav",
  82 ;; "davs", and "sftp" methods).  The zeroconf daemon is pre-configured
  83 ;; to discover services in the "local" domain.  If another domain
  84 ;; shall be used for discovering services, the custom option
  85 ;; `tramp-gvfs-zeroconf-domain' can be set accordingly.
  86
  87 ;; Restrictions:
  88
  89 ;; * The current GVFS implementation does not allow writing on the
  90 ;;   remote bluetooth device via OBEX.
  91 ;;
  92 ;; * Two shares of the same SMB server cannot be mounted in parallel.
  93
  94 ;;; Code:
  95
  96 ;; D-Bus support in the Emacs core can be disabled with configuration
  97 ;; option "--without-dbus".  Declare used subroutines and variables.
  98 (declare-function dbus-get-unique-name "dbusbind.c")
  99
 100 (require 'tramp)
 101
 102 (require 'dbus)
 103 (require 'url-parse)
 104 (require 'url-util)
 105 (require 'zeroconf)
 106
 107 ;; Pacify byte-compiler.
 108 (eval-when-compile
 109   (require 'cl)
 110   (require 'custom))
 111
 112 ;;;###tramp-autoload
 113 (defcustom tramp-gvfs-methods
 114   '("afp" "dav" "davs" "gdrive" "obex" "sftp" "synce")
 115   "List of methods for remote files, accessed with GVFS."
 116   :group 'tramp
 117   :version "25.2"
 118   :type '(repeat (choice (const "afp")
 119                          (const "dav")
 120                          (const "davs")
 121                          (const "ftp")
 122                          (const "gdrive")
 123                          (const "obex")
 124                          (const "sftp")
 125                          (const "smb")
 126                          (const "synce"))))
 127
 128 ;; Add defaults for `tramp-default-user-alist' and `tramp-default-host-alist'.
 129 ;;;###tramp-autoload
 130 (when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)"
 131                     user-mail-address)
 132   (add-to-list 'tramp-default-user-alist
 133                `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address)))
 134   (add-to-list 'tramp-default-host-alist
 135                '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address))))
 136 ;;;###tramp-autoload
 137 (add-to-list 'tramp-default-user-alist '("\\`synce\\'" nil nil))
 138
 139 ;;;###tramp-autoload
 140 (defcustom tramp-gvfs-zeroconf-domain "local"
 141   "Zeroconf domain to be used for discovering services, like host names."
 142   :group 'tramp
 143   :version "23.2"
 144   :type 'string)
 145
 146 ;; Add the methods to `tramp-methods', in order to allow minibuffer
 147 ;; completion.
 148 ;;;###tramp-autoload
 149 (when (featurep 'dbusbind)
 150   (dolist (elt tramp-gvfs-methods)
 151     (unless (assoc elt tramp-methods)
 152       (add-to-list 'tramp-methods (cons elt nil)))))
 153
 154 (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp")
 155   "The preceding object path for own objects.")
 156
 157 (defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon"
 158   "The well known name of the GVFS daemon.")
 159
 160 ;; D-Bus integration is available since Emacs 23 on some system types.
 161 ;; We don't call `dbus-ping', because this would load dbus.el.
 162 (defconst tramp-gvfs-enabled
 163   (ignore-errors
 164     (and (featurep 'dbusbind)
 165          (tramp-compat-funcall 'dbus-get-unique-name :system)
 166          (tramp-compat-funcall 'dbus-get-unique-name :session)
 167          (or (tramp-compat-process-running-p "gvfs-fuse-daemon")
 168              (tramp-compat-process-running-p "gvfsd-fuse"))))
 169   "Non-nil when GVFS is available.")
 170
 171 (defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker"
 172   "The object path of the GVFS daemon.")
 173
 174 (defconst tramp-gvfs-interface-mounttracker "org.gtk.vfs.MountTracker"
 175   "The mount tracking interface in the GVFS daemon.")
 176
 177 ;; Introspection data exist since GVFS 1.14.  If there are no such
 178 ;; data, we expect an earlier interface.
 179 (defconst tramp-gvfs-methods-mounttracker
 180   (and tramp-gvfs-enabled
 181        (dbus-introspect-get-method-names
 182         :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
 183         tramp-gvfs-interface-mounttracker))
 184   "The list of supported methods of the mount tracking interface.")
 185
 186 (defconst tramp-gvfs-listmounts
 187   (if (member "ListMounts" tramp-gvfs-methods-mounttracker)
 188       "ListMounts"
 189     "listMounts")
 190   "The name of the \"listMounts\" method.
 191 It has been changed in GVFS 1.14.")
 192
 193 (defconst tramp-gvfs-mountlocation
 194   (if (member "MountLocation" tramp-gvfs-methods-mounttracker)
 195       "MountLocation"
 196     "mountLocation")
 197   "The name of the \"mountLocation\" method.
 198 It has been changed in GVFS 1.14.")
 199
 200 (defconst tramp-gvfs-mountlocation-signature
 201   (and tramp-gvfs-enabled
 202        (dbus-introspect-get-signature
 203         :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
 204         tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation))
 205   "The D-Bus signature of the \"mountLocation\" method.
 206 It has been changed in GVFS 1.14.")
 207
 208 ;; <interface name='org.gtk.vfs.MountTracker'>
 209 ;;   <method name='listMounts'>
 210 ;;     <arg name='mount_info_list'
 211 ;;          type='a{sosssssbay{aya{say}}ay}'
 212 ;;          direction='out'/>
 213 ;;   </method>
 214 ;;   <method name='mountLocation'>
 215 ;;     <arg name='mount_spec'  type='{aya{say}}' direction='in'/>
 216 ;;     <arg name='dbus_id'     type='s'          direction='in'/>
 217 ;;     <arg name='object_path' type='o'          direction='in'/>
 218 ;;   </method>
 219 ;;   <signal name='mounted'>
 220 ;;     <arg name='mount_info'
 221 ;;          type='{sosssssbay{aya{say}}ay}'/>
 222 ;;   </signal>
 223 ;;   <signal name='unmounted'>
 224 ;;     <arg name='mount_info'
 225 ;;          type='{sosssssbay{aya{say}}ay}'/>
 226 ;;   </signal>
 227 ;; </interface>
 228 ;;
 229 ;; STRUCT               mount_info
 230 ;;   STRING               dbus_id
 231 ;;   OBJECT_PATH          object_path
 232 ;;   STRING               display_name
 233 ;;   STRING               stable_name
 234 ;;   STRING               x_content_types       Since GVFS 1.0 only !!!
 235 ;;   STRING               icon
 236 ;;   STRING               preferred_filename_encoding
 237 ;;   BOOLEAN              user_visible
 238 ;;   ARRAY BYTE           fuse_mountpoint
 239 ;;   STRUCT               mount_spec
 240 ;;     ARRAY BYTE           mount_prefix
 241 ;;     ARRAY
 242 ;;       STRUCT             mount_spec_item
 243 ;;         STRING             key (type, user, domain, host, server,
 244 ;;                                 share, volume, port, ssl)
 245 ;;         ARRAY BYTE         value
 246 ;;   ARRAY BYTE           default_location      Since GVFS 1.5 only !!!
 247
 248 (defconst tramp-gvfs-interface-mountoperation "org.gtk.vfs.MountOperation"
 249   "Used by the dbus-proxying implementation of GMountOperation.")
 250
 251 ;; <interface name='org.gtk.vfs.MountOperation'>
 252 ;;   <method name='askPassword'>
 253 ;;     <arg name='message'        type='s' direction='in'/>
 254 ;;     <arg name='default_user'   type='s' direction='in'/>
 255 ;;     <arg name='default_domain' type='s' direction='in'/>
 256 ;;     <arg name='flags'          type='u' direction='in'/>
 257 ;;     <arg name='handled'        type='b' direction='out'/>
 258 ;;     <arg name='aborted'        type='b' direction='out'/>
 259 ;;     <arg name='password'       type='s' direction='out'/>
 260 ;;     <arg name='username'       type='s' direction='out'/>
 261 ;;     <arg name='domain'         type='s' direction='out'/>
 262 ;;     <arg name='anonymous'      type='b' direction='out'/>
 263 ;;     <arg name='password_save'  type='u' direction='out'/>
 264 ;;   </method>
 265 ;;   <method name='askQuestion'>
 266 ;;     <arg name='message' type='s'  direction='in'/>
 267 ;;     <arg name='choices' type='as' direction='in'/>
 268 ;;     <arg name='handled' type='b'  direction='out'/>
 269 ;;     <arg name='aborted' type='b'  direction='out'/>
 270 ;;     <arg name='choice'  type='u'  direction='out'/>
 271 ;;   </method>
 272 ;; </interface>
 273
 274 ;; The following flags are used in "askPassword".  They are defined in
 275 ;; /usr/include/glib-2.0/gio/gioenums.h.
 276
 277 (defconst tramp-gvfs-password-need-password 1
 278   "Operation requires a password.")
 279
 280 (defconst tramp-gvfs-password-need-username 2
 281   "Operation requires a username.")
 282
 283 (defconst tramp-gvfs-password-need-domain 4
 284   "Operation requires a domain.")
 285
 286 (defconst tramp-gvfs-password-saving-supported 8
 287   "Operation supports saving settings.")
 288
 289 (defconst tramp-gvfs-password-anonymous-supported 16
 290   "Operation supports anonymous users.")
 291
 292 (defconst tramp-bluez-service "org.bluez"
 293   "The well known name of the BLUEZ service.")
 294
 295 (defconst tramp-bluez-interface-manager "org.bluez.Manager"
 296   "The manager interface of the BLUEZ daemon.")
 297
 298 ;; <interface name='org.bluez.Manager'>
 299 ;;   <method name='DefaultAdapter'>
 300 ;;     <arg type='o' direction='out'/>
 301 ;;   </method>
 302 ;;   <method name='FindAdapter'>
 303 ;;     <arg type='s' direction='in'/>
 304 ;;     <arg type='o' direction='out'/>
 305 ;;   </method>
 306 ;;   <method name='ListAdapters'>
 307 ;;     <arg type='ao' direction='out'/>
 308 ;;   </method>
 309 ;;   <signal name='AdapterAdded'>
 310 ;;     <arg type='o'/>
 311 ;;   </signal>
 312 ;;   <signal name='AdapterRemoved'>
 313 ;;     <arg type='o'/>
 314 ;;   </signal>
 315 ;;   <signal name='DefaultAdapterChanged'>
 316 ;;     <arg type='o'/>
 317 ;;   </signal>
 318 ;; </interface>
 319
 320 (defconst tramp-bluez-interface-adapter "org.bluez.Adapter"
 321   "The adapter interface of the BLUEZ daemon.")
 322
 323 ;; <interface name='org.bluez.Adapter'>
 324 ;;   <method name='GetProperties'>
 325 ;;     <arg type='a{sv}' direction='out'/>
 326 ;;   </method>
 327 ;;   <method name='SetProperty'>
 328 ;;     <arg type='s' direction='in'/>
 329 ;;     <arg type='v' direction='in'/>
 330 ;;   </method>
 331 ;;   <method name='RequestMode'>
 332 ;;     <arg type='s' direction='in'/>
 333 ;;   </method>
 334 ;;   <method name='ReleaseMode'/>
 335 ;;   <method name='RequestSession'/>
 336 ;;   <method name='ReleaseSession'/>
 337 ;;   <method name='StartDiscovery'/>
 338 ;;   <method name='StopDiscovery'/>
 339 ;;   <method name='ListDevices'>
 340 ;;     <arg type='ao' direction='out'/>
 341 ;;   </method>
 342 ;;   <method name='CreateDevice'>
 343 ;;     <arg type='s' direction='in'/>
 344 ;;     <arg type='o' direction='out'/>
 345 ;;   </method>
 346 ;;   <method name='CreatePairedDevice'>
 347 ;;     <arg type='s' direction='in'/>
 348 ;;     <arg type='o' direction='in'/>
 349 ;;     <arg type='s' direction='in'/>
 350 ;;     <arg type='o' direction='out'/>
 351 ;;   </method>
 352 ;;   <method name='CancelDeviceCreation'>
 353 ;;     <arg type='s' direction='in'/>
 354 ;;   </method>
 355 ;;   <method name='RemoveDevice'>
 356 ;;     <arg type='o' direction='in'/>
 357 ;;   </method>
 358 ;;   <method name='FindDevice'>
 359 ;;     <arg type='s' direction='in'/>
 360 ;;     <arg type='o' direction='out'/>
 361 ;;   </method>
 362 ;;   <method name='RegisterAgent'>
 363 ;;     <arg type='o' direction='in'/>
 364 ;;     <arg type='s' direction='in'/>
 365 ;;   </method>
 366 ;;   <method name='UnregisterAgent'>
 367 ;;     <arg type='o' direction='in'/>
 368 ;;   </method>
 369 ;;   <signal name='DeviceCreated'>
 370 ;;     <arg type='o'/>
 371 ;;   </signal>
 372 ;;   <signal name='DeviceRemoved'>
 373 ;;     <arg type='o'/>
 374 ;;   </signal>
 375 ;;   <signal name='DeviceFound'>
 376 ;;     <arg type='s'/>
 377 ;;     <arg type='a{sv}'/>
 378 ;;   </signal>
 379 ;;   <signal name='PropertyChanged'>
 380 ;;     <arg type='s'/>
 381 ;;     <arg type='v'/>
 382 ;;   </signal>
 383 ;;   <signal name='DeviceDisappeared'>
 384 ;;     <arg type='s'/>
 385 ;;   </signal>
 386 ;; </interface>
 387
 388 ;;;###tramp-autoload
 389 (defcustom tramp-bluez-discover-devices-timeout 60
 390   "Defines seconds since last bluetooth device discovery before rescanning.
 391 A value of 0 would require an immediate discovery during hostname
 392 completion, nil means to use always cached values for discovered
 393 devices."
 394   :group 'tramp
 395   :version "23.2"
 396   :type '(choice (const nil) integer))
 397
 398 (defvar tramp-bluez-discovery nil
 399   "Indicator for a running bluetooth device discovery.
 400 It keeps the timestamp of last discovery.")
 401
 402 (defvar tramp-bluez-devices nil
 403   "Alist of detected bluetooth devices.
 404 Every entry is a list (NAME ADDRESS).")
 405
 406 (defconst tramp-hal-service "org.freedesktop.Hal"
 407   "The well known name of the HAL service.")
 408
 409 (defconst tramp-hal-path-manager "/org/freedesktop/Hal/Manager"
 410   "The object path of the HAL daemon manager.")
 411
 412 (defconst tramp-hal-interface-manager "org.freedesktop.Hal.Manager"
 413   "The manager interface of the HAL daemon.")
 414
 415 (defconst tramp-hal-interface-device "org.freedesktop.Hal.Device"
 416   "The device interface of the HAL daemon.")
 417
 418 (defconst tramp-gvfs-file-attributes
 419   '("name"
 420     "type"
 421     "standard::display-name"
 422     "standard::symlink-target"
 423     "unix::nlink"
 424     "unix::uid"
 425     "owner::user"
 426     "unix::gid"
 427     "owner::group"
 428     "time::access"
 429     "time::modified"
 430     "time::changed"
 431     "standard::size"
 432     "unix::mode"
 433     "access::can-read"
 434     "access::can-write"
 435     "access::can-execute"
 436     "unix::inode"
 437     "unix::device")
 438   "GVFS file attributes.")
 439
 440 (defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp
 441   (concat "[[:blank:]]" (regexp-opt tramp-gvfs-file-attributes t) "=\\(.+?\\)")
 442   "Regexp to parse GVFS file attributes with `gvfs-ls'.")
 443
 444 (defconst tramp-gvfs-file-attributes-with-gvfs-info-regexp
 445   (concat "^[[:blank:]]*"
 446           (regexp-opt tramp-gvfs-file-attributes t)
 447           ":[[:blank:]]+\\(.*\\)$")
 448   "Regexp to parse GVFS file attributes with `gvfs-info'.")
 449
 450 \f
 451 ;; New handlers should be added here.
 452 (defconst tramp-gvfs-file-name-handler-alist
 453   '((access-file . ignore)
 454     (add-name-to-file . tramp-gvfs-handle-copy-file)
 455     ;; `byte-compiler-base-file-name' performed by default handler.
 456     ;; `copy-directory' performed by default handler.
 457     (copy-file . tramp-gvfs-handle-copy-file)
 458     (delete-directory . tramp-gvfs-handle-delete-directory)
 459     (delete-file . tramp-gvfs-handle-delete-file)
 460     ;; `diff-latest-backup-file' performed by default handler.
 461     (directory-file-name . tramp-handle-directory-file-name)
 462     (directory-files . tramp-handle-directory-files)
 463     (directory-files-and-attributes
 464      . tramp-handle-directory-files-and-attributes)
 465     (dired-compress-file . ignore)
 466     (dired-uncache . tramp-handle-dired-uncache)
 467     (expand-file-name . tramp-gvfs-handle-expand-file-name)
 468     (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
 469     (file-acl . ignore)
 470     (file-attributes . tramp-gvfs-handle-file-attributes)
 471     (file-directory-p . tramp-gvfs-handle-file-directory-p)
 472     (file-equal-p . tramp-handle-file-equal-p)
 473     (file-executable-p . tramp-gvfs-handle-file-executable-p)
 474     (file-exists-p . tramp-handle-file-exists-p)
 475     (file-in-directory-p . tramp-handle-file-in-directory-p)
 476     (file-local-copy . tramp-gvfs-handle-file-local-copy)
 477     (file-modes . tramp-handle-file-modes)
 478     (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions)
 479     (file-name-as-directory . tramp-handle-file-name-as-directory)
 480     (file-name-completion . tramp-handle-file-name-completion)
 481     (file-name-directory . tramp-handle-file-name-directory)
 482     (file-name-nondirectory . tramp-handle-file-name-nondirectory)
 483     ;; `file-name-sans-versions' performed by default handler.
 484     (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
 485     (file-notify-add-watch . tramp-gvfs-handle-file-notify-add-watch)
 486     (file-notify-rm-watch . tramp-handle-file-notify-rm-watch)
 487     (file-notify-valid-p . tramp-handle-file-notify-valid-p)
 488     (file-ownership-preserved-p . ignore)
 489     (file-readable-p . tramp-gvfs-handle-file-readable-p)
 490     (file-regular-p . tramp-handle-file-regular-p)
 491     (file-remote-p . tramp-handle-file-remote-p)
 492     (file-selinux-context . ignore)
 493     (file-symlink-p . tramp-handle-file-symlink-p)
 494     ;; `file-truename' performed by default handler.
 495     (file-writable-p . tramp-gvfs-handle-file-writable-p)
 496     (find-backup-file-name . tramp-handle-find-backup-file-name)
 497     ;; `find-file-noselect' performed by default handler.
 498     ;; `get-file-buffer' performed by default handler.
 499     (insert-directory . tramp-handle-insert-directory)
 500     (insert-file-contents . tramp-handle-insert-file-contents)
 501     (load . tramp-handle-load)
 502     (make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
 503     (make-directory . tramp-gvfs-handle-make-directory)
 504     (make-directory-internal . ignore)
 505     (make-symbolic-link . tramp-handle-make-symbolic-link)
 506     (process-file . ignore)
 507     (rename-file . tramp-gvfs-handle-rename-file)
 508     (set-file-acl . ignore)
 509     (set-file-modes . ignore)
 510     (set-file-selinux-context . ignore)
 511     (set-file-times . ignore)
 512     (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
 513     (shell-command . ignore)
 514     (start-file-process . ignore)
 515     (substitute-in-file-name . tramp-handle-substitute-in-file-name)
 516     (unhandled-file-name-directory . ignore)
 517     (vc-registered . ignore)
 518     (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
 519     (write-region . tramp-gvfs-handle-write-region))
 520   "Alist of handler functions for Tramp GVFS method.
 521 Operations not mentioned here will be handled by the default Emacs primitives.")
 522
 523 ;; It must be a `defsubst' in order to push the whole code into
 524 ;; tramp-loaddefs.el.  Otherwise, there would be recursive autoloading.
 525 ;;;###tramp-autoload
 526 (defsubst tramp-gvfs-file-name-p (filename)
 527   "Check if it's a filename handled by the GVFS daemon."
 528   (and (tramp-tramp-file-p filename)
 529        (let ((method
 530               (tramp-file-name-method (tramp-dissect-file-name filename))))
 531          (and (stringp method) (member method tramp-gvfs-methods)))))
 532
 533 ;;;###tramp-autoload
 534 (defun tramp-gvfs-file-name-handler (operation &rest args)
 535   "Invoke the GVFS related OPERATION.
 536 First arg specifies the OPERATION, second arg is a list of arguments to
 537 pass to the OPERATION."
 538   (unless tramp-gvfs-enabled
 539     (tramp-user-error nil "Package `tramp-gvfs' not supported"))
 540   (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist)))
 541     (if fn
 542         (save-match-data (apply (cdr fn) args))
 543       (tramp-run-real-handler operation args))))
 544
 545 ;; This might be moved to tramp.el.  It shall be the first file name
 546 ;; handler.
 547 ;;;###tramp-autoload
 548 (when (featurep 'dbusbind)
 549   (add-to-list 'tramp-foreign-file-name-handler-alist
 550                (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler)))
 551
 552 \f
 553 ;; D-Bus helper function.
 554
 555 (defun tramp-gvfs-dbus-string-to-byte-array (string)
 556   "Like `dbus-string-to-byte-array' but add trailing \\0 if needed."
 557   (dbus-string-to-byte-array
 558    (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature)
 559        (concat string (string 0)) string)))
 560
 561 (defun tramp-gvfs-dbus-byte-array-to-string (byte-array)
 562   "Like `dbus-byte-array-to-string' but remove trailing \\0 if exists."
 563   ;; The byte array could be a variant.  Take care.
 564   (let ((byte-array
 565          (if (and (consp byte-array) (atom (car byte-array)))
 566              byte-array (car byte-array))))
 567     (dbus-byte-array-to-string
 568      (if (and (consp byte-array) (zerop (car (last byte-array))))
 569          (butlast byte-array) byte-array))))
 570
 571 (defun tramp-gvfs-stringify-dbus-message (message)
 572   "Convert a D-Bus message into readable UTF8 strings, used for traces."
 573   (cond
 574    ((and (consp message) (characterp (car message)))
 575     (format "%S" (tramp-gvfs-dbus-byte-array-to-string message)))
 576    ((consp message)
 577     (mapcar 'tramp-gvfs-stringify-dbus-message message))
 578    ((stringp message)
 579     (format "%S" message))
 580    (t message)))
 581
 582 (defmacro with-tramp-dbus-call-method
 583   (vec synchronous bus service path interface method &rest args)
 584   "Apply a D-Bus call on bus BUS.
 585
 586 If SYNCHRONOUS is non-nil, the call is synchronously.  Otherwise,
 587 it is an asynchronous call, with `ignore' as callback function.
 588
 589 The other arguments have the same meaning as with `dbus-call-method'
 590 or `dbus-call-method-asynchronously'.  Additionally, the call
 591 will be traced by Tramp with trace level 6."
 592   `(let ((func (if ,synchronous
 593                    'dbus-call-method 'dbus-call-method-asynchronously))
 594          (args (append (list ,bus ,service ,path ,interface ,method)
 595                        (if ,synchronous (list ,@args) (list 'ignore ,@args))))
 596          result)
 597      (tramp-message ,vec 6 "%s %s" func args)
 598      (setq result (apply func args))
 599      (tramp-message ,vec 6 "%s" (tramp-gvfs-stringify-dbus-message result))
 600      result))
 601
 602 (put 'with-tramp-dbus-call-method 'lisp-indent-function 2)
 603 (put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body))
 604 (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>"))
 605
 606 (defvar tramp-gvfs-dbus-event-vector nil
 607   "Current Tramp file name to be used, as vector.
 608 It is needed when D-Bus signals or errors arrive, because there
 609 is no information where to trace the message.")
 610
 611 (defun tramp-gvfs-dbus-event-error (event err)
 612   "Called when a D-Bus error message arrives, see `dbus-event-error-functions'."
 613   (when tramp-gvfs-dbus-event-vector
 614     (tramp-message tramp-gvfs-dbus-event-vector 10 "%S" event)
 615     (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err))))
 616
 617 ;; `dbus-event-error-hooks' has been renamed to `dbus-event-error-functions'.
 618 (add-hook
 619  (if (boundp 'dbus-event-error-functions)
 620      'dbus-event-error-functions 'dbus-event-error-hooks)
 621  'tramp-gvfs-dbus-event-error)
 622
 623 \f
 624 ;; File name primitives.
 625
 626 (defun tramp-gvfs-do-copy-or-rename-file
 627   (op filename newname &optional ok-if-already-exists keep-date
 628       preserve-uid-gid preserve-extended-attributes)
 629   "Copy or rename a remote file.
 630 OP must be `copy' or `rename' and indicates the operation to perform.
 631 FILENAME specifies the file to copy or rename, NEWNAME is the name of
 632 the new file (for copy) or the new name of the file (for rename).
 633 OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already.
 634 KEEP-DATE means to make sure that NEWNAME has the same timestamp
 635 as FILENAME.  PRESERVE-UID-GID, when non-nil, instructs to keep
 636 the uid and gid if both files are on the same host.
 637 PRESERVE-EXTENDED-ATTRIBUTES is ignored.
 638
 639 This function is invoked by `tramp-gvfs-handle-copy-file' and
 640 `tramp-gvfs-handle-rename-file'.  It is an error if OP is neither
 641 of `copy' and `rename'.  FILENAME and NEWNAME must be absolute
 642 file names."
 643   (unless (memq op '(copy rename))
 644     (error "Unknown operation `%s', must be `copy' or `rename'" op))
 645
 646     (let ((t1 (tramp-tramp-file-p filename))
 647           (t2 (tramp-tramp-file-p newname))
 648           (equal-remote (tramp-equal-remote filename newname))
 649           (file-operation (intern (format "%s-file" op)))
 650           (gvfs-operation (if (eq op 'copy) "gvfs-copy" "gvfs-move"))
 651           (msg-operation (if (eq op 'copy) "Copying" "Renaming")))
 652
 653       (with-parsed-tramp-file-name (if t1 filename newname) nil
 654         (when (and (not ok-if-already-exists) (file-exists-p newname))
 655           (tramp-error
 656            v 'file-already-exists "File %s already exists" newname))
 657
 658         (if (or (and equal-remote
 659                      (tramp-get-connection-property v "direct-copy-failed" nil))
 660                 (and t1 (not (tramp-gvfs-file-name-p filename)))
 661                 (and t2 (not (tramp-gvfs-file-name-p newname))))
 662
 663             ;; We cannot copy or rename directly.
 664             ;; PRESERVE-EXTENDED-ATTRIBUTES has been introduced with
 665             ;; Emacs 24.1 (as PRESERVE-SELINUX-CONTEXT), and renamed
 666             ;; in Emacs 24.3.
 667             (let ((tmpfile (tramp-compat-make-temp-file filename)))
 668               (cond
 669                (preserve-extended-attributes
 670                 (funcall
 671                  file-operation
 672                  filename tmpfile t keep-date preserve-uid-gid
 673                  preserve-extended-attributes))
 674                (t
 675                 (funcall
 676                  file-operation filename tmpfile t keep-date preserve-uid-gid)))
 677               (rename-file tmpfile newname ok-if-already-exists))
 678
 679           ;; Direct action.
 680           (with-tramp-progress-reporter
 681               v 0 (format "%s %s to %s" msg-operation filename newname)
 682             (unless
 683                 (apply
 684                  'tramp-gvfs-send-command v gvfs-operation
 685                  (append
 686                   (and (eq op 'copy) (or keep-date preserve-uid-gid)
 687                        '("--preserve"))
 688                   (list
 689                    (tramp-gvfs-url-file-name filename)
 690                    (tramp-gvfs-url-file-name newname))))
 691
 692               (if (or (not equal-remote)
 693                       (and equal-remote
 694                            (tramp-get-connection-property
 695                             v "direct-copy-failed" nil)))
 696                   ;; Propagate the error.
 697                   (with-current-buffer (tramp-get-connection-buffer v)
 698                     (goto-char (point-min))
 699                     (tramp-error-with-buffer
 700                      nil v 'file-error
 701                      "%s failed, see buffer `%s' for details."
 702                      msg-operation (buffer-name)))
 703
 704                 ;; Some WebDAV server, like the one from QNAP, do not
 705                 ;; support direct copy/move.  Try a fallback.
 706                 (tramp-set-connection-property v "direct-copy-failed" t)
 707                 (tramp-gvfs-do-copy-or-rename-file
 708                  op filename newname ok-if-already-exists keep-date
 709                  preserve-uid-gid preserve-extended-attributes))))
 710
 711           (when (and t1 (eq op 'rename))
 712             (with-parsed-tramp-file-name filename nil
 713               (tramp-flush-file-property v (file-name-directory localname))
 714               (tramp-flush-file-property v localname)))
 715
 716           (when t2
 717             (with-parsed-tramp-file-name newname nil
 718               (tramp-flush-file-property v (file-name-directory localname))
 719               (tramp-flush-file-property v localname)))))))
 720
 721 (defun tramp-gvfs-handle-copy-file
 722   (filename newname &optional ok-if-already-exists keep-date
 723             preserve-uid-gid preserve-extended-attributes)
 724   "Like `copy-file' for Tramp files."
 725   (setq filename (expand-file-name filename))
 726   (setq newname (expand-file-name newname))
 727   (cond
 728    ;; At least one file a Tramp file?
 729    ((or (tramp-tramp-file-p filename)
 730         (tramp-tramp-file-p newname))
 731     (tramp-gvfs-do-copy-or-rename-file
 732      'copy filename newname ok-if-already-exists keep-date
 733      preserve-uid-gid preserve-extended-attributes))
 734    ;; Compat section.  PRESERVE-EXTENDED-ATTRIBUTES has been
 735    ;; introduced with Emacs 24.1 (as PRESERVE-SELINUX-CONTEXT), and
 736    ;; renamed in Emacs 24.3.
 737    (preserve-extended-attributes
 738     (tramp-run-real-handler
 739      'copy-file
 740      (list filename newname ok-if-already-exists keep-date
 741            preserve-uid-gid preserve-extended-attributes)))
 742    (t
 743     (tramp-run-real-handler
 744      'copy-file
 745      (list filename newname ok-if-already-exists keep-date preserve-uid-gid)))))
 746
 747 (defun tramp-gvfs-handle-delete-directory (directory &optional recursive trash)
 748   "Like `delete-directory' for Tramp files."
 749   (when (and recursive (not (file-symlink-p directory)))
 750     (mapc (lambda (file)
 751             (if (eq t (car (file-attributes file)))
 752                 (tramp-compat-delete-directory file recursive trash)
 753               (tramp-compat-delete-file file trash)))
 754           (directory-files
 755            directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
 756   (with-parsed-tramp-file-name directory nil
 757     (tramp-flush-file-property v (file-name-directory localname))
 758     (tramp-flush-directory-property v localname)
 759     (unless
 760         (tramp-gvfs-send-command
 761          v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm")
 762          (tramp-gvfs-url-file-name directory))
 763       ;; Propagate the error.
 764       (with-current-buffer (tramp-get-connection-buffer v)
 765         (goto-char (point-min))
 766         (tramp-error-with-buffer
 767          nil v 'file-error "Couldn't delete %s" directory)))))
 768
 769 (defun tramp-gvfs-handle-delete-file (filename &optional trash)
 770   "Like `delete-file' for Tramp files."
 771   (with-parsed-tramp-file-name filename nil
 772     (tramp-flush-file-property v (file-name-directory localname))
 773     (tramp-flush-file-property v localname)
 774     (unless
 775         (tramp-gvfs-send-command
 776          v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm")
 777          (tramp-gvfs-url-file-name filename))
 778       ;; Propagate the error.
 779       (with-current-buffer (tramp-get-connection-buffer v)
 780         (goto-char (point-min))
 781         (tramp-error-with-buffer
 782          nil v 'file-error "Couldn't delete %s" filename)))))
 783
 784 (defun tramp-gvfs-handle-expand-file-name (name &optional dir)
 785   "Like `expand-file-name' for Tramp files."
 786   ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
 787   (setq dir (or dir default-directory "/"))
 788   ;; Unless NAME is absolute, concat DIR and NAME.
 789   (unless (file-name-absolute-p name)
 790     (setq name (concat (file-name-as-directory dir) name)))
 791   ;; If NAME is not a Tramp file, run the real handler.
 792   (if (not (tramp-tramp-file-p name))
 793       (tramp-run-real-handler 'expand-file-name (list name nil))
 794     ;; Dissect NAME.
 795     (with-parsed-tramp-file-name name nil
 796       ;; If there is a default location, expand tilde.
 797       (when (string-match "\\`\\(~\\)\\(/\\|\\'\\)" localname)
 798         (save-match-data
 799           (tramp-gvfs-maybe-open-connection (vector method user host "/" hop)))
 800         (setq localname
 801               (replace-match
 802                (tramp-get-file-property  v "/" "default-location" "~")
 803                nil t localname 1)))
 804       ;; Tilde expansion is not possible.
 805       (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
 806         (tramp-error
 807          v 'file-error
 808          "Cannot expand tilde in file `%s'" name))
 809       (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
 810         (setq localname (concat "/" localname)))
 811       ;; We do not pass "/..".
 812       (if (string-match "^\\(afp\\|smb\\)$" method)
 813           (when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname)
 814             (setq localname (replace-match "/" t t localname 1)))
 815         (when (string-match "^/\\.\\./?" localname)
 816           (setq localname (replace-match "/" t t localname))))
 817       ;; There might be a double slash.  Remove this.
 818       (while (string-match "//" localname)
 819         (setq localname (replace-match "/" t t localname)))
 820       ;; No tilde characters in file name, do normal
 821       ;; `expand-file-name' (this does "/./" and "/../").
 822       (tramp-make-tramp-file-name
 823        method user host
 824        (tramp-run-real-handler
 825         'expand-file-name (list localname))))))
 826
 827 (defun tramp-gvfs-get-directory-attributes (directory)
 828   "Return GVFS attributes association list of all files in DIRECTORY."
 829   (ignore-errors
 830     ;; Don't modify `last-coding-system-used' by accident.
 831     (let ((last-coding-system-used last-coding-system-used)
 832           result)
 833       (with-parsed-tramp-file-name directory nil
 834         (with-tramp-file-property v localname "directory-gvfs-attributes"
 835           (tramp-message v 5 "directory gvfs attributes: %s" localname)
 836           ;; Send command.
 837           (tramp-gvfs-send-command
 838            v "gvfs-ls" "-h" "-n" "-a"
 839            (mapconcat 'identity tramp-gvfs-file-attributes ",")
 840            (tramp-gvfs-url-file-name directory))
 841           ;; Parse output.
 842           (with-current-buffer (tramp-get-connection-buffer v)
 843             (goto-char (point-min))
 844             (while (looking-at
 845                     (concat "^\\(.+\\)[[:blank:]]"
 846                             "\\([[:digit:]]+\\)[[:blank:]]"
 847                             "(\\(.+?\\))"
 848                             tramp-gvfs-file-attributes-with-gvfs-ls-regexp))
 849               (let ((item (list (cons "type" (match-string 3))
 850                                 (cons "standard::size" (match-string 2))
 851                                 (cons "name" (match-string 1)))))
 852                 (goto-char (1+ (match-end 3)))
 853                 (while (looking-at
 854                         (concat
 855                          tramp-gvfs-file-attributes-with-gvfs-ls-regexp
 856                          "\\(" tramp-gvfs-file-attributes-with-gvfs-ls-regexp
 857                          "\\|" "$" "\\)"))
 858                   (push (cons (match-string 1) (match-string 2)) item)
 859                   (goto-char (match-end 2)))
 860                 ;; Add display name as head.
 861                 (push
 862                  (cons (cdr (or (assoc "standard::display-name" item)
 863                                 (assoc "name" item)))
 864                        (nreverse item))
 865                  result))
 866               (forward-line)))
 867           result)))))
 868
 869 (defun tramp-gvfs-get-root-attributes (filename)
 870   "Return GVFS attributes association list of FILENAME."
 871   (ignore-errors
 872     ;; Don't modify `last-coding-system-used' by accident.
 873     (let ((last-coding-system-used last-coding-system-used)
 874           result)
 875       (with-parsed-tramp-file-name filename nil
 876         (with-tramp-file-property v localname "file-gvfs-attributes"
 877           (tramp-message v 5 "file gvfs attributes: %s" localname)
 878           ;; Send command.
 879           (tramp-gvfs-send-command
 880            v "gvfs-info" (tramp-gvfs-url-file-name filename))
 881           ;; Parse output.
 882           (with-current-buffer (tramp-get-connection-buffer v)
 883             (goto-char (point-min))
 884             (while (re-search-forward
 885                     tramp-gvfs-file-attributes-with-gvfs-info-regexp nil t)
 886               (push (cons (match-string 1) (match-string 2)) result))
 887             result))))))
 888
 889 (defun tramp-gvfs-get-file-attributes (filename)
 890   "Return GVFS attributes association list of FILENAME."
 891   (setq filename (directory-file-name (expand-file-name filename)))
 892   (with-parsed-tramp-file-name filename nil
 893     (if (or
 894          (and (string-match "^\\(afp\\|smb\\)$" method)
 895               (string-match "^/?\\([^/]+\\)$" localname))
 896          (string-equal localname "/"))
 897         (tramp-gvfs-get-root-attributes filename)
 898       (assoc
 899        (file-name-nondirectory filename)
 900        (tramp-gvfs-get-directory-attributes (file-name-directory filename))))))
 901
 902 (defun tramp-gvfs-handle-file-attributes (filename &optional id-format)
 903   "Like `file-attributes' for Tramp files."
 904   (unless id-format (setq id-format 'integer))
 905   (ignore-errors
 906     (let ((attributes (tramp-gvfs-get-file-attributes filename))
 907           dirp res-symlink-target res-numlinks res-uid res-gid res-access
 908           res-mod res-change res-size res-filemodes res-inode res-device)
 909       (when attributes
 910         ;; ... directory or symlink
 911         (setq dirp (if (equal "directory" (cdr (assoc "type" attributes))) t))
 912         (setq res-symlink-target
 913               (cdr (assoc "standard::symlink-target" attributes)))
 914         ;; ... number links
 915         (setq res-numlinks
 916               (string-to-number
 917                (or (cdr (assoc "unix::nlink" attributes)) "0")))
 918         ;; ... uid and gid
 919         (setq res-uid
 920               (if (eq id-format 'integer)
 921                   (string-to-number
 922                    (or (cdr (assoc "unix::uid" attributes))
 923                        (format "%s" tramp-unknown-id-integer)))
 924                 (or (cdr (assoc "owner::user" attributes))
 925                     (cdr (assoc "unix::uid" attributes))
 926                     tramp-unknown-id-string)))
 927         (setq res-gid
 928               (if (eq id-format 'integer)
 929                   (string-to-number
 930                    (or (cdr (assoc "unix::gid" attributes))
 931                        (format "%s" tramp-unknown-id-integer)))
 932                 (or (cdr (assoc "owner::group" attributes))
 933                     (cdr (assoc "unix::gid" attributes))
 934                     tramp-unknown-id-string)))
 935         ;; ... last access, modification and change time
 936         (setq res-access
 937               (seconds-to-time
 938                (string-to-number
 939                 (or (cdr (assoc "time::access" attributes)) "0"))))
 940         (setq res-mod
 941               (seconds-to-time
 942                (string-to-number
 943                 (or (cdr (assoc "time::modified" attributes)) "0"))))
 944         (setq res-change
 945               (seconds-to-time
 946                (string-to-number
 947                 (or (cdr (assoc "time::changed" attributes)) "0"))))
 948         ;; ... size
 949         (setq res-size
 950               (string-to-number
 951                (or (cdr (assoc "standard::size" attributes)) "0")))
 952         ;; ... file mode flags
 953         (setq res-filemodes
 954               (let ((n (cdr (assoc "unix::mode" attributes))))
 955                 (if n
 956                     (tramp-file-mode-from-int (string-to-number n))
 957                   (format
 958                    "%s%s%s%s------"
 959                    (if dirp "d" "-")
 960                    (if (equal (cdr (assoc "access::can-read" attributes))
 961                               "FALSE")
 962                        "-" "r")
 963                    (if (equal (cdr (assoc "access::can-write" attributes))
 964                               "FALSE")
 965                        "-" "w")
 966                    (if (equal (cdr (assoc "access::can-execute" attributes))
 967                               "FALSE")
 968                        "-" "x")))))
 969         ;; ... inode and device
 970         (setq res-inode
 971               (let ((n (cdr (assoc "unix::inode" attributes))))
 972                 (if n
 973                     (string-to-number n)
 974                   (tramp-get-inode (tramp-dissect-file-name filename)))))
 975         (setq res-device
 976               (let ((n (cdr (assoc "unix::device" attributes))))
 977                 (if n
 978                     (string-to-number n)
 979                   (tramp-get-device (tramp-dissect-file-name filename)))))
 980
 981         ;; Return data gathered.
 982         (list
 983          ;; 0. t for directory, string (name linked to) for
 984          ;; symbolic link, or nil.
 985          (or dirp res-symlink-target)
 986          ;; 1. Number of links to file.
 987          res-numlinks
 988          ;; 2. File uid.
 989          res-uid
 990          ;; 3. File gid.
 991          res-gid
 992          ;; 4. Last access time, as a list of integers.
 993          ;; 5. Last modification time, likewise.
 994          ;; 6. Last status change time, likewise.
 995          res-access res-mod res-change
 996          ;; 7. Size in bytes (-1, if number is out of range).
 997          res-size
 998          ;; 8. File modes.
 999          res-filemodes
1000          ;; 9. t if file's gid would change if file were deleted
1001          ;; and recreated.
1002          nil
1003          ;; 10. Inode number.
1004          res-inode
1005          ;; 11. Device number.
1006          res-device
1007          )))))
1008
1009 (defun tramp-gvfs-handle-file-directory-p (filename)
1010   "Like `file-directory-p' for Tramp files."
1011   (eq t (car (file-attributes (file-truename filename)))))
1012
1013 (defun tramp-gvfs-handle-file-executable-p (filename)
1014   "Like `file-executable-p' for Tramp files."
1015   (with-parsed-tramp-file-name filename nil
1016     (with-tramp-file-property v localname "file-executable-p"
1017       (tramp-check-cached-permissions v ?x))))
1018
1019 (defun tramp-gvfs-handle-file-local-copy (filename)
1020   "Like `file-local-copy' for Tramp files."
1021   (with-parsed-tramp-file-name filename nil
1022     (let ((tmpfile (tramp-compat-make-temp-file filename)))
1023       (unless (file-exists-p filename)
1024         (tramp-error
1025          v 'file-error
1026          "Cannot make local copy of non-existing file `%s'" filename))
1027       (copy-file filename tmpfile 'ok-if-already-exists 'keep-time)
1028       tmpfile)))
1029
1030 (defun tramp-gvfs-handle-file-name-all-completions (filename directory)
1031   "Like `file-name-all-completions' for Tramp files."
1032   (unless (save-match-data (string-match "/" filename))
1033     (all-completions
1034      filename
1035      (with-parsed-tramp-file-name (expand-file-name directory) nil
1036        (with-tramp-file-property v localname "file-name-all-completions"
1037          (let ((result '("./" "../")))
1038            ;; Get a list of directories and files.
1039            (dolist (item (tramp-gvfs-get-directory-attributes directory) result)
1040              (if (string-equal (cdr (assoc "type" item)) "directory")
1041                  (push (file-name-as-directory (car item)) result)
1042                (push (car item) result)))))))))
1043
1044 (defun tramp-gvfs-handle-file-notify-add-watch (file-name flags _callback)
1045   "Like `file-notify-add-watch' for Tramp files."
1046   (setq file-name (expand-file-name file-name))
1047   (with-parsed-tramp-file-name file-name nil
1048     ;; We cannot watch directories, because `gvfs-monitor-dir' is not
1049     ;; supported for gvfs-mounted directories.
1050     (when (file-directory-p file-name)
1051       (tramp-error
1052        v 'file-notify-error "Monitoring not supported for `%s'" file-name))
1053     (let* ((default-directory (file-name-directory file-name))
1054            (events
1055             (cond
1056              ((and (memq 'change flags) (memq 'attribute-change flags))
1057               '(created changed changes-done-hint moved deleted
1058                         attribute-changed))
1059              ((memq 'change flags)
1060               '(created changed changes-done-hint moved deleted))
1061              ((memq 'attribute-change flags) '(attribute-changed))))
1062            (p (start-process
1063                "gvfs-monitor-file" (generate-new-buffer " *gvfs-monitor-file*")
1064                "gvfs-monitor-file" (tramp-gvfs-url-file-name file-name))))
1065       (if (not (processp p))
1066           (tramp-error
1067            v 'file-notify-error "Monitoring not supported for `%s'" file-name)
1068         (tramp-message
1069          v 6 "Run `%s', %S" (mapconcat 'identity (process-command p) " ") p)
1070         (tramp-set-connection-property p "vector" v)
1071         (process-put p 'events events)
1072         (process-put p 'watch-name localname)
1073         (set-process-query-on-exit-flag p nil)
1074         (set-process-filter p 'tramp-gvfs-monitor-file-process-filter)
1075         ;; There might be an error if the monitor is not supported.
1076         ;; Give the filter a chance to read the output.
1077         (tramp-accept-process-output p 1)
1078         (unless (memq (process-status p) '(run open))
1079           (tramp-error
1080            v 'file-notify-error "Monitoring not supported for `%s'" file-name))
1081         p))))
1082
1083 (defun tramp-gvfs-monitor-file-process-filter (proc string)
1084   "Read output from \"gvfs-monitor-file\" and add corresponding \
1085 file-notify events."
1086   (let* ((rest-string (process-get proc 'rest-string))
1087          (dd (with-current-buffer (process-buffer proc) default-directory))
1088          (ddu (regexp-quote (tramp-gvfs-url-file-name dd))))
1089     (when rest-string
1090       (tramp-message proc 10 "Previous string:\n%s" rest-string))
1091     (tramp-message proc 6 "%S\n%s" proc string)
1092     (setq string (concat rest-string string)
1093           ;; Attribute change is returned in unused wording.
1094           string (replace-regexp-in-string
1095                   "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string))
1096     (when (string-match "Monitoring not supported" string)
1097       (delete-process proc))
1098
1099     (while (string-match
1100             (concat "^[\n\r]*"
1101                     "File Monitor Event:[\n\r]+"
1102                     "File = \\([^\n\r]+\\)[\n\r]+"
1103                     "Event = \\([^[:blank:]]+\\)[\n\r]+")
1104             string)
1105       (let ((file (match-string 1 string))
1106             (action (intern-soft
1107                      (replace-regexp-in-string
1108                       "_" "-" (downcase (match-string 2 string))))))
1109         (setq string (replace-match "" nil nil string))
1110         ;; File names are returned as URL paths.  We must convert them.
1111         (when (string-match ddu file)
1112           (setq file (replace-match dd nil nil file)))
1113         (while (string-match "%\\([0-9A-F]\\{2\\}\\)" file)
1114           (setq file
1115                 (replace-match
1116                  (char-to-string (string-to-number (match-string 1 file) 16))
1117                  nil nil file)))
1118         ;; Usually, we would add an Emacs event now.  Unfortunately,
1119         ;; `unread-command-events' does not accept several events at
1120         ;; once.  Therefore, we apply the callback directly.
1121         (tramp-compat-funcall 'file-notify-callback (list proc action file))))
1122
1123     ;; Save rest of the string.
1124     (when (zerop (length string)) (setq string nil))
1125     (when string (tramp-message proc 10 "Rest string:\n%s" string))
1126     (process-put proc 'rest-string string)))
1127
1128 (defun tramp-gvfs-handle-file-readable-p (filename)
1129   "Like `file-readable-p' for Tramp files."
1130   (with-parsed-tramp-file-name filename nil
1131     (with-tramp-file-property v localname "file-readable-p"
1132       (tramp-check-cached-permissions v ?r))))
1133
1134 (defun tramp-gvfs-handle-file-writable-p (filename)
1135   "Like `file-writable-p' for Tramp files."
1136   (with-parsed-tramp-file-name filename nil
1137     (with-tramp-file-property v localname "file-writable-p"
1138       (if (file-exists-p filename)
1139           (tramp-check-cached-permissions v ?w)
1140         ;; If file doesn't exist, check if directory is writable.
1141         (and (file-directory-p (file-name-directory filename))
1142              (file-writable-p (file-name-directory filename)))))))
1143
1144 (defun tramp-gvfs-handle-make-directory (dir &optional parents)
1145   "Like `make-directory' for Tramp files."
1146   (setq dir (directory-file-name (expand-file-name dir)))
1147   (with-parsed-tramp-file-name dir nil
1148     (tramp-flush-file-property v (file-name-directory localname))
1149     (tramp-flush-directory-property v localname)
1150     (save-match-data
1151       (let ((ldir (file-name-directory dir)))
1152         ;; Make missing directory parts.  "gvfs-mkdir -p ..." does not
1153         ;; work robust.
1154         (when (and parents (not (file-directory-p ldir)))
1155           (make-directory ldir parents))
1156         ;; Just do it.
1157         (unless (tramp-gvfs-send-command
1158                  v "gvfs-mkdir" (tramp-gvfs-url-file-name dir))
1159           (tramp-error v 'file-error "Couldn't make directory %s" dir))))))
1160
1161 (defun tramp-gvfs-handle-rename-file
1162   (filename newname &optional ok-if-already-exists)
1163   "Like `rename-file' for Tramp files."
1164   ;; Check if both files are local -- invoke normal rename-file.
1165   ;; Otherwise, use Tramp from local system.
1166   (setq filename (expand-file-name filename))
1167   (setq newname (expand-file-name newname))
1168   ;; At least one file a Tramp file?
1169   (if (or (tramp-tramp-file-p filename)
1170           (tramp-tramp-file-p newname))
1171       (tramp-gvfs-do-copy-or-rename-file
1172        'rename filename newname ok-if-already-exists
1173        'keep-date 'preserve-uid-gid)
1174     (tramp-run-real-handler
1175      'rename-file (list filename newname ok-if-already-exists))))
1176
1177 (defun tramp-gvfs-handle-write-region
1178   (start end filename &optional append visit lockname confirm)
1179   "Like `write-region' for Tramp files."
1180   (with-parsed-tramp-file-name filename nil
1181     (when (and confirm (file-exists-p filename))
1182       (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename))
1183         (tramp-error v 'file-error "File not overwritten")))
1184
1185     (let ((tmpfile (tramp-compat-make-temp-file filename)))
1186       (when (and append (file-exists-p filename))
1187         (copy-file filename tmpfile 'ok))
1188       ;; We say `no-message' here because we don't want the visited file
1189       ;; modtime data to be clobbered from the temp file.  We call
1190       ;; `set-visited-file-modtime' ourselves later on.
1191       (tramp-run-real-handler
1192        'write-region
1193        (if confirm ; don't pass this arg unless defined for backward compat.
1194            (list start end tmpfile append 'no-message lockname confirm)
1195          (list start end tmpfile append 'no-message lockname)))
1196       (condition-case nil
1197           (rename-file tmpfile filename 'ok-if-already-exists)
1198         (error
1199          (delete-file tmpfile)
1200          (tramp-error
1201           v 'file-error "Couldn't write region to `%s'" filename))))
1202
1203     (tramp-flush-file-property v (file-name-directory localname))
1204     (tramp-flush-file-property v localname)
1205
1206     ;; Set file modification time.
1207     (when (or (eq visit t) (stringp visit))
1208       (set-visited-file-modtime (nth 5 (file-attributes filename))))
1209
1210     ;; The end.
1211     (when (or (eq visit t) (null visit) (stringp visit))
1212       (tramp-message v 0 "Wrote %s" filename))
1213     (run-hooks 'tramp-handle-write-region-hook)))
1214
1215 \f
1216 ;; File name conversions.
1217
1218 (defun tramp-gvfs-url-file-name (filename)
1219   "Return FILENAME in URL syntax."
1220   ;; "/" must NOT be hexlified.
1221   (let ((url-unreserved-chars (cons ?/ url-unreserved-chars))
1222         result)
1223     (setq
1224      result
1225      (url-recreate-url
1226       (if (tramp-tramp-file-p filename)
1227           (with-parsed-tramp-file-name filename nil
1228             (when (string-equal "gdrive" method)
1229               (setq method "google-drive"))
1230             (when (and user (string-match tramp-user-with-domain-regexp user))
1231               (setq user
1232                     (concat (match-string 2 user) ";" (match-string 1 user))))
1233             (url-parse-make-urlobj
1234              method (and user (url-hexify-string user)) nil
1235              (tramp-file-name-real-host v) (tramp-file-name-port v)
1236              (and localname (url-hexify-string localname)) nil nil t))
1237         (url-parse-make-urlobj
1238          "file" nil nil nil nil
1239          (url-hexify-string (file-truename filename)) nil nil t))))
1240     (when (tramp-tramp-file-p filename)
1241       (with-parsed-tramp-file-name filename nil
1242         (tramp-message v 10 "remote file `%s' is URL `%s'" filename result)))
1243     result))
1244
1245 (defun tramp-gvfs-object-path (filename)
1246   "Create a D-Bus object path from FILENAME."
1247   (expand-file-name (dbus-escape-as-identifier filename) tramp-gvfs-path-tramp))
1248
1249 (defun tramp-gvfs-file-name (object-path)
1250   "Retrieve file name from D-Bus OBJECT-PATH."
1251   (dbus-unescape-from-identifier
1252    (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path)))
1253
1254 (defun tramp-bluez-address (device)
1255   "Return bluetooth device address from a given bluetooth DEVICE name."
1256   (when (stringp device)
1257     (if (string-match tramp-ipv6-regexp device)
1258         (match-string 0 device)
1259       (cadr (assoc device (tramp-bluez-list-devices))))))
1260
1261 (defun tramp-bluez-device (address)
1262   "Return bluetooth device name from a given bluetooth device ADDRESS.
1263 ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1264   (when (stringp address)
1265     (while (string-match "[][]" address)
1266       (setq address (replace-match "" t t address)))
1267     (let (result)
1268       (dolist (item (tramp-bluez-list-devices) result)
1269         (when (string-match address (cadr item))
1270           (setq result (car item)))))))
1271
1272 \f
1273 ;; D-Bus GVFS functions.
1274
1275 (defun tramp-gvfs-handler-askpassword (message user domain flags)
1276   "Implementation for the \"org.gtk.vfs.MountOperation.askPassword\" method."
1277   (let* ((filename
1278           (tramp-gvfs-file-name (dbus-event-path-name last-input-event)))
1279          (pw-prompt
1280           (format
1281            "%s for %s "
1282            (if (string-match "\\([pP]assword\\|[pP]assphrase\\)" message)
1283                (capitalize (match-string 1 message))
1284              "Password")
1285            filename))
1286          password)
1287
1288     (condition-case nil
1289         (with-parsed-tramp-file-name filename l
1290           (when (and (zerop (length user))
1291                      (not
1292                       (zerop (logand flags tramp-gvfs-password-need-username))))
1293             (setq user (read-string "User name: ")))
1294           (when (and (zerop (length domain))
1295                      (not
1296                       (zerop (logand flags tramp-gvfs-password-need-domain))))
1297             (setq domain (read-string "Domain name: ")))
1298
1299           (tramp-message l 6 "%S %S %S %d" message user domain flags)
1300           (unless (tramp-get-connection-property l "first-password-request" nil)
1301             (tramp-clear-passwd l))
1302
1303           (setq tramp-current-method l-method
1304                 tramp-current-user user
1305                 tramp-current-host l-host
1306                 password (tramp-read-passwd
1307                           (tramp-get-connection-process l) pw-prompt))
1308
1309           ;; Return result.
1310           (if (stringp password)
1311               (list
1312                t ;; password handled.
1313                nil ;; no abort of D-Bus.
1314                password
1315                (tramp-file-name-real-user l)
1316                domain
1317                nil ;; not anonymous.
1318                0) ;; no password save.
1319             ;; No password provided.
1320             (list nil t "" (tramp-file-name-real-user l) domain nil 0)))
1321
1322       ;; When QUIT is raised, we shall return this information to D-Bus.
1323       (quit (list nil t "" "" "" nil 0)))))
1324
1325 (defun tramp-gvfs-handler-askquestion (message choices)
1326   "Implementation for the \"org.gtk.vfs.MountOperation.askQuestion\" method."
1327   (save-window-excursion
1328     (let ((enable-recursive-minibuffers t)
1329           choice)
1330
1331       (condition-case nil
1332           (with-parsed-tramp-file-name
1333               (tramp-gvfs-file-name (dbus-event-path-name last-input-event)) nil
1334             (tramp-message v 6 "%S %S" message choices)
1335
1336             ;; In theory, there can be several choices.  Until now,
1337             ;; there is only the question whether to accept an unknown
1338             ;; host signature.
1339             (with-temp-buffer
1340               ;; Preserve message for `progress-reporter'.
1341               (with-temp-message ""
1342                 (insert message)
1343                 (pop-to-buffer (current-buffer))
1344                 (setq choice (if (yes-or-no-p (concat (car choices) " ")) 0 1))
1345                 (tramp-message v 6 "%d" choice)))
1346
1347             ;; When the choice is "no", we set a dummy fuse-mountpoint
1348             ;; in order to leave the timeout.
1349             (unless (zerop choice)
1350               (tramp-set-file-property v "/" "fuse-mountpoint" "/"))
1351
1352             (list
1353              t ;; handled.
1354              nil ;; no abort of D-Bus.
1355              choice))
1356
1357         ;; When QUIT is raised, we shall return this information to D-Bus.
1358         (quit (list nil t 0))))))
1359
1360 (defun tramp-gvfs-handler-mounted-unmounted (mount-info)
1361   "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and
1362 \"org.gtk.vfs.MountTracker.unmounted\" signals."
1363   (ignore-errors
1364     (let ((signal-name (dbus-event-member-name last-input-event))
1365           (elt mount-info))
1366       ;; Jump over the first elements of the mount info. Since there
1367       ;; were changes in the entries, we cannot access dedicated
1368       ;; elements.
1369       (while (stringp (car elt)) (setq elt (cdr elt)))
1370       (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt)))
1371              (mount-spec (caddr elt))
1372              (default-location (tramp-gvfs-dbus-byte-array-to-string
1373                                 (cadddr elt)))
1374              (method (tramp-gvfs-dbus-byte-array-to-string
1375                       (cadr (assoc "type" (cadr mount-spec)))))
1376              (user (tramp-gvfs-dbus-byte-array-to-string
1377                     (cadr (assoc "user" (cadr mount-spec)))))
1378              (domain (tramp-gvfs-dbus-byte-array-to-string
1379                       (cadr (assoc "domain" (cadr mount-spec)))))
1380              (host (tramp-gvfs-dbus-byte-array-to-string
1381                     (cadr (or (assoc "host" (cadr mount-spec))
1382                               (assoc "server" (cadr mount-spec))))))
1383              (port (tramp-gvfs-dbus-byte-array-to-string
1384                     (cadr (assoc "port" (cadr mount-spec)))))
1385              (ssl (tramp-gvfs-dbus-byte-array-to-string
1386                    (cadr (assoc "ssl" (cadr mount-spec)))))
1387              (prefix (concat
1388                       (tramp-gvfs-dbus-byte-array-to-string
1389                        (car mount-spec))
1390                       (tramp-gvfs-dbus-byte-array-to-string
1391                        (or (cadr (assoc "share" (cadr mount-spec)))
1392                            (cadr (assoc "volume" (cadr mount-spec))))))))
1393         (when (string-match "^\\(afp\\|smb\\)" method)
1394           (setq method (match-string 1 method)))
1395         (when (string-equal "obex" method)
1396           (setq host (tramp-bluez-device host)))
1397         (when (and (string-equal "dav" method) (string-equal "true" ssl))
1398           (setq method "davs"))
1399         (when (string-equal "google-drive" method)
1400           (setq method "gdrive"))
1401         (unless (zerop (length domain))
1402           (setq user (concat user tramp-prefix-domain-format domain)))
1403         (unless (zerop (length port))
1404           (setq host (concat host tramp-prefix-port-format port)))
1405         (with-parsed-tramp-file-name
1406             (tramp-make-tramp-file-name method user host "") nil
1407           (tramp-message
1408            v 6 "%s %s"
1409            signal-name (tramp-gvfs-stringify-dbus-message mount-info))
1410           (tramp-set-file-property v "/" "list-mounts" 'undef)
1411           (if (string-equal (downcase signal-name) "unmounted")
1412               (tramp-set-file-property v "/" "fuse-mountpoint" nil)
1413             ;; Set prefix, mountpoint and location.
1414             (unless (string-equal prefix "/")
1415               (tramp-set-file-property v "/" "prefix" prefix))
1416             (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint)
1417             (tramp-set-file-property
1418              v "/" "default-location" default-location)))))))
1419
1420 (when tramp-gvfs-enabled
1421   (dbus-register-signal
1422    :session nil tramp-gvfs-path-mounttracker
1423    tramp-gvfs-interface-mounttracker "mounted"
1424    'tramp-gvfs-handler-mounted-unmounted)
1425   (dbus-register-signal
1426    :session nil tramp-gvfs-path-mounttracker
1427    tramp-gvfs-interface-mounttracker "Mounted"
1428    'tramp-gvfs-handler-mounted-unmounted)
1429
1430   (dbus-register-signal
1431    :session nil tramp-gvfs-path-mounttracker
1432    tramp-gvfs-interface-mounttracker "unmounted"
1433    'tramp-gvfs-handler-mounted-unmounted)
1434   (dbus-register-signal
1435    :session nil tramp-gvfs-path-mounttracker
1436    tramp-gvfs-interface-mounttracker "Unmounted"
1437    'tramp-gvfs-handler-mounted-unmounted))
1438
1439 (defun tramp-gvfs-connection-mounted-p (vec)
1440   "Check, whether the location is already mounted."
1441   (or
1442    (tramp-get-file-property vec "/" "fuse-mountpoint" nil)
1443    (catch 'mounted
1444      (dolist
1445          (elt
1446           (with-tramp-file-property vec "/" "list-mounts"
1447             (with-tramp-dbus-call-method vec t
1448               :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1449               tramp-gvfs-interface-mounttracker tramp-gvfs-listmounts))
1450           nil)
1451        ;; Jump over the first elements of the mount info. Since there
1452        ;; were changes in the entries, we cannot access dedicated
1453        ;; elements.
1454        (while (stringp (car elt)) (setq elt (cdr elt)))
1455        (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string
1456                                 (cadr elt)))
1457               (mount-spec (caddr elt))
1458               (default-location (tramp-gvfs-dbus-byte-array-to-string
1459                                  (cadddr elt)))
1460               (method (tramp-gvfs-dbus-byte-array-to-string
1461                        (cadr (assoc "type" (cadr mount-spec)))))
1462               (user (tramp-gvfs-dbus-byte-array-to-string
1463                      (cadr (assoc "user" (cadr mount-spec)))))
1464               (domain (tramp-gvfs-dbus-byte-array-to-string
1465                        (cadr (assoc "domain" (cadr mount-spec)))))
1466               (host (tramp-gvfs-dbus-byte-array-to-string
1467                      (cadr (or (assoc "host" (cadr mount-spec))
1468                                (assoc "server" (cadr mount-spec))))))
1469               (port (tramp-gvfs-dbus-byte-array-to-string
1470                      (cadr (assoc "port" (cadr mount-spec)))))
1471               (ssl (tramp-gvfs-dbus-byte-array-to-string
1472                     (cadr (assoc "ssl" (cadr mount-spec)))))
1473               (prefix (concat
1474                        (tramp-gvfs-dbus-byte-array-to-string
1475                         (car mount-spec))
1476                        (tramp-gvfs-dbus-byte-array-to-string
1477                         (or
1478                          (cadr (assoc "share" (cadr mount-spec)))
1479                          (cadr (assoc "volume" (cadr mount-spec))))))))
1480          (when (string-match "^\\(afp\\|smb\\)" method)
1481            (setq method (match-string 1 method)))
1482          (when (string-equal "obex" method)
1483            (setq host (tramp-bluez-device host)))
1484          (when (and (string-equal "dav" method) (string-equal "true" ssl))
1485            (setq method "davs"))
1486          (when (string-equal "google-drive" method)
1487            (setq method "gdrive"))
1488          (when (and (string-equal "synce" method) (zerop (length user)))
1489            (setq user (or (tramp-file-name-user vec) "")))
1490          (unless (zerop (length domain))
1491            (setq user (concat user tramp-prefix-domain-format domain)))
1492          (unless (zerop (length port))
1493            (setq host (concat host tramp-prefix-port-format port)))
1494          (when (and
1495                 (string-equal method (tramp-file-name-method vec))
1496                 (string-equal user (or (tramp-file-name-user vec) ""))
1497                 (string-equal host (tramp-file-name-host vec))
1498                 (string-match (concat "^" (regexp-quote prefix))
1499                               (tramp-file-name-localname vec)))
1500            ;; Set prefix, mountpoint and location.
1501            (unless (string-equal prefix "/")
1502              (tramp-set-file-property vec "/" "prefix" prefix))
1503            (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint)
1504            (tramp-set-file-property vec "/" "default-location" default-location)
1505            (throw 'mounted t)))))))
1506
1507 (defun tramp-gvfs-mount-spec-entry (key value)
1508   "Construct a mount-spec entry to be used in a mount_spec.
1509 It was \"a(say)\", but has changed to \"a{sv})\"."
1510   (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature)
1511       (list :dict-entry key
1512             (list :variant (tramp-gvfs-dbus-string-to-byte-array value)))
1513     (list :struct key (tramp-gvfs-dbus-string-to-byte-array value))))
1514
1515 (defun tramp-gvfs-mount-spec (vec)
1516   "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"."
1517   (let* ((method (tramp-file-name-method vec))
1518          (user (tramp-file-name-real-user vec))
1519          (domain (tramp-file-name-domain vec))
1520          (host (tramp-file-name-real-host vec))
1521          (port (tramp-file-name-port vec))
1522          (localname (tramp-file-name-localname vec))
1523          (share (when (string-match "^/?\\([^/]+\\)" localname)
1524                   (match-string 1 localname)))
1525          (ssl (when (string-match "^davs" method) "true" "false"))
1526          (mount-spec
1527           `(:array
1528             ,@(cond
1529                ((string-equal "smb" method)
1530                 (list (tramp-gvfs-mount-spec-entry "type" "smb-share")
1531                       (tramp-gvfs-mount-spec-entry "server" host)
1532                       (tramp-gvfs-mount-spec-entry "share" share)))
1533                ((string-equal "obex" method)
1534                 (list (tramp-gvfs-mount-spec-entry "type" method)
1535                       (tramp-gvfs-mount-spec-entry
1536                        "host" (concat "[" (tramp-bluez-address host) "]"))))
1537                ((string-match "\\`dav" method)
1538                 (list (tramp-gvfs-mount-spec-entry "type" "dav")
1539                       (tramp-gvfs-mount-spec-entry "host" host)
1540                       (tramp-gvfs-mount-spec-entry "ssl" ssl)))
1541                ((string-equal "afp" method)
1542                 (list (tramp-gvfs-mount-spec-entry "type" "afp-volume")
1543                       (tramp-gvfs-mount-spec-entry "host" host)
1544                       (tramp-gvfs-mount-spec-entry "volume" share)))
1545                ((string-equal "gdrive" method)
1546                 (list (tramp-gvfs-mount-spec-entry "type" "google-drive")
1547                       (tramp-gvfs-mount-spec-entry "host" host)))
1548                (t
1549                 (list (tramp-gvfs-mount-spec-entry "type" method)
1550                       (tramp-gvfs-mount-spec-entry "host" host))))
1551             ,@(when user
1552                 (list (tramp-gvfs-mount-spec-entry "user" user)))
1553             ,@(when domain
1554                 (list (tramp-gvfs-mount-spec-entry "domain" domain)))
1555             ,@(when port
1556                 (list (tramp-gvfs-mount-spec-entry
1557                        "port" (number-to-string port))))))
1558          (mount-pref
1559           (if (and (string-match "\\`dav" method)
1560                    (string-match "^/?[^/]+" localname))
1561               (match-string 0 localname)
1562             "/")))
1563
1564     ;; Return.
1565     `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec)))
1566
1567 \f
1568 ;; Connection functions.
1569
1570 (defun tramp-gvfs-maybe-open-connection (vec)
1571   "Maybe open a connection VEC.
1572 Does not do anything if a connection is already open, but re-opens the
1573 connection if a previous connection has died for some reason."
1574   (tramp-check-proper-method-and-host vec)
1575
1576   ;; We set the file name, in case there are incoming D-Bus signals or
1577   ;; D-Bus errors.
1578   (setq tramp-gvfs-dbus-event-vector vec)
1579
1580   ;; For password handling, we need a process bound to the connection
1581   ;; buffer.  Therefore, we create a dummy process.  Maybe there is a
1582   ;; better solution?
1583   (unless (get-buffer-process (tramp-get-connection-buffer vec))
1584     (let ((p (make-network-process
1585               :name (tramp-buffer-name vec)
1586               :buffer (tramp-get-connection-buffer vec)
1587               :server t :host 'local :service t :noquery t)))
1588       (set-process-query-on-exit-flag p nil)))
1589
1590   (unless (tramp-gvfs-connection-mounted-p vec)
1591     (let* ((method (tramp-file-name-method vec))
1592            (user (tramp-file-name-user vec))
1593            (host (tramp-file-name-host vec))
1594            (localname (tramp-file-name-localname vec))
1595            (object-path
1596             (tramp-gvfs-object-path
1597              (tramp-make-tramp-file-name method user host ""))))
1598
1599       (when (and (string-equal method "smb")
1600                  (string-equal localname "/"))
1601         (tramp-error vec 'file-error "Filename must contain a Windows share"))
1602
1603       (when (and (string-equal method "afp")
1604                  (string-equal localname "/"))
1605         (tramp-error vec 'file-error "Filename must contain an AFP volume"))
1606
1607       (with-tramp-progress-reporter
1608           vec 3
1609           (if (zerop (length user))
1610               (format "Opening connection for %s using %s" host method)
1611             (format "Opening connection for %s@%s using %s" user host method))
1612
1613         ;; Enable `auth-source'.
1614         (tramp-set-connection-property vec "first-password-request" t)
1615
1616         ;; There will be a callback of "askPassword" when a password is
1617         ;; needed.
1618         (dbus-register-method
1619          :session dbus-service-emacs object-path
1620          tramp-gvfs-interface-mountoperation "askPassword"
1621          'tramp-gvfs-handler-askpassword)
1622         (dbus-register-method
1623          :session dbus-service-emacs object-path
1624          tramp-gvfs-interface-mountoperation "AskPassword"
1625          'tramp-gvfs-handler-askpassword)
1626
1627         ;; There could be a callback of "askQuestion" when adding fingerprint.
1628         (dbus-register-method
1629          :session dbus-service-emacs object-path
1630          tramp-gvfs-interface-mountoperation "askQuestion"
1631          'tramp-gvfs-handler-askquestion)
1632         (dbus-register-method
1633          :session dbus-service-emacs object-path
1634          tramp-gvfs-interface-mountoperation "AskQuestion"
1635          'tramp-gvfs-handler-askquestion)
1636
1637         ;; The call must be asynchronously, because of the "askPassword"
1638         ;; or "askQuestion"callbacks.
1639         (if (string-match "(so)$" tramp-gvfs-mountlocation-signature)
1640             (with-tramp-dbus-call-method vec nil
1641               :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1642               tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1643               (tramp-gvfs-mount-spec vec)
1644               `(:struct :string ,(dbus-get-unique-name :session)
1645                         :object-path ,object-path))
1646           (with-tramp-dbus-call-method vec nil
1647             :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1648             tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1649             (tramp-gvfs-mount-spec vec)
1650             :string (dbus-get-unique-name :session) :object-path object-path))
1651
1652         ;; We must wait, until the mount is applied.  This will be
1653         ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint"
1654         ;; file property.
1655         (with-timeout
1656             ((or (tramp-get-method-parameter vec 'tramp-connection-timeout)
1657                  tramp-connection-timeout)
1658              (if (zerop (length (tramp-file-name-user vec)))
1659                  (tramp-error
1660                   vec 'file-error
1661                   "Timeout reached mounting %s using %s" host method)
1662                (tramp-error
1663                 vec 'file-error
1664                 "Timeout reached mounting %s@%s using %s" user host method)))
1665           (while (not (tramp-get-file-property vec "/" "fuse-mountpoint" nil))
1666             (read-event nil nil 0.1)))
1667
1668         ;; If `tramp-gvfs-handler-askquestion' has returned "No", it
1669         ;; is marked with the fuse-mountpoint "/".  We shall react.
1670         (when (string-equal
1671                (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/")
1672           (tramp-error vec 'file-error "FUSE mount denied"))
1673
1674         ;; Mark it as connected.
1675         (tramp-set-connection-property
1676          (tramp-get-connection-process vec) "connected" t))))
1677
1678   ;; In `tramp-check-cached-permissions', the connection properties
1679   ;; {uig,gid}-{integer,string} are used.  We set them to their local
1680   ;; counterparts.
1681   (with-tramp-connection-property
1682    vec "uid-integer" (tramp-get-local-uid 'integer))
1683   (with-tramp-connection-property
1684    vec "gid-integer" (tramp-get-local-gid 'integer))
1685   (with-tramp-connection-property
1686    vec "uid-string" (tramp-get-local-uid 'string))
1687   (with-tramp-connection-property
1688    vec "gid-string" (tramp-get-local-gid 'string)))
1689
1690 (defun tramp-gvfs-send-command (vec command &rest args)
1691   "Send the COMMAND with its ARGS to connection VEC.
1692 COMMAND is usually a command from the gvfs-* utilities.
1693 `call-process' is applied, and it returns t if the return code is zero."
1694   (let* ((locale (tramp-get-local-locale vec))
1695          (process-environment
1696           (append
1697            `(,(format "LANG=%s" locale)
1698              ,(format "LANGUAGE=%s" locale)
1699              ,(format "LC_ALL=%s" locale))
1700            process-environment)))
1701     (with-current-buffer (tramp-get-connection-buffer vec)
1702       (tramp-gvfs-maybe-open-connection vec)
1703       (erase-buffer)
1704       (zerop (apply 'tramp-call-process vec command nil t nil args)))))
1705
1706 \f
1707 ;; D-Bus BLUEZ functions.
1708
1709 (defun tramp-bluez-list-devices ()
1710   "Return all discovered bluetooth devices as list.
1711 Every entry is a list (NAME ADDRESS).
1712
1713 If `tramp-bluez-discover-devices-timeout' is an integer, and the last
1714 discovery happened more time before indicated there, a rescan will be
1715 started, which lasts some ten seconds.  Otherwise, cached results will
1716 be used."
1717   ;; Reset the scanned devices list if time has passed.
1718   (and (integerp tramp-bluez-discover-devices-timeout)
1719        (integerp tramp-bluez-discovery)
1720        (> (tramp-time-diff (current-time) tramp-bluez-discovery)
1721           tramp-bluez-discover-devices-timeout)
1722        (setq tramp-bluez-devices nil))
1723
1724   ;; Rescan if needed.
1725   (unless tramp-bluez-devices
1726     (let ((object-path
1727            (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1728              :system tramp-bluez-service "/"
1729              tramp-bluez-interface-manager "DefaultAdapter")))
1730       (setq tramp-bluez-devices nil
1731             tramp-bluez-discovery t)
1732       (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil
1733         :system tramp-bluez-service object-path
1734         tramp-bluez-interface-adapter "StartDiscovery")
1735       (while tramp-bluez-discovery
1736         (read-event nil nil 0.1))))
1737   (setq tramp-bluez-discovery (current-time))
1738   (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-bluez-devices)
1739   tramp-bluez-devices)
1740
1741 (defun tramp-bluez-property-changed (property value)
1742   "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal."
1743   (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" property value)
1744   (cond
1745    ((string-equal property "Discovering")
1746     (unless (car value)
1747       ;; "Discovering" FALSE means discovery run has been completed.
1748       ;; We stop it, because we don't need another run.
1749       (setq tramp-bluez-discovery nil)
1750       (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1751         :system tramp-bluez-service (dbus-event-path-name last-input-event)
1752         tramp-bluez-interface-adapter "StopDiscovery")))))
1753
1754 (when tramp-gvfs-enabled
1755   (dbus-register-signal
1756    :system nil nil tramp-bluez-interface-adapter "PropertyChanged"
1757    'tramp-bluez-property-changed))
1758
1759 (defun tramp-bluez-device-found (device args)
1760   "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal."
1761   (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" device args)
1762   (let ((alias (car (cadr (assoc "Alias" args))))
1763         (address (car (cadr (assoc "Address" args)))))
1764     ;; Maybe we shall check the device class for being a proper
1765     ;; device, and call also SDP in order to find the obex service.
1766     (add-to-list 'tramp-bluez-devices (list alias address))))
1767
1768 (when tramp-gvfs-enabled
1769   (dbus-register-signal
1770    :system nil nil tramp-bluez-interface-adapter "DeviceFound"
1771    'tramp-bluez-device-found))
1772
1773 (defun tramp-bluez-parse-device-names (_ignore)
1774   "Return a list of (nil host) tuples allowed to access."
1775   (mapcar
1776    (lambda (x) (list nil (car x)))
1777    (tramp-bluez-list-devices)))
1778
1779 ;; Add completion function for OBEX method.
1780 (when (and tramp-gvfs-enabled
1781            (member tramp-bluez-service (dbus-list-known-names :system)))
1782   (tramp-set-completion-function
1783    "obex" '((tramp-bluez-parse-device-names ""))))
1784
1785 \f
1786 ;; D-Bus zeroconf functions.
1787
1788 (defun tramp-zeroconf-parse-device-names (service)
1789   "Return a list of (user host) tuples allowed to access."
1790   (mapcar
1791    (lambda (x)
1792      (let ((host (zeroconf-service-host x))
1793            (port (zeroconf-service-port x))
1794            (text (zeroconf-service-txt x))
1795            user)
1796        (when port
1797          (setq host (format "%s%s%d" host tramp-prefix-port-regexp port)))
1798        ;; A user is marked in a TXT field like "u=guest".
1799        (while text
1800          (when (string-match "u=\\(.+\\)$" (car text))
1801            (setq user (match-string 1 (car text))))
1802          (setq text (cdr text)))
1803        (list user host)))
1804    (zeroconf-list-services service)))
1805
1806 ;; We use the TRIM argument of `split-string', which exist since Emacs
1807 ;; 24.4.  I mask this for older Emacs versions, there is no harm.
1808 (defun tramp-gvfs-parse-device-names (service)
1809   "Return a list of (user host) tuples allowed to access.
1810 This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi."
1811   (let ((result
1812          (ignore-errors
1813            (tramp-compat-funcall
1814             'split-string
1815             (shell-command-to-string (format "avahi-browse -trkp %s" service))
1816             "[\n\r]+" 'omit "^\\+;.*$"))))
1817     (delete-dups
1818      (mapcar
1819       (lambda (x)
1820         (let* ((list (split-string x ";"))
1821                (host (nth 6 list))
1822                (port (nth 8 list))
1823                (text (tramp-compat-funcall
1824                       'split-string (nth 9 list) "\" \"" 'omit "\""))
1825                user)
1826 ;         (when (and port (not (string-equal port "0")))
1827 ;           (setq host (format "%s%s%s" host tramp-prefix-port-regexp port)))
1828           ;; A user is marked in a TXT field like "u=guest".
1829           (while text
1830             (when (string-match "u=\\(.+\\)$" (car text))
1831               (setq user (match-string 1 (car text))))
1832             (setq text (cdr text)))
1833           (list user host)))
1834       result))))
1835
1836 ;; Add completion functions for AFP, DAV, DAVS, SFTP and SMB methods.
1837 (when tramp-gvfs-enabled
1838   ;; Suppress D-Bus error messages.
1839   (let (tramp-gvfs-dbus-event-vector)
1840     (zeroconf-init tramp-gvfs-zeroconf-domain)
1841     (if (zeroconf-list-service-types)
1842         (progn
1843           (tramp-set-completion-function
1844            "afp" '((tramp-zeroconf-parse-device-names "_afpovertcp._tcp")))
1845           (tramp-set-completion-function
1846            "dav" '((tramp-zeroconf-parse-device-names "_webdav._tcp")))
1847           (tramp-set-completion-function
1848            "davs" '((tramp-zeroconf-parse-device-names "_webdav._tcp")))
1849           (tramp-set-completion-function
1850            "sftp" '((tramp-zeroconf-parse-device-names "_ssh._tcp")
1851                     (tramp-zeroconf-parse-device-names "_workstation._tcp")))
1852           (when (member "smb" tramp-gvfs-methods)
1853             (tramp-set-completion-function
1854              "smb" '((tramp-zeroconf-parse-device-names "_smb._tcp")))))
1855
1856       (when (executable-find "avahi-browse")
1857         (tramp-set-completion-function
1858          "afp" '((tramp-gvfs-parse-device-names "_afpovertcp._tcp")))
1859         (tramp-set-completion-function
1860          "dav" '((tramp-gvfs-parse-device-names "_webdav._tcp")))
1861         (tramp-set-completion-function
1862          "davs" '((tramp-gvfs-parse-device-names "_webdav._tcp")))
1863         (tramp-set-completion-function
1864          "sftp" '((tramp-gvfs-parse-device-names "_ssh._tcp")
1865                   (tramp-gvfs-parse-device-names "_workstation._tcp")))
1866         (when (member "smb" tramp-gvfs-methods)
1867           (tramp-set-completion-function
1868            "smb" '((tramp-gvfs-parse-device-names "_smb._tcp"))))))))
1869
1870 \f
1871 ;; D-Bus SYNCE functions.
1872
1873 (defun tramp-synce-list-devices ()
1874   "Return all discovered synce devices as list.
1875 They are retrieved from the hal daemon."
1876   (let (tramp-synce-devices)
1877     (dolist (device
1878              (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1879                :system tramp-hal-service tramp-hal-path-manager
1880                tramp-hal-interface-manager "GetAllDevices"))
1881       (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1882               :system tramp-hal-service device tramp-hal-interface-device
1883               "PropertyExists" "sync.plugin")
1884         (let ((prop
1885                (with-tramp-dbus-call-method
1886                 tramp-gvfs-dbus-event-vector t
1887                 :system tramp-hal-service device tramp-hal-interface-device
1888                 "GetPropertyString" "pda.pocketpc.name")))
1889           (unless (member prop tramp-synce-devices)
1890             (push prop tramp-synce-devices)))))
1891     (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-synce-devices)
1892     tramp-synce-devices))
1893
1894 (defun tramp-synce-parse-device-names (_ignore)
1895   "Return a list of (nil host) tuples allowed to access."
1896   (mapcar
1897    (lambda (x) (list nil x))
1898    (tramp-synce-list-devices)))
1899
1900 ;; Add completion function for SYNCE method.
1901 (when tramp-gvfs-enabled
1902   (tramp-set-completion-function
1903    "synce" '((tramp-synce-parse-device-names ""))))
1904
1905 (add-hook 'tramp-unload-hook
1906           (lambda ()
1907             (unload-feature 'tramp-gvfs 'force)))
1908
1909 (provide 'tramp-gvfs)
1910
1911 ;;; TODO:
1912
1913 ;; * Host name completion for existing mount points (afp-server,
1914 ;;   smb-server) or via smb-network.
1915 ;; * Check, how two shares of the same SMB server can be mounted in
1916 ;;   parallel.
1917 ;; * Apply SDP on bluetooth devices, in order to filter out obex
1918 ;;   capability.
1919 ;; * Implement obex for other serial communication but bluetooth.
1920
1921 ;;; tramp-gvfs.el ends here