lisp/net/tramp-gvfs.el

   1 ;;; tramp-gvfs.el --- Tramp access functions for GVFS daemon  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 2009-2017 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 <https://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 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 'custom))
 110
 111 ;;;###tramp-autoload
 112 (defcustom tramp-gvfs-methods
 113   '("afp" "dav" "davs" "gdrive" "obex" "sftp" "synce")
 114   "List of methods for remote files, accessed with GVFS."
 115   :group 'tramp
 116   :version "26.1"
 117   :type '(repeat (choice (const "afp")
 118                          (const "dav")
 119                          (const "davs")
 120                          (const "ftp")
 121                          (const "gdrive")
 122                          (const "obex")
 123                          (const "sftp")
 124                          (const "smb")
 125                          (const "synce")))
 126   :require 'tramp)
 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   :require 'tramp)
 146
 147 ;; Add the methods to `tramp-methods', in order to allow minibuffer
 148 ;; completion.
 149 ;;;###tramp-autoload
 150 (when (featurep 'dbusbind)
 151   (dolist (elt tramp-gvfs-methods)
 152     (unless (assoc elt tramp-methods)
 153       (add-to-list 'tramp-methods (cons elt nil)))))
 154
 155 (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp")
 156   "The preceding object path for own objects.")
 157
 158 (defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon"
 159   "The well known name of the GVFS daemon.")
 160
 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   :require 'tramp)
 398
 399 (defvar tramp-bluez-discovery nil
 400   "Indicator for a running bluetooth device discovery.
 401 It keeps the timestamp of last discovery.")
 402
 403 (defvar tramp-bluez-devices nil
 404   "Alist of detected bluetooth devices.
 405 Every entry is a list (NAME ADDRESS).")
 406
 407 (defconst tramp-hal-service "org.freedesktop.Hal"
 408   "The well known name of the HAL service.")
 409
 410 (defconst tramp-hal-path-manager "/org/freedesktop/Hal/Manager"
 411   "The object path of the HAL daemon manager.")
 412
 413 (defconst tramp-hal-interface-manager "org.freedesktop.Hal.Manager"
 414   "The manager interface of the HAL daemon.")
 415
 416 (defconst tramp-hal-interface-device "org.freedesktop.Hal.Device"
 417   "The device interface of the HAL daemon.")
 418
 419 (defconst tramp-gvfs-file-attributes
 420   '("name"
 421     "type"
 422     "standard::display-name"
 423     "standard::symlink-target"
 424     "unix::nlink"
 425     "unix::uid"
 426     "owner::user"
 427     "unix::gid"
 428     "owner::group"
 429     "time::access"
 430     "time::modified"
 431     "time::changed"
 432     "standard::size"
 433     "unix::mode"
 434     "access::can-read"
 435     "access::can-write"
 436     "access::can-execute"
 437     "unix::inode"
 438     "unix::device")
 439   "GVFS file attributes.")
 440
 441 (defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp
 442   (concat "[[:blank:]]" (regexp-opt tramp-gvfs-file-attributes t) "=\\(.+?\\)")
 443   "Regexp to parse GVFS file attributes with `gvfs-ls'.")
 444
 445 (defconst tramp-gvfs-file-attributes-with-gvfs-info-regexp
 446   (concat "^[[:blank:]]*"
 447           (regexp-opt tramp-gvfs-file-attributes t)
 448           ":[[:blank:]]+\\(.*\\)$")
 449   "Regexp to parse GVFS file attributes with `gvfs-info'.")
 450
 451 (defconst tramp-gvfs-file-system-attributes
 452   '("filesystem::free"
 453     "filesystem::size"
 454     "filesystem::used")
 455   "GVFS file system attributes.")
 456
 457 (defconst tramp-gvfs-file-system-attributes-regexp
 458   (concat "^[[:blank:]]*"
 459           (regexp-opt tramp-gvfs-file-system-attributes t)
 460           ":[[:blank:]]+\\(.*\\)$")
 461   "Regexp to parse GVFS file system attributes with `gvfs-info'.")
 462
 463 \f
 464 ;; New handlers should be added here.
 465 ;;;###tramp-autoload
 466 (defconst tramp-gvfs-file-name-handler-alist
 467   '((access-file . ignore)
 468     (add-name-to-file . tramp-handle-add-name-to-file)
 469     ;; `byte-compiler-base-file-name' performed by default handler.
 470     ;; `copy-directory' performed by default handler.
 471     (copy-file . tramp-gvfs-handle-copy-file)
 472     (delete-directory . tramp-gvfs-handle-delete-directory)
 473     (delete-file . tramp-gvfs-handle-delete-file)
 474     ;; `diff-latest-backup-file' performed by default handler.
 475     (directory-file-name . tramp-handle-directory-file-name)
 476     (directory-files . tramp-handle-directory-files)
 477     (directory-files-and-attributes
 478      . tramp-handle-directory-files-and-attributes)
 479     (dired-compress-file . ignore)
 480     (dired-uncache . tramp-handle-dired-uncache)
 481     (expand-file-name . tramp-gvfs-handle-expand-file-name)
 482     (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
 483     (file-acl . ignore)
 484     (file-attributes . tramp-gvfs-handle-file-attributes)
 485     (file-directory-p . tramp-gvfs-handle-file-directory-p)
 486     (file-equal-p . tramp-handle-file-equal-p)
 487     (file-executable-p . tramp-gvfs-handle-file-executable-p)
 488     (file-exists-p . tramp-handle-file-exists-p)
 489     (file-in-directory-p . tramp-handle-file-in-directory-p)
 490     (file-local-copy . tramp-gvfs-handle-file-local-copy)
 491     (file-modes . tramp-handle-file-modes)
 492     (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions)
 493     (file-name-as-directory . tramp-handle-file-name-as-directory)
 494     (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p)
 495     (file-name-completion . tramp-handle-file-name-completion)
 496     (file-name-directory . tramp-handle-file-name-directory)
 497     (file-name-nondirectory . tramp-handle-file-name-nondirectory)
 498     ;; `file-name-sans-versions' performed by default handler.
 499     (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
 500     (file-notify-add-watch . tramp-gvfs-handle-file-notify-add-watch)
 501     (file-notify-rm-watch . tramp-handle-file-notify-rm-watch)
 502     (file-notify-valid-p . tramp-handle-file-notify-valid-p)
 503     (file-ownership-preserved-p . ignore)
 504     (file-readable-p . tramp-gvfs-handle-file-readable-p)
 505     (file-regular-p . tramp-handle-file-regular-p)
 506     (file-remote-p . tramp-handle-file-remote-p)
 507     (file-selinux-context . ignore)
 508     (file-symlink-p . tramp-handle-file-symlink-p)
 509     (file-system-info . tramp-gvfs-handle-file-system-info)
 510     (file-truename . tramp-handle-file-truename)
 511     (file-writable-p . tramp-gvfs-handle-file-writable-p)
 512     (find-backup-file-name . tramp-handle-find-backup-file-name)
 513     ;; `find-file-noselect' performed by default handler.
 514     ;; `get-file-buffer' performed by default handler.
 515     (insert-directory . tramp-handle-insert-directory)
 516     (insert-file-contents . tramp-handle-insert-file-contents)
 517     (load . tramp-handle-load)
 518     (make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
 519     (make-directory . tramp-gvfs-handle-make-directory)
 520     (make-directory-internal . ignore)
 521     (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
 522     (make-symbolic-link . tramp-handle-make-symbolic-link)
 523     (process-file . ignore)
 524     (rename-file . tramp-gvfs-handle-rename-file)
 525     (set-file-acl . ignore)
 526     (set-file-modes . ignore)
 527     (set-file-selinux-context . ignore)
 528     (set-file-times . ignore)
 529     (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
 530     (shell-command . ignore)
 531     (start-file-process . ignore)
 532     (substitute-in-file-name . tramp-handle-substitute-in-file-name)
 533     (temporary-file-directory . tramp-handle-temporary-file-directory)
 534     (unhandled-file-name-directory . ignore)
 535     (vc-registered . ignore)
 536     (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
 537     (write-region . tramp-gvfs-handle-write-region))
 538   "Alist of handler functions for Tramp GVFS method.
 539 Operations not mentioned here will be handled by the default Emacs primitives.")
 540
 541 ;; It must be a `defsubst' in order to push the whole code into
 542 ;; tramp-loaddefs.el.  Otherwise, there would be recursive autoloading.
 543 ;;;###tramp-autoload
 544 (defsubst tramp-gvfs-file-name-p (filename)
 545   "Check if it's a filename handled by the GVFS daemon."
 546   (and (tramp-tramp-file-p filename)
 547        (let ((method
 548               (tramp-file-name-method (tramp-dissect-file-name filename))))
 549          (and (stringp method) (member method tramp-gvfs-methods)))))
 550
 551 ;;;###tramp-autoload
 552 (defun tramp-gvfs-file-name-handler (operation &rest args)
 553   "Invoke the GVFS related OPERATION.
 554 First arg specifies the OPERATION, second arg is a list of arguments to
 555 pass to the OPERATION."
 556   (unless tramp-gvfs-enabled
 557     (tramp-compat-user-error nil "Package `tramp-gvfs' not supported"))
 558   (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist)))
 559     (if fn
 560         (save-match-data (apply (cdr fn) args))
 561       (tramp-run-real-handler operation args))))
 562
 563 ;;;###tramp-autoload
 564 (when (featurep 'dbusbind)
 565   (tramp-register-foreign-file-name-handler
 566    'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler))
 567
 568 \f
 569 ;; D-Bus helper function.
 570
 571 (defun tramp-gvfs-dbus-string-to-byte-array (string)
 572   "Like `dbus-string-to-byte-array' but add trailing \\0 if needed."
 573   (dbus-string-to-byte-array
 574    (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature)
 575        (concat string (string 0)) string)))
 576
 577 (defun tramp-gvfs-dbus-byte-array-to-string (byte-array)
 578   "Like `dbus-byte-array-to-string' but remove trailing \\0 if exists.
 579 Return nil for null BYTE-ARRAY."
 580   ;; The byte array could be a variant.  Take care.
 581   (let ((byte-array
 582          (if (and (consp byte-array) (atom (car byte-array)))
 583              byte-array (car byte-array))))
 584     (and byte-array
 585          (dbus-byte-array-to-string
 586           (if (and (consp byte-array) (zerop (car (last byte-array))))
 587               (butlast byte-array) byte-array)))))
 588
 589 (defun tramp-gvfs-stringify-dbus-message (message)
 590   "Convert a D-Bus message into readable UTF8 strings, used for traces."
 591   (cond
 592    ((and (consp message) (characterp (car message)))
 593     (format "%S" (tramp-gvfs-dbus-byte-array-to-string message)))
 594    ((consp message)
 595     (mapcar 'tramp-gvfs-stringify-dbus-message message))
 596    ((stringp message)
 597     (format "%S" message))
 598    (t message)))
 599
 600 (defmacro with-tramp-dbus-call-method
 601   (vec synchronous bus service path interface method &rest args)
 602   "Apply a D-Bus call on bus BUS.
 603
 604 If SYNCHRONOUS is non-nil, the call is synchronously.  Otherwise,
 605 it is an asynchronous call, with `ignore' as callback function.
 606
 607 The other arguments have the same meaning as with `dbus-call-method'
 608 or `dbus-call-method-asynchronously'.  Additionally, the call
 609 will be traced by Tramp with trace level 6."
 610   `(let ((func (if ,synchronous
 611                    'dbus-call-method 'dbus-call-method-asynchronously))
 612          (args (append (list ,bus ,service ,path ,interface ,method)
 613                        (if ,synchronous (list ,@args) (list 'ignore ,@args))))
 614          result)
 615      (tramp-message ,vec 6 "%s %s" func args)
 616      (setq result (apply func args))
 617      (tramp-message ,vec 6 "%s" (tramp-gvfs-stringify-dbus-message result))
 618      result))
 619
 620 (put 'with-tramp-dbus-call-method 'lisp-indent-function 2)
 621 (put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body))
 622 (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>"))
 623
 624 (defvar tramp-gvfs-dbus-event-vector nil
 625   "Current Tramp file name to be used, as vector.
 626 It is needed when D-Bus signals or errors arrive, because there
 627 is no information where to trace the message.")
 628
 629 (defun tramp-gvfs-dbus-event-error (event err)
 630   "Called when a D-Bus error message arrives, see `dbus-event-error-functions'."
 631   (when tramp-gvfs-dbus-event-vector
 632     (tramp-message tramp-gvfs-dbus-event-vector 10 "%S" event)
 633     (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err))))
 634
 635 ;; `dbus-event-error-hooks' has been renamed to
 636 ;; `dbus-event-error-functions' in Emacs 24.3.
 637 (add-hook
 638  (if (boundp 'dbus-event-error-functions)
 639      'dbus-event-error-functions 'dbus-event-error-hooks)
 640  'tramp-gvfs-dbus-event-error)
 641
 642 \f
 643 ;; File name primitives.
 644
 645 (defun tramp-gvfs-do-copy-or-rename-file
 646   (op filename newname &optional ok-if-already-exists keep-date
 647    preserve-uid-gid preserve-extended-attributes)
 648   "Copy or rename a remote file.
 649 OP must be `copy' or `rename' and indicates the operation to perform.
 650 FILENAME specifies the file to copy or rename, NEWNAME is the name of
 651 the new file (for copy) or the new name of the file (for rename).
 652 OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already.
 653 KEEP-DATE means to make sure that NEWNAME has the same timestamp
 654 as FILENAME.  PRESERVE-UID-GID, when non-nil, instructs to keep
 655 the uid and gid if both files are on the same host.
 656 PRESERVE-EXTENDED-ATTRIBUTES is ignored.
 657
 658 This function is invoked by `tramp-gvfs-handle-copy-file' and
 659 `tramp-gvfs-handle-rename-file'.  It is an error if OP is neither
 660 of `copy' and `rename'.  FILENAME and NEWNAME must be absolute
 661 file names."
 662   (unless (memq op '(copy rename))
 663     (error "Unknown operation `%s', must be `copy' or `rename'" op))
 664
 665     (let ((t1 (tramp-tramp-file-p filename))
 666           (t2 (tramp-tramp-file-p newname))
 667           (equal-remote (tramp-equal-remote filename newname))
 668           (file-operation (intern (format "%s-file" op)))
 669           (gvfs-operation (if (eq op 'copy) "gvfs-copy" "gvfs-move"))
 670           (msg-operation (if (eq op 'copy) "Copying" "Renaming")))
 671
 672       (with-parsed-tramp-file-name (if t1 filename newname) nil
 673         (when (and (not ok-if-already-exists) (file-exists-p newname))
 674           (tramp-error v 'file-already-exists newname))
 675
 676         (if (or (and equal-remote
 677                      (tramp-get-connection-property v "direct-copy-failed" nil))
 678                 (and t1 (not (tramp-gvfs-file-name-p filename)))
 679                 (and t2 (not (tramp-gvfs-file-name-p newname))))
 680
 681             ;; We cannot copy or rename directly.
 682             (let ((tmpfile (tramp-compat-make-temp-file filename)))
 683               (funcall
 684                file-operation filename tmpfile t keep-date preserve-uid-gid
 685                preserve-extended-attributes)
 686               (rename-file tmpfile newname ok-if-already-exists))
 687
 688           ;; Direct action.
 689           (with-tramp-progress-reporter
 690               v 0 (format "%s %s to %s" msg-operation filename newname)
 691             (unless
 692                 (apply
 693                  'tramp-gvfs-send-command v gvfs-operation
 694                  (append
 695                   (and (eq op 'copy) (or keep-date preserve-uid-gid)
 696                        '("--preserve"))
 697                   (list
 698                    (tramp-gvfs-url-file-name filename)
 699                    (tramp-gvfs-url-file-name newname))))
 700
 701               (if (or (not equal-remote)
 702                       (and equal-remote
 703                            (tramp-get-connection-property
 704                             v "direct-copy-failed" nil)))
 705                   ;; Propagate the error.
 706                   (with-current-buffer (tramp-get-connection-buffer v)
 707                     (goto-char (point-min))
 708                     (tramp-error-with-buffer
 709                      nil v 'file-error
 710                      "%s failed, see buffer `%s' for details."
 711                      msg-operation (buffer-name)))
 712
 713                 ;; Some WebDAV server, like the one from QNAP, do not
 714                 ;; support direct copy/move.  Try a fallback.
 715                 (tramp-set-connection-property v "direct-copy-failed" t)
 716                 (tramp-gvfs-do-copy-or-rename-file
 717                  op filename newname ok-if-already-exists keep-date
 718                  preserve-uid-gid preserve-extended-attributes))))
 719
 720           (when (and t1 (eq op 'rename))
 721             (with-parsed-tramp-file-name filename nil
 722               (tramp-flush-file-property v (file-name-directory localname))
 723               (tramp-flush-file-property v localname)))
 724
 725           (when t2
 726             (with-parsed-tramp-file-name newname nil
 727               (tramp-flush-file-property v (file-name-directory localname))
 728               (tramp-flush-file-property v localname)))))))
 729
 730 (defun tramp-gvfs-handle-copy-file
 731   (filename newname &optional ok-if-already-exists keep-date
 732    preserve-uid-gid preserve-extended-attributes)
 733   "Like `copy-file' for Tramp files."
 734   (setq filename (expand-file-name filename))
 735   (setq newname (expand-file-name newname))
 736   ;; At least one file a Tramp file?
 737   (if (or (tramp-tramp-file-p filename)
 738           (tramp-tramp-file-p newname))
 739       (tramp-gvfs-do-copy-or-rename-file
 740        'copy filename newname ok-if-already-exists keep-date
 741        preserve-uid-gid preserve-extended-attributes)
 742     (tramp-run-real-handler
 743      'copy-file
 744      (list filename newname ok-if-already-exists keep-date
 745            preserve-uid-gid preserve-extended-attributes))))
 746
 747 (defun tramp-gvfs-handle-delete-directory (directory &optional recursive trash)
 748   "Like `delete-directory' for Tramp files."
 749   (with-parsed-tramp-file-name directory nil
 750     (if (and recursive (not (file-symlink-p directory)))
 751         (mapc (lambda (file)
 752                 (if (eq t (tramp-compat-file-attribute-type
 753                            (file-attributes file)))
 754                     (delete-directory file recursive trash)
 755                   (delete-file file trash)))
 756               (directory-files
 757                directory 'full directory-files-no-dot-files-regexp))
 758       (when (directory-files directory nil directory-files-no-dot-files-regexp)
 759         (tramp-error
 760          v 'file-error "Couldn't delete non-empty %s" directory)))
 761
 762     (tramp-flush-file-property v (file-name-directory localname))
 763     (tramp-flush-directory-property v localname)
 764     (unless
 765         (tramp-gvfs-send-command
 766          v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm")
 767          (tramp-gvfs-url-file-name directory))
 768       ;; Propagate the error.
 769       (with-current-buffer (tramp-get-connection-buffer v)
 770         (goto-char (point-min))
 771         (tramp-error-with-buffer
 772          nil v 'file-error "Couldn't delete %s" directory)))))
 773
 774 (defun tramp-gvfs-handle-delete-file (filename &optional trash)
 775   "Like `delete-file' for Tramp files."
 776   (with-parsed-tramp-file-name filename nil
 777     (tramp-flush-file-property v (file-name-directory localname))
 778     (tramp-flush-file-property v localname)
 779     (unless
 780         (tramp-gvfs-send-command
 781          v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm")
 782          (tramp-gvfs-url-file-name filename))
 783       ;; Propagate the error.
 784       (with-current-buffer (tramp-get-connection-buffer v)
 785         (goto-char (point-min))
 786         (tramp-error-with-buffer
 787          nil v 'file-error "Couldn't delete %s" filename)))))
 788
 789 (defun tramp-gvfs-handle-expand-file-name (name &optional dir)
 790   "Like `expand-file-name' for Tramp files."
 791   ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
 792   (setq dir (or dir default-directory "/"))
 793   ;; Unless NAME is absolute, concat DIR and NAME.
 794   (unless (file-name-absolute-p name)
 795     (setq name (concat (file-name-as-directory dir) name)))
 796   ;; If NAME is not a Tramp file, run the real handler.
 797   (if (not (tramp-tramp-file-p name))
 798       (tramp-run-real-handler 'expand-file-name (list name nil))
 799     ;; Dissect NAME.
 800     (with-parsed-tramp-file-name name nil
 801       ;; If there is a default location, expand tilde.
 802       (when (string-match "\\`\\(~\\)\\(/\\|\\'\\)" localname)
 803         (save-match-data
 804           (tramp-gvfs-maybe-open-connection
 805            (make-tramp-file-name
 806             :method method :user user :domain domain
 807             :host host :port port :localname "/" :hop hop)))
 808         (setq localname
 809               (replace-match
 810                (tramp-get-connection-property v "default-location" "~")
 811                nil t localname 1)))
 812       ;; Tilde expansion is not possible.
 813       (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
 814         (tramp-error
 815          v 'file-error
 816          "Cannot expand tilde in file `%s'" name))
 817       (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
 818         (setq localname (concat "/" localname)))
 819       ;; We do not pass "/..".
 820       (if (string-match "^\\(afp\\|davs?\\|smb\\)$" method)
 821           (when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname)
 822             (setq localname (replace-match "/" t t localname 1)))
 823         (when (string-match "^/\\.\\./?" localname)
 824           (setq localname (replace-match "/" t t localname))))
 825       ;; There might be a double slash.  Remove this.
 826       (while (string-match "//" localname)
 827         (setq localname (replace-match "/" t t localname)))
 828       ;; No tilde characters in file name, do normal
 829       ;; `expand-file-name' (this does "/./" and "/../").
 830       (tramp-make-tramp-file-name
 831        method user domain host port
 832        (tramp-run-real-handler 'expand-file-name (list localname))))))
 833
 834 (defun tramp-gvfs-get-directory-attributes (directory)
 835   "Return GVFS attributes association list of all files in DIRECTORY."
 836   (ignore-errors
 837     ;; Don't modify `last-coding-system-used' by accident.
 838     (let ((last-coding-system-used last-coding-system-used)
 839           result)
 840       (with-parsed-tramp-file-name directory nil
 841         (with-tramp-file-property v localname "directory-attributes"
 842           (tramp-message v 5 "directory gvfs attributes: %s" localname)
 843           ;; Send command.
 844           (tramp-gvfs-send-command
 845            v "gvfs-ls" "-h" "-n" "-a"
 846            (mapconcat 'identity tramp-gvfs-file-attributes ",")
 847            (tramp-gvfs-url-file-name directory))
 848           ;; Parse output.
 849           (with-current-buffer (tramp-get-connection-buffer v)
 850             (goto-char (point-min))
 851             (while (looking-at
 852                     (concat "^\\(.+\\)[[:blank:]]"
 853                             "\\([[:digit:]]+\\)[[:blank:]]"
 854                             "(\\(.+?\\))"
 855                             tramp-gvfs-file-attributes-with-gvfs-ls-regexp))
 856               (let ((item (list (cons "type" (match-string 3))
 857                                 (cons "standard::size" (match-string 2))
 858                                 (cons "name" (match-string 1)))))
 859                 (goto-char (1+ (match-end 3)))
 860                 (while (looking-at
 861                         (concat
 862                          tramp-gvfs-file-attributes-with-gvfs-ls-regexp
 863                          "\\(" tramp-gvfs-file-attributes-with-gvfs-ls-regexp
 864                          "\\|" "$" "\\)"))
 865                   (push (cons (match-string 1) (match-string 2)) item)
 866                   (goto-char (match-end 2)))
 867                 ;; Add display name as head.
 868                 (push
 869                  (cons (cdr (or (assoc "standard::display-name" item)
 870                                 (assoc "name" item)))
 871                        (nreverse item))
 872                  result))
 873               (forward-line)))
 874           result)))))
 875
 876 (defun tramp-gvfs-get-root-attributes (filename &optional file-system)
 877   "Return GVFS attributes association list of FILENAME.
 878 If FILE-SYSTEM is non-nil, return file system attributes."
 879   (ignore-errors
 880     ;; Don't modify `last-coding-system-used' by accident.
 881     (let ((last-coding-system-used last-coding-system-used)
 882           result)
 883       (with-parsed-tramp-file-name filename nil
 884         (with-tramp-file-property
 885             v localname
 886             (if file-system "file-system-attributes" "file-attributes")
 887           (tramp-message
 888            v 5 "file%s gvfs attributes: %s"
 889            (if file-system " system" "") localname)
 890           ;; Send command.
 891           (if file-system
 892               (tramp-gvfs-send-command
 893                v "gvfs-info" "--filesystem" (tramp-gvfs-url-file-name filename))
 894             (tramp-gvfs-send-command
 895              v "gvfs-info" (tramp-gvfs-url-file-name filename)))
 896           ;; Parse output.
 897           (with-current-buffer (tramp-get-connection-buffer v)
 898             (goto-char (point-min))
 899             (while (re-search-forward
 900                     (if file-system
 901                         tramp-gvfs-file-system-attributes-regexp
 902                       tramp-gvfs-file-attributes-with-gvfs-info-regexp)
 903                     nil t)
 904               (push (cons (match-string 1) (match-string 2)) result))
 905             result))))))
 906
 907 (defun tramp-gvfs-get-file-attributes (filename)
 908   "Return GVFS attributes association list of FILENAME."
 909   (setq filename (directory-file-name (expand-file-name filename)))
 910   (with-parsed-tramp-file-name filename nil
 911     (setq localname (tramp-compat-file-name-unquote localname))
 912     (if (or (and (string-match "^\\(afp\\|davs?\\|smb\\)$" method)
 913                  (string-match "^/?\\([^/]+\\)$" localname))
 914             (string-equal localname "/"))
 915         (tramp-gvfs-get-root-attributes filename)
 916       (assoc
 917        (file-name-nondirectory filename)
 918        (tramp-gvfs-get-directory-attributes (file-name-directory filename))))))
 919
 920 (defun tramp-gvfs-handle-file-attributes (filename &optional id-format)
 921   "Like `file-attributes' for Tramp files."
 922   (unless id-format (setq id-format 'integer))
 923   (ignore-errors
 924     (let ((attributes (tramp-gvfs-get-file-attributes filename))
 925           dirp res-symlink-target res-numlinks res-uid res-gid res-access
 926           res-mod res-change res-size res-filemodes res-inode res-device)
 927       (when attributes
 928         ;; ... directory or symlink
 929         (setq dirp (if (equal "directory" (cdr (assoc "type" attributes))) t))
 930         (setq res-symlink-target
 931               (cdr (assoc "standard::symlink-target" attributes)))
 932         ;; ... number links
 933         (setq res-numlinks
 934               (string-to-number
 935                (or (cdr (assoc "unix::nlink" attributes)) "0")))
 936         ;; ... uid and gid
 937         (setq res-uid
 938               (if (eq id-format 'integer)
 939                   (string-to-number
 940                    (or (cdr (assoc "unix::uid" attributes))
 941                        (format "%s" tramp-unknown-id-integer)))
 942                 (or (cdr (assoc "owner::user" attributes))
 943                     (cdr (assoc "unix::uid" attributes))
 944                     tramp-unknown-id-string)))
 945         (setq res-gid
 946               (if (eq id-format 'integer)
 947                   (string-to-number
 948                    (or (cdr (assoc "unix::gid" attributes))
 949                        (format "%s" tramp-unknown-id-integer)))
 950                 (or (cdr (assoc "owner::group" attributes))
 951                     (cdr (assoc "unix::gid" attributes))
 952                     tramp-unknown-id-string)))
 953         ;; ... last access, modification and change time
 954         (setq res-access
 955               (seconds-to-time
 956                (string-to-number
 957                 (or (cdr (assoc "time::access" attributes)) "0"))))
 958         (setq res-mod
 959               (seconds-to-time
 960                (string-to-number
 961                 (or (cdr (assoc "time::modified" attributes)) "0"))))
 962         (setq res-change
 963               (seconds-to-time
 964                (string-to-number
 965                 (or (cdr (assoc "time::changed" attributes)) "0"))))
 966         ;; ... size
 967         (setq res-size
 968               (string-to-number
 969                (or (cdr (assoc "standard::size" attributes)) "0")))
 970         ;; ... file mode flags
 971         (setq res-filemodes
 972               (let ((n (cdr (assoc "unix::mode" attributes))))
 973                 (if n
 974                     (tramp-file-mode-from-int (string-to-number n))
 975                   (format
 976                    "%s%s%s%s------"
 977                    (if dirp "d" "-")
 978                    (if (equal (cdr (assoc "access::can-read" attributes))
 979                               "FALSE")
 980                        "-" "r")
 981                    (if (equal (cdr (assoc "access::can-write" attributes))
 982                               "FALSE")
 983                        "-" "w")
 984                    (if (equal (cdr (assoc "access::can-execute" attributes))
 985                               "FALSE")
 986                        "-" "x")))))
 987         ;; ... inode and device
 988         (setq res-inode
 989               (let ((n (cdr (assoc "unix::inode" attributes))))
 990                 (if n
 991                     (string-to-number n)
 992                   (tramp-get-inode (tramp-dissect-file-name filename)))))
 993         (setq res-device
 994               (let ((n (cdr (assoc "unix::device" attributes))))
 995                 (if n
 996                     (string-to-number n)
 997                   (tramp-get-device (tramp-dissect-file-name filename)))))
 998
 999         ;; Return data gathered.
1000         (list
1001          ;; 0. t for directory, string (name linked to) for
1002          ;; symbolic link, or nil.
1003          (or dirp res-symlink-target)
1004          ;; 1. Number of links to file.
1005          res-numlinks
1006          ;; 2. File uid.
1007          res-uid
1008          ;; 3. File gid.
1009          res-gid
1010          ;; 4. Last access time, as a list of integers.
1011          ;; 5. Last modification time, likewise.
1012          ;; 6. Last status change time, likewise.
1013          res-access res-mod res-change
1014          ;; 7. Size in bytes (-1, if number is out of range).
1015          res-size
1016          ;; 8. File modes.
1017          res-filemodes
1018          ;; 9. t if file's gid would change if file were deleted
1019          ;; and recreated.
1020          nil
1021          ;; 10. Inode number.
1022          res-inode
1023          ;; 11. Device number.
1024          res-device
1025          )))))
1026
1027 (defun tramp-gvfs-handle-file-directory-p (filename)
1028   "Like `file-directory-p' for Tramp files."
1029   (eq t (tramp-compat-file-attribute-type
1030          (file-attributes (file-truename filename)))))
1031
1032 (defun tramp-gvfs-handle-file-executable-p (filename)
1033   "Like `file-executable-p' for Tramp files."
1034   (with-parsed-tramp-file-name filename nil
1035     (with-tramp-file-property v localname "file-executable-p"
1036       (tramp-check-cached-permissions v ?x))))
1037
1038 (defun tramp-gvfs-handle-file-local-copy (filename)
1039   "Like `file-local-copy' for Tramp files."
1040   (with-parsed-tramp-file-name filename nil
1041     (let ((tmpfile (tramp-compat-make-temp-file filename)))
1042       (unless (file-exists-p filename)
1043         (tramp-error
1044          v tramp-file-missing
1045          "Cannot make local copy of non-existing file `%s'" filename))
1046       (copy-file filename tmpfile 'ok-if-already-exists 'keep-time)
1047       tmpfile)))
1048
1049 (defun tramp-gvfs-handle-file-name-all-completions (filename directory)
1050   "Like `file-name-all-completions' for Tramp files."
1051   (unless (save-match-data (string-match "/" filename))
1052     (all-completions
1053      filename
1054      (with-parsed-tramp-file-name (expand-file-name directory) nil
1055        (with-tramp-file-property v localname "file-name-all-completions"
1056          (let ((result '("./" "../")))
1057            ;; Get a list of directories and files.
1058            (dolist (item (tramp-gvfs-get-directory-attributes directory) result)
1059              (if (string-equal (cdr (assoc "type" item)) "directory")
1060                  (push (file-name-as-directory (car item)) result)
1061                (push (car item) result)))))))))
1062
1063 (defun tramp-gvfs-handle-file-notify-add-watch (file-name flags _callback)
1064   "Like `file-notify-add-watch' for Tramp files."
1065   (setq file-name (expand-file-name file-name))
1066   (with-parsed-tramp-file-name file-name nil
1067     ;; We cannot watch directories, because `gvfs-monitor-dir' is not
1068     ;; supported for gvfs-mounted directories.
1069     (when (file-directory-p file-name)
1070       (tramp-error
1071        v 'file-notify-error "Monitoring not supported for `%s'" file-name))
1072     (let* ((default-directory (file-name-directory file-name))
1073            (events
1074             (cond
1075              ((and (memq 'change flags) (memq 'attribute-change flags))
1076               '(created changed changes-done-hint moved deleted
1077                         attribute-changed))
1078              ((memq 'change flags)
1079               '(created changed changes-done-hint moved deleted))
1080              ((memq 'attribute-change flags) '(attribute-changed))))
1081            (p (start-process
1082                "gvfs-monitor-file" (generate-new-buffer " *gvfs-monitor-file*")
1083                "gvfs-monitor-file" (tramp-gvfs-url-file-name file-name))))
1084       (if (not (processp p))
1085           (tramp-error
1086            v 'file-notify-error "Monitoring not supported for `%s'" file-name)
1087         (tramp-message
1088          v 6 "Run `%s', %S" (mapconcat 'identity (process-command p) " ") p)
1089         (tramp-set-connection-property p "vector" v)
1090         (process-put p 'events events)
1091         (process-put p 'watch-name localname)
1092         (process-put p 'adjust-window-size-function 'ignore)
1093         (set-process-query-on-exit-flag p nil)
1094         (set-process-filter p 'tramp-gvfs-monitor-file-process-filter)
1095         ;; There might be an error if the monitor is not supported.
1096         ;; Give the filter a chance to read the output.
1097         (tramp-accept-process-output p 1)
1098         (unless (process-live-p p)
1099           (tramp-error
1100            v 'file-notify-error "Monitoring not supported for `%s'" file-name))
1101         p))))
1102
1103 (defun tramp-gvfs-monitor-file-process-filter (proc string)
1104   "Read output from \"gvfs-monitor-file\" and add corresponding \
1105 file-notify events."
1106   (let* ((rest-string (process-get proc 'rest-string))
1107          (dd (with-current-buffer (process-buffer proc) default-directory))
1108          (ddu (regexp-quote (tramp-gvfs-url-file-name dd))))
1109     (when rest-string
1110       (tramp-message proc 10 "Previous string:\n%s" rest-string))
1111     (tramp-message proc 6 "%S\n%s" proc string)
1112     (setq string (concat rest-string string)
1113           ;; Attribute change is returned in unused wording.
1114           string (replace-regexp-in-string
1115                   "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string))
1116     (when (string-match "Monitoring not supported" string)
1117       (delete-process proc))
1118
1119     (while (string-match
1120             (concat "^[\n\r]*"
1121                     "File Monitor Event:[\n\r]+"
1122                     "File = \\([^\n\r]+\\)[\n\r]+"
1123                     "Event = \\([^[:blank:]]+\\)[\n\r]+")
1124             string)
1125       (let ((file (match-string 1 string))
1126             (action (intern-soft
1127                      (replace-regexp-in-string
1128                       "_" "-" (downcase (match-string 2 string))))))
1129         (setq string (replace-match "" nil nil string))
1130         ;; File names are returned as URL paths.  We must convert them.
1131         (when (string-match ddu file)
1132           (setq file (replace-match dd nil nil file)))
1133         (while (string-match "%\\([0-9A-F]\\{2\\}\\)" file)
1134           (setq file
1135                 (replace-match
1136                  (char-to-string (string-to-number (match-string 1 file) 16))
1137                  nil nil file)))
1138         ;; Usually, we would add an Emacs event now.  Unfortunately,
1139         ;; `unread-command-events' does not accept several events at
1140         ;; once.  Therefore, we apply the callback directly.
1141         (tramp-compat-funcall 'file-notify-callback (list proc action file))))
1142
1143     ;; Save rest of the string.
1144     (when (zerop (length string)) (setq string nil))
1145     (when string (tramp-message proc 10 "Rest string:\n%s" string))
1146     (process-put proc 'rest-string string)))
1147
1148 (defun tramp-gvfs-handle-file-readable-p (filename)
1149   "Like `file-readable-p' for Tramp files."
1150   (with-parsed-tramp-file-name filename nil
1151     (with-tramp-file-property v localname "file-readable-p"
1152       (tramp-check-cached-permissions v ?r))))
1153
1154 (defun tramp-gvfs-handle-file-system-info (filename)
1155   "Like `file-system-info' for Tramp files."
1156   (setq filename (directory-file-name (expand-file-name filename)))
1157   (with-parsed-tramp-file-name filename nil
1158     ;; We don't use cached values.
1159     (tramp-set-file-property v localname "file-system-attributes" 'undef)
1160     (let* ((attr (tramp-gvfs-get-root-attributes filename 'file-system))
1161            (size (cdr (assoc "filesystem::size" attr)))
1162            (used (cdr (assoc "filesystem::used" attr)))
1163            (free (cdr (assoc "filesystem::free" attr))))
1164       (when (and (stringp size) (stringp used) (stringp free))
1165         (list (string-to-number (concat size "e0"))
1166               (- (string-to-number (concat size "e0"))
1167                  (string-to-number (concat used "e0")))
1168               (string-to-number (concat free "e0")))))))
1169
1170 (defun tramp-gvfs-handle-file-writable-p (filename)
1171   "Like `file-writable-p' for Tramp files."
1172   (with-parsed-tramp-file-name filename nil
1173     (with-tramp-file-property v localname "file-writable-p"
1174       (if (file-exists-p filename)
1175           (tramp-check-cached-permissions v ?w)
1176         ;; If file doesn't exist, check if directory is writable.
1177         (and (file-directory-p (file-name-directory filename))
1178              (file-writable-p (file-name-directory filename)))))))
1179
1180 (defun tramp-gvfs-handle-make-directory (dir &optional parents)
1181   "Like `make-directory' for Tramp files."
1182   (setq dir (directory-file-name (expand-file-name dir)))
1183   (with-parsed-tramp-file-name dir nil
1184     (tramp-flush-file-property v (file-name-directory localname))
1185     (tramp-flush-directory-property v localname)
1186     (save-match-data
1187       (let ((ldir (file-name-directory dir)))
1188         ;; Make missing directory parts.  "gvfs-mkdir -p ..." does not
1189         ;; work robust.
1190         (when (and parents (not (file-directory-p ldir)))
1191           (make-directory ldir parents))
1192         ;; Just do it.
1193         (unless (tramp-gvfs-send-command
1194                  v "gvfs-mkdir" (tramp-gvfs-url-file-name dir))
1195           (tramp-error v 'file-error "Couldn't make directory %s" dir))))))
1196
1197 (defun tramp-gvfs-handle-rename-file
1198   (filename newname &optional ok-if-already-exists)
1199   "Like `rename-file' for Tramp files."
1200   ;; Check if both files are local -- invoke normal rename-file.
1201   ;; Otherwise, use Tramp from local system.
1202   (setq filename (expand-file-name filename))
1203   (setq newname (expand-file-name newname))
1204   ;; At least one file a Tramp file?
1205   (if (or (tramp-tramp-file-p filename)
1206           (tramp-tramp-file-p newname))
1207       (tramp-gvfs-do-copy-or-rename-file
1208        'rename filename newname ok-if-already-exists
1209        'keep-date 'preserve-uid-gid)
1210     (tramp-run-real-handler
1211      'rename-file (list filename newname ok-if-already-exists))))
1212
1213 (defun tramp-gvfs-handle-write-region
1214   (start end filename &optional append visit lockname mustbenew)
1215   "Like `write-region' for Tramp files."
1216   (setq filename (expand-file-name filename))
1217   (with-parsed-tramp-file-name filename nil
1218     (when (and mustbenew (file-exists-p filename)
1219                (or (eq mustbenew 'excl)
1220                    (not
1221                     (y-or-n-p
1222                      (format "File %s exists; overwrite anyway? " filename)))))
1223       (tramp-error v 'file-already-exists filename))
1224
1225     (let ((tmpfile (tramp-compat-make-temp-file filename)))
1226       (when (and append (file-exists-p filename))
1227         (copy-file filename tmpfile 'ok))
1228       ;; We say `no-message' here because we don't want the visited file
1229       ;; modtime data to be clobbered from the temp file.  We call
1230       ;; `set-visited-file-modtime' ourselves later on.
1231       (tramp-run-real-handler
1232        'write-region (list start end tmpfile append 'no-message lockname))
1233       (condition-case nil
1234           (rename-file tmpfile filename 'ok-if-already-exists)
1235         (error
1236          (delete-file tmpfile)
1237          (tramp-error
1238           v 'file-error "Couldn't write region to `%s'" filename))))
1239
1240     (tramp-flush-file-property v (file-name-directory localname))
1241     (tramp-flush-file-property v localname)
1242
1243     ;; Set file modification time.
1244     (when (or (eq visit t) (stringp visit))
1245       (set-visited-file-modtime
1246        (tramp-compat-file-attribute-modification-time
1247         (file-attributes filename))))
1248
1249     ;; The end.
1250     (when (or (eq visit t) (null visit) (stringp visit))
1251       (tramp-message v 0 "Wrote %s" filename))
1252     (run-hooks 'tramp-handle-write-region-hook)))
1253
1254 \f
1255 ;; File name conversions.
1256
1257 (defun tramp-gvfs-url-file-name (filename)
1258   "Return FILENAME in URL syntax."
1259   ;; "/" must NOT be hexlified.
1260   (setq filename (tramp-compat-file-name-unquote filename))
1261   (let ((url-unreserved-chars (cons ?/ url-unreserved-chars))
1262         result)
1263     (setq
1264      result
1265      (url-recreate-url
1266       (if (tramp-tramp-file-p filename)
1267           (with-parsed-tramp-file-name filename nil
1268             (when (string-equal "gdrive" method)
1269               (setq method "google-drive"))
1270             (when (and user domain)
1271               (setq user (concat domain ";" user)))
1272             (url-parse-make-urlobj
1273              method (and user (url-hexify-string user)) nil host
1274              (if (stringp port) (string-to-number port) port)
1275              (and localname (url-hexify-string localname)) nil nil t))
1276         (url-parse-make-urlobj
1277          "file" nil nil nil nil
1278          (url-hexify-string (file-truename filename)) nil nil t))))
1279     (when (tramp-tramp-file-p filename)
1280       (with-parsed-tramp-file-name filename nil
1281         (tramp-message v 10 "remote file `%s' is URL `%s'" filename result)))
1282     result))
1283
1284 (defun tramp-gvfs-object-path (filename)
1285   "Create a D-Bus object path from FILENAME."
1286   (expand-file-name (dbus-escape-as-identifier filename) tramp-gvfs-path-tramp))
1287
1288 (defun tramp-gvfs-file-name (object-path)
1289   "Retrieve file name from D-Bus OBJECT-PATH."
1290   (dbus-unescape-from-identifier
1291    (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path)))
1292
1293 (defun tramp-bluez-address (device)
1294   "Return bluetooth device address from a given bluetooth DEVICE name."
1295   (when (stringp device)
1296     (if (string-match tramp-ipv6-regexp device)
1297         (match-string 0 device)
1298       (cadr (assoc device (tramp-bluez-list-devices))))))
1299
1300 (defun tramp-bluez-device (address)
1301   "Return bluetooth device name from a given bluetooth device ADDRESS.
1302 ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1303   (when (stringp address)
1304     (while (string-match "[][]" address)
1305       (setq address (replace-match "" t t address)))
1306     (let (result)
1307       (dolist (item (tramp-bluez-list-devices) result)
1308         (when (string-match address (cadr item))
1309           (setq result (car item)))))))
1310
1311 \f
1312 ;; D-Bus GVFS functions.
1313
1314 (defun tramp-gvfs-handler-askpassword (message user domain flags)
1315   "Implementation for the \"org.gtk.vfs.MountOperation.askPassword\" method."
1316   (let* ((filename
1317           (tramp-gvfs-file-name (dbus-event-path-name last-input-event)))
1318          (pw-prompt
1319           (format
1320            "%s for %s "
1321            (if (string-match "\\([pP]assword\\|[pP]assphrase\\)" message)
1322                (capitalize (match-string 1 message))
1323              "Password")
1324            filename))
1325          password)
1326
1327     (condition-case nil
1328         (with-parsed-tramp-file-name filename l
1329           (when (and (zerop (length user))
1330                      (not
1331                       (zerop (logand flags tramp-gvfs-password-need-username))))
1332             (setq user (read-string "User name: ")))
1333           (when (and (zerop (length domain))
1334                      (not
1335                       (zerop (logand flags tramp-gvfs-password-need-domain))))
1336             (setq domain (read-string "Domain name: ")))
1337
1338           (tramp-message l 6 "%S %S %S %d" message user domain flags)
1339           (unless (tramp-get-connection-property l "first-password-request" nil)
1340             (tramp-clear-passwd l))
1341
1342           ;; Set variables for computing the prompt for reading password.
1343           (setq tramp-current-method l-method
1344                 tramp-current-user user
1345                 tramp-current-domain l-domain
1346                 tramp-current-host l-host
1347                 tramp-current-port l-port
1348                 password (tramp-read-passwd
1349                           (tramp-get-connection-process l) pw-prompt))
1350
1351           ;; Return result.
1352           (if (stringp password)
1353               (list
1354                t ;; password handled.
1355                nil ;; no abort of D-Bus.
1356                password
1357                (tramp-file-name-user l)
1358                domain
1359                nil ;; not anonymous.
1360                0) ;; no password save.
1361             ;; No password provided.
1362             (list nil t "" (tramp-file-name-user l) domain nil 0)))
1363
1364       ;; When QUIT is raised, we shall return this information to D-Bus.
1365       (quit (list nil t "" "" "" nil 0)))))
1366
1367 (defun tramp-gvfs-handler-askquestion (message choices)
1368   "Implementation for the \"org.gtk.vfs.MountOperation.askQuestion\" method."
1369   (save-window-excursion
1370     (let ((enable-recursive-minibuffers t)
1371           (use-dialog-box (and use-dialog-box (null noninteractive)))
1372           result)
1373
1374       (with-parsed-tramp-file-name
1375           (tramp-gvfs-file-name (dbus-event-path-name last-input-event)) nil
1376         (tramp-message v 6 "%S %S" message choices)
1377
1378         (setq result
1379               (condition-case nil
1380                   (list
1381                    t ;; handled.
1382                    nil ;; no abort of D-Bus.
1383                    (with-tramp-connection-property
1384                        (tramp-get-connection-process v) message
1385                      ;; In theory, there can be several choices.
1386                      ;; Until now, there is only the question whether
1387                      ;; to accept an unknown host signature.
1388                      (with-temp-buffer
1389                        ;; Preserve message for `progress-reporter'.
1390                        (with-temp-message ""
1391                          (insert message)
1392                          (goto-char (point-max))
1393                          (if noninteractive
1394                              (message "%s" message)
1395                            (pop-to-buffer (current-buffer)))
1396                          (if (yes-or-no-p
1397                               (concat
1398                                (buffer-substring
1399                                 (line-beginning-position) (point))
1400                                " "))
1401                              0 1)))))
1402
1403                 ;; When QUIT is raised, we shall return this
1404                 ;; information to D-Bus.
1405                 (quit (list nil t 1))))
1406
1407         (tramp-message v 6 "%s" result)
1408
1409         ;; When the choice is "no", we set a dummy fuse-mountpoint in
1410         ;; order to leave the timeout.
1411         (unless (zerop (cl-caddr result))
1412           (tramp-set-file-property v "/" "fuse-mountpoint" "/"))
1413
1414         result))))
1415
1416 (defun tramp-gvfs-handler-mounted-unmounted (mount-info)
1417   "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and
1418 \"org.gtk.vfs.MountTracker.unmounted\" signals."
1419   (ignore-errors
1420     (let ((signal-name (dbus-event-member-name last-input-event))
1421           (elt mount-info))
1422       ;; Jump over the first elements of the mount info. Since there
1423       ;; were changes in the entries, we cannot access dedicated
1424       ;; elements.
1425       (while (stringp (car elt)) (setq elt (cdr elt)))
1426       (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt)))
1427              (mount-spec (cl-caddr elt))
1428              (default-location (tramp-gvfs-dbus-byte-array-to-string
1429                                 (cl-cadddr elt)))
1430              (method (tramp-gvfs-dbus-byte-array-to-string
1431                       (cadr (assoc "type" (cadr mount-spec)))))
1432              (user (tramp-gvfs-dbus-byte-array-to-string
1433                     (cadr (assoc "user" (cadr mount-spec)))))
1434              (domain (tramp-gvfs-dbus-byte-array-to-string
1435                       (cadr (assoc "domain" (cadr mount-spec)))))
1436              (host (tramp-gvfs-dbus-byte-array-to-string
1437                     (cadr (or (assoc "host" (cadr mount-spec))
1438                               (assoc "server" (cadr mount-spec))))))
1439              (port (tramp-gvfs-dbus-byte-array-to-string
1440                     (cadr (assoc "port" (cadr mount-spec)))))
1441              (ssl (tramp-gvfs-dbus-byte-array-to-string
1442                    (cadr (assoc "ssl" (cadr mount-spec)))))
1443              (prefix (concat
1444                       (tramp-gvfs-dbus-byte-array-to-string
1445                        (car mount-spec))
1446                       (tramp-gvfs-dbus-byte-array-to-string
1447                        (or (cadr (assoc "share" (cadr mount-spec)))
1448                            (cadr (assoc "volume" (cadr mount-spec))))))))
1449         (when (string-match "^\\(afp\\|smb\\)" method)
1450           (setq method (match-string 1 method)))
1451         (when (string-equal "obex" method)
1452           (setq host (tramp-bluez-device host)))
1453         (when (and (string-equal "dav" method) (string-equal "true" ssl))
1454           (setq method "davs"))
1455         (when (string-equal "google-drive" method)
1456           (setq method "gdrive"))
1457         (with-parsed-tramp-file-name
1458             (tramp-make-tramp-file-name method user domain host port "") nil
1459           (tramp-message
1460            v 6 "%s %s"
1461            signal-name (tramp-gvfs-stringify-dbus-message mount-info))
1462           (tramp-set-file-property v "/" "list-mounts" 'undef)
1463           (if (string-equal (downcase signal-name) "unmounted")
1464               (tramp-flush-file-property v "/")
1465             ;; Set prefix, mountpoint and location.
1466             (unless (string-equal prefix "/")
1467               (tramp-set-file-property v "/" "prefix" prefix))
1468             (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint)
1469             (tramp-set-connection-property
1470              v "default-location" default-location)))))))
1471
1472 (when tramp-gvfs-enabled
1473   (dbus-register-signal
1474    :session nil tramp-gvfs-path-mounttracker
1475    tramp-gvfs-interface-mounttracker "mounted"
1476    'tramp-gvfs-handler-mounted-unmounted)
1477   (dbus-register-signal
1478    :session nil tramp-gvfs-path-mounttracker
1479    tramp-gvfs-interface-mounttracker "Mounted"
1480    'tramp-gvfs-handler-mounted-unmounted)
1481
1482   (dbus-register-signal
1483    :session nil tramp-gvfs-path-mounttracker
1484    tramp-gvfs-interface-mounttracker "unmounted"
1485    'tramp-gvfs-handler-mounted-unmounted)
1486   (dbus-register-signal
1487    :session nil tramp-gvfs-path-mounttracker
1488    tramp-gvfs-interface-mounttracker "Unmounted"
1489    'tramp-gvfs-handler-mounted-unmounted))
1490
1491 (defun tramp-gvfs-connection-mounted-p (vec)
1492   "Check, whether the location is already mounted."
1493   (or
1494    (tramp-get-file-property vec "/" "fuse-mountpoint" nil)
1495    (catch 'mounted
1496      (dolist
1497          (elt
1498           (with-tramp-file-property vec "/" "list-mounts"
1499             (with-tramp-dbus-call-method vec t
1500               :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1501               tramp-gvfs-interface-mounttracker tramp-gvfs-listmounts))
1502           nil)
1503        ;; Jump over the first elements of the mount info. Since there
1504        ;; were changes in the entries, we cannot access dedicated
1505        ;; elements.
1506        (while (stringp (car elt)) (setq elt (cdr elt)))
1507        (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string
1508                                 (cadr elt)))
1509               (mount-spec (cl-caddr elt))
1510               (default-location (tramp-gvfs-dbus-byte-array-to-string
1511                                  (cl-cadddr elt)))
1512               (method (tramp-gvfs-dbus-byte-array-to-string
1513                        (cadr (assoc "type" (cadr mount-spec)))))
1514               (user (tramp-gvfs-dbus-byte-array-to-string
1515                      (cadr (assoc "user" (cadr mount-spec)))))
1516               (domain (tramp-gvfs-dbus-byte-array-to-string
1517                        (cadr (assoc "domain" (cadr mount-spec)))))
1518               (host (tramp-gvfs-dbus-byte-array-to-string
1519                      (cadr (or (assoc "host" (cadr mount-spec))
1520                                (assoc "server" (cadr mount-spec))))))
1521               (port (tramp-gvfs-dbus-byte-array-to-string
1522                      (cadr (assoc "port" (cadr mount-spec)))))
1523               (ssl (tramp-gvfs-dbus-byte-array-to-string
1524                     (cadr (assoc "ssl" (cadr mount-spec)))))
1525               (prefix (concat
1526                        (tramp-gvfs-dbus-byte-array-to-string
1527                         (car mount-spec))
1528                        (tramp-gvfs-dbus-byte-array-to-string
1529                         (or
1530                          (cadr (assoc "share" (cadr mount-spec)))
1531                          (cadr (assoc "volume" (cadr mount-spec))))))))
1532          (when (string-match "^\\(afp\\|smb\\)" method)
1533            (setq method (match-string 1 method)))
1534          (when (string-equal "obex" method)
1535            (setq host (tramp-bluez-device host)))
1536          (when (and (string-equal "dav" method) (string-equal "true" ssl))
1537            (setq method "davs"))
1538          (when (string-equal "google-drive" method)
1539            (setq method "gdrive"))
1540          (when (and (string-equal "synce" method) (zerop (length user)))
1541            (setq user (or (tramp-file-name-user vec) "")))
1542          (when (and
1543                 (string-equal method (tramp-file-name-method vec))
1544                 (string-equal user (tramp-file-name-user vec))
1545                 (string-equal domain (tramp-file-name-domain vec))
1546                 (string-equal host (tramp-file-name-host vec))
1547                 (string-equal port (tramp-file-name-port vec))
1548                 (string-match (concat "^" (regexp-quote prefix))
1549                               (tramp-file-name-unquote-localname vec)))
1550            ;; Set prefix, mountpoint and location.
1551            (unless (string-equal prefix "/")
1552              (tramp-set-file-property vec "/" "prefix" prefix))
1553            (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint)
1554            (tramp-set-connection-property
1555             vec "default-location" default-location)
1556            (throw 'mounted t)))))))
1557
1558 (defun tramp-gvfs-mount-spec-entry (key value)
1559   "Construct a mount-spec entry to be used in a mount_spec.
1560 It was \"a(say)\", but has changed to \"a{sv})\"."
1561   (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature)
1562       (list :dict-entry key
1563             (list :variant (tramp-gvfs-dbus-string-to-byte-array value)))
1564     (list :struct key (tramp-gvfs-dbus-string-to-byte-array value))))
1565
1566 (defun tramp-gvfs-mount-spec (vec)
1567   "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"."
1568   (let* ((method (tramp-file-name-method vec))
1569          (user (tramp-file-name-user vec))
1570          (domain (tramp-file-name-domain vec))
1571          (host (tramp-file-name-host vec))
1572          (port (tramp-file-name-port vec))
1573          (localname (tramp-file-name-unquote-localname vec))
1574          (share (when (string-match "^/?\\([^/]+\\)" localname)
1575                   (match-string 1 localname)))
1576          (ssl (if (string-match "^davs" method) "true" "false"))
1577          (mount-spec
1578           `(:array
1579             ,@(cond
1580                ((string-equal "smb" method)
1581                 (list (tramp-gvfs-mount-spec-entry "type" "smb-share")
1582                       (tramp-gvfs-mount-spec-entry "server" host)
1583                       (tramp-gvfs-mount-spec-entry "share" share)))
1584                ((string-equal "obex" method)
1585                 (list (tramp-gvfs-mount-spec-entry "type" method)
1586                       (tramp-gvfs-mount-spec-entry
1587                        "host" (concat "[" (tramp-bluez-address host) "]"))))
1588                ((string-match "\\`dav" method)
1589                 (list (tramp-gvfs-mount-spec-entry "type" "dav")
1590                       (tramp-gvfs-mount-spec-entry "host" host)
1591                       (tramp-gvfs-mount-spec-entry "ssl" ssl)))
1592                ((string-equal "afp" method)
1593                 (list (tramp-gvfs-mount-spec-entry "type" "afp-volume")
1594                       (tramp-gvfs-mount-spec-entry "host" host)
1595                       (tramp-gvfs-mount-spec-entry "volume" share)))
1596                ((string-equal "gdrive" method)
1597                 (list (tramp-gvfs-mount-spec-entry "type" "google-drive")
1598                       (tramp-gvfs-mount-spec-entry "host" host)))
1599                (t
1600                 (list (tramp-gvfs-mount-spec-entry "type" method)
1601                       (tramp-gvfs-mount-spec-entry "host" host))))
1602             ,@(when user
1603                 (list (tramp-gvfs-mount-spec-entry "user" user)))
1604             ,@(when domain
1605                 (list (tramp-gvfs-mount-spec-entry "domain" domain)))
1606             ,@(when port
1607                 (list (tramp-gvfs-mount-spec-entry "port" port)))))
1608          (mount-pref
1609           (if (and (string-match "\\`dav" method)
1610                    (string-match "^/?[^/]+" localname))
1611               (match-string 0 localname)
1612             "/")))
1613
1614     ;; Return.
1615     `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec)))
1616
1617 \f
1618 ;; Connection functions.
1619
1620 (defun tramp-gvfs-get-remote-uid (vec id-format)
1621   "The uid of the remote connection VEC, in ID-FORMAT.
1622 ID-FORMAT valid values are `string' and `integer'."
1623   (with-tramp-connection-property vec (format "uid-%s" id-format)
1624     (let ((method (tramp-file-name-method vec))
1625           (user (tramp-file-name-user vec))
1626           (domain (tramp-file-name-domain vec))
1627           (host (tramp-file-name-host vec))
1628           (port (tramp-file-name-port vec))
1629           (localname
1630            (tramp-get-connection-property vec "default-location" nil)))
1631       (cond
1632        ((and user (equal id-format 'string)) user)
1633        (localname
1634         (tramp-compat-file-attribute-user-id
1635          (file-attributes
1636           (tramp-make-tramp-file-name method user domain host port localname)
1637           id-format)))
1638        ((equal id-format 'integer) tramp-unknown-id-integer)
1639        ((equal id-format 'string) tramp-unknown-id-string)))))
1640
1641 (defun tramp-gvfs-get-remote-gid (vec id-format)
1642   "The gid of the remote connection VEC, in ID-FORMAT.
1643 ID-FORMAT valid values are `string' and `integer'."
1644   (with-tramp-connection-property vec (format "gid-%s" id-format)
1645     (let ((method (tramp-file-name-method vec))
1646           (user (tramp-file-name-user vec))
1647           (domain (tramp-file-name-domain vec))
1648           (host (tramp-file-name-host vec))
1649           (port (tramp-file-name-port vec))
1650           (localname
1651            (tramp-get-connection-property vec "default-location" nil)))
1652       (cond
1653        (localname
1654         (tramp-compat-file-attribute-group-id
1655          (file-attributes
1656           (tramp-make-tramp-file-name method user domain host port localname)
1657           id-format)))
1658        ((equal id-format 'integer) tramp-unknown-id-integer)
1659        ((equal id-format 'string) tramp-unknown-id-string)))))
1660
1661 (defvar tramp-gvfs-get-remote-uid-gid-in-progress nil
1662   "Indication, that remote uid and gid determination is in progress.")
1663
1664 (defun tramp-gvfs-maybe-open-connection (vec)
1665   "Maybe open a connection VEC.
1666 Does not do anything if a connection is already open, but re-opens the
1667 connection if a previous connection has died for some reason."
1668   ;; We set the file name, in case there are incoming D-Bus signals or
1669   ;; D-Bus errors.
1670   (setq tramp-gvfs-dbus-event-vector vec)
1671
1672   ;; For password handling, we need a process bound to the connection
1673   ;; buffer.  Therefore, we create a dummy process.  Maybe there is a
1674   ;; better solution?
1675   (unless (get-buffer-process (tramp-get-connection-buffer vec))
1676     (let ((p (make-network-process
1677               :name (tramp-buffer-name vec)
1678               :buffer (tramp-get-connection-buffer vec)
1679               :server t :host 'local :service t :noquery t)))
1680       (set-process-query-on-exit-flag p nil)))
1681
1682   (unless (tramp-gvfs-connection-mounted-p vec)
1683     (let* ((method (tramp-file-name-method vec))
1684            (user (tramp-file-name-user vec))
1685            (domain (tramp-file-name-domain vec))
1686            (host (tramp-file-name-host vec))
1687            (port (tramp-file-name-port vec))
1688            (localname (tramp-file-name-unquote-localname vec))
1689            (object-path
1690             (tramp-gvfs-object-path
1691              (tramp-make-tramp-file-name method user domain host port ""))))
1692
1693       (when (and (string-equal method "afp")
1694                  (string-equal localname "/"))
1695         (tramp-error vec 'file-error "Filename must contain an AFP volume"))
1696
1697       (when (and (string-match method "davs?")
1698                  (string-equal localname "/"))
1699         (tramp-error vec 'file-error "Filename must contain a WebDAV share"))
1700
1701       (when (and (string-equal method "smb")
1702                  (string-equal localname "/"))
1703         (tramp-error vec 'file-error "Filename must contain a Windows share"))
1704
1705       (with-tramp-progress-reporter
1706           vec 3
1707           (if (zerop (length user))
1708               (format "Opening connection for %s using %s" host method)
1709             (format "Opening connection for %s@%s using %s" user host method))
1710
1711         ;; Enable `auth-source'.
1712         (tramp-set-connection-property
1713          vec "first-password-request" tramp-cache-read-persistent-data)
1714
1715         ;; There will be a callback of "askPassword" when a password is needed.
1716         (dbus-register-method
1717          :session dbus-service-emacs object-path
1718          tramp-gvfs-interface-mountoperation "askPassword"
1719          'tramp-gvfs-handler-askpassword)
1720         (dbus-register-method
1721          :session dbus-service-emacs object-path
1722          tramp-gvfs-interface-mountoperation "AskPassword"
1723          'tramp-gvfs-handler-askpassword)
1724
1725         ;; There could be a callback of "askQuestion" when adding fingerprint.
1726         (dbus-register-method
1727          :session dbus-service-emacs object-path
1728          tramp-gvfs-interface-mountoperation "askQuestion"
1729          'tramp-gvfs-handler-askquestion)
1730         (dbus-register-method
1731          :session dbus-service-emacs object-path
1732          tramp-gvfs-interface-mountoperation "AskQuestion"
1733          'tramp-gvfs-handler-askquestion)
1734
1735         ;; The call must be asynchronously, because of the "askPassword"
1736         ;; or "askQuestion" callbacks.
1737         (if (string-match "(so)$" tramp-gvfs-mountlocation-signature)
1738             (with-tramp-dbus-call-method vec nil
1739               :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1740               tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1741               (tramp-gvfs-mount-spec vec)
1742               `(:struct :string ,(dbus-get-unique-name :session)
1743                         :object-path ,object-path))
1744           (with-tramp-dbus-call-method vec nil
1745             :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1746             tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1747             (tramp-gvfs-mount-spec vec)
1748             :string (dbus-get-unique-name :session) :object-path object-path))
1749
1750         ;; We must wait, until the mount is applied.  This will be
1751         ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint"
1752         ;; file property.
1753         (with-timeout
1754             ((or (tramp-get-method-parameter vec 'tramp-connection-timeout)
1755                  tramp-connection-timeout)
1756              (if (zerop (length (tramp-file-name-user vec)))
1757                  (tramp-error
1758                   vec 'file-error
1759                   "Timeout reached mounting %s using %s" host method)
1760                (tramp-error
1761                 vec 'file-error
1762                 "Timeout reached mounting %s@%s using %s" user host method)))
1763           (while (not (tramp-get-file-property vec "/" "fuse-mountpoint" nil))
1764             (read-event nil nil 0.1)))
1765
1766         ;; If `tramp-gvfs-handler-askquestion' has returned "No", it
1767         ;; is marked with the fuse-mountpoint "/".  We shall react.
1768         (when (string-equal
1769                (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/")
1770           (tramp-error vec 'file-error "FUSE mount denied"))
1771
1772         ;; Set connection-local variables.
1773         (tramp-set-connection-local-variables vec)
1774
1775         ;; Mark it as connected.
1776         (tramp-set-connection-property
1777          (tramp-get-connection-process vec) "connected" t))))
1778
1779   ;; In `tramp-check-cached-permissions', the connection properties
1780   ;; {uig,gid}-{integer,string} are used.  We set them to proper values.
1781   (unless tramp-gvfs-get-remote-uid-gid-in-progress
1782     (let ((tramp-gvfs-get-remote-uid-gid-in-progress t))
1783       (tramp-gvfs-get-remote-uid vec 'integer)
1784       (tramp-gvfs-get-remote-gid vec 'integer)
1785       (tramp-gvfs-get-remote-uid vec 'string)
1786       (tramp-gvfs-get-remote-gid vec 'string))))
1787
1788 (defun tramp-gvfs-send-command (vec command &rest args)
1789   "Send the COMMAND with its ARGS to connection VEC.
1790 COMMAND is usually a command from the gvfs-* utilities.
1791 `call-process' is applied, and it returns t if the return code is zero."
1792   (let* ((locale (tramp-get-local-locale vec))
1793          (process-environment
1794           (append
1795            `(,(format "LANG=%s" locale)
1796              ,(format "LANGUAGE=%s" locale)
1797              ,(format "LC_ALL=%s" locale))
1798            process-environment)))
1799     (with-current-buffer (tramp-get-connection-buffer vec)
1800       (tramp-gvfs-maybe-open-connection vec)
1801       (erase-buffer)
1802       (or (zerop (apply 'tramp-call-process vec command nil t nil args))
1803           ;; Remove information about mounted connection.
1804           (and (tramp-flush-file-property vec "/") nil)))))
1805
1806 \f
1807 ;; D-Bus BLUEZ functions.
1808
1809 (defun tramp-bluez-list-devices ()
1810   "Return all discovered bluetooth devices as list.
1811 Every entry is a list (NAME ADDRESS).
1812
1813 If `tramp-bluez-discover-devices-timeout' is an integer, and the last
1814 discovery happened more time before indicated there, a rescan will be
1815 started, which lasts some ten seconds.  Otherwise, cached results will
1816 be used."
1817   ;; Reset the scanned devices list if time has passed.
1818   (and (integerp tramp-bluez-discover-devices-timeout)
1819        (integerp tramp-bluez-discovery)
1820        (> (tramp-time-diff (current-time) tramp-bluez-discovery)
1821           tramp-bluez-discover-devices-timeout)
1822        (setq tramp-bluez-devices nil))
1823
1824   ;; Rescan if needed.
1825   (unless tramp-bluez-devices
1826     (let ((object-path
1827            (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1828              :system tramp-bluez-service "/"
1829              tramp-bluez-interface-manager "DefaultAdapter")))
1830       (setq tramp-bluez-devices nil
1831             tramp-bluez-discovery t)
1832       (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil
1833         :system tramp-bluez-service object-path
1834         tramp-bluez-interface-adapter "StartDiscovery")
1835       (while tramp-bluez-discovery
1836         (read-event nil nil 0.1))))
1837   (setq tramp-bluez-discovery (current-time))
1838   (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-bluez-devices)
1839   tramp-bluez-devices)
1840
1841 (defun tramp-bluez-property-changed (property value)
1842   "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal."
1843   (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" property value)
1844   (cond
1845    ((string-equal property "Discovering")
1846     (unless (car value)
1847       ;; "Discovering" FALSE means discovery run has been completed.
1848       ;; We stop it, because we don't need another run.
1849       (setq tramp-bluez-discovery nil)
1850       (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1851         :system tramp-bluez-service (dbus-event-path-name last-input-event)
1852         tramp-bluez-interface-adapter "StopDiscovery")))))
1853
1854 (when tramp-gvfs-enabled
1855   (dbus-register-signal
1856    :system nil nil tramp-bluez-interface-adapter "PropertyChanged"
1857    'tramp-bluez-property-changed))
1858
1859 (defun tramp-bluez-device-found (device args)
1860   "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal."
1861   (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" device args)
1862   (let ((alias (car (cadr (assoc "Alias" args))))
1863         (address (car (cadr (assoc "Address" args)))))
1864     ;; Maybe we shall check the device class for being a proper
1865     ;; device, and call also SDP in order to find the obex service.
1866     (add-to-list 'tramp-bluez-devices (list alias address))))
1867
1868 (when tramp-gvfs-enabled
1869   (dbus-register-signal
1870    :system nil nil tramp-bluez-interface-adapter "DeviceFound"
1871    'tramp-bluez-device-found))
1872
1873 (defun tramp-bluez-parse-device-names (_ignore)
1874   "Return a list of (nil host) tuples allowed to access."
1875   (mapcar
1876    (lambda (x) (list nil (car x)))
1877    (tramp-bluez-list-devices)))
1878
1879 ;; Add completion function for OBEX method.
1880 (when (and tramp-gvfs-enabled
1881            (member tramp-bluez-service (dbus-list-known-names :system)))
1882   (tramp-set-completion-function
1883    "obex" '((tramp-bluez-parse-device-names ""))))
1884
1885 \f
1886 ;; D-Bus zeroconf functions.
1887
1888 (defun tramp-zeroconf-parse-device-names (service)
1889   "Return a list of (user host) tuples allowed to access."
1890   (mapcar
1891    (lambda (x)
1892      (let ((host (zeroconf-service-host x))
1893            (port (zeroconf-service-port x))
1894            (text (zeroconf-service-txt x))
1895            user)
1896        (when port
1897          (setq host (format "%s%s%d" host tramp-prefix-port-regexp port)))
1898        ;; A user is marked in a TXT field like "u=guest".
1899        (while text
1900          (when (string-match "u=\\(.+\\)$" (car text))
1901            (setq user (match-string 1 (car text))))
1902          (setq text (cdr text)))
1903        (list user host)))
1904    (zeroconf-list-services service)))
1905
1906 ;; We use the TRIM argument of `split-string', which exist since Emacs
1907 ;; 24.4.  I mask this for older Emacs versions, there is no harm.
1908 (defun tramp-gvfs-parse-device-names (service)
1909   "Return a list of (user host) tuples allowed to access.
1910 This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi."
1911   (let ((result
1912          (ignore-errors
1913            (tramp-compat-funcall
1914             'split-string
1915             (shell-command-to-string (format "avahi-browse -trkp %s" service))
1916             "[\n\r]+" 'omit "^\\+;.*$"))))
1917     (delete-dups
1918      (mapcar
1919       (lambda (x)
1920         (let* ((list (split-string x ";"))
1921                (host (nth 6 list))
1922                (text (tramp-compat-funcall
1923                       'split-string (nth 9 list) "\" \"" 'omit "\""))
1924                user)
1925           ;; A user is marked in a TXT field like "u=guest".
1926           (while text
1927             (when (string-match "u=\\(.+\\)$" (car text))
1928               (setq user (match-string 1 (car text))))
1929             (setq text (cdr text)))
1930           (list user host)))
1931       result))))
1932
1933 ;; Add completion functions for AFP, DAV, DAVS, SFTP and SMB methods.
1934 (when tramp-gvfs-enabled
1935   ;; Suppress D-Bus error messages.
1936   (let (tramp-gvfs-dbus-event-vector)
1937     (zeroconf-init tramp-gvfs-zeroconf-domain)
1938     (if (zeroconf-list-service-types)
1939         (progn
1940           (tramp-set-completion-function
1941            "afp" '((tramp-zeroconf-parse-device-names "_afpovertcp._tcp")))
1942           (tramp-set-completion-function
1943            "dav" '((tramp-zeroconf-parse-device-names "_webdav._tcp")))
1944           (tramp-set-completion-function
1945            "davs" '((tramp-zeroconf-parse-device-names "_webdav._tcp")))
1946           (tramp-set-completion-function
1947            "sftp" '((tramp-zeroconf-parse-device-names "_ssh._tcp")
1948                     (tramp-zeroconf-parse-device-names "_workstation._tcp")))
1949           (when (member "smb" tramp-gvfs-methods)
1950             (tramp-set-completion-function
1951              "smb" '((tramp-zeroconf-parse-device-names "_smb._tcp")))))
1952
1953       (when (executable-find "avahi-browse")
1954         (tramp-set-completion-function
1955          "afp" '((tramp-gvfs-parse-device-names "_afpovertcp._tcp")))
1956         (tramp-set-completion-function
1957          "dav" '((tramp-gvfs-parse-device-names "_webdav._tcp")))
1958         (tramp-set-completion-function
1959          "davs" '((tramp-gvfs-parse-device-names "_webdav._tcp")))
1960         (tramp-set-completion-function
1961          "sftp" '((tramp-gvfs-parse-device-names "_ssh._tcp")
1962                   (tramp-gvfs-parse-device-names "_workstation._tcp")))
1963         (when (member "smb" tramp-gvfs-methods)
1964           (tramp-set-completion-function
1965            "smb" '((tramp-gvfs-parse-device-names "_smb._tcp"))))))))
1966
1967 \f
1968 ;; D-Bus SYNCE functions.
1969
1970 (defun tramp-synce-list-devices ()
1971   "Return all discovered synce devices as list.
1972 They are retrieved from the hal daemon."
1973   (let (tramp-synce-devices)
1974     (dolist (device
1975              (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1976                :system tramp-hal-service tramp-hal-path-manager
1977                tramp-hal-interface-manager "GetAllDevices"))
1978       (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1979               :system tramp-hal-service device tramp-hal-interface-device
1980               "PropertyExists" "sync.plugin")
1981         (let ((prop
1982                (with-tramp-dbus-call-method
1983                 tramp-gvfs-dbus-event-vector t
1984                 :system tramp-hal-service device tramp-hal-interface-device
1985                 "GetPropertyString" "pda.pocketpc.name")))
1986           (unless (member prop tramp-synce-devices)
1987             (push prop tramp-synce-devices)))))
1988     (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-synce-devices)
1989     tramp-synce-devices))
1990
1991 (defun tramp-synce-parse-device-names (_ignore)
1992   "Return a list of (nil host) tuples allowed to access."
1993   (mapcar
1994    (lambda (x) (list nil x))
1995    (tramp-synce-list-devices)))
1996
1997 ;; Add completion function for SYNCE method.
1998 (when tramp-gvfs-enabled
1999   (tramp-set-completion-function
2000    "synce" '((tramp-synce-parse-device-names ""))))
2001
2002 (add-hook 'tramp-unload-hook
2003           (lambda ()
2004             (unload-feature 'tramp-gvfs 'force)))
2005
2006 (provide 'tramp-gvfs)
2007
2008 ;;; TODO:
2009
2010 ;; * Host name completion for existing mount points (afp-server,
2011 ;;   smb-server) or via smb-network.
2012 ;;
2013 ;; * Check, how two shares of the same SMB server can be mounted in
2014 ;;   parallel.
2015 ;;
2016 ;; * Apply SDP on bluetooth devices, in order to filter out obex
2017 ;;   capability.
2018 ;;
2019 ;; * Implement obex for other serial communication but bluetooth.
2020
2021 ;;; tramp-gvfs.el ends here