Mercurial > emacs

comparison lisp/net/tramp-gvfs.el @ 108863:608a41397301

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
* net/tramp-gvfs.el (top): Require url-util. (tramp-gvfs-mount-point): Removed. (tramp-gvfs-stringify-dbus-message, tramp-gvfs-send-command): New defuns. (with-tramp-dbus-call-method): Format trace message. (tramp-gvfs-handle-copy-file, tramp-gvfs-handle-rename-file): Implement backup call, when operation on local files fails. Use progress reporter. Flush properties of changed files. (tramp-gvfs-handle-make-directory): Make more traces. (tramp-gvfs-url-file-name): Hexify file name in url. (tramp-gvfs-fuse-file-name): Take also prefix (like dav shares) into account for the resulting file name. (tramp-gvfs-handler-askquestion): Return dummy mountpoint, when the answer is "no". See `tramp-gvfs-maybe-open-connection'. (tramp-gvfs-handler-mounted-unmounted) (tramp-gvfs-connection-mounted-p): Test also for new mountspec attribute "default_location". Set "prefix" property. (tramp-gvfs-mount-spec): Return both prefix and mountspec. (tramp-gvfs-maybe-open-connection): Test, whether mountpoint exists. Raise an error, if not (due to a corresponding answer "no" in interactive questions, for example).
author Michael Albinus <michael.albinus@gmx.de>
date Wed, 02 Jun 2010 11:53:00 +0200
parents 94d1d8a6dcfd
children 2c20a51413cb
comparison
equal deleted inserted replaced
108862:da77a7326f79 108863:608a41397301
25 ;; Access functions for the GVFS daemon from Tramp. Tested with GVFS 25 ;; Access functions for the GVFS daemon from Tramp. Tested with GVFS
26 ;; 1.0.2 (Ubuntu 8.10, Gnome 2.24). It has been reported also to run 26 ;; 1.0.2 (Ubuntu 8.10, Gnome 2.24). It has been reported also to run
27 ;; with GVFS 0.2.5 (Ubuntu 8.04, Gnome 2.22), but there is an 27 ;; with GVFS 0.2.5 (Ubuntu 8.04, Gnome 2.22), but there is an
28 ;; incompatibility with the mount_info structure, which has been 28 ;; incompatibility with the mount_info structure, which has been
29 ;; worked around. 29 ;; worked around.
30
31 ;; It has also been tested with GVFS 1.6.2 (Ubuntu 10.04, Gnome 2.30),
32 ;; where the default_location has been added to mount_info (see
33 ;; <https://bugzilla.gnome.org/show_bug.cgi?id=561998>.
30 34
31 ;; All actions to mount a remote location, and to retrieve mount 35 ;; All actions to mount a remote location, and to retrieve mount
32 ;; information, are performed by D-Bus messages. File operations 36 ;; information, are performed by D-Bus messages. File operations
33 ;; themselves are performed via the mounted filesystem in ~/.gvfs. 37 ;; themselves are performed via the mounted filesystem in ~/.gvfs.
34 ;; Consequently, GNU Emacs 23.1 with enabled D-Bus bindings is a 38 ;; Consequently, GNU Emacs 23.1 with enabled D-Bus bindings is a
98 (require 'custom)) 102 (require 'custom))
99 103
100 (require 'tramp) 104 (require 'tramp)
101 (require 'dbus) 105 (require 'dbus)
102 (require 'url-parse) 106 (require 'url-parse)
107 (require 'url-util)
103 (require 'zeroconf) 108 (require 'zeroconf)
104 109
105 (defcustom tramp-gvfs-methods '("dav" "davs" "obex" "synce") 110 (defcustom tramp-gvfs-methods '("dav" "davs" "obex" "synce")
106 "*List of methods for remote files, accessed with GVFS." 111 "*List of methods for remote files, accessed with GVFS."
107 :group 'tramp 112 :group 'tramp
130 (eval-after-load "tramp-gvfs" 135 (eval-after-load "tramp-gvfs"
131 '(when (featurep 'tramp-gvfs) 136 '(when (featurep 'tramp-gvfs)
132 (dolist (elt tramp-gvfs-methods) 137 (dolist (elt tramp-gvfs-methods)
133 (unless (assoc elt tramp-methods) 138 (unless (assoc elt tramp-methods)
134 (add-to-list 'tramp-methods (cons elt nil)))))) 139 (add-to-list 'tramp-methods (cons elt nil))))))
135
136 (defconst tramp-gvfs-mount-point
137 (file-name-as-directory (expand-file-name ".gvfs" "~/"))
138 "The directory name, fuses mounts remote ressources.")
139 140
140 (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp") 141 (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp")
141 "The preceeding object path for own objects.") 142 "The preceeding object path for own objects.")
142 143
143 (defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon" 144 (defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon"
188 ;; ARRAY BYTE mount_prefix 189 ;; ARRAY BYTE mount_prefix
189 ;; ARRAY 190 ;; ARRAY
190 ;; STRUCT mount_spec_item 191 ;; STRUCT mount_spec_item
191 ;; STRING key (server, share, type, user, host, port) 192 ;; STRING key (server, share, type, user, host, port)
192 ;; ARRAY BYTE value 193 ;; ARRAY BYTE value
194 ;; STRING default_location Since GVFS 1.5 only !!!
193 195
194 (defconst tramp-gvfs-interface-mountoperation "org.gtk.vfs.MountOperation" 196 (defconst tramp-gvfs-interface-mountoperation "org.gtk.vfs.MountOperation"
195 "Used by the dbus-proxying implementation of GMountOperation.") 197 "Used by the dbus-proxying implementation of GMountOperation.")
196 198
197 ;; <interface name='org.gtk.vfs.MountOperation'> 199 ;; <interface name='org.gtk.vfs.MountOperation'>
447 ;; This might be moved to tramp.el. It shall be the first file name 449 ;; This might be moved to tramp.el. It shall be the first file name
448 ;; handler. 450 ;; handler.
449 (add-to-list 'tramp-foreign-file-name-handler-alist 451 (add-to-list 'tramp-foreign-file-name-handler-alist
450 (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler)) 452 (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler))
451 453
454 (defun tramp-gvfs-stringify-dbus-message (message)
455 "Convert a D-Bus message into readable UTF8 strings, used for traces."
456 (cond
457 ((and (consp message) (characterp (car message)))
458 (format "%S" (dbus-byte-array-to-string message)))
459 ((consp message)
460 (mapcar 'tramp-gvfs-stringify-dbus-message message))
461 ((stringp message)
462 (format "%S" message))
463 (t message)))
464
452 (defmacro with-tramp-dbus-call-method 465 (defmacro with-tramp-dbus-call-method
453 (vec synchronous bus service path interface method &rest args) 466 (vec synchronous bus service path interface method &rest args)
454 "Apply a D-Bus call on bus BUS. 467 "Apply a D-Bus call on bus BUS.
455 468
456 If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise, 469 If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise,
464 (args (append (list ,bus ,service ,path ,interface ,method) 477 (args (append (list ,bus ,service ,path ,interface ,method)
465 (if ,synchronous (list ,@args) (list 'ignore ,@args)))) 478 (if ,synchronous (list ,@args) (list 'ignore ,@args))))
466 result) 479 result)
467 (tramp-message ,vec 6 "%s %s" func args) 480 (tramp-message ,vec 6 "%s %s" func args)
468 (setq result (apply func args)) 481 (setq result (apply func args))
469 (tramp-message ,vec 6 "\n%s" result) 482 (tramp-message ,vec 6 "%s" (tramp-gvfs-stringify-dbus-message result))
470 result)) 483 result))
471 484
472 (put 'with-tramp-dbus-call-method 'lisp-indent-function 2) 485 (put 'with-tramp-dbus-call-method 'lisp-indent-function 2)
473 (put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body)) 486 (put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body))
474 (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) 487 (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>"))
478 In case of an error, modify the error message by replacing 491 In case of an error, modify the error message by replacing
479 `filename' with its GVFS mounted name." 492 `filename' with its GVFS mounted name."
480 `(let ((fuse-file-name (regexp-quote (tramp-gvfs-fuse-file-name ,filename))) 493 `(let ((fuse-file-name (regexp-quote (tramp-gvfs-fuse-file-name ,filename)))
481 elt) 494 elt)
482 (condition-case err 495 (condition-case err
483 (apply ,handler (list ,@args)) 496 (funcall ,handler ,@args)
484 (error 497 (error
485 (setq elt (cdr err)) 498 (setq elt (cdr err))
486 (while elt 499 (while elt
487 (when (and (stringp (car elt)) 500 (when (and (stringp (car elt))
488 (string-match fuse-file-name (car elt))) 501 (string-match fuse-file-name (car elt)))
513 526
514 (defun tramp-gvfs-handle-copy-file 527 (defun tramp-gvfs-handle-copy-file
515 (filename newname &optional ok-if-already-exists keep-date 528 (filename newname &optional ok-if-already-exists keep-date
516 preserve-uid-gid preserve-selinux-context) 529 preserve-uid-gid preserve-selinux-context)
517 "Like `copy-file' for Tramp files." 530 "Like `copy-file' for Tramp files."
518 (let ((args 531 (with-parsed-tramp-file-name
519 (list 532 (if (tramp-tramp-file-p filename) filename newname) nil
520 (if (tramp-gvfs-file-name-p filename) 533 (with-progress-reporter
521 (tramp-gvfs-fuse-file-name filename) 534 v 0 (format "Copying %s to %s" filename newname)
522 filename) 535 (condition-case err
523 (if (tramp-gvfs-file-name-p newname) 536 (let ((args
524 (tramp-gvfs-fuse-file-name newname) 537 (list
525 newname) 538 (if (tramp-gvfs-file-name-p filename)
526 ok-if-already-exists keep-date preserve-uid-gid))) 539 (tramp-gvfs-fuse-file-name filename)
527 (when preserve-selinux-context 540 filename)
528 (setq args (append args (list preserve-selinux-context)))) 541 (if (tramp-gvfs-file-name-p newname)
529 (apply 'copy-file args))) 542 (tramp-gvfs-fuse-file-name newname)
543 newname)
544 ok-if-already-exists keep-date preserve-uid-gid)))
545 (when preserve-selinux-context
546 (setq args (append args (list preserve-selinux-context))))
547 (apply 'copy-file args))
548
549 ;; Error case. Let's try it with the GVFS utilities.
550 (error
551 (tramp-message v 4 "`copy-file' failed, trying `gvfs-copy'")
552 (unless
553 (zerop
554 (tramp-gvfs-send-command
555 v "gvfs-copy"
556 (if (or keep-date preserve-uid-gid) "--preserve" "")
557 (tramp-gvfs-url-file-name filename)
558 (tramp-gvfs-url-file-name newname)))
559 ;; Propagate the error.
560 (tramp-error v (car err) "%s" (cdr err)))))))
561
562 (when (file-remote-p newname)
563 (with-parsed-tramp-file-name newname nil
564 (tramp-flush-file-property v (file-name-directory localname))
565 (tramp-flush-file-property v localname))))
530 566
531 (defun tramp-gvfs-handle-delete-directory (directory &optional recursive) 567 (defun tramp-gvfs-handle-delete-directory (directory &optional recursive)
532 "Like `delete-directory' for Tramp files." 568 "Like `delete-directory' for Tramp files."
533 (tramp-compat-delete-directory 569 (tramp-compat-delete-directory
534 (tramp-gvfs-fuse-file-name directory) recursive)) 570 (tramp-gvfs-fuse-file-name directory) recursive))
655 result) 691 result)
656 (setq buffer-file-name filename))) 692 (setq buffer-file-name filename)))
657 693
658 (defun tramp-gvfs-handle-make-directory (dir &optional parents) 694 (defun tramp-gvfs-handle-make-directory (dir &optional parents)
659 "Like `make-directory' for Tramp files." 695 "Like `make-directory' for Tramp files."
660 (condition-case err 696 (with-parsed-tramp-file-name dir nil
661 (with-tramp-gvfs-error-message dir 'make-directory 697 (condition-case err
662 (tramp-gvfs-fuse-file-name dir) parents) 698 (with-tramp-gvfs-error-message dir 'make-directory
663 ;; Error case. Let's try it with the GVFS utilities. 699 (tramp-gvfs-fuse-file-name dir) parents)
664 (error 700
665 (with-parsed-tramp-file-name dir nil 701 ;; Error case. Let's try it with the GVFS utilities.
702 (error
666 (tramp-message v 4 "`make-directory' failed, trying `gvfs-mkdir'") 703 (tramp-message v 4 "`make-directory' failed, trying `gvfs-mkdir'")
667 (unless 704 (unless
668 (zerop 705 (zerop
669 (tramp-local-call-process 706 (tramp-gvfs-send-command
670 "gvfs-mkdir" nil (tramp-get-buffer v) nil 707 v "gvfs-mkdir" (tramp-gvfs-url-file-name dir)))
671 (tramp-gvfs-url-file-name dir))) 708 ;; Propagate the error.
672 (signal (car err) (cdr err))))))) 709 (tramp-error v (car err) "%s" (cdr err)))))))
673 710
674 (defun tramp-gvfs-handle-process-file 711 (defun tramp-gvfs-handle-process-file
675 (program &optional infile destination display &rest args) 712 (program &optional infile destination display &rest args)
676 "Like `process-file' for Tramp files." 713 "Like `process-file' for Tramp files."
677 (let ((default-directory (tramp-gvfs-fuse-file-name default-directory))) 714 (let ((default-directory (tramp-gvfs-fuse-file-name default-directory)))
678 (apply 'call-process program infile destination display args))) 715 (apply 'call-process program infile destination display args)))
679 716
680 (defun tramp-gvfs-handle-rename-file 717 (defun tramp-gvfs-handle-rename-file
681 (filename newname &optional ok-if-already-exists) 718 (filename newname &optional ok-if-already-exists)
682 "Like `rename-file' for Tramp files." 719 "Like `rename-file' for Tramp files."
683 (rename-file 720 (with-parsed-tramp-file-name
684 (if (tramp-gvfs-file-name-p filename) 721 (if (tramp-tramp-file-p filename) filename newname) nil
685 (tramp-gvfs-fuse-file-name filename) 722 (with-progress-reporter
686 filename) 723 v 0 (format "Renaming %s to %s" filename newname)
687 (if (tramp-gvfs-file-name-p newname) 724 (condition-case err
688 (tramp-gvfs-fuse-file-name newname) 725 (rename-file
689 newname) 726 (if (tramp-gvfs-file-name-p filename)
690 ok-if-already-exists)) 727 (tramp-gvfs-fuse-file-name filename)
728 filename)
729 (if (tramp-gvfs-file-name-p newname)
730 (tramp-gvfs-fuse-file-name newname)
731 newname)
732 ok-if-already-exists)
733
734 ;; Error case. Let's try it with the GVFS utilities.
735 (error
736 (tramp-message v 4 "`rename-file' failed, trying `gvfs-move'")
737 (unless
738 (zerop
739 (tramp-gvfs-send-command
740 v "gvfs-move"
741 (tramp-gvfs-url-file-name filename)
742 (tramp-gvfs-url-file-name newname)))
743 ;; Propagate the error.
744 (tramp-error v (car err) "%s" (cdr err)))))))
745
746 (when (file-remote-p filename)
747 (with-parsed-tramp-file-name filename nil
748 (tramp-flush-file-property v (file-name-directory localname))
749 (tramp-flush-file-property v localname)))
750
751 (when (file-remote-p newname)
752 (with-parsed-tramp-file-name newname nil
753 (tramp-flush-file-property v (file-name-directory localname))
754 (tramp-flush-file-property v localname))))
691 755
692 (defun tramp-gvfs-handle-set-file-modes (filename mode) 756 (defun tramp-gvfs-handle-set-file-modes (filename mode)
693 "Like `set-file-modes' for Tramp files." 757 "Like `set-file-modes' for Tramp files."
694 (with-tramp-gvfs-error-message filename 'set-file-modes 758 (with-tramp-gvfs-error-message filename 'set-file-modes
695 (tramp-gvfs-fuse-file-name filename) mode)) 759 (tramp-gvfs-fuse-file-name filename) mode))
728 (condition-case err 792 (condition-case err
729 (with-tramp-gvfs-error-message filename 'write-region 793 (with-tramp-gvfs-error-message filename 'write-region
730 start end (tramp-gvfs-fuse-file-name filename) 794 start end (tramp-gvfs-fuse-file-name filename)
731 append visit lockname confirm) 795 append visit lockname confirm)
732 796
733 ;; Error case. Let's try it with the GVFS utilities. 797 ;; Error case. Let's try rename.
734 (error 798 (error
735 (let ((tmpfile (tramp-compat-make-temp-file filename))) 799 (let ((tmpfile (tramp-compat-make-temp-file filename)))
736 (tramp-message v 4 "`write-region' failed, trying `gvfs-save'") 800 (tramp-message v 4 "`write-region' failed, trying `rename-file'")
737 (write-region start end tmpfile) 801 (write-region start end tmpfile)
738 (unwind-protect 802 (condition-case nil
739 (unless 803 (rename-file tmpfile filename)
740 (zerop 804 (error
741 (tramp-local-call-process 805 (delete-file tmpfile)
742 "gvfs-save" tmpfile (tramp-get-buffer v) nil 806 (tramp-error v (car err) "%s" (cdr err)))))))
743 (tramp-gvfs-url-file-name filename)))
744 (signal (car err) (cdr err)))
745 (delete-file tmpfile)))))
746 807
747 ;; Set file modification time. 808 ;; Set file modification time.
748 (when (or (eq visit t) (stringp visit)) 809 (when (or (eq visit t) (stringp visit))
749 (set-visited-file-modtime (nth 5 (file-attributes filename)))) 810 (set-visited-file-modtime (nth 5 (file-attributes filename))))
750 811
756 817
757 ;; File name conversions. 818 ;; File name conversions.
758 819
759 (defun tramp-gvfs-url-file-name (filename) 820 (defun tramp-gvfs-url-file-name (filename)
760 "Return FILENAME in URL syntax." 821 "Return FILENAME in URL syntax."
761 (url-recreate-url 822 ;; "/" must NOT be hexlified.
762 (if (tramp-tramp-file-p filename) 823 (let ((url-unreserved-chars (append '(?/) url-unreserved-chars)))
763 (with-parsed-tramp-file-name (file-truename filename) nil 824 (url-recreate-url
764 (when (string-match tramp-user-with-domain-regexp user) 825 (if (tramp-tramp-file-p filename)
765 (setq user 826 (with-parsed-tramp-file-name (file-truename filename) nil
766 (concat (match-string 2 user) ";" (match-string 2 user)))) 827 (when (string-match tramp-user-with-domain-regexp user)
767 (url-parse-make-urlobj 828 (setq user
768 method user nil 829 (concat (match-string 2 user) ";" (match-string 2 user))))
769 (tramp-file-name-real-host v) (tramp-file-name-port v) localname)) 830 (url-parse-make-urlobj
770 (url-parse-make-urlobj "file" nil nil nil nil (file-truename filename))))) 831 method user nil
832 (tramp-file-name-real-host v) (tramp-file-name-port v)
833 (url-hexify-string localname)))
834 (url-parse-make-urlobj
835 "file" nil nil nil nil (url-hexify-string (file-truename filename)))))))
771 836
772 (defun tramp-gvfs-object-path (filename) 837 (defun tramp-gvfs-object-path (filename)
773 "Create a D-Bus object path from FILENAME." 838 "Create a D-Bus object path from FILENAME."
774 (expand-file-name (dbus-escape-as-identifier filename) tramp-gvfs-path-tramp)) 839 (expand-file-name (dbus-escape-as-identifier filename) tramp-gvfs-path-tramp))
775 840
780 845
781 (defun tramp-gvfs-fuse-file-name (filename) 846 (defun tramp-gvfs-fuse-file-name (filename)
782 "Return FUSE file name, which is directly accessible." 847 "Return FUSE file name, which is directly accessible."
783 (with-parsed-tramp-file-name (expand-file-name filename) nil 848 (with-parsed-tramp-file-name (expand-file-name filename) nil
784 (tramp-gvfs-maybe-open-connection v) 849 (tramp-gvfs-maybe-open-connection v)
785 (let ((fuse-mountpoint 850 (let ((prefix (tramp-get-file-property v "/" "prefix" ""))
851 (fuse-mountpoint
786 (tramp-get-file-property v "/" "fuse-mountpoint" nil))) 852 (tramp-get-file-property v "/" "fuse-mountpoint" nil)))
787 (unless fuse-mountpoint 853 (unless fuse-mountpoint
788 (tramp-error 854 (tramp-error
789 v 'file-error "There is no FUSE mount point for `%s'" filename)) 855 v 'file-error "There is no FUSE mount point for `%s'" filename))
790 ;; We must remove the share from the local name. 856 ;; We must hide the prefix, if any.
791 (when (and (string-equal "smb" method) (string-match "/[^/]+" localname)) 857 (when (string-match (concat "^" (regexp-quote prefix)) localname)
792 (setq localname (replace-match "" t t localname))) 858 (setq localname (replace-match "" t t localname)))
793 (concat tramp-gvfs-mount-point fuse-mountpoint localname)))) 859 (tramp-message
860 v 10 "remote file `%s' is local file `%s'"
861 filename (concat fuse-mountpoint localname))
862 (concat fuse-mountpoint localname))))
794 863
795 (defun tramp-bluez-address (device) 864 (defun tramp-bluez-address (device)
796 "Return bluetooth device address from a given bluetooth DEVICE name." 865 "Return bluetooth device address from a given bluetooth DEVICE name."
797 (when (stringp device) 866 (when (stringp device)
798 (if (string-match tramp-ipv6-regexp device) 867 (if (string-match tramp-ipv6-regexp device)
879 (insert message) 948 (insert message)
880 (pop-to-buffer (current-buffer)) 949 (pop-to-buffer (current-buffer))
881 (setq choice (if (yes-or-no-p (concat (car choices) " ")) 0 1)) 950 (setq choice (if (yes-or-no-p (concat (car choices) " ")) 0 1))
882 (tramp-message v 6 "%d" choice))) 951 (tramp-message v 6 "%d" choice)))
883 952
884 ;; When the choice is "no", we set an empty 953 ;; When the choice is "no", we set a dummy fuse-mountpoint
885 ;; fuse-mountpoint in order to leave the timeout. 954 ;; in order to leave the timeout.
886 (unless (zerop choice) 955 (unless (zerop choice)
887 (tramp-set-file-property v "/" "fuse-mountpoint" "")) 956 (tramp-set-file-property v "/" "fuse-mountpoint" "/"))
888 957
889 (list 958 (list
890 t ;; handled. 959 t ;; handled.
891 nil ;; no abort of D-Bus. 960 nil ;; no abort of D-Bus.
892 choice)) 961 choice))
896 965
897 (defun tramp-gvfs-handler-mounted-unmounted (mount-info) 966 (defun tramp-gvfs-handler-mounted-unmounted (mount-info)
898 "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and 967 "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and
899 \"org.gtk.vfs.MountTracker.unmounted\" signals." 968 \"org.gtk.vfs.MountTracker.unmounted\" signals."
900 (ignore-errors 969 (ignore-errors
970 ;; The last element could be the default location in newer gvfs
971 ;; versions. We must check this.
972 (unless (consp (car (last mount-info)))
973 (setq mount-info (butlast mount-info)))
901 (let* ((signal-name (dbus-event-member-name last-input-event)) 974 (let* ((signal-name (dbus-event-member-name last-input-event))
902 (mount-spec (cadar (last mount-info))) 975 (mount-spec (cadar (last mount-info)))
903 (method (dbus-byte-array-to-string (cadr (assoc "type" mount-spec)))) 976 (method (dbus-byte-array-to-string (cadr (assoc "type" mount-spec))))
904 (user (dbus-byte-array-to-string (cadr (assoc "user" mount-spec)))) 977 (user (dbus-byte-array-to-string (cadr (assoc "user" mount-spec))))
905 (domain (dbus-byte-array-to-string 978 (domain (dbus-byte-array-to-string
906 (cadr (assoc "domain" mount-spec)))) 979 (cadr (assoc "domain" mount-spec))))
907 (host (dbus-byte-array-to-string 980 (host (dbus-byte-array-to-string
908 (cadr (or (assoc "host" mount-spec) 981 (cadr (or (assoc "host" mount-spec)
909 (assoc "server" mount-spec))))) 982 (assoc "server" mount-spec)))))
910 (port (dbus-byte-array-to-string (cadr (assoc "port" mount-spec)))) 983 (port (dbus-byte-array-to-string (cadr (assoc "port" mount-spec))))
911 (ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec))))) 984 (ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec))))
985 (prefix (concat (dbus-byte-array-to-string (caar (last mount-info)))
986 (dbus-byte-array-to-string
987 (cadr (assoc "share" mount-spec))))))
912 (when (string-match "^smb" method) 988 (when (string-match "^smb" method)
913 (setq method "smb")) 989 (setq method "smb"))
914 (when (string-equal "obex" method) 990 (when (string-equal "obex" method)
915 (setq host (tramp-bluez-device host))) 991 (setq host (tramp-bluez-device host)))
916 (when (and (string-equal "dav" method) (string-equal "true" ssl)) 992 (when (and (string-equal "dav" method) (string-equal "true" ssl))
919 (setq user (concat user tramp-prefix-domain-format domain))) 995 (setq user (concat user tramp-prefix-domain-format domain)))
920 (unless (zerop (length port)) 996 (unless (zerop (length port))
921 (setq host (concat host tramp-prefix-port-format port))) 997 (setq host (concat host tramp-prefix-port-format port)))
922 (with-parsed-tramp-file-name 998 (with-parsed-tramp-file-name
923 (tramp-make-tramp-file-name method user host "") nil 999 (tramp-make-tramp-file-name method user host "") nil
924 (tramp-message v 6 "%s %s" signal-name mount-info) 1000 (tramp-message
1001 v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info))
925 (tramp-set-file-property v "/" "list-mounts" 'undef) 1002 (tramp-set-file-property v "/" "list-mounts" 'undef)
926 (if (string-equal signal-name "unmounted") 1003 (if (string-equal signal-name "unmounted")
927 (tramp-set-file-property v "/" "fuse-mountpoint" nil) 1004 (tramp-set-file-property v "/" "fuse-mountpoint" nil)
1005 ;; Set prefix and mountpoint.
1006 (unless (string-equal prefix "/")
1007 (tramp-set-file-property v "/" "prefix" prefix))
928 (tramp-set-file-property 1008 (tramp-set-file-property
929 v "/" "fuse-mountpoint" 1009 v "/" "fuse-mountpoint"
930 (file-name-nondirectory 1010 (dbus-byte-array-to-string (car (last mount-info 2)))))))))
931 (dbus-byte-array-to-string (car (last mount-info 2))))))))))
932 1011
933 (dbus-register-signal 1012 (dbus-register-signal
934 :session nil tramp-gvfs-path-mounttracker 1013 :session nil tramp-gvfs-path-mounttracker
935 tramp-gvfs-interface-mounttracker "mounted" 1014 tramp-gvfs-interface-mounttracker "mounted"
936 'tramp-gvfs-handler-mounted-unmounted) 1015 'tramp-gvfs-handler-mounted-unmounted)
940 tramp-gvfs-interface-mounttracker "unmounted" 1019 tramp-gvfs-interface-mounttracker "unmounted"
941 'tramp-gvfs-handler-mounted-unmounted) 1020 'tramp-gvfs-handler-mounted-unmounted)
942 1021
943 (defun tramp-gvfs-connection-mounted-p (vec) 1022 (defun tramp-gvfs-connection-mounted-p (vec)
944 "Check, whether the location is already mounted." 1023 "Check, whether the location is already mounted."
945 (catch 'mounted 1024 (or
946 (dolist 1025 (tramp-get-file-property vec "/" "fuse-mountpoint" nil)
947 (elt 1026 (catch 'mounted
948 (with-file-property vec "/" "list-mounts" 1027 (dolist
949 (with-tramp-dbus-call-method vec t 1028 (elt
950 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker 1029 (with-file-property vec "/" "list-mounts"
951 tramp-gvfs-interface-mounttracker "listMounts")) 1030 (with-tramp-dbus-call-method vec t
952 nil) 1031 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
953 (let* ((mount-spec (cadar (last elt))) 1032 tramp-gvfs-interface-mounttracker "listMounts"))
954 (method (dbus-byte-array-to-string 1033 nil)
955 (cadr (assoc "type" mount-spec)))) 1034 ;; The last element could be the default location in newer gvfs
956 (user (dbus-byte-array-to-string 1035 ;; versions. We must check this.
957 (cadr (assoc "user" mount-spec)))) 1036 (unless (consp (car (last elt))) (setq elt (butlast elt)))
958 (domain (dbus-byte-array-to-string 1037 (let* ((mount-spec (cadar (last elt)))
959 (cadr (assoc "domain" mount-spec)))) 1038 (method (dbus-byte-array-to-string
960 (host (dbus-byte-array-to-string 1039 (cadr (assoc "type" mount-spec))))
961 (cadr (or (assoc "host" mount-spec) 1040 (user (dbus-byte-array-to-string
962 (assoc "server" mount-spec))))) 1041 (cadr (assoc "user" mount-spec))))
963 (port (dbus-byte-array-to-string (cadr (assoc "port" mount-spec)))) 1042 (domain (dbus-byte-array-to-string
964 (ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec))))) 1043 (cadr (assoc "domain" mount-spec))))
965 (when (string-match "^smb" method) 1044 (host (dbus-byte-array-to-string
966 (setq method "smb")) 1045 (cadr (or (assoc "host" mount-spec)
967 (when (string-equal "obex" method) 1046 (assoc "server" mount-spec)))))
968 (setq host (tramp-bluez-device host))) 1047 (port (dbus-byte-array-to-string
969 (when (and (string-equal "dav" method) (string-equal "true" ssl)) 1048 (cadr (assoc "port" mount-spec))))
970 (setq method "davs")) 1049 (ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec))))
971 (when (and (string-equal "synce" method) (zerop (length user))) 1050 (prefix (concat (dbus-byte-array-to-string (caar (last elt)))
972 (setq user (or (tramp-file-name-user vec) ""))) 1051 (dbus-byte-array-to-string
973 (unless (zerop (length domain)) 1052 (cadr (assoc "share" mount-spec))))))
974 (setq user (concat user tramp-prefix-domain-format domain))) 1053 (when (string-match "^smb" method)
975 (unless (zerop (length port)) 1054 (setq method "smb"))
976 (setq host (concat host tramp-prefix-port-format port))) 1055 (when (string-equal "obex" method)
977 (when (and 1056 (setq host (tramp-bluez-device host)))
978 (string-equal method (tramp-file-name-method vec)) 1057 (when (and (string-equal "dav" method) (string-equal "true" ssl))
979 (string-equal user (or (tramp-file-name-user vec) "")) 1058 (setq method "davs"))
980 (string-equal host (tramp-file-name-host vec))) 1059 (when (and (string-equal "synce" method) (zerop (length user)))
981 (tramp-set-file-property 1060 (setq user (or (tramp-file-name-user vec) "")))
982 vec "/" "fuse-mountpoint" 1061 (unless (zerop (length domain))
983 (file-name-nondirectory 1062 (setq user (concat user tramp-prefix-domain-format domain)))
984 (dbus-byte-array-to-string (car (last elt 2))))) 1063 (unless (zerop (length port))
985 (throw 'mounted t)))))) 1064 (setq host (concat host tramp-prefix-port-format port)))
1065 (when (and
1066 (string-equal method (tramp-file-name-method vec))
1067 (string-equal user (or (tramp-file-name-user vec) ""))
1068 (string-equal host (tramp-file-name-host vec))
1069 (string-match (concat "^" (regexp-quote prefix))
1070 (tramp-file-name-localname vec)))
1071 ;; Set prefix and mountpoint.
1072 (unless (string-equal prefix "/")
1073 (tramp-set-file-property vec "/" "prefix" prefix))
1074 (tramp-set-file-property
1075 vec "/" "fuse-mountpoint"
1076 (dbus-byte-array-to-string (car (last elt 2))))
1077 (throw 'mounted t)))))))
986 1078
987 (defun tramp-gvfs-mount-spec (vec) 1079 (defun tramp-gvfs-mount-spec (vec)
988 "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"." 1080 "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"."
989 (let* ((method (tramp-file-name-method vec)) 1081 (let* ((method (tramp-file-name-method vec))
990 (user (tramp-file-name-real-user vec)) 1082 (user (tramp-file-name-real-user vec))
991 (domain (tramp-file-name-domain vec)) 1083 (domain (tramp-file-name-domain vec))
992 (host (tramp-file-name-real-host vec)) 1084 (host (tramp-file-name-real-host vec))
993 (port (tramp-file-name-port vec)) 1085 (port (tramp-file-name-port vec))
994 (localname (tramp-file-name-localname vec)) 1086 (localname (tramp-file-name-localname vec))
995 (ssl (if (string-match "^davs" method) "true" "false")) 1087 (ssl (if (string-match "^davs" method) "true" "false"))
996 (mount-spec `(:array))) 1088 (mount-spec '(:array))
1089 (mount-pref "/"))
997 1090
998 (setq 1091 (setq
999 mount-spec 1092 mount-spec
1000 (append 1093 (append
1001 mount-spec 1094 mount-spec
1034 (add-to-list 1127 (add-to-list
1035 'mount-spec 1128 'mount-spec
1036 `(:struct "port" ,(dbus-string-to-byte-array (number-to-string port))) 1129 `(:struct "port" ,(dbus-string-to-byte-array (number-to-string port)))
1037 'append)) 1130 'append))
1038 1131
1132 (when (and (string-match "^dav" method)
1133 (string-match "^/?[^/]+" localname))
1134 (setq mount-pref (match-string 0 localname)))
1135
1039 ;; Return. 1136 ;; Return.
1040 mount-spec)) 1137 `(:struct ,(dbus-string-to-byte-array mount-pref) ,mount-spec)))
1041 1138
1042 1139
1043 ;; Connection functions 1140 ;; Connection functions
1044 1141
1045 (defun tramp-gvfs-maybe-open-connection (vec) 1142 (defun tramp-gvfs-maybe-open-connection (vec)
1094 ;; The call must be asynchronously, because of the "askPassword" 1191 ;; The call must be asynchronously, because of the "askPassword"
1095 ;; or "askQuestion"callbacks. 1192 ;; or "askQuestion"callbacks.
1096 (with-tramp-dbus-call-method vec nil 1193 (with-tramp-dbus-call-method vec nil
1097 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker 1194 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
1098 tramp-gvfs-interface-mounttracker "mountLocation" 1195 tramp-gvfs-interface-mounttracker "mountLocation"
1099 `(:struct 1196 (tramp-gvfs-mount-spec vec) (dbus-get-unique-name :session)
1100 ,(dbus-string-to-byte-array "/")
1101 ,(tramp-gvfs-mount-spec vec))
1102 (dbus-get-unique-name :session)
1103 :object-path object-path) 1197 :object-path object-path)
1104 1198
1105 ;; We must wait, until the mount is applied. This will be 1199 ;; We must wait, until the mount is applied. This will be
1106 ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint" 1200 ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint"
1107 ;; file property. 1201 ;; file property.
1115 vec 'file-error 1209 vec 'file-error
1116 "Timeout reached mounting %s@%s using %s" user host method))) 1210 "Timeout reached mounting %s@%s using %s" user host method)))
1117 (while (not (tramp-get-file-property vec "/" "fuse-mountpoint" nil)) 1211 (while (not (tramp-get-file-property vec "/" "fuse-mountpoint" nil))
1118 (read-event nil nil 0.1))) 1212 (read-event nil nil 0.1)))
1119 1213
1214 ;; If `tramp-gvfs-handler-askquestion' has returned "No", it
1215 ;; is marked with the fuse-mountpoint "/". We shall react.
1216 (when (string-equal
1217 (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/")
1218 (tramp-error vec 'file-error "FUSE mount denied"))
1219
1120 ;; We set the connection property "started" in order to put the 1220 ;; We set the connection property "started" in order to put the
1121 ;; remote location into the cache, which is helpful for further 1221 ;; remote location into the cache, which is helpful for further
1122 ;; completion. 1222 ;; completion.
1123 (tramp-set-connection-property vec "started" t))))) 1223 (tramp-set-connection-property vec "started" t)))))
1224
1225 (defun tramp-gvfs-send-command (vec command &rest args)
1226 "Send the COMMAND with its ARGS to connection VEC.
1227 COMMAND is usually a command from the gvfs-* utilities.
1228 `call-process' is applied, and its return code is returned."
1229 (let (result)
1230 (with-current-buffer (tramp-get-buffer vec)
1231 (erase-buffer)
1232 (tramp-message vec 6 "%s %s" command (mapconcat 'identity args " "))
1233 (setq result (apply 'tramp-local-call-process command nil t nil args))
1234 (tramp-message vec 6 "%s" (buffer-string))
1235 result)))
1124 1236
1125 1237
1126 ;; D-Bus BLUEZ functions. 1238 ;; D-Bus BLUEZ functions.
1127 1239
1128 (defun tramp-bluez-list-devices () 1240 (defun tramp-bluez-list-devices ()