Mercurial > emacs
comparison lisp/net/tramp-gvfs.el @ 108887:2c20a51413cb
* net/tramp-gvfs.el (tramp-gvfs-handle-expand-file-name): Expand "~/".
(tramp-gvfs-handler-mounted-unmounted)
(tramp-gvfs-connection-mounted-p): Handle default-location.
* net/tramp-smb.el (tramp-smb-handle-delete-directory): Don't try to
move files to trash.
author | Michael Albinus <michael.albinus@gmx.de> |
---|---|
date | Fri, 04 Jun 2010 13:26:54 +0200 |
parents | 608a41397301 |
children | 1d46091f1f65 |
comparison
equal
deleted
inserted
replaced
108886:0ed39249e8e4 | 108887:2c20a51413cb |
---|---|
155 "The mount tracking interface in the GVFS daemon.") | 155 "The mount tracking interface in the GVFS daemon.") |
156 | 156 |
157 ;; <interface name='org.gtk.vfs.MountTracker'> | 157 ;; <interface name='org.gtk.vfs.MountTracker'> |
158 ;; <method name='listMounts'> | 158 ;; <method name='listMounts'> |
159 ;; <arg name='mount_info_list' | 159 ;; <arg name='mount_info_list' |
160 ;; type='a{sosssssbay{aya{say}}}' | 160 ;; type='a{sosssssbay{aya{say}}ay}' |
161 ;; direction='out'/> | 161 ;; direction='out'/> |
162 ;; </method> | 162 ;; </method> |
163 ;; <method name='mountLocation'> | 163 ;; <method name='mountLocation'> |
164 ;; <arg name='mount_spec' type='{aya{say}}' direction='in'/> | 164 ;; <arg name='mount_spec' type='{aya{say}}' direction='in'/> |
165 ;; <arg name='dbus_id' type='s' direction='in'/> | 165 ;; <arg name='dbus_id' type='s' direction='in'/> |
166 ;; <arg name='object_path' type='o' direction='in'/> | 166 ;; <arg name='object_path' type='o' direction='in'/> |
167 ;; </method> | 167 ;; </method> |
168 ;; <signal name='mounted'> | 168 ;; <signal name='mounted'> |
169 ;; <arg name='mount_info' | 169 ;; <arg name='mount_info' |
170 ;; type='{sosssssbay{aya{say}}}'/> | 170 ;; type='{sosssssbay{aya{say}}ay}'/> |
171 ;; </signal> | 171 ;; </signal> |
172 ;; <signal name='unmounted'> | 172 ;; <signal name='unmounted'> |
173 ;; <arg name='mount_info' | 173 ;; <arg name='mount_info' |
174 ;; type='{sosssssbay{aya{say}}}'/> | 174 ;; type='{sosssssbay{aya{say}}ay}'/> |
175 ;; </signal> | 175 ;; </signal> |
176 ;; </interface> | 176 ;; </interface> |
177 ;; | 177 ;; |
178 ;; STRUCT mount_info | 178 ;; STRUCT mount_info |
179 ;; STRING dbus_id | 179 ;; STRING dbus_id |
189 ;; ARRAY BYTE mount_prefix | 189 ;; ARRAY BYTE mount_prefix |
190 ;; ARRAY | 190 ;; ARRAY |
191 ;; STRUCT mount_spec_item | 191 ;; STRUCT mount_spec_item |
192 ;; STRING key (server, share, type, user, host, port) | 192 ;; STRING key (server, share, type, user, host, port) |
193 ;; ARRAY BYTE value | 193 ;; ARRAY BYTE value |
194 ;; STRING default_location Since GVFS 1.5 only !!! | 194 ;; ARRAY BYTE default_location Since GVFS 1.5 only !!! |
195 | 195 |
196 (defconst tramp-gvfs-interface-mountoperation "org.gtk.vfs.MountOperation" | 196 (defconst tramp-gvfs-interface-mountoperation "org.gtk.vfs.MountOperation" |
197 "Used by the dbus-proxying implementation of GMountOperation.") | 197 "Used by the dbus-proxying implementation of GMountOperation.") |
198 | 198 |
199 ;; <interface name='org.gtk.vfs.MountOperation'> | 199 ;; <interface name='org.gtk.vfs.MountOperation'> |
606 ;; If NAME is not a Tramp file, run the real handler. | 606 ;; If NAME is not a Tramp file, run the real handler. |
607 (if (not (tramp-tramp-file-p name)) | 607 (if (not (tramp-tramp-file-p name)) |
608 (tramp-run-real-handler 'expand-file-name (list name nil)) | 608 (tramp-run-real-handler 'expand-file-name (list name nil)) |
609 ;; Dissect NAME. | 609 ;; Dissect NAME. |
610 (with-parsed-tramp-file-name name nil | 610 (with-parsed-tramp-file-name name nil |
611 ;; If there is a default location, expand tilde. | |
612 (when (string-match "\\`\\(~\\)\\(/\\|\\'\\)" localname) | |
613 (save-match-data | |
614 (tramp-gvfs-maybe-open-connection (vector method user host "/"))) | |
615 (setq localname | |
616 (replace-match | |
617 (tramp-get-file-property v "/" "default-location" "~") | |
618 nil t localname 1))) | |
611 ;; Tilde expansion is not possible. | 619 ;; Tilde expansion is not possible. |
612 (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) | 620 (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) |
613 (tramp-error | 621 (tramp-error |
614 v 'file-error | 622 v 'file-error |
615 "Cannot expand tilde in file `%s'" name)) | 623 "Cannot expand tilde in file `%s'" name)) |
965 | 973 |
966 (defun tramp-gvfs-handler-mounted-unmounted (mount-info) | 974 (defun tramp-gvfs-handler-mounted-unmounted (mount-info) |
967 "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and | 975 "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and |
968 \"org.gtk.vfs.MountTracker.unmounted\" signals." | 976 \"org.gtk.vfs.MountTracker.unmounted\" signals." |
969 (ignore-errors | 977 (ignore-errors |
970 ;; The last element could be the default location in newer gvfs | 978 (let ((signal-name (dbus-event-member-name last-input-event)) |
971 ;; versions. We must check this. | 979 (elt mount-info)) |
972 (unless (consp (car (last mount-info))) | 980 ;; Jump over the first elements of the mount info. Since there |
973 (setq mount-info (butlast mount-info))) | 981 ;; were changes in the antries, we cannot access dedicated |
974 (let* ((signal-name (dbus-event-member-name last-input-event)) | 982 ;; elements. |
975 (mount-spec (cadar (last mount-info))) | 983 (while (stringp (car elt)) (setq elt (cdr elt))) |
976 (method (dbus-byte-array-to-string (cadr (assoc "type" mount-spec)))) | 984 (let* ((fuse-mountpoint (dbus-byte-array-to-string (cadr elt))) |
977 (user (dbus-byte-array-to-string (cadr (assoc "user" mount-spec)))) | 985 (mount-spec (caddr elt)) |
978 (domain (dbus-byte-array-to-string | 986 (default-location (dbus-byte-array-to-string (cadddr elt))) |
979 (cadr (assoc "domain" mount-spec)))) | 987 (method (dbus-byte-array-to-string |
980 (host (dbus-byte-array-to-string | 988 (cadr (assoc "type" (cadr mount-spec))))) |
981 (cadr (or (assoc "host" mount-spec) | 989 (user (dbus-byte-array-to-string |
982 (assoc "server" mount-spec))))) | 990 (cadr (assoc "user" (cadr mount-spec))))) |
983 (port (dbus-byte-array-to-string (cadr (assoc "port" mount-spec)))) | 991 (domain (dbus-byte-array-to-string |
984 (ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec)))) | 992 (cadr (assoc "domain" (cadr mount-spec))))) |
985 (prefix (concat (dbus-byte-array-to-string (caar (last mount-info))) | 993 (host (dbus-byte-array-to-string |
986 (dbus-byte-array-to-string | 994 (cadr (or (assoc "host" (cadr mount-spec)) |
987 (cadr (assoc "share" mount-spec)))))) | 995 (assoc "server" (cadr mount-spec)))))) |
988 (when (string-match "^smb" method) | 996 (port (dbus-byte-array-to-string |
989 (setq method "smb")) | 997 (cadr (assoc "port" (cadr mount-spec))))) |
990 (when (string-equal "obex" method) | 998 (ssl (dbus-byte-array-to-string |
991 (setq host (tramp-bluez-device host))) | 999 (cadr (assoc "ssl" (cadr mount-spec))))) |
992 (when (and (string-equal "dav" method) (string-equal "true" ssl)) | 1000 (prefix (concat (dbus-byte-array-to-string (car mount-spec)) |
993 (setq method "davs")) | 1001 (dbus-byte-array-to-string |
994 (unless (zerop (length domain)) | 1002 (cadr (assoc "share" (cadr mount-spec))))))) |
995 (setq user (concat user tramp-prefix-domain-format domain))) | 1003 (when (string-match "^smb" method) |
996 (unless (zerop (length port)) | 1004 (setq method "smb")) |
997 (setq host (concat host tramp-prefix-port-format port))) | 1005 (when (string-equal "obex" method) |
998 (with-parsed-tramp-file-name | 1006 (setq host (tramp-bluez-device host))) |
999 (tramp-make-tramp-file-name method user host "") nil | 1007 (when (and (string-equal "dav" method) (string-equal "true" ssl)) |
1000 (tramp-message | 1008 (setq method "davs")) |
1001 v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info)) | 1009 (unless (zerop (length domain)) |
1002 (tramp-set-file-property v "/" "list-mounts" 'undef) | 1010 (setq user (concat user tramp-prefix-domain-format domain))) |
1003 (if (string-equal signal-name "unmounted") | 1011 (unless (zerop (length port)) |
1004 (tramp-set-file-property v "/" "fuse-mountpoint" nil) | 1012 (setq host (concat host tramp-prefix-port-format port))) |
1005 ;; Set prefix and mountpoint. | 1013 (with-parsed-tramp-file-name |
1006 (unless (string-equal prefix "/") | 1014 (tramp-make-tramp-file-name method user host "") nil |
1007 (tramp-set-file-property v "/" "prefix" prefix)) | 1015 (tramp-message |
1008 (tramp-set-file-property | 1016 v 6 "%s %s" |
1009 v "/" "fuse-mountpoint" | 1017 signal-name (tramp-gvfs-stringify-dbus-message mount-info)) |
1010 (dbus-byte-array-to-string (car (last mount-info 2))))))))) | 1018 (tramp-set-file-property v "/" "list-mounts" 'undef) |
1019 (if (string-equal signal-name "unmounted") | |
1020 (tramp-set-file-property v "/" "fuse-mountpoint" nil) | |
1021 ;; Set prefix, mountpoint and location. | |
1022 (unless (string-equal prefix "/") | |
1023 (tramp-set-file-property v "/" "prefix" prefix)) | |
1024 (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint) | |
1025 (tramp-set-file-property | |
1026 v "/" "default-location" default-location))))))) | |
1011 | 1027 |
1012 (dbus-register-signal | 1028 (dbus-register-signal |
1013 :session nil tramp-gvfs-path-mounttracker | 1029 :session nil tramp-gvfs-path-mounttracker |
1014 tramp-gvfs-interface-mounttracker "mounted" | 1030 tramp-gvfs-interface-mounttracker "mounted" |
1015 'tramp-gvfs-handler-mounted-unmounted) | 1031 'tramp-gvfs-handler-mounted-unmounted) |
1029 (with-file-property vec "/" "list-mounts" | 1045 (with-file-property vec "/" "list-mounts" |
1030 (with-tramp-dbus-call-method vec t | 1046 (with-tramp-dbus-call-method vec t |
1031 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker | 1047 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker |
1032 tramp-gvfs-interface-mounttracker "listMounts")) | 1048 tramp-gvfs-interface-mounttracker "listMounts")) |
1033 nil) | 1049 nil) |
1034 ;; The last element could be the default location in newer gvfs | 1050 ;; Jump over the first elements of the mount info. Since there |
1035 ;; versions. We must check this. | 1051 ;; were changes in the antries, we cannot access dedicated |
1036 (unless (consp (car (last elt))) (setq elt (butlast elt))) | 1052 ;; elements. |
1037 (let* ((mount-spec (cadar (last elt))) | 1053 (while (stringp (car elt)) (setq elt (cdr elt))) |
1054 (let* ((fuse-mountpoint (dbus-byte-array-to-string (cadr elt))) | |
1055 (mount-spec (caddr elt)) | |
1056 (default-location (dbus-byte-array-to-string (cadddr elt))) | |
1038 (method (dbus-byte-array-to-string | 1057 (method (dbus-byte-array-to-string |
1039 (cadr (assoc "type" mount-spec)))) | 1058 (cadr (assoc "type" (cadr mount-spec))))) |
1040 (user (dbus-byte-array-to-string | 1059 (user (dbus-byte-array-to-string |
1041 (cadr (assoc "user" mount-spec)))) | 1060 (cadr (assoc "user" (cadr mount-spec))))) |
1042 (domain (dbus-byte-array-to-string | 1061 (domain (dbus-byte-array-to-string |
1043 (cadr (assoc "domain" mount-spec)))) | 1062 (cadr (assoc "domain" (cadr mount-spec))))) |
1044 (host (dbus-byte-array-to-string | 1063 (host (dbus-byte-array-to-string |
1045 (cadr (or (assoc "host" mount-spec) | 1064 (cadr (or (assoc "host" (cadr mount-spec)) |
1046 (assoc "server" mount-spec))))) | 1065 (assoc "server" (cadr mount-spec)))))) |
1047 (port (dbus-byte-array-to-string | 1066 (port (dbus-byte-array-to-string |
1048 (cadr (assoc "port" mount-spec)))) | 1067 (cadr (assoc "port" (cadr mount-spec))))) |
1049 (ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec)))) | 1068 (ssl (dbus-byte-array-to-string |
1050 (prefix (concat (dbus-byte-array-to-string (caar (last elt))) | 1069 (cadr (assoc "ssl" (cadr mount-spec))))) |
1070 (prefix (concat (dbus-byte-array-to-string (car mount-spec)) | |
1051 (dbus-byte-array-to-string | 1071 (dbus-byte-array-to-string |
1052 (cadr (assoc "share" mount-spec)))))) | 1072 (cadr (assoc "share" (cadr mount-spec))))))) |
1053 (when (string-match "^smb" method) | 1073 (when (string-match "^smb" method) |
1054 (setq method "smb")) | 1074 (setq method "smb")) |
1055 (when (string-equal "obex" method) | 1075 (when (string-equal "obex" method) |
1056 (setq host (tramp-bluez-device host))) | 1076 (setq host (tramp-bluez-device host))) |
1057 (when (and (string-equal "dav" method) (string-equal "true" ssl)) | 1077 (when (and (string-equal "dav" method) (string-equal "true" ssl)) |
1066 (string-equal method (tramp-file-name-method vec)) | 1086 (string-equal method (tramp-file-name-method vec)) |
1067 (string-equal user (or (tramp-file-name-user vec) "")) | 1087 (string-equal user (or (tramp-file-name-user vec) "")) |
1068 (string-equal host (tramp-file-name-host vec)) | 1088 (string-equal host (tramp-file-name-host vec)) |
1069 (string-match (concat "^" (regexp-quote prefix)) | 1089 (string-match (concat "^" (regexp-quote prefix)) |
1070 (tramp-file-name-localname vec))) | 1090 (tramp-file-name-localname vec))) |
1071 ;; Set prefix and mountpoint. | 1091 ;; Set prefix, mountpoint and location. |
1072 (unless (string-equal prefix "/") | 1092 (unless (string-equal prefix "/") |
1073 (tramp-set-file-property vec "/" "prefix" prefix)) | 1093 (tramp-set-file-property vec "/" "prefix" prefix)) |
1074 (tramp-set-file-property | 1094 (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint) |
1075 vec "/" "fuse-mountpoint" | 1095 (tramp-set-file-property vec "/" "default-location" default-location) |
1076 (dbus-byte-array-to-string (car (last elt 2)))) | |
1077 (throw 'mounted t))))))) | 1096 (throw 'mounted t))))))) |
1078 | 1097 |
1079 (defun tramp-gvfs-mount-spec (vec) | 1098 (defun tramp-gvfs-mount-spec (vec) |
1080 "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"." | 1099 "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"." |
1081 (let* ((method (tramp-file-name-method vec)) | 1100 (let* ((method (tramp-file-name-method vec)) |