1 ;;; tramp-gvfs.el --- Tramp access functions for GVFS daemon
3 ;; Copyright (C) 2009-2013 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
: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 (dbus-introspect-get-method-names
171 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
172 tramp-gvfs-interface-mounttracker
)
173 "The list of supported methods of the mount tracking interface.")
175 (defconst tramp-gvfs-listmounts
176 (if (member "ListMounts" tramp-gvfs-methods-mounttracker
)
179 "The name of the \"listMounts\" method.
180 It has been changed in GVFS 1.14.")
182 (defconst tramp-gvfs-mountlocation
183 (if (member "MountLocation" tramp-gvfs-methods-mounttracker
)
186 "The name of the \"mountLocation\" method.
187 It has been changed in GVFS 1.14.")
189 (defconst tramp-gvfs-mountlocation-signature
190 (dbus-introspect-get-signature
191 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
192 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
)
193 "The D-Bus signature of the \"mountLocation\" method.
194 It has been changed in GVFS 1.14.")
196 ;; <interface name='org.gtk.vfs.MountTracker'>
197 ;; <method name='listMounts'>
198 ;; <arg name='mount_info_list'
199 ;; type='a{sosssssbay{aya{say}}ay}'
202 ;; <method name='mountLocation'>
203 ;; <arg name='mount_spec' type='{aya{say}}' direction='in'/>
204 ;; <arg name='dbus_id' type='s' direction='in'/>
205 ;; <arg name='object_path' type='o' direction='in'/>
207 ;; <signal name='mounted'>
208 ;; <arg name='mount_info'
209 ;; type='{sosssssbay{aya{say}}ay}'/>
211 ;; <signal name='unmounted'>
212 ;; <arg name='mount_info'
213 ;; type='{sosssssbay{aya{say}}ay}'/>
219 ;; OBJECT_PATH object_path
220 ;; STRING display_name
221 ;; STRING stable_name
222 ;; STRING x_content_types Since GVFS 1.0 only !!!
224 ;; STRING preferred_filename_encoding
225 ;; BOOLEAN user_visible
226 ;; ARRAY BYTE fuse_mountpoint
228 ;; ARRAY BYTE mount_prefix
230 ;; STRUCT mount_spec_item
231 ;; STRING key (server, share, type, user, host, port)
233 ;; ARRAY BYTE default_location Since GVFS 1.5 only !!!
235 (defconst tramp-gvfs-interface-mountoperation
"org.gtk.vfs.MountOperation"
236 "Used by the dbus-proxying implementation of GMountOperation.")
238 ;; <interface name='org.gtk.vfs.MountOperation'>
239 ;; <method name='askPassword'>
240 ;; <arg name='message' type='s' direction='in'/>
241 ;; <arg name='default_user' type='s' direction='in'/>
242 ;; <arg name='default_domain' type='s' direction='in'/>
243 ;; <arg name='flags' type='u' direction='in'/>
244 ;; <arg name='handled' type='b' direction='out'/>
245 ;; <arg name='aborted' type='b' direction='out'/>
246 ;; <arg name='password' type='s' direction='out'/>
247 ;; <arg name='username' type='s' direction='out'/>
248 ;; <arg name='domain' type='s' direction='out'/>
249 ;; <arg name='anonymous' type='b' direction='out'/>
250 ;; <arg name='password_save' type='u' direction='out'/>
252 ;; <method name='askQuestion'>
253 ;; <arg name='message' type='s' direction='in'/>
254 ;; <arg name='choices' type='as' direction='in'/>
255 ;; <arg name='handled' type='b' direction='out'/>
256 ;; <arg name='aborted' type='b' direction='out'/>
257 ;; <arg name='choice' type='u' direction='out'/>
261 ;; The following flags are used in "askPassword". They are defined in
262 ;; /usr/include/glib-2.0/gio/gioenums.h.
264 (defconst tramp-gvfs-password-need-password
1
265 "Operation requires a password.")
267 (defconst tramp-gvfs-password-need-username
2
268 "Operation requires a username.")
270 (defconst tramp-gvfs-password-need-domain
4
271 "Operation requires a domain.")
273 (defconst tramp-gvfs-password-saving-supported
8
274 "Operation supports saving settings.")
276 (defconst tramp-gvfs-password-anonymous-supported
16
277 "Operation supports anonymous users.")
279 (defconst tramp-bluez-service
"org.bluez"
280 "The well known name of the BLUEZ service.")
282 (defconst tramp-bluez-interface-manager
"org.bluez.Manager"
283 "The manager interface of the BLUEZ daemon.")
285 ;; <interface name='org.bluez.Manager'>
286 ;; <method name='DefaultAdapter'>
287 ;; <arg type='o' direction='out'/>
289 ;; <method name='FindAdapter'>
290 ;; <arg type='s' direction='in'/>
291 ;; <arg type='o' direction='out'/>
293 ;; <method name='ListAdapters'>
294 ;; <arg type='ao' direction='out'/>
296 ;; <signal name='AdapterAdded'>
299 ;; <signal name='AdapterRemoved'>
302 ;; <signal name='DefaultAdapterChanged'>
307 (defconst tramp-bluez-interface-adapter
"org.bluez.Adapter"
308 "The adapter interface of the BLUEZ daemon.")
310 ;; <interface name='org.bluez.Adapter'>
311 ;; <method name='GetProperties'>
312 ;; <arg type='a{sv}' direction='out'/>
314 ;; <method name='SetProperty'>
315 ;; <arg type='s' direction='in'/>
316 ;; <arg type='v' direction='in'/>
318 ;; <method name='RequestMode'>
319 ;; <arg type='s' direction='in'/>
321 ;; <method name='ReleaseMode'/>
322 ;; <method name='RequestSession'/>
323 ;; <method name='ReleaseSession'/>
324 ;; <method name='StartDiscovery'/>
325 ;; <method name='StopDiscovery'/>
326 ;; <method name='ListDevices'>
327 ;; <arg type='ao' direction='out'/>
329 ;; <method name='CreateDevice'>
330 ;; <arg type='s' direction='in'/>
331 ;; <arg type='o' direction='out'/>
333 ;; <method name='CreatePairedDevice'>
334 ;; <arg type='s' direction='in'/>
335 ;; <arg type='o' direction='in'/>
336 ;; <arg type='s' direction='in'/>
337 ;; <arg type='o' direction='out'/>
339 ;; <method name='CancelDeviceCreation'>
340 ;; <arg type='s' direction='in'/>
342 ;; <method name='RemoveDevice'>
343 ;; <arg type='o' direction='in'/>
345 ;; <method name='FindDevice'>
346 ;; <arg type='s' direction='in'/>
347 ;; <arg type='o' direction='out'/>
349 ;; <method name='RegisterAgent'>
350 ;; <arg type='o' direction='in'/>
351 ;; <arg type='s' direction='in'/>
353 ;; <method name='UnregisterAgent'>
354 ;; <arg type='o' direction='in'/>
356 ;; <signal name='DeviceCreated'>
359 ;; <signal name='DeviceRemoved'>
362 ;; <signal name='DeviceFound'>
364 ;; <arg type='a{sv}'/>
366 ;; <signal name='PropertyChanged'>
370 ;; <signal name='DeviceDisappeared'>
375 (defcustom tramp-bluez-discover-devices-timeout
60
376 "Defines seconds since last bluetooth device discovery before rescanning.
377 A value of 0 would require an immediate discovery during hostname
378 completion, nil means to use always cached values for discovered
382 :type
'(choice (const nil
) integer
))
384 (defvar tramp-bluez-discovery nil
385 "Indicator for a running bluetooth device discovery.
386 It keeps the timestamp of last discovery.")
388 (defvar tramp-bluez-devices nil
389 "Alist of detected bluetooth devices.
390 Every entry is a list (NAME ADDRESS).")
392 (defconst tramp-hal-service
"org.freedesktop.Hal"
393 "The well known name of the HAL service.")
395 (defconst tramp-hal-path-manager
"/org/freedesktop/Hal/Manager"
396 "The object path of the HAL daemon manager.")
398 (defconst tramp-hal-interface-manager
"org.freedesktop.Hal.Manager"
399 "The manager interface of the HAL daemon.")
401 (defconst tramp-hal-interface-device
"org.freedesktop.Hal.Device"
402 "The device interface of the HAL daemon.")
405 ;; New handlers should be added here.
406 (defconst tramp-gvfs-file-name-handler-alist
407 '((access-file . ignore
)
408 (add-name-to-file . tramp-gvfs-handle-copy-file
)
409 ;; `byte-compiler-base-file-name' performed by default handler.
410 ;; `copy-directory' performed by default handler.
411 (copy-file . tramp-gvfs-handle-copy-file
)
412 (delete-directory . tramp-gvfs-handle-delete-directory
)
413 (delete-file . tramp-gvfs-handle-delete-file
)
414 ;; `diff-latest-backup-file' performed by default handler.
415 (directory-file-name . tramp-handle-directory-file-name
)
416 (directory-files . tramp-handle-directory-files
)
417 (directory-files-and-attributes
418 . tramp-handle-directory-files-and-attributes
)
419 (dired-call-process . ignore
)
420 (dired-compress-file . ignore
)
421 (dired-uncache . tramp-handle-dired-uncache
)
422 (expand-file-name . tramp-gvfs-handle-expand-file-name
)
423 (file-accessible-directory-p . tramp-handle-file-accessible-directory-p
)
425 (file-attributes . tramp-gvfs-handle-file-attributes
)
426 (file-directory-p . tramp-gvfs-handle-file-directory-p
)
427 ;; `file-equal-p' performed by default handler.
428 (file-executable-p . tramp-gvfs-handle-file-executable-p
)
429 (file-exists-p . tramp-handle-file-exists-p
)
430 ;; `file-in-directory-p' performed by default handler.
431 (file-local-copy . tramp-gvfs-handle-file-local-copy
)
432 (file-modes . tramp-handle-file-modes
)
433 (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions
)
434 (file-name-as-directory . tramp-handle-file-name-as-directory
)
435 (file-name-completion . tramp-handle-file-name-completion
)
436 (file-name-directory . tramp-handle-file-name-directory
)
437 (file-name-nondirectory . tramp-handle-file-name-nondirectory
)
438 ;; `file-name-sans-versions' performed by default handler.
439 (file-newer-than-file-p . tramp-handle-file-newer-than-file-p
)
440 (file-notify-add-watch . tramp-gvfs-handle-file-notify-add-watch
)
441 (file-notify-rm-watch . tramp-handle-file-notify-rm-watch
)
442 (file-ownership-preserved-p . ignore
)
443 (file-readable-p . tramp-gvfs-handle-file-readable-p
)
444 (file-regular-p . tramp-handle-file-regular-p
)
445 (file-remote-p . tramp-handle-file-remote-p
)
446 (file-selinux-context . ignore
)
447 (file-symlink-p . tramp-handle-file-symlink-p
)
448 ;; `file-truename' performed by default handler.
449 (file-writable-p . tramp-gvfs-handle-file-writable-p
)
450 (find-backup-file-name . tramp-handle-find-backup-file-name
)
451 ;; `find-file-noselect' performed by default handler.
452 ;; `get-file-buffer' performed by default handler.
453 (insert-directory . tramp-gvfs-handle-insert-directory
)
454 (insert-file-contents . tramp-gvfs-handle-insert-file-contents
)
455 (load . tramp-handle-load
)
456 (make-auto-save-file-name . tramp-handle-make-auto-save-file-name
)
457 (make-directory . tramp-gvfs-handle-make-directory
)
458 (make-directory-internal . ignore
)
459 (make-symbolic-link . ignore
)
460 (process-file . ignore
)
461 (rename-file . tramp-gvfs-handle-rename-file
)
462 (set-file-acl . ignore
)
463 (set-file-modes . ignore
)
464 (set-file-selinux-context . ignore
)
465 (set-file-times . ignore
)
466 (set-visited-file-modtime . tramp-handle-set-visited-file-modtime
)
467 (shell-command . ignore
)
468 (start-file-process . ignore
)
469 (substitute-in-file-name . tramp-handle-substitute-in-file-name
)
470 (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory
)
471 (vc-registered . ignore
)
472 (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime
)
473 (write-region . tramp-gvfs-handle-write-region
))
474 "Alist of handler functions for Tramp GVFS method.
475 Operations not mentioned here will be handled by the default Emacs primitives.")
477 ;; It must be a `defsubst' in order to push the whole code into
478 ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading.
480 (defsubst tramp-gvfs-file-name-p
(filename)
481 "Check if it's a filename handled by the GVFS daemon."
482 (and (tramp-tramp-file-p filename
)
484 (tramp-file-name-method (tramp-dissect-file-name filename
))))
485 (and (stringp method
) (member method tramp-gvfs-methods
)))))
488 (defun tramp-gvfs-file-name-handler (operation &rest args
)
489 "Invoke the GVFS related OPERATION.
490 First arg specifies the OPERATION, second arg is a list of arguments to
491 pass to the OPERATION."
492 (unless tramp-gvfs-enabled
493 (tramp-user-error nil
"Package `tramp-gvfs' not supported"))
494 (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist
)))
496 (save-match-data (apply (cdr fn
) args
))
497 (tramp-run-real-handler operation args
))))
499 ;; This might be moved to tramp.el. It shall be the first file name
502 (when (featurep 'dbusbind
)
503 (add-to-list 'tramp-foreign-file-name-handler-alist
504 (cons 'tramp-gvfs-file-name-p
'tramp-gvfs-file-name-handler
)))
507 ;; D-Bus helper function.
509 (defun tramp-gvfs-dbus-string-to-byte-array (string)
510 "Like `dbus-string-to-byte-array' but add trailing \\0 if needed."
511 (dbus-string-to-byte-array
512 (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature
)
513 (concat string
(string 0)) string
)))
515 (defun tramp-gvfs-dbus-byte-array-to-string (byte-array)
516 "Like `dbus-byte-array-to-string' but remove trailing \\0 if exists."
517 ;; The byte array could be a variant. Take care.
519 (if (and (consp byte-array
) (atom (car byte-array
)))
520 byte-array
(car byte-array
))))
521 (dbus-byte-array-to-string
522 (if (and (consp byte-array
) (zerop (car (last byte-array
))))
523 (butlast byte-array
) byte-array
))))
525 (defun tramp-gvfs-stringify-dbus-message (message)
526 "Convert a D-Bus message into readable UTF8 strings, used for traces."
528 ((and (consp message
) (characterp (car message
)))
529 (format "%S" (tramp-gvfs-dbus-byte-array-to-string message
)))
531 (mapcar 'tramp-gvfs-stringify-dbus-message message
))
533 (format "%S" message
))
536 (defmacro with-tramp-dbus-call-method
537 (vec synchronous bus service path interface method
&rest args
)
538 "Apply a D-Bus call on bus BUS.
540 If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise,
541 it is an asynchronous call, with `ignore' as callback function.
543 The other arguments have the same meaning as with `dbus-call-method'
544 or `dbus-call-method-asynchronously'. Additionally, the call
545 will be traced by Tramp with trace level 6."
546 `(let ((func (if ,synchronous
547 'dbus-call-method
'dbus-call-method-asynchronously
))
548 (args (append (list ,bus
,service
,path
,interface
,method
)
549 (if ,synchronous
(list ,@args
) (list 'ignore
,@args
))))
551 (tramp-message ,vec
6 "%s %s" func args
)
552 (setq result
(apply func args
))
553 (tramp-message ,vec
6 "%s" (tramp-gvfs-stringify-dbus-message result
))
556 (put 'with-tramp-dbus-call-method
'lisp-indent-function
2)
557 (put 'with-tramp-dbus-call-method
'edebug-form-spec
'(form symbolp body
))
558 (tramp-compat-font-lock-add-keywords
559 'emacs-lisp-mode
'("\\<with-tramp-dbus-call-method\\>"))
561 (defvar tramp-gvfs-dbus-event-vector nil
562 "Current Tramp file name to be used, as vector.
563 It is needed when D-Bus signals or errors arrive, because there
564 is no information where to trace the message.")
566 (defun tramp-gvfs-dbus-event-error (event err
)
567 "Called when a D-Bus error message arrives, see `dbus-event-error-functions'."
568 (when tramp-gvfs-dbus-event-vector
569 (tramp-message tramp-gvfs-dbus-event-vector
10 "%S" event
)
570 (tramp-error tramp-gvfs-dbus-event-vector
'file-error
"%s" (cadr err
))))
572 ;; `dbus-event-error-hooks' has been renamed to `dbus-event-error-functions'.
574 (if (boundp 'dbus-event-error-functions
)
575 'dbus-event-error-functions
'dbus-event-error-hooks
)
576 'tramp-gvfs-dbus-event-error
)
579 ;; File name primitives.
581 (defun tramp-gvfs-handle-copy-file
582 (filename newname
&optional ok-if-already-exists keep-date
583 preserve-uid-gid preserve-extended-attributes
)
584 "Like `copy-file' for Tramp files."
585 (with-parsed-tramp-file-name
586 (if (tramp-tramp-file-p filename
) filename newname
) nil
588 (when (and (not ok-if-already-exists
) (file-exists-p newname
))
590 v
'file-already-exists
"File %s already exists" newname
))
592 (if (or (and (tramp-tramp-file-p filename
)
593 (not (tramp-gvfs-file-name-p filename
)))
594 (and (tramp-tramp-file-p newname
)
595 (not (tramp-gvfs-file-name-p newname
))))
597 ;; We cannot call `copy-file' directly. Use
598 ;; `tramp-compat-funcall' for backward compatibility (number
600 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
602 (preserve-extended-attributes
603 (tramp-compat-funcall
605 filename tmpfile t keep-date preserve-uid-gid
606 preserve-extended-attributes
))
608 (tramp-compat-funcall
609 'copy-file filename tmpfile t keep-date preserve-uid-gid
))
611 (copy-file filename tmpfile t keep-date
)))
612 (rename-file tmpfile newname ok-if-already-exists
))
615 (with-tramp-progress-reporter
616 v
0 (format "Copying %s to %s" filename newname
)
619 (append (if (or keep-date preserve-uid-gid
)
623 (tramp-gvfs-url-file-name filename
)
624 (tramp-gvfs-url-file-name newname
)))))
625 (apply 'tramp-gvfs-send-command v
"gvfs-copy" args
))
626 ;; Propagate the error.
627 (with-current-buffer (tramp-get-connection-buffer v
)
628 (goto-char (point-min))
629 (tramp-error-with-buffer
631 "Copying failed, see buffer `%s' for details." (buffer-name)))))
633 (when (file-remote-p newname
)
634 (with-parsed-tramp-file-name newname nil
635 (tramp-flush-file-property v
(file-name-directory localname
))
636 (tramp-flush-file-property v localname
))))))
638 (defun tramp-gvfs-handle-delete-directory (directory &optional recursive trash
)
639 "Like `delete-directory' for Tramp files."
640 (when (and recursive
(not (file-symlink-p directory
)))
642 (if (eq t
(car (file-attributes file
)))
643 (tramp-compat-delete-directory file recursive trash
)
644 (tramp-compat-delete-file file trash
)))
646 directory
'full
"^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
647 (with-parsed-tramp-file-name directory nil
648 (tramp-flush-file-property v
(file-name-directory localname
))
649 (tramp-flush-directory-property v localname
)
651 (tramp-gvfs-send-command
652 v
(if (and trash delete-by-moving-to-trash
) "gvfs-trash" "gvfs-rm")
653 (tramp-gvfs-url-file-name directory
))
654 ;; Propagate the error.
655 (with-current-buffer (tramp-get-connection-buffer v
)
656 (goto-char (point-min))
657 (tramp-error-with-buffer
658 nil v
'file-error
"Couldn't delete %s" directory
)))))
660 (defun tramp-gvfs-handle-delete-file (filename &optional trash
)
661 "Like `delete-file' for Tramp files."
662 (with-parsed-tramp-file-name filename nil
663 (tramp-flush-file-property v
(file-name-directory localname
))
664 (tramp-flush-directory-property v localname
)
666 (tramp-gvfs-send-command
667 v
(if (and trash delete-by-moving-to-trash
) "gvfs-trash" "gvfs-rm")
668 (tramp-gvfs-url-file-name filename
))
669 ;; Propagate the error.
670 (with-current-buffer (tramp-get-connection-buffer v
)
671 (goto-char (point-min))
672 (tramp-error-with-buffer
673 nil v
'file-error
"Couldn't delete %s" filename
)))))
675 (defun tramp-gvfs-handle-expand-file-name (name &optional dir
)
676 "Like `expand-file-name' for Tramp files."
677 ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
678 (setq dir
(or dir default-directory
"/"))
679 ;; Unless NAME is absolute, concat DIR and NAME.
680 (unless (file-name-absolute-p name
)
681 (setq name
(concat (file-name-as-directory dir
) name
)))
682 ;; If NAME is not a Tramp file, run the real handler.
683 (if (not (tramp-tramp-file-p name
))
684 (tramp-run-real-handler 'expand-file-name
(list name nil
))
686 (with-parsed-tramp-file-name name nil
687 ;; If there is a default location, expand tilde.
688 (when (string-match "\\`\\(~\\)\\(/\\|\\'\\)" localname
)
690 (tramp-gvfs-maybe-open-connection (vector method user host
"/" hop
)))
693 (tramp-get-file-property v
"/" "default-location" "~")
695 ;; Tilde expansion is not possible.
696 (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname
)
699 "Cannot expand tilde in file `%s'" name
))
700 (unless (tramp-run-real-handler 'file-name-absolute-p
(list localname
))
701 (setq localname
(concat "/" localname
)))
702 ;; We do not pass "/..".
703 (if (string-equal "smb" method
)
704 (when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname
)
705 (setq localname
(replace-match "/" t t localname
1)))
706 (when (string-match "^/\\.\\./?" localname
)
707 (setq localname
(replace-match "/" t t localname
))))
708 ;; There might be a double slash. Remove this.
709 (while (string-match "//" localname
)
710 (setq localname
(replace-match "/" t t localname
)))
711 ;; No tilde characters in file name, do normal
712 ;; `expand-file-name' (this does "/./" and "/../").
713 (tramp-make-tramp-file-name
715 (tramp-run-real-handler
716 'expand-file-name
(list localname
))))))
718 (defun tramp-gvfs-handle-file-attributes (filename &optional id-format
)
719 "Like `file-attributes' for Tramp files."
720 (unless id-format
(setq id-format
'integer
))
721 ;; Don't modify `last-coding-system-used' by accident.
722 (let ((last-coding-system-used last-coding-system-used
)
723 dirp res-symlink-target res-numlinks res-uid res-gid res-access
724 res-mod res-change res-size res-filemodes res-inode res-device
)
725 (with-parsed-tramp-file-name filename nil
726 (with-tramp-file-property
727 v localname
(format "file-attributes-%s" id-format
)
728 (tramp-message v
5 "file attributes: %s" localname
)
729 (tramp-gvfs-send-command
730 v
"gvfs-info" (tramp-gvfs-url-file-name filename
))
732 (with-current-buffer (tramp-get-connection-buffer v
)
733 (goto-char (point-min))
734 (when (re-search-forward "attributes:" nil t
)
735 ;; ... directory or symlink
736 (goto-char (point-min))
737 (setq dirp
(if (re-search-forward "type:\\s-+directory" nil t
) t
))
738 (goto-char (point-min))
739 (setq res-symlink-target
740 (if (re-search-forward
741 "standard::symlink-target:\\s-+\\(\\S-+\\)" nil t
)
744 (goto-char (point-min))
746 (if (re-search-forward "unix::nlink:\\s-+\\([0-9]+\\)" nil t
)
747 (string-to-number (match-string 1)) 0))
749 (goto-char (point-min))
751 (or (if (eq id-format
'integer
)
752 (if (re-search-forward
753 "unix::uid:\\s-+\\([0-9]+\\)" nil t
)
754 (string-to-number (match-string 1)))
755 (if (re-search-forward
756 "owner::user:\\s-+\\(\\S-+\\)" nil t
)
758 (tramp-get-local-uid id-format
)))
760 (or (if (eq id-format
'integer
)
761 (if (re-search-forward
762 "unix::gid:\\s-+\\([0-9]+\\)" nil t
)
763 (string-to-number (match-string 1)))
764 (if (re-search-forward
765 "owner::group:\\s-+\\(\\S-+\\)" nil t
)
767 (tramp-get-local-gid id-format
)))
768 ;; ... last access, modification and change time
769 (goto-char (point-min))
771 (if (re-search-forward
772 "time::access:\\s-+\\([0-9]+\\)" nil t
)
773 (seconds-to-time (string-to-number (match-string 1)))
775 (goto-char (point-min))
777 (if (re-search-forward
778 "time::modified:\\s-+\\([0-9]+\\)" nil t
)
779 (seconds-to-time (string-to-number (match-string 1)))
781 (goto-char (point-min))
783 (if (re-search-forward
784 "time::changed:\\s-+\\([0-9]+\\)" nil t
)
785 (seconds-to-time (string-to-number (match-string 1)))
788 (goto-char (point-min))
790 (if (re-search-forward
791 "standard::size:\\s-+\\([0-9]+\\)" nil t
)
792 (string-to-number (match-string 1)) 0))
793 ;; ... file mode flags
794 (goto-char (point-min))
796 (if (re-search-forward "unix::mode:\\s-+\\([0-9]+\\)" nil t
)
797 (tramp-file-mode-from-int (match-string 1))
798 (if dirp
"drwx------" "-rwx------")))
799 ;; ... inode and device
800 (goto-char (point-min))
802 (if (re-search-forward "unix::inode:\\s-+\\([0-9]+\\)" nil t
)
803 (string-to-number (match-string 1))
804 (tramp-get-inode v
)))
805 (goto-char (point-min))
807 (if (re-search-forward "unix::device:\\s-+\\([0-9]+\\)" nil t
)
808 (string-to-number (match-string 1))
809 (tramp-get-device v
)))
811 ;; Return data gathered.
813 ;; 0. t for directory, string (name linked to) for
814 ;; symbolic link, or nil.
815 (or dirp res-symlink-target
)
816 ;; 1. Number of links to file.
822 ;; 4. Last access time, as a list of integers.
823 ;; 5. Last modification time, likewise.
824 ;; 6. Last status change time, likewise.
825 res-access res-mod res-change
826 ;; 7. Size in bytes (-1, if number is out of range).
830 ;; 9. t if file's gid would change if file were deleted
835 ;; 11. Device number.
839 (defun tramp-gvfs-handle-file-directory-p (filename)
840 "Like `file-directory-p' for Tramp files."
841 (eq t
(car (file-attributes filename
))))
843 (defun tramp-gvfs-handle-file-executable-p (filename)
844 "Like `file-executable-p' for Tramp files."
845 (with-parsed-tramp-file-name filename nil
846 (with-tramp-file-property v localname
"file-executable-p"
847 (tramp-check-cached-permissions v ?x
))))
849 (defun tramp-gvfs-handle-file-local-copy (filename)
850 "Like `file-local-copy' for Tramp files."
851 (with-parsed-tramp-file-name filename nil
852 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
853 (unless (file-exists-p filename
)
856 "Cannot make local copy of non-existing file `%s'" filename
))
857 (copy-file filename tmpfile t t
)
860 (defun tramp-gvfs-handle-file-name-all-completions (filename directory
)
861 "Like `file-name-all-completions' for Tramp files."
862 (unless (save-match-data (string-match "/" filename
))
863 (with-parsed-tramp-file-name (expand-file-name directory
) nil
870 ;; Try cache entries for filename, filename with last
871 ;; character removed, filename with last two characters
872 ;; removed, ..., and finally the empty string - all
873 ;; concatenated to the local directory name.
874 (let ((remote-file-name-inhibit-cache
875 (or remote-file-name-inhibit-cache
876 tramp-completion-reread-directory-timeout
)))
878 ;; This is inefficient for very long filenames, pity
879 ;; `reduce' is not available...
886 (tramp-get-file-property
888 (concat localname
(substring filename
0 x
))
889 "file-name-all-completions"
891 (when cache-hit
(list cache-hit
))))
892 ;; We cannot use a length of 0, because file properties
893 ;; for "foo" and "foo/" are identical.
894 (tramp-compat-number-sequence (length filename
) 1 -
1)))))
896 ;; Cache expired or no matching cache entry found so we need
897 ;; to perform a remote operation.
898 (let ((result '("." ".."))
900 ;; Get a list of directories and files.
901 (tramp-gvfs-send-command
902 v
"gvfs-ls" (tramp-gvfs-url-file-name directory
))
904 ;; Now grab the output.
906 (insert-buffer-substring (tramp-get-connection-buffer v
))
907 (goto-char (point-max))
908 (while (zerop (forward-line -
1))
909 (setq entry
(buffer-substring (point) (point-at-eol)))
910 (when (string-match filename entry
)
911 (if (file-directory-p (expand-file-name entry directory
))
912 (push (concat entry
"/") result
)
913 (push entry result
)))))
915 ;; Because the remote op went through OK we know the
916 ;; directory we `cd'-ed to exists.
917 (tramp-set-file-property v localname
"file-exists-p" t
)
919 ;; Because the remote op went through OK we know every
920 ;; file listed by `ls' exists.
921 (mapc (lambda (entry)
922 (tramp-set-file-property
923 v
(concat localname entry
) "file-exists-p" t
))
926 ;; Store result in the cache.
927 (tramp-set-file-property
928 v
(concat localname filename
)
929 "file-name-all-completions" result
))))))))
931 (defun tramp-gvfs-handle-file-notify-add-watch (file-name _flags _callback
)
932 "Like `file-notify-add-watch' for Tramp files."
933 (setq file-name
(expand-file-name file-name
))
934 (with-parsed-tramp-file-name file-name nil
935 (let ((p (start-process
936 "gvfs-monitor-file" (generate-new-buffer " *gvfs-monitor-file*")
937 "gvfs-monitor-file" (tramp-gvfs-url-file-name file-name
))))
938 (if (not (processp p
))
940 v
'file-notify-error
"gvfs-monitor-file failed to start")
941 (tramp-compat-set-process-query-on-exit-flag p nil
)
942 (set-process-filter p
'tramp-gvfs-file-gvfs-monitor-file-process-filter
)
943 (with-current-buffer (process-buffer p
)
944 (setq default-directory
(file-name-directory file-name
)))
947 (defun tramp-gvfs-file-gvfs-monitor-file-process-filter (proc string
)
948 "Read output from \"gvfs-monitor-file\" and add corresponding file-notify events."
949 (let* ((rest-string (tramp-compat-process-get proc
'rest-string
))
950 (dd (with-current-buffer (process-buffer proc
) default-directory
))
951 (ddu (regexp-quote (tramp-gvfs-url-file-name dd
))))
953 (tramp-message proc
10 "Previous string:\n%s" rest-string
))
954 (tramp-message proc
6 "%S\n%s" proc string
)
955 (setq string
(concat rest-string string
)
956 ;; Attribute change is returned in unused wording.
957 string
(tramp-compat-replace-regexp-in-string
958 "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string
))
962 "File Monitor Event:[\n\r]+"
963 "File = \\([^\n\r]+\\)[\n\r]+"
964 "Event = \\([^[:blank:]]+\\)[\n\r]+")
966 (let ((action (intern-soft
967 (tramp-compat-replace-regexp-in-string
968 "_" "-" (downcase (match-string 2 string
)))))
969 (file (match-string 1 string
)))
970 (setq string
(replace-match "" nil nil string
))
971 ;; File names are returned as URL paths. We must convert them.
972 (when (string-match ddu file
)
973 (setq file
(replace-match dd nil nil file
)))
974 (while (string-match "%\\([0-9A-F]\\{2\\}\\)" file
)
977 (char-to-string (string-to-number (match-string 1 file
) 16))
979 ;; Usually, we would add an Emacs event now. Unfortunately,
980 ;; `unread-command-events' does not accept several events at
981 ;; once. Therefore, we apply the callback directly.
982 (tramp-compat-funcall 'file-notify-callback
(list proc action file
))))
984 ;; Save rest of the string.
985 (when (zerop (length string
)) (setq string nil
))
986 (when string
(tramp-message proc
10 "Rest string:\n%s" string
))
987 (tramp-compat-process-put proc
'rest-string string
)))
989 (defun tramp-gvfs-handle-file-readable-p (filename)
990 "Like `file-readable-p' for Tramp files."
991 (with-parsed-tramp-file-name filename nil
992 (with-tramp-file-property v localname
"file-executable-p"
993 (tramp-check-cached-permissions v ?r
))))
995 (defun tramp-gvfs-handle-file-writable-p (filename)
996 "Like `file-writable-p' for Tramp files."
997 (with-parsed-tramp-file-name filename nil
998 (with-tramp-file-property v localname
"file-writable-p"
999 (if (file-exists-p filename
)
1000 (tramp-check-cached-permissions v ?w
)
1001 ;; If file doesn't exist, check if directory is writable.
1002 (and (file-directory-p (file-name-directory filename
))
1003 (file-writable-p (file-name-directory filename
)))))))
1005 (defun tramp-gvfs-handle-insert-directory
1006 (filename switches
&optional wildcard full-directory-p
)
1007 "Like `insert-directory' for Tramp files."
1008 ;; gvfs-* output is hard to parse. So we let `ls-lisp' do the job.
1009 (with-parsed-tramp-file-name (expand-file-name filename
) nil
1010 (with-tramp-progress-reporter v
0 (format "Opening directory %s" filename
)
1012 (let (ls-lisp-use-insert-directory-program)
1013 (tramp-run-real-handler
1015 (list filename switches wildcard full-directory-p
))))))
1017 (defun tramp-gvfs-handle-insert-file-contents
1018 (filename &optional visit beg end replace
)
1019 "Like `insert-file-contents' for Tramp files."
1020 (barf-if-buffer-read-only)
1021 (setq filename
(expand-file-name filename
))
1022 (let (tmpfile result
)
1024 (if (not (file-exists-p filename
))
1025 ;; We don't raise a Tramp error, because it might be
1026 ;; suppressed, like in `find-file-noselect-1'.
1027 (signal 'file-error
(list "File not found on remote host" filename
))
1029 (setq tmpfile
(file-local-copy filename
)
1030 result
(insert-file-contents tmpfile visit beg end replace
)))
1033 (setq buffer-file-name filename
)
1034 (setq buffer-read-only
(not (file-writable-p filename
)))
1035 (set-visited-file-modtime)
1036 (set-buffer-modified-p nil
))
1037 (when (stringp tmpfile
)
1038 (delete-file tmpfile
)))
1041 (list filename
(cadr result
))))
1043 (defun tramp-gvfs-handle-make-directory (dir &optional parents
)
1044 "Like `make-directory' for Tramp files."
1045 (with-parsed-tramp-file-name dir nil
1048 'tramp-gvfs-send-command v
"gvfs-mkdir"
1050 (list "-p" (tramp-gvfs-url-file-name dir
))
1051 (list (tramp-gvfs-url-file-name dir
))))
1052 ;; Propagate the error.
1053 (tramp-error v
'file-error
"Couldn't make directory %s" dir
))))
1055 (defun tramp-gvfs-handle-rename-file
1056 (filename newname
&optional ok-if-already-exists
)
1057 "Like `rename-file' for Tramp files."
1058 (with-parsed-tramp-file-name
1059 (if (tramp-tramp-file-p filename
) filename newname
) nil
1061 (when (and (not ok-if-already-exists
) (file-exists-p newname
))
1063 v
'file-already-exists
"File %s already exists" newname
))
1065 (if (or (and (tramp-tramp-file-p filename
)
1066 (not (tramp-gvfs-file-name-p filename
)))
1067 (and (tramp-tramp-file-p newname
)
1068 (not (tramp-gvfs-file-name-p newname
))))
1070 ;; We cannot move directly.
1071 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
1072 (rename-file filename tmpfile t
)
1073 (rename-file tmpfile newname ok-if-already-exists
))
1076 (with-tramp-progress-reporter
1077 v
0 (format "Renaming %s to %s" filename newname
)
1079 (tramp-gvfs-send-command
1081 (tramp-gvfs-url-file-name filename
)
1082 (tramp-gvfs-url-file-name newname
))
1083 ;; Propagate the error.
1084 (with-current-buffer (tramp-get-buffer v
)
1085 (goto-char (point-min))
1086 (tramp-error-with-buffer
1088 "Renaming failed, see buffer `%s' for details." (buffer-name)))))
1090 (when (file-remote-p filename
)
1091 (with-parsed-tramp-file-name filename nil
1092 (tramp-flush-file-property v
(file-name-directory localname
))
1093 (tramp-flush-file-property v localname
)))
1095 (when (file-remote-p newname
)
1096 (with-parsed-tramp-file-name newname nil
1097 (tramp-flush-file-property v
(file-name-directory localname
))
1098 (tramp-flush-file-property v localname
))))))
1100 (defun tramp-gvfs-handle-write-region
1101 (start end filename
&optional _append visit _lockname confirm
)
1102 "Like `write-region' for Tramp files."
1103 (with-parsed-tramp-file-name filename nil
1104 ;; XEmacs takes a coding system as the seventh argument, not `confirm'.
1105 (when (and (not (featurep 'xemacs
)) confirm
(file-exists-p filename
))
1106 (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename
))
1107 (tramp-error v
'file-error
"File not overwritten")))
1109 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
1110 (write-region start end tmpfile
)
1112 (rename-file tmpfile filename
'ok-if-already-exists
)
1114 (delete-file tmpfile
)
1116 v
'file-error
"Couldn't write region to `%s'" filename
))))
1118 (tramp-flush-file-property v
(file-name-directory localname
))
1119 (tramp-flush-file-property v localname
)
1121 ;; Set file modification time.
1122 (when (or (eq visit t
) (stringp visit
))
1123 (set-visited-file-modtime (nth 5 (file-attributes filename
))))
1126 (when (or (eq visit t
) (null visit
) (stringp visit
))
1127 (tramp-message v
0 "Wrote %s" filename
))
1128 (run-hooks 'tramp-handle-write-region-hook
)))
1131 ;; File name conversions.
1133 (defun tramp-gvfs-url-file-name (filename)
1134 "Return FILENAME in URL syntax."
1135 ;; "/" must NOT be hexlified.
1136 (let ((url-unreserved-chars (append '(?
/) url-unreserved-chars
))
1141 (if (tramp-tramp-file-p filename
)
1142 (with-parsed-tramp-file-name filename nil
1143 (when (and user
(string-match tramp-user-with-domain-regexp user
))
1145 (concat (match-string 2 user
) ";" (match-string 1 user
))))
1146 (url-parse-make-urlobj
1147 method
(url-hexify-string user
) nil
1148 (tramp-file-name-real-host v
) (tramp-file-name-port v
)
1149 (url-hexify-string localname
) nil nil t
))
1150 (url-parse-make-urlobj
1151 "file" nil nil nil nil
1152 (url-hexify-string (file-truename filename
)) nil nil t
))))
1153 (when (tramp-tramp-file-p filename
)
1154 (with-parsed-tramp-file-name filename nil
1155 (tramp-message v
10 "remote file `%s' is URL `%s'" filename result
)))
1158 (defun tramp-gvfs-object-path (filename)
1159 "Create a D-Bus object path from FILENAME."
1160 (expand-file-name (dbus-escape-as-identifier filename
) tramp-gvfs-path-tramp
))
1162 (defun tramp-gvfs-file-name (object-path)
1163 "Retrieve file name from D-Bus OBJECT-PATH."
1164 (dbus-unescape-from-identifier
1165 (tramp-compat-replace-regexp-in-string
1166 "^.*/\\([^/]+\\)$" "\\1" object-path
)))
1168 (defun tramp-bluez-address (device)
1169 "Return bluetooth device address from a given bluetooth DEVICE name."
1170 (when (stringp device
)
1171 (if (string-match tramp-ipv6-regexp device
)
1172 (match-string 0 device
)
1173 (cadr (assoc device
(tramp-bluez-list-devices))))))
1175 (defun tramp-bluez-device (address)
1176 "Return bluetooth device name from a given bluetooth device ADDRESS.
1177 ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1178 (when (stringp address
)
1179 (while (string-match "[][]" address
)
1180 (setq address
(replace-match "" t t address
)))
1182 (dolist (item (tramp-bluez-list-devices) result
)
1183 (when (string-match address
(cadr item
))
1184 (setq result
(car item
)))))))
1187 ;; D-Bus GVFS functions.
1189 (defun tramp-gvfs-handler-askpassword (message user domain flags
)
1190 "Implementation for the \"org.gtk.vfs.MountOperation.askPassword\" method."
1192 (tramp-gvfs-file-name (dbus-event-path-name last-input-event
)))
1196 (if (string-match "\\([pP]assword\\|[pP]assphrase\\)" message
)
1197 (capitalize (match-string 1 message
))
1203 (with-parsed-tramp-file-name filename l
1204 (when (and (zerop (length user
))
1206 (zerop (logand flags tramp-gvfs-password-need-username
))))
1207 (setq user
(read-string "User name: ")))
1208 (when (and (zerop (length domain
))
1209 (not (zerop (logand flags tramp-gvfs-password-need-domain
))))
1210 (setq domain
(read-string "Domain name: ")))
1212 (tramp-message l
6 "%S %S %S %d" message user domain flags
)
1213 (setq tramp-current-method l-method
1214 tramp-current-user user
1215 tramp-current-host l-host
1216 password
(tramp-read-passwd
1217 (tramp-get-connection-process l
) pw-prompt
))
1220 (if (stringp password
)
1222 t
;; password handled.
1223 nil
;; no abort of D-Bus.
1225 (tramp-file-name-real-user l
)
1227 nil
;; not anonymous.
1228 0) ;; no password save.
1229 ;; No password provided.
1230 (list nil t
"" (tramp-file-name-real-user l
) domain nil
0)))
1232 ;; When QUIT is raised, we shall return this information to D-Bus.
1233 (quit (list nil t
"" "" "" nil
0)))))
1235 (defun tramp-gvfs-handler-askquestion (message choices
)
1236 "Implementation for the \"org.gtk.vfs.MountOperation.askQuestion\" method."
1237 (save-window-excursion
1238 (let ((enable-recursive-minibuffers t
)
1242 (with-parsed-tramp-file-name
1243 (tramp-gvfs-file-name (dbus-event-path-name last-input-event
)) nil
1244 (tramp-message v
6 "%S %S" message choices
)
1246 ;; In theory, there can be several choices. Until now,
1247 ;; there is only the question whether to accept an unknown
1250 ;; Preserve message for `progress-reporter'.
1251 (tramp-compat-with-temp-message ""
1253 (pop-to-buffer (current-buffer))
1254 (setq choice
(if (yes-or-no-p (concat (car choices
) " ")) 0 1))
1255 (tramp-message v
6 "%d" choice
)))
1257 ;; When the choice is "no", we set a dummy fuse-mountpoint
1258 ;; in order to leave the timeout.
1259 (unless (zerop choice
)
1260 (tramp-set-file-property v
"/" "fuse-mountpoint" "/"))
1264 nil
;; no abort of D-Bus.
1267 ;; When QUIT is raised, we shall return this information to D-Bus.
1268 (quit (list nil t
0))))))
1270 (defun tramp-gvfs-handler-mounted-unmounted (mount-info)
1271 "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and
1272 \"org.gtk.vfs.MountTracker.unmounted\" signals."
1274 (let ((signal-name (dbus-event-member-name last-input-event
))
1276 ;; Jump over the first elements of the mount info. Since there
1277 ;; were changes in the entries, we cannot access dedicated
1279 (while (stringp (car elt
)) (setq elt
(cdr elt
)))
1280 (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt
)))
1281 (mount-spec (caddr elt
))
1282 (default-location (tramp-gvfs-dbus-byte-array-to-string
1284 (method (tramp-gvfs-dbus-byte-array-to-string
1285 (cadr (assoc "type" (cadr mount-spec
)))))
1286 (user (tramp-gvfs-dbus-byte-array-to-string
1287 (cadr (assoc "user" (cadr mount-spec
)))))
1288 (domain (tramp-gvfs-dbus-byte-array-to-string
1289 (cadr (assoc "domain" (cadr mount-spec
)))))
1290 (host (tramp-gvfs-dbus-byte-array-to-string
1291 (cadr (or (assoc "host" (cadr mount-spec
))
1292 (assoc "server" (cadr mount-spec
))))))
1293 (port (tramp-gvfs-dbus-byte-array-to-string
1294 (cadr (assoc "port" (cadr mount-spec
)))))
1295 (ssl (tramp-gvfs-dbus-byte-array-to-string
1296 (cadr (assoc "ssl" (cadr mount-spec
)))))
1297 (prefix (concat (tramp-gvfs-dbus-byte-array-to-string
1299 (tramp-gvfs-dbus-byte-array-to-string
1300 (cadr (assoc "share" (cadr mount-spec
)))))))
1301 (when (string-match "^smb" method
)
1302 (setq method
"smb"))
1303 (when (string-equal "obex" method
)
1304 (setq host
(tramp-bluez-device host
)))
1305 (when (and (string-equal "dav" method
) (string-equal "true" ssl
))
1306 (setq method
"davs"))
1307 (unless (zerop (length domain
))
1308 (setq user
(concat user tramp-prefix-domain-format domain
)))
1309 (unless (zerop (length port
))
1310 (setq host
(concat host tramp-prefix-port-format port
)))
1311 (with-parsed-tramp-file-name
1312 (tramp-make-tramp-file-name method user host
"") nil
1315 signal-name
(tramp-gvfs-stringify-dbus-message mount-info
))
1316 (tramp-set-file-property v
"/" "list-mounts" 'undef
)
1317 (if (string-equal (downcase signal-name
) "unmounted")
1318 (tramp-set-file-property v
"/" "fuse-mountpoint" nil
)
1319 ;; Set prefix, mountpoint and location.
1320 (unless (string-equal prefix
"/")
1321 (tramp-set-file-property v
"/" "prefix" prefix
))
1322 (tramp-set-file-property v
"/" "fuse-mountpoint" fuse-mountpoint
)
1323 (tramp-set-file-property
1324 v
"/" "default-location" default-location
)))))))
1326 (when tramp-gvfs-enabled
1327 (dbus-register-signal
1328 :session nil tramp-gvfs-path-mounttracker
1329 tramp-gvfs-interface-mounttracker
"mounted"
1330 'tramp-gvfs-handler-mounted-unmounted
)
1331 (dbus-register-signal
1332 :session nil tramp-gvfs-path-mounttracker
1333 tramp-gvfs-interface-mounttracker
"Mounted"
1334 'tramp-gvfs-handler-mounted-unmounted
)
1336 (dbus-register-signal
1337 :session nil tramp-gvfs-path-mounttracker
1338 tramp-gvfs-interface-mounttracker
"unmounted"
1339 'tramp-gvfs-handler-mounted-unmounted
)
1340 (dbus-register-signal
1341 :session nil tramp-gvfs-path-mounttracker
1342 tramp-gvfs-interface-mounttracker
"Unmounted"
1343 'tramp-gvfs-handler-mounted-unmounted
))
1345 (defun tramp-gvfs-connection-mounted-p (vec)
1346 "Check, whether the location is already mounted."
1348 (tramp-get-file-property vec
"/" "fuse-mountpoint" nil
)
1352 (with-tramp-file-property vec
"/" "list-mounts"
1353 (with-tramp-dbus-call-method vec t
1354 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1355 tramp-gvfs-interface-mounttracker tramp-gvfs-listmounts
))
1357 ;; Jump over the first elements of the mount info. Since there
1358 ;; were changes in the entries, we cannot access dedicated
1360 (while (stringp (car elt
)) (setq elt
(cdr elt
)))
1361 (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string
1363 (mount-spec (caddr elt
))
1364 (default-location (tramp-gvfs-dbus-byte-array-to-string
1366 (method (tramp-gvfs-dbus-byte-array-to-string
1367 (cadr (assoc "type" (cadr mount-spec
)))))
1368 (user (tramp-gvfs-dbus-byte-array-to-string
1369 (cadr (assoc "user" (cadr mount-spec
)))))
1370 (domain (tramp-gvfs-dbus-byte-array-to-string
1371 (cadr (assoc "domain" (cadr mount-spec
)))))
1372 (host (tramp-gvfs-dbus-byte-array-to-string
1373 (cadr (or (assoc "host" (cadr mount-spec
))
1374 (assoc "server" (cadr mount-spec
))))))
1375 (port (tramp-gvfs-dbus-byte-array-to-string
1376 (cadr (assoc "port" (cadr mount-spec
)))))
1377 (ssl (tramp-gvfs-dbus-byte-array-to-string
1378 (cadr (assoc "ssl" (cadr mount-spec
)))))
1379 (prefix (concat (tramp-gvfs-dbus-byte-array-to-string
1381 (tramp-gvfs-dbus-byte-array-to-string
1382 (cadr (assoc "share" (cadr mount-spec
)))))))
1383 (when (string-match "^smb" method
)
1384 (setq method
"smb"))
1385 (when (string-equal "obex" method
)
1386 (setq host
(tramp-bluez-device host
)))
1387 (when (and (string-equal "dav" method
) (string-equal "true" ssl
))
1388 (setq method
"davs"))
1389 (when (and (string-equal "synce" method
) (zerop (length user
)))
1390 (setq user
(or (tramp-file-name-user vec
) "")))
1391 (unless (zerop (length domain
))
1392 (setq user
(concat user tramp-prefix-domain-format domain
)))
1393 (unless (zerop (length port
))
1394 (setq host
(concat host tramp-prefix-port-format port
)))
1396 (string-equal method
(tramp-file-name-method vec
))
1397 (string-equal user
(or (tramp-file-name-user vec
) ""))
1398 (string-equal host
(tramp-file-name-host vec
))
1399 (string-match (concat "^" (regexp-quote prefix
))
1400 (tramp-file-name-localname vec
)))
1401 ;; Set prefix, mountpoint and location.
1402 (unless (string-equal prefix
"/")
1403 (tramp-set-file-property vec
"/" "prefix" prefix
))
1404 (tramp-set-file-property vec
"/" "fuse-mountpoint" fuse-mountpoint
)
1405 (tramp-set-file-property vec
"/" "default-location" default-location
)
1406 (throw 'mounted t
)))))))
1408 (defun tramp-gvfs-mount-spec-entry (key value
)
1409 "Construct a mount-spec entry to be used in a mount_spec.
1410 It was \"a(say)\", but has changed to \"a{sv})\"."
1411 (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature
)
1412 (list :dict-entry key
1413 (list :variant
(tramp-gvfs-dbus-string-to-byte-array value
)))
1414 (list :struct key
(tramp-gvfs-dbus-string-to-byte-array value
))))
1416 (defun tramp-gvfs-mount-spec (vec)
1417 "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"."
1418 (let* ((method (tramp-file-name-method vec
))
1419 (user (tramp-file-name-real-user vec
))
1420 (domain (tramp-file-name-domain vec
))
1421 (host (tramp-file-name-real-host vec
))
1422 (port (tramp-file-name-port vec
))
1423 (localname (tramp-file-name-localname vec
))
1424 (ssl (if (string-match "^davs" method
) "true" "false"))
1428 ((string-equal "smb" method
)
1429 (string-match "^/?\\([^/]+\\)" localname
)
1430 (list (tramp-gvfs-mount-spec-entry "type" "smb-share")
1431 (tramp-gvfs-mount-spec-entry "server" host
)
1432 (tramp-gvfs-mount-spec-entry
1433 "share" (match-string 1 localname
))))
1434 ((string-equal "obex" method
)
1435 (list (tramp-gvfs-mount-spec-entry "type" method
)
1436 (tramp-gvfs-mount-spec-entry
1437 "host" (concat "[" (tramp-bluez-address host
) "]"))))
1438 ((string-match "\\`dav" method
)
1439 (list (tramp-gvfs-mount-spec-entry "type" "dav")
1440 (tramp-gvfs-mount-spec-entry "host" host
)
1441 (tramp-gvfs-mount-spec-entry "ssl" ssl
)))
1443 (list (tramp-gvfs-mount-spec-entry "type" method
)
1444 (tramp-gvfs-mount-spec-entry "host" host
))))
1446 (list (tramp-gvfs-mount-spec-entry "user" user
)))
1448 (list (tramp-gvfs-mount-spec-entry "domain" domain
)))
1450 (list (tramp-gvfs-mount-spec-entry
1451 "port" (number-to-string port
))))))
1453 (if (and (string-match "\\`dav" method
)
1454 (string-match "^/?[^/]+" localname
))
1455 (match-string 0 localname
)
1459 `(:struct
,(tramp-gvfs-dbus-string-to-byte-array mount-pref
) ,mount-spec
)))
1462 ;; Connection functions.
1464 (defun tramp-gvfs-maybe-open-connection (vec)
1465 "Maybe open a connection VEC.
1466 Does not do anything if a connection is already open, but re-opens the
1467 connection if a previous connection has died for some reason."
1468 (tramp-check-proper-method-and-host vec
)
1470 ;; We set the file name, in case there are incoming D-Bus signals or
1472 (setq tramp-gvfs-dbus-event-vector vec
)
1474 ;; For password handling, we need a process bound to the connection
1475 ;; buffer. Therefore, we create a dummy process. Maybe there is a
1477 (unless (get-buffer-process (tramp-get-connection-buffer vec
))
1478 (let ((p (make-network-process
1479 :name
(tramp-buffer-name vec
)
1480 :buffer
(tramp-get-connection-buffer vec
)
1481 :server t
:host
'local
:service t
)))
1482 (tramp-compat-set-process-query-on-exit-flag p nil
)))
1484 (unless (tramp-gvfs-connection-mounted-p vec
)
1485 (let* ((method (tramp-file-name-method vec
))
1486 (user (tramp-file-name-user vec
))
1487 (host (tramp-file-name-host vec
))
1488 (localname (tramp-file-name-localname vec
))
1490 (tramp-gvfs-object-path
1491 (tramp-make-tramp-file-name method user host
""))))
1493 (when (and (string-equal method
"smb")
1494 (string-equal localname
"/"))
1495 (tramp-error vec
'file-error
"Filename must contain a Windows share"))
1497 (with-tramp-progress-reporter
1499 (if (zerop (length user
))
1500 (format "Opening connection for %s using %s" host method
)
1501 (format "Opening connection for %s@%s using %s" user host method
))
1503 ;; Enable auth-source and password-cache.
1504 (tramp-set-connection-property vec
"first-password-request" t
)
1506 ;; There will be a callback of "askPassword" when a password is
1508 (dbus-register-method
1509 :session dbus-service-emacs object-path
1510 tramp-gvfs-interface-mountoperation
"askPassword"
1511 'tramp-gvfs-handler-askpassword
)
1512 (dbus-register-method
1513 :session dbus-service-emacs object-path
1514 tramp-gvfs-interface-mountoperation
"AskPassword"
1515 'tramp-gvfs-handler-askpassword
)
1517 ;; There could be a callback of "askQuestion" when adding fingerprint.
1518 (dbus-register-method
1519 :session dbus-service-emacs object-path
1520 tramp-gvfs-interface-mountoperation
"askQuestion"
1521 'tramp-gvfs-handler-askquestion
)
1522 (dbus-register-method
1523 :session dbus-service-emacs object-path
1524 tramp-gvfs-interface-mountoperation
"AskQuestion"
1525 'tramp-gvfs-handler-askquestion
)
1527 ;; The call must be asynchronously, because of the "askPassword"
1528 ;; or "askQuestion"callbacks.
1529 (if (string-match "(so)$" tramp-gvfs-mountlocation-signature
)
1530 (with-tramp-dbus-call-method vec nil
1531 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1532 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1533 (tramp-gvfs-mount-spec vec
)
1534 `(:struct
:string
,(dbus-get-unique-name :session
)
1535 :object-path
,object-path
))
1536 (with-tramp-dbus-call-method vec nil
1537 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1538 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1539 (tramp-gvfs-mount-spec vec
)
1540 :string
(dbus-get-unique-name :session
) :object-path object-path
))
1542 ;; We must wait, until the mount is applied. This will be
1543 ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint"
1546 ((or (tramp-get-method-parameter method
'tramp-connection-timeout
)
1547 tramp-connection-timeout
)
1548 (if (zerop (length (tramp-file-name-user vec
)))
1551 "Timeout reached mounting %s using %s" host method
)
1554 "Timeout reached mounting %s@%s using %s" user host method
)))
1555 (while (not (tramp-get-file-property vec
"/" "fuse-mountpoint" nil
))
1556 (read-event nil nil
0.1)))
1558 ;; If `tramp-gvfs-handler-askquestion' has returned "No", it
1559 ;; is marked with the fuse-mountpoint "/". We shall react.
1561 (tramp-get-file-property vec
"/" "fuse-mountpoint" "") "/")
1562 (tramp-error vec
'file-error
"FUSE mount denied"))
1564 ;; In `tramp-check-cached-permissions', the connection
1565 ;; properties {uig,gid}-{integer,string} are used. We set
1566 ;; them to their local counterparts.
1567 (tramp-set-connection-property
1568 vec
"uid-integer" (tramp-get-local-uid 'integer
))
1569 (tramp-set-connection-property
1570 vec
"gid-integer" (tramp-get-local-gid 'integer
))
1571 (tramp-set-connection-property
1572 vec
"uid-string" (tramp-get-local-uid 'string
))
1573 (tramp-set-connection-property
1574 vec
"gid-string" (tramp-get-local-gid 'string
))))))
1576 (defun tramp-gvfs-send-command (vec command
&rest args
)
1577 "Send the COMMAND with its ARGS to connection VEC.
1578 COMMAND is usually a command from the gvfs-* utilities.
1579 `call-process' is applied, and it returns `t' if the return code is zero."
1581 (with-current-buffer (tramp-get-connection-buffer vec
)
1582 (tramp-gvfs-maybe-open-connection vec
)
1584 (tramp-message vec
6 "%s %s" command
(mapconcat 'identity args
" "))
1585 (setq result
(apply 'tramp-call-process command nil t nil args
))
1586 (tramp-message vec
6 "\n%s" (buffer-string))
1590 ;; D-Bus BLUEZ functions.
1592 (defun tramp-bluez-list-devices ()
1593 "Return all discovered bluetooth devices as list.
1594 Every entry is a list (NAME ADDRESS).
1596 If `tramp-bluez-discover-devices-timeout' is an integer, and the last
1597 discovery happened more time before indicated there, a rescan will be
1598 started, which lasts some ten seconds. Otherwise, cached results will
1600 ;; Reset the scanned devices list if time has passed.
1601 (and (integerp tramp-bluez-discover-devices-timeout
)
1602 (integerp tramp-bluez-discovery
)
1603 (> (tramp-time-diff (current-time) tramp-bluez-discovery
)
1604 tramp-bluez-discover-devices-timeout
)
1605 (setq tramp-bluez-devices nil
))
1607 ;; Rescan if needed.
1608 (unless tramp-bluez-devices
1610 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1611 :system tramp-bluez-service
"/"
1612 tramp-bluez-interface-manager
"DefaultAdapter")))
1613 (setq tramp-bluez-devices nil
1614 tramp-bluez-discovery t
)
1615 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil
1616 :system tramp-bluez-service object-path
1617 tramp-bluez-interface-adapter
"StartDiscovery")
1618 (while tramp-bluez-discovery
1619 (read-event nil nil
0.1))))
1620 (setq tramp-bluez-discovery
(current-time))
1621 (tramp-message tramp-gvfs-dbus-event-vector
10 "%s" tramp-bluez-devices
)
1622 tramp-bluez-devices
)
1624 (defun tramp-bluez-property-changed (property value
)
1625 "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal."
1626 (tramp-message tramp-gvfs-dbus-event-vector
6 "%s %s" property value
)
1628 ((string-equal property
"Discovering")
1630 ;; "Discovering" FALSE means discovery run has been completed.
1631 ;; We stop it, because we don't need another run.
1632 (setq tramp-bluez-discovery nil
)
1633 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1634 :system tramp-bluez-service
(dbus-event-path-name last-input-event
)
1635 tramp-bluez-interface-adapter
"StopDiscovery")))))
1637 (dbus-register-signal
1638 :system nil nil tramp-bluez-interface-adapter
"PropertyChanged"
1639 'tramp-bluez-property-changed
)
1641 (defun tramp-bluez-device-found (device args
)
1642 "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal."
1643 (tramp-message tramp-gvfs-dbus-event-vector
6 "%s %s" device args
)
1644 (let ((alias (car (cadr (assoc "Alias" args
))))
1645 (address (car (cadr (assoc "Address" args
)))))
1646 ;; Maybe we shall check the device class for being a proper
1647 ;; device, and call also SDP in order to find the obex service.
1648 (add-to-list 'tramp-bluez-devices
(list alias address
))))
1650 (dbus-register-signal
1651 :system nil nil tramp-bluez-interface-adapter
"DeviceFound"
1652 'tramp-bluez-device-found
)
1654 (defun tramp-bluez-parse-device-names (_ignore)
1655 "Return a list of (nil host) tuples allowed to access."
1657 (lambda (x) (list nil
(car x
)))
1658 (tramp-bluez-list-devices)))
1660 ;; Add completion function for OBEX method.
1661 (when (member tramp-bluez-service
(dbus-list-known-names :system
))
1662 (tramp-set-completion-function
1663 "obex" '((tramp-bluez-parse-device-names ""))))
1666 ;; D-Bus zeroconf functions.
1668 (defun tramp-zeroconf-parse-workstation-device-names (_ignore)
1669 "Return a list of (user host) tuples allowed to access."
1672 (list nil
(zeroconf-service-host x
)))
1673 (zeroconf-list-services "_workstation._tcp")))
1675 (defun tramp-zeroconf-parse-webdav-device-names (_ignore)
1676 "Return a list of (user host) tuples allowed to access."
1679 (let ((host (zeroconf-service-host x
))
1680 (port (zeroconf-service-port x
))
1681 (text (zeroconf-service-txt x
))
1684 (setq host
(format "%s%s%d" host tramp-prefix-port-regexp port
)))
1685 ;; A user is marked in a TXT field like "u=guest".
1687 (when (string-match "u=\\(.+\\)$" (car text
))
1688 (setq user
(match-string 1 (car text
))))
1689 (setq text
(cdr text
)))
1691 (zeroconf-list-services "_webdav._tcp")))
1693 ;; Add completion function for DAV and DAVS methods.
1694 (when (member zeroconf-service-avahi
(dbus-list-known-names :system
))
1695 (zeroconf-init tramp-gvfs-zeroconf-domain
)
1696 (tramp-set-completion-function
1697 "sftp" '((tramp-zeroconf-parse-workstation-device-names "")))
1698 (tramp-set-completion-function
1699 "dav" '((tramp-zeroconf-parse-webdav-device-names "")))
1700 (tramp-set-completion-function
1701 "davs" '((tramp-zeroconf-parse-webdav-device-names ""))))
1704 ;; D-Bus SYNCE functions.
1706 (defun tramp-synce-list-devices ()
1707 "Return all discovered synce devices as list.
1708 They are retrieved from the hal daemon."
1709 (let (tramp-synce-devices)
1711 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1712 :system tramp-hal-service tramp-hal-path-manager
1713 tramp-hal-interface-manager
"GetAllDevices"))
1714 (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1715 :system tramp-hal-service device tramp-hal-interface-device
1716 "PropertyExists" "sync.plugin")
1718 (with-tramp-dbus-call-method
1719 tramp-gvfs-dbus-event-vector t
1720 :system tramp-hal-service device tramp-hal-interface-device
1721 "GetPropertyString" "pda.pocketpc.name")))
1722 (unless (member prop tramp-synce-devices
)
1723 (push prop tramp-synce-devices
)))))
1724 (tramp-message tramp-gvfs-dbus-event-vector
10 "%s" tramp-synce-devices
)
1725 tramp-synce-devices
))
1727 (defun tramp-synce-parse-device-names (_ignore)
1728 "Return a list of (nil host) tuples allowed to access."
1730 (lambda (x) (list nil x
))
1731 (tramp-synce-list-devices)))
1733 ;; Add completion function for SYNCE method.
1734 (tramp-set-completion-function
1735 "synce" '((tramp-synce-parse-device-names "")))
1737 (add-hook 'tramp-unload-hook
1739 (unload-feature 'tramp-gvfs
'force
)))
1741 (provide 'tramp-gvfs
)
1745 ;; * Host name completion via smb-server or smb-network.
1746 ;; * Check how two shares of the same SMB server can be mounted in
1748 ;; * Apply SDP on bluetooth devices, in order to filter out obex
1750 ;; * Implement obex for other serial communication but bluetooth.
1752 ;;; tramp-gvfs.el ends here