[Emacs-diffs] scratch/gnus-cloud 5950ff5 12/15: Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs

[Teodor Zlatanov]

branch: scratch/gnus-cloud
commit 5950ff5a158ee6b86750c3bbca89c4d6e9818444
Merge: 526cbfe f24fe30
Author: Ted Zlatanov <address@hidden>
Commit: Ted Zlatanov <address@hidden>

    Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs
---
 doc/misc/tramp.texi          |   20 ++++++++-
 doc/misc/trampver.texi       |    2 +-
 etc/NEWS                     |    4 ++
 lisp/net/tramp-gvfs.el       |   95 ++++++++++++++++++++++++------------------
 lisp/net/tramp.el            |   14 ++++---
 lisp/net/trampver.el         |    6 +--
 test/lisp/net/tramp-tests.el |    5 +--
 7 files changed, 92 insertions(+), 54 deletions(-)

diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 894ccbe..dc3ef23 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -957,6 +957,22 @@ syntax requires a leading volume (share) name, for example:
 based on standard protocols, such as address@hidden  @option{davs} does the 
same
 but with SSL encryption.  Both methods support the port numbers.
 
address@hidden @option{gdrive}
address@hidden method gdrive
address@hidden gdrive method
address@hidden Google Drive
+
+Via the @option{gdrive} method it is possible to access your Google
+Drive online storage.  User and host name of the remote file name are
+your email address of the Google Drive credentials, like
address@hidden@trampfn{gdrive,john.doe@@gmail.com,/}}.  These credentials must
+be populated in your @command{Online Accounts} application outside Emacs.
+
+Since Google Drive uses cryptic blob file names internally,
address@hidden works with the @code{display-name} of the files.  This
+could produce unexpected behaviour in case two files in the same
+directory have the same @code{display-name}, such a situation must be avoided.
+
 @item @option{obex}
 @cindex method obex
 @cindex obex method
@@ -986,8 +1002,8 @@ requires the SYNCE-GVFS plugin.
 @vindex tramp-gvfs-methods
 This custom option is a list of external methods for address@hidden  By
 default, this list includes @option{afp}, @option{dav}, @option{davs},
address@hidden, @option{sftp} and @option{synce}.  Other methods to
-include are: @option{ftp} and @option{smb}.
address@hidden, @option{obex}, @option{sftp} and @option{synce}.
+Other methods to include are: @option{ftp} and @option{smb}.
 @end defopt
 
 
diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi
index 6f67f35..3101dc0 100644
--- a/doc/misc/trampver.texi
+++ b/doc/misc/trampver.texi
@@ -8,7 +8,7 @@
 @c In the Tramp GIT, the version number is auto-frobbed from
 @c configure.ac, so you should edit that file and run
 @c "autoconf && ./configure" to change the version number.
address@hidden trampver 2.3.0
address@hidden trampver 2.3.1-pre
 
 @c Other flags from configuration
 @set instprefix /usr/local
diff --git a/etc/NEWS b/etc/NEWS
index 7e11f62..2f2ae65 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -318,6 +318,10 @@ different group ID.
 +++
 *** New connection method "doas" for OpenBSD hosts.
 
++++
+*** New connection method "gdrive", which allows to access Google
+Drive onsite repositories.
+
 ---
 ** 'auto-revert-use-notify' is set back to t in 'global-auto-revert-mode'.
 
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 0e874d6..8e7ef0f 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -49,10 +49,10 @@
 
 ;; The custom option `tramp-gvfs-methods' contains the list of
 ;; supported connection methods.  Per default, these are "afp", "dav",
-;; "davs", "obex", "sftp" and "synce".  Note that with "obex" it might
-;; be necessary to pair with the other bluetooth device, if it hasn't
-;; been done already.  There might be also some few seconds delay in
-;; discovering available bluetooth devices.
+;; "davs", "gdrive", "obex", "sftp" and "synce".  Note that with
+;; "obex" it might be necessary to pair with the other bluetooth
+;; device, if it hasn't been done already.  There might be also some
+;; few seconds delay in discovering available bluetooth devices.
 
 ;; Other possible connection methods are "ftp" and "smb".  When one of
 ;; these methods is added to the list, the remote access for that
@@ -110,21 +110,29 @@
   (require 'custom))
 
 ;;;###tramp-autoload
-(defcustom tramp-gvfs-methods '("afp" "dav" "davs" "obex" "sftp" "synce")
+(defcustom tramp-gvfs-methods
+  '("afp" "dav" "davs" "gdrive" "obex" "sftp" "synce")
   "List of methods for remote files, accessed with GVFS."
   :group 'tramp
-  :version "25.1"
+  :version "25.2"
   :type '(repeat (choice (const "afp")
                         (const "dav")
                         (const "davs")
                         (const "ftp")
+                        (const "gdrive")
                         (const "obex")
                         (const "sftp")
                         (const "smb")
                         (const "synce"))))
 
-;; Add a default for `tramp-default-user-alist'.  Rule: For the SYNCE
-;; method, no user is chosen.
+;; Add defaults for `tramp-default-user-alist' and `tramp-default-host-alist'.
+;;;###tramp-autoload
+(when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)"
+                   user-mail-address)
+  (add-to-list 'tramp-default-user-alist
+              `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address)))
+  (add-to-list 'tramp-default-host-alist
+              '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address))))
 ;;;###tramp-autoload
 (add-to-list 'tramp-default-user-alist '("\\`synce\\'" nil nil))
 
@@ -408,11 +416,9 @@ Every entry is a list (NAME ADDRESS).")
   "The device interface of the HAL daemon.")
 
 (defconst tramp-gvfs-file-attributes
-  '("type"
+  '("name"
+    "type"
     "standard::display-name"
-    ;; We don't need this one.  It is used as delimiter in case the
-    ;; display name contains spaces, which is hard to parse.
-    "standard::icon"
     "standard::symlink-target"
     "unix::nlink"
     "unix::uid"
@@ -432,9 +438,7 @@ Every entry is a list (NAME ADDRESS).")
   "GVFS file attributes.")
 
 (defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp
-  (concat "[[:blank:]]"
-         (regexp-opt tramp-gvfs-file-attributes t)
-         "=\\([^[:blank:]]+\\)")
+  (concat "[[:blank:]]" (regexp-opt tramp-gvfs-file-attributes t) "=\\(.+?\\)")
   "Regexp to parse GVFS file attributes with `gvfs-ls'.")
 
 (defconst tramp-gvfs-file-attributes-with-gvfs-info-regexp
@@ -834,25 +838,31 @@ file names."
           v "gvfs-ls" "-h" "-n" "-a"
           (mapconcat 'identity tramp-gvfs-file-attributes ",")
           (tramp-gvfs-url-file-name directory))
-         ;; Parse output ...
+         ;; Parse output.
          (with-current-buffer (tramp-get-connection-buffer v)
            (goto-char (point-min))
-           (while (re-search-forward
+           (while (looking-at
                    (concat "^\\(.+\\)[[:blank:]]"
                            "\\([[:digit:]]+\\)[[:blank:]]"
-                           "(\\(.+\\))[[:blank:]]"
-                           "standard::display-name=\\(.+\\)[[:blank:]]"
-                           "standard::icon=")
-                   (point-at-eol) t)
-             (let ((item (list (cons "standard::display-name" (match-string 4))
-                               (cons "type" (match-string 3))
+                           "(\\(.+?\\))"
+                           tramp-gvfs-file-attributes-with-gvfs-ls-regexp))
+             (let ((item (list (cons "type" (match-string 3))
                                (cons "standard::size" (match-string 2))
-                               (match-string 1))))
-               (while (re-search-forward
-                       tramp-gvfs-file-attributes-with-gvfs-ls-regexp
-                       (point-at-eol) t)
-                 (push (cons (match-string 1) (match-string 2)) item))
-               (push (nreverse item) result))
+                               (cons "name" (match-string 1)))))
+               (goto-char (1+ (match-end 3)))
+               (while (looking-at
+                       (concat
+                        tramp-gvfs-file-attributes-with-gvfs-ls-regexp
+                        "\\(" tramp-gvfs-file-attributes-with-gvfs-ls-regexp
+                        "\\|" "$" "\\)"))
+                 (push (cons (match-string 1) (match-string 2)) item)
+                 (goto-char (match-end 2)))
+               ;; Add display name as head.
+               (push
+                (cons (cdr (or (assoc "standard::display-name" item)
+                               (assoc "name" item)))
+                      (nreverse item))
+                result))
              (forward-line)))
          result)))))
 
@@ -868,7 +878,7 @@ file names."
          ;; Send command.
          (tramp-gvfs-send-command
           v "gvfs-info" (tramp-gvfs-url-file-name filename))
-         ;; Parse output ...
+         ;; Parse output.
          (with-current-buffer (tramp-get-connection-buffer v)
            (goto-char (point-min))
            (while (re-search-forward
@@ -1024,17 +1034,12 @@ file names."
      filename
      (with-parsed-tramp-file-name (expand-file-name directory) nil
        (with-tramp-file-property v localname "file-name-all-completions"
-         (let ((result '("./" "../"))
-              entry)
+         (let ((result '("./" "../")))
            ;; Get a list of directories and files.
           (dolist (item (tramp-gvfs-get-directory-attributes directory) result)
-            (setq entry
-                  (or ;; Use display-name if available (google-drive).
-                   ;(cdr (assoc "standard::display-name" item))
-                   (car item)))
             (if (string-equal (cdr (assoc "type" item)) "directory")
-                (push (file-name-as-directory entry) result)
-              (push entry result)))))))))
+                (push (file-name-as-directory (car item)) result)
+              (push (car item) result)))))))))
 
 (defun tramp-gvfs-handle-file-notify-add-watch (file-name flags _callback)
   "Like `file-notify-add-watch' for Tramp files."
@@ -1220,6 +1225,8 @@ file-notify events."
      (url-recreate-url
       (if (tramp-tramp-file-p filename)
          (with-parsed-tramp-file-name filename nil
+           (when (string-equal "gdrive" method)
+             (setq method "google-drive"))
            (when (and user (string-match tramp-user-with-domain-regexp user))
              (setq user
                    (concat (match-string 2 user) ";" (match-string 1 user))))
@@ -1389,6 +1396,8 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or 
\"[xx:xx:xx:xx:xx:xx]\"."
          (setq host (tramp-bluez-device host)))
        (when (and (string-equal "dav" method) (string-equal "true" ssl))
          (setq method "davs"))
+       (when (string-equal "google-drive" method)
+         (setq method "gdrive"))
        (unless (zerop (length domain))
          (setq user (concat user tramp-prefix-domain-format domain)))
        (unless (zerop (length port))
@@ -1474,6 +1483,8 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or 
\"[xx:xx:xx:xx:xx:xx]\"."
           (setq host (tramp-bluez-device host)))
         (when (and (string-equal "dav" method) (string-equal "true" ssl))
           (setq method "davs"))
+        (when (string-equal "google-drive" method)
+          (setq method "gdrive"))
         (when (and (string-equal "synce" method) (zerop (length user)))
           (setq user (or (tramp-file-name-user vec) "")))
         (unless (zerop (length domain))
@@ -1531,6 +1542,9 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
                 (list (tramp-gvfs-mount-spec-entry "type" "afp-volume")
                       (tramp-gvfs-mount-spec-entry "host" host)
                       (tramp-gvfs-mount-spec-entry "volume" share)))
+               ((string-equal "gdrive" method)
+                (list (tramp-gvfs-mount-spec-entry "type" "google-drive")
+                      (tramp-gvfs-mount-spec-entry "host" host)))
                (t
                 (list (tramp-gvfs-mount-spec-entry "type" method)
                       (tramp-gvfs-mount-spec-entry "host" host))))
@@ -1896,8 +1910,9 @@ They are retrieved from the hal daemon."
 
 ;;; TODO:
 
-;; * Host name completion via afp-server, smb-server or smb-network.
-;; * Check how two shares of the same SMB server can be mounted in
+;; * Host name completion for existing mount points (afp-server,
+;;   smb-server) or via smb-network.
+;; * Check, how two shares of the same SMB server can be mounted in
 ;;   parallel.
 ;; * Apply SDP on bluetooth devices, in order to filter out obex
 ;;   capability.
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index b02760b..d80006a 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -4012,7 +4012,7 @@ are written with verbosity of 6."
               (vector tramp-current-method tramp-current-user
                       tramp-current-host nil nil)))
        (destination (if (eq destination t) (current-buffer) destination))
-       result)
+       output error result)
     (tramp-message
      v 6 "`%s %s' %s %s"
      program (mapconcat 'identity args " ") infile destination)
@@ -4023,13 +4023,17 @@ are written with verbosity of 6."
                 'call-process program infile (or destination t) display args))
          ;; `result' could also be an error string.
          (when (stringp result)
-           (signal 'file-error (list result)))
+           (setq error result
+                 result 1))
          (with-current-buffer
              (if (bufferp destination) destination (current-buffer))
-           (tramp-message v 6 "%d\n%s" result (buffer-string))))
+           (setq output (buffer-string))))
       (error
-       (setq result 1)
-       (tramp-message v 6 "%d\n%s" result (error-message-string err))))
+       (setq error (error-message-string err)
+            result 1)))
+    (if (zerop (length error))
+       (tramp-message v 6 "%d\n%s" result output)
+      (tramp-message v 6 "%d\n%s\n%s" result output error))
     result))
 
 (defun tramp-call-process-region
diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el
index aea2605..fad7e7f 100644
--- a/lisp/net/trampver.el
+++ b/lisp/net/trampver.el
@@ -6,7 +6,7 @@
 ;; Author: Kai Großjohann <address@hidden>
 ;; Keywords: comm, processes
 ;; Package: tramp
-;; Version: 2.3.0
+;; Version: 2.3.1-pre
 
 ;; This file is part of GNU Emacs.
 
@@ -32,7 +32,7 @@
 ;; should be changed only there.
 
 ;;;###tramp-autoload
-(defconst tramp-version "2.3.0"
+(defconst tramp-version "2.3.1-pre"
   "This version of Tramp.")
 
 ;;;###tramp-autoload
@@ -54,7 +54,7 @@
 ;; Check for Emacs version.
 (let ((x (if (>= emacs-major-version 23)
     "ok"
-  (format "Tramp 2.3.0 is not fit for %s"
+  (format "Tramp 2.3.1-pre is not fit for %s"
          (when (string-match "^.*$" (emacs-version))
            (match-string 0 (emacs-version)))))))
   (unless (string-match "\\`ok\\'" x) (error "%s" x)))
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index b9562c1..fe927bb 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -119,7 +119,6 @@ eval properly in `should', `should-not' or `should-error'.  
BODY
 shall not contain a timeout."
   (declare (indent 1) (debug (natnump body)))
   `(let ((tramp-verbose ,verbose)
-        (tramp-message-show-message t)
         (tramp-debug-on-error t)
         (debug-ignored-errors
          (cons "^make-symbolic-link not supported$" debug-ignored-errors)))
@@ -932,7 +931,7 @@ This tests also `file-directory-p' and 
`file-accessible-directory-p'."
          (make-directory tmp-name1)
          (should (file-directory-p tmp-name1))
          (should (file-accessible-directory-p tmp-name1))
-         (should-error (make-directory tmp-name2) :type 'file-error)
+         (should-error (make-directory tmp-name2))
          (make-directory tmp-name2 'parents)
          (should (file-directory-p tmp-name2))
          (should (file-accessible-directory-p tmp-name2)))
@@ -953,7 +952,7 @@ This tests also `file-directory-p' and 
`file-accessible-directory-p'."
     ;; Delete non-empty directory.
     (make-directory tmp-name)
     (write-region "foo" nil (expand-file-name "bla" tmp-name))
-    (should-error (delete-directory tmp-name) :type 'file-error)
+    (should-error (delete-directory tmp-name))
     (delete-directory tmp-name 'recursive)
     (should-not (file-directory-p tmp-name))))