| 1 | ;;; tramp-gvfs.el --- Tramp access functions for GVFS daemon |
| 2 | |
| 3 | ;; Copyright (C) 2009-2011 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Michael Albinus <michael.albinus@gmx.de> |
| 6 | ;; Keywords: comm, processes |
| 7 | ;; Package: tramp |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation, either version 3 of the License, or |
| 14 | ;; (at your option) any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 23 | |
| 24 | ;;; Commentary: |
| 25 | |
| 26 | ;; Access functions for the GVFS daemon from Tramp. Tested with GVFS |
| 27 | ;; 1.0.2 (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.2 (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 | ;; All actions to mount a remote location, and to retrieve mount |
| 37 | ;; information, are performed by D-Bus messages. File operations |
| 38 | ;; themselves are performed via the mounted filesystem in ~/.gvfs. |
| 39 | ;; Consequently, GNU Emacs 23.1 with enabled D-Bus bindings is a |
| 40 | ;; precondition. |
| 41 | |
| 42 | ;; The GVFS D-Bus interface is said to be unstable. There are even no |
| 43 | ;; introspection data. The interface, as discovered during |
| 44 | ;; development time, is given in respective comments. |
| 45 | |
| 46 | ;; The customer option `tramp-gvfs-methods' contains the list of |
| 47 | ;; supported connection methods. Per default, these are "dav", |
| 48 | ;; "davs", "obex" and "synce". Note that with "obex" it might be |
| 49 | ;; necessary to pair with the other bluetooth device, if it hasn't |
| 50 | ;; been done already. There might be also some few seconds delay in |
| 51 | ;; discovering available bluetooth devices. |
| 52 | |
| 53 | ;; Other possible connection methods are "ftp", "sftp" and "smb". |
| 54 | ;; When one of these methods is added to the list, the remote access |
| 55 | ;; for that method is performed via GVFS instead of the native Tramp |
| 56 | ;; implementation. |
| 57 | |
| 58 | ;; GVFS offers even more connection methods. The complete list of |
| 59 | ;; connection methods of the actual GVFS implementation can be |
| 60 | ;; retrieved by: |
| 61 | ;; |
| 62 | ;; (message |
| 63 | ;; "%s" |
| 64 | ;; (mapcar |
| 65 | ;; 'car |
| 66 | ;; (dbus-call-method |
| 67 | ;; :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker |
| 68 | ;; tramp-gvfs-interface-mounttracker "listMountableInfo"))) |
| 69 | |
| 70 | ;; Note that all other connection methods are not tested, beside the |
| 71 | ;; ones offered for customization in `tramp-gvfs-methods'. If you |
| 72 | ;; request an additional connection method to be supported, please |
| 73 | ;; drop me a note. |
| 74 | |
| 75 | ;; For hostname completion, information is retrieved either from the |
| 76 | ;; bluez daemon (for the "obex" method), the hal daemon (for the |
| 77 | ;; "synce" method), or from the zeroconf daemon (for the "dav", |
| 78 | ;; "davs", and "sftp" methods). The zeroconf daemon is pre-configured |
| 79 | ;; to discover services in the "local" domain. If another domain |
| 80 | ;; shall be used for discovering services, the customer option |
| 81 | ;; `tramp-gvfs-zeroconf-domain' can be set accordingly. |
| 82 | |
| 83 | ;; Restrictions: |
| 84 | |
| 85 | ;; * The current GVFS implementation does not allow to write on the |
| 86 | ;; remote bluetooth device via OBEX. |
| 87 | ;; |
| 88 | ;; * Two shares of the same SMB server cannot be mounted in parallel. |
| 89 | |
| 90 | ;;; Code: |
| 91 | |
| 92 | ;; D-Bus support in the Emacs core can be disabled with configuration |
| 93 | ;; option "--without-dbus". Declare used subroutines and variables. |
| 94 | (declare-function dbus-call-method "dbusbind.c") |
| 95 | (declare-function dbus-call-method-asynchronously "dbusbind.c") |
| 96 | (declare-function dbus-get-unique-name "dbusbind.c") |
| 97 | (declare-function dbus-register-method "dbusbind.c") |
| 98 | (declare-function dbus-register-signal "dbusbind.c") |
| 99 | |
| 100 | ;; Pacify byte-compiler |
| 101 | (eval-when-compile |
| 102 | (require 'cl) |
| 103 | (require 'custom)) |
| 104 | |
| 105 | (require 'tramp) |
| 106 | |
| 107 | (require 'dbus) |
| 108 | (require 'url-parse) |
| 109 | (require 'url-util) |
| 110 | (require 'zeroconf) |
| 111 | |
| 112 | ;;;###tramp-autoload |
| 113 | (defcustom tramp-gvfs-methods '("dav" "davs" "obex" "synce") |
| 114 | "*List of methods for remote files, accessed with GVFS." |
| 115 | :group 'tramp |
| 116 | :version "23.2" |
| 117 | :type '(repeat (choice (const "dav") |
| 118 | (const "davs") |
| 119 | (const "ftp") |
| 120 | (const "obex") |
| 121 | (const "sftp") |
| 122 | (const "smb") |
| 123 | (const "synce")))) |
| 124 | |
| 125 | ;; Add a default for `tramp-default-user-alist'. Rule: For the SYNCE |
| 126 | ;; method, no user is chosen. |
| 127 | ;;;###tramp-autoload |
| 128 | (add-to-list 'tramp-default-user-alist '("\\`synce\\'" nil nil)) |
| 129 | |
| 130 | (defcustom tramp-gvfs-zeroconf-domain "local" |
| 131 | "*Zeroconf domain to be used for discovering services, like host names." |
| 132 | :group 'tramp |
| 133 | :version "23.2" |
| 134 | :type 'string) |
| 135 | |
| 136 | ;; Add the methods to `tramp-methods', in order to allow minibuffer |
| 137 | ;; completion. |
| 138 | ;;;###tramp-autoload |
| 139 | (when (featurep 'dbusbind) |
| 140 | (dolist (elt tramp-gvfs-methods) |
| 141 | (unless (assoc elt tramp-methods) |
| 142 | (add-to-list 'tramp-methods (cons elt nil))))) |
| 143 | |
| 144 | (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp") |
| 145 | "The preceding object path for own objects.") |
| 146 | |
| 147 | (defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon" |
| 148 | "The well known name of the GVFS daemon.") |
| 149 | |
| 150 | ;; Check that GVFS is available. D-Bus integration is available since |
| 151 | ;; Emacs 23 on some system types. We don't call `dbus-ping', because |
| 152 | ;; this would load dbus.el. |
| 153 | (unless (and (tramp-compat-funcall 'dbus-get-unique-name :session) |
| 154 | (tramp-compat-process-running-p "gvfs-fuse-daemon")) |
| 155 | (error "Package `tramp-gvfs' not supported")) |
| 156 | |
| 157 | (defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker" |
| 158 | "The object path of the GVFS daemon.") |
| 159 | |
| 160 | (defconst tramp-gvfs-interface-mounttracker "org.gtk.vfs.MountTracker" |
| 161 | "The mount tracking interface in the GVFS daemon.") |
| 162 | |
| 163 | ;; <interface name='org.gtk.vfs.MountTracker'> |
| 164 | ;; <method name='listMounts'> |
| 165 | ;; <arg name='mount_info_list' |
| 166 | ;; type='a{sosssssbay{aya{say}}ay}' |
| 167 | ;; direction='out'/> |
| 168 | ;; </method> |
| 169 | ;; <method name='mountLocation'> |
| 170 | ;; <arg name='mount_spec' type='{aya{say}}' direction='in'/> |
| 171 | ;; <arg name='dbus_id' type='s' direction='in'/> |
| 172 | ;; <arg name='object_path' type='o' direction='in'/> |
| 173 | ;; </method> |
| 174 | ;; <signal name='mounted'> |
| 175 | ;; <arg name='mount_info' |
| 176 | ;; type='{sosssssbay{aya{say}}ay}'/> |
| 177 | ;; </signal> |
| 178 | ;; <signal name='unmounted'> |
| 179 | ;; <arg name='mount_info' |
| 180 | ;; type='{sosssssbay{aya{say}}ay}'/> |
| 181 | ;; </signal> |
| 182 | ;; </interface> |
| 183 | ;; |
| 184 | ;; STRUCT mount_info |
| 185 | ;; STRING dbus_id |
| 186 | ;; OBJECT_PATH object_path |
| 187 | ;; STRING display_name |
| 188 | ;; STRING stable_name |
| 189 | ;; STRING x_content_types Since GVFS 1.0 only !!! |
| 190 | ;; STRING icon |
| 191 | ;; STRING prefered_filename_encoding |
| 192 | ;; BOOLEAN user_visible |
| 193 | ;; ARRAY BYTE fuse_mountpoint |
| 194 | ;; STRUCT mount_spec |
| 195 | ;; ARRAY BYTE mount_prefix |
| 196 | ;; ARRAY |
| 197 | ;; STRUCT mount_spec_item |
| 198 | ;; STRING key (server, share, type, user, host, port) |
| 199 | ;; ARRAY BYTE value |
| 200 | ;; ARRAY BYTE default_location Since GVFS 1.5 only !!! |
| 201 | |
| 202 | (defconst tramp-gvfs-interface-mountoperation "org.gtk.vfs.MountOperation" |
| 203 | "Used by the dbus-proxying implementation of GMountOperation.") |
| 204 | |
| 205 | ;; <interface name='org.gtk.vfs.MountOperation'> |
| 206 | ;; <method name='askPassword'> |
| 207 | ;; <arg name='message' type='s' direction='in'/> |
| 208 | ;; <arg name='default_user' type='s' direction='in'/> |
| 209 | ;; <arg name='default_domain' type='s' direction='in'/> |
| 210 | ;; <arg name='flags' type='u' direction='in'/> |
| 211 | ;; <arg name='handled' type='b' direction='out'/> |
| 212 | ;; <arg name='aborted' type='b' direction='out'/> |
| 213 | ;; <arg name='password' type='s' direction='out'/> |
| 214 | ;; <arg name='username' type='s' direction='out'/> |
| 215 | ;; <arg name='domain' type='s' direction='out'/> |
| 216 | ;; <arg name='anonymous' type='b' direction='out'/> |
| 217 | ;; <arg name='password_save' type='u' direction='out'/> |
| 218 | ;; </method> |
| 219 | ;; <method name='askQuestion'> |
| 220 | ;; <arg name='message' type='s' direction='in'/> |
| 221 | ;; <arg name='choices' type='as' direction='in'/> |
| 222 | ;; <arg name='handled' type='b' direction='out'/> |
| 223 | ;; <arg name='aborted' type='b' direction='out'/> |
| 224 | ;; <arg name='choice' type='u' direction='out'/> |
| 225 | ;; </method> |
| 226 | ;; </interface> |
| 227 | |
| 228 | ;; The following flags are used in "askPassword". They are defined in |
| 229 | ;; /usr/include/glib-2.0/gio/gioenums.h. |
| 230 | |
| 231 | (defconst tramp-gvfs-password-need-password 1 |
| 232 | "Operation requires a password.") |
| 233 | |
| 234 | (defconst tramp-gvfs-password-need-username 2 |
| 235 | "Operation requires a username.") |
| 236 | |
| 237 | (defconst tramp-gvfs-password-need-domain 4 |
| 238 | "Operation requires a domain.") |
| 239 | |
| 240 | (defconst tramp-gvfs-password-saving-supported 8 |
| 241 | "Operation supports saving settings.") |
| 242 | |
| 243 | (defconst tramp-gvfs-password-anonymous-supported 16 |
| 244 | "Operation supports anonymous users.") |
| 245 | |
| 246 | (defconst tramp-bluez-service "org.bluez" |
| 247 | "The well known name of the BLUEZ service.") |
| 248 | |
| 249 | (defconst tramp-bluez-interface-manager "org.bluez.Manager" |
| 250 | "The manager interface of the BLUEZ daemon.") |
| 251 | |
| 252 | ;; <interface name='org.bluez.Manager'> |
| 253 | ;; <method name='DefaultAdapter'> |
| 254 | ;; <arg type='o' direction='out'/> |
| 255 | ;; </method> |
| 256 | ;; <method name='FindAdapter'> |
| 257 | ;; <arg type='s' direction='in'/> |
| 258 | ;; <arg type='o' direction='out'/> |
| 259 | ;; </method> |
| 260 | ;; <method name='ListAdapters'> |
| 261 | ;; <arg type='ao' direction='out'/> |
| 262 | ;; </method> |
| 263 | ;; <signal name='AdapterAdded'> |
| 264 | ;; <arg type='o'/> |
| 265 | ;; </signal> |
| 266 | ;; <signal name='AdapterRemoved'> |
| 267 | ;; <arg type='o'/> |
| 268 | ;; </signal> |
| 269 | ;; <signal name='DefaultAdapterChanged'> |
| 270 | ;; <arg type='o'/> |
| 271 | ;; </signal> |
| 272 | ;; </interface> |
| 273 | |
| 274 | (defconst tramp-bluez-interface-adapter "org.bluez.Adapter" |
| 275 | "The adapter interface of the BLUEZ daemon.") |
| 276 | |
| 277 | ;; <interface name='org.bluez.Adapter'> |
| 278 | ;; <method name='GetProperties'> |
| 279 | ;; <arg type='a{sv}' direction='out'/> |
| 280 | ;; </method> |
| 281 | ;; <method name='SetProperty'> |
| 282 | ;; <arg type='s' direction='in'/> |
| 283 | ;; <arg type='v' direction='in'/> |
| 284 | ;; </method> |
| 285 | ;; <method name='RequestMode'> |
| 286 | ;; <arg type='s' direction='in'/> |
| 287 | ;; </method> |
| 288 | ;; <method name='ReleaseMode'/> |
| 289 | ;; <method name='RequestSession'/> |
| 290 | ;; <method name='ReleaseSession'/> |
| 291 | ;; <method name='StartDiscovery'/> |
| 292 | ;; <method name='StopDiscovery'/> |
| 293 | ;; <method name='ListDevices'> |
| 294 | ;; <arg type='ao' direction='out'/> |
| 295 | ;; </method> |
| 296 | ;; <method name='CreateDevice'> |
| 297 | ;; <arg type='s' direction='in'/> |
| 298 | ;; <arg type='o' direction='out'/> |
| 299 | ;; </method> |
| 300 | ;; <method name='CreatePairedDevice'> |
| 301 | ;; <arg type='s' direction='in'/> |
| 302 | ;; <arg type='o' direction='in'/> |
| 303 | ;; <arg type='s' direction='in'/> |
| 304 | ;; <arg type='o' direction='out'/> |
| 305 | ;; </method> |
| 306 | ;; <method name='CancelDeviceCreation'> |
| 307 | ;; <arg type='s' direction='in'/> |
| 308 | ;; </method> |
| 309 | ;; <method name='RemoveDevice'> |
| 310 | ;; <arg type='o' direction='in'/> |
| 311 | ;; </method> |
| 312 | ;; <method name='FindDevice'> |
| 313 | ;; <arg type='s' direction='in'/> |
| 314 | ;; <arg type='o' direction='out'/> |
| 315 | ;; </method> |
| 316 | ;; <method name='RegisterAgent'> |
| 317 | ;; <arg type='o' direction='in'/> |
| 318 | ;; <arg type='s' direction='in'/> |
| 319 | ;; </method> |
| 320 | ;; <method name='UnregisterAgent'> |
| 321 | ;; <arg type='o' direction='in'/> |
| 322 | ;; </method> |
| 323 | ;; <signal name='DeviceCreated'> |
| 324 | ;; <arg type='o'/> |
| 325 | ;; </signal> |
| 326 | ;; <signal name='DeviceRemoved'> |
| 327 | ;; <arg type='o'/> |
| 328 | ;; </signal> |
| 329 | ;; <signal name='DeviceFound'> |
| 330 | ;; <arg type='s'/> |
| 331 | ;; <arg type='a{sv}'/> |
| 332 | ;; </signal> |
| 333 | ;; <signal name='PropertyChanged'> |
| 334 | ;; <arg type='s'/> |
| 335 | ;; <arg type='v'/> |
| 336 | ;; </signal> |
| 337 | ;; <signal name='DeviceDisappeared'> |
| 338 | ;; <arg type='s'/> |
| 339 | ;; </signal> |
| 340 | ;; </interface> |
| 341 | |
| 342 | (defcustom tramp-bluez-discover-devices-timeout 60 |
| 343 | "Defines seconds since last bluetooth device discovery before rescanning. |
| 344 | A value of 0 would require an immediate discovery during hostname |
| 345 | completion, nil means to use always cached values for discovered |
| 346 | devices." |
| 347 | :group 'tramp |
| 348 | :version "23.2" |
| 349 | :type '(choice (const nil) integer)) |
| 350 | |
| 351 | (defvar tramp-bluez-discovery nil |
| 352 | "Indicator for a running bluetooth device discovery. |
| 353 | It keeps the timestamp of last discovery.") |
| 354 | |
| 355 | (defvar tramp-bluez-devices nil |
| 356 | "Alist of detected bluetooth devices. |
| 357 | Every entry is a list (NAME ADDRESS).") |
| 358 | |
| 359 | (defconst tramp-hal-service "org.freedesktop.Hal" |
| 360 | "The well known name of the HAL service.") |
| 361 | |
| 362 | (defconst tramp-hal-path-manager "/org/freedesktop/Hal/Manager" |
| 363 | "The object path of the HAL daemon manager.") |
| 364 | |
| 365 | (defconst tramp-hal-interface-manager "org.freedesktop.Hal.Manager" |
| 366 | "The manager interface of the HAL daemon.") |
| 367 | |
| 368 | (defconst tramp-hal-interface-device "org.freedesktop.Hal.Device" |
| 369 | "The device interface of the HAL daemon.") |
| 370 | |
| 371 | \f |
| 372 | ;; New handlers should be added here. |
| 373 | (defconst tramp-gvfs-file-name-handler-alist |
| 374 | '( |
| 375 | (access-file . ignore) |
| 376 | (add-name-to-file . tramp-gvfs-handle-copy-file) |
| 377 | ;; `byte-compiler-base-file-name' performed by default handler. |
| 378 | (copy-file . tramp-gvfs-handle-copy-file) |
| 379 | (delete-directory . tramp-gvfs-handle-delete-directory) |
| 380 | (delete-file . tramp-gvfs-handle-delete-file) |
| 381 | ;; `diff-latest-backup-file' performed by default handler. |
| 382 | (directory-file-name . tramp-handle-directory-file-name) |
| 383 | (directory-files . tramp-gvfs-handle-directory-files) |
| 384 | (directory-files-and-attributes |
| 385 | . tramp-gvfs-handle-directory-files-and-attributes) |
| 386 | (dired-call-process . ignore) |
| 387 | (dired-compress-file . ignore) |
| 388 | (dired-uncache . tramp-handle-dired-uncache) |
| 389 | ;; `executable-find' is not official yet. performed by default handler. |
| 390 | (expand-file-name . tramp-gvfs-handle-expand-file-name) |
| 391 | ;; `file-accessible-directory-p' performed by default handler. |
| 392 | (file-attributes . tramp-gvfs-handle-file-attributes) |
| 393 | (file-directory-p . tramp-gvfs-handle-file-directory-p) |
| 394 | (file-executable-p . tramp-gvfs-handle-file-executable-p) |
| 395 | (file-exists-p . tramp-gvfs-handle-file-exists-p) |
| 396 | (file-local-copy . tramp-gvfs-handle-file-local-copy) |
| 397 | ;; `file-modes' performed by default handler. |
| 398 | (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions) |
| 399 | (file-name-as-directory . tramp-handle-file-name-as-directory) |
| 400 | (file-name-completion . tramp-handle-file-name-completion) |
| 401 | (file-name-directory . tramp-handle-file-name-directory) |
| 402 | (file-name-nondirectory . tramp-handle-file-name-nondirectory) |
| 403 | ;; `file-name-sans-versions' performed by default handler. |
| 404 | (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) |
| 405 | (file-ownership-preserved-p . ignore) |
| 406 | (file-readable-p . tramp-gvfs-handle-file-readable-p) |
| 407 | (file-regular-p . tramp-handle-file-regular-p) |
| 408 | (file-remote-p . tramp-handle-file-remote-p) |
| 409 | (file-selinux-context . tramp-gvfs-handle-file-selinux-context) |
| 410 | (file-symlink-p . tramp-handle-file-symlink-p) |
| 411 | ;; `file-truename' performed by default handler. |
| 412 | (file-writable-p . tramp-gvfs-handle-file-writable-p) |
| 413 | (find-backup-file-name . tramp-handle-find-backup-file-name) |
| 414 | ;; `find-file-noselect' performed by default handler. |
| 415 | ;; `get-file-buffer' performed by default handler. |
| 416 | (insert-directory . tramp-gvfs-handle-insert-directory) |
| 417 | (insert-file-contents . tramp-gvfs-handle-insert-file-contents) |
| 418 | (load . tramp-handle-load) |
| 419 | (make-directory . tramp-gvfs-handle-make-directory) |
| 420 | (make-directory-internal . ignore) |
| 421 | (make-symbolic-link . ignore) |
| 422 | (process-file . tramp-gvfs-handle-process-file) |
| 423 | (rename-file . tramp-gvfs-handle-rename-file) |
| 424 | (set-file-modes . tramp-gvfs-handle-set-file-modes) |
| 425 | (set-file-selinux-context . tramp-gvfs-handle-set-file-selinux-context) |
| 426 | (set-visited-file-modtime . tramp-gvfs-handle-set-visited-file-modtime) |
| 427 | (shell-command . tramp-gvfs-handle-shell-command) |
| 428 | (start-file-process . tramp-gvfs-handle-start-file-process) |
| 429 | (substitute-in-file-name . tramp-handle-substitute-in-file-name) |
| 430 | (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) |
| 431 | (vc-registered . ignore) |
| 432 | (verify-visited-file-modtime |
| 433 | . tramp-gvfs-handle-verify-visited-file-modtime) |
| 434 | (write-region . tramp-gvfs-handle-write-region) |
| 435 | ) |
| 436 | "Alist of handler functions for Tramp GVFS method. |
| 437 | Operations not mentioned here will be handled by the default Emacs primitives.") |
| 438 | |
| 439 | ;;;###tramp-autoload |
| 440 | (defsubst tramp-gvfs-file-name-p (filename) |
| 441 | "Check if it's a filename handled by the GVFS daemon." |
| 442 | (and (tramp-tramp-file-p filename) |
| 443 | (let ((method |
| 444 | (tramp-file-name-method (tramp-dissect-file-name filename)))) |
| 445 | (and (stringp method) (member method tramp-gvfs-methods))))) |
| 446 | |
| 447 | ;;;###tramp-autoload |
| 448 | (defun tramp-gvfs-file-name-handler (operation &rest args) |
| 449 | "Invoke the GVFS related OPERATION. |
| 450 | First arg specifies the OPERATION, second arg is a list of arguments to |
| 451 | pass to the OPERATION." |
| 452 | (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) |
| 453 | (if fn |
| 454 | (save-match-data (apply (cdr fn) args)) |
| 455 | (tramp-run-real-handler operation args)))) |
| 456 | |
| 457 | ;; This might be moved to tramp.el. It shall be the first file name |
| 458 | ;; handler. |
| 459 | ;;;###tramp-autoload |
| 460 | (when (featurep 'dbusbind) |
| 461 | (add-to-list 'tramp-foreign-file-name-handler-alist |
| 462 | (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler))) |
| 463 | |
| 464 | (defun tramp-gvfs-stringify-dbus-message (message) |
| 465 | "Convert a D-Bus message into readable UTF8 strings, used for traces." |
| 466 | (cond |
| 467 | ((and (consp message) (characterp (car message))) |
| 468 | (format "%S" (dbus-byte-array-to-string message))) |
| 469 | ((consp message) |
| 470 | (mapcar 'tramp-gvfs-stringify-dbus-message message)) |
| 471 | ((stringp message) |
| 472 | (format "%S" message)) |
| 473 | (t message))) |
| 474 | |
| 475 | (defmacro with-tramp-dbus-call-method |
| 476 | (vec synchronous bus service path interface method &rest args) |
| 477 | "Apply a D-Bus call on bus BUS. |
| 478 | |
| 479 | If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise, |
| 480 | it is an asynchronous call, with `ignore' as callback function. |
| 481 | |
| 482 | The other arguments have the same meaning as with `dbus-call-method' |
| 483 | or `dbus-call-method-asynchronously'. Additionally, the call |
| 484 | will be traced by Tramp with trace level 6." |
| 485 | `(let ((func (if ,synchronous |
| 486 | 'dbus-call-method 'dbus-call-method-asynchronously)) |
| 487 | (args (append (list ,bus ,service ,path ,interface ,method) |
| 488 | (if ,synchronous (list ,@args) (list 'ignore ,@args)))) |
| 489 | result) |
| 490 | (tramp-message ,vec 6 "%s %s" func args) |
| 491 | (setq result (apply func args)) |
| 492 | (tramp-message ,vec 6 "%s" (tramp-gvfs-stringify-dbus-message result)) |
| 493 | result)) |
| 494 | |
| 495 | (put 'with-tramp-dbus-call-method 'lisp-indent-function 2) |
| 496 | (put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body)) |
| 497 | (tramp-compat-font-lock-add-keywords |
| 498 | 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) |
| 499 | |
| 500 | (defmacro with-tramp-gvfs-error-message (filename handler &rest args) |
| 501 | "Apply a Tramp GVFS `handler'. |
| 502 | In case of an error, modify the error message by replacing |
| 503 | `filename' with its GVFS mounted name." |
| 504 | `(let ((fuse-file-name (regexp-quote (tramp-gvfs-fuse-file-name ,filename))) |
| 505 | elt) |
| 506 | (condition-case err |
| 507 | (tramp-compat-funcall ,handler ,@args) |
| 508 | (error |
| 509 | (setq elt (cdr err)) |
| 510 | (while elt |
| 511 | (when (and (stringp (car elt)) |
| 512 | (string-match fuse-file-name (car elt))) |
| 513 | (setcar elt (replace-match ,filename t t (car elt)))) |
| 514 | (setq elt (cdr elt))) |
| 515 | (signal (car err) (cdr err)))))) |
| 516 | |
| 517 | (put 'with-tramp-gvfs-error-message 'lisp-indent-function 2) |
| 518 | (put 'with-tramp-gvfs-error-message 'edebug-form-spec '(form symbolp body)) |
| 519 | (tramp-compat-font-lock-add-keywords |
| 520 | 'emacs-lisp-mode '("\\<with-tramp-gvfs-error-message\\>")) |
| 521 | |
| 522 | (defvar tramp-gvfs-dbus-event-vector nil |
| 523 | "Current Tramp file name to be used, as vector. |
| 524 | It is needed when D-Bus signals or errors arrive, because there |
| 525 | is no information where to trace the message.") |
| 526 | |
| 527 | (defun tramp-gvfs-dbus-event-error (event err) |
| 528 | "Called when a D-Bus error message arrives, see `dbus-event-error-hooks'." |
| 529 | (when tramp-gvfs-dbus-event-vector |
| 530 | (tramp-message tramp-gvfs-dbus-event-vector 10 "%S" event) |
| 531 | (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err)))) |
| 532 | |
| 533 | (add-hook 'dbus-event-error-hooks 'tramp-gvfs-dbus-event-error) |
| 534 | |
| 535 | \f |
| 536 | ;; File name primitives. |
| 537 | |
| 538 | (defun tramp-gvfs-handle-copy-file |
| 539 | (filename newname &optional ok-if-already-exists keep-date |
| 540 | preserve-uid-gid preserve-selinux-context) |
| 541 | "Like `copy-file' for Tramp files." |
| 542 | (with-parsed-tramp-file-name |
| 543 | (if (tramp-tramp-file-p filename) filename newname) nil |
| 544 | (tramp-with-progress-reporter |
| 545 | v 0 (format "Copying %s to %s" filename newname) |
| 546 | (condition-case err |
| 547 | (let ((args |
| 548 | (list |
| 549 | (if (tramp-gvfs-file-name-p filename) |
| 550 | (tramp-gvfs-fuse-file-name filename) |
| 551 | filename) |
| 552 | (if (tramp-gvfs-file-name-p newname) |
| 553 | (tramp-gvfs-fuse-file-name newname) |
| 554 | newname) |
| 555 | ok-if-already-exists keep-date preserve-uid-gid))) |
| 556 | (when preserve-selinux-context |
| 557 | (setq args (append args (list preserve-selinux-context)))) |
| 558 | (apply 'copy-file args)) |
| 559 | |
| 560 | ;; Error case. Let's try it with the GVFS utilities. |
| 561 | (error |
| 562 | (tramp-message v 4 "`copy-file' failed, trying `gvfs-copy'") |
| 563 | (unless |
| 564 | (zerop |
| 565 | (let ((args |
| 566 | (append (if (or keep-date preserve-uid-gid) |
| 567 | (list "--preserve") |
| 568 | nil) |
| 569 | (list |
| 570 | (tramp-gvfs-url-file-name filename) |
| 571 | (tramp-gvfs-url-file-name newname))))) |
| 572 | (apply 'tramp-gvfs-send-command v "gvfs-copy" args))) |
| 573 | ;; Propagate the error. |
| 574 | (tramp-error v (car err) "%s" (cdr err))))))) |
| 575 | |
| 576 | (when (file-remote-p newname) |
| 577 | (with-parsed-tramp-file-name newname nil |
| 578 | (tramp-flush-file-property v (file-name-directory localname)) |
| 579 | (tramp-flush-file-property v localname)))) |
| 580 | |
| 581 | (defun tramp-gvfs-handle-delete-directory (directory &optional recursive) |
| 582 | "Like `delete-directory' for Tramp files." |
| 583 | (tramp-compat-delete-directory |
| 584 | (tramp-gvfs-fuse-file-name directory) recursive)) |
| 585 | |
| 586 | (defun tramp-gvfs-handle-delete-file (filename &optional trash) |
| 587 | "Like `delete-file' for Tramp files." |
| 588 | (tramp-compat-delete-file (tramp-gvfs-fuse-file-name filename) trash)) |
| 589 | |
| 590 | (defun tramp-gvfs-handle-directory-files |
| 591 | (directory &optional full match nosort) |
| 592 | "Like `directory-files' for Tramp files." |
| 593 | (let ((fuse-file-name (tramp-gvfs-fuse-file-name directory))) |
| 594 | (mapcar |
| 595 | (lambda (x) |
| 596 | (if (string-match fuse-file-name x) |
| 597 | (replace-match directory t t x) |
| 598 | x)) |
| 599 | (directory-files fuse-file-name full match nosort)))) |
| 600 | |
| 601 | (defun tramp-gvfs-handle-directory-files-and-attributes |
| 602 | (directory &optional full match nosort id-format) |
| 603 | "Like `directory-files-and-attributes' for Tramp files." |
| 604 | (let ((fuse-file-name (tramp-gvfs-fuse-file-name directory))) |
| 605 | (mapcar |
| 606 | (lambda (x) |
| 607 | (when (string-match fuse-file-name (car x)) |
| 608 | (setcar x (replace-match directory t t (car x)))) |
| 609 | x) |
| 610 | (directory-files-and-attributes |
| 611 | fuse-file-name full match nosort id-format)))) |
| 612 | |
| 613 | (defun tramp-gvfs-handle-expand-file-name (name &optional dir) |
| 614 | "Like `expand-file-name' for Tramp files." |
| 615 | ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". |
| 616 | (setq dir (or dir default-directory "/")) |
| 617 | ;; Unless NAME is absolute, concat DIR and NAME. |
| 618 | (unless (file-name-absolute-p name) |
| 619 | (setq name (concat (file-name-as-directory dir) name))) |
| 620 | ;; If NAME is not a Tramp file, run the real handler. |
| 621 | (if (not (tramp-tramp-file-p name)) |
| 622 | (tramp-run-real-handler 'expand-file-name (list name nil)) |
| 623 | ;; Dissect NAME. |
| 624 | (with-parsed-tramp-file-name name nil |
| 625 | ;; If there is a default location, expand tilde. |
| 626 | (when (string-match "\\`\\(~\\)\\(/\\|\\'\\)" localname) |
| 627 | (save-match-data |
| 628 | (tramp-gvfs-maybe-open-connection (vector method user host "/"))) |
| 629 | (setq localname |
| 630 | (replace-match |
| 631 | (tramp-get-file-property v "/" "default-location" "~") |
| 632 | nil t localname 1))) |
| 633 | ;; Tilde expansion is not possible. |
| 634 | (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) |
| 635 | (tramp-error |
| 636 | v 'file-error |
| 637 | "Cannot expand tilde in file `%s'" name)) |
| 638 | (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) |
| 639 | (setq localname (concat "/" localname))) |
| 640 | ;; We do not pass "/..". |
| 641 | (if (string-equal "smb" method) |
| 642 | (when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname) |
| 643 | (setq localname (replace-match "/" t t localname 1))) |
| 644 | (when (string-match "^/\\.\\./?" localname) |
| 645 | (setq localname (replace-match "/" t t localname)))) |
| 646 | ;; There might be a double slash. Remove this. |
| 647 | (while (string-match "//" localname) |
| 648 | (setq localname (replace-match "/" t t localname))) |
| 649 | ;; No tilde characters in file name, do normal |
| 650 | ;; `expand-file-name' (this does "/./" and "/../"). |
| 651 | (tramp-make-tramp-file-name |
| 652 | method user host |
| 653 | (tramp-run-real-handler |
| 654 | 'expand-file-name (list localname)))))) |
| 655 | |
| 656 | (defun tramp-gvfs-handle-file-attributes (filename &optional id-format) |
| 657 | "Like `file-attributes' for Tramp files." |
| 658 | (file-attributes (tramp-gvfs-fuse-file-name filename) id-format)) |
| 659 | |
| 660 | (defun tramp-gvfs-handle-file-directory-p (filename) |
| 661 | "Like `file-directory-p' for Tramp files." |
| 662 | (file-directory-p (tramp-gvfs-fuse-file-name filename))) |
| 663 | |
| 664 | (defun tramp-gvfs-handle-file-executable-p (filename) |
| 665 | "Like `file-executable-p' for Tramp files." |
| 666 | (file-executable-p (tramp-gvfs-fuse-file-name filename))) |
| 667 | |
| 668 | (defun tramp-gvfs-handle-file-exists-p (filename) |
| 669 | "Like `file-exists-p' for Tramp files." |
| 670 | (file-exists-p (tramp-gvfs-fuse-file-name filename))) |
| 671 | |
| 672 | (defun tramp-gvfs-handle-file-local-copy (filename) |
| 673 | "Like `file-local-copy' for Tramp files." |
| 674 | (with-parsed-tramp-file-name filename nil |
| 675 | (let ((tmpfile (tramp-compat-make-temp-file filename))) |
| 676 | (unless (file-exists-p filename) |
| 677 | (tramp-error |
| 678 | v 'file-error |
| 679 | "Cannot make local copy of non-existing file `%s'" filename)) |
| 680 | (copy-file filename tmpfile t t) |
| 681 | tmpfile))) |
| 682 | |
| 683 | (defun tramp-gvfs-handle-file-name-all-completions (filename directory) |
| 684 | "Like `file-name-all-completions' for Tramp files." |
| 685 | (unless (save-match-data (string-match "/" filename)) |
| 686 | (file-name-all-completions filename (tramp-gvfs-fuse-file-name directory)))) |
| 687 | |
| 688 | (defun tramp-gvfs-handle-file-readable-p (filename) |
| 689 | "Like `file-readable-p' for Tramp files." |
| 690 | (file-readable-p (tramp-gvfs-fuse-file-name filename))) |
| 691 | |
| 692 | (defun tramp-gvfs-handle-file-selinux-context (filename) |
| 693 | "Like `file-selinux-context' for Tramp files." |
| 694 | (tramp-compat-funcall |
| 695 | 'file-selinux-context (tramp-gvfs-fuse-file-name filename))) |
| 696 | |
| 697 | (defun tramp-gvfs-handle-file-writable-p (filename) |
| 698 | "Like `file-writable-p' for Tramp files." |
| 699 | (file-writable-p (tramp-gvfs-fuse-file-name filename))) |
| 700 | |
| 701 | (defun tramp-gvfs-handle-insert-directory |
| 702 | (filename switches &optional wildcard full-directory-p) |
| 703 | "Like `insert-directory' for Tramp files." |
| 704 | (insert-directory |
| 705 | (tramp-gvfs-fuse-file-name filename) switches wildcard full-directory-p)) |
| 706 | |
| 707 | (defun tramp-gvfs-handle-insert-file-contents |
| 708 | (filename &optional visit beg end replace) |
| 709 | "Like `insert-file-contents' for Tramp files." |
| 710 | (unwind-protect |
| 711 | (let ((fuse-file-name (tramp-gvfs-fuse-file-name filename)) |
| 712 | (result |
| 713 | (insert-file-contents |
| 714 | (tramp-gvfs-fuse-file-name filename) visit beg end replace))) |
| 715 | (when (string-match fuse-file-name (car result)) |
| 716 | (setcar result (replace-match filename t t (car result)))) |
| 717 | result) |
| 718 | (setq buffer-file-name filename))) |
| 719 | |
| 720 | (defun tramp-gvfs-handle-make-directory (dir &optional parents) |
| 721 | "Like `make-directory' for Tramp files." |
| 722 | (with-parsed-tramp-file-name dir nil |
| 723 | (condition-case err |
| 724 | (with-tramp-gvfs-error-message dir 'make-directory |
| 725 | (tramp-gvfs-fuse-file-name dir) parents) |
| 726 | |
| 727 | ;; Error case. Let's try it with the GVFS utilities. |
| 728 | (error |
| 729 | (tramp-message v 4 "`make-directory' failed, trying `gvfs-mkdir'") |
| 730 | (unless |
| 731 | (zerop |
| 732 | (tramp-gvfs-send-command |
| 733 | v "gvfs-mkdir" (tramp-gvfs-url-file-name dir))) |
| 734 | ;; Propagate the error. |
| 735 | (tramp-error v (car err) "%s" (cdr err))))))) |
| 736 | |
| 737 | (defun tramp-gvfs-handle-process-file |
| 738 | (program &optional infile destination display &rest args) |
| 739 | "Like `process-file' for Tramp files." |
| 740 | (let ((default-directory (tramp-gvfs-fuse-file-name default-directory))) |
| 741 | (apply 'call-process program infile destination display args))) |
| 742 | |
| 743 | (defun tramp-gvfs-handle-rename-file |
| 744 | (filename newname &optional ok-if-already-exists) |
| 745 | "Like `rename-file' for Tramp files." |
| 746 | (with-parsed-tramp-file-name |
| 747 | (if (tramp-tramp-file-p filename) filename newname) nil |
| 748 | (tramp-with-progress-reporter |
| 749 | v 0 (format "Renaming %s to %s" filename newname) |
| 750 | (condition-case err |
| 751 | (rename-file |
| 752 | (if (tramp-gvfs-file-name-p filename) |
| 753 | (tramp-gvfs-fuse-file-name filename) |
| 754 | filename) |
| 755 | (if (tramp-gvfs-file-name-p newname) |
| 756 | (tramp-gvfs-fuse-file-name newname) |
| 757 | newname) |
| 758 | ok-if-already-exists) |
| 759 | |
| 760 | ;; Error case. Let's try it with the GVFS utilities. |
| 761 | (error |
| 762 | (tramp-message v 4 "`rename-file' failed, trying `gvfs-move'") |
| 763 | (unless |
| 764 | (zerop |
| 765 | (tramp-gvfs-send-command |
| 766 | v "gvfs-move" |
| 767 | (tramp-gvfs-url-file-name filename) |
| 768 | (tramp-gvfs-url-file-name newname))) |
| 769 | ;; Propagate the error. |
| 770 | (tramp-error v (car err) "%s" (cdr err))))))) |
| 771 | |
| 772 | (when (file-remote-p filename) |
| 773 | (with-parsed-tramp-file-name filename nil |
| 774 | (tramp-flush-file-property v (file-name-directory localname)) |
| 775 | (tramp-flush-file-property v localname))) |
| 776 | |
| 777 | (when (file-remote-p newname) |
| 778 | (with-parsed-tramp-file-name newname nil |
| 779 | (tramp-flush-file-property v (file-name-directory localname)) |
| 780 | (tramp-flush-file-property v localname)))) |
| 781 | |
| 782 | (defun tramp-gvfs-handle-set-file-modes (filename mode) |
| 783 | "Like `set-file-modes' for Tramp files." |
| 784 | (with-tramp-gvfs-error-message filename 'set-file-modes |
| 785 | (tramp-gvfs-fuse-file-name filename) mode)) |
| 786 | |
| 787 | (defun tramp-gvfs-handle-set-file-selinux-context (filename context) |
| 788 | "Like `set-file-selinux-context' for Tramp files." |
| 789 | (with-tramp-gvfs-error-message filename 'set-file-selinux-context |
| 790 | (tramp-gvfs-fuse-file-name filename) context)) |
| 791 | |
| 792 | (defun tramp-gvfs-handle-set-visited-file-modtime (&optional time-list) |
| 793 | "Like `set-visited-file-modtime' for Tramp files." |
| 794 | (let ((buffer-file-name (tramp-gvfs-fuse-file-name (buffer-file-name)))) |
| 795 | (set-visited-file-modtime time-list))) |
| 796 | |
| 797 | (defun tramp-gvfs-handle-shell-command |
| 798 | (command &optional output-buffer error-buffer) |
| 799 | "Like `shell-command' for Tramp files." |
| 800 | (let ((default-directory (tramp-gvfs-fuse-file-name default-directory))) |
| 801 | (shell-command command output-buffer error-buffer))) |
| 802 | |
| 803 | (defun tramp-gvfs-handle-start-file-process (name buffer program &rest args) |
| 804 | "Like `start-file-process' for Tramp files." |
| 805 | (let ((default-directory (tramp-gvfs-fuse-file-name default-directory))) |
| 806 | (apply 'start-process name buffer program args))) |
| 807 | |
| 808 | (defun tramp-gvfs-handle-verify-visited-file-modtime (buf) |
| 809 | "Like `verify-visited-file-modtime' for Tramp files." |
| 810 | (with-current-buffer buf |
| 811 | (let ((buffer-file-name (tramp-gvfs-fuse-file-name (buffer-file-name)))) |
| 812 | (verify-visited-file-modtime buf)))) |
| 813 | |
| 814 | (defun tramp-gvfs-handle-write-region |
| 815 | (start end filename &optional append visit lockname confirm) |
| 816 | "Like `write-region' for Tramp files." |
| 817 | (with-parsed-tramp-file-name filename nil |
| 818 | (condition-case err |
| 819 | (with-tramp-gvfs-error-message filename 'write-region |
| 820 | start end (tramp-gvfs-fuse-file-name filename) |
| 821 | append visit lockname confirm) |
| 822 | |
| 823 | ;; Error case. Let's try rename. |
| 824 | (error |
| 825 | (let ((tmpfile (tramp-compat-make-temp-file filename))) |
| 826 | (tramp-message v 4 "`write-region' failed, trying `rename-file'") |
| 827 | (write-region start end tmpfile) |
| 828 | (condition-case nil |
| 829 | (rename-file tmpfile filename) |
| 830 | (error |
| 831 | (delete-file tmpfile) |
| 832 | (tramp-error v (car err) "%s" (cdr err))))))) |
| 833 | |
| 834 | ;; Set file modification time. |
| 835 | (when (or (eq visit t) (stringp visit)) |
| 836 | (set-visited-file-modtime (nth 5 (file-attributes filename)))) |
| 837 | |
| 838 | ;; The end. |
| 839 | (when (or (eq visit t) (null visit) (stringp visit)) |
| 840 | (tramp-message v 0 "Wrote %s" filename)) |
| 841 | (run-hooks 'tramp-handle-write-region-hook))) |
| 842 | |
| 843 | \f |
| 844 | ;; File name conversions. |
| 845 | |
| 846 | (defun tramp-gvfs-url-file-name (filename) |
| 847 | "Return FILENAME in URL syntax." |
| 848 | ;; "/" must NOT be hexlified. |
| 849 | (let ((url-unreserved-chars (append '(?/) url-unreserved-chars))) |
| 850 | (url-recreate-url |
| 851 | (if (tramp-tramp-file-p filename) |
| 852 | (with-parsed-tramp-file-name (file-truename filename) nil |
| 853 | (when (string-match tramp-user-with-domain-regexp user) |
| 854 | (setq user |
| 855 | (concat (match-string 2 user) ";" (match-string 2 user)))) |
| 856 | (url-parse-make-urlobj |
| 857 | method user nil |
| 858 | (tramp-file-name-real-host v) (tramp-file-name-port v) |
| 859 | (url-hexify-string localname))) |
| 860 | (url-parse-make-urlobj |
| 861 | "file" nil nil nil nil (url-hexify-string (file-truename filename))))))) |
| 862 | |
| 863 | (defun tramp-gvfs-object-path (filename) |
| 864 | "Create a D-Bus object path from FILENAME." |
| 865 | (expand-file-name (dbus-escape-as-identifier filename) tramp-gvfs-path-tramp)) |
| 866 | |
| 867 | (defun tramp-gvfs-file-name (object-path) |
| 868 | "Retrieve file name from D-Bus OBJECT-PATH." |
| 869 | (dbus-unescape-from-identifier |
| 870 | (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path))) |
| 871 | |
| 872 | (defun tramp-gvfs-fuse-file-name (filename) |
| 873 | "Return FUSE file name, which is directly accessible." |
| 874 | (with-parsed-tramp-file-name (expand-file-name filename) nil |
| 875 | (tramp-gvfs-maybe-open-connection v) |
| 876 | (let ((prefix (tramp-get-file-property v "/" "prefix" "")) |
| 877 | (fuse-mountpoint |
| 878 | (tramp-get-file-property v "/" "fuse-mountpoint" nil))) |
| 879 | (unless fuse-mountpoint |
| 880 | (tramp-error |
| 881 | v 'file-error "There is no FUSE mount point for `%s'" filename)) |
| 882 | ;; We must hide the prefix, if any. |
| 883 | (when (string-match (concat "^" (regexp-quote prefix)) localname) |
| 884 | (setq localname (replace-match "" t t localname))) |
| 885 | (tramp-message |
| 886 | v 10 "remote file `%s' is local file `%s'" |
| 887 | filename (concat fuse-mountpoint localname)) |
| 888 | (concat fuse-mountpoint localname)))) |
| 889 | |
| 890 | (defun tramp-bluez-address (device) |
| 891 | "Return bluetooth device address from a given bluetooth DEVICE name." |
| 892 | (when (stringp device) |
| 893 | (if (string-match tramp-ipv6-regexp device) |
| 894 | (match-string 0 device) |
| 895 | (cadr (assoc device (tramp-bluez-list-devices)))))) |
| 896 | |
| 897 | (defun tramp-bluez-device (address) |
| 898 | "Return bluetooth device name from a given bluetooth device ADDRESS. |
| 899 | ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." |
| 900 | (when (stringp address) |
| 901 | (while (string-match "[][]" address) |
| 902 | (setq address (replace-match "" t t address))) |
| 903 | (let (result) |
| 904 | (dolist (item (tramp-bluez-list-devices) result) |
| 905 | (when (string-match address (cadr item)) |
| 906 | (setq result (car item))))))) |
| 907 | |
| 908 | \f |
| 909 | ;; D-Bus GVFS functions. |
| 910 | |
| 911 | (defun tramp-gvfs-handler-askpassword (message user domain flags) |
| 912 | "Implementation for the \"org.gtk.vfs.MountOperation.askPassword\" method." |
| 913 | (let* ((filename |
| 914 | (tramp-gvfs-file-name (dbus-event-path-name last-input-event))) |
| 915 | (pw-prompt |
| 916 | (format |
| 917 | "%s for %s " |
| 918 | (if (string-match "\\([pP]assword\\|[pP]assphrase\\)" message) |
| 919 | (capitalize (match-string 1 message)) |
| 920 | "Password") |
| 921 | filename)) |
| 922 | password) |
| 923 | |
| 924 | (condition-case nil |
| 925 | (with-parsed-tramp-file-name filename l |
| 926 | (when (and (zerop (length user)) |
| 927 | (not |
| 928 | (zerop (logand flags tramp-gvfs-password-need-username)))) |
| 929 | (setq user (read-string "User name: "))) |
| 930 | (when (and (zerop (length domain)) |
| 931 | (not (zerop (logand flags tramp-gvfs-password-need-domain)))) |
| 932 | (setq domain (read-string "Domain name: "))) |
| 933 | |
| 934 | (tramp-message l 6 "%S %S %S %d" message user domain flags) |
| 935 | (setq tramp-current-method l-method |
| 936 | tramp-current-user user |
| 937 | tramp-current-host l-host |
| 938 | password (tramp-read-passwd |
| 939 | (tramp-get-connection-process l) pw-prompt)) |
| 940 | |
| 941 | ;; Return result. |
| 942 | (if (stringp password) |
| 943 | (list |
| 944 | t ;; password handled. |
| 945 | nil ;; no abort of D-Bus. |
| 946 | password |
| 947 | (tramp-file-name-real-user l) |
| 948 | domain |
| 949 | nil ;; not anonymous. |
| 950 | 0) ;; no password save. |
| 951 | ;; No password provided. |
| 952 | (list nil t "" (tramp-file-name-real-user l) domain nil 0))) |
| 953 | |
| 954 | ;; When QUIT is raised, we shall return this information to D-Bus. |
| 955 | (quit (list nil t "" "" "" nil 0))))) |
| 956 | |
| 957 | (defun tramp-gvfs-handler-askquestion (message choices) |
| 958 | "Implementation for the \"org.gtk.vfs.MountOperation.askQuestion\" method." |
| 959 | (save-window-excursion |
| 960 | (let ((enable-recursive-minibuffers t) |
| 961 | choice) |
| 962 | |
| 963 | (condition-case nil |
| 964 | (with-parsed-tramp-file-name |
| 965 | (tramp-gvfs-file-name (dbus-event-path-name last-input-event)) nil |
| 966 | (tramp-message v 6 "%S %S" message choices) |
| 967 | |
| 968 | ;; In theory, there can be several choices. Until now, |
| 969 | ;; there is only the question whether to accept an unknown |
| 970 | ;; host signature. |
| 971 | (with-temp-buffer |
| 972 | ;; Preserve message for `progress-reporter'. |
| 973 | (tramp-compat-with-temp-message "" |
| 974 | (insert message) |
| 975 | (pop-to-buffer (current-buffer)) |
| 976 | (setq choice (if (yes-or-no-p (concat (car choices) " ")) 0 1)) |
| 977 | (tramp-message v 6 "%d" choice))) |
| 978 | |
| 979 | ;; When the choice is "no", we set a dummy fuse-mountpoint |
| 980 | ;; in order to leave the timeout. |
| 981 | (unless (zerop choice) |
| 982 | (tramp-set-file-property v "/" "fuse-mountpoint" "/")) |
| 983 | |
| 984 | (list |
| 985 | t ;; handled. |
| 986 | nil ;; no abort of D-Bus. |
| 987 | choice)) |
| 988 | |
| 989 | ;; When QUIT is raised, we shall return this information to D-Bus. |
| 990 | (quit (list nil t 0)))))) |
| 991 | |
| 992 | (defun tramp-gvfs-handler-mounted-unmounted (mount-info) |
| 993 | "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and |
| 994 | \"org.gtk.vfs.MountTracker.unmounted\" signals." |
| 995 | (ignore-errors |
| 996 | (let ((signal-name (dbus-event-member-name last-input-event)) |
| 997 | (elt mount-info)) |
| 998 | ;; Jump over the first elements of the mount info. Since there |
| 999 | ;; were changes in the entries, we cannot access dedicated |
| 1000 | ;; elements. |
| 1001 | (while (stringp (car elt)) (setq elt (cdr elt))) |
| 1002 | (let* ((fuse-mountpoint (dbus-byte-array-to-string (cadr elt))) |
| 1003 | (mount-spec (caddr elt)) |
| 1004 | (default-location (dbus-byte-array-to-string (cadddr elt))) |
| 1005 | (method (dbus-byte-array-to-string |
| 1006 | (cadr (assoc "type" (cadr mount-spec))))) |
| 1007 | (user (dbus-byte-array-to-string |
| 1008 | (cadr (assoc "user" (cadr mount-spec))))) |
| 1009 | (domain (dbus-byte-array-to-string |
| 1010 | (cadr (assoc "domain" (cadr mount-spec))))) |
| 1011 | (host (dbus-byte-array-to-string |
| 1012 | (cadr (or (assoc "host" (cadr mount-spec)) |
| 1013 | (assoc "server" (cadr mount-spec)))))) |
| 1014 | (port (dbus-byte-array-to-string |
| 1015 | (cadr (assoc "port" (cadr mount-spec))))) |
| 1016 | (ssl (dbus-byte-array-to-string |
| 1017 | (cadr (assoc "ssl" (cadr mount-spec))))) |
| 1018 | (prefix (concat (dbus-byte-array-to-string (car mount-spec)) |
| 1019 | (dbus-byte-array-to-string |
| 1020 | (cadr (assoc "share" (cadr mount-spec))))))) |
| 1021 | (when (string-match "^smb" method) |
| 1022 | (setq method "smb")) |
| 1023 | (when (string-equal "obex" method) |
| 1024 | (setq host (tramp-bluez-device host))) |
| 1025 | (when (and (string-equal "dav" method) (string-equal "true" ssl)) |
| 1026 | (setq method "davs")) |
| 1027 | (unless (zerop (length domain)) |
| 1028 | (setq user (concat user tramp-prefix-domain-format domain))) |
| 1029 | (unless (zerop (length port)) |
| 1030 | (setq host (concat host tramp-prefix-port-format port))) |
| 1031 | (with-parsed-tramp-file-name |
| 1032 | (tramp-make-tramp-file-name method user host "") nil |
| 1033 | (tramp-message |
| 1034 | v 6 "%s %s" |
| 1035 | signal-name (tramp-gvfs-stringify-dbus-message mount-info)) |
| 1036 | (tramp-set-file-property v "/" "list-mounts" 'undef) |
| 1037 | (if (string-equal signal-name "unmounted") |
| 1038 | (tramp-set-file-property v "/" "fuse-mountpoint" nil) |
| 1039 | ;; Set prefix, mountpoint and location. |
| 1040 | (unless (string-equal prefix "/") |
| 1041 | (tramp-set-file-property v "/" "prefix" prefix)) |
| 1042 | (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint) |
| 1043 | (tramp-set-file-property |
| 1044 | v "/" "default-location" default-location))))))) |
| 1045 | |
| 1046 | (dbus-register-signal |
| 1047 | :session nil tramp-gvfs-path-mounttracker |
| 1048 | tramp-gvfs-interface-mounttracker "mounted" |
| 1049 | 'tramp-gvfs-handler-mounted-unmounted) |
| 1050 | |
| 1051 | (dbus-register-signal |
| 1052 | :session nil tramp-gvfs-path-mounttracker |
| 1053 | tramp-gvfs-interface-mounttracker "unmounted" |
| 1054 | 'tramp-gvfs-handler-mounted-unmounted) |
| 1055 | |
| 1056 | (defun tramp-gvfs-connection-mounted-p (vec) |
| 1057 | "Check, whether the location is already mounted." |
| 1058 | (or |
| 1059 | (tramp-get-file-property vec "/" "fuse-mountpoint" nil) |
| 1060 | (catch 'mounted |
| 1061 | (dolist |
| 1062 | (elt |
| 1063 | (with-file-property vec "/" "list-mounts" |
| 1064 | (with-tramp-dbus-call-method vec t |
| 1065 | :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker |
| 1066 | tramp-gvfs-interface-mounttracker "listMounts")) |
| 1067 | nil) |
| 1068 | ;; Jump over the first elements of the mount info. Since there |
| 1069 | ;; were changes in the entries, we cannot access dedicated |
| 1070 | ;; elements. |
| 1071 | (while (stringp (car elt)) (setq elt (cdr elt))) |
| 1072 | (let* ((fuse-mountpoint (dbus-byte-array-to-string (cadr elt))) |
| 1073 | (mount-spec (caddr elt)) |
| 1074 | (default-location (dbus-byte-array-to-string (cadddr elt))) |
| 1075 | (method (dbus-byte-array-to-string |
| 1076 | (cadr (assoc "type" (cadr mount-spec))))) |
| 1077 | (user (dbus-byte-array-to-string |
| 1078 | (cadr (assoc "user" (cadr mount-spec))))) |
| 1079 | (domain (dbus-byte-array-to-string |
| 1080 | (cadr (assoc "domain" (cadr mount-spec))))) |
| 1081 | (host (dbus-byte-array-to-string |
| 1082 | (cadr (or (assoc "host" (cadr mount-spec)) |
| 1083 | (assoc "server" (cadr mount-spec)))))) |
| 1084 | (port (dbus-byte-array-to-string |
| 1085 | (cadr (assoc "port" (cadr mount-spec))))) |
| 1086 | (ssl (dbus-byte-array-to-string |
| 1087 | (cadr (assoc "ssl" (cadr mount-spec))))) |
| 1088 | (prefix (concat (dbus-byte-array-to-string (car mount-spec)) |
| 1089 | (dbus-byte-array-to-string |
| 1090 | (cadr (assoc "share" (cadr mount-spec))))))) |
| 1091 | (when (string-match "^smb" method) |
| 1092 | (setq method "smb")) |
| 1093 | (when (string-equal "obex" method) |
| 1094 | (setq host (tramp-bluez-device host))) |
| 1095 | (when (and (string-equal "dav" method) (string-equal "true" ssl)) |
| 1096 | (setq method "davs")) |
| 1097 | (when (and (string-equal "synce" method) (zerop (length user))) |
| 1098 | (setq user (or (tramp-file-name-user vec) ""))) |
| 1099 | (unless (zerop (length domain)) |
| 1100 | (setq user (concat user tramp-prefix-domain-format domain))) |
| 1101 | (unless (zerop (length port)) |
| 1102 | (setq host (concat host tramp-prefix-port-format port))) |
| 1103 | (when (and |
| 1104 | (string-equal method (tramp-file-name-method vec)) |
| 1105 | (string-equal user (or (tramp-file-name-user vec) "")) |
| 1106 | (string-equal host (tramp-file-name-host vec)) |
| 1107 | (string-match (concat "^" (regexp-quote prefix)) |
| 1108 | (tramp-file-name-localname vec))) |
| 1109 | ;; Set prefix, mountpoint and location. |
| 1110 | (unless (string-equal prefix "/") |
| 1111 | (tramp-set-file-property vec "/" "prefix" prefix)) |
| 1112 | (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint) |
| 1113 | (tramp-set-file-property vec "/" "default-location" default-location) |
| 1114 | (throw 'mounted t))))))) |
| 1115 | |
| 1116 | (defun tramp-gvfs-mount-spec (vec) |
| 1117 | "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"." |
| 1118 | (let* ((method (tramp-file-name-method vec)) |
| 1119 | (user (tramp-file-name-real-user vec)) |
| 1120 | (domain (tramp-file-name-domain vec)) |
| 1121 | (host (tramp-file-name-real-host vec)) |
| 1122 | (port (tramp-file-name-port vec)) |
| 1123 | (localname (tramp-file-name-localname vec)) |
| 1124 | (ssl (if (string-match "^davs" method) "true" "false")) |
| 1125 | (mount-spec '(:array)) |
| 1126 | (mount-pref "/")) |
| 1127 | |
| 1128 | (setq |
| 1129 | mount-spec |
| 1130 | (append |
| 1131 | mount-spec |
| 1132 | (cond |
| 1133 | ((string-equal "smb" method) |
| 1134 | (string-match "^/?\\([^/]+\\)" localname) |
| 1135 | `((:struct "type" ,(dbus-string-to-byte-array "smb-share")) |
| 1136 | (:struct "server" ,(dbus-string-to-byte-array host)) |
| 1137 | (:struct "share" ,(dbus-string-to-byte-array |
| 1138 | (match-string 1 localname))))) |
| 1139 | ((string-equal "obex" method) |
| 1140 | `((:struct "type" ,(dbus-string-to-byte-array method)) |
| 1141 | (:struct "host" ,(dbus-string-to-byte-array |
| 1142 | (concat "[" (tramp-bluez-address host) "]"))))) |
| 1143 | ((string-match "^dav" method) |
| 1144 | `((:struct "type" ,(dbus-string-to-byte-array "dav")) |
| 1145 | (:struct "host" ,(dbus-string-to-byte-array host)) |
| 1146 | (:struct "ssl" ,(dbus-string-to-byte-array ssl)))) |
| 1147 | (t |
| 1148 | `((:struct "type" ,(dbus-string-to-byte-array method)) |
| 1149 | (:struct "host" ,(dbus-string-to-byte-array host))))))) |
| 1150 | |
| 1151 | (when user |
| 1152 | (add-to-list |
| 1153 | 'mount-spec |
| 1154 | `(:struct "user" ,(dbus-string-to-byte-array user)) |
| 1155 | 'append)) |
| 1156 | |
| 1157 | (when domain |
| 1158 | (add-to-list |
| 1159 | 'mount-spec |
| 1160 | `(:struct "domain" ,(dbus-string-to-byte-array domain)) |
| 1161 | 'append)) |
| 1162 | |
| 1163 | (when port |
| 1164 | (add-to-list |
| 1165 | 'mount-spec |
| 1166 | `(:struct "port" ,(dbus-string-to-byte-array (number-to-string port))) |
| 1167 | 'append)) |
| 1168 | |
| 1169 | (when (and (string-match "^dav" method) |
| 1170 | (string-match "^/?[^/]+" localname)) |
| 1171 | (setq mount-pref (match-string 0 localname))) |
| 1172 | |
| 1173 | ;; Return. |
| 1174 | `(:struct ,(dbus-string-to-byte-array mount-pref) ,mount-spec))) |
| 1175 | |
| 1176 | \f |
| 1177 | ;; Connection functions |
| 1178 | |
| 1179 | (defun tramp-gvfs-maybe-open-connection (vec) |
| 1180 | "Maybe open a connection VEC. |
| 1181 | Does not do anything if a connection is already open, but re-opens the |
| 1182 | connection if a previous connection has died for some reason." |
| 1183 | |
| 1184 | ;; We set the file name, in case there are incoming D-Bus signals or |
| 1185 | ;; D-Bus errors. |
| 1186 | (setq tramp-gvfs-dbus-event-vector vec) |
| 1187 | |
| 1188 | ;; For password handling, we need a process bound to the connection |
| 1189 | ;; buffer. Therefore, we create a dummy process. Maybe there is a |
| 1190 | ;; better solution? |
| 1191 | (unless (get-buffer-process (tramp-get-buffer vec)) |
| 1192 | (let ((p (make-network-process |
| 1193 | :name (tramp-buffer-name vec) |
| 1194 | :buffer (tramp-get-buffer vec) |
| 1195 | :server t :host 'local :service t))) |
| 1196 | (tramp-compat-set-process-query-on-exit-flag p nil))) |
| 1197 | |
| 1198 | (unless (tramp-gvfs-connection-mounted-p vec) |
| 1199 | (let* ((method (tramp-file-name-method vec)) |
| 1200 | (user (tramp-file-name-user vec)) |
| 1201 | (host (tramp-file-name-host vec)) |
| 1202 | (object-path |
| 1203 | (tramp-gvfs-object-path |
| 1204 | (tramp-make-tramp-file-name method user host "")))) |
| 1205 | |
| 1206 | (tramp-with-progress-reporter |
| 1207 | vec 3 |
| 1208 | (if (zerop (length user)) |
| 1209 | (format "Opening connection for %s using %s" host method) |
| 1210 | (format "Opening connection for %s@%s using %s" user host method)) |
| 1211 | |
| 1212 | ;; Enable auth-sorce and password-cache. |
| 1213 | (tramp-set-connection-property vec "first-password-request" t) |
| 1214 | |
| 1215 | ;; There will be a callback of "askPassword" when a password is |
| 1216 | ;; needed. |
| 1217 | (dbus-register-method |
| 1218 | :session dbus-service-emacs object-path |
| 1219 | tramp-gvfs-interface-mountoperation "askPassword" |
| 1220 | 'tramp-gvfs-handler-askpassword) |
| 1221 | |
| 1222 | ;; There could be a callback of "askQuestion" when adding fingerprint. |
| 1223 | (dbus-register-method |
| 1224 | :session dbus-service-emacs object-path |
| 1225 | tramp-gvfs-interface-mountoperation "askQuestion" |
| 1226 | 'tramp-gvfs-handler-askquestion) |
| 1227 | |
| 1228 | ;; The call must be asynchronously, because of the "askPassword" |
| 1229 | ;; or "askQuestion"callbacks. |
| 1230 | (with-tramp-dbus-call-method vec nil |
| 1231 | :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker |
| 1232 | tramp-gvfs-interface-mounttracker "mountLocation" |
| 1233 | (tramp-gvfs-mount-spec vec) (dbus-get-unique-name :session) |
| 1234 | :object-path object-path) |
| 1235 | |
| 1236 | ;; We must wait, until the mount is applied. This will be |
| 1237 | ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint" |
| 1238 | ;; file property. |
| 1239 | (with-timeout |
| 1240 | (60 |
| 1241 | (if (zerop (length (tramp-file-name-user vec))) |
| 1242 | (tramp-error |
| 1243 | vec 'file-error |
| 1244 | "Timeout reached mounting %s using %s" host method) |
| 1245 | (tramp-error |
| 1246 | vec 'file-error |
| 1247 | "Timeout reached mounting %s@%s using %s" user host method))) |
| 1248 | (while (not (tramp-get-file-property vec "/" "fuse-mountpoint" nil)) |
| 1249 | (read-event nil nil 0.1))) |
| 1250 | |
| 1251 | ;; If `tramp-gvfs-handler-askquestion' has returned "No", it |
| 1252 | ;; is marked with the fuse-mountpoint "/". We shall react. |
| 1253 | (when (string-equal |
| 1254 | (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/") |
| 1255 | (tramp-error vec 'file-error "FUSE mount denied")) |
| 1256 | |
| 1257 | ;; We set the connection property "started" in order to put the |
| 1258 | ;; remote location into the cache, which is helpful for further |
| 1259 | ;; completion. |
| 1260 | (tramp-set-connection-property vec "started" t))))) |
| 1261 | |
| 1262 | (defun tramp-gvfs-send-command (vec command &rest args) |
| 1263 | "Send the COMMAND with its ARGS to connection VEC. |
| 1264 | COMMAND is usually a command from the gvfs-* utilities. |
| 1265 | `call-process' is applied, and its return code is returned." |
| 1266 | (let (result) |
| 1267 | (with-current-buffer (tramp-get-buffer vec) |
| 1268 | (erase-buffer) |
| 1269 | (tramp-message vec 6 "%s %s" command (mapconcat 'identity args " ")) |
| 1270 | (setq result (apply 'tramp-local-call-process command nil t nil args)) |
| 1271 | (tramp-message vec 6 "%s" (buffer-string)) |
| 1272 | result))) |
| 1273 | |
| 1274 | \f |
| 1275 | ;; D-Bus BLUEZ functions. |
| 1276 | |
| 1277 | (defun tramp-bluez-list-devices () |
| 1278 | "Return all discovered bluetooth devices as list. |
| 1279 | Every entry is a list (NAME ADDRESS). |
| 1280 | |
| 1281 | If `tramp-bluez-discover-devices-timeout' is an integer, and the last |
| 1282 | discovery happened more time before indicated there, a rescan will be |
| 1283 | started, which lasts some ten seconds. Otherwise, cached results will |
| 1284 | be used." |
| 1285 | ;; Reset the scanned devices list if time has passed. |
| 1286 | (and (integerp tramp-bluez-discover-devices-timeout) |
| 1287 | (integerp tramp-bluez-discovery) |
| 1288 | (> (tramp-time-diff (current-time) tramp-bluez-discovery) |
| 1289 | tramp-bluez-discover-devices-timeout) |
| 1290 | (setq tramp-bluez-devices nil)) |
| 1291 | |
| 1292 | ;; Rescan if needed. |
| 1293 | (unless tramp-bluez-devices |
| 1294 | (let ((object-path |
| 1295 | (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t |
| 1296 | :system tramp-bluez-service "/" |
| 1297 | tramp-bluez-interface-manager "DefaultAdapter"))) |
| 1298 | (setq tramp-bluez-devices nil |
| 1299 | tramp-bluez-discovery t) |
| 1300 | (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil |
| 1301 | :system tramp-bluez-service object-path |
| 1302 | tramp-bluez-interface-adapter "StartDiscovery") |
| 1303 | (while tramp-bluez-discovery |
| 1304 | (read-event nil nil 0.1)))) |
| 1305 | (setq tramp-bluez-discovery (current-time)) |
| 1306 | (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-bluez-devices) |
| 1307 | tramp-bluez-devices) |
| 1308 | |
| 1309 | (defun tramp-bluez-property-changed (property value) |
| 1310 | "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal." |
| 1311 | (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" property value) |
| 1312 | (cond |
| 1313 | ((string-equal property "Discovering") |
| 1314 | (unless (car value) |
| 1315 | ;; "Discovering" FALSE means discovery run has been completed. |
| 1316 | ;; We stop it, because we don't need another run. |
| 1317 | (setq tramp-bluez-discovery nil) |
| 1318 | (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t |
| 1319 | :system tramp-bluez-service (dbus-event-path-name last-input-event) |
| 1320 | tramp-bluez-interface-adapter "StopDiscovery"))))) |
| 1321 | |
| 1322 | (dbus-register-signal |
| 1323 | :system nil nil tramp-bluez-interface-adapter "PropertyChanged" |
| 1324 | 'tramp-bluez-property-changed) |
| 1325 | |
| 1326 | (defun tramp-bluez-device-found (device args) |
| 1327 | "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal." |
| 1328 | (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" device args) |
| 1329 | (let ((alias (car (cadr (assoc "Alias" args)))) |
| 1330 | (address (car (cadr (assoc "Address" args))))) |
| 1331 | ;; Maybe we shall check the device class for being a proper |
| 1332 | ;; device, and call also SDP in order to find the obex service. |
| 1333 | (add-to-list 'tramp-bluez-devices (list alias address)))) |
| 1334 | |
| 1335 | (dbus-register-signal |
| 1336 | :system nil nil tramp-bluez-interface-adapter "DeviceFound" |
| 1337 | 'tramp-bluez-device-found) |
| 1338 | |
| 1339 | (defun tramp-bluez-parse-device-names (ignore) |
| 1340 | "Return a list of (nil host) tuples allowed to access." |
| 1341 | (mapcar |
| 1342 | (lambda (x) (list nil (car x))) |
| 1343 | (tramp-bluez-list-devices))) |
| 1344 | |
| 1345 | ;; Add completion function for OBEX method. |
| 1346 | (when (member tramp-bluez-service (dbus-list-known-names :system)) |
| 1347 | (tramp-set-completion-function |
| 1348 | "obex" '((tramp-bluez-parse-device-names "")))) |
| 1349 | |
| 1350 | \f |
| 1351 | ;; D-Bus zeroconf functions. |
| 1352 | |
| 1353 | (defun tramp-zeroconf-parse-workstation-device-names (ignore) |
| 1354 | "Return a list of (user host) tuples allowed to access." |
| 1355 | (mapcar |
| 1356 | (lambda (x) |
| 1357 | (list nil (zeroconf-service-host x))) |
| 1358 | (zeroconf-list-services "_workstation._tcp"))) |
| 1359 | |
| 1360 | (defun tramp-zeroconf-parse-webdav-device-names (ignore) |
| 1361 | "Return a list of (user host) tuples allowed to access." |
| 1362 | (mapcar |
| 1363 | (lambda (x) |
| 1364 | (let ((host (zeroconf-service-host x)) |
| 1365 | (port (zeroconf-service-port x)) |
| 1366 | (text (zeroconf-service-txt x)) |
| 1367 | user) |
| 1368 | (when port |
| 1369 | (setq host (format "%s%s%d" host tramp-prefix-port-regexp port))) |
| 1370 | ;; A user is marked in a TXT field like "u=guest". |
| 1371 | (while text |
| 1372 | (when (string-match "u=\\(.+\\)$" (car text)) |
| 1373 | (setq user (match-string 1 (car text)))) |
| 1374 | (setq text (cdr text))) |
| 1375 | (list user host))) |
| 1376 | (zeroconf-list-services "_webdav._tcp"))) |
| 1377 | |
| 1378 | ;; Add completion function for DAV and DAVS methods. |
| 1379 | (when (member zeroconf-service-avahi (dbus-list-known-names :system)) |
| 1380 | (zeroconf-init tramp-gvfs-zeroconf-domain) |
| 1381 | (tramp-set-completion-function |
| 1382 | "sftp" '((tramp-zeroconf-parse-workstation-device-names ""))) |
| 1383 | (tramp-set-completion-function |
| 1384 | "dav" '((tramp-zeroconf-parse-webdav-device-names ""))) |
| 1385 | (tramp-set-completion-function |
| 1386 | "davs" '((tramp-zeroconf-parse-webdav-device-names "")))) |
| 1387 | |
| 1388 | \f |
| 1389 | ;; D-Bus SYNCE functions. |
| 1390 | |
| 1391 | (defun tramp-synce-list-devices () |
| 1392 | "Return all discovered synce devices as list. |
| 1393 | They are retrieved from the hal daemon." |
| 1394 | (let (tramp-synce-devices) |
| 1395 | (dolist (device |
| 1396 | (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t |
| 1397 | :system tramp-hal-service tramp-hal-path-manager |
| 1398 | tramp-hal-interface-manager "GetAllDevices")) |
| 1399 | (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t |
| 1400 | :system tramp-hal-service device tramp-hal-interface-device |
| 1401 | "PropertyExists" "sync.plugin") |
| 1402 | (add-to-list |
| 1403 | 'tramp-synce-devices |
| 1404 | (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t |
| 1405 | :system tramp-hal-service device tramp-hal-interface-device |
| 1406 | "GetPropertyString" "pda.pocketpc.name")))) |
| 1407 | (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-synce-devices) |
| 1408 | tramp-synce-devices)) |
| 1409 | |
| 1410 | (defun tramp-synce-parse-device-names (ignore) |
| 1411 | "Return a list of (nil host) tuples allowed to access." |
| 1412 | (mapcar |
| 1413 | (lambda (x) (list nil x)) |
| 1414 | (tramp-synce-list-devices))) |
| 1415 | |
| 1416 | ;; Add completion function for SYNCE method. |
| 1417 | (tramp-set-completion-function |
| 1418 | "synce" '((tramp-synce-parse-device-names ""))) |
| 1419 | |
| 1420 | (add-hook 'tramp-unload-hook |
| 1421 | (lambda () |
| 1422 | (unload-feature 'tramp-gvfs 'force))) |
| 1423 | |
| 1424 | (provide 'tramp-gvfs) |
| 1425 | |
| 1426 | ;;; TODO: |
| 1427 | |
| 1428 | ;; * Host name completion via smb-server or smb-network. |
| 1429 | ;; * Check how two shares of the same SMB server can be mounted in |
| 1430 | ;; parallel. |
| 1431 | ;; * Apply SDP on bluetooth devices, in order to filter out obex |
| 1432 | ;; capability. |
| 1433 | ;; * Implement obex for other serial communication but bluetooth. |
| 1434 | |
| 1435 | ;;; tramp-gvfs.el ends here |