[Emacs-diffs] master 0797b39: Possibly skip IMAP server FETCH responses

[Eric Abrahamsen]

branch: master
commit 0797b39185e66983c7286e89f93dd4f6c83b6ea7
Author: Eric Abrahamsen <address@hidden>
Commit: Eric Abrahamsen <address@hidden>

    Possibly skip IMAP server FETCH responses
    
    See bug#35433
    
    * lisp/gnus/nnimap.el (nnimap-transform-headers): Skip FETCH responses
      that only provide message flags, not message headers.
---
 lisp/gnus/nnimap.el | 93 ++++++++++++++++++++++++++++++-----------------------
 1 file changed, 53 insertions(+), 40 deletions(-)

diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 06817f4..67c5db1 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -231,8 +231,9 @@ textual parts.")
     'headers))
 
 (defun nnimap-transform-headers ()
+  "Transform server's FETCH response into parseable headers."
   (goto-char (point-min))
-  (let (article lines size string labels)
+  (let (seen-articles article lines size string labels)
     (cl-block nil
       (while (not (eobp))
        (while (not (looking-at "\\* [0-9]+ FETCH"))
@@ -261,45 +262,57 @@ textual parts.")
              (and (re-search-forward "UID \\([0-9]+\\)" (line-end-position)
                                      t)
                   (match-string 1)))
-       (setq lines nil)
-       (beginning-of-line)
-       (setq size
-             (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)"
-                                     (line-end-position)
-                                     t)
-                  (match-string 1)))
-       (beginning-of-line)
-       (when (search-forward "X-GM-LABELS" (line-end-position) t)
-         (setq labels (ignore-errors (read (current-buffer)))))
-       (beginning-of-line)
-       (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
-         (let ((structure (ignore-errors
-                            (read (current-buffer)))))
-           (while (and (consp structure)
-                       (not (atom (car structure))))
-             (setq structure (car structure)))
-           (setq lines (if (and
-                            (stringp (car structure))
-                            (equal (upcase (nth 0 structure)) "MESSAGE")
-                            (equal (upcase (nth 1 structure)) "RFC822"))
-                           (nth 9 structure)
-                         (nth 7 structure)))))
-       (delete-region (line-beginning-position) (line-end-position))
-       (insert (format "211 %s Article retrieved." article))
-       (forward-line 1)
-       (when size
-         (insert (format "Chars: %s\n" size)))
-       (when lines
-         (insert (format "Lines: %s\n" lines)))
-       (when labels
-         (insert (format "X-GM-LABELS: %s\n" labels)))
-       ;; Most servers have a blank line after the headers, but
-       ;; Davmail doesn't.
-       (unless (re-search-forward "^\r$\\|^)\r?$" nil t)
-         (goto-char (point-max)))
-       (delete-region (line-beginning-position) (line-end-position))
-       (insert ".")
-       (forward-line 1)))))
+       ;; If we've already got headers for this article, or this
+       ;; FETCH line doesn't provide headers for the article, skip
+       ;; it.  See bug#35433.
+       (if (or (member article seen-articles)
+               (save-excursion
+                 (forward-line)
+                 (null (looking-at-p
+                        ;; We're expecting a mail header.
+                        "^[!-9;-~]+: "))))
+           (delete-region (line-beginning-position)
+                          (1+ (line-end-position)))
+         (setq lines nil)
+         (beginning-of-line)
+         (setq size
+               (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)"
+                                       (line-end-position)
+                                       t)
+                    (match-string 1)))
+         (beginning-of-line)
+         (when (search-forward "X-GM-LABELS" (line-end-position) t)
+           (setq labels (ignore-errors (read (current-buffer)))))
+         (beginning-of-line)
+         (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
+           (let ((structure (ignore-errors
+                              (read (current-buffer)))))
+             (while (and (consp structure)
+                         (not (atom (car structure))))
+               (setq structure (car structure)))
+             (setq lines (if (and
+                              (stringp (car structure))
+                              (equal (upcase (nth 0 structure)) "MESSAGE")
+                              (equal (upcase (nth 1 structure)) "RFC822"))
+                             (nth 9 structure)
+                           (nth 7 structure)))))
+         (delete-region (line-beginning-position) (line-end-position))
+         (insert (format "211 %s Article retrieved." article))
+         (forward-line 1)
+         (when size
+           (insert (format "Chars: %s\n" size)))
+         (when lines
+           (insert (format "Lines: %s\n" lines)))
+         (when labels
+           (insert (format "X-GM-LABELS: %s\n" labels)))
+         ;; Most servers have a blank line after the headers, but
+         ;; Davmail doesn't.
+         (unless (re-search-forward "^\r$\\|^)\r?$" nil t)
+           (goto-char (point-max)))
+         (delete-region (line-beginning-position) (line-end-position))
+         (insert ".")
+         (forward-line 1)
+         (push article seen-articles))))))
 
 (defun nnimap-unfold-quoted-lines ()
   ;; Unfold quoted {number} strings.