[PATCH] RFC4731 for lisp/net/imap.el

[Vitaly Mayatskikh]

Hi!

I've added support for "IMAP4 Extension to SEARCH Command for Controlling
What Kind of Information Is Returned". It allows Gnus to uses some nice
features like very fast searching of minuid/maxuid or retrieving results
for SEARCH command in sequence-set. Also patch automatically routes query
from imap-search routine to the new imap-esearch when possible, as it
significantly reduces amount of consumed traffic.

Patch was tested with Zimbra server and it works well so far.

diff -puw lisp/net/imap.el.orig lisp/net/imap.el
--- lisp/net/imap.el.orig       2008-05-06 09:31:46.000000000 +0200
+++ lisp/net/imap.el    2008-08-14 10:40:31.000000000 +0200
@@ -1721,6 +1721,8 @@ is non-nil return these properties."
      (imap-message-get ,uid 'BODY)))
 
 (defun imap-search (predicate &optional buffer)
+  (if (imap-capability 'ESEARCH)
+      (car (imap-esearch (concat "UID SEARCH RETURN (ALL) " predicate) '(ALL)))
   (with-current-buffer (or buffer (current-buffer))
     (imap-mailbox-put 'search 'dummy)
     (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))
@@ -1728,7 +1730,39 @@ is non-nil return these properties."
          (progn
            (message "Missing SEARCH response to a SEARCH command (server not 
RFC compliant)...")
            nil)
-       (imap-mailbox-get-1 'search imap-current-mailbox)))))
+         (imap-mailbox-get-1 'search imap-current-mailbox))))))
+
+(defun imap-esearch (query tags &optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-mailbox-put 'esearch 'dummy)
+    (when (imap-ok-p (imap-send-command-wait query))
+      (if (eq (imap-mailbox-get-1 'esearch imap-current-mailbox) 'dummy)
+         (progn
+           (message "Missing ESEARCH response to a SEARCH command (server not 
RFC compliant)...")
+           nil)
+       (let ((answer (imap-mailbox-get-1 'esearch imap-current-mailbox))
+             tag result)
+         (while answer
+           (setq tag (intern (upcase (car answer))))
+           (cond ((eq tag 'UID)
+                  nil)
+                 ((memq tag tags)
+                  (setq result
+                        (append result
+                                (list
+                                 (if (eq tag 'ALL)
+                                     (gnus-uncompress-range 
+                                      (mapcar #'(lambda (x)
+                                                  (let ((y (split-string x 
":")))
+                                                    (if (null (cdr y))
+                                                        (string-to-number (car 
y))
+                                                      (cons (string-to-number 
(car y))
+                                                            (string-to-number 
(cadr y))))))
+                                              (split-string (cadr answer) 
"\,")))
+                                   (string-to-number (cadr answer)))))))
+                 (t nil))
+           (setq answer (cdr answer)))
+         result)))))
 
 (defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
   "Return t if FLAG can be permanently (between IMAP sessions) saved on 
articles, in MAILBOX on server in BUFFER."
@@ -2265,6 +2299,9 @@ Return nil if no complete line has arriv
           (SEARCH     (imap-mailbox-put
                        'search
                        (read (concat "(" (buffer-substring (point) 
(point-max)) ")"))))
+          (ESEARCH     (imap-mailbox-put
+                        'esearch
+                        (cddr (split-string (buffer-substring (point) 
(point-max)) " " "\,"))))
           (STATUS     (imap-parse-status))
           (CAPABILITY (setq imap-capability
                               (read (concat "(" (upcase (buffer-substring

Thanks!
-- 
wbr, Vitaly