Commit 4f201088 authored by Michael Albinus's avatar Michael Albinus
Browse files

* 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.
parent 18ccd78a
2010-06-04 Michael Albinus <michael.albinus@gmx.de>
* 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.
2010-06-04 Juanma Barranquero <lekktu@gmail.com> 2010-06-04 Juanma Barranquero <lekktu@gmail.com>
   
* international/mule-cmds.el (nonascii-insert-offset) * international/mule-cmds.el (nonascii-insert-offset)
......
...@@ -157,7 +157,7 @@ ...@@ -157,7 +157,7 @@
;; <interface name='org.gtk.vfs.MountTracker'> ;; <interface name='org.gtk.vfs.MountTracker'>
;; <method name='listMounts'> ;; <method name='listMounts'>
;; <arg name='mount_info_list' ;; <arg name='mount_info_list'
;; type='a{sosssssbay{aya{say}}}' ;; type='a{sosssssbay{aya{say}}ay}'
;; direction='out'/> ;; direction='out'/>
;; </method> ;; </method>
;; <method name='mountLocation'> ;; <method name='mountLocation'>
...@@ -167,11 +167,11 @@ ...@@ -167,11 +167,11 @@
;; </method> ;; </method>
;; <signal name='mounted'> ;; <signal name='mounted'>
;; <arg name='mount_info' ;; <arg name='mount_info'
;; type='{sosssssbay{aya{say}}}'/> ;; type='{sosssssbay{aya{say}}ay}'/>
;; </signal> ;; </signal>
;; <signal name='unmounted'> ;; <signal name='unmounted'>
;; <arg name='mount_info' ;; <arg name='mount_info'
;; type='{sosssssbay{aya{say}}}'/> ;; type='{sosssssbay{aya{say}}ay}'/>
;; </signal> ;; </signal>
;; </interface> ;; </interface>
;; ;;
...@@ -191,7 +191,7 @@ ...@@ -191,7 +191,7 @@
;; STRUCT mount_spec_item ;; STRUCT mount_spec_item
;; STRING key (server, share, type, user, host, port) ;; STRING key (server, share, type, user, host, port)
;; ARRAY BYTE value ;; ARRAY BYTE value
;; STRING default_location Since GVFS 1.5 only !!! ;; ARRAY BYTE default_location Since GVFS 1.5 only !!!
(defconst tramp-gvfs-interface-mountoperation "org.gtk.vfs.MountOperation" (defconst tramp-gvfs-interface-mountoperation "org.gtk.vfs.MountOperation"
"Used by the dbus-proxying implementation of GMountOperation.") "Used by the dbus-proxying implementation of GMountOperation.")
...@@ -608,6 +608,14 @@ is no information where to trace the message.") ...@@ -608,6 +608,14 @@ is no information where to trace the message.")
(tramp-run-real-handler 'expand-file-name (list name nil)) (tramp-run-real-handler 'expand-file-name (list name nil))
;; Dissect NAME. ;; Dissect NAME.
(with-parsed-tramp-file-name name nil (with-parsed-tramp-file-name name nil
;; If there is a default location, expand tilde.
(when (string-match "\\`\\(~\\)\\(/\\|\\'\\)" localname)
(save-match-data
(tramp-gvfs-maybe-open-connection (vector method user host "/")))
(setq localname
(replace-match
(tramp-get-file-property v "/" "default-location" "~")
nil t localname 1)))
;; Tilde expansion is not possible. ;; Tilde expansion is not possible.
(when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
(tramp-error (tramp-error
...@@ -967,47 +975,55 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." ...@@ -967,47 +975,55 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
"Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and
\"org.gtk.vfs.MountTracker.unmounted\" signals." \"org.gtk.vfs.MountTracker.unmounted\" signals."
(ignore-errors (ignore-errors
;; The last element could be the default location in newer gvfs (let ((signal-name (dbus-event-member-name last-input-event))
;; versions. We must check this. (elt mount-info))
(unless (consp (car (last mount-info))) ;; Jump over the first elements of the mount info. Since there
(setq mount-info (butlast mount-info))) ;; were changes in the antries, we cannot access dedicated
(let* ((signal-name (dbus-event-member-name last-input-event)) ;; elements.
(mount-spec (cadar (last mount-info))) (while (stringp (car elt)) (setq elt (cdr elt)))
(method (dbus-byte-array-to-string (cadr (assoc "type" mount-spec)))) (let* ((fuse-mountpoint (dbus-byte-array-to-string (cadr elt)))
(user (dbus-byte-array-to-string (cadr (assoc "user" mount-spec)))) (mount-spec (caddr elt))
(domain (dbus-byte-array-to-string (default-location (dbus-byte-array-to-string (cadddr elt)))
(cadr (assoc "domain" mount-spec)))) (method (dbus-byte-array-to-string
(host (dbus-byte-array-to-string (cadr (assoc "type" (cadr mount-spec)))))
(cadr (or (assoc "host" mount-spec) (user (dbus-byte-array-to-string
(assoc "server" mount-spec))))) (cadr (assoc "user" (cadr mount-spec)))))
(port (dbus-byte-array-to-string (cadr (assoc "port" mount-spec)))) (domain (dbus-byte-array-to-string
(ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec)))) (cadr (assoc "domain" (cadr mount-spec)))))
(prefix (concat (dbus-byte-array-to-string (caar (last mount-info))) (host (dbus-byte-array-to-string
(dbus-byte-array-to-string (cadr (or (assoc "host" (cadr mount-spec))
(cadr (assoc "share" mount-spec)))))) (assoc "server" (cadr mount-spec))))))
(when (string-match "^smb" method) (port (dbus-byte-array-to-string
(setq method "smb")) (cadr (assoc "port" (cadr mount-spec)))))
(when (string-equal "obex" method) (ssl (dbus-byte-array-to-string
(setq host (tramp-bluez-device host))) (cadr (assoc "ssl" (cadr mount-spec)))))
(when (and (string-equal "dav" method) (string-equal "true" ssl)) (prefix (concat (dbus-byte-array-to-string (car mount-spec))
(setq method "davs")) (dbus-byte-array-to-string
(unless (zerop (length domain)) (cadr (assoc "share" (cadr mount-spec)))))))
(setq user (concat user tramp-prefix-domain-format domain))) (when (string-match "^smb" method)
(unless (zerop (length port)) (setq method "smb"))
(setq host (concat host tramp-prefix-port-format port))) (when (string-equal "obex" method)
(with-parsed-tramp-file-name (setq host (tramp-bluez-device host)))
(tramp-make-tramp-file-name method user host "") nil (when (and (string-equal "dav" method) (string-equal "true" ssl))
(tramp-message (setq method "davs"))
v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info)) (unless (zerop (length domain))
(tramp-set-file-property v "/" "list-mounts" 'undef) (setq user (concat user tramp-prefix-domain-format domain)))
(if (string-equal signal-name "unmounted") (unless (zerop (length port))
(tramp-set-file-property v "/" "fuse-mountpoint" nil) (setq host (concat host tramp-prefix-port-format port)))
;; Set prefix and mountpoint. (with-parsed-tramp-file-name
(unless (string-equal prefix "/") (tramp-make-tramp-file-name method user host "") nil
(tramp-set-file-property v "/" "prefix" prefix)) (tramp-message
(tramp-set-file-property v 6 "%s %s"
v "/" "fuse-mountpoint" signal-name (tramp-gvfs-stringify-dbus-message mount-info))
(dbus-byte-array-to-string (car (last mount-info 2))))))))) (tramp-set-file-property v "/" "list-mounts" 'undef)
(if (string-equal signal-name "unmounted")
(tramp-set-file-property v "/" "fuse-mountpoint" nil)
;; Set prefix, mountpoint and location.
(unless (string-equal prefix "/")
(tramp-set-file-property v "/" "prefix" prefix))
(tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint)
(tramp-set-file-property
v "/" "default-location" default-location)))))))
(dbus-register-signal (dbus-register-signal
:session nil tramp-gvfs-path-mounttracker :session nil tramp-gvfs-path-mounttracker
...@@ -1031,25 +1047,29 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." ...@@ -1031,25 +1047,29 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
:session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
tramp-gvfs-interface-mounttracker "listMounts")) tramp-gvfs-interface-mounttracker "listMounts"))
nil) nil)
;; The last element could be the default location in newer gvfs ;; Jump over the first elements of the mount info. Since there
;; versions. We must check this. ;; were changes in the antries, we cannot access dedicated
(unless (consp (car (last elt))) (setq elt (butlast elt))) ;; elements.
(let* ((mount-spec (cadar (last elt))) (while (stringp (car elt)) (setq elt (cdr elt)))
(let* ((fuse-mountpoint (dbus-byte-array-to-string (cadr elt)))
(mount-spec (caddr elt))
(default-location (dbus-byte-array-to-string (cadddr elt)))
(method (dbus-byte-array-to-string (method (dbus-byte-array-to-string
(cadr (assoc "type" mount-spec)))) (cadr (assoc "type" (cadr mount-spec)))))
(user (dbus-byte-array-to-string (user (dbus-byte-array-to-string
(cadr (assoc "user" mount-spec)))) (cadr (assoc "user" (cadr mount-spec)))))
(domain (dbus-byte-array-to-string (domain (dbus-byte-array-to-string
(cadr (assoc "domain" mount-spec)))) (cadr (assoc "domain" (cadr mount-spec)))))
(host (dbus-byte-array-to-string (host (dbus-byte-array-to-string
(cadr (or (assoc "host" mount-spec) (cadr (or (assoc "host" (cadr mount-spec))
(assoc "server" mount-spec))))) (assoc "server" (cadr mount-spec))))))
(port (dbus-byte-array-to-string (port (dbus-byte-array-to-string
(cadr (assoc "port" mount-spec)))) (cadr (assoc "port" (cadr mount-spec)))))
(ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec)))) (ssl (dbus-byte-array-to-string
(prefix (concat (dbus-byte-array-to-string (caar (last elt))) (cadr (assoc "ssl" (cadr mount-spec)))))
(prefix (concat (dbus-byte-array-to-string (car mount-spec))
(dbus-byte-array-to-string (dbus-byte-array-to-string
(cadr (assoc "share" mount-spec)))))) (cadr (assoc "share" (cadr mount-spec)))))))
(when (string-match "^smb" method) (when (string-match "^smb" method)
(setq method "smb")) (setq method "smb"))
(when (string-equal "obex" method) (when (string-equal "obex" method)
...@@ -1068,12 +1088,11 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." ...@@ -1068,12 +1088,11 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
(string-equal host (tramp-file-name-host vec)) (string-equal host (tramp-file-name-host vec))
(string-match (concat "^" (regexp-quote prefix)) (string-match (concat "^" (regexp-quote prefix))
(tramp-file-name-localname vec))) (tramp-file-name-localname vec)))
;; Set prefix and mountpoint. ;; Set prefix, mountpoint and location.
(unless (string-equal prefix "/") (unless (string-equal prefix "/")
(tramp-set-file-property vec "/" "prefix" prefix)) (tramp-set-file-property vec "/" "prefix" prefix))
(tramp-set-file-property (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint)
vec "/" "fuse-mountpoint" (tramp-set-file-property vec "/" "default-location" default-location)
(dbus-byte-array-to-string (car (last elt 2))))
(throw 'mounted t))))))) (throw 'mounted t)))))))
(defun tramp-gvfs-mount-spec (vec) (defun tramp-gvfs-mount-spec (vec)
......
...@@ -382,7 +382,7 @@ PRESERVE-UID-GID is completely ignored." ...@@ -382,7 +382,7 @@ PRESERVE-UID-GID is completely ignored."
(lambda (file) (lambda (file)
(if (file-directory-p file) (if (file-directory-p file)
(tramp-compat-delete-directory file recursive) (tramp-compat-delete-directory file recursive)
(tramp-compat-delete-file file 'trash))) (delete-file file)))
;; We do not want to delete "." and "..". ;; We do not want to delete "." and "..".
(directory-files (directory-files
directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"))) directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment