X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=a53f9ac468d43b7d50b6aedede8cb1528f4818d9;hb=b337710ff9bcdbc013e6a12ce3cb4f8c934f6b2b;hp=c11e30a2f967e49e1fb131f07283a795be143a3c;hpb=f553da2f2970e179fbbf10d91dd33278f06ca76b;p=gnus diff --git a/lisp/nnimap.el b/lisp/nnimap.el index c11e30a2f..a53f9ac46 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -26,6 +26,10 @@ ;;; Code: +;; For Emacs <22.2 and XEmacs. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (eval-and-compile (require 'nnheader)) @@ -40,6 +44,11 @@ (require 'utf7) (require 'tls) (require 'parse-time) +(require 'nnmail) +(require 'proto-stream) + +(eval-when-compile + (require 'gnus-sum)) (autoload 'auth-source-forget-user-or-password "auth-source") (autoload 'auth-source-user-or-password "auth-source") @@ -54,9 +63,10 @@ If nnimap-stream is `ssl', this will default to `imaps'. If not, it will default to `imap'.") -(defvoo nnimap-stream 'ssl +(defvoo nnimap-stream 'undecided "How nnimap will talk to the IMAP server. -Values are `ssl', `network', `starttls' or `shell'.") +Values are `ssl', `network', `starttls' or `shell'. +The default is to try `ssl' first, and then `network'.") (defvoo nnimap-shell-program (if (boundp 'imap-shell-program) (if (listp imap-shell-program) @@ -74,6 +84,9 @@ Uses the same syntax as nnmail-split-methods") (defvoo nnimap-split-fancy nil "Uses the same syntax as nnmail-split-fancy.") +(defvoo nnimap-unsplittable-articles '(%Deleted %Seen) + "Articles with the flags in the list will not be considered when splitting.") + (make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'" "Emacs 24.1") @@ -114,7 +127,7 @@ textual parts.") (defstruct nnimap group process commands capabilities select-result newlinep server - last-command-time greeting) + last-command-time greeting examined) (defvar nnimap-object nil) @@ -132,6 +145,16 @@ textual parts.") (defun nnimap-buffer () (nnimap-find-process-buffer nntp-server-buffer)) +(defun nnimap-header-parameters () + (format "(UID RFC822.SIZE BODYSTRUCTURE %s)" + (format + (if (nnimap-ver4-p) + "BODY.PEEK[HEADER.FIELDS %s]" + "RFC822.HEADER.LINES %s") + (append '(Subject From Date Message-Id + References In-Reply-To Xref) + nnmail-extra-headers)))) + (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old) (with-current-buffer nntp-server-buffer (erase-buffer) @@ -142,14 +165,7 @@ textual parts.") (nnimap-send-command "UID FETCH %s %s" (nnimap-article-ranges (gnus-compress-sequence articles)) - (format "(UID RFC822.SIZE BODYSTRUCTURE %s)" - (format - (if (nnimap-ver4-p) - "BODY.PEEK[HEADER.FIELDS %s]" - "RFC822.HEADER.LINES %s") - (append '(Subject From Date Message-Id - References In-Reply-To Xref) - nnmail-extra-headers)))) + (nnimap-header-parameters)) t) (nnimap-transform-headers)) (insert-buffer-substring @@ -167,11 +183,12 @@ textual parts.") (return))) (setq article (match-string 1)) ;; Unfold quoted {number} strings. - (while (re-search-forward "[^]] {\\([0-9]+\\)}\r\n" + (while (re-search-forward "[^]][ (]{\\([0-9]+\\)}\r?\n" (1+ (line-end-position)) t) (setq size (string-to-number (match-string 1))) (delete-region (+ (match-beginning 0) 2) (point)) - (setq string (delete-region (point) (+ (point) size))) + (setq string (buffer-substring (point) (+ (point) size))) + (delete-region (point) (+ (point) size)) (insert (format "%S" string))) (setq bytes (nnimap-get-length) lines nil) @@ -196,11 +213,22 @@ textual parts.") (insert (format "Chars: %s\n" size))) (when lines (insert (format "Lines: %s\n" lines))) - (re-search-forward "^\r$") + (unless (re-search-forward "^\r$" nil t) + (goto-char (point-max))) (delete-region (line-beginning-position) (line-end-position)) (insert ".") (forward-line 1))))) +(defun nnimap-unfold-quoted-lines () + ;; Unfold quoted {number} strings. + (let (size string) + (while (re-search-forward " {\\([0-9]+\\)}\r?\n" nil t) + (setq size (string-to-number (match-string 1))) + (delete-region (1+ (match-beginning 0)) (point)) + (setq string (buffer-substring (point) (+ (point) size))) + (delete-region (point) (+ (point) size)) + (insert (format "%S" string))))) + (defun nnimap-get-length () (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t) (string-to-number (match-string 1)))) @@ -245,16 +273,6 @@ textual parts.") (push (current-buffer) nnimap-process-buffers) (current-buffer))) -(defun nnimap-open-shell-stream (name buffer host port) - (let ((process-connection-type nil)) - (start-process name buffer shell-file-name - shell-command-switch - (format-spec - nnimap-shell-program - (format-spec-make - ?s host - ?p port))))) - (defun nnimap-credentials (address ports &optional inhibit-create) (let (port credentials) ;; Request the credentials from all ports, but only query on the @@ -276,7 +294,7 @@ textual parts.") (with-current-buffer buffer (when (and nnimap-object (nnimap-last-command-time nnimap-object) - (> (time-to-seconds + (> (gnus-float-time (time-subtract now (nnimap-last-command-time nnimap-object))) @@ -285,92 +303,78 @@ textual parts.") (nnimap-send-command "NOOP"))))))) (defun nnimap-open-connection (buffer) + ;; Be backwards-compatible -- the earlier value of nnimap-stream was + ;; `ssl' when nnimap-server-port was nil. Sort of. + (when (and nnimap-server-port + (eq nnimap-stream 'undecided)) + (setq nnimap-stream 'ssl)) + (let ((stream + (if (eq nnimap-stream 'undecided) + (loop for type in '(ssl network) + for stream = (let ((nnimap-stream type)) + (nnimap-open-connection-1 buffer)) + while (eq stream 'no-connect) + finally (return stream)) + (nnimap-open-connection-1 buffer)))) + (if (eq stream 'no-connect) + nil + stream))) + +(defun nnimap-open-connection-1 (buffer) (unless nnimap-keepalive-timer (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15) 'nnimap-keepalive))) - (block nil - (with-current-buffer (nnimap-make-process-buffer buffer) - (let* ((coding-system-for-read 'binary) - (coding-system-for-write 'binary) - (port nil) - (ports - (cond - ((eq nnimap-stream 'network) - (open-network-stream - "*nnimap*" (current-buffer) nnimap-address - (setq port - (or nnimap-server-port - (if (netrc-find-service-number "imap") - "imap" - "143")))) - '("143" "imap")) - ((eq nnimap-stream 'shell) - (nnimap-open-shell-stream - "*nnimap*" (current-buffer) nnimap-address - (setq port (or nnimap-server-port "imap"))) - '("imap")) - ((eq nnimap-stream 'starttls) - (let ((tls-program (nnimap-extend-tls-programs))) - (open-tls-stream - "*nnimap*" (current-buffer) nnimap-address - (setq port (or nnimap-server-port "imap")) - 'starttls)) - '("imap")) - ((memq nnimap-stream '(ssl tls)) - (funcall (if (fboundp 'open-gnutls-stream) - 'open-gnutls-stream - 'open-tls-stream) - "*nnimap*" (current-buffer) nnimap-address - (setq port - (or nnimap-server-port - (if (netrc-find-service-number "imaps") - "imaps" - "993")))) - '("143" "993" "imap" "imaps")) - (t - (error "Unknown stream type: %s" nnimap-stream)))) - connection-result login-result credentials) - (setf (nnimap-process nnimap-object) - (get-buffer-process (current-buffer))) - (if (not (and (nnimap-process nnimap-object) - (memq (process-status (nnimap-process nnimap-object)) - '(open run)))) - (nnheader-report 'nnimap "Unable to contact %s:%s via %s" - nnimap-address port nnimap-stream) - (gnus-set-process-query-on-exit-flag - (nnimap-process nnimap-object) nil) - (if (not (setq connection-result (nnimap-wait-for-connection))) - (nnheader-report 'nnimap - "%s" (buffer-substring - (point) (line-end-position))) + (with-current-buffer (nnimap-make-process-buffer buffer) + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (port nil) + (ports + (cond + ((or (eq nnimap-stream 'network) + (eq nnimap-stream 'starttls)) + (nnheader-message 7 "Opening connection to %s..." + nnimap-address) + '("143" "imap")) + ((eq nnimap-stream 'shell) + (nnheader-message 7 "Opening connection to %s via shell..." + nnimap-address) + '("imap")) + ((memq nnimap-stream '(ssl tls)) + (nnheader-message 7 "Opening connection to %s via tls..." + nnimap-address) + '("143" "993" "imap" "imaps")) + (t + (error "Unknown stream type: %s" nnimap-stream)))) + (proto-stream-always-use-starttls t) + login-result credentials) + (when nnimap-server-port + (setq ports (append ports (list nnimap-server-port)))) + (destructuring-bind (stream greeting capabilities) + (open-protocol-stream + "*nnimap*" (current-buffer) nnimap-address (car (last ports)) + :type nnimap-stream + :shell-command nnimap-shell-program + :capability-command "1 CAPABILITY\r\n" + :success " OK " + :starttls-function + (lambda (capabilities) + (when (gnus-string-match-p "STARTTLS" capabilities) + "1 STARTTLS\r\n"))) + (setf (nnimap-process nnimap-object) stream) + (if (not stream) + (progn + (nnheader-report 'nnimap "Unable to contact %s:%s via %s" + nnimap-address port nnimap-stream) + 'no-connect) + (gnus-set-process-query-on-exit-flag stream nil) + (if (not (gnus-string-match-p "[*.] \\(OK\\|PREAUTH\\)" greeting)) + (nnheader-report 'nnimap "%s" greeting) ;; Store the greeting (for debugging purposes). - (setf (nnimap-greeting nnimap-object) - (buffer-substring (line-beginning-position) - (line-end-position))) - ;; Store the capabilities. + (setf (nnimap-greeting nnimap-object) greeting) (setf (nnimap-capabilities nnimap-object) - (mapcar - #'upcase - (nnimap-find-parameter - "CAPABILITY" (cdr (nnimap-command "CAPABILITY"))))) - (when nnimap-server-port - (push (format "%s" nnimap-server-port) ports)) - ;; If this is a STARTTLS-capable server, then sever the - ;; connection and start a STARTTLS connection instead. - (when (and (eq nnimap-stream 'network) - (member "STARTTLS" (nnimap-capabilities nnimap-object))) - (let ((nnimap-stream 'starttls)) - (let ((tls-process - (nnimap-open-connection buffer))) - ;; If the STARTTLS connection was successful, we - ;; kill our first non-encrypted connection. If it - ;; wasn't successful, we just use our unencrypted - ;; connection. - (when (memq (process-status tls-process) '(open run)) - (delete-process (nnimap-process nnimap-object)) - (kill-buffer (current-buffer)) - (return tls-process))))) - (unless (equal connection-result "PREAUTH") + (mapcar #'upcase + (split-string capabilities))) + (unless (gnus-string-match-p "[*.] PREAUTH" greeting) (if (not (setq credentials (if (eq nnimap-authenticator 'anonymous) (list "anonymous" @@ -384,9 +388,18 @@ textual parts.") ;; physical address. (nnimap-credentials nnimap-address ports))))) (setq nnimap-object nil) - (setq login-result (nnimap-command "LOGIN %S %S" - (car credentials) - (cadr credentials))) + (setq login-result + (if (and (nnimap-capability "AUTH=PLAIN") + (nnimap-capability "LOGINDISABLED")) + (nnimap-command + "AUTHENTICATE PLAIN %s" + (base64-encode-string + (format "\000%s\000%s" + (nnimap-quote-specials (car credentials)) + (nnimap-quote-specials (cadr credentials))))) + (nnimap-command "LOGIN %S %S" + (car credentials) + (cadr credentials)))) (unless (car login-result) ;; If the login failed, then forget the credentials ;; that are now possibly cached. @@ -399,22 +412,19 @@ textual parts.") (delete-process (nnimap-process nnimap-object)) (setq nnimap-object nil)))) (when nnimap-object - (when (member "QRESYNC" (nnimap-capabilities nnimap-object)) + (when (nnimap-capability "QRESYNC") (nnimap-command "ENABLE QRESYNC")) (nnimap-process nnimap-object)))))))) -(defun nnimap-extend-tls-programs () - (let ((programs tls-program) - result) - (unless (consp programs) - (setq programs (list programs))) - (dolist (program programs) - (when (assoc (car (split-string program)) tls-starttls-switches) - (push (if (not (string-match "%s" program)) - (concat program " " "%s") - program) - result))) - (nreverse result))) +(defun nnimap-quote-specials (string) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "[\\\"]" nil t) + (forward-char -1) + (insert "\\") + (forward-char 1)) + (buffer-string))) (defun nnimap-find-parameter (parameter elems) (let (result) @@ -432,6 +442,7 @@ textual parts.") (when (nnoo-change-server 'nnimap server nil) (ignore-errors (delete-process (get-buffer-process (nnimap-buffer)))) + (nnoo-close-server 'nnimap server) t)) (deffoo nnimap-request-close () @@ -465,7 +476,7 @@ textual parts.") (let ((start (point))) (forward-sexp 1) (downcase-region start (point)) - (goto-char (point)) + (goto-char start) (read (current-buffer)))) parts (nnimap-find-wanted-parts structure)))) (when (if parts @@ -478,12 +489,28 @@ textual parts.") (nnheader-ms-strip-cr) (cons group article))))))))) -(defun nnimap-get-whole-article (article) +(deffoo nnimap-request-head (article &optional group server to-buffer) + (when (nnimap-possibly-change-group group server) + (with-current-buffer (nnimap-buffer) + (when (stringp article) + (setq article (nnimap-find-article-by-message-id group article))) + (nnimap-get-whole-article + article (format "UID FETCH %%d %s" + (nnimap-header-parameters))) + (let ((buffer (current-buffer))) + (with-current-buffer (or to-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring buffer) + (nnheader-ms-strip-cr) + (cons group article)))))) + +(defun nnimap-get-whole-article (article &optional command) (let ((result (nnimap-command - (if (nnimap-ver4-p) - "UID FETCH %d BODY.PEEK[]" - "UID FETCH %d RFC822.PEEK") + (or command + (if (nnimap-ver4-p) + "UID FETCH %d BODY.PEEK[]" + "UID FETCH %d RFC822.PEEK")) article))) ;; Check that we really got an article. (goto-char (point-min)) @@ -501,8 +528,11 @@ textual parts.") (delete-region (point) (point-max))) t))) +(defun nnimap-capability (capability) + (member capability (nnimap-capabilities nnimap-object))) + (defun nnimap-ver4-p () - (member "IMAP4REV1" (nnimap-capabilities nnimap-object))) + (nnimap-capability "IMAP4REV1")) (defun nnimap-get-partial-article (article parts structure) (let ((result @@ -553,9 +583,9 @@ textual parts.") (pop bstruc)) (setq type (car bstruc)) (setq bstruc (car (cdr bstruc))) - (when (and (stringp (car bstruc)) - (string= (downcase (car bstruc)) "boundary")) - (setq boundary (cadr bstruc)))) + (let ((has-boundary (member "boundary" bstruc))) + (when has-boundary + (setq boundary (cadr has-boundary))))) (when subp (insert (format "Content-type: multipart/%s; boundary=%S\n\n" (downcase type) boundary))) @@ -605,7 +635,14 @@ textual parts.") (nreverse parts))) (deffoo nnimap-request-group (group &optional server dont-check info) - (let ((result (nnimap-possibly-change-group group server)) + (let ((result (nnimap-possibly-change-group + ;; Don't SELECT the group if we're going to select it + ;; later, anyway. + (if (and dont-check + (assoc group nnimap-current-infos)) + nil + group) + server)) articles active marks high low) (with-current-buffer nntp-server-buffer (when result @@ -622,6 +659,7 @@ textual parts.") (nnimap-send-command "SELECT %S" (utf7-encode group t))) (flag-sequence (nnimap-send-command "UID FETCH 1:* FLAGS"))) + (setf (nnimap-group nnimap-object) group) (nnimap-wait-for-response flag-sequence) (setq marks (nnimap-flags-to-marks @@ -630,7 +668,8 @@ textual parts.") 1 group "SELECT"))))) (when (and info marks) - (nnimap-update-infos marks (list info))) + (nnimap-update-infos marks (list info)) + (nnimap-store-info info (gnus-active (gnus-info-group info)))) (goto-char (point-max)) (let ((uidnext (nth 5 (car marks)))) (setq high (or (if uidnext @@ -657,9 +696,17 @@ textual parts.") (deffoo nnimap-request-rename-group (group new-name &optional server) (when (nnimap-possibly-change-group nil server) (with-current-buffer (nnimap-buffer) + (nnimap-unselect-group) (car (nnimap-command "RENAME %S %S" (utf7-encode group t) (utf7-encode new-name t)))))) +(defun nnimap-unselect-group () + ;; Make sure we don't have this group open read/write by asking + ;; to examine a mailbox that doesn't exist. This seems to be + ;; the only way that allows us to reliably go back to unselected + ;; state on Courier. + (nnimap-command "EXAMINE DOES.NOT.EXIST")) + (deffoo nnimap-request-expunge-group (group &optional server) (when (nnimap-possibly-change-group group server) (with-current-buffer (nnimap-buffer) @@ -689,7 +736,11 @@ textual parts.") (deffoo nnimap-request-move-article (article group server accept-form &optional last internal-move-group) (with-temp-buffer - (when (nnimap-request-article article group server (current-buffer)) + (mm-disable-multibyte) + (when (funcall (if internal-move-group + 'nnimap-request-head + '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"))) @@ -702,8 +753,9 @@ textual parts.") (when (car result) (nnimap-delete-article article) (cons internal-move-group - (nnimap-find-article-by-message-id - internal-move-group message-id)))) + (or (nnimap-find-uid-response "COPYUID" (cadr result)) + (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 @@ -719,7 +771,7 @@ textual parts.") ((and force (eq nnmail-expiry-target 'delete)) (unless (nnimap-delete-article (gnus-compress-sequence articles)) - (message "Article marked for deletion, but not expunged.")) + (nnheader-message 7 "Article marked for deletion, but not expunged.")) nil) (t (let ((deletable-articles @@ -744,8 +796,9 @@ textual parts.") (dolist (article articles) (let ((target nnmail-expiry-target)) (with-temp-buffer + (mm-disable-multibyte) (when (nnimap-request-article article group server (current-buffer)) - (message "Expiring article %s:%d" group article) + (nnheader-message 7 "Expiring article %s:%d" group article) (when (functionp target) (setq target (funcall target group))) (when (and target @@ -782,8 +835,10 @@ textual parts.") (defun nnimap-find-article-by-message-id (group message-id) (with-current-buffer (nnimap-buffer) (erase-buffer) - (setf (nnimap-group nnimap-object) nil) - (nnimap-send-command "EXAMINE %S" (utf7-encode group t)) + (unless (equal group (nnimap-group nnimap-object)) + (setf (nnimap-group nnimap-object) nil) + (setf (nnimap-examined nnimap-object) group) + (nnimap-send-command "EXAMINE %S" (utf7-encode group t))) (let ((sequence (nnimap-send-command "UID SEARCH HEADER Message-Id %S" message-id)) article result) @@ -800,7 +855,7 @@ textual parts.") (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)" (nnimap-article-ranges articles)) (cond - ((member "UIDPLUS" (nnimap-capabilities nnimap-object)) + ((nnimap-capability "UIDPLUS") (nnimap-command "UID EXPUNGE %s" (nnimap-article-ranges articles)) t) @@ -815,7 +870,7 @@ textual parts.") (when (and (nnimap-possibly-change-group nil server) nnimap-inbox nnimap-split-methods) - (message "nnimap %s splitting mail..." server) + (nnheader-message 7 "nnimap %s splitting mail..." server) (nnimap-split-incoming-mail))) (defun nnimap-marks-to-flags (marks) @@ -839,9 +894,10 @@ textual parts.") (setq sequence (nnimap-send-command "UID STORE %s %sFLAGS.SILENT (%s)" (nnimap-article-ranges range) - (if (eq action 'del) - "-" - "+") + (cond + ((eq action 'del) "-") + ((eq action 'add) "+") + ((eq action 'set) "")) (mapconcat #'identity flags " "))))))) ;; Wait for the last command to complete to avoid later ;; syncronisation problems with the stream. @@ -854,11 +910,18 @@ textual parts.") (let ((message-id (message-field-value "message-id")) sequence message) (nnimap-add-cr) - (setq message (buffer-string)) + (setq message (buffer-substring-no-properties (point-min) (point-max))) (with-current-buffer (nnimap-buffer) + ;; If we have this group open read-only, then unselect it + ;; before appending to it. + (when (equal (nnimap-examined nnimap-object) group) + (nnimap-unselect-group)) + (erase-buffer) (setq sequence (nnimap-send-command "APPEND %S {%d}" (utf7-encode group t) (length message))) + (unless nnimap-streaming + (nnimap-wait-for-connection "^[+]")) (process-send-string (get-buffer-process (current-buffer)) message) (process-send-string (get-buffer-process (current-buffer)) (if (nnimap-newlinep nnimap-object) @@ -867,10 +930,36 @@ textual parts.") (let ((result (nnimap-get-response sequence))) (if (not (car result)) (progn - (message "%s" (nnheader-get-report-string 'nnimap)) + (nnheader-message 7 "%s" (nnheader-get-report-string 'nnimap)) nil) (cons group - (nnimap-find-article-by-message-id group message-id)))))))) + (or (nnimap-find-uid-response "APPENDUID" (car result)) + (nnimap-find-article-by-message-id + group message-id))))))))) + +(defun nnimap-find-uid-response (name list) + (let ((result (car (last (nnimap-find-response-element name list))))) + (and result + (string-to-number result)))) + +(defun nnimap-find-response-element (name list) + (let (result) + (dolist (elem list) + (when (and (consp elem) + (equal name (car elem))) + (setq result elem))) + result)) + +(deffoo nnimap-request-replace-article (article group buffer) + (let (group-art) + (when (and (nnimap-possibly-change-group group nil) + ;; Put the article into the group. + (with-current-buffer buffer + (setq group-art + (nnimap-request-accept-article group nil t)))) + (nnimap-delete-article (list article)) + ;; Return the new article number. + (cdr group-art)))) (defun nnimap-add-cr () (goto-char (point-min)) @@ -878,15 +967,25 @@ textual parts.") (replace-match "\r\n" t t))) (defun nnimap-get-groups () - (let ((result (nnimap-command "LIST \"\" \"*\"")) + (erase-buffer) + (let ((sequence (nnimap-send-command "LIST \"\" \"*\"")) groups) - (when (car result) - (dolist (line (cdr result)) - (when (and (equal (car line) "LIST") - (not (and (caadr line) - (string-match "noselect" (caadr line))))) - (push (car (last line)) groups))) - (nreverse groups)))) + (nnimap-wait-for-response sequence) + (subst-char-in-region (point-min) (point-max) + ?\\ ?% t) + (goto-char (point-min)) + (nnimap-unfold-quoted-lines) + (goto-char (point-min)) + (while (search-forward "* LIST " nil t) + (let ((flags (read (current-buffer))) + (separator (read (current-buffer))) + (group (read (current-buffer)))) + (unless (member '%NoSelect flags) + (push (if (stringp group) + group + (format "%s" group)) + groups)))) + (nreverse groups))) (deffoo nnimap-request-list (&optional server) (nnimap-possibly-change-group nil server) @@ -900,6 +999,7 @@ textual parts.") (with-current-buffer (nnimap-buffer) (setf (nnimap-group nnimap-object) nil) (dolist (group groups) + (setf (nnimap-examined nnimap-object) group) (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t)) group) sequences)) @@ -948,8 +1048,7 @@ textual parts.") (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))) + (let ((qresyncp (nnimap-capability "QRESYNC")) 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. @@ -959,13 +1058,15 @@ textual parts.") active (cdr (assq 'active params)) uidvalidity (cdr (assq 'uidvalidity params)) modseq (cdr (assq 'modseq params))) + (setf (nnimap-examined nnimap-object) group) (if (and qresyncp uidvalidity modseq) (push - (list 'qresync - (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))" - group uidvalidity modseq) + (list (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))" + (utf7-encode group t) + uidvalidity modseq) + 'qresync nil group 'qresync) sequences) (let ((start @@ -982,15 +1083,11 @@ textual parts.") ;; examine), but will tell us whether the group ;; is read-only or not. "SELECT"))) - (push (list (nnimap-send-command "%s %S" command group) + (push (list (nnimap-send-command "%s %S" command + (utf7-encode group t)) (nnimap-send-command "UID FETCH %d:* FLAGS" start) start group command) - sequences))) - ;; Some servers apparently can't have many outstanding - ;; commands, so throttle them. - (when (and (not nnimap-streaming) - (car sequences)) - (nnimap-wait-for-response (caar sequences)))) + sequences)))) sequences)))) (deffoo nnimap-finish-retrieve-group-infos (server infos sequences) @@ -998,7 +1095,10 @@ textual parts.") (nnimap-possibly-change-group nil server)) (with-current-buffer (nnimap-buffer) ;; Wait for the final data to trickle in. - (when (nnimap-wait-for-response (cadar sequences) t) + (when (nnimap-wait-for-response (if (eq (cadar sequences) 'qresync) + (caar sequences) + (cadar sequences)) + t) ;; 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. @@ -1028,13 +1128,16 @@ textual parts.") (defun nnimap-update-info (info marks) (destructuring-bind (existing flags high low uidnext start-article - permanent-flags uidvalidity) marks + permanent-flags uidvalidity + vanished highestmodseq) marks (cond ;; Ignore groups with no UIDNEXT/marks. This happens for ;; completely empty groups. ((and (not existing) (not uidnext)) - ) + (let ((active (cdr (assq 'active (gnus-info-params info))))) + (when active + (gnus-set-active (gnus-info-group info) active)))) ;; 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. @@ -1043,12 +1146,15 @@ textual parts.") (and old-uidvalidity (not (equal old-uidvalidity uidvalidity)) (> start-article 1))) - (gnus-group-remove-parameter info 'uidvalidity)) + (gnus-group-remove-parameter info 'uidvalidity) + (gnus-group-remove-parameter info 'modseq)) ;; 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))) + (active (or (gnus-active group) + (cdr (assq 'active (gnus-info-params info)))))) (when uidnext (setq high (1- uidnext))) ;; First set the active ranges based on high/low. @@ -1056,6 +1162,11 @@ textual parts.") (not (gnus-active group))) (gnus-set-active group (cond + (active + (cons (min (or low (car active)) + (car active)) + (max (or high (cdr active)) + (cdr active)))) ((and low high) (cons low high)) (uidnext @@ -1068,63 +1179,121 @@ textual parts.") nil))) (gnus-set-active group - (cons (car (gnus-active group)) + (cons (car active) (or high (1- uidnext))))) ;; 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 + (and (or (memq '%* permanent-flags) + (memq '%Seen permanent-flags)) + permanent-flags))) + ;; 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))) + (when (setq permanent-flags + (cdr (assq 'permanent-flags (gnus-info-params info)))) + (if (and highestmodseq + (not start-article)) + ;; We've gotten the data by QRESYNCing. + (nnimap-update-qresync-info + info existing (nnimap-imap-ranges-to-gnus-ranges vanished) flags) + ;; Do normal non-QRESYNC flag updates. + ;; 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))) + (when (or (not (listp permanent-flags)) + (memq '%Seen permanent-flags)) + (gnus-info-set-read info read)) + ;; Update the marks. + (setq marks (gnus-info-marks info)) + (dolist (type (cdr nnimap-mark-alist)) + (when (or (not (listp permanent-flags)) + (memq (car (assoc (caddr type) flags)) + permanent-flags) + (memq '%* permanent-flags)) + (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) + (gnus-group-set-parameter info 'modseq highestmodseq) (nnimap-store-info info (gnus-active group))))))) +(defun nnimap-update-qresync-info (info existing vanished flags) + ;; Add all the vanished articles to the list of read articles. + (gnus-info-set-read + info + (gnus-add-to-range + (gnus-add-to-range + (gnus-range-add (gnus-info-read info) + vanished) + (cdr (assq '%Flagged flags))) + (cdr (assq '%Seen flags)))) + (let ((marks (gnus-info-marks info))) + (dolist (type (cdr nnimap-mark-alist)) + (let ((ticks (assoc (car type) marks)) + (new-marks + (cdr (or (assoc (caddr type) flags) ; %Flagged + (assoc (intern (cadr type) obarray) flags) + (assoc (cadr type) flags))))) ; "\Flagged" + (setq marks (delq ticks marks)) + (pop ticks) + ;; Add the new marks we got. + (setq ticks (gnus-add-to-range ticks new-marks)) + ;; Remove the marks from messages that don't have them. + (setq ticks (gnus-remove-from-range + ticks + (gnus-compress-sequence + (gnus-sorted-complement existing new-marks)))) + (when ticks + (push (cons (car type) ticks) marks))) + (gnus-info-set-marks info marks t)))) + +(defun nnimap-imap-ranges-to-gnus-ranges (irange) + (if (zerop (length irange)) + nil + (let ((result nil)) + (dolist (elem (split-string irange ",")) + (push + (if (string-match ":" elem) + (let ((numbers (split-string elem ":"))) + (cons (string-to-number (car numbers)) + (string-to-number (cadr numbers)))) + (string-to-number elem)) + result)) + (nreverse result)))) + (defun nnimap-store-info (info active) (let* ((group (gnus-group-real-name (gnus-info-group info))) (entry (assoc group nnimap-current-infos))) @@ -1134,14 +1303,16 @@ textual parts.") (defun nnimap-flags-to-marks (groups) (let (data group totalp uidnext articles start-article mark permanent-flags - uidvalidity) + uidvalidity vanished highestmodseq) (dolist (elem groups) (setq group (car elem) uidnext (nth 1 elem) start-article (nth 2 elem) permanent-flags (nth 3 elem) uidvalidity (nth 4 elem) - articles (nthcdr 5 elem)) + vanished (nth 5 elem) + highestmodseq (nth 6 elem) + articles (nthcdr 7 elem)) (let ((high (caar articles)) marks low existing) (dolist (article articles) @@ -1153,7 +1324,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 - permanent-flags uidvalidity) + permanent-flags uidvalidity vanished highestmodseq) data))) data)) @@ -1163,13 +1334,13 @@ textual parts.") (subst-char-in-region (point-min) (point-max) ?\\ ?% t) (let (start end articles groups uidnext elems permanent-flags - uidvalidity) + uidvalidity vanished highestmodseq) (dolist (elem sequences) (destructuring-bind (group-sequence flag-sequence totalp group command) elem (setq start (point)) - ;; The EXAMINE was successful. (when (and + ;; The EXAMINE was successful. (search-forward (format "\n%d OK " group-sequence) nil t) (progn (forward-line 1) @@ -1189,24 +1360,42 @@ textual parts.") (goto-char start) (setq uidvalidity (and (re-search-forward "UIDVALIDITY \\([0-9]+\\)" - (or end (point-min)) t) + (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 start) + (setq vanished + (and (eq flag-sequence 'qresync) + (re-search-forward "VANISHED.* \\([0-9:,]+\\)" + (or end (point-min)) t) + (match-string 1))) + (goto-char start) + (setq highestmodseq + (and (search-forward "HIGHESTMODSEQ " + (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)) - (setq start (point)) - (goto-char end) - (while (search-forward " FETCH " start t) + (or (eq flag-sequence 'qresync) + (search-forward (format "\n%d OK " flag-sequence) nil t))) + (if (eq flag-sequence 'qresync) + (progn + (goto-char start) + (setq start end)) + (setq start (point)) + (goto-char end)) + (while (re-search-forward "^\\* [0-9]+ FETCH " start t) (setq elems (read (current-buffer))) (push (cons (cadr (memq 'UID elems)) (cadr (memq 'FLAGS elems))) articles)) - (push (nconc (list group uidnext totalp permanent-flags uidvalidity) + (push (nconc (list group uidnext totalp permanent-flags uidvalidity + vanished highestmodseq) articles) groups) + (goto-char end) (setq articles nil)))) groups)) @@ -1217,6 +1406,25 @@ textual parts.") (setq nnimap-status-string "Read-only server") nil) +(deffoo nnimap-request-thread (id) + (let* ((refs (split-string + (or (mail-header-references (gnus-summary-article-header)) + ""))) + (cmd (let ((value + (format + "(OR HEADER REFERENCES %s HEADER Message-Id %s)" + id id))) + (dolist (refid refs value) + (setq value (format + "(OR (OR HEADER Message-Id %s HEADER REFERENCES %s) %s)" + refid refid value))))) + (result (with-current-buffer (nnimap-buffer) + (nnimap-command "UID SEARCH %s" cmd)))) + (gnus-fetch-headers + (and (car result) (delete 0 (mapcar #'string-to-number + (cdr (assoc "SEARCH" (cdr result)))))) + nil t))) + (defun nnimap-possibly-change-group (group server) (let ((open-result t)) (when (and server @@ -1261,6 +1469,10 @@ textual parts.") (if (nnimap-newlinep nnimap-object) "" "\r")))) + ;; Some servers apparently can't have many outstanding + ;; commands, so throttle them. + (unless nnimap-streaming + (nnimap-wait-for-response nnimap-sequence)) nnimap-sequence) (defun nnimap-log-command (command) @@ -1286,12 +1498,14 @@ textual parts.") (nnimap-wait-for-response sequence) (nnimap-parse-response)) -(defun nnimap-wait-for-connection () +(defun nnimap-wait-for-connection (&optional regexp) + (unless regexp + (setq regexp "^[*.] .*\n")) (let ((process (get-buffer-process (current-buffer)))) (goto-char (point-min)) (while (and (memq (process-status process) '(open run)) - (not (re-search-forward "^[*.] .*\n" nil t))) + (not (re-search-forward regexp nil t))) (nnheader-accept-process-output process) (goto-char (point-min))) (forward-line -1) @@ -1301,20 +1515,28 @@ textual parts.") (defun nnimap-wait-for-response (sequence &optional messagep) (let ((process (get-buffer-process (current-buffer))) openp) - (goto-char (point-max)) - (while (and (setq openp (memq (process-status process) - '(open run))) - (not (re-search-backward - (format "^%d .*\n" sequence) - (if nnimap-streaming - (max (point-min) (- (point) 500)) - (point-min)) - t))) - (when messagep - (message "nnimap read %dk" (/ (buffer-size) 1000))) - (nnheader-accept-process-output process) - (goto-char (point-max))) - openp)) + (condition-case nil + (progn + (goto-char (point-max)) + (while (and (setq openp (memq (process-status process) + '(open run))) + (not (re-search-backward + (format "^%d .*\n" sequence) + (if nnimap-streaming + (max (point-min) (- (point) 500)) + (point-min)) + t))) + (when messagep + (nnheader-message 7 "nnimap read %dk" (/ (buffer-size) 1000))) + (nnheader-accept-process-output process) + (goto-char (point-max))) + openp) + (quit + ;; The user hit C-g while we were waiting: kill the process, in case + ;; it's a gnutls-cli process that's stuck (tends to happen a lot behind + ;; NAT routers). + (delete-process process) + nil)))) (defun nnimap-parse-response () (let ((lines (split-string (nnimap-last-response-string) "\r\n" t)) @@ -1332,6 +1554,7 @@ textual parts.") (defun nnimap-parse-line (line) (let (char result) (with-temp-buffer + (mm-disable-multibyte) (insert line) (goto-char (point-min)) (while (not (eobp)) @@ -1343,12 +1566,16 @@ textual parts.") (split-string (buffer-substring (1+ (point)) - (1- (search-forward "]" (line-end-position) 'move))))) + (if (search-forward "]" (line-end-position) 'move) + (1- (point)) + (point))))) ((eql char ?\() (split-string (buffer-substring (1+ (point)) - (1- (search-forward ")" (line-end-position) 'move))))) + (if (search-forward ")" (line-end-position) 'move) + (1- (point)) + (point))))) ((eql char ?\") (forward-char 1) (buffer-substring @@ -1416,6 +1643,7 @@ textual parts.") new-articles) (erase-buffer) (nnimap-command "SELECT %S" nnimap-inbox) + (setf (nnimap-group nnimap-object) nnimap-inbox) (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*"))) (when new-articles (nnimap-fetch-inbox new-articles) @@ -1468,7 +1696,7 @@ textual parts.") (cond ;; If the server supports it, we now delete the message we have ;; just copied over. - ((member "UIDPLUS" (nnimap-capabilities nnimap-object)) + ((nnimap-capability "UIDPLUS") (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. @@ -1488,9 +1716,8 @@ textual parts.") (defun nnimap-new-articles (flags) (let (new) (dolist (elem flags) - (when (or (null (cdr elem)) - (and (not (memq '%Deleted (cdr elem))) - (not (memq '%Seen (cdr elem))))) + (unless (gnus-list-memq-of-list nnimap-unsplittable-articles + (cdr elem)) (push (car elem) new))) (gnus-compress-sequence (nreverse new)))) @@ -1525,8 +1752,10 @@ textual parts.") (forward-char (1+ bytes)) (setq bytes (nnimap-get-length)) (delete-region (line-beginning-position) (line-end-position)) - (forward-char (1+ bytes)) - (delete-region (line-beginning-position) (line-end-position)))))) + ;; There's a body; skip past that. + (when bytes + (forward-char (1+ bytes)) + (delete-region (line-beginning-position) (line-end-position))))))) (defun nnimap-dummy-active-number (group &optional server) 1)