X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=6882ed63135df3801fcd162d6d2e500557340f6b;hb=f9b7cf1052718555ece040f07e5b7d9e4bf0fc30;hp=cb4c9f0108ce663d02cb1491a404415d0d907f34;hpb=379ed83162f175ca88ec8c34cb6ffb4e2bc08fae;p=gnus diff --git a/lisp/nnimap.el b/lisp/nnimap.el index cb4c9f010..6882ed631 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -1,6 +1,6 @@ ;;; nnimap.el --- IMAP interface for Gnus -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010-2011 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Simon Josefsson @@ -31,7 +31,11 @@ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-and-compile - (require 'nnheader)) + (require 'nnheader) + ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for + ;; `make-network-stream'. + (unless (fboundp 'open-protocol-stream) + (require 'proto-stream))) (eval-when-compile (require 'cl)) @@ -46,25 +50,29 @@ (require 'parse-time) (require 'nnmail) -(eval-when-compile - (require 'gnus-sum)) - -(autoload 'auth-source-forget-user-or-password "auth-source") -(autoload 'auth-source-user-or-password "auth-source") +(autoload 'auth-source-forget+ "auth-source") +(autoload 'auth-source-search "auth-source") (nnoo-declare nnimap) (defvoo nnimap-address nil "The address of the IMAP server.") +(defvoo nnimap-user nil + "Username to use for authentication to the IMAP server.") + (defvoo nnimap-server-port nil "The IMAP port used. If nnimap-stream is `ssl', this will default to `imaps'. If not, it will default to `imap'.") -(defvoo nnimap-stream 'ssl - "How nnimap will talk to the IMAP server. -Values are `ssl', `network', `starttls' or `shell'.") +(defvoo nnimap-stream 'undecided + "How nnimap talks to the IMAP server. +The value should be either `undecided', `ssl' or `tls', +`network', `starttls', `plain', or `shell'. + +If the value is `undecided', nnimap tries `ssl' first, then falls +back on `network'.") (defvoo nnimap-shell-program (if (boundp 'imap-shell-program) (if (listp imap-shell-program) @@ -73,14 +81,15 @@ Values are `ssl', `network', `starttls' or `shell'.") "ssh %s imapd")) (defvoo nnimap-inbox nil - "The mail box where incoming mail arrives and should be split out of.") + "The mail box where incoming mail arrives and should be split out of. +For example, \"INBOX\".") (defvoo nnimap-split-methods nil "How mail is split. -Uses the same syntax as nnmail-split-methods") +Uses the same syntax as `nnmail-split-methods'.") (defvoo nnimap-split-fancy nil - "Uses the same syntax as nnmail-split-fancy.") + "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.") @@ -125,7 +134,7 @@ textual parts.") (defstruct nnimap group process commands capabilities select-result newlinep server - last-command-time greeting examined) + last-command-time greeting examined stream-type) (defvar nnimap-object nil) @@ -140,6 +149,11 @@ textual parts.") (download "gnus-download") (forward "gnus-forward"))) +(defvar nnimap-quirks + '(("QRESYNC" "Zimbra" "QRESYNC "))) + +(defvar nnimap-inhibit-logging nil) + (defun nnimap-buffer () (nnimap-find-process-buffer nntp-server-buffer)) @@ -165,7 +179,8 @@ textual parts.") (nnimap-article-ranges (gnus-compress-sequence articles)) (nnimap-header-parameters)) t) - (nnimap-transform-headers)) + (nnimap-transform-headers) + (nnheader-remove-cr-followed-by-lf)) (insert-buffer-substring (nnimap-find-process-buffer (current-buffer)))) 'headers)) @@ -271,29 +286,24 @@ 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 - ;; last port if all the previous ones have failed. - (while (and (null credentials) - (setq port (pop ports))) - (setq credentials - (auth-source-user-or-password - '("login" "password") address port nil - (if inhibit-create - nil - (null ports))))) - credentials)) +(defun nnimap-credentials (address ports user) + (let* ((auth-source-creation-prompts + '((user . "IMAP user at %h: ") + (secret . "IMAP password for %u@%h: "))) + (found (nth 0 (auth-source-search :max 1 + :host address + :port ports + :user user + :require '(:user :secret) + :create t)))) + (if found + (list (plist-get found :user) + (let ((secret (plist-get found :secret))) + (if (functionp secret) + (funcall secret) + secret)) + (plist-get found :save-function)) + nil))) (defun nnimap-keepalive () (let ((now (current-time))) @@ -310,145 +320,123 @@ textual parts.") (* 5 60))) (nnimap-send-command "NOOP"))))))) -(declare-function gnutls-negotiate "gnutls" - (proc type &optional priority-string trustfiles keyfiles)) - (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 - ((or (eq nnimap-stream 'network) - (and (eq nnimap-stream 'starttls) - (fboundp 'open-gnutls-stream))) - (nnheader-message 7 "Opening connection to %s..." - nnimap-address) - (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) - (nnheader-message 7 "Opening connection to %s via shell..." - nnimap-address) - (nnimap-open-shell-stream - "*nnimap*" (current-buffer) nnimap-address - (setq port (or nnimap-server-port "imap"))) - '("imap")) - ((eq nnimap-stream 'starttls) - (nnheader-message 7 "Opening connection to %s via starttls..." - nnimap-address) - (let ((tls-program - '("openssl s_client -connect %h:%p -no_ssl2 -ign_eof -starttls imap"))) - (open-tls-stream - "*nnimap*" (current-buffer) nnimap-address - (setq port (or nnimap-server-port "imap")))) - '("imap")) - ((memq nnimap-stream '(ssl tls)) - (nnheader-message 7 "Opening connection to %s via tls..." - nnimap-address) - (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))) - ;; Store the greeting (for debugging purposes). - (setf (nnimap-greeting nnimap-object) - (buffer-substring (line-beginning-position) - (line-end-position))) - (nnimap-get-capabilities) - (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. + (with-current-buffer (nnimap-make-process-buffer buffer) + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (port nil) + (ports (cond - ((and (or (and (eq nnimap-stream 'network) - (nnimap-capability "STARTTLS")) - (eq nnimap-stream 'starttls)) - (fboundp 'open-gnutls-stream)) - (nnimap-command "STARTTLS") - (gnutls-negotiate (nnimap-process nnimap-object) nil) - ;; Get the capabilities again -- they may have changed - ;; after doing STARTTLS. - (nnimap-get-capabilities)) - ((and (eq nnimap-stream 'network) - (nnimap-capability "STARTTLS")) - (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") + ((memq nnimap-stream '(network plain starttls)) + (nnheader-message 7 "Opening connection to %s..." + nnimap-address) + '("imap" "143")) + ((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) + '("imaps" "imap" "993" "143")) + (t + (error "Unknown stream type: %s" nnimap-stream)))) + login-result credentials) + (when nnimap-server-port + (push nnimap-server-port ports)) + (let* ((stream-list + (open-protocol-stream + "*nnimap*" (current-buffer) nnimap-address (car ports) + :type nnimap-stream + :return-list t + :shell-command nnimap-shell-program + :capability-command "1 CAPABILITY\r\n" + :end-of-command "\r\n" + :success " OK " + :starttls-function + (lambda (capabilities) + (when (gnus-string-match-p "STARTTLS" capabilities) + "1 STARTTLS\r\n")))) + (stream (car stream-list)) + (props (cdr stream-list)) + (greeting (plist-get props :greeting)) + (capabilities (plist-get props :capabilities)) + (stream-type (plist-get props :type))) + (when (and stream (not (memq (process-status stream) '(open run)))) + (setq stream nil)) + (setf (nnimap-process nnimap-object) stream) + (setf (nnimap-stream-type nnimap-object) stream-type) + (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) greeting) + (setf (nnimap-capabilities nnimap-object) + (mapcar #'upcase + (split-string capabilities))) + (unless (gnus-string-match-p "[*.] PREAUTH" greeting) (if (not (setq credentials (if (eq nnimap-authenticator 'anonymous) (list "anonymous" (message-make-address)) - (or - ;; First look for the credentials based - ;; on the virtual server name. - (nnimap-credentials - (nnoo-current-server 'nnimap) ports t) - ;; Then look them up based on the - ;; physical address. - (nnimap-credentials nnimap-address ports))))) + ;; Look for the credentials based on + ;; the virtual server name and the address + (nnimap-credentials + (gnus-delete-duplicates + (list + nnimap-address + (nnoo-current-server 'nnimap))) + ports + nnimap-user)))) (setq nnimap-object nil) - (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) + (let ((nnimap-inhibit-logging t)) + (setq login-result + (nnimap-login (car credentials) (cadr credentials)))) + (if (car login-result) + (progn + ;; Save the credentials if a save function exists + ;; (such a function will only be passed if a new + ;; token was created). + (when (functionp (nth 2 credentials)) + (funcall (nth 2 credentials))) + ;; See if CAPABILITY is set as part of login + ;; response. + (dolist (response (cddr login-result)) + (when (string= "CAPABILITY" (upcase (car response))) + (setf (nnimap-capabilities nnimap-object) + (mapcar #'upcase (cdr response)))))) ;; If the login failed, then forget the credentials ;; that are now possibly cached. (dolist (host (list (nnoo-current-server 'nnimap) nnimap-address)) (dolist (port ports) - (dolist (element '("login" "password")) - (auth-source-forget-user-or-password - element host port)))) + (auth-source-forget+ :host host :port port))) (delete-process (nnimap-process nnimap-object)) (setq nnimap-object nil)))) (when nnimap-object @@ -456,12 +444,38 @@ textual parts.") (nnimap-command "ENABLE QRESYNC")) (nnimap-process nnimap-object)))))))) -(defun nnimap-get-capabilities () - (setf (nnimap-capabilities nnimap-object) - (mapcar - #'upcase - (nnimap-find-parameter - "CAPABILITY" (cdr (nnimap-command "CAPABILITY")))))) +(autoload 'rfc2104-hash "rfc2104") + +(defun nnimap-login (user password) + (cond + ;; Prefer plain LOGIN if it's enabled (since it requires fewer + ;; round trips than CRAM-MD5, and it's less likely to be buggy), + ;; and we're using an encrypted connection. + ((and (not (nnimap-capability "LOGINDISABLED")) + (eq (nnimap-stream-type nnimap-object) 'tls)) + (nnimap-command "LOGIN %S %S" user password)) + ((nnimap-capability "AUTH=CRAM-MD5") + (erase-buffer) + (let ((sequence (nnimap-send-command "AUTHENTICATE CRAM-MD5")) + (challenge (nnimap-wait-for-line "^\\+\\(.*\\)\n"))) + (process-send-string + (get-buffer-process (current-buffer)) + (concat + (base64-encode-string + (concat user " " + (rfc2104-hash 'md5 64 16 password + (base64-decode-string challenge)))) + "\r\n")) + (nnimap-wait-for-response sequence))) + ((not (nnimap-capability "LOGINDISABLED")) + (nnimap-command "LOGIN %S %S" user password)) + ((nnimap-capability "AUTH=PLAIN") + (nnimap-command + "AUTHENTICATE PLAIN %s" + (base64-encode-string + (format "\000%s\000%s" + (nnimap-quote-specials user) + (nnimap-quote-specials password))))))) (defun nnimap-quote-specials (string) (with-temp-buffer @@ -531,25 +545,26 @@ textual parts.") (nnimap-get-whole-article article)) (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))))))))) + (nnheader-insert-buffer-substring buffer) + (nnheader-ms-strip-cr))) + (cons group 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)))))) + (if (null article) + nil + (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 @@ -611,7 +626,7 @@ textual parts.") ;; Collect all the body parts. (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]") (setq id (match-string 1) - bytes (nnimap-get-length)) + bytes (or (nnimap-get-length) 0)) (beginning-of-line) (delete-region (point) (progn (forward-line 1) (point))) (push (list id (buffer-substring (point) (+ (point) bytes))) @@ -685,7 +700,7 @@ textual parts.") (let ((result (nnimap-possibly-change-group ;; Don't SELECT the group if we're going to select it ;; later, anyway. - (if (and dont-check + (if (and (not dont-check) (assoc group nnimap-current-infos)) nil group) @@ -840,22 +855,42 @@ textual parts.") (defun nnimap-process-expiry-targets (articles group server) (let ((deleted-articles nil)) - (dolist (article articles) - (let ((target nnmail-expiry-target)) - (with-temp-buffer - (mm-disable-multibyte) - (when (nnimap-request-article article group server (current-buffer)) - (nnheader-message 7 "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)))))) + (cond + ;; shortcut further processing if we're going to delete the articles + ((eq nnmail-expiry-target 'delete) + (setq deleted-articles articles) + t) + ;; or just move them to another folder on the same IMAP server + ((and (not (functionp nnmail-expiry-target)) + (gnus-server-equal (gnus-group-method nnmail-expiry-target) + (gnus-server-to-method + (format "nnimap:%s" server)))) + (and (nnimap-possibly-change-group group server) + (with-current-buffer (nnimap-buffer) + (nnheader-message 7 "Expiring articles from %s: %s" group articles) + (nnimap-command + "UID COPY %s %S" + (nnimap-article-ranges (gnus-compress-sequence articles)) + (utf7-encode (gnus-group-real-name nnmail-expiry-target) t)) + (setq deleted-articles articles))) + t) + (t + (dolist (article articles) + (let ((target nnmail-expiry-target)) + (with-temp-buffer + (mm-disable-multibyte) + (when (nnimap-request-article article group server (current-buffer)) + (nnheader-message 7 "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)) @@ -927,6 +962,16 @@ textual parts.") (push flag flags))) flags)) +(deffoo nnimap-request-update-group-status (group status &optional server) + (when (nnimap-possibly-change-group nil server) + (let ((command (assoc + status + '((subscribe "SUBSCRIBE") + (unsubscribe "UNSUBSCRIBE"))))) + (when command + (with-current-buffer (nnimap-buffer) + (nnimap-command "%s %S" (cadr command) (utf7-encode group t))))))) + (deffoo nnimap-request-set-mark (group actions &optional server) (when (nnimap-possibly-change-group group server) (let (sequence) @@ -959,30 +1004,60 @@ textual parts.") (nnimap-add-cr) (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) - "\n" - "\r\n")) - (let ((result (nnimap-get-response sequence))) - (if (not (car result)) - (progn - (nnheader-message 7 "%s" (nnheader-get-report-string 'nnimap)) - nil) - (cons group - (or (nnimap-find-uid-response "APPENDUID" (car result)) - (nnimap-find-article-by-message-id - group message-id))))))))) + (when (setq message (or (nnimap-process-quirk "OK Gimap " 'append message) + message)) + ;; 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) + "\n" + "\r\n")) + (let ((result (nnimap-get-response sequence))) + (if (not (nnimap-ok-p result)) + (progn + (nnheader-report 'nnimap "%s" result) + nil) + (cons group + (or (nnimap-find-uid-response "APPENDUID" (car result)) + (nnimap-find-article-by-message-id + group message-id)))))))))) + +(defun nnimap-process-quirk (greeting-match type data) + (when (and (nnimap-greeting nnimap-object) + (string-match greeting-match (nnimap-greeting nnimap-object)) + (eq type 'append) + (string-match "\000" data)) + (let ((choice (gnus-multiple-choice + "Message contains NUL characters. Delete, continue, abort? " + '((?d "Delete NUL characters") + (?c "Try to APPEND the message as is") + (?a "Abort"))))) + (cond + ((eq choice ?a) + (nnheader-report 'nnimap "Aborted APPEND due to NUL characters")) + ((eq choice ?c) + data) + (t + (with-temp-buffer + (insert data) + (goto-char (point-min)) + (while (search-forward "\000" nil t) + (replace-match "" t t)) + (buffer-string))))))) + +(defun nnimap-ok-p (value) + (and (consp value) + (consp (car value)) + (equal (caar value) "OK"))) (defun nnimap-find-uid-response (name list) (let ((result (car (last (nnimap-find-response-element name list))))) @@ -1035,60 +1110,62 @@ textual parts.") (nreverse groups))) (deffoo nnimap-request-list (&optional server) - (nnimap-possibly-change-group nil server) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (let ((groups - (with-current-buffer (nnimap-buffer) - (nnimap-get-groups))) - sequences responses) - (when groups - (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)) - (nnimap-wait-for-response (caar sequences)) - (setq responses - (nnimap-get-responses (mapcar #'car sequences)))) - (dolist (response responses) - (let* ((sequence (car response)) - (response (cadr response)) - (group (cadr (assoc sequence sequences)))) - (when (and group - (equal (caar response) "OK")) - (let ((uidnext (nnimap-find-parameter "UIDNEXT" response)) - highest exists) - (dolist (elem response) - (when (equal (cadr elem) "EXISTS") - (setq exists (string-to-number (car elem))))) - (when uidnext - (setq highest (1- (string-to-number (car uidnext))))) - (cond - ((null highest) - (insert (format "%S 0 1 y\n" (utf7-decode group t)))) - ((zerop exists) - ;; Empty group. - (insert (format "%S %d %d y\n" - (utf7-decode group t) highest (1+ highest)))) - (t - ;; Return the widest possible range. - (insert (format "%S %d 1 y\n" (utf7-decode group t) - (or highest exists))))))))) - t)))) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (let ((groups + (with-current-buffer (nnimap-buffer) + (nnimap-get-groups))) + sequences responses) + (when groups + (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)) + (nnimap-wait-for-response (caar sequences)) + (setq responses + (nnimap-get-responses (mapcar #'car sequences)))) + (dolist (response responses) + (let* ((sequence (car response)) + (response (cadr response)) + (group (cadr (assoc sequence sequences)))) + (when (and group + (equal (caar response) "OK")) + (let ((uidnext (nnimap-find-parameter "UIDNEXT" response)) + highest exists) + (dolist (elem response) + (when (equal (cadr elem) "EXISTS") + (setq exists (string-to-number (car elem))))) + (when uidnext + (setq highest (1- (string-to-number (car uidnext))))) + (cond + ((null highest) + (insert (format "%S 0 1 y\n" (utf7-decode group t)))) + ((zerop exists) + ;; Empty group. + (insert (format "%S %d %d y\n" + (utf7-decode group t) + highest (1+ highest)))) + (t + ;; Return the widest possible range. + (insert (format "%S %d 1 y\n" (utf7-decode group t) + (or highest exists))))))))) + t))))) (deffoo nnimap-request-newgroups (date &optional server) - (nnimap-possibly-change-group nil server) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (dolist (group (with-current-buffer (nnimap-buffer) - (nnimap-get-groups))) - (unless (assoc group nnimap-current-infos) - ;; Insert dummy numbers here -- they don't matter. - (insert (format "%S 0 1 y\n" group)))) - t)) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (dolist (group (with-current-buffer (nnimap-buffer) + (nnimap-get-groups))) + (unless (assoc group nnimap-current-infos) + ;; Insert dummy numbers here -- they don't matter. + (insert (format "%S 0 1 y\n" group)))) + t))) (deffoo nnimap-retrieve-group-data-early (server infos) (when (nnimap-possibly-change-group nil server) @@ -1108,10 +1185,12 @@ textual parts.") (setf (nnimap-examined nnimap-object) group) (if (and qresyncp uidvalidity + active modseq) (push - (list (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))" + (list (nnimap-send-command "EXAMINE %S (%s (%s %s))" (utf7-encode group t) + (nnimap-quirk "QRESYNC") uidvalidity modseq) 'qresync nil group 'qresync) @@ -1137,6 +1216,15 @@ textual parts.") sequences)))) sequences)))) +(defun nnimap-quirk (command) + (let ((quirk (assoc command nnimap-quirks))) + ;; If this server is of a type that matches a quirk, then return + ;; the "quirked" command instead of the proper one. + (if (or (null quirk) + (not (string-match (nth 1 quirk) (nnimap-greeting nnimap-object)))) + command + (nth 2 quirk)))) + (deffoo nnimap-finish-retrieve-group-infos (server infos sequences) (when (and sequences (nnimap-possibly-change-group nil server)) @@ -1224,10 +1312,9 @@ textual parts.") (t ;; No articles and no uidnext. nil))) - (gnus-set-active - group - (cons (car active) - (or high (1- uidnext))))) + (gnus-set-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 @@ -1291,6 +1378,14 @@ textual parts.") (when new-marks (push (cons (car type) new-marks) marks))))) (gnus-info-set-marks info marks t)))) + ;; Tell Gnus whether there are any \Recent messages in any of + ;; the groups. + (let ((recent (cdr (assoc '%Recent flags)))) + (when (and active + recent + (> (car (last recent)) (cdr active))) + (push (list (cons (gnus-group-real-name group) 0)) + nnmail-split-history))) ;; 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) @@ -1380,6 +1475,11 @@ textual parts.") ;; Change \Delete etc to %Delete, so that the reader can read it. (subst-char-in-region (point-min) (point-max) ?\\ ?% t) + ;; Remove any MODSEQ entries in the buffer, because they may contain + ;; numbers that are too large for 32-bit Emacsen. + (while (re-search-forward " MODSEQ ([0-9]+)" nil t) + (replace-match "" t t)) + (goto-char (point-min)) (let (start end articles groups uidnext elems permanent-flags uidvalidity vanished highestmodseq) (dolist (elem sequences) @@ -1414,14 +1514,14 @@ textual parts.") (goto-char start) (setq vanished (and (eq flag-sequence 'qresync) - (re-search-forward "VANISHED.* \\([0-9:,]+\\)" + (re-search-forward "^\\* VANISHED .* \\([0-9:,]+\\)" (or end (point-min)) t) (match-string 1))) (goto-char start) (setq highestmodseq - (and (search-forward "HIGHESTMODSEQ " + (and (re-search-forward "HIGHESTMODSEQ \\([0-9]+\\)" (or end (point-min)) t) - (read (current-buffer)))) + (match-string 1))) (goto-char end) (forward-line -1)) ;; The UID FETCH FLAGS was successful. @@ -1434,10 +1534,11 @@ textual parts.") (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)) + (let ((p (point))) + (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 vanished highestmodseq) articles) @@ -1453,9 +1554,13 @@ 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)) +(declare-function gnus-fetch-headers "gnus-sum" + (articles &optional limit force-new dependencies)) + +(deffoo nnimap-request-thread (header) + (let* ((id (mail-header-id header)) + (refs (split-string + (or (mail-header-references header) ""))) (cmd (let ((value (format @@ -1467,10 +1572,11 @@ textual parts.") 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))) + (when result + (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)) @@ -1507,6 +1613,7 @@ textual parts.") (defvar nnimap-sequence 0) (defun nnimap-send-command (&rest args) + (setf (nnimap-last-command-time nnimap-object) (current-time)) (process-send-string (get-buffer-process (current-buffer)) (nnimap-log-command @@ -1525,12 +1632,14 @@ textual parts.") (defun nnimap-log-command (command) (with-current-buffer (get-buffer-create "*imap log*") (goto-char (point-max)) - (insert (format-time-string "%H:%M:%S") " " command)) + (insert (format-time-string "%H:%M:%S") " " + (if nnimap-inhibit-logging + "(inhibited)\n" + command))) command) (defun nnimap-command (&rest args) (erase-buffer) - (setf (nnimap-last-command-time nnimap-object) (current-time)) (let* ((sequence (apply #'nnimap-send-command args)) (response (nnimap-get-response sequence))) (if (equal (caar response) "OK") @@ -1546,8 +1655,9 @@ textual parts.") (nnimap-parse-response)) (defun nnimap-wait-for-connection (&optional regexp) - (unless regexp - (setq regexp "^[*.] .*\n")) + (nnimap-wait-for-line (or regexp "^[*.] .*\n") "[*.] \\([A-Z0-9]+\\)")) + +(defun nnimap-wait-for-line (regexp &optional response-regexp) (let ((process (get-buffer-process (current-buffer)))) (goto-char (point-min)) (while (and (memq (process-status process) @@ -1556,7 +1666,7 @@ textual parts.") (nnheader-accept-process-output process) (goto-char (point-min))) (forward-line -1) - (and (looking-at "[*.] \\([A-Z0-9]+\\)") + (and (looking-at (or response-regexp regexp)) (match-string 1)))) (defun nnimap-wait-for-response (sequence &optional messagep) @@ -1567,18 +1677,22 @@ textual parts.") (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))) + (progn + ;; Skip past any "*" lines that the server has + ;; output. + (while (and (not (bobp)) + (progn + (forward-line -1) + (looking-at "\\*")))) + (not (looking-at (format "%d .*\n" sequence))))) (when messagep (nnheader-message 7 "nnimap read %dk" (/ (buffer-size) 1000))) (nnheader-accept-process-output process) (goto-char (point-max))) openp) (quit + (when debug-on-quit + (debug "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). @@ -1670,11 +1784,15 @@ textual parts.") (format "(UID %s%s)" (format (if (nnimap-ver4-p) - "BODY.PEEK[HEADER] BODY.PEEK" + "BODY.PEEK" "RFC822.PEEK")) - (if nnimap-split-download-body-default - "[]" - "[1]"))) + (cond + (nnimap-split-download-body-default + "[]") + ((nnimap-ver4-p) + "[HEADER]") + (t + "[1]")))) t)) (defun nnimap-split-incoming-mail () @@ -1754,7 +1872,7 @@ textual parts.") (defun nnimap-parse-copied-articles (sequences) (let (sequence copied range) (goto-char (point-min)) - (while (re-search-forward "^\\([0-9]+\\) OK " nil t) + (while (re-search-forward "^\\([0-9]+\\) OK\\b" nil t) (setq sequence (string-to-number (match-string 1))) (when (setq range (cadr (assq sequence sequences))) (push (gnus-uncompress-range range) copied)))