1 ;;; tramp-gvfs.el --- Tramp access functions for GVFS daemon
3 ;; Copyright (C) 2009-2014 Free Software Foundation, Inc.
5 ;; Author: Michael Albinus <michael.albinus@gmx.de>
6 ;; Keywords: comm, processes
9 ;; This file is part of GNU Emacs.
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.
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.
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/>.
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
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>.
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.
39 ;; All actions to mount a remote location, and to retrieve mount
40 ;; information, are performed by D-Bus messages. File operations
41 ;; themselves are performed via the mounted filesystem in ~/.gvfs.
42 ;; Consequently, GNU Emacs 23.1 with enabled D-Bus bindings is a
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
50 ;; The customer option `tramp-gvfs-methods' contains the list of
51 ;; supported connection methods. Per default, these are "dav",
52 ;; "davs", "obex" and "synce". Note that with "obex" it might be
53 ;; necessary to pair with the other bluetooth device, if it hasn't
54 ;; been done already. There might be also some few seconds delay in
55 ;; discovering available bluetooth devices.
57 ;; Other possible connection methods are "ftp", "sftp" and "smb".
58 ;; When one of these methods is added to the list, the remote access
59 ;; for that method is performed via GVFS instead of the native Tramp
62 ;; GVFS offers even more connection methods. The complete list of
63 ;; connection methods of the actual GVFS implementation can be
71 ;; :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
72 ;; tramp-gvfs-interface-mounttracker "listMountableInfo")))
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
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 "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 customer option
85 ;; `tramp-gvfs-zeroconf-domain' can be set accordingly.
89 ;; * The current GVFS implementation does not allow to write on the
90 ;; remote bluetooth device via OBEX.
92 ;; * Two shares of the same SMB server cannot be mounted in parallel.
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")
107 ;; Pacify byte-compiler.
111 (defvar ls-lisp-use-insert-directory-program
)
114 (defcustom tramp-gvfs-methods
'("dav" "davs" "obex" "synce")
115 "List of methods for remote files, accessed with GVFS."
118 :type
'(repeat (choice (const "dav")
126 ;; Add a default for `tramp-default-user-alist'. Rule: For the SYNCE
127 ;; method, no user is chosen.
129 (add-to-list 'tramp-default-user-alist
'("\\`synce\\'" nil nil
))
131 (defcustom tramp-gvfs-zeroconf-domain
"local"
132 "Zeroconf domain to be used for discovering services, like host names."
137 ;; Add the methods to `tramp-methods', in order to allow minibuffer
140 (when (featurep 'dbusbind
)
141 (dolist (elt tramp-gvfs-methods
)
142 (unless (assoc elt tramp-methods
)
143 (add-to-list 'tramp-methods
(cons elt nil
)))))
145 (defconst tramp-gvfs-path-tramp
(concat dbus-path-emacs
"/Tramp")
146 "The preceding object path for own objects.")
148 (defconst tramp-gvfs-service-daemon
"org.gtk.vfs.Daemon"
149 "The well known name of the GVFS daemon.")
151 ;; D-Bus integration is available since Emacs 23 on some system types.
152 ;; We don't call `dbus-ping', because this would load dbus.el.
153 (defconst tramp-gvfs-enabled
155 (and (featurep 'dbusbind
)
156 (tramp-compat-funcall 'dbus-get-unique-name
:system
)
157 (tramp-compat-funcall 'dbus-get-unique-name
:session
)
158 (or (tramp-compat-process-running-p "gvfs-fuse-daemon")
159 (tramp-compat-process-running-p "gvfsd-fuse"))))
160 "Non-nil when GVFS is available.")
162 (defconst tramp-gvfs-path-mounttracker
"/org/gtk/vfs/mounttracker"
163 "The object path of the GVFS daemon.")
165 (defconst tramp-gvfs-interface-mounttracker
"org.gtk.vfs.MountTracker"
166 "The mount tracking interface in the GVFS daemon.")
168 ;; Introspection data exist since GVFS 1.14. If there are no such
169 ;; data, we expect an earlier interface.
170 (defconst tramp-gvfs-methods-mounttracker
171 (dbus-introspect-get-method-names
172 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
173 tramp-gvfs-interface-mounttracker
)
174 "The list of supported methods of the mount tracking interface.")
176 (defconst tramp-gvfs-listmounts
177 (if (member "ListMounts" tramp-gvfs-methods-mounttracker
)
180 "The name of the \"listMounts\" method.
181 It has been changed in GVFS 1.14.")
183 (defconst tramp-gvfs-mountlocation
184 (if (member "MountLocation" tramp-gvfs-methods-mounttracker
)
187 "The name of the \"mountLocation\" method.
188 It has been changed in GVFS 1.14.")
190 (defconst tramp-gvfs-mountlocation-signature
191 (dbus-introspect-get-signature
192 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
193 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
)
194 "The D-Bus signature of the \"mountLocation\" method.
195 It has been changed in GVFS 1.14.")
197 ;; <interface name='org.gtk.vfs.MountTracker'>
198 ;; <method name='listMounts'>
199 ;; <arg name='mount_info_list'
200 ;; type='a{sosssssbay{aya{say}}ay}'
203 ;; <method name='mountLocation'>
204 ;; <arg name='mount_spec' type='{aya{say}}' direction='in'/>
205 ;; <arg name='dbus_id' type='s' direction='in'/>
206 ;; <arg name='object_path' type='o' direction='in'/>
208 ;; <signal name='mounted'>
209 ;; <arg name='mount_info'
210 ;; type='{sosssssbay{aya{say}}ay}'/>
212 ;; <signal name='unmounted'>
213 ;; <arg name='mount_info'
214 ;; type='{sosssssbay{aya{say}}ay}'/>
220 ;; OBJECT_PATH object_path
221 ;; STRING display_name
222 ;; STRING stable_name
223 ;; STRING x_content_types Since GVFS 1.0 only !!!
225 ;; STRING preferred_filename_encoding
226 ;; BOOLEAN user_visible
227 ;; ARRAY BYTE fuse_mountpoint
229 ;; ARRAY BYTE mount_prefix
231 ;; STRUCT mount_spec_item
232 ;; STRING key (server, share, type, user, host, port)
234 ;; ARRAY BYTE default_location Since GVFS 1.5 only !!!
236 (defconst tramp-gvfs-interface-mountoperation
"org.gtk.vfs.MountOperation"
237 "Used by the dbus-proxying implementation of GMountOperation.")
239 ;; <interface name='org.gtk.vfs.MountOperation'>
240 ;; <method name='askPassword'>
241 ;; <arg name='message' type='s' direction='in'/>
242 ;; <arg name='default_user' type='s' direction='in'/>
243 ;; <arg name='default_domain' type='s' direction='in'/>
244 ;; <arg name='flags' type='u' direction='in'/>
245 ;; <arg name='handled' type='b' direction='out'/>
246 ;; <arg name='aborted' type='b' direction='out'/>
247 ;; <arg name='password' type='s' direction='out'/>
248 ;; <arg name='username' type='s' direction='out'/>
249 ;; <arg name='domain' type='s' direction='out'/>
250 ;; <arg name='anonymous' type='b' direction='out'/>
251 ;; <arg name='password_save' type='u' direction='out'/>
253 ;; <method name='askQuestion'>
254 ;; <arg name='message' type='s' direction='in'/>
255 ;; <arg name='choices' type='as' direction='in'/>
256 ;; <arg name='handled' type='b' direction='out'/>
257 ;; <arg name='aborted' type='b' direction='out'/>
258 ;; <arg name='choice' type='u' direction='out'/>
262 ;; The following flags are used in "askPassword". They are defined in
263 ;; /usr/include/glib-2.0/gio/gioenums.h.
265 (defconst tramp-gvfs-password-need-password
1
266 "Operation requires a password.")
268 (defconst tramp-gvfs-password-need-username
2
269 "Operation requires a username.")
271 (defconst tramp-gvfs-password-need-domain
4
272 "Operation requires a domain.")
274 (defconst tramp-gvfs-password-saving-supported
8
275 "Operation supports saving settings.")
277 (defconst tramp-gvfs-password-anonymous-supported
16
278 "Operation supports anonymous users.")
280 (defconst tramp-bluez-service
"org.bluez"
281 "The well known name of the BLUEZ service.")
283 (defconst tramp-bluez-interface-manager
"org.bluez.Manager"
284 "The manager interface of the BLUEZ daemon.")
286 ;; <interface name='org.bluez.Manager'>
287 ;; <method name='DefaultAdapter'>
288 ;; <arg type='o' direction='out'/>
290 ;; <method name='FindAdapter'>
291 ;; <arg type='s' direction='in'/>
292 ;; <arg type='o' direction='out'/>
294 ;; <method name='ListAdapters'>
295 ;; <arg type='ao' direction='out'/>
297 ;; <signal name='AdapterAdded'>
300 ;; <signal name='AdapterRemoved'>
303 ;; <signal name='DefaultAdapterChanged'>
308 (defconst tramp-bluez-interface-adapter
"org.bluez.Adapter"
309 "The adapter interface of the BLUEZ daemon.")
311 ;; <interface name='org.bluez.Adapter'>
312 ;; <method name='GetProperties'>
313 ;; <arg type='a{sv}' direction='out'/>
315 ;; <method name='SetProperty'>
316 ;; <arg type='s' direction='in'/>
317 ;; <arg type='v' direction='in'/>
319 ;; <method name='RequestMode'>
320 ;; <arg type='s' direction='in'/>
322 ;; <method name='ReleaseMode'/>
323 ;; <method name='RequestSession'/>
324 ;; <method name='ReleaseSession'/>
325 ;; <method name='StartDiscovery'/>
326 ;; <method name='StopDiscovery'/>
327 ;; <method name='ListDevices'>
328 ;; <arg type='ao' direction='out'/>
330 ;; <method name='CreateDevice'>
331 ;; <arg type='s' direction='in'/>
332 ;; <arg type='o' direction='out'/>
334 ;; <method name='CreatePairedDevice'>
335 ;; <arg type='s' direction='in'/>
336 ;; <arg type='o' direction='in'/>
337 ;; <arg type='s' direction='in'/>
338 ;; <arg type='o' direction='out'/>
340 ;; <method name='CancelDeviceCreation'>
341 ;; <arg type='s' direction='in'/>
343 ;; <method name='RemoveDevice'>
344 ;; <arg type='o' direction='in'/>
346 ;; <method name='FindDevice'>
347 ;; <arg type='s' direction='in'/>
348 ;; <arg type='o' direction='out'/>
350 ;; <method name='RegisterAgent'>
351 ;; <arg type='o' direction='in'/>
352 ;; <arg type='s' direction='in'/>
354 ;; <method name='UnregisterAgent'>
355 ;; <arg type='o' direction='in'/>
357 ;; <signal name='DeviceCreated'>
360 ;; <signal name='DeviceRemoved'>
363 ;; <signal name='DeviceFound'>
365 ;; <arg type='a{sv}'/>
367 ;; <signal name='PropertyChanged'>
371 ;; <signal name='DeviceDisappeared'>
376 (defcustom tramp-bluez-discover-devices-timeout
60
377 "Defines seconds since last bluetooth device discovery before rescanning.
378 A value of 0 would require an immediate discovery during hostname
379 completion, nil means to use always cached values for discovered
383 :type
'(choice (const nil
) integer
))
385 (defvar tramp-bluez-discovery nil
386 "Indicator for a running bluetooth device discovery.
387 It keeps the timestamp of last discovery.")
389 (defvar tramp-bluez-devices nil
390 "Alist of detected bluetooth devices.
391 Every entry is a list (NAME ADDRESS).")
393 (defconst tramp-hal-service
"org.freedesktop.Hal"
394 "The well known name of the HAL service.")
396 (defconst tramp-hal-path-manager
"/org/freedesktop/Hal/Manager"
397 "The object path of the HAL daemon manager.")
399 (defconst tramp-hal-interface-manager
"org.freedesktop.Hal.Manager"
400 "The manager interface of the HAL daemon.")
402 (defconst tramp-hal-interface-device
"org.freedesktop.Hal.Device"
403 "The device interface of the HAL daemon.")
406 ;; New handlers should be added here.
407 (defconst tramp-gvfs-file-name-handler-alist
408 '((access-file . ignore
)
409 (add-name-to-file . tramp-gvfs-handle-copy-file
)
410 ;; `byte-compiler-base-file-name' performed by default handler.
411 ;; `copy-directory' performed by default handler.
412 (copy-file . tramp-gvfs-handle-copy-file
)
413 (delete-directory . tramp-gvfs-handle-delete-directory
)
414 (delete-file . tramp-gvfs-handle-delete-file
)
415 ;; `diff-latest-backup-file' performed by default handler.
416 (directory-file-name . tramp-handle-directory-file-name
)
417 (directory-files . tramp-handle-directory-files
)
418 (directory-files-and-attributes
419 . tramp-handle-directory-files-and-attributes
)
420 (dired-call-process . ignore
)
421 (dired-compress-file . ignore
)
422 (dired-uncache . tramp-handle-dired-uncache
)
423 (expand-file-name . tramp-gvfs-handle-expand-file-name
)
424 (file-accessible-directory-p . tramp-handle-file-accessible-directory-p
)
426 (file-attributes . tramp-gvfs-handle-file-attributes
)
427 (file-directory-p . tramp-gvfs-handle-file-directory-p
)
428 ;; `file-equal-p' performed by default handler.
429 (file-executable-p . tramp-gvfs-handle-file-executable-p
)
430 (file-exists-p . tramp-handle-file-exists-p
)
431 ;; `file-in-directory-p' performed by default handler.
432 (file-local-copy . tramp-gvfs-handle-file-local-copy
)
433 (file-modes . tramp-handle-file-modes
)
434 (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions
)
435 (file-name-as-directory . tramp-handle-file-name-as-directory
)
436 (file-name-completion . tramp-handle-file-name-completion
)
437 (file-name-directory . tramp-handle-file-name-directory
)
438 (file-name-nondirectory . tramp-handle-file-name-nondirectory
)
439 ;; `file-name-sans-versions' performed by default handler.
440 (file-newer-than-file-p . tramp-handle-file-newer-than-file-p
)
441 (file-notify-add-watch . tramp-gvfs-handle-file-notify-add-watch
)
442 (file-notify-rm-watch . tramp-handle-file-notify-rm-watch
)
443 (file-ownership-preserved-p . ignore
)
444 (file-readable-p . tramp-gvfs-handle-file-readable-p
)
445 (file-regular-p . tramp-handle-file-regular-p
)
446 (file-remote-p . tramp-handle-file-remote-p
)
447 (file-selinux-context . ignore
)
448 (file-symlink-p . tramp-handle-file-symlink-p
)
449 ;; `file-truename' performed by default handler.
450 (file-writable-p . tramp-gvfs-handle-file-writable-p
)
451 (find-backup-file-name . tramp-handle-find-backup-file-name
)
452 ;; `find-file-noselect' performed by default handler.
453 ;; `get-file-buffer' performed by default handler.
454 (insert-directory . tramp-gvfs-handle-insert-directory
)
455 (insert-file-contents . tramp-handle-insert-file-contents
)
456 (load . tramp-handle-load
)
457 (make-auto-save-file-name . tramp-handle-make-auto-save-file-name
)
458 (make-directory . tramp-gvfs-handle-make-directory
)
459 (make-directory-internal . ignore
)
460 (make-symbolic-link . ignore
)
461 (process-file . ignore
)
462 (rename-file . tramp-gvfs-handle-rename-file
)
463 (set-file-acl . ignore
)
464 (set-file-modes . ignore
)
465 (set-file-selinux-context . ignore
)
466 (set-file-times . ignore
)
467 (set-visited-file-modtime . tramp-handle-set-visited-file-modtime
)
468 (shell-command . ignore
)
469 (start-file-process . ignore
)
470 (substitute-in-file-name . tramp-handle-substitute-in-file-name
)
471 (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory
)
472 (vc-registered . ignore
)
473 (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime
)
474 (write-region . tramp-gvfs-handle-write-region
))
475 "Alist of handler functions for Tramp GVFS method.
476 Operations not mentioned here will be handled by the default Emacs primitives.")
478 ;; It must be a `defsubst' in order to push the whole code into
479 ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading.
481 (defsubst tramp-gvfs-file-name-p
(filename)
482 "Check if it's a filename handled by the GVFS daemon."
483 (and (tramp-tramp-file-p filename
)
485 (tramp-file-name-method (tramp-dissect-file-name filename
))))
486 (and (stringp method
) (member method tramp-gvfs-methods
)))))
489 (defun tramp-gvfs-file-name-handler (operation &rest args
)
490 "Invoke the GVFS related OPERATION.
491 First arg specifies the OPERATION, second arg is a list of arguments to
492 pass to the OPERATION."
493 (unless tramp-gvfs-enabled
494 (tramp-user-error nil
"Package `tramp-gvfs' not supported"))
495 (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist
)))
497 (save-match-data (apply (cdr fn
) args
))
498 (tramp-run-real-handler operation args
))))
500 ;; This might be moved to tramp.el. It shall be the first file name
503 (when (featurep 'dbusbind
)
504 (add-to-list 'tramp-foreign-file-name-handler-alist
505 (cons 'tramp-gvfs-file-name-p
'tramp-gvfs-file-name-handler
)))
508 ;; D-Bus helper function.
510 (defun tramp-gvfs-dbus-string-to-byte-array (string)
511 "Like `dbus-string-to-byte-array' but add trailing \\0 if needed."
512 (dbus-string-to-byte-array
513 (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature
)
514 (concat string
(string 0)) string
)))
516 (defun tramp-gvfs-dbus-byte-array-to-string (byte-array)
517 "Like `dbus-byte-array-to-string' but remove trailing \\0 if exists."
518 ;; The byte array could be a variant. Take care.
520 (if (and (consp byte-array
) (atom (car byte-array
)))
521 byte-array
(car byte-array
))))
522 (dbus-byte-array-to-string
523 (if (and (consp byte-array
) (zerop (car (last byte-array
))))
524 (butlast byte-array
) byte-array
))))
526 (defun tramp-gvfs-stringify-dbus-message (message)
527 "Convert a D-Bus message into readable UTF8 strings, used for traces."
529 ((and (consp message
) (characterp (car message
)))
530 (format "%S" (tramp-gvfs-dbus-byte-array-to-string message
)))
532 (mapcar 'tramp-gvfs-stringify-dbus-message message
))
534 (format "%S" message
))
537 (defmacro with-tramp-dbus-call-method
538 (vec synchronous bus service path interface method
&rest args
)
539 "Apply a D-Bus call on bus BUS.
541 If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise,
542 it is an asynchronous call, with `ignore' as callback function.
544 The other arguments have the same meaning as with `dbus-call-method'
545 or `dbus-call-method-asynchronously'. Additionally, the call
546 will be traced by Tramp with trace level 6."
547 `(let ((func (if ,synchronous
548 'dbus-call-method
'dbus-call-method-asynchronously
))
549 (args (append (list ,bus
,service
,path
,interface
,method
)
550 (if ,synchronous
(list ,@args
) (list 'ignore
,@args
))))
552 (tramp-message ,vec
6 "%s %s" func args
)
553 (setq result
(apply func args
))
554 (tramp-message ,vec
6 "%s" (tramp-gvfs-stringify-dbus-message result
))
557 (put 'with-tramp-dbus-call-method
'lisp-indent-function
2)
558 (put 'with-tramp-dbus-call-method
'edebug-form-spec
'(form symbolp body
))
559 (tramp-compat-font-lock-add-keywords
560 'emacs-lisp-mode
'("\\<with-tramp-dbus-call-method\\>"))
562 (defvar tramp-gvfs-dbus-event-vector nil
563 "Current Tramp file name to be used, as vector.
564 It is needed when D-Bus signals or errors arrive, because there
565 is no information where to trace the message.")
567 (defun tramp-gvfs-dbus-event-error (event err
)
568 "Called when a D-Bus error message arrives, see `dbus-event-error-functions'."
569 (when tramp-gvfs-dbus-event-vector
570 (tramp-message tramp-gvfs-dbus-event-vector
10 "%S" event
)
571 (tramp-error tramp-gvfs-dbus-event-vector
'file-error
"%s" (cadr err
))))
573 ;; `dbus-event-error-hooks' has been renamed to `dbus-event-error-functions'.
575 (if (boundp 'dbus-event-error-functions
)
576 'dbus-event-error-functions
'dbus-event-error-hooks
)
577 'tramp-gvfs-dbus-event-error
)
580 ;; File name primitives.
582 (defun tramp-gvfs-handle-copy-file
583 (filename newname
&optional ok-if-already-exists keep-date
584 preserve-uid-gid preserve-extended-attributes
)
585 "Like `copy-file' for Tramp files."
586 (with-parsed-tramp-file-name
587 (if (tramp-tramp-file-p filename
) filename newname
) nil
589 (when (and (not ok-if-already-exists
) (file-exists-p newname
))
591 v
'file-already-exists
"File %s already exists" newname
))
593 (if (or (and (tramp-tramp-file-p filename
)
594 (not (tramp-gvfs-file-name-p filename
)))
595 (and (tramp-tramp-file-p newname
)
596 (not (tramp-gvfs-file-name-p newname
))))
598 ;; We cannot call `copy-file' directly. Use
599 ;; `tramp-compat-funcall' for backward compatibility (number
601 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
603 (preserve-extended-attributes
604 (tramp-compat-funcall
606 filename tmpfile t keep-date preserve-uid-gid
607 preserve-extended-attributes
))
609 (tramp-compat-funcall
610 'copy-file filename tmpfile t keep-date preserve-uid-gid
))
612 (copy-file filename tmpfile t keep-date
)))
613 (rename-file tmpfile newname ok-if-already-exists
))
616 (with-tramp-progress-reporter
617 v
0 (format "Copying %s to %s" filename newname
)
620 (append (if (or keep-date preserve-uid-gid
)
624 (tramp-gvfs-url-file-name filename
)
625 (tramp-gvfs-url-file-name newname
)))))
626 (apply 'tramp-gvfs-send-command v
"gvfs-copy" args
))
627 ;; Propagate the error.
628 (with-current-buffer (tramp-get-connection-buffer v
)
629 (goto-char (point-min))
630 (tramp-error-with-buffer
632 "Copying failed, see buffer `%s' for details." (buffer-name)))))
634 (when (tramp-tramp-file-p newname
)
635 (with-parsed-tramp-file-name newname nil
636 (tramp-flush-file-property v
(file-name-directory localname
))
637 (tramp-flush-file-property v localname
))))))
639 (defun tramp-gvfs-handle-delete-directory (directory &optional recursive trash
)
640 "Like `delete-directory' for Tramp files."
641 (when (and recursive
(not (file-symlink-p directory
)))
643 (if (eq t
(car (file-attributes file
)))
644 (tramp-compat-delete-directory file recursive trash
)
645 (tramp-compat-delete-file file trash
)))
647 directory
'full
"^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
648 (with-parsed-tramp-file-name directory nil
649 (tramp-flush-file-property v
(file-name-directory localname
))
650 (tramp-flush-directory-property v localname
)
652 (tramp-gvfs-send-command
653 v
(if (and trash delete-by-moving-to-trash
) "gvfs-trash" "gvfs-rm")
654 (tramp-gvfs-url-file-name directory
))
655 ;; Propagate the error.
656 (with-current-buffer (tramp-get-connection-buffer v
)
657 (goto-char (point-min))
658 (tramp-error-with-buffer
659 nil v
'file-error
"Couldn't delete %s" directory
)))))
661 (defun tramp-gvfs-handle-delete-file (filename &optional trash
)
662 "Like `delete-file' for Tramp files."
663 (with-parsed-tramp-file-name filename nil
664 (tramp-flush-file-property v
(file-name-directory localname
))
665 (tramp-flush-directory-property v localname
)
667 (tramp-gvfs-send-command
668 v
(if (and trash delete-by-moving-to-trash
) "gvfs-trash" "gvfs-rm")
669 (tramp-gvfs-url-file-name filename
))
670 ;; Propagate the error.
671 (with-current-buffer (tramp-get-connection-buffer v
)
672 (goto-char (point-min))
673 (tramp-error-with-buffer
674 nil v
'file-error
"Couldn't delete %s" filename
)))))
676 (defun tramp-gvfs-handle-expand-file-name (name &optional dir
)
677 "Like `expand-file-name' for Tramp files."
678 ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
679 (setq dir
(or dir default-directory
"/"))
680 ;; Unless NAME is absolute, concat DIR and NAME.
681 (unless (file-name-absolute-p name
)
682 (setq name
(concat (file-name-as-directory dir
) name
)))
683 ;; If NAME is not a Tramp file, run the real handler.
684 (if (not (tramp-tramp-file-p name
))
685 (tramp-run-real-handler 'expand-file-name
(list name nil
))
687 (with-parsed-tramp-file-name name nil
688 ;; If there is a default location, expand tilde.
689 (when (string-match "\\`\\(~\\)\\(/\\|\\'\\)" localname
)
691 (tramp-gvfs-maybe-open-connection (vector method user host
"/" hop
)))
694 (tramp-get-file-property v
"/" "default-location" "~")
696 ;; Tilde expansion is not possible.
697 (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname
)
700 "Cannot expand tilde in file `%s'" name
))
701 (unless (tramp-run-real-handler 'file-name-absolute-p
(list localname
))
702 (setq localname
(concat "/" localname
)))
703 ;; We do not pass "/..".
704 (if (string-equal "smb" method
)
705 (when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname
)
706 (setq localname
(replace-match "/" t t localname
1)))
707 (when (string-match "^/\\.\\./?" localname
)
708 (setq localname
(replace-match "/" t t localname
))))
709 ;; There might be a double slash. Remove this.
710 (while (string-match "//" localname
)
711 (setq localname
(replace-match "/" t t localname
)))
712 ;; No tilde characters in file name, do normal
713 ;; `expand-file-name' (this does "/./" and "/../").
714 (tramp-make-tramp-file-name
716 (tramp-run-real-handler
717 'expand-file-name
(list localname
))))))
719 (defun tramp-gvfs-handle-file-attributes (filename &optional id-format
)
720 "Like `file-attributes' for Tramp files."
721 (unless id-format
(setq id-format
'integer
))
722 ;; Don't modify `last-coding-system-used' by accident.
723 (let ((last-coding-system-used last-coding-system-used
)
724 dirp res-symlink-target res-numlinks res-uid res-gid res-access
725 res-mod res-change res-size res-filemodes res-inode res-device
)
726 (with-parsed-tramp-file-name filename nil
727 (with-tramp-file-property
728 v localname
(format "file-attributes-%s" id-format
)
729 (tramp-message v
5 "file attributes: %s" localname
)
730 (tramp-gvfs-send-command
731 v
"gvfs-info" (tramp-gvfs-url-file-name filename
))
733 (with-current-buffer (tramp-get-connection-buffer v
)
734 (goto-char (point-min))
735 (when (re-search-forward "attributes:" nil t
)
736 ;; ... directory or symlink
737 (goto-char (point-min))
738 (setq dirp
(if (re-search-forward "type:\\s-+directory" nil t
) t
))
739 (goto-char (point-min))
740 (setq res-symlink-target
741 (if (re-search-forward
742 "standard::symlink-target:\\s-+\\(\\S-+\\)" nil t
)
745 (goto-char (point-min))
747 (if (re-search-forward "unix::nlink:\\s-+\\([0-9]+\\)" nil t
)
748 (string-to-number (match-string 1)) 0))
750 (goto-char (point-min))
752 (or (if (eq id-format
'integer
)
753 (if (re-search-forward
754 "unix::uid:\\s-+\\([0-9]+\\)" nil t
)
755 (string-to-number (match-string 1)))
756 (if (re-search-forward
757 "owner::user:\\s-+\\(\\S-+\\)" nil t
)
759 (tramp-get-local-uid id-format
)))
761 (or (if (eq id-format
'integer
)
762 (if (re-search-forward
763 "unix::gid:\\s-+\\([0-9]+\\)" nil t
)
764 (string-to-number (match-string 1)))
765 (if (re-search-forward
766 "owner::group:\\s-+\\(\\S-+\\)" nil t
)
768 (tramp-get-local-gid id-format
)))
769 ;; ... last access, modification and change time
770 (goto-char (point-min))
772 (if (re-search-forward
773 "time::access:\\s-+\\([0-9]+\\)" nil t
)
774 (seconds-to-time (string-to-number (match-string 1)))
776 (goto-char (point-min))
778 (if (re-search-forward
779 "time::modified:\\s-+\\([0-9]+\\)" nil t
)
780 (seconds-to-time (string-to-number (match-string 1)))
782 (goto-char (point-min))
784 (if (re-search-forward
785 "time::changed:\\s-+\\([0-9]+\\)" nil t
)
786 (seconds-to-time (string-to-number (match-string 1)))
789 (goto-char (point-min))
791 (if (re-search-forward
792 "standard::size:\\s-+\\([0-9]+\\)" nil t
)
793 (string-to-number (match-string 1)) 0))
794 ;; ... file mode flags
795 (goto-char (point-min))
797 (if (re-search-forward "unix::mode:\\s-+\\([0-9]+\\)" nil t
)
798 (tramp-file-mode-from-int (match-string 1))
799 (if dirp
"drwx------" "-rwx------")))
800 ;; ... inode and device
801 (goto-char (point-min))
803 (if (re-search-forward "unix::inode:\\s-+\\([0-9]+\\)" nil t
)
804 (string-to-number (match-string 1))
805 (tramp-get-inode v
)))
806 (goto-char (point-min))
808 (if (re-search-forward "unix::device:\\s-+\\([0-9]+\\)" nil t
)
809 (string-to-number (match-string 1))
810 (tramp-get-device v
)))
812 ;; Return data gathered.
814 ;; 0. t for directory, string (name linked to) for
815 ;; symbolic link, or nil.
816 (or dirp res-symlink-target
)
817 ;; 1. Number of links to file.
823 ;; 4. Last access time, as a list of integers.
824 ;; 5. Last modification time, likewise.
825 ;; 6. Last status change time, likewise.
826 res-access res-mod res-change
827 ;; 7. Size in bytes (-1, if number is out of range).
831 ;; 9. t if file's gid would change if file were deleted
836 ;; 11. Device number.
840 (defun tramp-gvfs-handle-file-directory-p (filename)
841 "Like `file-directory-p' for Tramp files."
842 (eq t
(car (file-attributes filename
))))
844 (defun tramp-gvfs-handle-file-executable-p (filename)
845 "Like `file-executable-p' for Tramp files."
846 (with-parsed-tramp-file-name filename nil
847 (with-tramp-file-property v localname
"file-executable-p"
848 (tramp-check-cached-permissions v ?x
))))
850 (defun tramp-gvfs-handle-file-local-copy (filename)
851 "Like `file-local-copy' for Tramp files."
852 (with-parsed-tramp-file-name filename nil
853 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
854 (unless (file-exists-p filename
)
857 "Cannot make local copy of non-existing file `%s'" filename
))
858 (copy-file filename tmpfile t t
)
861 (defun tramp-gvfs-handle-file-name-all-completions (filename directory
)
862 "Like `file-name-all-completions' for Tramp files."
863 (unless (save-match-data (string-match "/" filename
))
864 (with-parsed-tramp-file-name (expand-file-name directory
) nil
871 ;; Try cache entries for filename, filename with last
872 ;; character removed, filename with last two characters
873 ;; removed, ..., and finally the empty string - all
874 ;; concatenated to the local directory name.
875 (let ((remote-file-name-inhibit-cache
876 (or remote-file-name-inhibit-cache
877 tramp-completion-reread-directory-timeout
)))
879 ;; This is inefficient for very long filenames, pity
880 ;; `reduce' is not available...
887 (tramp-get-file-property
889 (concat localname
(substring filename
0 x
))
890 "file-name-all-completions"
892 (when cache-hit
(list cache-hit
))))
893 ;; We cannot use a length of 0, because file properties
894 ;; for "foo" and "foo/" are identical.
895 (tramp-compat-number-sequence (length filename
) 1 -
1)))))
897 ;; Cache expired or no matching cache entry found so we need
898 ;; to perform a remote operation.
899 (let ((result '("." ".."))
901 ;; Get a list of directories and files.
902 (tramp-gvfs-send-command
903 v
"gvfs-ls" (tramp-gvfs-url-file-name directory
))
905 ;; Now grab the output.
907 (insert-buffer-substring (tramp-get-connection-buffer v
))
908 (goto-char (point-max))
909 (while (zerop (forward-line -
1))
910 (setq entry
(buffer-substring (point) (point-at-eol)))
911 (when (string-match filename entry
)
912 (if (file-directory-p (expand-file-name entry directory
))
913 (push (concat entry
"/") result
)
914 (push entry result
)))))
916 ;; Because the remote op went through OK we know the
917 ;; directory we `cd'-ed to exists.
918 (tramp-set-file-property v localname
"file-exists-p" t
)
920 ;; Because the remote op went through OK we know every
921 ;; file listed by `ls' exists.
922 (mapc (lambda (entry)
923 (tramp-set-file-property
924 v
(concat localname entry
) "file-exists-p" t
))
927 ;; Store result in the cache.
928 (tramp-set-file-property
929 v
(concat localname filename
)
930 "file-name-all-completions" result
))))))))
932 (defun tramp-gvfs-handle-file-notify-add-watch (file-name _flags _callback
)
933 "Like `file-notify-add-watch' for Tramp files."
934 (setq file-name
(expand-file-name file-name
))
935 (with-parsed-tramp-file-name file-name nil
936 (let ((p (start-process
937 "gvfs-monitor-file" (generate-new-buffer " *gvfs-monitor-file*")
938 "gvfs-monitor-file" (tramp-gvfs-url-file-name file-name
))))
939 (if (not (processp p
))
941 v
'file-notify-error
"gvfs-monitor-file failed to start")
943 v
6 "Run `%s', %S" (mapconcat 'identity
(process-command p
) " ") p
)
944 (tramp-set-connection-property p
"vector" v
)
945 (tramp-compat-set-process-query-on-exit-flag p nil
)
946 (set-process-filter p
'tramp-gvfs-file-gvfs-monitor-file-process-filter
)
947 (with-current-buffer (process-buffer p
)
948 (setq default-directory
(file-name-directory file-name
)))
951 (defun tramp-gvfs-file-gvfs-monitor-file-process-filter (proc string
)
952 "Read output from \"gvfs-monitor-file\" and add corresponding file-notify events."
953 (let* ((rest-string (tramp-compat-process-get proc
'rest-string
))
954 (dd (with-current-buffer (process-buffer proc
) default-directory
))
955 (ddu (regexp-quote (tramp-gvfs-url-file-name dd
))))
957 (tramp-message proc
10 "Previous string:\n%s" rest-string
))
958 (tramp-message proc
6 "%S\n%s" proc string
)
959 (setq string
(concat rest-string string
)
960 ;; Attribute change is returned in unused wording.
961 string
(tramp-compat-replace-regexp-in-string
962 "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string
))
966 "File Monitor Event:[\n\r]+"
967 "File = \\([^\n\r]+\\)[\n\r]+"
968 "Event = \\([^[:blank:]]+\\)[\n\r]+")
970 (let ((action (intern-soft
971 (tramp-compat-replace-regexp-in-string
972 "_" "-" (downcase (match-string 2 string
)))))
973 (file (match-string 1 string
)))
974 (setq string
(replace-match "" nil nil string
))
975 ;; File names are returned as URL paths. We must convert them.
976 (when (string-match ddu file
)
977 (setq file
(replace-match dd nil nil file
)))
978 (while (string-match "%\\([0-9A-F]\\{2\\}\\)" file
)
981 (char-to-string (string-to-number (match-string 1 file
) 16))
983 ;; Usually, we would add an Emacs event now. Unfortunately,
984 ;; `unread-command-events' does not accept several events at
985 ;; once. Therefore, we apply the callback directly.
986 (tramp-compat-funcall 'file-notify-callback
(list proc action file
))))
988 ;; Save rest of the string.
989 (when (zerop (length string
)) (setq string nil
))
990 (when string
(tramp-message proc
10 "Rest string:\n%s" string
))
991 (tramp-compat-process-put proc
'rest-string string
)))
993 (defun tramp-gvfs-handle-file-readable-p (filename)
994 "Like `file-readable-p' for Tramp files."
995 (with-parsed-tramp-file-name filename nil
996 (with-tramp-file-property v localname
"file-executable-p"
997 (tramp-check-cached-permissions v ?r
))))
999 (defun tramp-gvfs-handle-file-writable-p (filename)
1000 "Like `file-writable-p' for Tramp files."
1001 (with-parsed-tramp-file-name filename nil
1002 (with-tramp-file-property v localname
"file-writable-p"
1003 (if (file-exists-p filename
)
1004 (tramp-check-cached-permissions v ?w
)
1005 ;; If file doesn't exist, check if directory is writable.
1006 (and (file-directory-p (file-name-directory filename
))
1007 (file-writable-p (file-name-directory filename
)))))))
1009 (defun tramp-gvfs-handle-insert-directory
1010 (filename switches
&optional wildcard full-directory-p
)
1011 "Like `insert-directory' for Tramp files."
1012 ;; gvfs-* output is hard to parse. So we let `ls-lisp' do the job.
1013 (unless switches
(setq switches
""))
1014 (with-parsed-tramp-file-name (expand-file-name filename
) nil
1015 (with-tramp-progress-reporter v
0 (format "Opening directory %s" filename
)
1017 (let (ls-lisp-use-insert-directory-program)
1018 (tramp-run-real-handler
1020 (list filename switches wildcard full-directory-p
))))))
1022 (defun tramp-gvfs-handle-make-directory (dir &optional parents
)
1023 "Like `make-directory' for Tramp files."
1024 (with-parsed-tramp-file-name dir nil
1027 'tramp-gvfs-send-command v
"gvfs-mkdir"
1029 (list "-p" (tramp-gvfs-url-file-name dir
))
1030 (list (tramp-gvfs-url-file-name dir
))))
1031 ;; Propagate the error.
1032 (tramp-error v
'file-error
"Couldn't make directory %s" dir
))))
1034 (defun tramp-gvfs-handle-rename-file
1035 (filename newname
&optional ok-if-already-exists
)
1036 "Like `rename-file' for Tramp files."
1037 (with-parsed-tramp-file-name
1038 (if (tramp-tramp-file-p filename
) filename newname
) nil
1040 (when (and (not ok-if-already-exists
) (file-exists-p newname
))
1042 v
'file-already-exists
"File %s already exists" newname
))
1044 (if (or (and (tramp-tramp-file-p filename
)
1045 (not (tramp-gvfs-file-name-p filename
)))
1046 (and (tramp-tramp-file-p newname
)
1047 (not (tramp-gvfs-file-name-p newname
))))
1049 ;; We cannot move directly.
1050 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
1051 (rename-file filename tmpfile t
)
1052 (rename-file tmpfile newname ok-if-already-exists
))
1055 (with-tramp-progress-reporter
1056 v
0 (format "Renaming %s to %s" filename newname
)
1058 (tramp-gvfs-send-command
1060 (tramp-gvfs-url-file-name filename
)
1061 (tramp-gvfs-url-file-name newname
))
1062 ;; Propagate the error.
1063 (with-current-buffer (tramp-get-buffer v
)
1064 (goto-char (point-min))
1065 (tramp-error-with-buffer
1067 "Renaming failed, see buffer `%s' for details." (buffer-name)))))
1069 (when (tramp-tramp-file-p filename
)
1070 (with-parsed-tramp-file-name filename nil
1071 (tramp-flush-file-property v
(file-name-directory localname
))
1072 (tramp-flush-file-property v localname
)))
1074 (when (tramp-tramp-file-p newname
)
1075 (with-parsed-tramp-file-name newname nil
1076 (tramp-flush-file-property v
(file-name-directory localname
))
1077 (tramp-flush-file-property v localname
))))))
1079 (defun tramp-gvfs-handle-write-region
1080 (start end filename
&optional append visit lockname confirm
)
1081 "Like `write-region' for Tramp files."
1082 (with-parsed-tramp-file-name filename nil
1083 ;; XEmacs takes a coding system as the seventh argument, not `confirm'.
1084 (when (and (not (featurep 'xemacs
)) confirm
(file-exists-p filename
))
1085 (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename
))
1086 (tramp-error v
'file-error
"File not overwritten")))
1088 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
1089 (when (and append
(file-exists-p filename
))
1090 (copy-file filename tmpfile
'ok
))
1091 ;; We say `no-message' here because we don't want the visited file
1092 ;; modtime data to be clobbered from the temp file. We call
1093 ;; `set-visited-file-modtime' ourselves later on.
1094 (tramp-run-real-handler
1096 (if confirm
; don't pass this arg unless defined for backward compat.
1097 (list start end tmpfile append
'no-message lockname confirm
)
1098 (list start end tmpfile append
'no-message lockname
)))
1100 (rename-file tmpfile filename
'ok-if-already-exists
)
1102 (delete-file tmpfile
)
1104 v
'file-error
"Couldn't write region to `%s'" filename
))))
1106 (tramp-flush-file-property v
(file-name-directory localname
))
1107 (tramp-flush-file-property v localname
)
1109 ;; Set file modification time.
1110 (when (or (eq visit t
) (stringp visit
))
1111 (set-visited-file-modtime (nth 5 (file-attributes filename
))))
1114 (when (or (eq visit t
) (null visit
) (stringp visit
))
1115 (tramp-message v
0 "Wrote %s" filename
))
1116 (run-hooks 'tramp-handle-write-region-hook
)))
1119 ;; File name conversions.
1121 (defun tramp-gvfs-url-file-name (filename)
1122 "Return FILENAME in URL syntax."
1123 ;; "/" must NOT be hexlified.
1124 (let ((url-unreserved-chars (append '(?
/) url-unreserved-chars
))
1129 (if (tramp-tramp-file-p filename
)
1130 (with-parsed-tramp-file-name filename nil
1131 (when (and user
(string-match tramp-user-with-domain-regexp user
))
1133 (concat (match-string 2 user
) ";" (match-string 1 user
))))
1134 (url-parse-make-urlobj
1135 method
(url-hexify-string user
) nil
1136 (tramp-file-name-real-host v
) (tramp-file-name-port v
)
1137 (url-hexify-string localname
) nil nil t
))
1138 (url-parse-make-urlobj
1139 "file" nil nil nil nil
1140 (url-hexify-string (file-truename filename
)) nil nil t
))))
1141 (when (tramp-tramp-file-p filename
)
1142 (with-parsed-tramp-file-name filename nil
1143 (tramp-message v
10 "remote file `%s' is URL `%s'" filename result
)))
1146 (defun tramp-gvfs-object-path (filename)
1147 "Create a D-Bus object path from FILENAME."
1148 (expand-file-name (dbus-escape-as-identifier filename
) tramp-gvfs-path-tramp
))
1150 (defun tramp-gvfs-file-name (object-path)
1151 "Retrieve file name from D-Bus OBJECT-PATH."
1152 (dbus-unescape-from-identifier
1153 (tramp-compat-replace-regexp-in-string
1154 "^.*/\\([^/]+\\)$" "\\1" object-path
)))
1156 (defun tramp-bluez-address (device)
1157 "Return bluetooth device address from a given bluetooth DEVICE name."
1158 (when (stringp device
)
1159 (if (string-match tramp-ipv6-regexp device
)
1160 (match-string 0 device
)
1161 (cadr (assoc device
(tramp-bluez-list-devices))))))
1163 (defun tramp-bluez-device (address)
1164 "Return bluetooth device name from a given bluetooth device ADDRESS.
1165 ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1166 (when (stringp address
)
1167 (while (string-match "[][]" address
)
1168 (setq address
(replace-match "" t t address
)))
1170 (dolist (item (tramp-bluez-list-devices) result
)
1171 (when (string-match address
(cadr item
))
1172 (setq result
(car item
)))))))
1175 ;; D-Bus GVFS functions.
1177 (defun tramp-gvfs-handler-askpassword (message user domain flags
)
1178 "Implementation for the \"org.gtk.vfs.MountOperation.askPassword\" method."
1180 (tramp-gvfs-file-name (dbus-event-path-name last-input-event
)))
1184 (if (string-match "\\([pP]assword\\|[pP]assphrase\\)" message
)
1185 (capitalize (match-string 1 message
))
1191 (with-parsed-tramp-file-name filename l
1192 (when (and (zerop (length user
))
1194 (zerop (logand flags tramp-gvfs-password-need-username
))))
1195 (setq user
(read-string "User name: ")))
1196 (when (and (zerop (length domain
))
1197 (not (zerop (logand flags tramp-gvfs-password-need-domain
))))
1198 (setq domain
(read-string "Domain name: ")))
1200 (tramp-message l
6 "%S %S %S %d" message user domain flags
)
1201 (setq tramp-current-method l-method
1202 tramp-current-user user
1203 tramp-current-host l-host
1204 password
(tramp-read-passwd
1205 (tramp-get-connection-process l
) pw-prompt
))
1208 (if (stringp password
)
1210 t
;; password handled.
1211 nil
;; no abort of D-Bus.
1213 (tramp-file-name-real-user l
)
1215 nil
;; not anonymous.
1216 0) ;; no password save.
1217 ;; No password provided.
1218 (list nil t
"" (tramp-file-name-real-user l
) domain nil
0)))
1220 ;; When QUIT is raised, we shall return this information to D-Bus.
1221 (quit (list nil t
"" "" "" nil
0)))))
1223 (defun tramp-gvfs-handler-askquestion (message choices
)
1224 "Implementation for the \"org.gtk.vfs.MountOperation.askQuestion\" method."
1225 (save-window-excursion
1226 (let ((enable-recursive-minibuffers t
)
1230 (with-parsed-tramp-file-name
1231 (tramp-gvfs-file-name (dbus-event-path-name last-input-event
)) nil
1232 (tramp-message v
6 "%S %S" message choices
)
1234 ;; In theory, there can be several choices. Until now,
1235 ;; there is only the question whether to accept an unknown
1238 ;; Preserve message for `progress-reporter'.
1239 (tramp-compat-with-temp-message ""
1241 (pop-to-buffer (current-buffer))
1242 (setq choice
(if (yes-or-no-p (concat (car choices
) " ")) 0 1))
1243 (tramp-message v
6 "%d" choice
)))
1245 ;; When the choice is "no", we set a dummy fuse-mountpoint
1246 ;; in order to leave the timeout.
1247 (unless (zerop choice
)
1248 (tramp-set-file-property v
"/" "fuse-mountpoint" "/"))
1252 nil
;; no abort of D-Bus.
1255 ;; When QUIT is raised, we shall return this information to D-Bus.
1256 (quit (list nil t
0))))))
1258 (defun tramp-gvfs-handler-mounted-unmounted (mount-info)
1259 "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and
1260 \"org.gtk.vfs.MountTracker.unmounted\" signals."
1262 (let ((signal-name (dbus-event-member-name last-input-event
))
1264 ;; Jump over the first elements of the mount info. Since there
1265 ;; were changes in the entries, we cannot access dedicated
1267 (while (stringp (car elt
)) (setq elt
(cdr elt
)))
1268 (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt
)))
1269 (mount-spec (caddr elt
))
1270 (default-location (tramp-gvfs-dbus-byte-array-to-string
1272 (method (tramp-gvfs-dbus-byte-array-to-string
1273 (cadr (assoc "type" (cadr mount-spec
)))))
1274 (user (tramp-gvfs-dbus-byte-array-to-string
1275 (cadr (assoc "user" (cadr mount-spec
)))))
1276 (domain (tramp-gvfs-dbus-byte-array-to-string
1277 (cadr (assoc "domain" (cadr mount-spec
)))))
1278 (host (tramp-gvfs-dbus-byte-array-to-string
1279 (cadr (or (assoc "host" (cadr mount-spec
))
1280 (assoc "server" (cadr mount-spec
))))))
1281 (port (tramp-gvfs-dbus-byte-array-to-string
1282 (cadr (assoc "port" (cadr mount-spec
)))))
1283 (ssl (tramp-gvfs-dbus-byte-array-to-string
1284 (cadr (assoc "ssl" (cadr mount-spec
)))))
1285 (prefix (concat (tramp-gvfs-dbus-byte-array-to-string
1287 (tramp-gvfs-dbus-byte-array-to-string
1288 (cadr (assoc "share" (cadr mount-spec
)))))))
1289 (when (string-match "^smb" method
)
1290 (setq method
"smb"))
1291 (when (string-equal "obex" method
)
1292 (setq host
(tramp-bluez-device host
)))
1293 (when (and (string-equal "dav" method
) (string-equal "true" ssl
))
1294 (setq method
"davs"))
1295 (unless (zerop (length domain
))
1296 (setq user
(concat user tramp-prefix-domain-format domain
)))
1297 (unless (zerop (length port
))
1298 (setq host
(concat host tramp-prefix-port-format port
)))
1299 (with-parsed-tramp-file-name
1300 (tramp-make-tramp-file-name method user host
"") nil
1303 signal-name
(tramp-gvfs-stringify-dbus-message mount-info
))
1304 (tramp-set-file-property v
"/" "list-mounts" 'undef
)
1305 (if (string-equal (downcase signal-name
) "unmounted")
1306 (tramp-set-file-property v
"/" "fuse-mountpoint" nil
)
1307 ;; Set prefix, mountpoint and location.
1308 (unless (string-equal prefix
"/")
1309 (tramp-set-file-property v
"/" "prefix" prefix
))
1310 (tramp-set-file-property v
"/" "fuse-mountpoint" fuse-mountpoint
)
1311 (tramp-set-file-property
1312 v
"/" "default-location" default-location
)))))))
1314 (when tramp-gvfs-enabled
1315 (dbus-register-signal
1316 :session nil tramp-gvfs-path-mounttracker
1317 tramp-gvfs-interface-mounttracker
"mounted"
1318 'tramp-gvfs-handler-mounted-unmounted
)
1319 (dbus-register-signal
1320 :session nil tramp-gvfs-path-mounttracker
1321 tramp-gvfs-interface-mounttracker
"Mounted"
1322 'tramp-gvfs-handler-mounted-unmounted
)
1324 (dbus-register-signal
1325 :session nil tramp-gvfs-path-mounttracker
1326 tramp-gvfs-interface-mounttracker
"unmounted"
1327 'tramp-gvfs-handler-mounted-unmounted
)
1328 (dbus-register-signal
1329 :session nil tramp-gvfs-path-mounttracker
1330 tramp-gvfs-interface-mounttracker
"Unmounted"
1331 'tramp-gvfs-handler-mounted-unmounted
))
1333 (defun tramp-gvfs-connection-mounted-p (vec)
1334 "Check, whether the location is already mounted."
1336 (tramp-get-file-property vec
"/" "fuse-mountpoint" nil
)
1340 (with-tramp-file-property vec
"/" "list-mounts"
1341 (with-tramp-dbus-call-method vec t
1342 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1343 tramp-gvfs-interface-mounttracker tramp-gvfs-listmounts
))
1345 ;; Jump over the first elements of the mount info. Since there
1346 ;; were changes in the entries, we cannot access dedicated
1348 (while (stringp (car elt
)) (setq elt
(cdr elt
)))
1349 (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string
1351 (mount-spec (caddr elt
))
1352 (default-location (tramp-gvfs-dbus-byte-array-to-string
1354 (method (tramp-gvfs-dbus-byte-array-to-string
1355 (cadr (assoc "type" (cadr mount-spec
)))))
1356 (user (tramp-gvfs-dbus-byte-array-to-string
1357 (cadr (assoc "user" (cadr mount-spec
)))))
1358 (domain (tramp-gvfs-dbus-byte-array-to-string
1359 (cadr (assoc "domain" (cadr mount-spec
)))))
1360 (host (tramp-gvfs-dbus-byte-array-to-string
1361 (cadr (or (assoc "host" (cadr mount-spec
))
1362 (assoc "server" (cadr mount-spec
))))))
1363 (port (tramp-gvfs-dbus-byte-array-to-string
1364 (cadr (assoc "port" (cadr mount-spec
)))))
1365 (ssl (tramp-gvfs-dbus-byte-array-to-string
1366 (cadr (assoc "ssl" (cadr mount-spec
)))))
1367 (prefix (concat (tramp-gvfs-dbus-byte-array-to-string
1369 (tramp-gvfs-dbus-byte-array-to-string
1370 (cadr (assoc "share" (cadr mount-spec
)))))))
1371 (when (string-match "^smb" method
)
1372 (setq method
"smb"))
1373 (when (string-equal "obex" method
)
1374 (setq host
(tramp-bluez-device host
)))
1375 (when (and (string-equal "dav" method
) (string-equal "true" ssl
))
1376 (setq method
"davs"))
1377 (when (and (string-equal "synce" method
) (zerop (length user
)))
1378 (setq user
(or (tramp-file-name-user vec
) "")))
1379 (unless (zerop (length domain
))
1380 (setq user
(concat user tramp-prefix-domain-format domain
)))
1381 (unless (zerop (length port
))
1382 (setq host
(concat host tramp-prefix-port-format port
)))
1384 (string-equal method
(tramp-file-name-method vec
))
1385 (string-equal user
(or (tramp-file-name-user vec
) ""))
1386 (string-equal host
(tramp-file-name-host vec
))
1387 (string-match (concat "^" (regexp-quote prefix
))
1388 (tramp-file-name-localname vec
)))
1389 ;; Set prefix, mountpoint and location.
1390 (unless (string-equal prefix
"/")
1391 (tramp-set-file-property vec
"/" "prefix" prefix
))
1392 (tramp-set-file-property vec
"/" "fuse-mountpoint" fuse-mountpoint
)
1393 (tramp-set-file-property vec
"/" "default-location" default-location
)
1394 (throw 'mounted t
)))))))
1396 (defun tramp-gvfs-mount-spec-entry (key value
)
1397 "Construct a mount-spec entry to be used in a mount_spec.
1398 It was \"a(say)\", but has changed to \"a{sv})\"."
1399 (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature
)
1400 (list :dict-entry key
1401 (list :variant
(tramp-gvfs-dbus-string-to-byte-array value
)))
1402 (list :struct key
(tramp-gvfs-dbus-string-to-byte-array value
))))
1404 (defun tramp-gvfs-mount-spec (vec)
1405 "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"."
1406 (let* ((method (tramp-file-name-method vec
))
1407 (user (tramp-file-name-real-user vec
))
1408 (domain (tramp-file-name-domain vec
))
1409 (host (tramp-file-name-real-host vec
))
1410 (port (tramp-file-name-port vec
))
1411 (localname (tramp-file-name-localname vec
))
1412 (ssl (if (string-match "^davs" method
) "true" "false"))
1416 ((string-equal "smb" method
)
1417 (string-match "^/?\\([^/]+\\)" localname
)
1418 (list (tramp-gvfs-mount-spec-entry "type" "smb-share")
1419 (tramp-gvfs-mount-spec-entry "server" host
)
1420 (tramp-gvfs-mount-spec-entry
1421 "share" (match-string 1 localname
))))
1422 ((string-equal "obex" method
)
1423 (list (tramp-gvfs-mount-spec-entry "type" method
)
1424 (tramp-gvfs-mount-spec-entry
1425 "host" (concat "[" (tramp-bluez-address host
) "]"))))
1426 ((string-match "\\`dav" method
)
1427 (list (tramp-gvfs-mount-spec-entry "type" "dav")
1428 (tramp-gvfs-mount-spec-entry "host" host
)
1429 (tramp-gvfs-mount-spec-entry "ssl" ssl
)))
1431 (list (tramp-gvfs-mount-spec-entry "type" method
)
1432 (tramp-gvfs-mount-spec-entry "host" host
))))
1434 (list (tramp-gvfs-mount-spec-entry "user" user
)))
1436 (list (tramp-gvfs-mount-spec-entry "domain" domain
)))
1438 (list (tramp-gvfs-mount-spec-entry
1439 "port" (number-to-string port
))))))
1441 (if (and (string-match "\\`dav" method
)
1442 (string-match "^/?[^/]+" localname
))
1443 (match-string 0 localname
)
1447 `(:struct
,(tramp-gvfs-dbus-string-to-byte-array mount-pref
) ,mount-spec
)))
1450 ;; Connection functions.
1452 (defun tramp-gvfs-maybe-open-connection (vec)
1453 "Maybe open a connection VEC.
1454 Does not do anything if a connection is already open, but re-opens the
1455 connection if a previous connection has died for some reason."
1456 (tramp-check-proper-method-and-host vec
)
1458 ;; We set the file name, in case there are incoming D-Bus signals or
1460 (setq tramp-gvfs-dbus-event-vector vec
)
1462 ;; For password handling, we need a process bound to the connection
1463 ;; buffer. Therefore, we create a dummy process. Maybe there is a
1465 (unless (get-buffer-process (tramp-get-connection-buffer vec
))
1466 (let ((p (make-network-process
1467 :name
(tramp-buffer-name vec
)
1468 :buffer
(tramp-get-connection-buffer vec
)
1469 :server t
:host
'local
:service t
)))
1470 (tramp-compat-set-process-query-on-exit-flag p nil
)))
1472 (unless (tramp-gvfs-connection-mounted-p vec
)
1473 (let* ((method (tramp-file-name-method vec
))
1474 (user (tramp-file-name-user vec
))
1475 (host (tramp-file-name-host vec
))
1476 (localname (tramp-file-name-localname vec
))
1478 (tramp-gvfs-object-path
1479 (tramp-make-tramp-file-name method user host
""))))
1481 (when (and (string-equal method
"smb")
1482 (string-equal localname
"/"))
1483 (tramp-error vec
'file-error
"Filename must contain a Windows share"))
1485 (with-tramp-progress-reporter
1487 (if (zerop (length user
))
1488 (format "Opening connection for %s using %s" host method
)
1489 (format "Opening connection for %s@%s using %s" user host method
))
1491 ;; Enable auth-source and password-cache.
1492 (tramp-set-connection-property vec
"first-password-request" t
)
1494 ;; There will be a callback of "askPassword" when a password is
1496 (dbus-register-method
1497 :session dbus-service-emacs object-path
1498 tramp-gvfs-interface-mountoperation
"askPassword"
1499 'tramp-gvfs-handler-askpassword
)
1500 (dbus-register-method
1501 :session dbus-service-emacs object-path
1502 tramp-gvfs-interface-mountoperation
"AskPassword"
1503 'tramp-gvfs-handler-askpassword
)
1505 ;; There could be a callback of "askQuestion" when adding fingerprint.
1506 (dbus-register-method
1507 :session dbus-service-emacs object-path
1508 tramp-gvfs-interface-mountoperation
"askQuestion"
1509 'tramp-gvfs-handler-askquestion
)
1510 (dbus-register-method
1511 :session dbus-service-emacs object-path
1512 tramp-gvfs-interface-mountoperation
"AskQuestion"
1513 'tramp-gvfs-handler-askquestion
)
1515 ;; The call must be asynchronously, because of the "askPassword"
1516 ;; or "askQuestion"callbacks.
1517 (if (string-match "(so)$" tramp-gvfs-mountlocation-signature
)
1518 (with-tramp-dbus-call-method vec nil
1519 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1520 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1521 (tramp-gvfs-mount-spec vec
)
1522 `(:struct
:string
,(dbus-get-unique-name :session
)
1523 :object-path
,object-path
))
1524 (with-tramp-dbus-call-method vec nil
1525 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1526 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1527 (tramp-gvfs-mount-spec vec
)
1528 :string
(dbus-get-unique-name :session
) :object-path object-path
))
1530 ;; We must wait, until the mount is applied. This will be
1531 ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint"
1534 ((or (tramp-get-method-parameter method
'tramp-connection-timeout
)
1535 tramp-connection-timeout
)
1536 (if (zerop (length (tramp-file-name-user vec
)))
1539 "Timeout reached mounting %s using %s" host method
)
1542 "Timeout reached mounting %s@%s using %s" user host method
)))
1543 (while (not (tramp-get-file-property vec
"/" "fuse-mountpoint" nil
))
1544 (read-event nil nil
0.1)))
1546 ;; If `tramp-gvfs-handler-askquestion' has returned "No", it
1547 ;; is marked with the fuse-mountpoint "/". We shall react.
1549 (tramp-get-file-property vec
"/" "fuse-mountpoint" "") "/")
1550 (tramp-error vec
'file-error
"FUSE mount denied"))
1552 ;; In `tramp-check-cached-permissions', the connection
1553 ;; properties {uig,gid}-{integer,string} are used. We set
1554 ;; them to their local counterparts.
1555 (tramp-set-connection-property
1556 vec
"uid-integer" (tramp-get-local-uid 'integer
))
1557 (tramp-set-connection-property
1558 vec
"gid-integer" (tramp-get-local-gid 'integer
))
1559 (tramp-set-connection-property
1560 vec
"uid-string" (tramp-get-local-uid 'string
))
1561 (tramp-set-connection-property
1562 vec
"gid-string" (tramp-get-local-gid 'string
))))))
1564 (defun tramp-gvfs-send-command (vec command
&rest args
)
1565 "Send the COMMAND with its ARGS to connection VEC.
1566 COMMAND is usually a command from the gvfs-* utilities.
1567 `call-process' is applied, and it returns `t' if the return code is zero."
1569 (with-current-buffer (tramp-get-connection-buffer vec
)
1570 (tramp-gvfs-maybe-open-connection vec
)
1572 (tramp-message vec
6 "%s %s" command
(mapconcat 'identity args
" "))
1573 (setq result
(apply 'tramp-call-process command nil t nil args
))
1574 (tramp-message vec
6 "\n%s" (buffer-string))
1578 ;; D-Bus BLUEZ functions.
1580 (defun tramp-bluez-list-devices ()
1581 "Return all discovered bluetooth devices as list.
1582 Every entry is a list (NAME ADDRESS).
1584 If `tramp-bluez-discover-devices-timeout' is an integer, and the last
1585 discovery happened more time before indicated there, a rescan will be
1586 started, which lasts some ten seconds. Otherwise, cached results will
1588 ;; Reset the scanned devices list if time has passed.
1589 (and (integerp tramp-bluez-discover-devices-timeout
)
1590 (integerp tramp-bluez-discovery
)
1591 (> (tramp-time-diff (current-time) tramp-bluez-discovery
)
1592 tramp-bluez-discover-devices-timeout
)
1593 (setq tramp-bluez-devices nil
))
1595 ;; Rescan if needed.
1596 (unless tramp-bluez-devices
1598 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1599 :system tramp-bluez-service
"/"
1600 tramp-bluez-interface-manager
"DefaultAdapter")))
1601 (setq tramp-bluez-devices nil
1602 tramp-bluez-discovery t
)
1603 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil
1604 :system tramp-bluez-service object-path
1605 tramp-bluez-interface-adapter
"StartDiscovery")
1606 (while tramp-bluez-discovery
1607 (read-event nil nil
0.1))))
1608 (setq tramp-bluez-discovery
(current-time))
1609 (tramp-message tramp-gvfs-dbus-event-vector
10 "%s" tramp-bluez-devices
)
1610 tramp-bluez-devices
)
1612 (defun tramp-bluez-property-changed (property value
)
1613 "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal."
1614 (tramp-message tramp-gvfs-dbus-event-vector
6 "%s %s" property value
)
1616 ((string-equal property
"Discovering")
1618 ;; "Discovering" FALSE means discovery run has been completed.
1619 ;; We stop it, because we don't need another run.
1620 (setq tramp-bluez-discovery nil
)
1621 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1622 :system tramp-bluez-service
(dbus-event-path-name last-input-event
)
1623 tramp-bluez-interface-adapter
"StopDiscovery")))))
1625 (when tramp-gvfs-enabled
1626 (dbus-register-signal
1627 :system nil nil tramp-bluez-interface-adapter
"PropertyChanged"
1628 'tramp-bluez-property-changed
))
1630 (defun tramp-bluez-device-found (device args
)
1631 "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal."
1632 (tramp-message tramp-gvfs-dbus-event-vector
6 "%s %s" device args
)
1633 (let ((alias (car (cadr (assoc "Alias" args
))))
1634 (address (car (cadr (assoc "Address" args
)))))
1635 ;; Maybe we shall check the device class for being a proper
1636 ;; device, and call also SDP in order to find the obex service.
1637 (add-to-list 'tramp-bluez-devices
(list alias address
))))
1639 (when tramp-gvfs-enabled
1640 (dbus-register-signal
1641 :system nil nil tramp-bluez-interface-adapter
"DeviceFound"
1642 'tramp-bluez-device-found
))
1644 (defun tramp-bluez-parse-device-names (_ignore)
1645 "Return a list of (nil host) tuples allowed to access."
1647 (lambda (x) (list nil
(car x
)))
1648 (tramp-bluez-list-devices)))
1650 ;; Add completion function for OBEX method.
1651 (when (and tramp-gvfs-enabled
1652 (member tramp-bluez-service
(dbus-list-known-names :system
)))
1653 (tramp-set-completion-function
1654 "obex" '((tramp-bluez-parse-device-names ""))))
1657 ;; D-Bus zeroconf functions.
1659 (defun tramp-zeroconf-parse-workstation-device-names (_ignore)
1660 "Return a list of (user host) tuples allowed to access."
1663 (list nil
(zeroconf-service-host x
)))
1664 (zeroconf-list-services "_workstation._tcp")))
1666 (defun tramp-zeroconf-parse-webdav-device-names (_ignore)
1667 "Return a list of (user host) tuples allowed to access."
1670 (let ((host (zeroconf-service-host x
))
1671 (port (zeroconf-service-port x
))
1672 (text (zeroconf-service-txt x
))
1675 (setq host
(format "%s%s%d" host tramp-prefix-port-regexp port
)))
1676 ;; A user is marked in a TXT field like "u=guest".
1678 (when (string-match "u=\\(.+\\)$" (car text
))
1679 (setq user
(match-string 1 (car text
))))
1680 (setq text
(cdr text
)))
1682 (zeroconf-list-services "_webdav._tcp")))
1684 ;; Add completion function for DAV and DAVS methods.
1685 (when (and tramp-gvfs-enabled
1686 (member zeroconf-service-avahi
(dbus-list-known-names :system
)))
1687 (zeroconf-init tramp-gvfs-zeroconf-domain
)
1688 (tramp-set-completion-function
1689 "sftp" '((tramp-zeroconf-parse-workstation-device-names "")))
1690 (tramp-set-completion-function
1691 "dav" '((tramp-zeroconf-parse-webdav-device-names "")))
1692 (tramp-set-completion-function
1693 "davs" '((tramp-zeroconf-parse-webdav-device-names ""))))
1696 ;; D-Bus SYNCE functions.
1698 (defun tramp-synce-list-devices ()
1699 "Return all discovered synce devices as list.
1700 They are retrieved from the hal daemon."
1701 (let (tramp-synce-devices)
1703 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1704 :system tramp-hal-service tramp-hal-path-manager
1705 tramp-hal-interface-manager
"GetAllDevices"))
1706 (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1707 :system tramp-hal-service device tramp-hal-interface-device
1708 "PropertyExists" "sync.plugin")
1710 (with-tramp-dbus-call-method
1711 tramp-gvfs-dbus-event-vector t
1712 :system tramp-hal-service device tramp-hal-interface-device
1713 "GetPropertyString" "pda.pocketpc.name")))
1714 (unless (member prop tramp-synce-devices
)
1715 (push prop tramp-synce-devices
)))))
1716 (tramp-message tramp-gvfs-dbus-event-vector
10 "%s" tramp-synce-devices
)
1717 tramp-synce-devices
))
1719 (defun tramp-synce-parse-device-names (_ignore)
1720 "Return a list of (nil host) tuples allowed to access."
1722 (lambda (x) (list nil x
))
1723 (tramp-synce-list-devices)))
1725 ;; Add completion function for SYNCE method.
1726 (when tramp-gvfs-enabled
1727 (tramp-set-completion-function
1728 "synce" '((tramp-synce-parse-device-names ""))))
1730 (add-hook 'tramp-unload-hook
1732 (unload-feature 'tramp-gvfs
'force
)))
1734 (provide 'tramp-gvfs
)
1738 ;; * Host name completion via smb-server or smb-network.
1739 ;; * Check how two shares of the same SMB server can be mounted in
1741 ;; * Apply SDP on bluetooth devices, in order to filter out obex
1743 ;; * Implement obex for other serial communication but bluetooth.
1745 ;;; tramp-gvfs.el ends here