Gnus -- minor build / warning fixes [OK For Upstream]

[gnus] / lisp / gnus-cloud.el

diff --git a/lisp/gnus-cloud.el b/lisp/gnus-cloud.el
index f9f7fdc..52b1360 100644 (file)
--- a/lisp/gnus-cloud.el
+++ b/lisp/gnus-cloud.el
@@ -1,6 +1,6 @@
 ;;; gnus-cloud.el --- storing and retrieving data via IMAP
 
 ;;; gnus-cloud.el --- storing and retrieving data via IMAP
 

-;; Copyright (C) 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2014-2016 Free Software Foundation, Inc.

 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: mail
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: mail


@@ -26,9 +26,11 @@
 
 (eval-when-compile (require 'cl))
 (require 'parse-time)
 
 (eval-when-compile (require 'cl))
 (require 'parse-time)

+(require 'nnimap)

 
 (defgroup gnus-cloud nil
   "Syncing Gnus data via IMAP."
 
 (defgroup gnus-cloud nil
   "Syncing Gnus data via IMAP."

+  :version "25.1"

   :group 'gnus)
 
 (defcustom gnus-cloud-synced-files
   :group 'gnus)
 
 (defcustom gnus-cloud-synced-files


@@ -38,9 +40,11 @@
     (:directory "~/News" :match ".*.SCORE\\'"))
   "List of file regexps that should be kept up-to-date via the cloud."
   :group 'gnus-cloud
     (:directory "~/News" :match ".*.SCORE\\'"))
   "List of file regexps that should be kept up-to-date via the cloud."
   :group 'gnus-cloud

+  ;; FIXME this type does not match the default.  Nor does the documentation.

   :type '(repeat regexp))
 
 (defvar gnus-cloud-group-name "*Emacs Cloud*")
   :type '(repeat regexp))
 
 (defvar gnus-cloud-group-name "*Emacs Cloud*")

+(defvar gnus-cloud-covered-servers nil)

 
 (defvar gnus-cloud-version 1)
 (defvar gnus-cloud-sequence 1)
 
 (defvar gnus-cloud-version 1)
 (defvar gnus-cloud-sequence 1)


@@ -123,7 +127,7 @@
        (let ((spec (ignore-errors (read (current-buffer))))
              length)
          (when (and (consp spec)
        (let ((spec (ignore-errors (read (current-buffer))))
              length)
          (when (and (consp spec)

-                    (memq (getf spec :type) '(:file :data :deleta)))
+                    (memq (plist-get spec :type) '(:file :data :delete)))

            (setq length (plist-get spec :length))
            (push (append spec
                          (list
            (setq length (plist-get spec :length))
            (push (append spec
                          (list


@@ -227,15 +231,19 @@
              (string< old timestamp))
       timestamp)))
 
              (string< old timestamp))
       timestamp)))
 

+(declare-function gnus-activate-group "gnus-start"
+                 (group &optional scan dont-check method dont-sub-check))
+(declare-function gnus-subscribe-group "gnus-start"
+                 (group &optional previous method))
+

 (defun gnus-cloud-ensure-cloud-group ()
   (let ((method (if (stringp gnus-cloud-method)
                    (gnus-server-to-method gnus-cloud-method)
                  gnus-cloud-method)))
     (unless (or (gnus-active gnus-cloud-group-name)
 (defun gnus-cloud-ensure-cloud-group ()
   (let ((method (if (stringp gnus-cloud-method)
                    (gnus-server-to-method gnus-cloud-method)
                  gnus-cloud-method)))
     (unless (or (gnus-active gnus-cloud-group-name)

-               (gnus-activate-group gnus-cloud-group-name nil nil
-                                    gnus-cloud-method))
-      (and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method)
-          (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
+               (gnus-activate-group gnus-cloud-group-name nil nil method))
+      (and (gnus-request-create-group gnus-cloud-group-name method)
+          (gnus-activate-group gnus-cloud-group-name nil nil method)

           (gnus-subscribe-group gnus-cloud-group-name)))))
 
 (defun gnus-cloud-upload-data (&optional full)
           (gnus-subscribe-group gnus-cloud-group-name)))))
 
 (defun gnus-cloud-upload-data (&optional full)


@@ -274,7 +282,10 @@
        (while (and (not (eobp))
                    (setq head (nnheader-parse-head)))
          (push head headers))))
        (while (and (not (eobp))
                    (setq head (nnheader-parse-head)))
          (push head headers))))

-    (nreverse headers)))
+    (sort (nreverse headers)
+         (lambda (h1 h2)
+           (> (gnus-cloud-chunk-sequence (mail-header-subject h1))
+              (gnus-cloud-chunk-sequence (mail-header-subject h2)))))))

 
 (defun gnus-cloud-chunk-sequence (string)
   (if (string-match "sequence: \\([0-9]+\\)" string)
 
 (defun gnus-cloud-chunk-sequence (string)
   (if (string-match "sequence: \\([0-9]+\\)" string)


@@ -282,11 +293,7 @@
     0))
 
 (defun gnus-cloud-prune-old-chunks (headers)
     0))
 
 (defun gnus-cloud-prune-old-chunks (headers)

-  (let ((headers
-        (sort (reverse headers)
-              (lambda (h1 h2)
-                (> (gnus-cloud-chunk-sequence (mail-header-subject h1))
-                   (gnus-cloud-chunk-sequence (mail-header-subject h2))))))
+  (let ((headers (reverse headers))

        (found nil))
   (while (and headers
              (not found))
        (found nil))
   (while (and headers
              (not found))


@@ -302,6 +309,34 @@
             (nreverse headers))
      (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))))
 
             (nreverse headers))
      (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))))
 

+(defun gnus-cloud-download-data ()
+  (let ((articles nil)
+       chunks)
+    (dolist (header (gnus-cloud-available-chunks))
+      (when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
+              gnus-cloud-sequence)
+       (push (mail-header-number header) articles)))
+    (when articles
+      (nnimap-request-articles (nreverse articles) gnus-cloud-group-name)
+      (with-current-buffer nntp-server-buffer
+       (goto-char (point-min))
+       (while (re-search-forward "^Version " nil t)
+         (beginning-of-line)
+         (push (gnus-cloud-parse-chunk) chunks)
+         (forward-line 1))))))
+
+(defun gnus-cloud-server-p (server)
+  (member server gnus-cloud-covered-servers))
+
+(defun gnus-cloud-collect-full-newsrc ()
+  (let ((infos nil))
+    (dolist (info (cdr gnus-newsrc-alist))
+      (when (gnus-cloud-server-p
+            (gnus-method-to-server
+             (gnus-find-method-for-group (gnus-info-group info))))
+       (push info infos)))
+    ))
+

 (provide 'gnus-cloud)
 
 ;;; gnus-cloud.el ends here
 (provide 'gnus-cloud)
 
 ;;; gnus-cloud.el ends here