diff options
| author | Michael Albinus | 2013-03-09 12:06:23 +0100 |
|---|---|---|
| committer | Michael Albinus | 2013-03-09 12:06:23 +0100 |
| commit | 3675b1698d0a3a5a8ee09354f2d15e233de8cece (patch) | |
| tree | 959ead3abf3e2f3ce6fc18f676bb4bf60696cebb | |
| parent | 27a98a62d1c46b057428cc3ed964743b69628299 (diff) | |
| download | emacs-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/ChangeLog | 69 | ||||
| -rw-r--r-- | lisp/net/tramp-gvfs.el | 858 | ||||
| -rw-r--r-- | lisp/net/tramp-sh.el | 97 | ||||
| -rw-r--r-- | lisp/net/tramp.el | 112 |
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 @@ | |||
| 1 | 2013-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 | |||
| 1 | 2013-03-09 Stefan Monnier <monnier@iro.umontreal.ca> | 70 | 2013-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. | ||
| 177 | It 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. | ||
| 184 | It 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. | ||
| 191 | It 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. | ||
| 1393 | It 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. |
| 1277 | COMMAND is usually a command from the gvfs-* utilities. | 1568 | COMMAND 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 | |||
| 788 | here-document, otherwise the command could exceed maximum length | 788 | here-document, otherwise the command could exceed maximum length |
| 789 | of command line.") | 789 | of 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. | ||
| 808 | This 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. | ||
| 4659 | Return t if according to the cache access type ACCESS is known to | ||
| 4660 | be 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. | ||
| 4717 | This 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. | ||
| 1510 | This 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. |
| 1510 | VEC-OR-PROC identifies the connection to use, SIGNAL is the | 1515 | VEC-OR-PROC identifies the connection to use, SIGNAL is the |
| 1511 | signal identifier to be raised, remaining args passed to | 1516 | signal 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. | ||
| 1548 | This 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. | ||
| 3681 | This 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. | ||
| 3701 | This 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. | ||
| 3724 | Return t if according to the cache access type ACCESS is known to | ||
| 3725 | be 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." |