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))