aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMichael Albinus2013-03-09 12:06:23 +0100
committerMichael Albinus2013-03-09 12:06:23 +0100
commit3675b1698d0a3a5a8ee09354f2d15e233de8cece (patch)
tree959ead3abf3e2f3ce6fc18f676bb4bf60696cebb
parent27a98a62d1c46b057428cc3ed964743b69628299 (diff)
downloademacs-3675b1698d0a3a5a8ee09354f2d15e233de8cece.tar.gz
emacs-3675b1698d0a3a5a8ee09354f2d15e233de8cece.zip
Major rewrite due to changed D-Bus interface of GVFS 1.14.
* net/tramp-gvfs.el (top): Extend check for gvfs availability. (tramp-gvfs-methods-mounttracker, tramp-gvfs-listmounts) (tramp-gvfs-mountlocation, tramp-gvfs-mountlocation-signature): New defconst. (tramp-gvfs-file-name-handler-alist) [directory-files]: [directory-files-and-attributes, file-exists-p, file-modes]: Use Tramp default handler. [file-acl, file-selinux-context, process-file, set-file-acl]: [set-file-modes, set-file-selinux-context, shell-command]: [start-file-process ]: Remove handler. [verify-visited-file-modtime]: New handler. (tramp-gvfs-dbus-string-to-byte-array) (tramp-gvfs-dbus-byte-array-to-string): New defuns. Replace all calls of `dbus-string-to-byte-array' and `tramp-gvfs-dbus-byte-array-to-string'. (tramp-gvfs-handle-copy-file) (tramp-gvfs-handle-delete-directory) (tramp-gvfs-handle-delete-file, tramp-gvfs-handle-file-attributes) (tramp-gvfs-handle-file-directory-p) (tramp-gvfs-handle-file-executable-p) (tramp-gvfs-handle-file-name-all-completions) (tramp-gvfs-handle-file-readable-p) (tramp-gvfs-handle-file-writable-p) (tramp-gvfs-handle-insert-directory) (tramp-gvfs-handle-insert-file-contents) (tramp-gvfs-handle-make-directory, tramp-gvfs-handle-rename-file) (tramp-gvfs-handle-set-visited-file-modtime) (tramp-gvfs-handle-write-region): Rewrite. (tramp-gvfs-handle-file-acl) (tramp-gvfs-handle-file-selinux-context) (tramp-gvfs-handle-process-file, tramp-gvfs-handle-set-file-acl) (tramp-gvfs-handle-set-file-modes) (tramp-gvfs-handle-set-file-selinux-context) (tramp-gvfs-handle-shell-command) (tramp-gvfs-handle-start-file-process) (tramp-gvfs-handle-verify-visited-file-modtime): Remove defuns. (tramp-gvfs-url-file-name): Do not use `file-truename', we work over the symlinks. Fix user handling. (top, tramp-gvfs-handler-mounted-unmounted): Handle different names of the D-Bus signals. (tramp-gvfs-connection-mounted-p): Handle different names of the D-Bus methods. (tramp-gvfs-mount-spec-entry): New defun. (tramp-gvfs-mount-spec): Use it. (tramp-gvfs-maybe-open-connection): Check, that in case of "smb" there is a share name. Handle different names of the D-Bus signals and methods. (tramp-gvfs-maybe-open-connection): Set connection properties needed for `tramp-check-cached-permissions'. (tramp-gvfs-send-command): Apply `tramp-gvfs-maybe-open-connection'. Return t or nil. * net/tramp.el (tramp-backtrace): Move up. (tramp-error): Apply a backtrace into the debug buffer when `tramp-verbose > 9. (tramp-file-mode-type-map, tramp-file-mode-from-int) (tramp-file-mode-permissions, tramp-get-local-uid) (tramp-get-local-gid, tramp-check-cached-permissions): Move from tramp-sh.el. * net/tramp-sh.el (tramp-file-mode-type-map) (tramp-check-cached-permissions, tramp-file-mode-from-int) (tramp-file-mode-permissions, tramp-get-local-uid) (tramp-get-local-gid): Move to tramp.el.
-rw-r--r--lisp/ChangeLog69
-rw-r--r--lisp/net/tramp-gvfs.el858
-rw-r--r--lisp/net/tramp-sh.el97
-rw-r--r--lisp/net/tramp.el112
4 files changed, 751 insertions, 385 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 5e625aed387..41d5a4ed0d0 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,72 @@
12013-03-09 Michael Albinus <michael.albinus@gmx.de>
2
3 Major rewrite due to changed D-Bus interface of GVFS 1.14.
4
5 * net/tramp-gvfs.el (top): Extend check for gvfs availability.
6 (tramp-gvfs-methods-mounttracker, tramp-gvfs-listmounts)
7 (tramp-gvfs-mountlocation, tramp-gvfs-mountlocation-signature):
8 New defconst.
9 (tramp-gvfs-file-name-handler-alist) [directory-files]:
10 [directory-files-and-attributes, file-exists-p, file-modes]: Use
11 Tramp default handler.
12 [file-acl, file-selinux-context, process-file, set-file-acl]:
13 [set-file-modes, set-file-selinux-context, shell-command]:
14 [start-file-process ]: Remove handler.
15 [verify-visited-file-modtime]: New handler.
16 (tramp-gvfs-dbus-string-to-byte-array)
17 (tramp-gvfs-dbus-byte-array-to-string): New defuns. Replace all
18 calls of `dbus-string-to-byte-array' and
19 `tramp-gvfs-dbus-byte-array-to-string'.
20 (tramp-gvfs-handle-copy-file)
21 (tramp-gvfs-handle-delete-directory)
22 (tramp-gvfs-handle-delete-file, tramp-gvfs-handle-file-attributes)
23 (tramp-gvfs-handle-file-directory-p)
24 (tramp-gvfs-handle-file-executable-p)
25 (tramp-gvfs-handle-file-name-all-completions)
26 (tramp-gvfs-handle-file-readable-p)
27 (tramp-gvfs-handle-file-writable-p)
28 (tramp-gvfs-handle-insert-directory)
29 (tramp-gvfs-handle-insert-file-contents)
30 (tramp-gvfs-handle-make-directory, tramp-gvfs-handle-rename-file)
31 (tramp-gvfs-handle-set-visited-file-modtime)
32 (tramp-gvfs-handle-write-region): Rewrite.
33 (tramp-gvfs-handle-file-acl)
34 (tramp-gvfs-handle-file-selinux-context)
35 (tramp-gvfs-handle-process-file, tramp-gvfs-handle-set-file-acl)
36 (tramp-gvfs-handle-set-file-modes)
37 (tramp-gvfs-handle-set-file-selinux-context)
38 (tramp-gvfs-handle-shell-command)
39 (tramp-gvfs-handle-start-file-process)
40 (tramp-gvfs-handle-verify-visited-file-modtime): Remove defuns.
41 (tramp-gvfs-url-file-name): Do not use `file-truename', we work
42 over the symlinks. Fix user handling.
43 (top, tramp-gvfs-handler-mounted-unmounted): Handle different names
44 of the D-Bus signals.
45 (tramp-gvfs-connection-mounted-p): Handle different names of the
46 D-Bus methods.
47 (tramp-gvfs-mount-spec-entry): New defun.
48 (tramp-gvfs-mount-spec): Use it.
49 (tramp-gvfs-maybe-open-connection): Check, that in case of "smb"
50 there is a share name. Handle different names of the D-Bus
51 signals and methods.
52 (tramp-gvfs-maybe-open-connection): Set connection properties
53 needed for `tramp-check-cached-permissions'.
54 (tramp-gvfs-send-command): Apply `tramp-gvfs-maybe-open-connection'.
55 Return t or nil.
56
57 * net/tramp.el (tramp-backtrace): Move up.
58 (tramp-error): Apply a backtrace into the debug buffer when
59 `tramp-verbose > 9.
60 (tramp-file-mode-type-map, tramp-file-mode-from-int)
61 (tramp-file-mode-permissions, tramp-get-local-uid)
62 (tramp-get-local-gid, tramp-check-cached-permissions): Move from
63 tramp-sh.el.
64
65 * net/tramp-sh.el (tramp-file-mode-type-map)
66 (tramp-check-cached-permissions, tramp-file-mode-from-int)
67 (tramp-file-mode-permissions, tramp-get-local-uid)
68 (tramp-get-local-gid): Move to tramp.el.
69
12013-03-09 Stefan Monnier <monnier@iro.umontreal.ca> 702013-03-09 Stefan Monnier <monnier@iro.umontreal.ca>
2 71
3 Separate mouse-1-click-follows-link from mouse-drag-region. 72 Separate mouse-1-click-follows-link from mouse-drag-region.
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 7473871e564..e3850653263 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -24,24 +24,28 @@
24;;; Commentary: 24;;; Commentary:
25 25
26;; Access functions for the GVFS daemon from Tramp. Tested with GVFS 26;; Access functions for the GVFS daemon from Tramp. Tested with GVFS
27;; 1.0.2 (Ubuntu 8.10, Gnome 2.24). It has been reported also to run 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 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 29;; incompatibility with the mount_info structure, which has been
30;; worked around. 30;; worked around.
31 31
32;; It has also been tested with GVFS 1.6.2 (Ubuntu 10.04, Gnome 2.30), 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 33;; where the default_location has been added to mount_info (see
34;; <https://bugzilla.gnome.org/show_bug.cgi?id=561998>. 34;; <https://bugzilla.gnome.org/show_bug.cgi?id=561998>.
35 35
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.
38
36;; All actions to mount a remote location, and to retrieve mount 39;; All actions to mount a remote location, and to retrieve mount
37;; information, are performed by D-Bus messages. File operations 40;; information, are performed by D-Bus messages. File operations
38;; themselves are performed via the mounted filesystem in ~/.gvfs. 41;; themselves are performed via the mounted filesystem in ~/.gvfs.
39;; Consequently, GNU Emacs 23.1 with enabled D-Bus bindings is a 42;; Consequently, GNU Emacs 23.1 with enabled D-Bus bindings is a
40;; precondition. 43;; precondition.
41 44
42;; The GVFS D-Bus interface is said to be unstable. There are even no 45;; The GVFS D-Bus interface is said to be unstable. There were even
43;; introspection data. The interface, as discovered during 46;; no introspection data before GVFS 1.14. The interface, as
44;; development time, is given in respective comments. 47;; discovered during development time, is given in respective
48;; comments.
45 49
46;; The customer option `tramp-gvfs-methods' contains the list of 50;; The customer option `tramp-gvfs-methods' contains the list of
47;; supported connection methods. Per default, these are "dav", 51;; supported connection methods. Per default, these are "dav",
@@ -147,7 +151,8 @@
147;; Emacs 23 on some system types. We don't call `dbus-ping', because 151;; Emacs 23 on some system types. We don't call `dbus-ping', because
148;; this would load dbus.el. 152;; this would load dbus.el.
149(unless (and (tramp-compat-funcall 'dbus-get-unique-name :session) 153(unless (and (tramp-compat-funcall 'dbus-get-unique-name :session)
150 (tramp-compat-process-running-p "gvfs-fuse-daemon")) 154 (or (tramp-compat-process-running-p "gvfs-fuse-daemon")
155 (tramp-compat-process-running-p "gvfsd-fuse")))
151 (error "Package `tramp-gvfs' not supported")) 156 (error "Package `tramp-gvfs' not supported"))
152 157
153(defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker" 158(defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker"
@@ -156,6 +161,35 @@
156(defconst tramp-gvfs-interface-mounttracker "org.gtk.vfs.MountTracker" 161(defconst tramp-gvfs-interface-mounttracker "org.gtk.vfs.MountTracker"
157 "The mount tracking interface in the GVFS daemon.") 162 "The mount tracking interface in the GVFS daemon.")
158 163
164;; Introspection data exist since GVFS 1.14. If there are no such
165;; data, we expect an earlier interface.
166(defconst tramp-gvfs-methods-mounttracker
167 (dbus-introspect-get-method-names
168 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
169 tramp-gvfs-interface-mounttracker)
170 "The list of supported methods of the mount tracking interface.")
171
172(defconst tramp-gvfs-listmounts
173 (if (member "ListMounts" tramp-gvfs-methods-mounttracker)
174 "ListMounts"
175 "listMounts")
176 "The name of the \"listMounts\" method.
177It has been changed in GVFS 1.14.")
178
179(defconst tramp-gvfs-mountlocation
180 (if (member "MountLocation" tramp-gvfs-methods-mounttracker)
181 "MountLocation"
182 "mountLocation")
183 "The name of the \"mountLocation\" method.
184It has been changed in GVFS 1.14.")
185
186(defconst tramp-gvfs-mountlocation-signature
187 (dbus-introspect-get-signature
188 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
189 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation)
190 "The D-Bus signature of the \"mountLocation\" method.
191It has been changed in GVFS 1.14.")
192
159;; <interface name='org.gtk.vfs.MountTracker'> 193;; <interface name='org.gtk.vfs.MountTracker'>
160;; <method name='listMounts'> 194;; <method name='listMounts'>
161;; <arg name='mount_info_list' 195;; <arg name='mount_info_list'
@@ -376,22 +410,22 @@ Every entry is a list (NAME ADDRESS).")
376 (delete-file . tramp-gvfs-handle-delete-file) 410 (delete-file . tramp-gvfs-handle-delete-file)
377 ;; `diff-latest-backup-file' performed by default handler. 411 ;; `diff-latest-backup-file' performed by default handler.
378 (directory-file-name . tramp-handle-directory-file-name) 412 (directory-file-name . tramp-handle-directory-file-name)
379 (directory-files . tramp-gvfs-handle-directory-files) 413 (directory-files . tramp-handle-directory-files)
380 (directory-files-and-attributes 414 (directory-files-and-attributes
381 . tramp-gvfs-handle-directory-files-and-attributes) 415 . tramp-handle-directory-files-and-attributes)
382 (dired-call-process . ignore) 416 (dired-call-process . ignore)
383 (dired-compress-file . ignore) 417 (dired-compress-file . ignore)
384 (dired-uncache . tramp-handle-dired-uncache) 418 (dired-uncache . tramp-handle-dired-uncache)
385 ;; `executable-find' is not official yet. performed by default handler. 419 ;; `executable-find' is not official yet. performed by default handler.
386 (expand-file-name . tramp-gvfs-handle-expand-file-name) 420 (expand-file-name . tramp-gvfs-handle-expand-file-name)
387 (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) 421 (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
388 (file-acl . tramp-gvfs-handle-file-acl) 422 (file-acl . ignore)
389 (file-attributes . tramp-gvfs-handle-file-attributes) 423 (file-attributes . tramp-gvfs-handle-file-attributes)
390 (file-directory-p . tramp-gvfs-handle-file-directory-p) 424 (file-directory-p . tramp-gvfs-handle-file-directory-p)
391 (file-executable-p . tramp-gvfs-handle-file-executable-p) 425 (file-executable-p . tramp-gvfs-handle-file-executable-p)
392 (file-exists-p . tramp-gvfs-handle-file-exists-p) 426 (file-exists-p . tramp-handle-file-exists-p)
393 (file-local-copy . tramp-gvfs-handle-file-local-copy) 427 (file-local-copy . tramp-gvfs-handle-file-local-copy)
394 ;; `file-modes' performed by default handler. 428 (file-modes . tramp-handle-file-modes)
395 (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions) 429 (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions)
396 (file-name-as-directory . tramp-handle-file-name-as-directory) 430 (file-name-as-directory . tramp-handle-file-name-as-directory)
397 (file-name-completion . tramp-handle-file-name-completion) 431 (file-name-completion . tramp-handle-file-name-completion)
@@ -403,7 +437,7 @@ Every entry is a list (NAME ADDRESS).")
403 (file-readable-p . tramp-gvfs-handle-file-readable-p) 437 (file-readable-p . tramp-gvfs-handle-file-readable-p)
404 (file-regular-p . tramp-handle-file-regular-p) 438 (file-regular-p . tramp-handle-file-regular-p)
405 (file-remote-p . tramp-handle-file-remote-p) 439 (file-remote-p . tramp-handle-file-remote-p)
406 (file-selinux-context . tramp-gvfs-handle-file-selinux-context) 440 (file-selinux-context . ignore)
407 (file-symlink-p . tramp-handle-file-symlink-p) 441 (file-symlink-p . tramp-handle-file-symlink-p)
408 ;; `file-truename' performed by default handler. 442 ;; `file-truename' performed by default handler.
409 (file-writable-p . tramp-gvfs-handle-file-writable-p) 443 (file-writable-p . tramp-gvfs-handle-file-writable-p)
@@ -416,19 +450,18 @@ Every entry is a list (NAME ADDRESS).")
416 (make-directory . tramp-gvfs-handle-make-directory) 450 (make-directory . tramp-gvfs-handle-make-directory)
417 (make-directory-internal . ignore) 451 (make-directory-internal . ignore)
418 (make-symbolic-link . ignore) 452 (make-symbolic-link . ignore)
419 (process-file . tramp-gvfs-handle-process-file) 453 (process-file . ignore)
420 (rename-file . tramp-gvfs-handle-rename-file) 454 (rename-file . tramp-gvfs-handle-rename-file)
421 (set-file-acl . tramp-gvfs-handle-set-file-acl) 455 (set-file-acl . ignore)
422 (set-file-modes . tramp-gvfs-handle-set-file-modes) 456 (set-file-modes . ignore)
423 (set-file-selinux-context . tramp-gvfs-handle-set-file-selinux-context) 457 (set-file-selinux-context . ignore)
424 (set-visited-file-modtime . tramp-gvfs-handle-set-visited-file-modtime) 458 (set-visited-file-modtime . tramp-gvfs-handle-set-visited-file-modtime)
425 (shell-command . tramp-gvfs-handle-shell-command) 459 (shell-command . ignore)
426 (start-file-process . tramp-gvfs-handle-start-file-process) 460 (start-file-process . ignore)
427 (substitute-in-file-name . tramp-handle-substitute-in-file-name) 461 (substitute-in-file-name . tramp-handle-substitute-in-file-name)
428 (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) 462 (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
429 (vc-registered . ignore) 463 (vc-registered . ignore)
430 (verify-visited-file-modtime 464 ;; `verify-visited-file-modtime' performed by default handler.
431 . tramp-gvfs-handle-verify-visited-file-modtime)
432 (write-region . tramp-gvfs-handle-write-region) 465 (write-region . tramp-gvfs-handle-write-region)
433) 466)
434 "Alist of handler functions for Tramp GVFS method. 467 "Alist of handler functions for Tramp GVFS method.
@@ -461,11 +494,30 @@ pass to the OPERATION."
461 (add-to-list 'tramp-foreign-file-name-handler-alist 494 (add-to-list 'tramp-foreign-file-name-handler-alist
462 (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler))) 495 (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler)))
463 496
497
498;; D-Bus helper function.
499
500(defun tramp-gvfs-dbus-string-to-byte-array (string)
501 "Like `dbus-string-to-byte-array' but add trailing \\0 if needed."
502 (dbus-string-to-byte-array
503 (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature)
504 (concat string (string 0)) string)))
505
506(defun tramp-gvfs-dbus-byte-array-to-string (byte-array)
507 "Like `dbus-byte-array-to-string' but remove trailing \\0 if exists."
508 ;; The byte array could be a variant. Take care.
509 (let ((byte-array
510 (if (and (consp byte-array) (atom (car byte-array)))
511 byte-array (car byte-array))))
512 (dbus-byte-array-to-string
513 (if (and (consp byte-array) (zerop (car (last byte-array))))
514 (butlast byte-array) byte-array))))
515
464(defun tramp-gvfs-stringify-dbus-message (message) 516(defun tramp-gvfs-stringify-dbus-message (message)
465 "Convert a D-Bus message into readable UTF8 strings, used for traces." 517 "Convert a D-Bus message into readable UTF8 strings, used for traces."
466 (cond 518 (cond
467 ((and (consp message) (characterp (car message))) 519 ((and (consp message) (characterp (car message)))
468 (format "%S" (dbus-byte-array-to-string message))) 520 (format "%S" (tramp-gvfs-dbus-byte-array-to-string message)))
469 ((consp message) 521 ((consp message)
470 (mapcar 'tramp-gvfs-stringify-dbus-message message)) 522 (mapcar 'tramp-gvfs-stringify-dbus-message message))
471 ((stringp message) 523 ((stringp message)
@@ -545,74 +597,89 @@ is no information where to trace the message.")
545 "Like `copy-file' for Tramp files." 597 "Like `copy-file' for Tramp files."
546 (with-parsed-tramp-file-name 598 (with-parsed-tramp-file-name
547 (if (tramp-tramp-file-p filename) filename newname) nil 599 (if (tramp-tramp-file-p filename) filename newname) nil
548 (with-tramp-progress-reporter 600
549 v 0 (format "Copying %s to %s" filename newname) 601 (when (and (not ok-if-already-exists) (file-exists-p newname))
550 (condition-case err 602 (tramp-error
551 (let ((args 603 v 'file-already-exists "File %s already exists" newname))
552 (list 604
553 (if (tramp-gvfs-file-name-p filename) 605 (if (or (and (tramp-tramp-file-p filename)
554 (tramp-gvfs-fuse-file-name filename) 606 (not (tramp-gvfs-file-name-p filename)))
555 filename) 607 (and (tramp-tramp-file-p newname)
556 (if (tramp-gvfs-file-name-p newname) 608 (not (tramp-gvfs-file-name-p newname))))
557 (tramp-gvfs-fuse-file-name newname) 609
558 newname) 610 ;; We cannot copy directly.
559 ok-if-already-exists keep-date preserve-uid-gid))) 611 (let ((tmpfile (tramp-compat-make-temp-file filename)))
560 (when preserve-extended-attributes 612 (cond
561 (setq args (append args (list preserve-extended-attributes)))) 613 (preserve-extended-attributes
562 (apply 'copy-file args)) 614 (copy-file
563 615 filename tmpfile t keep-date preserve-uid-gid
564 ;; Error case. Let's try it with the GVFS utilities. 616 preserve-extended-attributes))
565 (error 617 (preserve-uid-gid
566 (tramp-message v 4 "`copy-file' failed, trying `gvfs-copy'") 618 (copy-file filename tmpfile t keep-date preserve-uid-gid))
567 (unless 619 (t
568 (zerop 620 (copy-file filename tmpfile t keep-date)))
569 (let ((args 621 (rename-file tmpfile newname ok-if-already-exists))
570 (append (if (or keep-date preserve-uid-gid) 622
571 (list "--preserve") 623 ;; Direct copy.
572 nil) 624 (with-tramp-progress-reporter
573 (list 625 v 0 (format "Copying %s to %s" filename newname)
574 (tramp-gvfs-url-file-name filename) 626 (unless
575 (tramp-gvfs-url-file-name newname))))) 627 (let ((args
576 (apply 'tramp-gvfs-send-command v "gvfs-copy" args))) 628 (append (if (or keep-date preserve-uid-gid)
577 ;; Propagate the error. 629 (list "--preserve")
578 (tramp-error v (car err) "%s" (cdr err))))))) 630 nil)
579 631 (list
580 (when (file-remote-p newname) 632 (tramp-gvfs-url-file-name filename)
581 (with-parsed-tramp-file-name newname nil 633 (tramp-gvfs-url-file-name newname)))))
582 (tramp-flush-file-property v (file-name-directory localname)) 634 (apply 'tramp-gvfs-send-command v "gvfs-copy" args))
583 (tramp-flush-file-property v localname)))) 635 ;; Propagate the error.
584 636 (with-current-buffer (tramp-get-connection-buffer v)
585(defun tramp-gvfs-handle-delete-directory (directory &optional recursive) 637 (goto-char (point-min))
638 (tramp-error-with-buffer
639 nil v 'file-error
640 "Copying failed, see buffer `%s' for details." (buffer-name)))))
641
642 (when (file-remote-p newname)
643 (with-parsed-tramp-file-name newname nil
644 (tramp-flush-file-property v (file-name-directory localname))
645 (tramp-flush-file-property v localname))))))
646
647(defun tramp-gvfs-handle-delete-directory (directory &optional recursive trash)
586 "Like `delete-directory' for Tramp files." 648 "Like `delete-directory' for Tramp files."
587 (tramp-compat-delete-directory 649 (when (and recursive (not (file-symlink-p directory)))
588 (tramp-gvfs-fuse-file-name directory) recursive)) 650 (mapc (lambda (file)
651 (if (eq t (car (file-attributes file)))
652 (tramp-compat-delete-directory file recursive trash)
653 (tramp-compat-delete-file file trash)))
654 (directory-files
655 directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
656 (with-parsed-tramp-file-name directory nil
657 (tramp-flush-file-property v (file-name-directory localname))
658 (tramp-flush-directory-property v localname)
659 (unless
660 (tramp-gvfs-send-command
661 v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm")
662 (tramp-gvfs-url-file-name directory))
663 ;; Propagate the error.
664 (with-current-buffer (tramp-get-connection-buffer v)
665 (goto-char (point-min))
666 (tramp-error-with-buffer
667 nil v 'file-error "Couldn't delete %s" directory)))))
589 668
590(defun tramp-gvfs-handle-delete-file (filename &optional trash) 669(defun tramp-gvfs-handle-delete-file (filename &optional trash)
591 "Like `delete-file' for Tramp files." 670 "Like `delete-file' for Tramp files."
592 (tramp-compat-delete-file (tramp-gvfs-fuse-file-name filename) trash)) 671 (with-parsed-tramp-file-name filename nil
593 672 (tramp-flush-file-property v (file-name-directory localname))
594(defun tramp-gvfs-handle-directory-files 673 (tramp-flush-directory-property v localname)
595 (directory &optional full match nosort) 674 (unless
596 "Like `directory-files' for Tramp files." 675 (tramp-gvfs-send-command
597 (let ((fuse-file-name (tramp-gvfs-fuse-file-name directory))) 676 v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm")
598 (mapcar 677 (tramp-gvfs-url-file-name filename))
599 (lambda (x) 678 ;; Propagate the error.
600 (if (string-match fuse-file-name x) 679 (with-current-buffer (tramp-get-connection-buffer v)
601 (replace-match directory t t x) 680 (goto-char (point-min))
602 x)) 681 (tramp-error-with-buffer
603 (directory-files fuse-file-name full match nosort)))) 682 nil v 'file-error "Couldn't delete %s" filename)))))
604
605(defun tramp-gvfs-handle-directory-files-and-attributes
606 (directory &optional full match nosort id-format)
607 "Like `directory-files-and-attributes' for Tramp files."
608 (let ((fuse-file-name (tramp-gvfs-fuse-file-name directory)))
609 (mapcar
610 (lambda (x)
611 (when (string-match fuse-file-name (car x))
612 (setcar x (replace-match directory t t (car x))))
613 x)
614 (directory-files-and-attributes
615 fuse-file-name full match nosort id-format))))
616 683
617(defun tramp-gvfs-handle-expand-file-name (name &optional dir) 684(defun tramp-gvfs-handle-expand-file-name (name &optional dir)
618 "Like `expand-file-name' for Tramp files." 685 "Like `expand-file-name' for Tramp files."
@@ -657,25 +724,136 @@ is no information where to trace the message.")
657 (tramp-run-real-handler 724 (tramp-run-real-handler
658 'expand-file-name (list localname)))))) 725 'expand-file-name (list localname))))))
659 726
660(defun tramp-gvfs-handle-file-acl (filename)
661 "Like `file-acl' for Tramp files."
662 (tramp-compat-funcall 'file-acl (tramp-gvfs-fuse-file-name filename)))
663
664(defun tramp-gvfs-handle-file-attributes (filename &optional id-format) 727(defun tramp-gvfs-handle-file-attributes (filename &optional id-format)
665 "Like `file-attributes' for Tramp files." 728 "Like `file-attributes' for Tramp files."
666 (file-attributes (tramp-gvfs-fuse-file-name filename) id-format)) 729 (unless id-format (setq id-format 'integer))
730 ;; Don't modify `last-coding-system-used' by accident.
731 (let ((last-coding-system-used last-coding-system-used)
732 dirp res-symlink-target res-numlinks res-uid res-gid res-access
733 res-mod res-change res-size res-filemodes res-inode res-device)
734 (with-parsed-tramp-file-name filename nil
735 (with-tramp-file-property
736 v localname (format "file-attributes-%s" id-format)
737 (tramp-message v 5 "file attributes: %s" localname)
738 (tramp-gvfs-send-command
739 v "gvfs-info" (tramp-gvfs-url-file-name filename))
740 ;; Parse output ...
741 (with-current-buffer (tramp-get-connection-buffer v)
742 (goto-char (point-min))
743 (when (re-search-forward "attributes:" nil t)
744 ;; ... directory or symlink
745 (goto-char (point-min))
746 (setq dirp (if (re-search-forward "type:\\s-+directory" nil t) t))
747 (goto-char (point-min))
748 (setq res-symlink-target
749 (if (re-search-forward
750 "standard::symlink-target:\\s-+\\(\\S-+\\)" nil t)
751 (match-string 1)))
752 ;; ... number links
753 (goto-char (point-min))
754 (setq res-numlinks
755 (if (re-search-forward "unix::nlink:\\s-+\\([0-9]+\\)" nil t)
756 (string-to-number (match-string 1)) 0))
757 ;; ... uid and gid
758 (goto-char (point-min))
759 (setq res-uid
760 (or (if (eq id-format 'integer)
761 (if (re-search-forward
762 "unix::uid:\\s-+\\([0-9]+\\)" nil t)
763 (string-to-number (match-string 1)))
764 (if (re-search-forward
765 "owner::user:\\s-+\\(\\S-+\\)" nil t)
766 (match-string 1)))
767 (tramp-get-local-uid id-format)))
768 (setq res-gid
769 (or (if (eq id-format 'integer)
770 (if (re-search-forward
771 "unix::gid:\\s-+\\([0-9]+\\)" nil t)
772 (string-to-number (match-string 1)))
773 (if (re-search-forward
774 "owner::group:\\s-+\\(\\S-+\\)" nil t)
775 (match-string 1)))
776 (tramp-get-local-gid id-format)))
777 ;; ... last access, modification and change time
778 (goto-char (point-min))
779 (setq res-access
780 (if (re-search-forward
781 "time::access:\\s-+\\([0-9]+\\)" nil t)
782 (seconds-to-time (string-to-number (match-string 1)))
783 '(0 0)))
784 (goto-char (point-min))
785 (setq res-mod
786 (if (re-search-forward
787 "time::modified:\\s-+\\([0-9]+\\)" nil t)
788 (seconds-to-time (string-to-number (match-string 1)))
789 '(0 0)))
790 (goto-char (point-min))
791 (setq res-change
792 (if (re-search-forward
793 "time::changed:\\s-+\\([0-9]+\\)" nil t)
794 (seconds-to-time (string-to-number (match-string 1)))
795 '(0 0)))
796 ;; ... size
797 (goto-char (point-min))
798 (setq res-size
799 (if (re-search-forward
800 "standard::size:\\s-+\\([0-9]+\\)" nil t)
801 (string-to-number (match-string 1)) 0))
802 ;; ... file mode flags
803 (goto-char (point-min))
804 (setq res-filemodes
805 (if (re-search-forward "unix::mode:\\s-+\\([0-9]+\\)" nil t)
806 (tramp-file-mode-from-int (match-string 1))
807 (if dirp "drwx------" "-rwx------")))
808 ;; ... inode and device
809 (goto-char (point-min))
810 (setq res-inode
811 (if (re-search-forward "unix::inode:\\s-+\\([0-9]+\\)" nil t)
812 (string-to-number (match-string 1))
813 (tramp-get-inode v)))
814 (goto-char (point-min))
815 (setq res-device
816 (if (re-search-forward "unix::device:\\s-+\\([0-9]+\\)" nil t)
817 (string-to-number (match-string 1))
818 (tramp-get-device v)))
819
820 ;; Return data gathered.
821 (list
822 ;; 0. t for directory, string (name linked to) for
823 ;; symbolic link, or nil.
824 (or dirp res-symlink-target)
825 ;; 1. Number of links to file.
826 res-numlinks
827 ;; 2. File uid.
828 res-uid
829 ;; 3. File gid.
830 res-gid
831 ;; 4. Last access time, as a list of integers.
832 ;; 5. Last modification time, likewise.
833 ;; 6. Last status change time, likewise.
834 res-access res-mod res-change
835 ;; 7. Size in bytes (-1, if number is out of range).
836 res-size
837 ;; 8. File modes.
838 res-filemodes
839 ;; 9. t if file's gid would change if file were deleted
840 ;; and recreated.
841 nil
842 ;; 10. Inode number.
843 res-inode
844 ;; 11. Device number.
845 res-device
846 )))))))
667 847
668(defun tramp-gvfs-handle-file-directory-p (filename) 848(defun tramp-gvfs-handle-file-directory-p (filename)
669 "Like `file-directory-p' for Tramp files." 849 "Like `file-directory-p' for Tramp files."
670 (file-directory-p (tramp-gvfs-fuse-file-name filename))) 850 (eq t (car (file-attributes filename))))
671 851
672(defun tramp-gvfs-handle-file-executable-p (filename) 852(defun tramp-gvfs-handle-file-executable-p (filename)
673 "Like `file-executable-p' for Tramp files." 853 "Like `file-executable-p' for Tramp files."
674 (file-executable-p (tramp-gvfs-fuse-file-name filename))) 854 (with-parsed-tramp-file-name filename nil
675 855 (with-tramp-file-property v localname "file-executable-p"
676(defun tramp-gvfs-handle-file-exists-p (filename) 856 (tramp-check-cached-permissions v ?x))))
677 "Like `file-exists-p' for Tramp files."
678 (file-exists-p (tramp-gvfs-fuse-file-name filename)))
679 857
680(defun tramp-gvfs-handle-file-local-copy (filename) 858(defun tramp-gvfs-handle-file-local-copy (filename)
681 "Like `file-local-copy' for Tramp files." 859 "Like `file-local-copy' for Tramp files."
@@ -691,158 +869,221 @@ is no information where to trace the message.")
691(defun tramp-gvfs-handle-file-name-all-completions (filename directory) 869(defun tramp-gvfs-handle-file-name-all-completions (filename directory)
692 "Like `file-name-all-completions' for Tramp files." 870 "Like `file-name-all-completions' for Tramp files."
693 (unless (save-match-data (string-match "/" filename)) 871 (unless (save-match-data (string-match "/" filename))
694 (file-name-all-completions filename (tramp-gvfs-fuse-file-name directory)))) 872 (with-parsed-tramp-file-name (expand-file-name directory) nil
873
874 (all-completions
875 filename
876 (mapcar
877 'list
878 (or
879 ;; Try cache entries for filename, filename with last
880 ;; character removed, filename with last two characters
881 ;; removed, ..., and finally the empty string - all
882 ;; concatenated to the local directory name.
883 (let ((remote-file-name-inhibit-cache
884 (or remote-file-name-inhibit-cache
885 tramp-completion-reread-directory-timeout)))
886
887 ;; This is inefficient for very long filenames, pity
888 ;; `reduce' is not available...
889 (car
890 (apply
891 'append
892 (mapcar
893 (lambda (x)
894 (let ((cache-hit
895 (tramp-get-file-property
896 v
897 (concat localname (substring filename 0 x))
898 "file-name-all-completions"
899 nil)))
900 (when cache-hit (list cache-hit))))
901 ;; We cannot use a length of 0, because file properties
902 ;; for "foo" and "foo/" are identical.
903 (tramp-compat-number-sequence (length filename) 1 -1)))))
904
905 ;; Cache expired or no matching cache entry found so we need
906 ;; to perform a remote operation.
907 (let ((result '("." ".."))
908 entry)
909 ;; Get a list of directories and files.
910 (tramp-gvfs-send-command
911 v "gvfs-ls" (tramp-gvfs-url-file-name directory))
912
913 ;; Now grab the output.
914 (with-temp-buffer
915 (insert-buffer-substring (tramp-get-connection-buffer v))
916 (goto-char (point-max))
917 (while (zerop (forward-line -1))
918 (setq entry (buffer-substring (point) (point-at-eol)))
919 (when (string-match filename entry)
920 (if (file-directory-p (expand-file-name entry directory))
921 (push (concat entry "/") result)
922 (push entry result)))))
923
924 ;; Because the remote op went through OK we know the
925 ;; directory we `cd'-ed to exists.
926 (tramp-set-file-property v localname "file-exists-p" t)
927
928 ;; Because the remote op went through OK we know every
929 ;; file listed by `ls' exists.
930 (mapc (lambda (entry)
931 (tramp-set-file-property
932 v (concat localname entry) "file-exists-p" t))
933 result)
934
935 ;; Store result in the cache.
936 (tramp-set-file-property
937 v (concat localname filename)
938 "file-name-all-completions" result))))))))
695 939
696(defun tramp-gvfs-handle-file-readable-p (filename) 940(defun tramp-gvfs-handle-file-readable-p (filename)
697 "Like `file-readable-p' for Tramp files." 941 "Like `file-readable-p' for Tramp files."
698 (file-readable-p (tramp-gvfs-fuse-file-name filename))) 942 (with-parsed-tramp-file-name filename nil
699 943 (with-tramp-file-property v localname "file-executable-p"
700(defun tramp-gvfs-handle-file-selinux-context (filename) 944 (tramp-check-cached-permissions v ?r))))
701 "Like `file-selinux-context' for Tramp files."
702 (tramp-compat-funcall
703 'file-selinux-context (tramp-gvfs-fuse-file-name filename)))
704 945
705(defun tramp-gvfs-handle-file-writable-p (filename) 946(defun tramp-gvfs-handle-file-writable-p (filename)
706 "Like `file-writable-p' for Tramp files." 947 "Like `file-writable-p' for Tramp files."
707 (file-writable-p (tramp-gvfs-fuse-file-name filename))) 948 (with-parsed-tramp-file-name filename nil
949 (with-tramp-file-property v localname "file-writable-p"
950 (if (file-exists-p filename)
951 (tramp-check-cached-permissions v ?w)
952 ;; If file doesn't exist, check if directory is writable.
953 (and (file-directory-p (file-name-directory filename))
954 (file-writable-p (file-name-directory filename)))))))
708 955
709(defun tramp-gvfs-handle-insert-directory 956(defun tramp-gvfs-handle-insert-directory
710 (filename switches &optional wildcard full-directory-p) 957 (filename switches &optional wildcard full-directory-p)
711 "Like `insert-directory' for Tramp files." 958 "Like `insert-directory' for Tramp files."
712 (insert-directory 959 ;; gvfs-* output is hard to parse. So we let `ls-lisp' do the job.
713 (tramp-gvfs-fuse-file-name filename) switches wildcard full-directory-p)) 960 (with-parsed-tramp-file-name (expand-file-name filename) nil
961 (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename)
962 (require 'ls-lisp)
963 (let (ls-lisp-use-insert-directory-program)
964 (tramp-run-real-handler
965 'insert-directory
966 (list filename switches wildcard full-directory-p))))))
714 967
715(defun tramp-gvfs-handle-insert-file-contents 968(defun tramp-gvfs-handle-insert-file-contents
716 (filename &optional visit beg end replace) 969 (filename &optional visit beg end replace)
717 "Like `insert-file-contents' for Tramp files." 970 "Like `insert-file-contents' for Tramp files."
718 (unwind-protect 971 (barf-if-buffer-read-only)
719 (let ((fuse-file-name (tramp-gvfs-fuse-file-name filename)) 972 (setq filename (expand-file-name filename))
720 (result 973 (let (tmpfile result)
721 (insert-file-contents 974 (unwind-protect
722 (tramp-gvfs-fuse-file-name filename) visit beg end replace))) 975 (if (not (file-exists-p filename))
723 (when (string-match fuse-file-name (car result)) 976 ;; We don't raise a Tramp error, because it might be
724 (setcar result (replace-match filename t t (car result)))) 977 ;; suppressed, like in `find-file-noselect-1'.
725 result) 978 (signal 'file-error (list "File not found on remote host" filename))
726 (setq buffer-file-name filename))) 979
980 (setq tmpfile (file-local-copy filename)
981 result (insert-file-contents tmpfile visit beg end replace)))
982 ;; Save exit.
983 (when visit
984 (setq buffer-file-name filename)
985 (setq buffer-read-only (not (file-writable-p filename)))
986 (set-visited-file-modtime)
987 (set-buffer-modified-p nil))
988 (when (stringp tmpfile)
989 (delete-file tmpfile)))
990
991 ;; Result.
992 (list filename (cadr result))))
727 993
728(defun tramp-gvfs-handle-make-directory (dir &optional parents) 994(defun tramp-gvfs-handle-make-directory (dir &optional parents)
729 "Like `make-directory' for Tramp files." 995 "Like `make-directory' for Tramp files."
730 (with-parsed-tramp-file-name dir nil 996 (with-parsed-tramp-file-name dir nil
731 (condition-case err 997 (unless
732 (with-tramp-gvfs-error-message dir 'make-directory 998 (apply
733 (tramp-gvfs-fuse-file-name dir) parents) 999 'tramp-gvfs-send-command v "gvfs-mkdir"
734 1000 (if parents
735 ;; Error case. Let's try it with the GVFS utilities. 1001 (list "-p" (tramp-gvfs-url-file-name dir))
736 (error 1002 (list (tramp-gvfs-url-file-name dir))))
737 (tramp-message v 4 "`make-directory' failed, trying `gvfs-mkdir'") 1003 ;; Propagate the error.
738 (unless 1004 (tramp-error v 'file-error "Couldn't make directory %s" dir))))
739 (zerop
740 (tramp-gvfs-send-command
741 v "gvfs-mkdir" (tramp-gvfs-url-file-name dir)))
742 ;; Propagate the error.
743 (tramp-error v (car err) "%s" (cdr err)))))))
744
745(defun tramp-gvfs-handle-process-file
746 (program &optional infile destination display &rest args)
747 "Like `process-file' for Tramp files."
748 (let ((default-directory (tramp-gvfs-fuse-file-name default-directory)))
749 (apply 'call-process program infile destination display args)))
750 1005
751(defun tramp-gvfs-handle-rename-file 1006(defun tramp-gvfs-handle-rename-file
752 (filename newname &optional ok-if-already-exists) 1007 (filename newname &optional ok-if-already-exists)
753 "Like `rename-file' for Tramp files." 1008 "Like `rename-file' for Tramp files."
754 (with-parsed-tramp-file-name 1009 (with-parsed-tramp-file-name
755 (if (tramp-tramp-file-p filename) filename newname) nil 1010 (if (tramp-tramp-file-p filename) filename newname) nil
756 (with-tramp-progress-reporter
757 v 0 (format "Renaming %s to %s" filename newname)
758 (condition-case err
759 (rename-file
760 (if (tramp-gvfs-file-name-p filename)
761 (tramp-gvfs-fuse-file-name filename)
762 filename)
763 (if (tramp-gvfs-file-name-p newname)
764 (tramp-gvfs-fuse-file-name newname)
765 newname)
766 ok-if-already-exists)
767
768 ;; Error case. Let's try it with the GVFS utilities.
769 (error
770 (tramp-message v 4 "`rename-file' failed, trying `gvfs-move'")
771 (unless
772 (zerop
773 (tramp-gvfs-send-command
774 v "gvfs-move"
775 (tramp-gvfs-url-file-name filename)
776 (tramp-gvfs-url-file-name newname)))
777 ;; Propagate the error.
778 (tramp-error v (car err) "%s" (cdr err)))))))
779
780 (when (file-remote-p filename)
781 (with-parsed-tramp-file-name filename nil
782 (tramp-flush-file-property v (file-name-directory localname))
783 (tramp-flush-file-property v localname)))
784 1011
785 (when (file-remote-p newname) 1012 (when (and (not ok-if-already-exists) (file-exists-p newname))
786 (with-parsed-tramp-file-name newname nil 1013 (tramp-error
787 (tramp-flush-file-property v (file-name-directory localname)) 1014 v 'file-already-exists "File %s already exists" newname))
788 (tramp-flush-file-property v localname))))
789 1015
790(defun tramp-gvfs-handle-set-file-acl (filename acl-string) 1016 (if (or (and (tramp-tramp-file-p filename)
791 "Like `set-file-acl' for Tramp files." 1017 (not (tramp-gvfs-file-name-p filename)))
792 (with-tramp-gvfs-error-message filename 'set-file-acl 1018 (and (tramp-tramp-file-p newname)
793 (tramp-gvfs-fuse-file-name filename) acl-string)) 1019 (not (tramp-gvfs-file-name-p newname))))
794 1020
795(defun tramp-gvfs-handle-set-file-modes (filename mode) 1021 ;; We cannot move directly.
796 "Like `set-file-modes' for Tramp files." 1022 (let ((tmpfile (tramp-compat-make-temp-file filename)))
797 (with-tramp-gvfs-error-message filename 'set-file-modes 1023 (rename-file filename tmpfile t)
798 (tramp-gvfs-fuse-file-name filename) mode)) 1024 (rename-file tmpfile newname ok-if-already-exists))
799 1025
800(defun tramp-gvfs-handle-set-file-selinux-context (filename context) 1026 ;; Direct move.
801 "Like `set-file-selinux-context' for Tramp files." 1027 (with-tramp-progress-reporter
802 (with-tramp-gvfs-error-message filename 'set-file-selinux-context 1028 v 0 (format "Renaming %s to %s" filename newname)
803 (tramp-gvfs-fuse-file-name filename) context)) 1029 (unless
1030 (tramp-gvfs-send-command
1031 v "gvfs-move"
1032 (tramp-gvfs-url-file-name filename)
1033 (tramp-gvfs-url-file-name newname))
1034 ;; Propagate the error.
1035 (with-current-buffer (tramp-get-buffer v)
1036 (goto-char (point-min))
1037 (tramp-error-with-buffer
1038 nil v 'file-error
1039 "Renaming failed, see buffer `%s' for details." (buffer-name)))))
1040
1041 (when (file-remote-p filename)
1042 (with-parsed-tramp-file-name filename nil
1043 (tramp-flush-file-property v (file-name-directory localname))
1044 (tramp-flush-file-property v localname)))
1045
1046 (when (file-remote-p newname)
1047 (with-parsed-tramp-file-name newname nil
1048 (tramp-flush-file-property v (file-name-directory localname))
1049 (tramp-flush-file-property v localname))))))
804 1050
805(defun tramp-gvfs-handle-set-visited-file-modtime (&optional time-list) 1051(defun tramp-gvfs-handle-set-visited-file-modtime (&optional time-list)
806 "Like `set-visited-file-modtime' for Tramp files." 1052 "Like `set-visited-file-modtime' for Tramp files."
807 (let ((buffer-file-name (tramp-gvfs-fuse-file-name (buffer-file-name)))) 1053 (unless (buffer-file-name)
808 (set-visited-file-modtime time-list))) 1054 (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file"
809 1055 (buffer-name)))
810(defun tramp-gvfs-handle-shell-command 1056 (unless time-list
811 (command &optional output-buffer error-buffer) 1057 (let ((f (buffer-file-name)))
812 "Like `shell-command' for Tramp files." 1058 (with-parsed-tramp-file-name f nil
813 (let ((default-directory (tramp-gvfs-fuse-file-name default-directory))) 1059 (let ((remote-file-name-inhibit-cache t)
814 (shell-command command output-buffer error-buffer))) 1060 (attr (file-attributes f)))
815 1061 ;; '(-1 65535) means file doesn't exists yet.
816(defun tramp-gvfs-handle-start-file-process (name buffer program &rest args) 1062 (setq time-list (or (nth 5 attr) '(-1 65535)))))))
817 "Like `start-file-process' for Tramp files." 1063 ;; We use '(0 0) as a don't-know value.
818 (let ((default-directory (tramp-gvfs-fuse-file-name default-directory))) 1064 (unless (not (equal time-list '(0 0)))
819 (apply 'start-process name buffer program args))) 1065 (tramp-run-real-handler 'set-visited-file-modtime (list time-list))))
820
821(defun tramp-gvfs-handle-verify-visited-file-modtime (buf)
822 "Like `verify-visited-file-modtime' for Tramp files."
823 (with-current-buffer buf
824 (let ((buffer-file-name (tramp-gvfs-fuse-file-name (buffer-file-name))))
825 (verify-visited-file-modtime buf))))
826 1066
827(defun tramp-gvfs-handle-write-region 1067(defun tramp-gvfs-handle-write-region
828 (start end filename &optional append visit lockname confirm) 1068 (start end filename &optional append visit lockname confirm)
829 "Like `write-region' for Tramp files." 1069 "Like `write-region' for Tramp files."
830 (with-parsed-tramp-file-name filename nil 1070 (with-parsed-tramp-file-name filename nil
831 (condition-case err 1071 ;; XEmacs takes a coding system as the seventh argument, not `confirm'.
832 (with-tramp-gvfs-error-message filename 'write-region 1072 (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename))
833 start end (tramp-gvfs-fuse-file-name filename) 1073 (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename))
834 append visit lockname confirm) 1074 (tramp-error v 'file-error "File not overwritten")))
835 1075
836 ;; Error case. Let's try rename. 1076 (let ((tmpfile (tramp-compat-make-temp-file filename)))
837 (error 1077 (write-region start end tmpfile)
838 (let ((tmpfile (tramp-compat-make-temp-file filename))) 1078 (condition-case nil
839 (tramp-message v 4 "`write-region' failed, trying `rename-file'") 1079 (rename-file tmpfile filename)
840 (write-region start end tmpfile) 1080 (error
841 (condition-case nil 1081 (delete-file tmpfile)
842 (rename-file tmpfile filename) 1082 (tramp-error
843 (error 1083 v 'file-error "Couldn't write region to `%s'" filename))))
844 (delete-file tmpfile) 1084
845 (tramp-error v (car err) "%s" (cdr err))))))) 1085 (tramp-flush-file-property v (file-name-directory localname))
1086 (tramp-flush-file-property v localname)
846 1087
847 ;; Set file modification time. 1088 ;; Set file modification time.
848 (when (or (eq visit t) (stringp visit)) 1089 (when (or (eq visit t) (stringp visit))
@@ -859,19 +1100,27 @@ is no information where to trace the message.")
859(defun tramp-gvfs-url-file-name (filename) 1100(defun tramp-gvfs-url-file-name (filename)
860 "Return FILENAME in URL syntax." 1101 "Return FILENAME in URL syntax."
861 ;; "/" must NOT be hexlified. 1102 ;; "/" must NOT be hexlified.
862 (let ((url-unreserved-chars (append '(?/) url-unreserved-chars))) 1103 (let ((url-unreserved-chars (append '(?/) url-unreserved-chars))
863 (url-recreate-url 1104 result)
864 (if (tramp-tramp-file-p filename) 1105 (setq
865 (with-parsed-tramp-file-name (file-truename filename) nil 1106 result
866 (when (string-match tramp-user-with-domain-regexp user) 1107 (url-recreate-url
867 (setq user 1108 (if (tramp-tramp-file-p filename)
868 (concat (match-string 2 user) ";" (match-string 2 user)))) 1109 (with-parsed-tramp-file-name filename nil
869 (url-parse-make-urlobj 1110 (when (and user (string-match tramp-user-with-domain-regexp user))
870 method user nil 1111 (setq user
871 (tramp-file-name-real-host v) (tramp-file-name-port v) 1112 (concat (match-string 2 user) ";" (match-string 1 user))))
872 (url-hexify-string localname))) 1113 (url-parse-make-urlobj
873 (url-parse-make-urlobj 1114 method (url-hexify-string user) nil
874 "file" nil nil nil nil (url-hexify-string (file-truename filename))))))) 1115 (tramp-file-name-real-host v) (tramp-file-name-port v)
1116 (url-hexify-string localname) nil nil t))
1117 (url-parse-make-urlobj
1118 "file" nil nil nil nil
1119 (url-hexify-string (file-truename filename)) nil nil t))))
1120 (when (tramp-tramp-file-p filename)
1121 (with-parsed-tramp-file-name filename nil
1122 (tramp-message v 10 "remote file `%s' is URL `%s'" filename result)))
1123 result))
875 1124
876(defun tramp-gvfs-object-path (filename) 1125(defun tramp-gvfs-object-path (filename)
877 "Create a D-Bus object path from FILENAME." 1126 "Create a D-Bus object path from FILENAME."
@@ -1012,24 +1261,26 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1012 ;; were changes in the entries, we cannot access dedicated 1261 ;; were changes in the entries, we cannot access dedicated
1013 ;; elements. 1262 ;; elements.
1014 (while (stringp (car elt)) (setq elt (cdr elt))) 1263 (while (stringp (car elt)) (setq elt (cdr elt)))
1015 (let* ((fuse-mountpoint (dbus-byte-array-to-string (cadr elt))) 1264 (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt)))
1016 (mount-spec (caddr elt)) 1265 (mount-spec (caddr elt))
1017 (default-location (dbus-byte-array-to-string (cadddr elt))) 1266 (default-location (tramp-gvfs-dbus-byte-array-to-string
1018 (method (dbus-byte-array-to-string 1267 (cadddr elt)))
1268 (method (tramp-gvfs-dbus-byte-array-to-string
1019 (cadr (assoc "type" (cadr mount-spec))))) 1269 (cadr (assoc "type" (cadr mount-spec)))))
1020 (user (dbus-byte-array-to-string 1270 (user (tramp-gvfs-dbus-byte-array-to-string
1021 (cadr (assoc "user" (cadr mount-spec))))) 1271 (cadr (assoc "user" (cadr mount-spec)))))
1022 (domain (dbus-byte-array-to-string 1272 (domain (tramp-gvfs-dbus-byte-array-to-string
1023 (cadr (assoc "domain" (cadr mount-spec))))) 1273 (cadr (assoc "domain" (cadr mount-spec)))))
1024 (host (dbus-byte-array-to-string 1274 (host (tramp-gvfs-dbus-byte-array-to-string
1025 (cadr (or (assoc "host" (cadr mount-spec)) 1275 (cadr (or (assoc "host" (cadr mount-spec))
1026 (assoc "server" (cadr mount-spec)))))) 1276 (assoc "server" (cadr mount-spec))))))
1027 (port (dbus-byte-array-to-string 1277 (port (tramp-gvfs-dbus-byte-array-to-string
1028 (cadr (assoc "port" (cadr mount-spec))))) 1278 (cadr (assoc "port" (cadr mount-spec)))))
1029 (ssl (dbus-byte-array-to-string 1279 (ssl (tramp-gvfs-dbus-byte-array-to-string
1030 (cadr (assoc "ssl" (cadr mount-spec))))) 1280 (cadr (assoc "ssl" (cadr mount-spec)))))
1031 (prefix (concat (dbus-byte-array-to-string (car mount-spec)) 1281 (prefix (concat (tramp-gvfs-dbus-byte-array-to-string
1032 (dbus-byte-array-to-string 1282 (car mount-spec))
1283 (tramp-gvfs-dbus-byte-array-to-string
1033 (cadr (assoc "share" (cadr mount-spec))))))) 1284 (cadr (assoc "share" (cadr mount-spec)))))))
1034 (when (string-match "^smb" method) 1285 (when (string-match "^smb" method)
1035 (setq method "smb")) 1286 (setq method "smb"))
@@ -1047,7 +1298,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1047 v 6 "%s %s" 1298 v 6 "%s %s"
1048 signal-name (tramp-gvfs-stringify-dbus-message mount-info)) 1299 signal-name (tramp-gvfs-stringify-dbus-message mount-info))
1049 (tramp-set-file-property v "/" "list-mounts" 'undef) 1300 (tramp-set-file-property v "/" "list-mounts" 'undef)
1050 (if (string-equal signal-name "unmounted") 1301 (if (string-equal (downcase signal-name) "unmounted")
1051 (tramp-set-file-property v "/" "fuse-mountpoint" nil) 1302 (tramp-set-file-property v "/" "fuse-mountpoint" nil)
1052 ;; Set prefix, mountpoint and location. 1303 ;; Set prefix, mountpoint and location.
1053 (unless (string-equal prefix "/") 1304 (unless (string-equal prefix "/")
@@ -1060,11 +1311,19 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1060 :session nil tramp-gvfs-path-mounttracker 1311 :session nil tramp-gvfs-path-mounttracker
1061 tramp-gvfs-interface-mounttracker "mounted" 1312 tramp-gvfs-interface-mounttracker "mounted"
1062 'tramp-gvfs-handler-mounted-unmounted) 1313 'tramp-gvfs-handler-mounted-unmounted)
1314(dbus-register-signal
1315 :session nil tramp-gvfs-path-mounttracker
1316 tramp-gvfs-interface-mounttracker "Mounted"
1317 'tramp-gvfs-handler-mounted-unmounted)
1063 1318
1064(dbus-register-signal 1319(dbus-register-signal
1065 :session nil tramp-gvfs-path-mounttracker 1320 :session nil tramp-gvfs-path-mounttracker
1066 tramp-gvfs-interface-mounttracker "unmounted" 1321 tramp-gvfs-interface-mounttracker "unmounted"
1067 'tramp-gvfs-handler-mounted-unmounted) 1322 'tramp-gvfs-handler-mounted-unmounted)
1323(dbus-register-signal
1324 :session nil tramp-gvfs-path-mounttracker
1325 tramp-gvfs-interface-mounttracker "Unmounted"
1326 'tramp-gvfs-handler-mounted-unmounted)
1068 1327
1069(defun tramp-gvfs-connection-mounted-p (vec) 1328(defun tramp-gvfs-connection-mounted-p (vec)
1070 "Check, whether the location is already mounted." 1329 "Check, whether the location is already mounted."
@@ -1076,30 +1335,33 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1076 (with-tramp-file-property vec "/" "list-mounts" 1335 (with-tramp-file-property vec "/" "list-mounts"
1077 (with-tramp-dbus-call-method vec t 1336 (with-tramp-dbus-call-method vec t
1078 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker 1337 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1079 tramp-gvfs-interface-mounttracker "listMounts")) 1338 tramp-gvfs-interface-mounttracker tramp-gvfs-listmounts))
1080 nil) 1339 nil)
1081 ;; Jump over the first elements of the mount info. Since there 1340 ;; Jump over the first elements of the mount info. Since there
1082 ;; were changes in the entries, we cannot access dedicated 1341 ;; were changes in the entries, we cannot access dedicated
1083 ;; elements. 1342 ;; elements.
1084 (while (stringp (car elt)) (setq elt (cdr elt))) 1343 (while (stringp (car elt)) (setq elt (cdr elt)))
1085 (let* ((fuse-mountpoint (dbus-byte-array-to-string (cadr elt))) 1344 (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string
1345 (cadr elt)))
1086 (mount-spec (caddr elt)) 1346 (mount-spec (caddr elt))
1087 (default-location (dbus-byte-array-to-string (cadddr elt))) 1347 (default-location (tramp-gvfs-dbus-byte-array-to-string
1088 (method (dbus-byte-array-to-string 1348 (cadddr elt)))
1349 (method (tramp-gvfs-dbus-byte-array-to-string
1089 (cadr (assoc "type" (cadr mount-spec))))) 1350 (cadr (assoc "type" (cadr mount-spec)))))
1090 (user (dbus-byte-array-to-string 1351 (user (tramp-gvfs-dbus-byte-array-to-string
1091 (cadr (assoc "user" (cadr mount-spec))))) 1352 (cadr (assoc "user" (cadr mount-spec)))))
1092 (domain (dbus-byte-array-to-string 1353 (domain (tramp-gvfs-dbus-byte-array-to-string
1093 (cadr (assoc "domain" (cadr mount-spec))))) 1354 (cadr (assoc "domain" (cadr mount-spec)))))
1094 (host (dbus-byte-array-to-string 1355 (host (tramp-gvfs-dbus-byte-array-to-string
1095 (cadr (or (assoc "host" (cadr mount-spec)) 1356 (cadr (or (assoc "host" (cadr mount-spec))
1096 (assoc "server" (cadr mount-spec)))))) 1357 (assoc "server" (cadr mount-spec))))))
1097 (port (dbus-byte-array-to-string 1358 (port (tramp-gvfs-dbus-byte-array-to-string
1098 (cadr (assoc "port" (cadr mount-spec))))) 1359 (cadr (assoc "port" (cadr mount-spec)))))
1099 (ssl (dbus-byte-array-to-string 1360 (ssl (tramp-gvfs-dbus-byte-array-to-string
1100 (cadr (assoc "ssl" (cadr mount-spec))))) 1361 (cadr (assoc "ssl" (cadr mount-spec)))))
1101 (prefix (concat (dbus-byte-array-to-string (car mount-spec)) 1362 (prefix (concat (tramp-gvfs-dbus-byte-array-to-string
1102 (dbus-byte-array-to-string 1363 (car mount-spec))
1364 (tramp-gvfs-dbus-byte-array-to-string
1103 (cadr (assoc "share" (cadr mount-spec))))))) 1365 (cadr (assoc "share" (cadr mount-spec)))))))
1104 (when (string-match "^smb" method) 1366 (when (string-match "^smb" method)
1105 (setq method "smb")) 1367 (setq method "smb"))
@@ -1126,6 +1388,14 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1126 (tramp-set-file-property vec "/" "default-location" default-location) 1388 (tramp-set-file-property vec "/" "default-location" default-location)
1127 (throw 'mounted t))))))) 1389 (throw 'mounted t)))))))
1128 1390
1391(defun tramp-gvfs-mount-spec-entry (key value)
1392 "Construct a mount-spec entry to be used in a mount_spec.
1393It was \"a(say)\", but has changed to \"a{sv})\"."
1394 (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature)
1395 (list :dict-entry key
1396 (list :variant (tramp-gvfs-dbus-string-to-byte-array value)))
1397 (list :struct key (tramp-gvfs-dbus-string-to-byte-array value))))
1398
1129(defun tramp-gvfs-mount-spec (vec) 1399(defun tramp-gvfs-mount-spec (vec)
1130 "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"." 1400 "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"."
1131 (let* ((method (tramp-file-name-method vec)) 1401 (let* ((method (tramp-file-name-method vec))
@@ -1145,38 +1415,32 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1145 (cond 1415 (cond
1146 ((string-equal "smb" method) 1416 ((string-equal "smb" method)
1147 (string-match "^/?\\([^/]+\\)" localname) 1417 (string-match "^/?\\([^/]+\\)" localname)
1148 `((:struct "type" ,(dbus-string-to-byte-array "smb-share")) 1418 (list (tramp-gvfs-mount-spec-entry "type" "smb-share")
1149 (:struct "server" ,(dbus-string-to-byte-array host)) 1419 (tramp-gvfs-mount-spec-entry "server" host)
1150 (:struct "share" ,(dbus-string-to-byte-array 1420 (tramp-gvfs-mount-spec-entry "share" (match-string 1 localname))))
1151 (match-string 1 localname)))))
1152 ((string-equal "obex" method) 1421 ((string-equal "obex" method)
1153 `((:struct "type" ,(dbus-string-to-byte-array method)) 1422 (list (tramp-gvfs-mount-spec-entry "type" method)
1154 (:struct "host" ,(dbus-string-to-byte-array 1423 (tramp-gvfs-mount-spec-entry
1155 (concat "[" (tramp-bluez-address host) "]"))))) 1424 "host" (concat "[" (tramp-bluez-address host) "]"))))
1156 ((string-match "^dav" method) 1425 ((string-match "^dav" method)
1157 `((:struct "type" ,(dbus-string-to-byte-array "dav")) 1426 (list (tramp-gvfs-mount-spec-entry "type" "dav")
1158 (:struct "host" ,(dbus-string-to-byte-array host)) 1427 (tramp-gvfs-mount-spec-entry "host" host)
1159 (:struct "ssl" ,(dbus-string-to-byte-array ssl)))) 1428 (tramp-gvfs-mount-spec-entry "ssl" ssl)))
1160 (t 1429 (t
1161 `((:struct "type" ,(dbus-string-to-byte-array method)) 1430 (list (tramp-gvfs-mount-spec-entry "type" method)
1162 (:struct "host" ,(dbus-string-to-byte-array host))))))) 1431 (tramp-gvfs-mount-spec-entry "host" host))))))
1163 1432
1164 (when user 1433 (when user
1165 (add-to-list 1434 (add-to-list
1166 'mount-spec 1435 'mount-spec (tramp-gvfs-mount-spec-entry "user" user) 'append))
1167 `(:struct "user" ,(dbus-string-to-byte-array user))
1168 'append))
1169 1436
1170 (when domain 1437 (when domain
1171 (add-to-list 1438 (add-to-list
1172 'mount-spec 1439 'mount-spec (tramp-gvfs-mount-spec-entry "domain" domain) 'append))
1173 `(:struct "domain" ,(dbus-string-to-byte-array domain))
1174 'append))
1175 1440
1176 (when port 1441 (when port
1177 (add-to-list 1442 (add-to-list
1178 'mount-spec 1443 'mount-spec (tramp-gvfs-mount-spec-entry "port" (number-to-string port))
1179 `(:struct "port" ,(dbus-string-to-byte-array (number-to-string port)))
1180 'append)) 1444 'append))
1181 1445
1182 (when (and (string-match "^dav" method) 1446 (when (and (string-match "^dav" method)
@@ -1184,7 +1448,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
1184 (setq mount-pref (match-string 0 localname))) 1448 (setq mount-pref (match-string 0 localname)))
1185 1449
1186 ;; Return. 1450 ;; Return.
1187 `(:struct ,(dbus-string-to-byte-array mount-pref) ,mount-spec))) 1451 `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec)))
1188 1452
1189 1453
1190;; Connection functions 1454;; Connection functions
@@ -1201,10 +1465,10 @@ connection if a previous connection has died for some reason."
1201 ;; For password handling, we need a process bound to the connection 1465 ;; For password handling, we need a process bound to the connection
1202 ;; buffer. Therefore, we create a dummy process. Maybe there is a 1466 ;; buffer. Therefore, we create a dummy process. Maybe there is a
1203 ;; better solution? 1467 ;; better solution?
1204 (unless (get-buffer-process (tramp-get-buffer vec)) 1468 (unless (get-buffer-process (tramp-get-connection-buffer vec))
1205 (let ((p (make-network-process 1469 (let ((p (make-network-process
1206 :name (tramp-buffer-name vec) 1470 :name (tramp-buffer-name vec)
1207 :buffer (tramp-get-buffer vec) 1471 :buffer (tramp-get-connection-buffer vec)
1208 :server t :host 'local :service t))) 1472 :server t :host 'local :service t)))
1209 (tramp-compat-set-process-query-on-exit-flag p nil))) 1473 (tramp-compat-set-process-query-on-exit-flag p nil)))
1210 1474
@@ -1212,10 +1476,15 @@ connection if a previous connection has died for some reason."
1212 (let* ((method (tramp-file-name-method vec)) 1476 (let* ((method (tramp-file-name-method vec))
1213 (user (tramp-file-name-user vec)) 1477 (user (tramp-file-name-user vec))
1214 (host (tramp-file-name-host vec)) 1478 (host (tramp-file-name-host vec))
1479 (localname (tramp-file-name-localname vec))
1215 (object-path 1480 (object-path
1216 (tramp-gvfs-object-path 1481 (tramp-gvfs-object-path
1217 (tramp-make-tramp-file-name method user host "")))) 1482 (tramp-make-tramp-file-name method user host ""))))
1218 1483
1484 (when (and (string-equal method "smb")
1485 (string-equal localname "/"))
1486 (tramp-error vec 'file-error "Filename must contain a Windows share"))
1487
1219 (with-tramp-progress-reporter 1488 (with-tramp-progress-reporter
1220 vec 3 1489 vec 3
1221 (if (zerop (length user)) 1490 (if (zerop (length user))
@@ -1231,20 +1500,35 @@ connection if a previous connection has died for some reason."
1231 :session dbus-service-emacs object-path 1500 :session dbus-service-emacs object-path
1232 tramp-gvfs-interface-mountoperation "askPassword" 1501 tramp-gvfs-interface-mountoperation "askPassword"
1233 'tramp-gvfs-handler-askpassword) 1502 'tramp-gvfs-handler-askpassword)
1503 (dbus-register-method
1504 :session dbus-service-emacs object-path
1505 tramp-gvfs-interface-mountoperation "AskPassword"
1506 'tramp-gvfs-handler-askpassword)
1234 1507
1235 ;; There could be a callback of "askQuestion" when adding fingerprint. 1508 ;; There could be a callback of "askQuestion" when adding fingerprint.
1236 (dbus-register-method 1509 (dbus-register-method
1237 :session dbus-service-emacs object-path 1510 :session dbus-service-emacs object-path
1238 tramp-gvfs-interface-mountoperation "askQuestion" 1511 tramp-gvfs-interface-mountoperation "askQuestion"
1239 'tramp-gvfs-handler-askquestion) 1512 'tramp-gvfs-handler-askquestion)
1513 (dbus-register-method
1514 :session dbus-service-emacs object-path
1515 tramp-gvfs-interface-mountoperation "AskQuestion"
1516 'tramp-gvfs-handler-askquestion)
1240 1517
1241 ;; The call must be asynchronously, because of the "askPassword" 1518 ;; The call must be asynchronously, because of the "askPassword"
1242 ;; or "askQuestion"callbacks. 1519 ;; or "askQuestion"callbacks.
1243 (with-tramp-dbus-call-method vec nil 1520 (if (string-match "(so)$" tramp-gvfs-mountlocation-signature)
1244 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker 1521 (with-tramp-dbus-call-method vec nil
1245 tramp-gvfs-interface-mounttracker "mountLocation" 1522 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1246 (tramp-gvfs-mount-spec vec) (dbus-get-unique-name :session) 1523 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1247 :object-path object-path) 1524 (tramp-gvfs-mount-spec vec)
1525 `(:struct :string ,(dbus-get-unique-name :session)
1526 :object-path ,object-path))
1527 (with-tramp-dbus-call-method vec nil
1528 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1529 tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
1530 (tramp-gvfs-mount-spec vec)
1531 :string (dbus-get-unique-name :session) :object-path object-path))
1248 1532
1249 ;; We must wait, until the mount is applied. This will be 1533 ;; We must wait, until the mount is applied. This will be
1250 ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint" 1534 ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint"
@@ -1267,22 +1551,30 @@ connection if a previous connection has died for some reason."
1267 (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/") 1551 (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/")
1268 (tramp-error vec 'file-error "FUSE mount denied")) 1552 (tramp-error vec 'file-error "FUSE mount denied"))
1269 1553
1270 ;; We set the connection property "started" in order to put the 1554 ;; In `tramp-check-cached-permissions', the connection
1271 ;; remote location into the cache, which is helpful for further 1555 ;; properties {uig,gid}-{integer,string} are used. We set
1272 ;; completion. 1556 ;; them to their local counterparts.
1273 (tramp-set-connection-property vec "started" t))))) 1557 (tramp-set-connection-property
1558 vec "uid-integer" (tramp-get-local-uid 'integer))
1559 (tramp-set-connection-property
1560 vec "gid-integer" (tramp-get-local-gid 'integer))
1561 (tramp-set-connection-property
1562 vec "uid-string" (tramp-get-local-uid 'string))
1563 (tramp-set-connection-property
1564 vec "gid-string" (tramp-get-local-gid 'string))))))
1274 1565
1275(defun tramp-gvfs-send-command (vec command &rest args) 1566(defun tramp-gvfs-send-command (vec command &rest args)
1276 "Send the COMMAND with its ARGS to connection VEC. 1567 "Send the COMMAND with its ARGS to connection VEC.
1277COMMAND is usually a command from the gvfs-* utilities. 1568COMMAND is usually a command from the gvfs-* utilities.
1278`call-process' is applied, and its return code is returned." 1569`call-process' is applied, and it returns `t' if the return code is zero."
1279 (let (result) 1570 (let (result)
1280 (with-current-buffer (tramp-get-buffer vec) 1571 (with-current-buffer (tramp-get-connection-buffer vec)
1572 (tramp-gvfs-maybe-open-connection vec)
1281 (erase-buffer) 1573 (erase-buffer)
1282 (tramp-message vec 6 "%s %s" command (mapconcat 'identity args " ")) 1574 (tramp-message vec 6 "%s %s" command (mapconcat 'identity args " "))
1283 (setq result (apply 'tramp-compat-call-process command nil t nil args)) 1575 (setq result (apply 'tramp-compat-call-process command nil t nil args))
1284 (tramp-message vec 6 "%s" (buffer-string)) 1576 (tramp-message vec 6 "\n%s" (buffer-string))
1285 result))) 1577 (zerop result))))
1286 1578
1287 1579
1288;; D-Bus BLUEZ functions. 1580;; D-Bus BLUEZ functions.
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 9dd37fdf63a..e429d176a6e 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -788,25 +788,6 @@ existence, and file readability. Input shall be read via
788here-document, otherwise the command could exceed maximum length 788here-document, otherwise the command could exceed maximum length
789of command line.") 789of command line.")
790 790
791(defconst tramp-file-mode-type-map
792 '((0 . "-") ; Normal file (SVID-v2 and XPG2)
793 (1 . "p") ; fifo
794 (2 . "c") ; character device
795 (3 . "m") ; multiplexed character device (v7)
796 (4 . "d") ; directory
797 (5 . "?") ; Named special file (XENIX)
798 (6 . "b") ; block device
799 (7 . "?") ; multiplexed block device (v7)
800 (8 . "-") ; regular file
801 (9 . "n") ; network special file (HP-UX)
802 (10 . "l") ; symlink
803 (11 . "?") ; ACL shadow inode (Solaris, not userspace)
804 (12 . "s") ; socket
805 (13 . "D") ; door special (Solaris)
806 (14 . "w")) ; whiteout (BSD)
807 "A list of file types returned from the `stat' system call.
808This is used to map a mode number to a permission string.")
809
810;; New handlers should be added here. The following operations can be 791;; New handlers should be added here. The following operations can be
811;; handled using the normal primitives: file-name-sans-versions, 792;; handled using the normal primitives: file-name-sans-versions,
812;; get-file-buffer. 793;; get-file-buffer.
@@ -4654,76 +4635,6 @@ Return ATTR."
4654 (tramp-get-device vec)) 4635 (tramp-get-device vec))
4655 attr)) 4636 attr))
4656 4637
4657(defun tramp-check-cached-permissions (vec access)
4658 "Check `file-attributes' caches for VEC.
4659Return t if according to the cache access type ACCESS is known to
4660be granted."
4661 (let ((result nil)
4662 (offset (cond
4663 ((eq ?r access) 1)
4664 ((eq ?w access) 2)
4665 ((eq ?x access) 3))))
4666 (dolist (suffix '("string" "integer") result)
4667 (setq
4668 result
4669 (or
4670 result
4671 (let ((file-attr
4672 (tramp-get-file-property
4673 vec (tramp-file-name-localname vec)
4674 (concat "file-attributes-" suffix) nil))
4675 (remote-uid
4676 (tramp-get-connection-property
4677 vec (concat "uid-" suffix) nil))
4678 (remote-gid
4679 (tramp-get-connection-property
4680 vec (concat "gid-" suffix) nil)))
4681 (and
4682 file-attr
4683 (or
4684 ;; Not a symlink
4685 (eq t (car file-attr))
4686 (null (car file-attr)))
4687 (or
4688 ;; World accessible.
4689 (eq access (aref (nth 8 file-attr) (+ offset 6)))
4690 ;; User accessible and owned by user.
4691 (and
4692 (eq access (aref (nth 8 file-attr) offset))
4693 (equal remote-uid (nth 2 file-attr)))
4694 ;; Group accessible and owned by user's
4695 ;; principal group.
4696 (and
4697 (eq access (aref (nth 8 file-attr) (+ offset 3)))
4698 (equal remote-gid (nth 3 file-attr)))))))))))
4699
4700(defun tramp-file-mode-from-int (mode)
4701 "Turn an integer representing a file mode into an ls(1)-like string."
4702 (let ((type (cdr
4703 (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map)))
4704 (user (logand (lsh mode -6) 7))
4705 (group (logand (lsh mode -3) 7))
4706 (other (logand (lsh mode -0) 7))
4707 (suid (> (logand (lsh mode -9) 4) 0))
4708 (sgid (> (logand (lsh mode -9) 2) 0))
4709 (sticky (> (logand (lsh mode -9) 1) 0)))
4710 (setq user (tramp-file-mode-permissions user suid "s"))
4711 (setq group (tramp-file-mode-permissions group sgid "s"))
4712 (setq other (tramp-file-mode-permissions other sticky "t"))
4713 (concat type user group other)))
4714
4715(defun tramp-file-mode-permissions (perm suid suid-text)
4716 "Convert a permission bitset into a string.
4717This is used internally by `tramp-file-mode-from-int'."
4718 (let ((r (> (logand perm 4) 0))
4719 (w (> (logand perm 2) 0))
4720 (x (> (logand perm 1) 0)))
4721 (concat (or (and r "r") "-")
4722 (or (and w "w") "-")
4723 (or (and suid x suid-text) ; suid, execute
4724 (and suid (upcase suid-text)) ; suid, !execute
4725 (and x "x") "-")))) ; !suid
4726
4727(defun tramp-shell-case-fold (string) 4638(defun tramp-shell-case-fold (string)
4728 "Converts STRING to shell glob pattern which ignores case." 4639 "Converts STRING to shell glob pattern which ignores case."
4729 (mapconcat 4640 (mapconcat
@@ -4992,14 +4903,6 @@ This is used internally by `tramp-file-mode-from-int'."
4992 ;; The command might not always return a number. 4903 ;; The command might not always return a number.
4993 (if (and (equal id-format 'integer) (not (integerp res))) -1 res)))) 4904 (if (and (equal id-format 'integer) (not (integerp res))) -1 res))))
4994 4905
4995(defun tramp-get-local-uid (id-format)
4996 (if (equal id-format 'integer) (user-uid) (user-login-name)))
4997
4998(defun tramp-get-local-gid (id-format)
4999 (if (and (fboundp 'group-gid) (equal id-format 'integer))
5000 (tramp-compat-funcall 'group-gid)
5001 (nth 3 (tramp-compat-file-attributes "~/" id-format))))
5002
5003;; Some predefined connection properties. 4906;; Some predefined connection properties.
5004(defun tramp-get-inline-compress (vec prop size) 4907(defun tramp-get-inline-compress (vec prop size)
5005 "Return the compress command related to PROP. 4908 "Return the compress command related to PROP.
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index d959cfc854a..dc3dffd857b 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -1505,12 +1505,18 @@ applicable)."
1505 (concat (format "(%d) # " level) fmt-string) 1505 (concat (format "(%d) # " level) fmt-string)
1506 args))))))) 1506 args)))))))
1507 1507
1508(defsubst tramp-backtrace (vec-or-proc)
1509 "Dump a backtrace into the debug buffer.
1510This function is meant for debugging purposes."
1511 (tramp-message vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))))
1512
1508(defsubst tramp-error (vec-or-proc signal fmt-string &rest args) 1513(defsubst tramp-error (vec-or-proc signal fmt-string &rest args)
1509 "Emit an error. 1514 "Emit an error.
1510VEC-OR-PROC identifies the connection to use, SIGNAL is the 1515VEC-OR-PROC identifies the connection to use, SIGNAL is the
1511signal identifier to be raised, remaining args passed to 1516signal identifier to be raised, remaining args passed to
1512`tramp-message'. Finally, signal SIGNAL is raised." 1517`tramp-message'. Finally, signal SIGNAL is raised."
1513 (let (tramp-message-show-message) 1518 (let (tramp-message-show-message)
1519 (tramp-backtrace vec-or-proc)
1514 (tramp-message 1520 (tramp-message
1515 vec-or-proc 1 "%s" 1521 vec-or-proc 1 "%s"
1516 (error-message-string 1522 (error-message-string
@@ -1543,11 +1549,6 @@ an input event arrives. The other arguments are passed to `tramp-error'."
1543 "`M-x tramp-cleanup-this-connection'")) 1549 "`M-x tramp-cleanup-this-connection'"))
1544 (sit-for 30)))))) 1550 (sit-for 30))))))
1545 1551
1546(defsubst tramp-backtrace (vec-or-proc)
1547 "Dump a backtrace into the debug buffer.
1548This function is meant for debugging purposes."
1549 (tramp-message vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))))
1550
1551(defmacro with-parsed-tramp-file-name (filename var &rest body) 1552(defmacro with-parsed-tramp-file-name (filename var &rest body)
1552 "Parse a Tramp filename and make components available in the body. 1553 "Parse a Tramp filename and make components available in the body.
1553 1554
@@ -3660,6 +3661,107 @@ would yield `t'. On the other hand, the following check results in nil:
3660 (t (error "Tenth char `%c' must be one of `xtT-'" 3661 (t (error "Tenth char `%c' must be one of `xtT-'"
3661 other-execute-or-sticky))))))) 3662 other-execute-or-sticky)))))))
3662 3663
3664(defconst tramp-file-mode-type-map
3665 '((0 . "-") ; Normal file (SVID-v2 and XPG2)
3666 (1 . "p") ; fifo
3667 (2 . "c") ; character device
3668 (3 . "m") ; multiplexed character device (v7)
3669 (4 . "d") ; directory
3670 (5 . "?") ; Named special file (XENIX)
3671 (6 . "b") ; block device
3672 (7 . "?") ; multiplexed block device (v7)
3673 (8 . "-") ; regular file
3674 (9 . "n") ; network special file (HP-UX)
3675 (10 . "l") ; symlink
3676 (11 . "?") ; ACL shadow inode (Solaris, not userspace)
3677 (12 . "s") ; socket
3678 (13 . "D") ; door special (Solaris)
3679 (14 . "w")) ; whiteout (BSD)
3680 "A list of file types returned from the `stat' system call.
3681This is used to map a mode number to a permission string.")
3682
3683;;;###tramp-autoload
3684(defun tramp-file-mode-from-int (mode)
3685 "Turn an integer representing a file mode into an ls(1)-like string."
3686 (let ((type (cdr
3687 (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map)))
3688 (user (logand (lsh mode -6) 7))
3689 (group (logand (lsh mode -3) 7))
3690 (other (logand (lsh mode -0) 7))
3691 (suid (> (logand (lsh mode -9) 4) 0))
3692 (sgid (> (logand (lsh mode -9) 2) 0))
3693 (sticky (> (logand (lsh mode -9) 1) 0)))
3694 (setq user (tramp-file-mode-permissions user suid "s"))
3695 (setq group (tramp-file-mode-permissions group sgid "s"))
3696 (setq other (tramp-file-mode-permissions other sticky "t"))
3697 (concat type user group other)))
3698
3699(defun tramp-file-mode-permissions (perm suid suid-text)
3700 "Convert a permission bitset into a string.
3701This is used internally by `tramp-file-mode-from-int'."
3702 (let ((r (> (logand perm 4) 0))
3703 (w (> (logand perm 2) 0))
3704 (x (> (logand perm 1) 0)))
3705 (concat (or (and r "r") "-")
3706 (or (and w "w") "-")
3707 (or (and suid x suid-text) ; suid, execute
3708 (and suid (upcase suid-text)) ; suid, !execute
3709 (and x "x") "-")))) ; !suid
3710
3711;;;###tramp-autoload
3712(defun tramp-get-local-uid (id-format)
3713 (if (equal id-format 'integer) (user-uid) (user-login-name)))
3714
3715;;;###tramp-autoload
3716(defun tramp-get-local-gid (id-format)
3717 (if (and (fboundp 'group-gid) (equal id-format 'integer))
3718 (tramp-compat-funcall 'group-gid)
3719 (nth 3 (tramp-compat-file-attributes "~/" id-format))))
3720
3721;;;###tramp-autoload
3722(defun tramp-check-cached-permissions (vec access)
3723 "Check `file-attributes' caches for VEC.
3724Return t if according to the cache access type ACCESS is known to
3725be granted."
3726 (let ((result nil)
3727 (offset (cond
3728 ((eq ?r access) 1)
3729 ((eq ?w access) 2)
3730 ((eq ?x access) 3))))
3731 (dolist (suffix '("string" "integer") result)
3732 (setq
3733 result
3734 (or
3735 result
3736 (let ((file-attr
3737 (tramp-get-file-property
3738 vec (tramp-file-name-localname vec)
3739 (concat "file-attributes-" suffix) nil))
3740 (remote-uid
3741 (tramp-get-connection-property
3742 vec (concat "uid-" suffix) nil))
3743 (remote-gid
3744 (tramp-get-connection-property
3745 vec (concat "gid-" suffix) nil)))
3746 (and
3747 file-attr
3748 (or
3749 ;; Not a symlink
3750 (eq t (car file-attr))
3751 (null (car file-attr)))
3752 (or
3753 ;; World accessible.
3754 (eq access (aref (nth 8 file-attr) (+ offset 6)))
3755 ;; User accessible and owned by user.
3756 (and
3757 (eq access (aref (nth 8 file-attr) offset))
3758 (equal remote-uid (nth 2 file-attr)))
3759 ;; Group accessible and owned by user's
3760 ;; principal group.
3761 (and
3762 (eq access (aref (nth 8 file-attr) (+ offset 3)))
3763 (equal remote-gid (nth 3 file-attr)))))))))))
3764
3663;;;###tramp-autoload 3765;;;###tramp-autoload
3664(defun tramp-local-host-p (vec) 3766(defun tramp-local-host-p (vec)
3665 "Return t if this points to the local host, nil otherwise." 3767 "Return t if this points to the local host, nil otherwise."