Major change in the flags algorithm: Use UIDVALIDITY, SELECT and PERMANENT-FLAGS
authorLars Magne Ingebrigtsen <larsi@quimbies.gnus.org>
Sat, 9 Oct 2010 15:26:14 +0000 (17:26 +0200)
committerLars Magne Ingebrigtsen <larsi@quimbies.gnus.org>
Sat, 9 Oct 2010 15:26:14 +0000 (17:26 +0200)
(nnimap-retrieve-group-data-early): Rework the marks code to heed
UIDVALIDITY and find out which groups are read-only and not.

lisp/ChangeLog
lisp/gnus.el
lisp/nnimap.el

index 75db5dc..45052d1 100644 (file)
@@ -2,6 +2,8 @@
 
        * nnimap.el (nnimap-open-connection): If we have gnutls loaded, then
        try to use that for the tls stream.
 
        * nnimap.el (nnimap-open-connection): If we have gnutls loaded, then
        try to use that for the tls stream.
+       (nnimap-retrieve-group-data-early): Rework the marks code to heed
+       UIDVALIDITY and find out which groups are read-only and not.
 
 2010-10-09  Julien Danjou  <julien@danjou.info>
 
 
 2010-10-09  Julien Danjou  <julien@danjou.info>
 
index 6f80bcd..d02444c 100644 (file)
@@ -3922,8 +3922,11 @@ If ALLOW-LIST, also allow list as a result."
                           group 'params))))
 
 (defun gnus-group-set-parameter (group name value)
                           group 'params))))
 
 (defun gnus-group-set-parameter (group name value)
-  "Set parameter NAME to VALUE in GROUP."
-  (let ((info (gnus-get-info group)))
+  "Set parameter NAME to VALUE in GROUP.
+GROUP can also be an INFO structure."
+  (let ((info (if (listp group)
+                 group
+               (gnus-get-info group))))
     (when info
       (gnus-group-remove-parameter group name)
       (let ((old-params (gnus-info-params info))
     (when info
       (gnus-group-remove-parameter group name)
       (let ((old-params (gnus-info-params info))
@@ -3933,11 +3936,14 @@ If ALLOW-LIST, also allow list as a result."
                    (not (eq (caar old-params) name)))
            (setq new-params (append new-params (list (car old-params)))))
          (setq old-params (cdr old-params)))
                    (not (eq (caar old-params) name)))
            (setq new-params (append new-params (list (car old-params)))))
          (setq old-params (cdr old-params)))
-       (gnus-group-set-info new-params group 'params)))))
+       (gnus-group-set-info new-params (gnus-info-group group) 'params)))))
 
 (defun gnus-group-remove-parameter (group name)
 
 (defun gnus-group-remove-parameter (group name)
-  "Remove parameter NAME from GROUP."
-  (let ((info (gnus-get-info group)))
+  "Remove parameter NAME from GROUP.
+GROUP can also be an INFO structure."
+  (let ((info (if (listp group)
+                 group
+               (gnus-get-info group))))
     (when info
       (let ((params (gnus-info-params info)))
        (when params
     (when info
       (let ((params (gnus-info-params info)))
        (when params
index 8dad44d..7d3fedb 100644 (file)
@@ -626,8 +626,10 @@ textual parts.")
              (setq marks
                    (nnimap-flags-to-marks
                     (nnimap-parse-flags
              (setq marks
                    (nnimap-flags-to-marks
                     (nnimap-parse-flags
-                     (list (list group-sequence flag-sequence 1 group)))))
-             (when info
+                     (list (list group-sequence flag-sequence
+                                 1 group "SELECT")))))
+             (when (and info
+                        marks)
                (nnimap-update-infos marks (list info)))
              (goto-char (point-max))
              (let ((uidnext (nth 5 (car marks))))
                (nnimap-update-infos marks (list info)))
              (goto-char (point-max))
              (let ((uidnext (nth 5 (car marks))))
@@ -941,41 +943,45 @@ textual parts.")
 (deffoo nnimap-retrieve-group-data-early (server infos)
   (when (nnimap-possibly-change-group nil server)
     (with-current-buffer (nnimap-buffer)
 (deffoo nnimap-retrieve-group-data-early (server infos)
   (when (nnimap-possibly-change-group nil server)
     (with-current-buffer (nnimap-buffer)
+      (erase-buffer)
+      (setf (nnimap-group nnimap-object) nil)
       ;; QRESYNC handling isn't implemented.
       (let ((qresyncp (member "notQRESYNC" (nnimap-capabilities nnimap-object)))
       ;; QRESYNC handling isn't implemented.
       (let ((qresyncp (member "notQRESYNC" (nnimap-capabilities nnimap-object)))
-           marks groups sequences)
+           params groups sequences active uidvalidity modseq group)
        ;; Go through the infos and gather the data needed to know
        ;; what and how to request the data.
        (dolist (info infos)
        ;; Go through the infos and gather the data needed to know
        ;; what and how to request the data.
        (dolist (info infos)
-         (setq marks (gnus-info-marks info))
-         (push (list (gnus-group-real-name (gnus-info-group info))
-                     (cdr (assq 'active marks))
-                     (cdr (assq 'uid marks)))
-               groups))
-       ;; Then request the data.
-       (erase-buffer)
-       (setf (nnimap-group nnimap-object) nil)
-       (dolist (elem groups)
+         (setq params (gnus-info-params info)
+               group (gnus-group-real-name (gnus-info-group info))
+               active (cdr (assq 'active params))
+               uidvalidity (cdr (assq 'uidvalidity params))
+               modseq (cdr (assq 'modseq params)))
          (if (and qresyncp
          (if (and qresyncp
-                  (nth 2 elem))
+                  uidvalidity
+                  modseq)
              (push
               (list 'qresync
                     (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))"
              (push
               (list 'qresync
                     (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))"
-                                         (car elem)
-                                         (car (nth 2 elem))
-                                         (cdr (nth 2 elem)))
-                    nil
-                    (car elem))
+                                         group uidvalidity modseq)
+                    nil group 'qresync)
               sequences)
            (let ((start
               sequences)
            (let ((start
-                  (if (nth 1 elem)
+                  (if (and active uidvalidity)
                       ;; Fetch the last 100 flags.
                       ;; Fetch the last 100 flags.
-                      (max 1 (- (cdr (nth 1 elem)) 100))
-                    1)))
-             (push (list (nnimap-send-command "EXAMINE %S" (car elem))
+                      (max 1 (- (cdr active) 100))
+                    1))
+                 (command
+                  (if uidvalidity
+                      "EXAMINE"
+                    ;; If we don't have a UIDVALIDITY, then this is
+                    ;; the first time we've seen the group, so we
+                    ;; have to do a SELECT (which is slower than an
+                    ;; examine), but will tell us whether the group
+                    ;; is read-only or not.
+                    "SELECT")))
+             (push (list (nnimap-send-command "%s %S" command group)
                          (nnimap-send-command "UID FETCH %d:* FLAGS" start)
                          (nnimap-send-command "UID FETCH %d:* FLAGS" start)
-                         start
-                         (car elem))
+                         start group command)
                    sequences)))
          ;; Some servers apparently can't have many outstanding
          ;; commands, so throttle them.
                    sequences)))
          ;; Some servers apparently can't have many outstanding
          ;; commands, so throttle them.
@@ -990,9 +996,9 @@ textual parts.")
     (with-current-buffer (nnimap-buffer)
       ;; Wait for the final data to trickle in.
       (when (nnimap-wait-for-response (cadar sequences) t)
     (with-current-buffer (nnimap-buffer)
       ;; Wait for the final data to trickle in.
       (when (nnimap-wait-for-response (cadar sequences) t)
-       ;; Now we should have all the data we need, no matter whether
-       ;; we're QRESYNCING, fetching all the flags from scratch, or
-       ;; just fetching the last 100 flags per group.
+       ;; Now we should have most of the data we need, no matter
+       ;; whether we're QRESYNCING, fetching all the flags from
+       ;; scratch, or just fetching the last 100 flags per group.
        (nnimap-update-infos (nnimap-flags-to-marks
                              (nnimap-parse-flags
                               (nreverse sequences)))
        (nnimap-update-infos (nnimap-flags-to-marks
                              (nnimap-parse-flags
                               (nreverse sequences)))
@@ -1012,17 +1018,31 @@ textual parts.")
 
 (defun nnimap-update-infos (flags infos)
   (dolist (info infos)
 
 (defun nnimap-update-infos (flags infos)
   (dolist (info infos)
-    (let ((group (gnus-group-real-name (gnus-info-group info))))
-      (nnimap-update-info info (cdr (assoc group flags))))))
+    (let* ((group (gnus-group-real-name (gnus-info-group info)))
+          (marks (cdr (assoc group flags))))
+      (when marks
+       (nnimap-update-info info marks)))))
 
 (defun nnimap-update-info (info marks)
 
 (defun nnimap-update-info (info marks)
-  (when (and marks
-            ;; Ignore groups with no UIDNEXT/marks.  This happens for
-            ;; completely empty groups.
-            (or (car marks)
-                (nth 4 marks)))
-    (destructuring-bind (existing flags high low uidnext start-article
-                                 permanent-flags) marks
+  (destructuring-bind (existing flags high low uidnext start-article
+                               permanent-flags uidvalidity) marks
+    (cond
+     ;; Ignore groups with no UIDNEXT/marks.  This happens for
+     ;; completely empty groups.
+     ((and (not existing)
+          (not uidnext))
+      )
+     ;; We have a mismatch between the old and new UIDVALIDITY
+     ;; identifiers, so we have to re-request the group info (the next
+     ;; time).  This virtually never happens.
+     ((let ((old-uidvalidity
+            (cdr (assq 'uidvalidity (gnus-info-params info)))))
+       (and old-uidvalidity
+            (not (equal old-uidvalidity uidvalidity))
+            (> start-article 1)))
+      (gnus-group-remove-parameter info 'uidvalidity))
+     ;; We have the data needed to update.
+     (t
       (let ((group (gnus-info-group info))
            (completep (and start-article
                            (= start-article 1))))
       (let ((group (gnus-info-group info))
            (completep (and start-article
                            (= start-article 1))))
@@ -1047,52 +1067,60 @@ textual parts.")
           group
           (cons (car (gnus-active group))
                 (or high (1- uidnext)))))
           group
           (cons (car (gnus-active group))
                 (or high (1- uidnext)))))
-       ;; Then update the list of read articles.
-       (let* ((unread
-               (gnus-compress-sequence
-                (gnus-set-difference
-                 (gnus-set-difference
-                  existing
-                  (cdr (assoc '%Seen flags)))
-                 (cdr (assoc '%Flagged flags)))))
-              (read (gnus-range-difference
-                     (cons start-article high) unread)))
-         (when (> start-article 1)
-           (setq read
-                 (gnus-range-nconcat
-                  (if (> start-article 1)
-                      (gnus-sorted-range-intersection
-                       (cons 1 (1- start-article))
-                       (gnus-info-read info))
-                    (gnus-info-read info))
-                  read)))
-         (gnus-info-set-read info read)
-         ;; Update the marks.
-         (setq marks (gnus-info-marks info))
-         ;; Note the active level for the next run-through.
-         (let ((active (assq 'active marks)))
-           (if active
-               (setcdr active (gnus-active group))
-             (push (cons 'active (gnus-active group)) marks)))
-         (dolist (type (cdr nnimap-mark-alist))
-           (let ((old-marks (assoc (car type) marks))
-                 (new-marks
-                  (gnus-compress-sequence
-                   (cdr (or (assoc (caddr type) flags)     ; %Flagged
-                            (assoc (intern (cadr type) obarray) flags)
-                            (assoc (cadr type) flags)))))) ; "\Flagged"
-             (setq marks (delq old-marks marks))
-             (pop old-marks)
-             (when (and old-marks
-                        (> start-article 1))
-               (setq old-marks (gnus-range-difference
-                                old-marks
-                                (cons start-article high)))
-               (setq new-marks (gnus-range-nconcat old-marks new-marks)))
-             (when new-marks
-               (push (cons (car type) new-marks) marks)))
-           (gnus-info-set-marks info marks t)
-           (nnimap-store-info info (gnus-active group))))))))
+       ;; See whether this is a read-only group.
+       (unless (eq permanent-flags 'not-scanned)
+         (gnus-group-set-parameter
+          info 'permanent-flags
+          (if (memq '%* permanent-flags)
+              t
+            nil)))
+       ;; Then update marks and read articles if this isn't a
+       ;; read-only IMAP group.
+       (when (cdr (assq 'permanent-flags (gnus-info-params info)))
+         ;; Update the list of read articles.
+         (let* ((unread
+                 (gnus-compress-sequence
+                  (gnus-set-difference
+                   (gnus-set-difference
+                    existing
+                    (cdr (assoc '%Seen flags)))
+                   (cdr (assoc '%Flagged flags)))))
+                (read (gnus-range-difference
+                       (cons start-article high) unread)))
+           (when (> start-article 1)
+             (setq read
+                   (gnus-range-nconcat
+                    (if (> start-article 1)
+                        (gnus-sorted-range-intersection
+                         (cons 1 (1- start-article))
+                         (gnus-info-read info))
+                      (gnus-info-read info))
+                    read)))
+           (gnus-info-set-read info read)
+           ;; Update the marks.
+           (setq marks (gnus-info-marks info))
+           (dolist (type (cdr nnimap-mark-alist))
+             (let ((old-marks (assoc (car type) marks))
+                   (new-marks
+                    (gnus-compress-sequence
+                     (cdr (or (assoc (caddr type) flags) ; %Flagged
+                              (assoc (intern (cadr type) obarray) flags)
+                              (assoc (cadr type) flags)))))) ; "\Flagged"
+               (setq marks (delq old-marks marks))
+               (pop old-marks)
+               (when (and old-marks
+                          (> start-article 1))
+                 (setq old-marks (gnus-range-difference
+                                  old-marks
+                                  (cons start-article high)))
+                 (setq new-marks (gnus-range-nconcat old-marks new-marks)))
+               (when new-marks
+                 (push (cons (car type) new-marks) marks)))
+             (gnus-info-set-marks info marks t))))
+       ;; Note the active level for the next run-through.
+       (gnus-group-set-parameter info 'active (gnus-active group))
+       (gnus-group-set-parameter info 'uidvalidity uidvalidity)
+       (nnimap-store-info info (gnus-active group)))))))
 
 (defun nnimap-store-info (info active)
   (let* ((group (gnus-group-real-name (gnus-info-group info)))
 
 (defun nnimap-store-info (info active)
   (let* ((group (gnus-group-real-name (gnus-info-group info)))
@@ -1102,13 +1130,15 @@ textual parts.")
       (push (list group info active) nnimap-current-infos))))
 
 (defun nnimap-flags-to-marks (groups)
       (push (list group info active) nnimap-current-infos))))
 
 (defun nnimap-flags-to-marks (groups)
-  (let (data group totalp uidnext articles start-article mark permanent-flags)
+  (let (data group totalp uidnext articles start-article mark permanent-flags
+            uidvalidity)
     (dolist (elem groups)
       (setq group (car elem)
            uidnext (nth 1 elem)
            start-article (nth 2 elem)
            permanent-flags (nth 3 elem)
     (dolist (elem groups)
       (setq group (car elem)
            uidnext (nth 1 elem)
            start-article (nth 2 elem)
            permanent-flags (nth 3 elem)
-           articles (nthcdr 4 elem))
+           uidvalidity (nth 4 elem)
+           articles (nthcdr 5 elem))
       (let ((high (caar articles))
            marks low existing)
        (dolist (article articles)
       (let ((high (caar articles))
            marks low existing)
        (dolist (article articles)
@@ -1120,7 +1150,7 @@ textual parts.")
                (push (list flag (car article)) marks)
              (setcdr mark (cons (car article) (cdr mark))))))
        (push (list group existing marks high low uidnext start-article
                (push (list flag (car article)) marks)
              (setcdr mark (cons (car article) (cdr mark))))))
        (push (list group existing marks high low uidnext start-article
-                   permanent-flags)
+                   permanent-flags uidvalidity)
              data)))
     data))
 
              data)))
     data))
 
@@ -1129,29 +1159,41 @@ textual parts.")
   ;; Change \Delete etc to %Delete, so that the reader can read it.
   (subst-char-in-region (point-min) (point-max)
                        ?\\ ?% t)
   ;; Change \Delete etc to %Delete, so that the reader can read it.
   (subst-char-in-region (point-min) (point-max)
                        ?\\ ?% t)
-  (let (start end articles groups uidnext elems permanent-flags)
+  (let (start end articles groups uidnext elems permanent-flags
+             uidvalidity)
     (dolist (elem sequences)
     (dolist (elem sequences)
-      (destructuring-bind (group-sequence flag-sequence totalp group) elem
+      (destructuring-bind (group-sequence flag-sequence totalp group command)
+         elem
        (setq start (point))
        ;; The EXAMINE was successful.
        (setq start (point))
        ;; The EXAMINE was successful.
-       (when (and (search-forward (format "\n%d OK " group-sequence) nil t)
-                  (progn
-                    (forward-line 1)
-                    (setq end (point))
-                    (goto-char start)
-                    (setq permanent-flags
+       (when (and
+              (search-forward (format "\n%d OK " group-sequence) nil t)
+              (progn
+                (forward-line 1)
+                (setq end (point))
+                (goto-char start)
+                (setq permanent-flags
+                      (if (equal command "SELECT")
                           (and (search-forward "PERMANENTFLAGS "
                           (and (search-forward "PERMANENTFLAGS "
-                                                (or end (point-min)) t)
-                               (read (current-buffer))))
-                    (goto-char start)
-                    (setq uidnext
-                          (and (search-forward "UIDNEXT "
-                                                (or end (point-min)) t)
-                               (read (current-buffer))))
-                    (goto-char end)
-                    (forward-line -1))
-                  ;; The UID FETCH FLAGS was successful.
-                  (search-forward (format "\n%d OK " flag-sequence) nil t))
+                                               (or end (point-min)) t)
+                               (read (current-buffer)))
+                        'not-scanned))
+                (goto-char start)
+                (setq uidnext
+                      (and (search-forward "UIDNEXT "
+                                           (or end (point-min)) t)
+                           (read (current-buffer))))
+                (goto-char start)
+                (setq uidvalidity
+                      (and (re-search-forward "UIDVALIDITY \\([0-9]+\\)"
+                                           (or end (point-min)) t)
+                           ;; Store UIDVALIDITY as a string, as it's
+                           ;; too big for 32-bit Emacsen, usually.
+                           (match-string 1)))
+                (goto-char end)
+                (forward-line -1))
+              ;; The UID FETCH FLAGS was successful.
+              (search-forward (format "\n%d OK " flag-sequence) nil t))
          (setq start (point))
          (goto-char end)
          (while (search-forward " FETCH " start t)
          (setq start (point))
          (goto-char end)
          (while (search-forward " FETCH " start t)
@@ -1159,7 +1201,8 @@ textual parts.")
            (push (cons (cadr (memq 'UID elems))
                        (cadr (memq 'FLAGS elems)))
                  articles))
            (push (cons (cadr (memq 'UID elems))
                        (cadr (memq 'FLAGS elems)))
                  articles))
-         (push (nconc (list group uidnext totalp permanent-flags) articles)
+         (push (nconc (list group uidnext totalp permanent-flags uidvalidity)
+                      articles)
                groups)
          (setq articles nil))))
     groups))
                groups)
          (setq articles nil))))
     groups))