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' performed by default handler.
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-compat-user-error "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 copy directly.
598 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
600 (preserve-extended-attributes
602 filename tmpfile t keep-date preserve-uid-gid
603 preserve-extended-attributes
))
605 (copy-file filename tmpfile t keep-date preserve-uid-gid
))
607 (copy-file filename tmpfile t keep-date
)))
608 (rename-file tmpfile newname ok-if-already-exists
))
611 (with-tramp-progress-reporter
612 v
0 (format "Copying %s to %s" filename newname
)
615 (append (if (or keep-date preserve-uid-gid
)
619 (tramp-gvfs-url-file-name filename
)
620 (tramp-gvfs-url-file-name newname
)))))
621 (apply 'tramp-gvfs-send-command v
"gvfs-copy" args
))
622 ;; Propagate the error.
623 (with-current-buffer (tramp-get-connection-buffer v
)
624 (goto-char (point-min))
625 (tramp-error-with-buffer
627 "Copying failed, see buffer `%s' for details." (buffer-name)))))
629 (when (file-remote-p newname
)
630 (with-parsed-tramp-file-name newname nil
631 (tramp-flush-file-property v
(file-name-directory localname
))
632 (tramp-flush-file-property v localname
))))))
634 (defun tramp-gvfs-handle-delete-directory (directory &optional recursive trash
)
635 "Like `delete-directory' for Tramp files."
636 (when (and recursive
(not (file-symlink-p directory
)))
638 (if (eq t
(car (file-attributes file
)))
639 (tramp-compat-delete-directory file recursive trash
)
640 (tramp-compat-delete-file file trash
)))
642 directory
'full
"^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
643 (with-parsed-tramp-file-name directory nil
644 (tramp-flush-file-property v
(file-name-directory localname
))
645 (tramp-flush-directory-property v localname
)
647 (tramp-gvfs-send-command
648 v
(if (and trash delete-by-moving-to-trash
) "gvfs-trash" "gvfs-rm")
649 (tramp-gvfs-url-file-name directory
))
650 ;; Propagate the error.
651 (with-current-buffer (tramp-get-connection-buffer v
)
652 (goto-char (point-min))
653 (tramp-error-with-buffer
654 nil v
'file-error
"Couldn't delete %s" directory
)))))
656 (defun tramp-gvfs-handle-delete-file (filename &optional trash
)
657 "Like `delete-file' for Tramp files."
658 (with-parsed-tramp-file-name filename nil
659 (tramp-flush-file-property v
(file-name-directory localname
))
660 (tramp-flush-directory-property v localname
)
662 (tramp-gvfs-send-command
663 v
(if (and trash delete-by-moving-to-trash
) "gvfs-trash" "gvfs-rm")
664 (tramp-gvfs-url-file-name filename
))
665 ;; Propagate the error.
666 (with-current-buffer (tramp-get-connection-buffer v
)
667 (goto-char (point-min))
668 (tramp-error-with-buffer
669 nil v
'file-error
"Couldn't delete %s" filename
)))))
671 (defun tramp-gvfs-handle-expand-file-name (name &optional dir
)
672 "Like `expand-file-name' for Tramp files."
673 ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
674 (setq dir
(or dir default-directory
"/"))
675 ;; Unless NAME is absolute, concat DIR and NAME.
676 (unless (file-name-absolute-p name
)
677 (setq name
(concat (file-name-as-directory dir
) name
)))
678 ;; If NAME is not a Tramp file, run the real handler.
679 (if (not (tramp-tramp-file-p name
))
680 (tramp-run-real-handler 'expand-file-name
(list name nil
))
682 (with-parsed-tramp-file-name name nil
683 ;; If there is a default location, expand tilde.
684 (when (string-match "\\`\\(~\\)\\(/\\|\\'\\)" localname
)
686 (tramp-gvfs-maybe-open-connection (vector method user host
"/" hop
)))
689 (tramp-get-file-property v
"/" "default-location" "~")
691 ;; Tilde expansion is not possible.
692 (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname
)
695 "Cannot expand tilde in file `%s'" name
))
696 (unless (tramp-run-real-handler 'file-name-absolute-p
(list localname
))
697 (setq localname
(concat "/" localname
)))
698 ;; We do not pass "/..".
699 (if (string-equal "smb" method
)
700 (when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname
)
701 (setq localname
(replace-match "/" t t localname
1)))
702 (when (string-match "^/\\.\\./?" localname
)
703 (setq localname
(replace-match "/" t t localname
))))
704 ;; There might be a double slash. Remove this.
705 (while (string-match "//" localname
)
706 (setq localname
(replace-match "/" t t localname
)))
707 ;; No tilde characters in file name, do normal
708 ;; `expand-file-name' (this does "/./" and "/../").
709 (tramp-make-tramp-file-name
711 (tramp-run-real-handler
712 'expand-file-name
(list localname
))))))
714 (defun tramp-gvfs-handle-file-attributes (filename &optional id-format
)
715 "Like `file-attributes' for Tramp files."
716 (unless id-format
(setq id-format
'integer
))
717 ;; Don't modify `last-coding-system-used' by accident.
718 (let ((last-coding-system-used last-coding-system-used
)
719 dirp res-symlink-target res-numlinks res-uid res-gid res-access
720 res-mod res-change res-size res-filemodes res-inode res-device
)
721 (with-parsed-tramp-file-name filename nil
722 (with-tramp-file-property
723 v localname
(format "file-attributes-%s" id-format
)
724 (tramp-message v
5 "file attributes: %s" localname
)
725 (tramp-gvfs-send-command
726 v
"gvfs-info" (tramp-gvfs-url-file-name filename
))
728 (with-current-buffer (tramp-get-connection-buffer v
)
729 (goto-char (point-min))
730 (when (re-search-forward "attributes:" nil t
)
731 ;; ... directory or symlink
732 (goto-char (point-min))
733 (setq dirp
(if (re-search-forward "type:\\s-+directory" nil t
) t
))
734 (goto-char (point-min))
735 (setq res-symlink-target
736 (if (re-search-forward
737 "standard::symlink-target:\\s-+\\(\\S-+\\)" nil t
)
740 (goto-char (point-min))
742 (if (re-search-forward "unix::nlink:\\s-+\\([0-9]+\\)" nil t
)
743 (string-to-number (match-string 1)) 0))
745 (goto-char (point-min))
747 (or (if (eq id-format
'integer
)
748 (if (re-search-forward
749 "unix::uid:\\s-+\\([0-9]+\\)" nil t
)
750 (string-to-number (match-string 1)))
751 (if (re-search-forward
752 "owner::user:\\s-+\\(\\S-+\\)" nil t
)
754 (tramp-get-local-uid id-format
)))
756 (or (if (eq id-format
'integer
)
757 (if (re-search-forward
758 "unix::gid:\\s-+\\([0-9]+\\)" nil t
)
759 (string-to-number (match-string 1)))
760 (if (re-search-forward
761 "owner::group:\\s-+\\(\\S-+\\)" nil t
)
763 (tramp-get-local-gid id-format
)))
764 ;; ... last access, modification and change time
765 (goto-char (point-min))
767 (if (re-search-forward
768 "time::access:\\s-+\\([0-9]+\\)" nil t
)
769 (seconds-to-time (string-to-number (match-string 1)))
771 (goto-char (point-min))
773 (if (re-search-forward
774 "time::modified:\\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::changed:\\s-+\\([0-9]+\\)" nil t
)
781 (seconds-to-time (string-to-number (match-string 1)))
784 (goto-char (point-min))
786 (if (re-search-forward
787 "standard::size:\\s-+\\([0-9]+\\)" nil t
)
788 (string-to-number (match-string 1)) 0))
789 ;; ... file mode flags
790 (goto-char (point-min))
792 (if (re-search-forward "unix::mode:\\s-+\\([0-9]+\\)" nil t
)
793 (tramp-file-mode-from-int (match-string 1))
794 (if dirp
"drwx------" "-rwx------")))
795 ;; ... inode and device
796 (goto-char (point-min))
798 (if (re-search-forward "unix::inode:\\s-+\\([0-9]+\\)" nil t
)
799 (string-to-number (match-string 1))
800 (tramp-get-inode v
)))
801 (goto-char (point-min))
803 (if (re-search-forward "unix::device:\\s-+\\([0-9]+\\)" nil t
)
804 (string-to-number (match-string 1))
805 (tramp-get-device v
)))
807 ;; Return data gathered.
809 ;; 0. t for directory, string (name linked to) for
810 ;; symbolic link, or nil.
811 (or dirp res-symlink-target
)
812 ;; 1. Number of links to file.
818 ;; 4. Last access time, as a list of integers.
819 ;; 5. Last modification time, likewise.
820 ;; 6. Last status change time, likewise.
821 res-access res-mod res-change
822 ;; 7. Size in bytes (-1, if number is out of range).
826 ;; 9. t if file's gid would change if file were deleted
831 ;; 11. Device number.
835 (defun tramp-gvfs-handle-file-directory-p (filename)
836 "Like `file-directory-p' for Tramp files."
837 (eq t
(car (file-attributes filename
))))
839 (defun tramp-gvfs-handle-file-executable-p (filename)
840 "Like `file-executable-p' for Tramp files."
841 (with-parsed-tramp-file-name filename nil
842 (with-tramp-file-property v localname
"file-executable-p"
843 (tramp-check-cached-permissions v ?x
))))
845 (defun tramp-gvfs-handle-file-local-copy (filename)
846 "Like `file-local-copy' for Tramp files."
847 (with-parsed-tramp-file-name filename nil
848 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
849 (unless (file-exists-p filename
)
852 "Cannot make local copy of non-existing file `%s'" filename
))
853 (copy-file filename tmpfile t t
)
856 (defun tramp-gvfs-handle-file-name-all-completions (filename directory
)
857 "Like `file-name-all-completions' for Tramp files."
858 (unless (save-match-data (string-match "/" filename
))
859 (with-parsed-tramp-file-name (expand-file-name directory
) nil
866 ;; Try cache entries for filename, filename with last
867 ;; character removed, filename with last two characters
868 ;; removed, ..., and finally the empty string - all
869 ;; concatenated to the local directory name.
870 (let ((remote-file-name-inhibit-cache
871 (or remote-file-name-inhibit-cache
872 tramp-completion-reread-directory-timeout
)))
874 ;; This is inefficient for very long filenames, pity
875 ;; `reduce' is not available...
882 (tramp-get-file-property
884 (concat localname
(substring filename
0 x
))
885 "file-name-all-completions"
887 (when cache-hit
(list cache-hit
))))
888 ;; We cannot use a length of 0, because file properties
889 ;; for "foo" and "foo/" are identical.
890 (tramp-compat-number-sequence (length filename
) 1 -
1)))))
892 ;; Cache expired or no matching cache entry found so we need
893 ;; to perform a remote operation.
894 (let ((result '("." ".."))
896 ;; Get a list of directories and files.
897 (tramp-gvfs-send-command
898 v
"gvfs-ls" (tramp-gvfs-url-file-name directory
))
900 ;; Now grab the output.
902 (insert-buffer-substring (tramp-get-connection-buffer v
))
903 (goto-char (point-max))
904 (while (zerop (forward-line -
1))
905 (setq entry
(buffer-substring (point) (point-at-eol)))
906 (when (string-match filename entry
)
907 (if (file-directory-p (expand-file-name entry directory
))
908 (push (concat entry
"/") result
)
909 (push entry result
)))))
911 ;; Because the remote op went through OK we know the
912 ;; directory we `cd'-ed to exists.
913 (tramp-set-file-property v localname
"file-exists-p" t
)
915 ;; Because the remote op went through OK we know every
916 ;; file listed by `ls' exists.
917 (mapc (lambda (entry)
918 (tramp-set-file-property
919 v
(concat localname entry
) "file-exists-p" t
))
922 ;; Store result in the cache.
923 (tramp-set-file-property
924 v
(concat localname filename
)
925 "file-name-all-completions" result
))))))))
927 (defun tramp-gvfs-handle-file-notify-add-watch (file-name _flags _callback
)
928 "Like `file-notify-add-watch' for Tramp files."
929 (setq file-name
(expand-file-name file-name
))
930 (with-parsed-tramp-file-name file-name nil
931 (let ((p (start-process
932 "gvfs-monitor-file" (generate-new-buffer " *gvfs-monitor-file*")
933 "gvfs-monitor-file" (tramp-gvfs-url-file-name file-name
))))
934 (if (not (processp p
))
936 v
'file-notify-error
"gvfs-monitor-file failed to start")
937 (tramp-compat-set-process-query-on-exit-flag p nil
)
938 (set-process-filter p
'tramp-gvfs-file-gvfs-monitor-file-process-filter
)
939 (with-current-buffer (process-buffer p
)
940 (setq default-directory
(file-name-directory file-name
)))
943 (defun tramp-gvfs-file-gvfs-monitor-file-process-filter (proc string
)
944 "Read output from \"gvfs-monitor-file\" and add corresponding file-notify events."
945 (let* ((rest-string (tramp-compat-process-get proc
'rest-string
))
946 (dd (with-current-buffer (process-buffer proc
) default-directory
))
947 (ddu (regexp-quote (tramp-gvfs-url-file-name dd
))))
949 (tramp-message proc
10 "Previous string:\n%s" rest-string
))
950 (tramp-message proc
6 "%S\n%s" proc string
)
951 (setq string
(concat rest-string string
)
952 ;; Attribute change is returned in unused wording.
953 string
(replace-regexp-in-string
954 "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string
))
958 "File Monitor Event:[\n\r]+"
959 "File = \\([^\n\r]+\\)[\n\r]+"
960 "Event = \\([^[:blank:]]+\\)[\n\r]+")
962 (let ((action (intern-soft
963 (replace-regexp-in-string
964 "_" "-" (downcase (match-string 2 string
)))))
965 (file (match-string 1 string
)))
966 (setq string
(replace-match "" nil nil string
))
967 ;; File names are returned as URL paths. We must convert them.
968 (when (string-match ddu file
)
969 (setq file
(replace-match dd nil nil file
)))
970 (while (string-match "%\\([0-9A-F]\\{2\\}\\)" file
)
973 (char-to-string (string-to-number (match-string 1 file
) 16))
975 ;; Usually, we would add an Emacs event now. Unfortunately,
976 ;; `unread-command-events' does not accept several events at
977 ;; once. Therefore, we apply the callback directly.
978 (tramp-compat-funcall 'file-notify-callback
(list proc action file
))))
980 ;; Save rest of the string.
981 (when (zerop (length string
)) (setq string nil
))
982 (when string
(tramp-message proc
10 "Rest string:\n%s" string
))
983 (tramp-compat-process-put proc
'rest-string string
)))
985 (defun tramp-gvfs-handle-file-readable-p (filename)
986 "Like `file-readable-p' for Tramp files."
987 (with-parsed-tramp-file-name filename nil
988 (with-tramp-file-property v localname
"file-executable-p"
989 (tramp-check-cached-permissions v ?r
))))
991 (defun tramp-gvfs-handle-file-writable-p (filename)
992 "Like `file-writable-p' for Tramp files."
993 (with-parsed-tramp-file-name filename nil
994 (with-tramp-file-property v localname
"file-writable-p"
995 (if (file-exists-p filename
)
996 (tramp-check-cached-permissions v ?w
)
997 ;; If file doesn't exist, check if directory is writable.
998 (and (file-directory-p (file-name-directory filename
))
999 (file-writable-p (file-name-directory filename
)))))))
1001 (defun tramp-gvfs-handle-insert-directory
1002 (filename switches
&optional wildcard full-directory-p
)
1003 "Like `insert-directory' for Tramp files."
1004 ;; gvfs-* output is hard to parse. So we let `ls-lisp' do the job.
1005 (with-parsed-tramp-file-name (expand-file-name filename
) nil
1006 (with-tramp-progress-reporter v
0 (format "Opening directory %s" filename
)
1008 (let (ls-lisp-use-insert-directory-program)
1009 (tramp-run-real-handler
1011 (list filename switches wildcard full-directory-p
))))))
1013 (defun tramp-gvfs-handle-insert-file-contents
1014 (filename &optional visit beg end replace
)
1015 "Like `insert-file-contents' for Tramp files."
1016 (barf-if-buffer-read-only)
1017 (setq filename
(expand-file-name filename
))
1018 (let (tmpfile result
)
1020 (if (not (file-exists-p filename
))
1021 ;; We don't raise a Tramp error, because it might be
1022 ;; suppressed, like in `find-file-noselect-1'.
1023 (signal 'file-error
(list "File not found on remote host" filename
))
1025 (setq tmpfile
(file-local-copy filename
)
1026 result
(insert-file-contents tmpfile visit beg end replace
)))
1029 (setq buffer-file-name filename
)
1030 (setq buffer-read-only
(not (file-writable-p filename
)))
1031 (set-visited-file-modtime)
1032 (set-buffer-modified-p nil
))
1033 (when (stringp tmpfile
)
1034 (delete-file tmpfile
)))
1037 (list filename
(cadr result
))))
1039 (defun tramp-gvfs-handle-make-directory (dir &optional parents
)
1040 "Like `make-directory' for Tramp files."
1041 (with-parsed-tramp-file-name dir nil
1044 'tramp-gvfs-send-command v
"gvfs-mkdir"
1046 (list "-p" (tramp-gvfs-url-file-name dir
))
1047 (list (tramp-gvfs-url-file-name dir
))))
1048 ;; Propagate the error.
1049 (tramp-error v
'file-error
"Couldn't make directory %s" dir
))))
1051 (defun tramp-gvfs-handle-rename-file
1052 (filename newname
&optional ok-if-already-exists
)
1053 "Like `rename-file' for Tramp files."
1054 (with-parsed-tramp-file-name
1055 (if (tramp-tramp-file-p filename
) filename newname
) nil
1057 (when (and (not ok-if-already-exists
) (file-exists-p newname
))
1059 v
'file-already-exists
"File %s already exists" newname
))
1061 (if (or (and (tramp-tramp-file-p filename
)
1062 (not (tramp-gvfs-file-name-p filename
)))
1063 (and (tramp-tramp-file-p newname
)
1064 (not (tramp-gvfs-file-name-p newname
))))
1066 ;; We cannot move directly.
1067 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
1068 (rename-file filename tmpfile t
)
1069 (rename-file tmpfile newname ok-if-already-exists
))
1072 (with-tramp-progress-reporter
1073 v
0 (format "Renaming %s to %s" filename newname
)
1075 (tramp-gvfs-send-command
1077 (tramp-gvfs-url-file-name filename
)
1078 (tramp-gvfs-url-file-name newname
))
1079 ;; Propagate the error.
1080 (with-current-buffer (tramp-get-buffer v
)
1081 (goto-char (point-min))
1082 (tramp-error-with-buffer
1084 "Renaming failed, see buffer `%s' for details." (buffer-name)))))
1086 (when (file-remote-p filename
)
1087 (with-parsed-tramp-file-name filename nil
1088 (tramp-flush-file-property v
(file-name-directory localname
))
1089 (tramp-flush-file-property v localname
)))
1091 (when (file-remote-p newname
)
1092 (with-parsed-tramp-file-name newname nil
1093 (tramp-flush-file-property v
(file-name-directory localname
))
1094 (tramp-flush-file-property v localname
))))))
1096 (defun tramp-gvfs-handle-write-region
1097 (start end filename
&optional _append visit _lockname confirm
)
1098 "Like `write-region' for Tramp files."
1099 (with-parsed-tramp-file-name filename nil
1100 ;; XEmacs takes a coding system as the seventh argument, not `confirm'.
1101 (when (and (not (featurep 'xemacs
)) confirm
(file-exists-p filename
))
1102 (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename
))
1103 (tramp-error v
'file-error
"File not overwritten")))
1105 (let ((tmpfile (tramp-compat-make-temp-file filename
)))
1106 (write-region start end tmpfile
)
1108 (rename-file tmpfile filename
'ok-if-already-exists
)
1110 (delete-file tmpfile
)
1112 v
'file-error
"Couldn't write region to `%s'" filename
))))
1114 (tramp-flush-file-property v
(file-name-directory localname
))
1115 (tramp-flush-file-property v localname
)
1117 ;; Set file modification time.
1118 (when (or (eq visit t
) (stringp visit
))
1119 (set-visited-file-modtime (nth 5 (file-attributes filename
))))
1122 (when (or (eq visit t
) (null visit
) (stringp visit
))
1123 (tramp-message v
0 "Wrote %s" filename
))
1124 (run-hooks 'tramp-handle-write-region-hook
)))
1127 ;; File name conversions.
1129 (defun tramp-gvfs-url-file-name (filename)
1130 "Return FILENAME in URL syntax."
1131 ;; "/" must NOT be hexlified.
1132 (let ((url-unreserved-chars (append '(?
/) url-unreserved-chars
))
1137 (if (tramp-tramp-file-p filename
)
1138 (with-parsed-tramp-file-name filename nil
1139 (when (and user
(string-match tramp-user-with-domain-regexp user
))
1141 (concat (match-string 2 user
) ";" (match-string 1 user
))))
1142 (url-parse-make-urlobj
1143 method
(url-hexify-string user
) nil
1144 (tramp-file-name-real-host v
) (tramp-file-name-port v
)
1145 (url-hexify-string localname
) nil nil t
))
1146 (url-parse-make-urlobj
1147 "file" nil nil nil nil
1148 (url-hexify-string (file-truename filename
)) nil nil t
))))
1149 (when (tramp-tramp-file-p filename
)
1150 (with-parsed-tramp-file-name filename nil
1151 (tramp-message v
10 "remote file `%s' is URL `%s'" filename result
)))
1154 (defun tramp-gvfs-object-path (filename)
1155 "Create a D-Bus object path from FILENAME."
1156 (expand-file-name (dbus-escape-as-identifier filename
) tramp-gvfs-path-tramp
))
1158 (defun tramp-gvfs-file-name (object-path)
1159 "Retrieve file name from D-Bus OBJECT-PATH."
1160 (dbus-unescape-from-identifier
1161 (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path
)))
1163 (defun tramp-bluez-address (device)
1164 "Return bluetooth device address from a given bluetooth DEVICE name."
1165 (when (stringp device
)
1166 (if (string-match tramp-ipv6-regexp device
)
1167 (match-string 0 device
)
1168 (cadr (assoc device
(tramp-bluez-list-devices))))))
1170 (defun tramp-bluez-device (address)
1171 "Return bluetooth device name from a given bluetooth device ADDRESS.
1172 ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1173 (when (stringp address
)
1174 (while (string-match "[][]" address
)
1175 (setq address
(replace-match "" t t address
)))
1177 (dolist (item (tramp-bluez-list-devices) result
)
1178 (when (string-match address
(cadr item
))
1179 (setq result
(car item
)))))))
1182 ;; D-Bus GVFS functions.
1184 (defun tramp-gvfs-handler-askpassword (message user domain flags
)
1185 "Implementation for the \"org.gtk.vfs.MountOperation.askPassword\" method."
1187 (tramp-gvfs-file-name (dbus-event-path-name last-input-event
)))
1191 (if (string-match "\\([pP]assword\\|[pP]assphrase\\)" message
)
1192 (capitalize (match-string 1 message
))
1198 (with-parsed-tramp-file-name filename l
1199 (when (and (zerop (length user
))
1201 (zerop (logand flags tramp-gvfs-password-need-username
))))
1202 (setq user
(read-string "User name: ")))
1203 (when (and (zerop (length domain
))
1204 (not (zerop (logand flags tramp-gvfs-password-need-domain
))))
1205 (setq domain
(read-string "Domain name: ")))
1207 (tramp-message l
6 "%S %S %S %d" message user domain flags
)
1208 (setq tramp-current-method l-method
1209 tramp-current-user user
1210 tramp-current-host l-host
1211 password
(tramp-read-passwd
1212 (tramp-get-connection-process l
) pw-prompt
))
1215 (if (stringp password
)
1217 t
;; password handled.
1218 nil
;; no abort of D-Bus.
1220 (tramp-file-name-real-user l
)
1222 nil
;; not anonymous.
1223 0) ;; no password save.
1224 ;; No password provided.
1225 (list nil t
"" (tramp-file-name-real-user l
) domain nil
0)))
1227 ;; When QUIT is raised, we shall return this information to D-Bus.
1228 (quit (list nil t
"" "" "" nil
0)))))
1230 (defun tramp-gvfs-handler-askquestion (message choices
)
1231 "Implementation for the \"org.gtk.vfs.MountOperation.askQuestion\" method."
1232 (save-window-excursion
1233 (let ((enable-recursive-minibuffers t
)
1237 (with-parsed-tramp-file-name
1238 (tramp-gvfs-file-name (dbus-event-path-name last-input-event
)) nil
1239 (tramp-message v
6 "%S %S" message choices
)
1241 ;; In theory, there can be several choices. Until now,
1242 ;; there is only the question whether to accept an unknown
1245 ;; Preserve message for `progress-reporter'.
1246 (tramp-compat-with-temp-message ""
1248 (pop-to-buffer (current-buffer))
1249 (setq choice
(if (yes-or-no-p (concat (car choices
) " ")) 0 1))
1250 (tramp-message v
6 "%d" choice
)))
1252 ;; When the choice is "no", we set a dummy fuse-mountpoint
1253 ;; in order to leave the timeout.
1254 (unless (zerop choice
)
1255 (tramp-set-file-property v
"/" "fuse-mountpoint" "/"))
1259 nil
;; no abort of D-Bus.
1262 ;; When QUIT is raised, we shall return this information to D-Bus.
1263 (quit (list nil t
0))))))
1265 (defun tramp-gvfs-handler-mounted-unmounted (mount-info)
1266 "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and
1267 \"org.gtk.vfs.MountTracker.unmounted\" signals."
1269 (let ((signal-name (dbus-event-member-name last-input-event
))
1271 ;; Jump over the first elements of the mount info. Since there
1272 ;; were changes in the entries, we cannot access dedicated
1274 (while (stringp (car elt
)) (setq elt
(cdr elt
)))
1275 (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt
)))
1276 (mount-spec (caddr elt
))
1277 (default-location (tramp-gvfs-dbus-byte-array-to-string
1279 (method (tramp-gvfs-dbus-byte-array-to-string
1280 (cadr (assoc "type" (cadr mount-spec
)))))
1281 (user (tramp-gvfs-dbus-byte-array-to-string
1282 (cadr (assoc "user" (cadr mount-spec
)))))
1283 (domain (tramp-gvfs-dbus-byte-array-to-string
1284 (cadr (assoc "domain" (cadr mount-spec
)))))
1285 (host (tramp-gvfs-dbus-byte-array-to-string
1286 (cadr (or (assoc "host" (cadr mount-spec
))
1287 (assoc "server" (cadr mount-spec
))))))
1288 (port (tramp-gvfs-dbus-byte-array-to-string
1289 (cadr (assoc "port" (cadr mount-spec
)))))
1290 (ssl (tramp-gvfs-dbus-byte-array-to-string
1291 (cadr (assoc "ssl" (cadr mount-spec
)))))
1292 (prefix (concat (tramp-gvfs-dbus-byte-array-to-string
1294 (tramp-gvfs-dbus-byte-array-to-string
1295 (cadr (assoc "share" (cadr mount-spec
)))))))
1296 (when (string-match "^smb" method
)
1297 (setq method
"smb"))
1298 (when (string-equal "obex" method
)
1299 (setq host
(tramp-bluez-device host
)))
1300 (when (and (string-equal "dav" method
) (string-equal "true" ssl
))
1301 (setq method
"davs"))
1302 (unless (zerop (length domain
))
1303 (setq user
(concat user tramp-prefix-domain-format domain
)))
1304 (unless (zerop (length port
))
1305 (setq host
(concat host tramp-prefix-port-format port
)))
1306 (with-parsed-tramp-file-name
1307 (tramp-make-tramp-file-name method user host
"") nil
1310 signal-name
(tramp-gvfs-stringify-dbus-message mount-info
))
1311 (tramp-set-file-property v
"/" "list-mounts" 'undef
)
1312 (if (string-equal (downcase signal-name
) "unmounted")
1313 (tramp-set-file-property v
"/" "fuse-mountpoint" nil
)
1314 ;; Set prefix, mountpoint and location.
1315 (unless (string-equal prefix
"/")
1316 (tramp-set-file-property v
"/" "prefix" prefix
))
1317 (tramp-set-file-property v
"/" "fuse-mountpoint" fuse-mountpoint
)
1318 (tramp-set-file-property
1319 v
"/" "default-location" default-location
)))))))
1321 (when tramp-gvfs-enabled
1322 (dbus-register-signal
1323 :session nil tramp-gvfs-path-mounttracker
1324 tramp-gvfs-interface-mounttracker
"mounted"
1325 'tramp-gvfs-handler-mounted-unmounted
)
1326 (dbus-register-signal
1327 :session nil tramp-gvfs-path-mounttracker
1328 tramp-gvfs-interface-mounttracker
"Mounted"
1329 'tramp-gvfs-handler-mounted-unmounted
)
1331 (dbus-register-signal
1332 :session nil tramp-gvfs-path-mounttracker
1333 tramp-gvfs-interface-mounttracker
"unmounted"
1334 'tramp-gvfs-handler-mounted-unmounted
)
1335 (dbus-register-signal
1336 :session nil tramp-gvfs-path-mounttracker
1337 tramp-gvfs-interface-mounttracker
"Unmounted"
1338 'tramp-gvfs-handler-mounted-unmounted
))
1340 (defun tramp-gvfs-connection-mounted-p (vec)
1341 "Check, whether the location is already mounted."
1343 (tramp-get-file-property vec
"/" "fuse-mountpoint" nil
)
1347 (with-tramp-file-property vec
"/" "list-mounts"
1348 (with-tramp-dbus-call-method vec t
1349 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1350 tramp-gvfs-interface-mounttracker tramp-gvfs-listmounts
))
1352 ;; Jump over the first elements of the mount info. Since there
1353 ;; were changes in the entries, we cannot access dedicated
1355 (while (stringp (car elt
)) (setq elt
(cdr elt
)))
1356 (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string
1358 (mount-spec (caddr elt
))
1359 (default-location (tramp-gvfs-dbus-byte-array-to-string
1361 (method (tramp-gvfs-dbus-byte-array-to-string
1362 (cadr (assoc "type" (cadr mount-spec
)))))
1363 (user (tramp-gvfs-dbus-byte-array-to-string
1364 (cadr (assoc "user" (cadr mount-spec
)))))
1365 (domain (tramp-gvfs-dbus-byte-array-to-string
1366 (cadr (assoc "domain" (cadr mount-spec
)))))
1367 (host (tramp-gvfs-dbus-byte-array-to-string
1368 (cadr (or (assoc "host" (cadr mount-spec
))
1369 (assoc "server" (cadr mount-spec
))))))
1370 (port (tramp-gvfs-dbus-byte-array-to-string
1371 (cadr (assoc "port" (cadr mount-spec
)))))
1372 (ssl (tramp-gvfs-dbus-byte-array-to-string
1373 (cadr (assoc "ssl" (cadr mount-spec
)))))
1374 (prefix (concat (tramp-gvfs-dbus-byte-array-to-string
1376 (tramp-gvfs-dbus-byte-array-to-string
1377 (cadr (assoc "share" (cadr mount-spec
)))))))
1378 (when (string-match "^smb" method
)
1379 (setq method
"smb"))
1380 (when (string-equal "obex" method
)
1381 (setq host
(tramp-bluez-device host
)))
1382 (when (and (string-equal "dav" method
) (string-equal "true" ssl
))
1383 (setq method
"davs"))
1384 (when (and (string-equal "synce" method
) (zerop (length user
)))
1385 (setq user
(or (tramp-file-name-user vec
) "")))
1386 (unless (zerop (length domain
))
1387 (setq user
(concat user tramp-prefix-domain-format domain
)))
1388 (unless (zerop (length port
))
1389 (setq host
(concat host tramp-prefix-port-format port
)))
1391 (string-equal method
(tramp-file-name-method vec
))
1392 (string-equal user
(or (tramp-file-name-user vec
) ""))
1393 (string-equal host
(tramp-file-name-host vec
))
1394 (string-match (concat "^" (regexp-quote prefix
))
1395 (tramp-file-name-localname vec
)))
1396 ;; Set prefix, mountpoint and location.
1397 (unless (string-equal prefix
"/")
1398 (tramp-set-file-property vec
"/" "prefix" prefix
))
1399 (tramp-set-file-property vec
"/" "fuse-mountpoint" fuse-mountpoint
)
1400 (tramp-set-file-property vec
"/" "default-location" default-location
)
1401 (throw 'mounted t
)))))))
1403 (defun tramp-gvfs-mount-spec-entry (key value
)
1404 "Construct a mount-spec entry to be used in a mount_spec.
1405 It was \"a(say)\", but has changed to \"a{sv})\"."
1406 (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature
)
1407 (list :dict-entry key
1408 (list :variant
(tramp-gvfs-dbus-string-to-byte-array value
)))
1409 (list :struct key
(tramp-gvfs-dbus-string-to-byte-array value
))))
1411 (defun tramp-gvfs-mount-spec (vec)
1412 "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"."
1413 (let* ((method (tramp-file-name-method vec
))
1414 (user (tramp-file-name-real-user vec
))
1415 (domain (tramp-file-name-domain vec
))
1416 (host (tramp-file-name-real-host vec
))
1417 (port (tramp-file-name-port vec
))
1418 (localname (tramp-file-name-localname vec
))
1419 (ssl (if (string-match "^davs" method
) "true" "false"))
1420 (mount-spec '(:array
))
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 "share" (match-string 1 localname
))))
1433 ((string-equal "obex" method
)
1434 (list (tramp-gvfs-mount-spec-entry "type" method
)
1435 (tramp-gvfs-mount-spec-entry
1436 "host" (concat "[" (tramp-bluez-address host
) "]"))))
1437 ((string-match "^dav" method
)
1438 (list (tramp-gvfs-mount-spec-entry "type" "dav")
1439 (tramp-gvfs-mount-spec-entry "host" host
)
1440 (tramp-gvfs-mount-spec-entry "ssl" ssl
)))
1442 (list (tramp-gvfs-mount-spec-entry "type" method
)
1443 (tramp-gvfs-mount-spec-entry "host" host
))))))
1447 'mount-spec
(tramp-gvfs-mount-spec-entry "user" user
) 'append
))
1451 'mount-spec
(tramp-gvfs-mount-spec-entry "domain" domain
) 'append
))
1455 'mount-spec
(tramp-gvfs-mount-spec-entry "port" (number-to-string port
))
1458 (when (and (string-match "^dav" method
)
1459 (string-match "^/?[^/]+" localname
))
1460 (setq mount-pref
(match-string 0 localname
)))
1463 `(:struct
,(tramp-gvfs-dbus-string-to-byte-array mount-pref
) ,mount-spec
)))
1466 ;; Connection functions.
1468 (defun tramp-gvfs-maybe-open-connection (vec)
1469 "Maybe open a connection VEC.
1470 Does not do anything if a connection is already open, but re-opens the
1471 connection if a previous connection has died for some reason."
1473 ;; We set the file name, in case there are incoming D-Bus signals or
1475 (setq tramp-gvfs-dbus-event-vector vec
)
1477 ;; For password handling, we need a process bound to the connection
1478 ;; buffer. Therefore, we create a dummy process. Maybe there is a
1480 (unless (get-buffer-process (tramp-get-connection-buffer vec
))
1481 (let ((p (make-network-process
1482 :name
(tramp-buffer-name vec
)
1483 :buffer
(tramp-get-connection-buffer vec
)
1484 :server t
:host
'local
:service t
)))
1485 (tramp-compat-set-process-query-on-exit-flag p nil
)))
1487 (unless (tramp-gvfs-connection-mounted-p vec
)
1488 (let* ((method (tramp-file-name-method vec
))
1489 (user (tramp-file-name-user vec
))
1490 (host (tramp-file-name-host vec
))
1491 (localname (tramp-file-name-localname vec
))
1493 (tramp-gvfs-object-path
1494 (tramp-make-tramp-file-name method user host
""))))
1496 (when (and (string-equal method
"smb")
1497 (string-equal localname
"/"))
1498 (tramp-error vec
'file-error
"Filename must contain a Windows share"))
1500 (with-tramp-progress-reporter
1502 (if (zerop (length user
))
1503 (format "Opening connection for %s using %s" host method
)
1504 (format "Opening connection for %s@%s using %s" user host method
))
1506 ;; Enable auth-source and password-cache.
1507 (tramp-set-connection-property vec
"first-password-request" t
)
1509 ;; There will be a callback of "askPassword" when a password is
1511 (dbus-register-method
1512 :session dbus-service-emacs object-path
1513 tramp-gvfs-interface-mountoperation
"askPassword"
1514 'tramp-gvfs-handler-askpassword
)
1515 (dbus-register-method
1516 :session dbus-service-emacs object-path
1517 tramp-gvfs-interface-mountoperation
"AskPassword"
1518 'tramp-gvfs-handler-askpassword
)
1520 ;; There could be a callback of "askQuestion" when adding fingerprint.
1521 (dbus-register-method
1522 :session dbus-service-emacs object-path
1523 tramp-gvfs-interface-mountoperation
"askQuestion"
1524 'tramp-gvfs-handler-askquestion
)
1525 (dbus-register-method
1526 :session dbus-service-emacs object-path
1527 tramp-gvfs-interface-mountoperation
"AskQuestion"
1528 'tramp-gvfs-handler-askquestion
)
1530 ;; The call must be asynchronously, because of the "askPassword"
1531 ;; or "askQuestion"callbacks.
1532 (if (string-match "(so)$" tramp-gvfs-mountlocation-signature
)
1533 (with-tramp-dbus-call-method vec nil
1534 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1535 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1536 (tramp-gvfs-mount-spec vec
)
1537 `(:struct
:string
,(dbus-get-unique-name :session
)
1538 :object-path
,object-path
))
1539 (with-tramp-dbus-call-method vec nil
1540 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1541 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1542 (tramp-gvfs-mount-spec vec
)
1543 :string
(dbus-get-unique-name :session
) :object-path object-path
))
1545 ;; We must wait, until the mount is applied. This will be
1546 ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint"
1549 ((or (tramp-get-method-parameter method
'tramp-connection-timeout
)
1550 tramp-connection-timeout
)
1551 (if (zerop (length (tramp-file-name-user vec
)))
1554 "Timeout reached mounting %s using %s" host method
)
1557 "Timeout reached mounting %s@%s using %s" user host method
)))
1558 (while (not (tramp-get-file-property vec
"/" "fuse-mountpoint" nil
))
1559 (read-event nil nil
0.1)))
1561 ;; If `tramp-gvfs-handler-askquestion' has returned "No", it
1562 ;; is marked with the fuse-mountpoint "/". We shall react.
1564 (tramp-get-file-property vec
"/" "fuse-mountpoint" "") "/")
1565 (tramp-error vec
'file-error
"FUSE mount denied"))
1567 ;; In `tramp-check-cached-permissions', the connection
1568 ;; properties {uig,gid}-{integer,string} are used. We set
1569 ;; them to their local counterparts.
1570 (tramp-set-connection-property
1571 vec
"uid-integer" (tramp-get-local-uid 'integer
))
1572 (tramp-set-connection-property
1573 vec
"gid-integer" (tramp-get-local-gid 'integer
))
1574 (tramp-set-connection-property
1575 vec
"uid-string" (tramp-get-local-uid 'string
))
1576 (tramp-set-connection-property
1577 vec
"gid-string" (tramp-get-local-gid 'string
))))))
1579 (defun tramp-gvfs-send-command (vec command
&rest args
)
1580 "Send the COMMAND with its ARGS to connection VEC.
1581 COMMAND is usually a command from the gvfs-* utilities.
1582 `call-process' is applied, and it returns `t' if the return code is zero."
1584 (with-current-buffer (tramp-get-connection-buffer vec
)
1585 (tramp-gvfs-maybe-open-connection vec
)
1587 (tramp-message vec
6 "%s %s" command
(mapconcat 'identity args
" "))
1588 (setq result
(apply 'tramp-call-process command nil t nil args
))
1589 (tramp-message vec
6 "\n%s" (buffer-string))
1593 ;; D-Bus BLUEZ functions.
1595 (defun tramp-bluez-list-devices ()
1596 "Return all discovered bluetooth devices as list.
1597 Every entry is a list (NAME ADDRESS).
1599 If `tramp-bluez-discover-devices-timeout' is an integer, and the last
1600 discovery happened more time before indicated there, a rescan will be
1601 started, which lasts some ten seconds. Otherwise, cached results will
1603 ;; Reset the scanned devices list if time has passed.
1604 (and (integerp tramp-bluez-discover-devices-timeout
)
1605 (integerp tramp-bluez-discovery
)
1606 (> (tramp-time-diff (current-time) tramp-bluez-discovery
)
1607 tramp-bluez-discover-devices-timeout
)
1608 (setq tramp-bluez-devices nil
))
1610 ;; Rescan if needed.
1611 (unless tramp-bluez-devices
1613 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1614 :system tramp-bluez-service
"/"
1615 tramp-bluez-interface-manager
"DefaultAdapter")))
1616 (setq tramp-bluez-devices nil
1617 tramp-bluez-discovery t
)
1618 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil
1619 :system tramp-bluez-service object-path
1620 tramp-bluez-interface-adapter
"StartDiscovery")
1621 (while tramp-bluez-discovery
1622 (read-event nil nil
0.1))))
1623 (setq tramp-bluez-discovery
(current-time))
1624 (tramp-message tramp-gvfs-dbus-event-vector
10 "%s" tramp-bluez-devices
)
1625 tramp-bluez-devices
)
1627 (defun tramp-bluez-property-changed (property value
)
1628 "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal."
1629 (tramp-message tramp-gvfs-dbus-event-vector
6 "%s %s" property value
)
1631 ((string-equal property
"Discovering")
1633 ;; "Discovering" FALSE means discovery run has been completed.
1634 ;; We stop it, because we don't need another run.
1635 (setq tramp-bluez-discovery nil
)
1636 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1637 :system tramp-bluez-service
(dbus-event-path-name last-input-event
)
1638 tramp-bluez-interface-adapter
"StopDiscovery")))))
1640 (dbus-register-signal
1641 :system nil nil tramp-bluez-interface-adapter
"PropertyChanged"
1642 'tramp-bluez-property-changed
)
1644 (defun tramp-bluez-device-found (device args
)
1645 "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal."
1646 (tramp-message tramp-gvfs-dbus-event-vector
6 "%s %s" device args
)
1647 (let ((alias (car (cadr (assoc "Alias" args
))))
1648 (address (car (cadr (assoc "Address" args
)))))
1649 ;; Maybe we shall check the device class for being a proper
1650 ;; device, and call also SDP in order to find the obex service.
1651 (add-to-list 'tramp-bluez-devices
(list alias address
))))
1653 (dbus-register-signal
1654 :system nil nil tramp-bluez-interface-adapter
"DeviceFound"
1655 'tramp-bluez-device-found
)
1657 (defun tramp-bluez-parse-device-names (_ignore)
1658 "Return a list of (nil host) tuples allowed to access."
1660 (lambda (x) (list nil
(car x
)))
1661 (tramp-bluez-list-devices)))
1663 ;; Add completion function for OBEX method.
1664 (when (member tramp-bluez-service
(dbus-list-known-names :system
))
1665 (tramp-set-completion-function
1666 "obex" '((tramp-bluez-parse-device-names ""))))
1669 ;; D-Bus zeroconf functions.
1671 (defun tramp-zeroconf-parse-workstation-device-names (_ignore)
1672 "Return a list of (user host) tuples allowed to access."
1675 (list nil
(zeroconf-service-host x
)))
1676 (zeroconf-list-services "_workstation._tcp")))
1678 (defun tramp-zeroconf-parse-webdav-device-names (_ignore)
1679 "Return a list of (user host) tuples allowed to access."
1682 (let ((host (zeroconf-service-host x
))
1683 (port (zeroconf-service-port x
))
1684 (text (zeroconf-service-txt x
))
1687 (setq host
(format "%s%s%d" host tramp-prefix-port-regexp port
)))
1688 ;; A user is marked in a TXT field like "u=guest".
1690 (when (string-match "u=\\(.+\\)$" (car text
))
1691 (setq user
(match-string 1 (car text
))))
1692 (setq text
(cdr text
)))
1694 (zeroconf-list-services "_webdav._tcp")))
1696 ;; Add completion function for DAV and DAVS methods.
1697 (when (member zeroconf-service-avahi
(dbus-list-known-names :system
))
1698 (zeroconf-init tramp-gvfs-zeroconf-domain
)
1699 (tramp-set-completion-function
1700 "sftp" '((tramp-zeroconf-parse-workstation-device-names "")))
1701 (tramp-set-completion-function
1702 "dav" '((tramp-zeroconf-parse-webdav-device-names "")))
1703 (tramp-set-completion-function
1704 "davs" '((tramp-zeroconf-parse-webdav-device-names ""))))
1707 ;; D-Bus SYNCE functions.
1709 (defun tramp-synce-list-devices ()
1710 "Return all discovered synce devices as list.
1711 They are retrieved from the hal daemon."
1712 (let (tramp-synce-devices)
1714 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1715 :system tramp-hal-service tramp-hal-path-manager
1716 tramp-hal-interface-manager
"GetAllDevices"))
1717 (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1718 :system tramp-hal-service device tramp-hal-interface-device
1719 "PropertyExists" "sync.plugin")
1721 'tramp-synce-devices
1722 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
1723 :system tramp-hal-service device tramp-hal-interface-device
1724 "GetPropertyString" "pda.pocketpc.name"))))
1725 (tramp-message tramp-gvfs-dbus-event-vector
10 "%s" tramp-synce-devices
)
1726 tramp-synce-devices
))
1728 (defun tramp-synce-parse-device-names (_ignore)
1729 "Return a list of (nil host) tuples allowed to access."
1731 (lambda (x) (list nil x
))
1732 (tramp-synce-list-devices)))
1734 ;; Add completion function for SYNCE method.
1735 (tramp-set-completion-function
1736 "synce" '((tramp-synce-parse-device-names "")))
1738 (add-hook 'tramp-unload-hook
1740 (unload-feature 'tramp-gvfs
'force
)))
1742 (provide 'tramp-gvfs
)
1746 ;; * Host name completion via smb-server or smb-network.
1747 ;; * Check how two shares of the same SMB server can be mounted in
1749 ;; * Apply SDP on bluetooth devices, in order to filter out obex
1751 ;; * Implement obex for other serial communication but bluetooth.
1753 ;;; tramp-gvfs.el ends here