lisp/net/tramp-gvfs.el

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