Merge branch 'master' of https://git.gnus.org/gnus

[gnus] / lisp / nnimap.el

diff --git a/lisp/nnimap.el b/lisp/nnimap.el
index 0fe5816..4a77836 100644 (file)
--- a/lisp/nnimap.el
+++ b/lisp/nnimap.el
@@ -37,6 +37,7 @@
 (require 'gnus)
 (require 'nnoo)
 (require 'netrc)
 (require 'gnus)
 (require 'nnoo)
 (require 'netrc)

+(require 'parse-time)

 
 (nnoo-declare nnimap)
 
 
 (nnoo-declare nnimap)
 


@@ -61,11 +62,23 @@ Values are `ssl' and `network'.")
 (defvoo nnimap-inbox nil
   "The mail box where incoming mail arrives and should be split out of.")
 
 (defvoo nnimap-inbox nil
   "The mail box where incoming mail arrives and should be split out of.")
 

-(defvoo nnimap-expunge-inbox nil
-  "If non-nil, expunge the inbox after fetching mail.
+(defvoo nnimap-authenticator nil
+  "How nnimap authenticate itself to the server.
+Possible choices are nil (use default methods) or `anonymous'.")
+
+(defvoo nnimap-fetch-partial-articles nil
+  "If non-nil, nnimap will fetch partial articles.
+If t, nnimap will fetch only the first part.  If a string, it
+will fetch all parts that have types that match that string.  A
+likely value would be \"text/\" to automatically fetch all
+textual parts.")
+
+(defvoo nnimap-expunge t
+  "If non-nil, expunge articles after deleting them.

 This is always done if the server supports UID EXPUNGE, but it's
 not done by default on servers that doesn't support that command.")
 
 This is always done if the server supports UID EXPUNGE, but it's
 not done by default on servers that doesn't support that command.")
 

+

 (defvoo nnimap-connection-alist nil)
 
 (defvoo nnimap-current-infos nil)
 (defvoo nnimap-connection-alist nil)
 
 (defvoo nnimap-current-infos nil)


@@ -126,7 +139,7 @@ not done by default on servers that doesn't support that command.")
 
 (defun nnimap-transform-headers ()
   (goto-char (point-min))
 
 (defun nnimap-transform-headers ()
   (goto-char (point-min))

-  (let (article bytes lines)
+  (let (article bytes lines size)

     (block nil
       (while (not (eobp))
        (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
     (block nil
       (while (not (eobp))
        (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))


@@ -137,6 +150,12 @@ not done by default on servers that doesn't support that command.")
              bytes (nnimap-get-length)
              lines nil)
        (beginning-of-line)
              bytes (nnimap-get-length)
              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 "BODYSTRUCTURE" (line-end-position) t)
          (let ((structure (ignore-errors (read (current-buffer)))))
            (while (and (consp structure)
        (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
          (let ((structure (ignore-errors (read (current-buffer)))))
            (while (and (consp structure)


@@ -146,7 +165,8 @@ not done by default on servers that doesn't support that command.")
        (delete-region (line-beginning-position) (line-end-position))
        (insert (format "211 %s Article retrieved." article))
        (forward-line 1)
        (delete-region (line-beginning-position) (line-end-position))
        (insert (format "211 %s Article retrieved." article))
        (forward-line 1)

-       (insert (format "Bytes: %d\n" bytes))
+       (when size
+         (insert (format "Chars: %s\n" size)))

        (when lines
          (insert (format "Lines: %s\n" lines)))
        (re-search-forward "^\r$")
        (when lines
          (insert (format "Lines: %s\n" lines)))
        (re-search-forward "^\r$")


@@ -254,7 +274,14 @@ not done by default on servers that doesn't support that command.")
        (when (setq connection-result (nnimap-wait-for-connection))
          (unless (equal connection-result "PREAUTH")
            (if (not (setq credentials
        (when (setq connection-result (nnimap-wait-for-connection))
          (unless (equal connection-result "PREAUTH")
            (if (not (setq credentials

-                          (nnimap-credentials nnimap-address ports)))
+                          (if (eq nnimap-authenticator 'anonymous)
+                              (list "anonymous"
+                                    (message-make-address))
+                            (nnimap-credentials
+                             nnimap-address
+                             (if nnimap-server-port
+                                 (cons (format "%s" nnimap-server-port) ports)
+                               ports)))))

                (setq nnimap-object nil)
              (setq login-result (nnimap-command "LOGIN %S %S"
                                                 (car credentials)
                (setq nnimap-object nil)
              (setq login-result (nnimap-command "LOGIN %S %S"
                                                 (car credentials)


@@ -302,7 +329,8 @@ not done by default on servers that doesn't support that command.")
 
 (deffoo nnimap-request-article (article &optional group server to-buffer)
   (with-current-buffer nntp-server-buffer
 
 (deffoo nnimap-request-article (article &optional group server to-buffer)
   (with-current-buffer nntp-server-buffer

-    (let ((result (nnimap-possibly-change-group group server)))
+    (let ((result (nnimap-possibly-change-group group server))
+         parts)

       (when (stringp article)
        (setq article (nnimap-find-article-by-message-id group article)))
       (when (and result
       (when (stringp article)
        (setq article (nnimap-find-article-by-message-id group article)))
       (when (and result


@@ -310,12 +338,24 @@ not done by default on servers that doesn't support that command.")
        (erase-buffer)
        (with-current-buffer (nnimap-buffer)
          (erase-buffer)
        (erase-buffer)
        (with-current-buffer (nnimap-buffer)
          (erase-buffer)

+         (when nnimap-fetch-partial-articles
+           (if (eq nnimap-fetch-partial-articles t)
+               (setq parts '(1))
+             (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article)
+             (goto-char (point-min))
+             (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t)
+               (let ((structure (ignore-errors (read (current-buffer)))))
+                 (setq parts (nnimap-find-wanted-parts structure))))))

          (setq result
                (nnimap-command
                 (if (member "IMAP4REV1" (nnimap-capabilities nnimap-object))
                     "UID FETCH %d BODY.PEEK[]"
                   "UID FETCH %d RFC822.PEEK")
          (setq result
                (nnimap-command
                 (if (member "IMAP4REV1" (nnimap-capabilities nnimap-object))
                     "UID FETCH %d BODY.PEEK[]"
                   "UID FETCH %d RFC822.PEEK")

-                article)))
+                article))
+         ;; Check that we really got an article.
+         (goto-char (point-min))
+         (unless (looking-at "\\* [0-9]+ FETCH")
+           (setq result nil)))

        (let ((buffer (nnimap-find-process-buffer (current-buffer))))
          (when (car result)
            (with-current-buffer (or to-buffer nntp-server-buffer)
        (let ((buffer (nnimap-find-process-buffer (current-buffer))))
          (when (car result)
            (with-current-buffer (or to-buffer nntp-server-buffer)


@@ -327,12 +367,35 @@ not done by default on servers that doesn't support that command.")
                (goto-char (+ (point) bytes))
                (delete-region (point) (point-max))
                (nnheader-ms-strip-cr))
                (goto-char (+ (point) bytes))
                (delete-region (point) (point-max))
                (nnheader-ms-strip-cr))

-             t)))))))
+             (cons group article))))))))
+
+(defun nnimap-find-wanted-parts (structure)
+  (message-flatten-list (nnimap-find-wanted-parts-1 structure "")))
+
+(defun nnimap-find-wanted-parts-1 (structure prefix)
+  (let ((num 1)
+       parts)
+    (while (consp (car structure))
+      (let ((sub (pop structure)))
+       (if (consp (car sub))
+           (push (nnimap-find-wanted-parts-1
+                  sub (if (string= prefix "")
+                          (number-to-string num)
+                        (format "%s.%s" prefix num)))
+                 parts)
+         (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub))))
+           (when (string-match nnimap-fetch-partial-articles type)
+             (push (if (string= prefix "")
+                       (number-to-string num)
+                     (format "%s.%s" prefix num))
+                   parts)))
+         (incf num))))
+    (nreverse parts)))

 
 (deffoo nnimap-request-group (group &optional server dont-check info)
 
 (deffoo nnimap-request-group (group &optional server dont-check info)

-  (with-current-buffer nntp-server-buffer
-    (let ((result (nnimap-possibly-change-group group server))
-         articles active marks high low)
+  (let ((result (nnimap-possibly-change-group group server))
+       articles active marks high low)
+    (with-current-buffer nntp-server-buffer

       (when result
        (if (and dont-check
                 (setq active (nth 2 (assoc group nnimap-current-infos))))
       (when result
        (if (and dont-check
                 (setq active (nth 2 (assoc group nnimap-current-infos))))


@@ -344,7 +407,7 @@ not done by default on servers that doesn't support that command.")
          (with-current-buffer (nnimap-buffer)
            (erase-buffer)
            (let ((group-sequence
          (with-current-buffer (nnimap-buffer)
            (erase-buffer)
            (let ((group-sequence

-                  (nnimap-send-command "SELECT %S" (utf7-encode group)))
+                  (nnimap-send-command "SELECT %S" (utf7-encode group t)))

                  (flag-sequence
                   (nnimap-send-command "UID FETCH 1:* FLAGS")))
              (nnimap-wait-for-response flag-sequence)
                  (flag-sequence
                   (nnimap-send-command "UID FETCH 1:* FLAGS")))
              (nnimap-wait-for-response flag-sequence)


@@ -360,15 +423,28 @@ not done by default on servers that doesn't support that command.")
                (setq high (nth 3 (car marks))
                      low (nth 4 (car marks))))
               ((re-search-backward "UIDNEXT \\([0-9]+\\)" nil t)
                (setq high (nth 3 (car marks))
                      low (nth 4 (car marks))))
               ((re-search-backward "UIDNEXT \\([0-9]+\\)" nil t)

-               (setq high (string-to-number (match-string 1))
+               (setq high (1- (string-to-number (match-string 1)))

                      low 1)))))
          (erase-buffer)
          (insert
           (format
                      low 1)))))
          (erase-buffer)
          (insert
           (format

-           "211 %d %d %d %S\n"
-           (1+ (- high low))
-           low high group))))
-      t)))
+           "211 %d %d %d %S\n" (1+ (- high low)) low high group)))
+       t))))
+
+(deffoo nnimap-request-create-group (group &optional server args)
+  (when (nnimap-possibly-change-group nil server)
+    (with-current-buffer (nnimap-buffer)
+      (car (nnimap-command "CREATE %S" (utf7-encode group t))))))
+
+(deffoo nnimap-request-delete-group (group &optional force server)
+  (when (nnimap-possibly-change-group nil server)
+    (with-current-buffer (nnimap-buffer)
+      (car (nnimap-command "DELETE %S" (utf7-encode group t))))))
+
+(deffoo nnimap-request-expunge-group (group &optional server)
+  (when (nnimap-possibly-change-group group server)
+    (with-current-buffer (nnimap-buffer)
+      (car (nnimap-command "EXPUNGE")))))

 
 (defun nnimap-get-flags (spec)
   (let ((articles nil)
 
 (defun nnimap-get-flags (spec)
   (let ((articles nil)


@@ -390,22 +466,23 @@ not done by default on servers that doesn't support that command.")
 
 (deffoo nnimap-request-move-article (article group server accept-form
                                             &optional last internal-move-group)
 
 (deffoo nnimap-request-move-article (article group server accept-form
                                             &optional last internal-move-group)

-  (when (nnimap-possibly-change-group group server)
-    ;; If the move is internal (on the same server), just do it the easy
-    ;; way.
-    (let ((message-id (message-field-value "message-id")))
-      (if internal-move-group
-         (let ((result
-                (with-current-buffer (nnimap-buffer)
-                  (nnimap-command "UID COPY %d %S"
-                                  article
-                                  (utf7-encode internal-move-group t)))))
-           (when (car result)
-             (nnimap-delete-article article)
-             (cons internal-move-group
-                   (nnimap-find-article-by-message-id
-                    internal-move-group message-id))))
-       (with-temp-buffer
+  (with-temp-buffer
+    (when (nnimap-request-article article group server (current-buffer))
+      ;; If the move is internal (on the same server), just do it the easy
+      ;; way.
+      (let ((message-id (message-field-value "message-id")))
+       (if internal-move-group
+           (let ((result
+                  (with-current-buffer (nnimap-buffer)
+                    (nnimap-command "UID COPY %d %S"
+                                    article
+                                    (utf7-encode internal-move-group t)))))
+             (when (car result)
+               (nnimap-delete-article article)
+               (cons internal-move-group
+                     (nnimap-find-article-by-message-id
+                      internal-move-group message-id))))
+         ;; Move the article to a different method.

          (let ((result (eval accept-form)))
            (when result
              (nnimap-delete-article article)
          (let ((result (eval accept-form)))
            (when result
              (nnimap-delete-article article)


@@ -413,14 +490,71 @@ not done by default on servers that doesn't support that command.")
 
 (deffoo nnimap-request-expire-articles (articles group &optional server force)
   (cond
 
 (deffoo nnimap-request-expire-articles (articles group &optional server force)
   (cond

+   ((null articles)
+    nil)

    ((not (nnimap-possibly-change-group group server))
     articles)
    ((not (nnimap-possibly-change-group group server))
     articles)

-   (force
+   ((and force
+        (eq nnmail-expiry-target 'delete))

     (unless (nnimap-delete-article articles)
       (message "Article marked for deletion, but not expunged."))
     nil)
    (t
     (unless (nnimap-delete-article articles)
       (message "Article marked for deletion, but not expunged."))
     nil)
    (t

-    articles)))
+    (let ((deletable-articles
+          (if force
+              articles
+            (gnus-sorted-intersection
+             articles
+             (nnimap-find-expired-articles group)))))
+      (if (null deletable-articles)
+         articles
+       (if (eq nnmail-expiry-target 'delete)
+           (nnimap-delete-article deletable-articles)
+         (setq deletable-articles
+               (nnimap-process-expiry-targets
+                deletable-articles group server)))
+       ;; Return the articles we didn't delete.
+       (gnus-sorted-complement articles deletable-articles))))))
+
+(defun nnimap-process-expiry-targets (articles group server)
+  (let ((deleted-articles nil))
+    (dolist (article articles)
+      (let ((target nnmail-expiry-target))
+       (with-temp-buffer
+         (when (nnimap-request-article article group server (current-buffer))
+           (message "Expiring article %s:%d" group article)
+           (when (functionp target)
+             (setq target (funcall target group)))
+           (when (and target
+                      (not (eq target 'delete)))
+             (if (or (gnus-request-group target t)
+                     (gnus-request-create-group target))
+                 (nnmail-expiry-target-group target group)
+               (setq target nil)))
+           (when target
+             (push article deleted-articles))))))
+    ;; Change back to the current group again.
+    (nnimap-possibly-change-group group server)
+    (setq deleted-articles (nreverse deleted-articles))
+    (nnimap-delete-article deleted-articles)
+    deleted-articles))
+
+(defun nnimap-find-expired-articles (group)
+  (let ((cutoff (nnmail-expired-article-p group nil nil)))
+    (with-current-buffer (nnimap-buffer)
+      (let ((result
+            (nnimap-command
+             "UID SEARCH SENTBEFORE %s"
+             (format-time-string
+              (format "%%d-%s-%%Y"
+                      (upcase
+                       (car (rassoc (nth 4 (decode-time cutoff))
+                                    parse-time-months))))
+              cutoff))))
+       (and (car result)
+            (delete 0 (mapcar #'string-to-number
+                              (cdr (assoc "SEARCH" (cdr result))))))))))
+

 
 (defun nnimap-find-article-by-message-id (group message-id)
   (when (nnimap-possibly-change-group group nil)
 
 (defun nnimap-find-article-by-message-id (group message-id)
   (when (nnimap-possibly-change-group group nil)


@@ -438,10 +572,17 @@ not done by default on servers that doesn't support that command.")
   (with-current-buffer (nnimap-buffer)
     (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
                    (nnimap-article-ranges articles))
   (with-current-buffer (nnimap-buffer)
     (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
                    (nnimap-article-ranges articles))

-    (when (member "UIDPLUS" (nnimap-capabilities nnimap-object))
-      (nnimap-send-command "UID EXPUNGE %s"
-                          (nnimap-article-ranges articles))
-      t)))
+    (cond
+     ((member "UIDPLUS" (nnimap-capabilities nnimap-object))
+      (nnimap-command "UID EXPUNGE %s"
+                     (nnimap-article-ranges articles))
+      t)
+     (nnimap-expunge
+      (nnimap-command "EXPUNGE")
+      t)
+     (t (gnus-message 7 (concat "nnimap: nnimap-expunge is not set and the "
+                                "server doesn't support UIDPLUS, so we won't "
+                                "delete this article now"))))))

 
 (deffoo nnimap-request-scan (&optional group server)
   (when (and (nnimap-possibly-change-group nil server)
 
 (deffoo nnimap-request-scan (&optional group server)
   (when (and (nnimap-possibly-change-group nil server)


@@ -476,7 +617,8 @@ not done by default on servers that doesn't support that command.")
                                (mapconcat #'identity flags " ")))))))
        ;; Wait for the last command to complete to avoid later
        ;; syncronisation problems with the stream.
                                (mapconcat #'identity flags " ")))))))
        ;; Wait for the last command to complete to avoid later
        ;; syncronisation problems with the stream.

-       (nnimap-wait-for-response sequence)))))
+       (when sequence
+         (nnimap-wait-for-response sequence))))))

 
 (deffoo nnimap-request-accept-article (group &optional server last)
   (when (nnimap-possibly-change-group nil server)
 
 (deffoo nnimap-request-accept-article (group &optional server last)
   (when (nnimap-possibly-change-group nil server)


@@ -809,7 +951,9 @@ not done by default on servers that doesn't support that command.")
     (if (equal (caar response) "OK")
        (cons t response)
       (nnheader-report 'nnimap "%s"
     (if (equal (caar response) "OK")
        (cons t response)
       (nnheader-report 'nnimap "%s"

-                      (mapconcat #'identity (car response) " "))
+                      (mapconcat (lambda (a)
+                                   (format "%s" a))
+                                 (car response) " "))

       nil)))
 
 (defun nnimap-get-response (sequence)
       nil)))
 
 (defun nnimap-get-response (sequence)


@@ -821,21 +965,25 @@ not done by default on servers that doesn't support that command.")
     (goto-char (point-min))
     (while (and (memq (process-status process)
                      '(open run))
     (goto-char (point-min))
     (while (and (memq (process-status process)
                      '(open run))

-               (not (re-search-forward "^\\* " nil t)))
+               (not (re-search-forward "^\\* .*\n" nil t)))

       (nnheader-accept-process-output process)
       (goto-char (point-min)))
       (nnheader-accept-process-output process)
       (goto-char (point-min)))

-    (and (looking-at "[A-Z0-9]+")
-        (match-string 0))))
+    (forward-line -1)
+    (and (looking-at "\\* \\([A-Z0-9]+\\)")
+        (match-string 1))))

 
 (defun nnimap-wait-for-response (sequence &optional messagep)
 
 (defun nnimap-wait-for-response (sequence &optional messagep)

-  (goto-char (point-max))
-  (while (not (re-search-backward (format "^%d .*\n" sequence)
-                                 (max (point-min) (- (point) 500))
-                                 t))
-    (when messagep
-      (message "Read %dKB" (/ (buffer-size) 1000)))
-    (nnheader-accept-process-output (get-buffer-process (current-buffer)))
-    (goto-char (point-max))))
+  (let ((process (get-buffer-process (current-buffer))))
+    (goto-char (point-max))
+    (while (and (memq (process-status process)
+                     '(open run))
+               (not (re-search-backward (format "^%d .*\n" sequence)
+                                        (max (point-min) (- (point) 500))
+                                        t)))
+      (when messagep
+       (message "Read %dKB" (/ (buffer-size) 1000)))
+      (nnheader-accept-process-output process)
+      (goto-char (point-max)))))

 
 (defun nnimap-parse-response ()
   (let ((lines (split-string (nnimap-last-response-string) "\r\n" t))
 
 (defun nnimap-parse-response ()
   (let ((lines (split-string (nnimap-last-response-string) "\r\n" t))


@@ -914,7 +1062,7 @@ not done by default on servers that doesn't support that command.")
                 "BODY.PEEK[HEADER] BODY.PEEK"
               "RFC822.PEEK"))
            (if nnimap-split-download-body-default
                 "BODY.PEEK[HEADER] BODY.PEEK"
               "RFC822.PEEK"))
            (if nnimap-split-download-body-default

-               ""
+               "[]"

              "[1]")))
    t))
 
              "[1]")))
    t))
 


@@ -966,17 +1114,19 @@ not done by default on servers that doesn't support that command.")
 (defun nnimap-mark-and-expunge-incoming (range)
   (when range
     (setq range (nnimap-article-ranges range))
 (defun nnimap-mark-and-expunge-incoming (range)
   (when range
     (setq range (nnimap-article-ranges range))

-    (nnimap-send-command
-     "UID STORE %s +FLAGS.SILENT (\\Deleted)" range)
-    (cond
-     ;; If the server supports it, we now delete the message we have
-     ;; just copied over.
-     ((member "UIDPLUS" (nnimap-capabilities nnimap-object))
-      (nnimap-send-command "UID EXPUNGE %s" range))
-     ;; If it doesn't support UID EXPUNGE, then we only expunge if the
-     ;; user has configured it.
-     (nnimap-expunge-inbox
-      (nnimap-send-command "EXPUNGE")))))
+    (let ((sequence
+          (nnimap-send-command
+           "UID STORE %s +FLAGS.SILENT (\\Deleted)" range)))
+      (cond
+       ;; If the server supports it, we now delete the message we have
+       ;; just copied over.
+       ((member "UIDPLUS" (nnimap-capabilities nnimap-object))
+       (setq sequence (nnimap-send-command "UID EXPUNGE %s" range)))
+       ;; If it doesn't support UID EXPUNGE, then we only expunge if the
+       ;; user has configured it.
+       (nnimap-expunge
+       (setq sequence (nnimap-send-command "EXPUNGE"))))
+      (nnimap-wait-for-response sequence))))

 
 (defun nnimap-parse-copied-articles (sequences)
   (let (sequence copied range)
 
 (defun nnimap-parse-copied-articles (sequences)
   (let (sequence copied range)