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", "sftp" and "synce". Note that with "obex" it might
53 ;; be 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" and "smb". When one of
58 ;; these methods is added to the list, the remote access for that
59 ;; method is performed via GVFS instead of the native Tramp
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.
113 (defcustom tramp-gvfs-methods
'("dav" "davs" "obex" "sftp" "synce")
114 "List of methods for remote files, accessed with GVFS."
117 :type
'(repeat (choice (const "dav")
125 ;; Add a default for `tramp-default-user-alist'. Rule: For the SYNCE
126 ;; method, no user is chosen.
128 (add-to-list 'tramp-default-user-alist
'("\\`synce\\'" nil nil
))
130 (defcustom tramp-gvfs-zeroconf-domain
"local"
131 "Zeroconf domain to be used for discovering services, like host names."
136 ;; Add the methods to `tramp-methods', in order to allow minibuffer
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
)))))
144 (defconst tramp-gvfs-path-tramp
(concat dbus-path-emacs
"/Tramp")
145 "The preceding object path for own objects.")
147 (defconst tramp-gvfs-service-daemon
"org.gtk.vfs.Daemon"
148 "The well known name of the GVFS daemon.")
150 ;; D-Bus integration is available since Emacs 23 on some system types.
151 ;; We don't call `dbus-ping', because this would load dbus.el.
152 (defconst tramp-gvfs-enabled
154 (and (featurep 'dbusbind
)
155 (tramp-compat-funcall 'dbus-get-unique-name
:system
)
156 (tramp-compat-funcall 'dbus-get-unique-name
:session
)
157 (or (tramp-compat-process-running-p "gvfs-fuse-daemon")
158 (tramp-compat-process-running-p "gvfsd-fuse"))))
159 "Non-nil when GVFS is available.")
161 (defconst tramp-gvfs-path-mounttracker
"/org/gtk/vfs/mounttracker"
162 "The object path of the GVFS daemon.")
164 (defconst tramp-gvfs-interface-mounttracker
"org.gtk.vfs.MountTracker"
165 "The mount tracking interface in the GVFS daemon.")
167 ;; Introspection data exist since GVFS 1.14. If there are no such
168 ;; data, we expect an earlier interface.
169 (defconst tramp-gvfs-methods-mounttracker
170 (and tramp-gvfs-enabled
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 (and tramp-gvfs-enabled
192 (dbus-introspect-get-signature
193 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
194 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
))
195 "The D-Bus signature of the \"mountLocation\" method.
196 It has been changed in GVFS 1.14.")
198 ;; <interface name='org.gtk.vfs.MountTracker'>
199 ;; <method name='listMounts'>
200 ;; <arg name='mount_info_list'
201 ;; type='a{sosssssbay{aya{say}}ay}'
204 ;; <method name='mountLocation'>
205 ;; <arg name='mount_spec' type='{aya{say}}' direction='in'/>
206 ;; <arg name='dbus_id' type='s' direction='in'/>
207 ;; <arg name='object_path' type='o' direction='in'/>
209 ;; <signal name='mounted'>
210 ;; <arg name='mount_info'
211 ;; type='{sosssssbay{aya{say}}ay}'/>
213 ;; <signal name='unmounted'>
214 ;; <arg name='mount_info'
215 ;; type='{sosssssbay{aya{say}}ay}'/>
221 ;; OBJECT_PATH object_path
222 ;; STRING display_name
223 ;; STRING stable_name
224 ;; STRING x_content_types Since GVFS 1.0 only !!!
226 ;; STRING preferred_filename_encoding
227 ;; BOOLEAN user_visible
228 ;; ARRAY BYTE fuse_mountpoint
230 ;; ARRAY BYTE mount_prefix
232 ;; STRUCT mount_spec_item
233 ;; STRING key (server, share, type, user, host, port)
235 ;; ARRAY BYTE default_location Since GVFS 1.5 only !!!
237 (defconst tramp-gvfs-interface-mountoperation
"org.gtk.vfs.MountOperation"
238 "Used by the dbus-proxying implementation of GMountOperation.")
240 ;; <interface name='org.gtk.vfs.MountOperation'>
241 ;; <method name='askPassword'>
242 ;; <arg name='message' type='s' direction='in'/>
243 ;; <arg name='default_user' type='s' direction='in'/>
244 ;; <arg name='default_domain' type='s' direction='in'/>
245 ;; <arg name='flags' type='u' direction='in'/>
246 ;; <arg name='handled' type='b' direction='out'/>
247 ;; <arg name='aborted' type='b' direction='out'/>
248 ;; <arg name='password' type='s' direction='out'/>
249 ;; <arg name='username' type='s' direction='out'/>
250 ;; <arg name='domain' type='s' direction='out'/>
251 ;; <arg name='anonymous' type='b' direction='out'/>
252 ;; <arg name='password_save' type='u' direction='out'/>
254 ;; <method name='askQuestion'>
255 ;; <arg name='message' type='s' direction='in'/>
256 ;; <arg name='choices' type='as' direction='in'/>
257 ;; <arg name='handled' type='b' direction='out'/>
258 ;; <arg name='aborted' type='b' direction='out'/>
259 ;; <arg name='choice' type='u' direction='out'/>
263 ;; The following flags are used in "askPassword". They are defined in
264 ;; /usr/include/glib-2.0/gio/gioenums.h.
266 (defconst tramp-gvfs-password-need-password
1
267 "Operation requires a password.")
269 (defconst tramp-gvfs-password-need-username
2
270 "Operation requires a username.")
272 (defconst tramp-gvfs-password-need-domain
4
273 "Operation requires a domain.")
275 (defconst tramp-gvfs-password-saving-supported
8
276 "Operation supports saving settings.")
278 (defconst tramp-gvfs-password-anonymous-supported
16
279 "Operation supports anonymous users.")
281 (defconst tramp-bluez-service
"org.bluez"
282 "The well known name of the BLUEZ service.")
284 (defconst tramp-bluez-interface-manager
"org.bluez.Manager"
285 "The manager interface of the BLUEZ daemon.")
287 ;; <interface name='org.bluez.Manager'>
288 ;; <method name='DefaultAdapter'>
289 ;; <arg type='o' direction='out'/>
291 ;; <method name='FindAdapter'>
292 ;; <arg type='s' direction='in'/>
293 ;; <arg type='o' direction='out'/>
295 ;; <method name='ListAdapters'>
296 ;; <arg type='ao' direction='out'/>
298 ;; <signal name='AdapterAdded'>
301 ;; <signal name='AdapterRemoved'>
304 ;; <signal name='DefaultAdapterChanged'>
309 (defconst tramp-bluez-interface-adapter
"org.bluez.Adapter"
310 "The adapter interface of the BLUEZ daemon.")
312 ;; <interface name='org.bluez.Adapter'>
313 ;; <method name='GetProperties'>
314 ;; <arg type='a{sv}' direction='out'/>
316 ;; <method name='SetProperty'>
317 ;; <arg type='s' direction='in'/>
318 ;; <arg type='v' direction='in'/>
320 ;; <method name='RequestMode'>
321 ;; <arg type='s' direction='in'/>
323 ;; <method name='ReleaseMode'/>
324 ;; <method name='RequestSession'/>
325 ;; <method name='ReleaseSession'/>
326 ;; <method name='StartDiscovery'/>
327 ;; <method name='StopDiscovery'/>
328 ;; <method name='ListDevices'>
329 ;; <arg type='ao' direction='out'/>
331 ;; <method name='CreateDevice'>
332 ;; <arg type='s' direction='in'/>
333 ;; <arg type='o' direction='out'/>
335 ;; <method name='CreatePairedDevice'>
336 ;; <arg type='s' direction='in'/>
337 ;; <arg type='o' direction='in'/>
338 ;; <arg type='s' direction='in'/>
339 ;; <arg type='o' direction='out'/>
341 ;; <method name='CancelDeviceCreation'>
342 ;; <arg type='s' direction='in'/>
344 ;; <method name='RemoveDevice'>
345 ;; <arg type='o' direction='in'/>
347 ;; <method name='FindDevice'>
348 ;; <arg type='s' direction='in'/>
349 ;; <arg type='o' direction='out'/>
351 ;; <method name='RegisterAgent'>
352 ;; <arg type='o' direction='in'/>
353 ;; <arg type='s' direction='in'/>
355 ;; <method name='UnregisterAgent'>
356 ;; <arg type='o' direction='in'/>
358 ;; <signal name='DeviceCreated'>
361 ;; <signal name='DeviceRemoved'>
364 ;; <signal name='DeviceFound'>
366 ;; <arg type='a{sv}'/>
368 ;; <signal name='PropertyChanged'>
372 ;; <signal name='DeviceDisappeared'>
377 (defcustom tramp-bluez-discover-devices-timeout
60
378 "Defines seconds since last bluetooth device discovery before rescanning.
379 A value of 0 would require an immediate discovery during hostname
380 completion, nil means to use always cached values for discovered
384 :type
'(choice (const nil
) integer
))
386 (defvar tramp-bluez-discovery nil
387 "Indicator for a running bluetooth device discovery.
388 It keeps the timestamp of last discovery.")
390 (defvar tramp-bluez-devices nil
391 "Alist of detected bluetooth devices.
392 Every entry is a list (NAME ADDRESS).")
394 (defconst tramp-hal-service
"org.freedesktop.Hal"
395 "The well known name of the HAL service.")
397 (defconst tramp-hal-path-manager
"/org/freedesktop/Hal/Manager"
398 "The object path of the HAL daemon manager.")
400 (defconst tramp-hal-interface-manager
"org.freedesktop.Hal.Manager"
401 "The manager interface of the HAL daemon.")
403 (defconst tramp-hal-interface-device
"org.freedesktop.Hal.Device"
404 "The device interface of the HAL daemon.")
407 ;; New handlers should be added here.
408 (defconst tramp-gvfs-file-name-handler-alist
409 '((access-file . ignore
)
410 (add-name-to-file . tramp-gvfs-handle-copy-file
)
411 ;; `byte-compiler-base-file-name' performed by default handler.
412 ;; `copy-directory' performed by default handler.
413 (copy-file . tramp-gvfs-handle-copy-file
)
414 (delete-directory . tramp-gvfs-handle-delete-directory
)
415 (delete-file . tramp-gvfs-handle-delete-file
)
416 ;; `diff-latest-backup-file' performed by default handler.
417 (directory-file-name . tramp-handle-directory-file-name
)
418 (directory-files . tramp-handle-directory-files
)
419 (directory-files-and-attributes
420 . tramp-handle-directory-files-and-attributes
)
421 (dired-call-process . ignore
)
422 (dired-compress-file . ignore
)
423 (dired-uncache . tramp-handle-dired-uncache
)
424 (expand-file-name . tramp-gvfs-handle-expand-file-name
)
425 (file-accessible-directory-p . tramp-handle-file-accessible-directory-p
)
427 (file-attributes . tramp-gvfs-handle-file-attributes
)
428 (file-directory-p . tramp-gvfs-handle-file-directory-p
)
429 ;; `file-equal-p' performed by default handler.
430 (file-executable-p . tramp-gvfs-handle-file-executable-p
)
431 (file-exists-p . tramp-handle-file-exists-p
)
432 ;; `file-in-directory-p' performed by default handler.
433 (file-local-copy . tramp-gvfs-handle-file-local-copy
)
434 (file-modes . tramp-handle-file-modes
)
435 (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions
)
436 (file-name-as-directory . tramp-handle-file-name-as-directory
)
437 (file-name-completion . tramp-handle-file-name-completion
)
438 (file-name-directory . tramp-handle-file-name-directory
)
439 (file-name-nondirectory . tramp-handle-file-name-nondirectory
)
440 ;; `file-name-sans-versions' performed by default handler.
441 (file-newer-than-file-p . tramp-handle-file-newer-than-file-p
)
442 (file-notify-add-watch . tramp-gvfs-handle-file-notify-add-watch
)
443 (file-notify-rm-watch . tramp-handle-file-notify-rm-watch
)
444 (file-ownership-preserved-p . ignore
)
445 (file-readable-p . tramp-gvfs-handle-file-readable-p
)
446 (file-regular-p . tramp-handle-file-regular-p
)
447 (file-remote-p . tramp-handle-file-remote-p
)
448 (file-selinux-context . ignore
)
449 (file-symlink-p . tramp-handle-file-symlink-p
)
450 ;; `file-truename' performed by default handler.
451 (file-writable-p . tramp-gvfs-handle-file-writable-p
)
452 (find-backup-file-name . tramp-handle-find-backup-file-name
)
453 ;; `find-file-noselect' performed by default handler.
454 ;; `get-file-buffer' performed by default handler.
455 (insert-directory . tramp-handle-insert-directory
)
456 (insert-file-contents . tramp-handle-insert-file-contents
)
457 (load . tramp-handle-load
)
458 (make-auto-save-file-name . tramp-handle-make-auto-save-file-name
)
459 (make-directory . tramp-gvfs-handle-make-directory
)
460 (make-directory-internal . ignore
)
461 (make-symbolic-link . tramp-handle-make-symbolic-link
)
462 (process-file . ignore
)
463 (rename-file . tramp-gvfs-handle-rename-file
)
464 (set-file-acl . ignore
)
465 (set-file-modes . ignore
)
466 (set-file-selinux-context . ignore
)
467 (set-file-times . ignore
)
468 (set-visited-file-modtime . tramp-handle-set-visited-file-modtime
)
469 (shell-command . ignore
)
470 (start-file-process . ignore
)
471 (substitute-in-file-name . tramp-handle-substitute-in-file-name
)
472 (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory
)
473 (vc-registered . ignore
)
474 (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime
)
475 (write-region . tramp-gvfs-handle-write-region
))
476 "Alist of handler functions for Tramp GVFS method.
477 Operations not mentioned here will be handled by the default Emacs primitives.")
479 ;; It must be a `defsubst' in order to push the whole code into
480 ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading.
482 (defsubst tramp-gvfs-file-name-p
(filename)
483 "Check if it's a filename handled by the GVFS daemon."
484 (and (tramp-tramp-file-p filename
)
486 (tramp-file-name-method (tramp-dissect-file-name filename
))))
487 (and (stringp method
) (member method tramp-gvfs-methods
)))))
490 (defun tramp-gvfs-file-name-handler (operation &rest args
)
491 "Invoke the GVFS related OPERATION.
492 First arg specifies the OPERATION, second arg is a list of arguments to
493 pass to the OPERATION."
494 (unless tramp-gvfs-enabled
495 (tramp-user-error nil
"Package `tramp-gvfs' not supported"))
496 (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist
)))
498 (save-match-data (apply (cdr fn
) args
))
499 (tramp-run-real-handler operation args
))))
501 ;; This might be moved to tramp.el. It shall be the first file name
504 (when (featurep 'dbusbind
)
505 (add-to-list 'tramp-foreign-file-name-handler-alist
506 (cons 'tramp-gvfs-file-name-p
'tramp-gvfs-file-name-handler
)))
509 ;; D-Bus helper function.
511 (defun tramp-gvfs-dbus-string-to-byte-array (string)
512 "Like `dbus-string-to-byte-array' but add trailing \\0 if needed."
513 (dbus-string-to-byte-array
514 (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature
)
515 (concat string
(string 0)) string
)))
517 (defun tramp-gvfs-dbus-byte-array-to-string (byte-array)
518 "Like `dbus-byte-array-to-string' but remove trailing \\0 if exists."
519 ;; The byte array could be a variant. Take care.
521 (if (and (consp byte-array
) (atom (car byte-array
)))
522 byte-array
(car byte-array
))))
523 (dbus-byte-array-to-string
524 (if (and (consp byte-array
) (zerop (car (last byte-array
))))
525 (butlast byte-array
) byte-array
))))
527 (defun tramp-gvfs-stringify-dbus-message (message)
528 "Convert a D-Bus message into readable UTF8 strings, used for traces."
530 ((and (consp message
) (characterp (car message
)))
531 (format "%S" (tramp-gvfs-dbus-byte-array-to-string message
)))
533 (mapcar 'tramp-gvfs-stringify-dbus-message message
))
535 (format "%S" message
))
538 (defmacro with-tramp-dbus-call-method
539 (vec synchronous bus service path interface method
&rest args
)
540 "Apply a D-Bus call on bus BUS.
542 If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise,
543 it is an asynchronous call, with `ignore' as callback function.
545 The other arguments have the same meaning as with `dbus-call-method'
546 or `dbus-call-method-asynchronously'. Additionally, the call
547 will be traced by Tramp with trace level 6."
548 `(let ((func (if ,synchronous
549 'dbus-call-method
'dbus-call-method-asynchronously
))
550 (args (append (list ,bus
,service
,path
,interface
,method
)
551 (if ,synchronous
(list ,@args
) (list 'ignore
,@args
))))
553 (tramp-message ,vec
6 "%s %s" func args
)
554 (setq result
(apply func args
))
555 (tramp-message ,vec
6 "%s" (tramp-gvfs-stringify-dbus-message result
))
558 (put 'with-tramp-dbus-call-method
'lisp-indent-function
2)
559 (put 'with-tramp-dbus-call-method
'edebug-form-spec
'(form symbolp body
))
560 (tramp-compat-font-lock-add-keywords
561 'emacs-lisp-mode
'("\\<with-tramp-dbus-call-method\\>"))
563 (defvar tramp-gvfs-dbus-event-vector nil
564 "Current Tramp file name to be used, as vector.
565 It is needed when D-Bus signals or errors arrive, because there
566 is no information where to trace the message.")
568 (defun tramp-gvfs-dbus-event-error (event err
)
569 "Called when a D-Bus error message arrives, see `dbus-event-error-functions'."
570 (when tramp-gvfs-dbus-event-vector
571 (tramp-message tramp-gvfs-dbus-event-vector
10 "%S" event
)
572 (tramp-error tramp-gvfs-dbus-event-vector
'file-error
"%s" (cadr err
))))
574 ;; `dbus-event-error-hooks' has been renamed to `dbus-event-error-functions'.
576 (if (boundp 'dbus-event-error-functions
)
577 'dbus-event-error-functions
'dbus-event-error-hooks
)
578 'tramp-gvfs-dbus-event-error
)
581 ;; File name primitives.
583 (defun tramp-gvfs-handle-copy-file
584 (filename newname
&optional ok-if-already-exists keep-date
585 preserve-uid-gid preserve-extended-attributes
)
586 "Like `copy-file' for Tramp files."
587 (with-parsed-tramp-file-name
588 (if (tramp-tramp-file-p filename
) filename newname
) nil
590 (when (and (not ok-if-already-exists
) (file-exists-p newname
))
592 v
'file-already-exists
"File %s already exists" newname
))
594 (if (or (and (tramp-tramp-file-p filename
)
595 (not (tramp-gvfs-file-name-p filename
)))
596 (and (tramp-tramp-file-p newname
)
597 (not (tramp-gvfs-file-name-p newname
))))
599 ;; We cannot call `copy-file' directly. Use
600 ;; `tramp-compat-funcall' for backward compatibility (number
602 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
604 (preserve-extended-attributes
605 (tramp-compat-funcall
607 filename tmpfile t keep-date preserve-uid-gid
608 preserve-extended-attributes
))
610 (tramp-compat-funcall
611 'copy-file filename tmpfile t keep-date preserve-uid-gid
))
613 (copy-file filename tmpfile t keep-date
)))
614 (rename-file tmpfile newname ok-if-already-exists
))
617 (with-tramp-progress-reporter
618 v
0 (format "Copying %s to %s" filename newname
)
621 (append (if (or keep-date preserve-uid-gid
)
625 (tramp-gvfs-url-file-name filename
)
626 (tramp-gvfs-url-file-name newname
)))))
627 (apply 'tramp-gvfs-send-command v
"gvfs-copy" args
))
628 ;; Propagate the error.
629 (with-current-buffer (tramp-get-connection-buffer v
)
630 (goto-char (point-min))
631 (tramp-error-with-buffer
633 "Copying failed, see buffer `%s' for details." (buffer-name)))))
635 (when (tramp-tramp-file-p newname
)
636 (with-parsed-tramp-file-name newname nil
637 (tramp-flush-file-property v
(file-name-directory localname
))
638 (tramp-flush-file-property v localname
))))))
640 (defun tramp-gvfs-handle-delete-directory (directory &optional recursive trash
)
641 "Like `delete-directory' for Tramp files."
642 (when (and recursive
(not (file-symlink-p directory
)))
644 (if (eq t
(car (file-attributes file
)))
645 (tramp-compat-delete-directory file recursive trash
)
646 (tramp-compat-delete-file file trash
)))
648 directory
'full
"^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
649 (with-parsed-tramp-file-name directory nil
650 (tramp-flush-file-property v
(file-name-directory localname
))
651 (tramp-flush-directory-property v localname
)
653 (tramp-gvfs-send-command
654 v
(if (and trash delete-by-moving-to-trash
) "gvfs-trash" "gvfs-rm")
655 (tramp-gvfs-url-file-name directory
))
656 ;; Propagate the error.
657 (with-current-buffer (tramp-get-connection-buffer v
)
658 (goto-char (point-min))
659 (tramp-error-with-buffer
660 nil v
'file-error
"Couldn't delete %s" directory
)))))
662 (defun tramp-gvfs-handle-delete-file (filename &optional trash
)
663 "Like `delete-file' for Tramp files."
664 (with-parsed-tramp-file-name filename nil
665 (tramp-flush-file-property v
(file-name-directory localname
))
666 (tramp-flush-file-property v localname
)
668 (tramp-gvfs-send-command
669 v
(if (and trash delete-by-moving-to-trash
) "gvfs-trash" "gvfs-rm")
670 (tramp-gvfs-url-file-name filename
))
671 ;; Propagate the error.
672 (with-current-buffer (tramp-get-connection-buffer v
)
673 (goto-char (point-min))
674 (tramp-error-with-buffer
675 nil v
'file-error
"Couldn't delete %s" filename
)))))
677 (defun tramp-gvfs-handle-expand-file-name (name &optional dir
)
678 "Like `expand-file-name' for Tramp files."
679 ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
680 (setq dir
(or dir default-directory
"/"))
681 ;; Unless NAME is absolute, concat DIR and NAME.
682 (unless (file-name-absolute-p name
)
683 (setq name
(concat (file-name-as-directory dir
) name
)))
684 ;; If NAME is not a Tramp file, run the real handler.
685 (if (not (tramp-tramp-file-p name
))
686 (tramp-run-real-handler 'expand-file-name
(list name nil
))
688 (with-parsed-tramp-file-name name nil
689 ;; If there is a default location, expand tilde.
690 (when (string-match "\\`\\(~\\)\\(/\\|\\'\\)" localname
)
692 (tramp-gvfs-maybe-open-connection (vector method user host
"/" hop
)))
695 (tramp-get-file-property v
"/" "default-location" "~")
697 ;; Tilde expansion is not possible.
698 (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname
)
701 "Cannot expand tilde in file `%s'" name
))
702 (unless (tramp-run-real-handler 'file-name-absolute-p
(list localname
))
703 (setq localname
(concat "/" localname
)))
704 ;; We do not pass "/..".
705 (if (string-equal "smb" method
)
706 (when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname
)
707 (setq localname
(replace-match "/" t t localname
1)))
708 (when (string-match "^/\\.\\./?" localname
)
709 (setq localname
(replace-match "/" t t localname
))))
710 ;; There might be a double slash. Remove this.
711 (while (string-match "//" localname
)
712 (setq localname
(replace-match "/" t t localname
)))
713 ;; No tilde characters in file name, do normal
714 ;; `expand-file-name' (this does "/./" and "/../").
715 (tramp-make-tramp-file-name
717 (tramp-run-real-handler
718 'expand-file-name
(list localname
))))))
720 (defun tramp-gvfs-handle-file-attributes (filename &optional id-format
)
721 "Like `file-attributes' for Tramp files."
722 (unless id-format
(setq id-format
'integer
))
723 ;; Don't modify `last-coding-system-used' by accident.
724 (let ((last-coding-system-used last-coding-system-used
)
725 dirp res-symlink-target res-numlinks res-uid res-gid res-access
726 res-mod res-change res-size res-filemodes res-inode res-device
)
727 (with-parsed-tramp-file-name filename nil
728 (with-tramp-file-property
729 v localname
(format "file-attributes-%s" id-format
)
730 (tramp-message v
5 "file attributes: %s" localname
)
731 (tramp-gvfs-send-command
732 v
"gvfs-info" (tramp-gvfs-url-file-name filename
))
734 (with-current-buffer (tramp-get-connection-buffer v
)
735 (goto-char (point-min))
736 (when (re-search-forward "attributes:" nil t
)
737 ;; ... directory or symlink
738 (goto-char (point-min))
739 (setq dirp
(if (re-search-forward "type:\\s-+directory" nil t
) t
))
740 (goto-char (point-min))
741 (setq res-symlink-target
742 (if (re-search-forward
743 "standard::symlink-target:\\s-+\\(\\S-+\\)" nil t
)
746 (goto-char (point-min))
748 (if (re-search-forward "unix::nlink:\\s-+\\([0-9]+\\)" nil t
)
749 (string-to-number (match-string 1)) 0))
751 (goto-char (point-min))
753 (or (if (eq id-format
'integer
)
754 (if (re-search-forward
755 "unix::uid:\\s-+\\([0-9]+\\)" nil t
)
756 (string-to-number (match-string 1)))
757 (if (re-search-forward
758 "owner::user:\\s-+\\(\\S-+\\)" nil t
)
760 (tramp-get-local-uid id-format
)))
762 (or (if (eq id-format
'integer
)
763 (if (re-search-forward
764 "unix::gid:\\s-+\\([0-9]+\\)" nil t
)
765 (string-to-number (match-string 1)))
766 (if (re-search-forward
767 "owner::group:\\s-+\\(\\S-+\\)" nil t
)
769 (tramp-get-local-gid id-format
)))
770 ;; ... last access, modification and change time
771 (goto-char (point-min))
773 (if (re-search-forward
774 "time::access:\\s-+\\([0-9]+\\)" nil t
)
775 (seconds-to-time (string-to-number (match-string 1)))
777 (goto-char (point-min))
779 (if (re-search-forward
780 "time::modified:\\s-+\\([0-9]+\\)" nil t
)
781 (seconds-to-time (string-to-number (match-string 1)))
783 (goto-char (point-min))
785 (if (re-search-forward
786 "time::changed:\\s-+\\([0-9]+\\)" nil t
)
787 (seconds-to-time (string-to-number (match-string 1)))
790 (goto-char (point-min))
792 (if (re-search-forward
793 "standard::size:\\s-+\\([0-9]+\\)" nil t
)
794 (string-to-number (match-string 1)) 0))
795 ;; ... file mode flags
796 (goto-char (point-min))
798 (if (re-search-forward "unix::mode:\\s-+\\([0-9]+\\)" nil t
)
799 (tramp-file-mode-from-int
800 (string-to-number (match-string 1)))
801 (if dirp
"drwx------" "-rwx------")))
802 ;; ... inode and device
803 (goto-char (point-min))
805 (if (re-search-forward "unix::inode:\\s-+\\([0-9]+\\)" nil t
)
806 (string-to-number (match-string 1))
807 (tramp-get-inode v
)))
808 (goto-char (point-min))
810 (if (re-search-forward "unix::device:\\s-+\\([0-9]+\\)" nil t
)
811 (string-to-number (match-string 1))
812 (tramp-get-device v
)))
814 ;; Return data gathered.
816 ;; 0. t for directory, string (name linked to) for
817 ;; symbolic link, or nil.
818 (or dirp res-symlink-target
)
819 ;; 1. Number of links to file.
825 ;; 4. Last access time, as a list of integers.
826 ;; 5. Last modification time, likewise.
827 ;; 6. Last status change time, likewise.
828 res-access res-mod res-change
829 ;; 7. Size in bytes (-1, if number is out of range).
833 ;; 9. t if file's gid would change if file were deleted
838 ;; 11. Device number.
842 (defun tramp-gvfs-handle-file-directory-p (filename)
843 "Like `file-directory-p' for Tramp files."
844 (eq t
(car (file-attributes filename
))))
846 (defun tramp-gvfs-handle-file-executable-p (filename)
847 "Like `file-executable-p' for Tramp files."
848 (with-parsed-tramp-file-name filename nil
849 (with-tramp-file-property v localname
"file-executable-p"
850 (tramp-check-cached-permissions v ?x
))))
852 (defun tramp-gvfs-handle-file-local-copy (filename)
853 "Like `file-local-copy' for Tramp files."
854 (with-parsed-tramp-file-name filename nil
855 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
856 (unless (file-exists-p filename
)
859 "Cannot make local copy of non-existing file `%s'" filename
))
860 (copy-file filename tmpfile t t
)
863 (defun tramp-gvfs-handle-file-name-all-completions (filename directory
)
864 "Like `file-name-all-completions' for Tramp files."
865 (unless (save-match-data (string-match "/" filename
))
866 (with-parsed-tramp-file-name (expand-file-name directory
) nil
873 ;; Try cache entries for filename, filename with last
874 ;; character removed, filename with last two characters
875 ;; removed, ..., and finally the empty string - all
876 ;; concatenated to the local directory name.
877 (let ((remote-file-name-inhibit-cache
878 (or remote-file-name-inhibit-cache
879 tramp-completion-reread-directory-timeout
)))
881 ;; This is inefficient for very long filenames, pity
882 ;; `reduce' is not available...
889 (tramp-get-file-property
891 (concat localname
(substring filename
0 x
))
892 "file-name-all-completions"
894 (when cache-hit
(list cache-hit
))))
895 ;; We cannot use a length of 0, because file properties
896 ;; for "foo" and "foo/" are identical.
897 (tramp-compat-number-sequence (length filename
) 1 -
1)))))
899 ;; Cache expired or no matching cache entry found so we need
900 ;; to perform a remote operation.
901 (let ((result '("." ".."))
903 ;; Get a list of directories and files.
904 (tramp-gvfs-send-command
905 v
"gvfs-ls" "-h" (tramp-gvfs-url-file-name directory
))
907 ;; Now grab the output.
909 (insert-buffer-substring (tramp-get-connection-buffer v
))
910 (goto-char (point-max))
911 (while (zerop (forward-line -
1))
912 (setq entry
(buffer-substring (point) (point-at-eol)))
913 (when (string-match filename entry
)
914 (if (file-directory-p (expand-file-name entry directory
))
915 (push (concat entry
"/") result
)
916 (push entry result
)))))
918 ;; Because the remote op went through OK we know the
919 ;; directory we `cd'-ed to exists.
920 (tramp-set-file-property v localname
"file-exists-p" t
)
922 ;; Because the remote op went through OK we know every
923 ;; file listed by `ls' exists.
924 (mapc (lambda (entry)
925 (tramp-set-file-property
926 v
(concat localname entry
) "file-exists-p" t
))
929 ;; Store result in the cache.
930 (tramp-set-file-property
931 v
(concat localname filename
)
932 "file-name-all-completions" result
))))))))
934 (defun tramp-gvfs-handle-file-notify-add-watch (file-name _flags _callback
)
935 "Like `file-notify-add-watch' for Tramp files."
936 (setq file-name
(expand-file-name file-name
))
937 (with-parsed-tramp-file-name file-name nil
938 (let ((p (start-process
939 "gvfs-monitor-file" (generate-new-buffer " *gvfs-monitor-file*")
940 "gvfs-monitor-file" (tramp-gvfs-url-file-name file-name
))))
941 (if (not (processp p
))
943 v
'file-notify-error
"gvfs-monitor-file failed to start")
945 v
6 "Run `%s', %S" (mapconcat 'identity
(process-command p
) " ") p
)
946 (tramp-set-connection-property p
"vector" v
)
947 (tramp-compat-set-process-query-on-exit-flag p nil
)
948 (set-process-filter p
'tramp-gvfs-file-gvfs-monitor-file-process-filter
)
949 (with-current-buffer (process-buffer p
)
950 (setq default-directory
(file-name-directory file-name
)))
953 (defun tramp-gvfs-file-gvfs-monitor-file-process-filter (proc string
)
954 "Read output from \"gvfs-monitor-file\" and add corresponding file-notify events."
955 (let* ((rest-string (tramp-compat-process-get proc
'rest-string
))
956 (dd (with-current-buffer (process-buffer proc
) default-directory
))
957 (ddu (regexp-quote (tramp-gvfs-url-file-name dd
))))
959 (tramp-message proc
10 "Previous string:\n%s" rest-string
))
960 (tramp-message proc
6 "%S\n%s" proc string
)
961 (setq string
(concat rest-string string
)
962 ;; Attribute change is returned in unused wording.
963 string
(tramp-compat-replace-regexp-in-string
964 "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string
))
968 "File Monitor Event:[\n\r]+"
969 "File = \\([^\n\r]+\\)[\n\r]+"
970 "Event = \\([^[:blank:]]+\\)[\n\r]+")
972 (let ((action (intern-soft
973 (tramp-compat-replace-regexp-in-string
974 "_" "-" (downcase (match-string 2 string
)))))
975 (file (match-string 1 string
)))
976 (setq string
(replace-match "" nil nil string
))
977 ;; File names are returned as URL paths. We must convert them.
978 (when (string-match ddu file
)
979 (setq file
(replace-match dd nil nil file
)))
980 (while (string-match "%\\([0-9A-F]\\{2\\}\\)" file
)
983 (char-to-string (string-to-number (match-string 1 file
) 16))
985 ;; Usually, we would add an Emacs event now. Unfortunately,
986 ;; `unread-command-events' does not accept several events at
987 ;; once. Therefore, we apply the callback directly.
988 (tramp-compat-funcall 'file-notify-callback
(list proc action file
))))
990 ;; Save rest of the string.
991 (when (zerop (length string
)) (setq string nil
))
992 (when string
(tramp-message proc
10 "Rest string:\n%s" string
))
993 (tramp-compat-process-put proc
'rest-string string
)))
995 (defun tramp-gvfs-handle-file-readable-p (filename)
996 "Like `file-readable-p' for Tramp files."
997 (with-parsed-tramp-file-name filename nil
998 (with-tramp-file-property v localname
"file-executable-p"
999 (tramp-check-cached-permissions v ?r
))))
1001 (defun tramp-gvfs-handle-file-writable-p (filename)
1002 "Like `file-writable-p' for Tramp files."
1003 (with-parsed-tramp-file-name filename nil
1004 (with-tramp-file-property v localname
"file-writable-p"
1005 (if (file-exists-p filename
)
1006 (tramp-check-cached-permissions v ?w
)
1007 ;; If file doesn't exist, check if directory is writable.
1008 (and (file-directory-p (file-name-directory filename
))
1009 (file-writable-p (file-name-directory filename
)))))))
1011 (defun tramp-gvfs-handle-make-directory (dir &optional parents
)
1012 "Like `make-directory' for Tramp files."
1013 (with-parsed-tramp-file-name dir nil
1016 'tramp-gvfs-send-command v
"gvfs-mkdir"
1018 (list "-p" (tramp-gvfs-url-file-name dir
))
1019 (list (tramp-gvfs-url-file-name dir
))))
1020 ;; Propagate the error.
1021 (tramp-error v
'file-error
"Couldn't make directory %s" dir
))))
1023 (defun tramp-gvfs-handle-rename-file
1024 (filename newname
&optional ok-if-already-exists
)
1025 "Like `rename-file' for Tramp files."
1026 (with-parsed-tramp-file-name
1027 (if (tramp-tramp-file-p filename
) filename newname
) nil
1029 (when (and (not ok-if-already-exists
) (file-exists-p newname
))
1031 v
'file-already-exists
"File %s already exists" newname
))
1033 (if (or (and (tramp-tramp-file-p filename
)
1034 (not (tramp-gvfs-file-name-p filename
)))
1035 (and (tramp-tramp-file-p newname
)
1036 (not (tramp-gvfs-file-name-p newname
))))
1038 ;; We cannot move directly.
1039 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
1040 (rename-file filename tmpfile t
)
1041 (rename-file tmpfile newname ok-if-already-exists
))
1044 (with-tramp-progress-reporter
1045 v
0 (format "Renaming %s to %s" filename newname
)
1047 (tramp-gvfs-send-command
1049 (tramp-gvfs-url-file-name filename
)
1050 (tramp-gvfs-url-file-name newname
))
1051 ;; Propagate the error.
1052 (with-current-buffer (tramp-get-buffer v
)
1053 (goto-char (point-min))
1054 (tramp-error-with-buffer
1056 "Renaming failed, see buffer `%s' for details." (buffer-name)))))
1058 (when (tramp-tramp-file-p filename
)
1059 (with-parsed-tramp-file-name filename nil
1060 (tramp-flush-file-property v
(file-name-directory localname
))
1061 (tramp-flush-file-property v localname
)))
1063 (when (tramp-tramp-file-p newname
)
1064 (with-parsed-tramp-file-name newname nil
1065 (tramp-flush-file-property v
(file-name-directory localname
))
1066 (tramp-flush-file-property v localname
))))))
1068 (defun tramp-gvfs-handle-write-region
1069 (start end filename
&optional append visit lockname confirm
)
1070 "Like `write-region' for Tramp files."
1071 (with-parsed-tramp-file-name filename nil
1072 ;; XEmacs takes a coding system as the seventh argument, not `confirm'.
1073 (when (and (not (featurep 'xemacs
)) confirm
(file-exists-p filename
))
1074 (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename
))
1075 (tramp-error v
'file-error
"File not overwritten")))
1077 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
1078 (when (and append
(file-exists-p filename
))
1079 (copy-file filename tmpfile
'ok
))
1080 ;; We say `no-message' here because we don't want the visited file
1081 ;; modtime data to be clobbered from the temp file. We call
1082 ;; `set-visited-file-modtime' ourselves later on.
1083 (tramp-run-real-handler
1085 (if confirm
; don't pass this arg unless defined for backward compat.
1086 (list start end tmpfile append
'no-message lockname confirm
)
1087 (list start end tmpfile append
'no-message lockname
)))
1089 (rename-file tmpfile filename
'ok-if-already-exists
)
1091 (delete-file tmpfile
)
1093 v
'file-error
"Couldn't write region to `%s'" filename
))))
1095 (tramp-flush-file-property v
(file-name-directory localname
))
1096 (tramp-flush-file-property v localname
)
1098 ;; Set file modification time.
1099 (when (or (eq visit t
) (stringp visit
))
1100 (set-visited-file-modtime (nth 5 (file-attributes filename
))))
1103 (when (or (eq visit t
) (null visit
) (stringp visit
))
1104 (tramp-message v
0 "Wrote %s" filename
))
1105 (run-hooks 'tramp-handle-write-region-hook
)))
1108 ;; File name conversions.
1110 (defun tramp-gvfs-url-file-name (filename)
1111 "Return FILENAME in URL syntax."
1112 ;; "/" must NOT be hexlified.
1113 (let ((url-unreserved-chars (cons ?
/ url-unreserved-chars
))
1118 (if (tramp-tramp-file-p filename
)
1119 (with-parsed-tramp-file-name filename nil
1120 (when (and user
(string-match tramp-user-with-domain-regexp user
))
1122 (concat (match-string 2 user
) ";" (match-string 1 user
))))
1123 (url-parse-make-urlobj
1124 method
(and user
(url-hexify-string user
)) nil
1125 (tramp-file-name-real-host v
) (tramp-file-name-port v
)
1126 (and localname
(url-hexify-string localname
)) nil nil t
))
1127 (url-parse-make-urlobj
1128 "file" nil nil nil nil
1129 (url-hexify-string (file-truename filename
)) nil nil t
))))
1130 (when (tramp-tramp-file-p filename
)
1131 (with-parsed-tramp-file-name filename nil
1132 (tramp-message v
10 "remote file `%s' is URL `%s'" filename result
)))
1135 (defun tramp-gvfs-object-path (filename)
1136 "Create a D-Bus object path from FILENAME."
1137 (expand-file-name (dbus-escape-as-identifier filename
) tramp-gvfs-path-tramp
))
1139 (defun tramp-gvfs-file-name (object-path)
1140 "Retrieve file name from D-Bus OBJECT-PATH."
1141 (dbus-unescape-from-identifier
1142 (tramp-compat-replace-regexp-in-string
1143 "^.*/\\([^/]+\\)$" "\\1" object-path
)))
1145 (defun tramp-bluez-address (device)
1146 "Return bluetooth device address from a given bluetooth DEVICE name."
1147 (when (stringp device
)
1148 (if (string-match tramp-ipv6-regexp device
)
1149 (match-string 0 device
)
1150 (cadr (assoc device
(tramp-bluez-list-devices))))))
1152 (defun tramp-bluez-device (address)
1153 "Return bluetooth device name from a given bluetooth device ADDRESS.
1154 ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1155 (when (stringp address
)
1156 (while (string-match "[][]" address
)
1157 (setq address
(replace-match "" t t address
)))
1159 (dolist (item (tramp-bluez-list-devices) result
)
1160 (when (string-match address
(cadr item
))
1161 (setq result
(car item
)))))))
1164 ;; D-Bus GVFS functions.
1166 (defun tramp-gvfs-handler-askpassword (message user domain flags
)
1167 "Implementation for the \"org.gtk.vfs.MountOperation.askPassword\" method."
1169 (tramp-gvfs-file-name (dbus-event-path-name last-input-event
)))
1173 (if (string-match "\\([pP]assword\\|[pP]assphrase\\)" message
)
1174 (capitalize (match-string 1 message
))
1180 (with-parsed-tramp-file-name filename l
1181 (when (and (zerop (length user
))
1183 (zerop (logand flags tramp-gvfs-password-need-username
))))
1184 (setq user
(read-string "User name: ")))
1185 (when (and (zerop (length domain
))
1187 (zerop (logand flags tramp-gvfs-password-need-domain
))))
1188 (setq domain
(read-string "Domain name: ")))
1190 (tramp-message l
6 "%S %S %S %d" message user domain flags
)
1191 (unless (tramp-get-connection-property l
"first-password-request" nil
)
1192 (tramp-clear-passwd l
))
1194 (setq tramp-current-method l-method
1195 tramp-current-user user
1196 tramp-current-host l-host
1197 password
(tramp-read-passwd
1198 (tramp-get-connection-process l
) pw-prompt
))
1201 (if (stringp password
)
1203 t
;; password handled.
1204 nil
;; no abort of D-Bus.
1206 (tramp-file-name-real-user l
)
1208 nil
;; not anonymous.
1209 0) ;; no password save.
1210 ;; No password provided.
1211 (list nil t
"" (tramp-file-name-real-user l
) domain nil
0)))
1213 ;; When QUIT is raised, we shall return this information to D-Bus.
1214 (quit (list nil t
"" "" "" nil
0)))))
1216 (defun tramp-gvfs-handler-askquestion (message choices
)
1217 "Implementation for the \"org.gtk.vfs.MountOperation.askQuestion\" method."
1218 (save-window-excursion
1219 (let ((enable-recursive-minibuffers t
)
1223 (with-parsed-tramp-file-name
1224 (tramp-gvfs-file-name (dbus-event-path-name last-input-event
)) nil
1225 (tramp-message v
6 "%S %S" message choices
)
1227 ;; In theory, there can be several choices. Until now,
1228 ;; there is only the question whether to accept an unknown
1231 ;; Preserve message for `progress-reporter'.
1232 (tramp-compat-with-temp-message ""
1234 (pop-to-buffer (current-buffer))
1235 (setq choice
(if (yes-or-no-p (concat (car choices
) " ")) 0 1))
1236 (tramp-message v
6 "%d" choice
)))
1238 ;; When the choice is "no", we set a dummy fuse-mountpoint
1239 ;; in order to leave the timeout.
1240 (unless (zerop choice
)
1241 (tramp-set-file-property v
"/" "fuse-mountpoint" "/"))
1245 nil
;; no abort of D-Bus.
1248 ;; When QUIT is raised, we shall return this information to D-Bus.
1249 (quit (list nil t
0))))))
1251 (defun tramp-gvfs-handler-mounted-unmounted (mount-info)
1252 "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and
1253 \"org.gtk.vfs.MountTracker.unmounted\" signals."
1255 (let ((signal-name (dbus-event-member-name last-input-event
))
1257 ;; Jump over the first elements of the mount info. Since there
1258 ;; were changes in the entries, we cannot access dedicated
1260 (while (stringp (car elt
)) (setq elt
(cdr elt
)))
1261 (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt
)))
1262 (mount-spec (caddr elt
))
1263 (default-location (tramp-gvfs-dbus-byte-array-to-string
1265 (method (tramp-gvfs-dbus-byte-array-to-string
1266 (cadr (assoc "type" (cadr mount-spec
)))))
1267 (user (tramp-gvfs-dbus-byte-array-to-string
1268 (cadr (assoc "user" (cadr mount-spec
)))))
1269 (domain (tramp-gvfs-dbus-byte-array-to-string
1270 (cadr (assoc "domain" (cadr mount-spec
)))))
1271 (host (tramp-gvfs-dbus-byte-array-to-string
1272 (cadr (or (assoc "host" (cadr mount-spec
))
1273 (assoc "server" (cadr mount-spec
))))))
1274 (port (tramp-gvfs-dbus-byte-array-to-string
1275 (cadr (assoc "port" (cadr mount-spec
)))))
1276 (ssl (tramp-gvfs-dbus-byte-array-to-string
1277 (cadr (assoc "ssl" (cadr mount-spec
)))))
1278 (prefix (concat (tramp-gvfs-dbus-byte-array-to-string
1280 (tramp-gvfs-dbus-byte-array-to-string
1281 (cadr (assoc "share" (cadr mount-spec
)))))))
1282 (when (string-match "^smb" method
)
1283 (setq method
"smb"))
1284 (when (string-equal "obex" method
)
1285 (setq host
(tramp-bluez-device host
)))
1286 (when (and (string-equal "dav" method
) (string-equal "true" ssl
))
1287 (setq method
"davs"))
1288 (unless (zerop (length domain
))
1289 (setq user
(concat user tramp-prefix-domain-format domain
)))
1290 (unless (zerop (length port
))
1291 (setq host
(concat host tramp-prefix-port-format port
)))
1292 (with-parsed-tramp-file-name
1293 (tramp-make-tramp-file-name method user host
"") nil
1296 signal-name
(tramp-gvfs-stringify-dbus-message mount-info
))
1297 (tramp-set-file-property v
"/" "list-mounts" 'undef
)
1298 (if (string-equal (downcase signal-name
) "unmounted")
1299 (tramp-set-file-property v
"/" "fuse-mountpoint" nil
)
1300 ;; Set prefix, mountpoint and location.
1301 (unless (string-equal prefix
"/")
1302 (tramp-set-file-property v
"/" "prefix" prefix
))
1303 (tramp-set-file-property v
"/" "fuse-mountpoint" fuse-mountpoint
)
1304 (tramp-set-file-property
1305 v
"/" "default-location" default-location
)))))))
1307 (when tramp-gvfs-enabled
1308 (dbus-register-signal
1309 :session nil tramp-gvfs-path-mounttracker
1310 tramp-gvfs-interface-mounttracker
"mounted"
1311 'tramp-gvfs-handler-mounted-unmounted
)
1312 (dbus-register-signal
1313 :session nil tramp-gvfs-path-mounttracker
1314 tramp-gvfs-interface-mounttracker
"Mounted"
1315 'tramp-gvfs-handler-mounted-unmounted
)
1317 (dbus-register-signal
1318 :session nil tramp-gvfs-path-mounttracker
1319 tramp-gvfs-interface-mounttracker
"unmounted"
1320 'tramp-gvfs-handler-mounted-unmounted
)
1321 (dbus-register-signal
1322 :session nil tramp-gvfs-path-mounttracker
1323 tramp-gvfs-interface-mounttracker
"Unmounted"
1324 'tramp-gvfs-handler-mounted-unmounted
))
1326 (defun tramp-gvfs-connection-mounted-p (vec)
1327 "Check, whether the location is already mounted."
1329 (tramp-get-file-property vec
"/" "fuse-mountpoint" nil
)
1333 (with-tramp-file-property vec
"/" "list-mounts"
1334 (with-tramp-dbus-call-method vec t
1335 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1336 tramp-gvfs-interface-mounttracker tramp-gvfs-listmounts
))
1338 ;; Jump over the first elements of the mount info. Since there
1339 ;; were changes in the entries, we cannot access dedicated
1341 (while (stringp (car elt
)) (setq elt
(cdr elt
)))
1342 (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string
1344 (mount-spec (caddr elt
))
1345 (default-location (tramp-gvfs-dbus-byte-array-to-string
1347 (method (tramp-gvfs-dbus-byte-array-to-string
1348 (cadr (assoc "type" (cadr mount-spec
)))))
1349 (user (tramp-gvfs-dbus-byte-array-to-string
1350 (cadr (assoc "user" (cadr mount-spec
)))))
1351 (domain (tramp-gvfs-dbus-byte-array-to-string
1352 (cadr (assoc "domain" (cadr mount-spec
)))))
1353 (host (tramp-gvfs-dbus-byte-array-to-string
1354 (cadr (or (assoc "host" (cadr mount-spec
))
1355 (assoc "server" (cadr mount-spec
))))))
1356 (port (tramp-gvfs-dbus-byte-array-to-string
1357 (cadr (assoc "port" (cadr mount-spec
)))))
1358 (ssl (tramp-gvfs-dbus-byte-array-to-string
1359 (cadr (assoc "ssl" (cadr mount-spec
)))))
1360 (prefix (concat (tramp-gvfs-dbus-byte-array-to-string
1362 (tramp-gvfs-dbus-byte-array-to-string
1363 (cadr (assoc "share" (cadr mount-spec
)))))))
1364 (when (string-match "^smb" method
)
1365 (setq method
"smb"))
1366 (when (string-equal "obex" method
)
1367 (setq host
(tramp-bluez-device host
)))
1368 (when (and (string-equal "dav" method
) (string-equal "true" ssl
))
1369 (setq method
"davs"))
1370 (when (and (string-equal "synce" method
) (zerop (length user
)))
1371 (setq user
(or (tramp-file-name-user vec
) "")))
1372 (unless (zerop (length domain
))
1373 (setq user
(concat user tramp-prefix-domain-format domain
)))
1374 (unless (zerop (length port
))
1375 (setq host
(concat host tramp-prefix-port-format port
)))
1377 (string-equal method
(tramp-file-name-method vec
))
1378 (string-equal user
(or (tramp-file-name-user vec
) ""))
1379 (string-equal host
(tramp-file-name-host vec
))
1380 (string-match (concat "^" (regexp-quote prefix
))
1381 (tramp-file-name-localname vec
)))
1382 ;; Set prefix, mountpoint and location.
1383 (unless (string-equal prefix
"/")
1384 (tramp-set-file-property vec
"/" "prefix" prefix
))
1385 (tramp-set-file-property vec
"/" "fuse-mountpoint" fuse-mountpoint
)
1386 (tramp-set-file-property vec
"/" "default-location" default-location
)
1387 (throw 'mounted t
)))))))
1389 (defun tramp-gvfs-mount-spec-entry (key value
)
1390 "Construct a mount-spec entry to be used in a mount_spec.
1391 It was \"a(say)\", but has changed to \"a{sv})\"."
1392 (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature
)
1393 (list :dict-entry key
1394 (list :variant
(tramp-gvfs-dbus-string-to-byte-array value
)))
1395 (list :struct key
(tramp-gvfs-dbus-string-to-byte-array value
))))
1397 (defun tramp-gvfs-mount-spec (vec)
1398 "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"."
1399 (let* ((method (tramp-file-name-method vec
))
1400 (user (tramp-file-name-real-user vec
))
1401 (domain (tramp-file-name-domain vec
))
1402 (host (tramp-file-name-real-host vec
))
1403 (port (tramp-file-name-port vec
))
1404 (localname (tramp-file-name-localname vec
))
1405 (ssl (if (string-match "^davs" method
) "true" "false"))
1409 ((string-equal "smb" method
)
1410 (string-match "^/?\\([^/]+\\)" localname
)
1411 (list (tramp-gvfs-mount-spec-entry "type" "smb-share")
1412 (tramp-gvfs-mount-spec-entry "server" host
)
1413 (tramp-gvfs-mount-spec-entry
1414 "share" (match-string 1 localname
))))
1415 ((string-equal "obex" method
)
1416 (list (tramp-gvfs-mount-spec-entry "type" method
)
1417 (tramp-gvfs-mount-spec-entry
1418 "host" (concat "[" (tramp-bluez-address host
) "]"))))
1419 ((string-match "\\`dav" method
)
1420 (list (tramp-gvfs-mount-spec-entry "type" "dav")
1421 (tramp-gvfs-mount-spec-entry "host" host
)
1422 (tramp-gvfs-mount-spec-entry "ssl" ssl
)))
1424 (list (tramp-gvfs-mount-spec-entry "type" method
)
1425 (tramp-gvfs-mount-spec-entry "host" host
))))
1427 (list (tramp-gvfs-mount-spec-entry "user" user
)))
1429 (list (tramp-gvfs-mount-spec-entry "domain" domain
)))
1431 (list (tramp-gvfs-mount-spec-entry
1432 "port" (number-to-string port
))))))
1434 (if (and (string-match "\\`dav" method
)
1435 (string-match "^/?[^/]+" localname
))
1436 (match-string 0 localname
)
1440 `(:struct
,(tramp-gvfs-dbus-string-to-byte-array mount-pref
) ,mount-spec
)))
1443 ;; Connection functions.
1445 (defun tramp-gvfs-maybe-open-connection (vec)
1446 "Maybe open a connection VEC.
1447 Does not do anything if a connection is already open, but re-opens the
1448 connection if a previous connection has died for some reason."
1449 (tramp-check-proper-method-and-host vec
)
1451 ;; We set the file name, in case there are incoming D-Bus signals or
1453 (setq tramp-gvfs-dbus-event-vector vec
)
1455 ;; For password handling, we need a process bound to the connection
1456 ;; buffer. Therefore, we create a dummy process. Maybe there is a
1458 (unless (get-buffer-process (tramp-get-connection-buffer vec
))
1459 (let ((p (make-network-process
1460 :name
(tramp-buffer-name vec
)
1461 :buffer
(tramp-get-connection-buffer vec
)
1462 :server t
:host
'local
:service t
)))
1463 (tramp-compat-set-process-query-on-exit-flag p nil
)))
1465 (unless (tramp-gvfs-connection-mounted-p vec
)
1466 (let* ((method (tramp-file-name-method vec
))
1467 (user (tramp-file-name-user vec
))
1468 (host (tramp-file-name-host vec
))
1469 (localname (tramp-file-name-localname vec
))
1471 (tramp-gvfs-object-path
1472 (tramp-make-tramp-file-name method user host
""))))
1474 (when (and (string-equal method
"smb")
1475 (string-equal localname
"/"))
1476 (tramp-error vec
'file-error
"Filename must contain a Windows share"))
1478 (with-tramp-progress-reporter
1480 (if (zerop (length user
))
1481 (format "Opening connection for %s using %s" host method
)
1482 (format "Opening connection for %s@%s using %s" user host method
))
1484 ;; Enable `auth-source'.
1485 (tramp-set-connection-property vec
"first-password-request" t
)
1487 ;; There will be a callback of "askPassword" when a password is
1489 (dbus-register-method
1490 :session dbus-service-emacs object-path
1491 tramp-gvfs-interface-mountoperation
"askPassword"
1492 'tramp-gvfs-handler-askpassword
)
1493 (dbus-register-method
1494 :session dbus-service-emacs object-path
1495 tramp-gvfs-interface-mountoperation
"AskPassword"
1496 'tramp-gvfs-handler-askpassword
)
1498 ;; There could be a callback of "askQuestion" when adding fingerprint.
1499 (dbus-register-method
1500 :session dbus-service-emacs object-path
1501 tramp-gvfs-interface-mountoperation
"askQuestion"
1502 'tramp-gvfs-handler-askquestion
)
1503 (dbus-register-method
1504 :session dbus-service-emacs object-path
1505 tramp-gvfs-interface-mountoperation
"AskQuestion"
1506 'tramp-gvfs-handler-askquestion
)
1508 ;; The call must be asynchronously, because of the "askPassword"
1509 ;; or "askQuestion"callbacks.
1510 (if (string-match "(so)$" tramp-gvfs-mountlocation-signature
)
1511 (with-tramp-dbus-call-method vec nil
1512 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1513 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1514 (tramp-gvfs-mount-spec vec
)
1515 `(:struct
:string
,(dbus-get-unique-name :session
)
1516 :object-path
,object-path
))
1517 (with-tramp-dbus-call-method vec nil
1518 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1519 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1520 (tramp-gvfs-mount-spec vec
)
1521 :string
(dbus-get-unique-name :session
) :object-path object-path
))
1523 ;; We must wait, until the mount is applied. This will be
1524 ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint"
1527 ((or (tramp-get-method-parameter method
'tramp-connection-timeout
)
1528 tramp-connection-timeout
)
1529 (if (zerop (length (tramp-file-name-user vec
)))
1532 "Timeout reached mounting %s using %s" host method
)
1535 "Timeout reached mounting %s@%s using %s" user host method
)))
1536 (while (not (tramp-get-file-property vec
"/" "fuse-mountpoint" nil
))
1537 (read-event nil nil
0.1)))
1539 ;; If `tramp-gvfs-handler-askquestion' has returned "No", it
1540 ;; is marked with the fuse-mountpoint "/". We shall react.
1542 (tramp-get-file-property vec
"/" "fuse-mountpoint" "") "/")
1543 (tramp-error vec
'file-error
"FUSE mount denied")))))
1545 ;; In `tramp-check-cached-permissions', the connection properties
1546 ;; {uig,gid}-{integer,string} are used. We set them to their local
1548 (with-tramp-connection-property
1549 vec
"uid-integer" (tramp-get-local-uid 'integer
))
1550 (with-tramp-connection-property
1551 vec
"gid-integer" (tramp-get-local-gid 'integer
))
1552 (with-tramp-connection-property
1553 vec
"uid-string" (tramp-get-local-uid 'string
))
1554 (with-tramp-connection-property
1555 vec
"gid-string" (tramp-get-local-gid 'string
)))
1557 (defun tramp-gvfs-send-command (vec command
&rest args
)
1558 "Send the COMMAND with its ARGS to connection VEC.
1559 COMMAND is usually a command from the gvfs-* utilities.
1560 `call-process' is applied, and it returns `t' if the return code is zero."
1561 (with-current-buffer (tramp-get-connection-buffer vec
)
1562 (tramp-gvfs-maybe-open-connection vec
)
1564 (zerop (apply 'tramp-call-process vec command nil t nil args
))))
1567 ;; D-Bus BLUEZ functions.
1569 (defun tramp-bluez-list-devices ()
1570 "Return all discovered bluetooth devices as list.
1571 Every entry is a list (NAME ADDRESS).
1573 If `tramp-bluez-discover-devices-timeout' is an integer, and the last
1574 discovery happened more time before indicated there, a rescan will be
1575 started, which lasts some ten seconds. Otherwise, cached results will
1577 ;; Reset the scanned devices list if time has passed.
1578 (and (integerp tramp-bluez-discover-devices-timeout
)
1579 (integerp tramp-bluez-discovery
)
1580 (> (tramp-time-diff (current-time) tramp-bluez-discovery
)
1581 tramp-bluez-discover-devices-timeout
)
1582 (setq tramp-bluez-devices nil
))
1584 ;; Rescan if needed.
1585 (unless tramp-bluez-devices
1587 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1588 :system tramp-bluez-service
"/"
1589 tramp-bluez-interface-manager
"DefaultAdapter")))
1590 (setq tramp-bluez-devices nil
1591 tramp-bluez-discovery t
)
1592 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil
1593 :system tramp-bluez-service object-path
1594 tramp-bluez-interface-adapter
"StartDiscovery")
1595 (while tramp-bluez-discovery
1596 (read-event nil nil
0.1))))
1597 (setq tramp-bluez-discovery
(current-time))
1598 (tramp-message tramp-gvfs-dbus-event-vector
10 "%s" tramp-bluez-devices
)
1599 tramp-bluez-devices
)
1601 (defun tramp-bluez-property-changed (property value
)
1602 "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal."
1603 (tramp-message tramp-gvfs-dbus-event-vector
6 "%s %s" property value
)
1605 ((string-equal property
"Discovering")
1607 ;; "Discovering" FALSE means discovery run has been completed.
1608 ;; We stop it, because we don't need another run.
1609 (setq tramp-bluez-discovery nil
)
1610 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1611 :system tramp-bluez-service
(dbus-event-path-name last-input-event
)
1612 tramp-bluez-interface-adapter
"StopDiscovery")))))
1614 (when tramp-gvfs-enabled
1615 (dbus-register-signal
1616 :system nil nil tramp-bluez-interface-adapter
"PropertyChanged"
1617 'tramp-bluez-property-changed
))
1619 (defun tramp-bluez-device-found (device args
)
1620 "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal."
1621 (tramp-message tramp-gvfs-dbus-event-vector
6 "%s %s" device args
)
1622 (let ((alias (car (cadr (assoc "Alias" args
))))
1623 (address (car (cadr (assoc "Address" args
)))))
1624 ;; Maybe we shall check the device class for being a proper
1625 ;; device, and call also SDP in order to find the obex service.
1626 (add-to-list 'tramp-bluez-devices
(list alias address
))))
1628 (when tramp-gvfs-enabled
1629 (dbus-register-signal
1630 :system nil nil tramp-bluez-interface-adapter
"DeviceFound"
1631 'tramp-bluez-device-found
))
1633 (defun tramp-bluez-parse-device-names (_ignore)
1634 "Return a list of (nil host) tuples allowed to access."
1636 (lambda (x) (list nil
(car x
)))
1637 (tramp-bluez-list-devices)))
1639 ;; Add completion function for OBEX method.
1640 (when (and tramp-gvfs-enabled
1641 (member tramp-bluez-service
(dbus-list-known-names :system
)))
1642 (tramp-set-completion-function
1643 "obex" '((tramp-bluez-parse-device-names ""))))
1646 ;; D-Bus zeroconf functions.
1648 (defun tramp-zeroconf-parse-workstation-device-names (_ignore)
1649 "Return a list of (user host) tuples allowed to access."
1652 (list nil
(zeroconf-service-host x
)))
1653 (zeroconf-list-services "_workstation._tcp")))
1655 (defun tramp-zeroconf-parse-webdav-device-names (_ignore)
1656 "Return a list of (user host) tuples allowed to access."
1659 (let ((host (zeroconf-service-host x
))
1660 (port (zeroconf-service-port x
))
1661 (text (zeroconf-service-txt x
))
1664 (setq host
(format "%s%s%d" host tramp-prefix-port-regexp port
)))
1665 ;; A user is marked in a TXT field like "u=guest".
1667 (when (string-match "u=\\(.+\\)$" (car text
))
1668 (setq user
(match-string 1 (car text
))))
1669 (setq text
(cdr text
)))
1671 (zeroconf-list-services "_webdav._tcp")))
1673 ;; Add completion function for SFTP, DAV and DAVS methods.
1674 (when (and tramp-gvfs-enabled
1675 (member zeroconf-service-avahi
(dbus-list-known-names :system
)))
1676 (zeroconf-init tramp-gvfs-zeroconf-domain
)
1677 (tramp-set-completion-function
1678 "sftp" '((tramp-zeroconf-parse-workstation-device-names "")))
1679 (tramp-set-completion-function
1680 "dav" '((tramp-zeroconf-parse-webdav-device-names "")))
1681 (tramp-set-completion-function
1682 "davs" '((tramp-zeroconf-parse-webdav-device-names ""))))
1685 ;; D-Bus SYNCE functions.
1687 (defun tramp-synce-list-devices ()
1688 "Return all discovered synce devices as list.
1689 They are retrieved from the hal daemon."
1690 (let (tramp-synce-devices)
1692 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1693 :system tramp-hal-service tramp-hal-path-manager
1694 tramp-hal-interface-manager
"GetAllDevices"))
1695 (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1696 :system tramp-hal-service device tramp-hal-interface-device
1697 "PropertyExists" "sync.plugin")
1699 (with-tramp-dbus-call-method
1700 tramp-gvfs-dbus-event-vector t
1701 :system tramp-hal-service device tramp-hal-interface-device
1702 "GetPropertyString" "pda.pocketpc.name")))
1703 (unless (member prop tramp-synce-devices
)
1704 (push prop tramp-synce-devices
)))))
1705 (tramp-message tramp-gvfs-dbus-event-vector
10 "%s" tramp-synce-devices
)
1706 tramp-synce-devices
))
1708 (defun tramp-synce-parse-device-names (_ignore)
1709 "Return a list of (nil host) tuples allowed to access."
1711 (lambda (x) (list nil x
))
1712 (tramp-synce-list-devices)))
1714 ;; Add completion function for SYNCE method.
1715 (when tramp-gvfs-enabled
1716 (tramp-set-completion-function
1717 "synce" '((tramp-synce-parse-device-names ""))))
1719 (add-hook 'tramp-unload-hook
1721 (unload-feature 'tramp-gvfs
'force
)))
1723 (provide 'tramp-gvfs
)
1727 ;; * Host name completion via smb-server or smb-network.
1728 ;; * Check how two shares of the same SMB server can be mounted in
1730 ;; * Apply SDP on bluetooth devices, in order to filter out obex
1732 ;; * Implement obex for other serial communication but bluetooth.
1734 ;;; tramp-gvfs.el ends here