;;; Code:
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
(eval-and-compile
(require 'nnheader))
(require 'nnoo)
(require 'netrc)
(require 'utf7)
+(require 'tls)
(require 'parse-time)
+(autoload 'auth-source-forget-user-or-password "auth-source")
+(autoload 'auth-source-user-or-password "auth-source")
+
(nnoo-declare nnimap)
(defvoo nnimap-address nil
"How mail is split.
Uses the same syntax as nnmail-split-methods")
+(defvoo nnimap-split-fancy nil
+ "Uses the same syntax as nnmail-split-fancy.")
+
+(make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'"
+ "Emacs 24.1")
+
(defvoo nnimap-authenticator nil
"How nnimap authenticate itself to the server.
Possible choices are nil (use default methods) or `anonymous'.")
(defvoo nnimap-current-infos nil)
+(defvoo nnimap-fetch-partial-articles nil
+ "If non-nil, Gnus 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.")
+
(defvar nnimap-process nil)
(defvar nnimap-status-string "")
(* 5 60)))
(nnimap-send-command "NOOP")))))))
+(declare-function gnutls-negotiate "subr" (fn file &optional arglist fileonly))
+
(defun nnimap-open-connection (buffer)
(unless nnimap-keepalive-timer
(setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
'nnimap-keepalive)))
- (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)
- (starttls-open-stream
- "*nnimap*" (current-buffer) nnimap-address
- (setq port (or nnimap-server-port "imap")))
- '("imap"))
- ((eq nnimap-stream 'ssl)
- (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"))))
- 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)))
- (setf (nnimap-greeting nnimap-object)
- (buffer-substring (line-beginning-position)
- (line-end-position)))
- (when (eq nnimap-stream 'starttls)
- (nnimap-command "STARTTLS")
- (starttls-negotiate (nnimap-process nnimap-object)))
- (when nnimap-server-port
- (push (format "%s" nnimap-server-port) ports))
- (unless (equal connection-result "PREAUTH")
- (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)))))
- (setq nnimap-object nil)
- (setq login-result (nnimap-command "LOGIN %S %S"
- (car credentials)
- (cadr credentials)))
- (unless (car login-result)
- (delete-process (nnimap-process nnimap-object))
- (setq nnimap-object nil))))
- (when nnimap-object
+ (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)))
+ ;; Store the capabilities.
(setf (nnimap-capabilities nnimap-object)
(mapcar
#'upcase
- (or (nnimap-find-parameter "CAPABILITY" (cdr login-result))
- (nnimap-find-parameter
- "CAPABILITY" (cdr (nnimap-command "CAPABILITY"))))))
- (when (member "QRESYNC" (nnimap-capabilities nnimap-object))
- (nnimap-command "ENABLE QRESYNC"))
- t))))))
+ (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.
+ (cond
+ ((and (or (and (eq nnimap-stream 'network)
+ (member "STARTTLS"
+ (nnimap-capabilities nnimap-object)))
+ (eq nnimap-stream 'starttls))
+ (fboundp 'open-gnutls-stream))
+ (nnimap-command "STARTTLS")
+ (gnutls-negotiate (nnimap-process nnimap-object) nil))
+ ((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")
+ (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)))))
+ (setq nnimap-object nil)
+ (setq login-result (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.
+ (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))))
+ (delete-process (nnimap-process nnimap-object))
+ (setq nnimap-object nil))))
+ (when nnimap-object
+ (when (member "QRESYNC" (nnimap-capabilities nnimap-object))
+ (nnimap-command "ENABLE QRESYNC"))
+ (nnimap-process nnimap-object))))))))
(defun nnimap-find-parameter (parameter elems)
(let (result)
result))
(deffoo nnimap-close-server (&optional server)
- t)
+ (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 ()
t)
(erase-buffer)
(with-current-buffer (nnimap-buffer)
(erase-buffer)
- (when gnus-fetch-partial-articles
- (if (eq gnus-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)
- (setq structure (ignore-errors (read (current-buffer)))
- parts (nnimap-find-wanted-parts structure)))))
+ (when nnimap-fetch-partial-articles
+ (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article)
+ (goto-char (point-min))
+ (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t)
+ (setq structure (ignore-errors
+ (let ((start (point)))
+ (forward-sexp 1)
+ (downcase-region start (point))
+ (goto-char start)
+ (read (current-buffer))))
+ parts (nnimap-find-wanted-parts structure))))
(when (if parts
(nnimap-get-partial-article article parts structure)
(nnimap-get-whole-article article))
t))
(defun nnimap-insert-partial-structure (structure parts &optional subp)
- (let ((type (car (last structure 4)))
- (boundary (cadr (member "BOUNDARY" (car (last structure 3))))))
+ (let (type boundary)
+ (let ((bstruc structure))
+ (while (consp (car bstruc))
+ (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))))
(when subp
(insert (format "Content-type: multipart/%s; boundary=%S\n\n"
(downcase type) boundary)))
(number-to-string num)
(format "%s.%s" prefix num))))
(setcar (nthcdr 9 sub) id)
- (when (string-match gnus-fetch-partial-articles type)
+ (when (if (eq nnimap-fetch-partial-articles t)
+ (equal id "1")
+ (string-match nnimap-fetch-partial-articles type))
(push id parts))))
(incf num)))
(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 dont-check
+ nil
+ group)
+ server))
articles active marks high low)
(with-current-buffer nntp-server-buffer
(when result
(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
(nnimap-parse-flags
- (list (list group-sequence flag-sequence 1 group)))))
- (when info
+ (list (list group-sequence flag-sequence
+ 1 group "SELECT")))))
+ (when (and info
+ marks)
(nnimap-update-infos marks (list info)))
(goto-char (point-max))
(let ((uidnext (nth 5 (car marks))))
- (setq high (if uidnext
- (1- uidnext)
- (nth 3 (car marks)))
- low (or (nth 4 (car marks)) uidnext)))))
+ (setq high (or (if uidnext
+ (1- uidnext)
+ (nth 3 (car marks)))
+ 0)
+ low (or (nth 4 (car marks)) uidnext 1)))))
(erase-buffer)
(insert
(format
(with-current-buffer (nnimap-buffer)
(car (nnimap-command "DELETE %S" (utf7-encode group t))))))
+(deffoo nnimap-request-rename-group (group new-name &optional server)
+ (when (nnimap-possibly-change-group nil server)
+ (with-current-buffer (nnimap-buffer)
+ ;; 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")
+ (setf (nnimap-group nnimap-object) nil)
+ (car (nnimap-command "RENAME %S %S"
+ (utf7-encode group t) (utf7-encode new-name t))))))
+
(deffoo nnimap-request-expunge-group (group &optional server)
(when (nnimap-possibly-change-group group server)
(with-current-buffer (nnimap-buffer)
(defun nnimap-get-flags (spec)
(let ((articles nil)
- elems)
+ elems end)
(with-current-buffer (nnimap-buffer)
(erase-buffer)
(nnimap-wait-for-response (nnimap-send-command
"UID FETCH %s FLAGS" spec))
+ (setq end (point))
+ (subst-char-in-region (point-min) (point-max)
+ ?\\ ?% t)
(goto-char (point-min))
- (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" nil t)
- (setq elems (nnimap-parse-line (match-string 1)))
- (push (cons (string-to-number (cadr (member "UID" elems)))
- (cadr (member "FLAGS" elems)))
+ (while (search-forward " FETCH " end t)
+ (setq elems (read (current-buffer)))
+ (push (cons (cadr (memq 'UID elems))
+ (cadr (memq 'FLAGS elems)))
articles)))
(nreverse articles)))
(deffoo nnimap-request-move-article (article group server accept-form
&optional last internal-move-group)
(with-temp-buffer
+ (mm-disable-multibyte)
(when (nnimap-request-article article group server (current-buffer))
;; If the move is internal (on the same server), just do it the easy
;; way.
((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
(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
(defun nnimap-find-article-by-message-id (group message-id)
- (when (nnimap-possibly-change-group group nil)
- (with-current-buffer (nnimap-buffer)
- (let ((result
- (nnimap-command "UID SEARCH HEADER Message-Id %S" message-id))
- article)
- (when (car result)
- ;; Select the last instance of the message in the group.
- (and (setq article
- (car (last (assoc "SEARCH" (cdr result)))))
- (string-to-number article)))))))
+ (with-current-buffer (nnimap-buffer)
+ (erase-buffer)
+ (setf (nnimap-group nnimap-object) nil)
+ (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
+ (let ((sequence
+ (nnimap-send-command "UID SEARCH HEADER Message-Id %S" message-id))
+ article result)
+ (setq result (nnimap-wait-for-response sequence))
+ (when (and result
+ (car (setq result (nnimap-parse-response))))
+ ;; Select the last instance of the message in the group.
+ (and (setq article
+ (car (last (assoc "SEARCH" (cdr result)))))
+ (string-to-number article))))))
(defun nnimap-delete-article (articles)
(with-current-buffer (nnimap-buffer)
(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)
(when (nnimap-possibly-change-group group server)
(let (sequence)
(with-current-buffer (nnimap-buffer)
+ (erase-buffer)
;; Just send all the STORE commands without waiting for
;; response. If they're successful, they're successful.
(dolist (action actions)
(deffoo nnimap-request-accept-article (group &optional server last)
(when (nnimap-possibly-change-group nil server)
(nnmail-check-syntax)
- (let ((message (buffer-string))
- (message-id (message-field-value "message-id"))
- sequence)
+ (let ((message-id (message-field-value "message-id"))
+ sequence message)
+ (nnimap-add-cr)
+ (setq message (buffer-string))
(with-current-buffer (nnimap-buffer)
(setq sequence (nnimap-send-command
"APPEND %S {%d}" (utf7-encode group t)
(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 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))
+
(deffoo nnimap-retrieve-group-data-early (server infos)
(when (nnimap-possibly-change-group nil server)
(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)))
- marks groups sequences)
+ (let ((qresyncp (member "QRESYNC" (nnimap-capabilities nnimap-object)))
+ 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.
(dolist (info infos)
- (setq marks (gnus-info-marks info))
- (push (list (gnus-group-real-name (gnus-info-group info))
- (cdr (assq 'active marks))
- (cdr (assq 'uid marks)))
- groups))
- ;; Then request the data.
- (erase-buffer)
- (setf (nnimap-group nnimap-object) nil)
- (dolist (elem groups)
+ (setq params (gnus-info-params info)
+ group (gnus-group-real-name (gnus-info-group info))
+ active (cdr (assq 'active params))
+ uidvalidity (cdr (assq 'uidvalidity params))
+ modseq (cdr (assq 'modseq params)))
(if (and qresyncp
- (nth 2 elem))
+ uidvalidity
+ modseq)
(push
- (list 'qresync
- (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))"
- (car elem)
- (car (nth 2 elem))
- (cdr (nth 2 elem)))
- nil
- (car elem))
+ (list (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))"
+ (utf7-encode group t)
+ uidvalidity modseq)
+ 'qresync
+ nil group 'qresync)
sequences)
(let ((start
- (if (nth 1 elem)
+ (if (and active uidvalidity)
;; Fetch the last 100 flags.
- (max 1 (- (cdr (nth 1 elem)) 100))
- 1)))
- (push (list (nnimap-send-command "EXAMINE %S" (car elem))
+ (max 1 (- (cdr active) 100))
+ 1))
+ (command
+ (if uidvalidity
+ "EXAMINE"
+ ;; If we don't have a UIDVALIDITY, then this is
+ ;; the first time we've seen the group, so we
+ ;; have to do a SELECT (which is slower than an
+ ;; examine), but will tell us whether the group
+ ;; is read-only or not.
+ "SELECT")))
+ (push (list (nnimap-send-command "%s %S" command
+ (utf7-encode group t))
(nnimap-send-command "UID FETCH %d:* FLAGS" start)
- start
- (car elem))
+ start group command)
sequences)))
;; Some servers apparently can't have many outstanding
;; commands, so throttle them.
(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))
- ;; Now we should have all 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.
+ (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.
(nnimap-update-infos (nnimap-flags-to-marks
(nnimap-parse-flags
(nreverse sequences)))
(defun nnimap-update-infos (flags infos)
(dolist (info infos)
- (let ((group (gnus-group-real-name (gnus-info-group info))))
- (nnimap-update-info info (cdr (assoc group flags))))))
+ (let* ((group (gnus-group-real-name (gnus-info-group info)))
+ (marks (cdr (assoc group flags))))
+ (when marks
+ (nnimap-update-info info marks)))))
(defun nnimap-update-info (info marks)
- (when marks
- (destructuring-bind (existing flags high low uidnext start-article
- permanent-flags) marks
- (let ((group (gnus-info-group info))
- (completep (and start-article
- (= start-article 1))))
+ (destructuring-bind (existing flags high low uidnext start-article
+ 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.
+ ((let ((old-uidvalidity
+ (cdr (assq 'uidvalidity (gnus-info-params info)))))
+ (and old-uidvalidity
+ (not (equal old-uidvalidity uidvalidity))
+ (> start-article 1)))
+ (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)))
+ (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.
(uidnext
;; No articles in this group.
(cons uidnext (1- uidnext)))
+ (active
+ active)
(start-article
(cons start-article (1- start-article)))
(t
;; No articles and no uidnext.
nil)))
- (setcdr (gnus-active group) (or high (1- uidnext))))
- (when (and (not high)
- uidnext)
- (setq high (1- uidnext)))
- ;; Then 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))
- ;; Note the active level for the next run-through.
- (let ((active (assq 'active marks)))
- (if active
- (setcdr active (gnus-active group))
- (push (cons 'active (gnus-active group)) marks)))
- (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)))
- (gnus-info-set-marks info marks t)
- (nnimap-store-info info (gnus-active group))))))))
+ (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
+ info 'permanent-flags
+ (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 (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 (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)))
(push (list group info active) nnimap-current-infos))))
(defun nnimap-flags-to-marks (groups)
- (let (data group totalp uidnext articles start-article mark permanent-flags)
+ (let (data group totalp uidnext articles start-article mark permanent-flags
+ uidvalidity vanished highestmodseq)
(dolist (elem groups)
(setq group (car elem)
uidnext (nth 1 elem)
start-article (nth 2 elem)
permanent-flags (nth 3 elem)
- articles (nthcdr 4 elem))
+ uidvalidity (nth 4 elem)
+ vanished (nth 5 elem)
+ highestmodseq (nth 6 elem)
+ articles (nthcdr 7 elem))
(let ((high (caar articles))
marks low existing)
(dolist (article articles)
(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)
+ permanent-flags uidvalidity vanished highestmodseq)
data)))
data))
;; Change \Delete etc to %Delete, so that the reader can read it.
(subst-char-in-region (point-min) (point-max)
?\\ ?% t)
- (let (start end articles groups uidnext elems permanent-flags)
+ (let (start end articles groups uidnext elems permanent-flags
+ uidvalidity vanished highestmodseq)
(dolist (elem sequences)
- (destructuring-bind (group-sequence flag-sequence totalp group) elem
+ (destructuring-bind (group-sequence flag-sequence totalp group command)
+ elem
(setq start (point))
- ;; The EXAMINE was successful.
- (when (and (search-forward (format "\n%d OK " group-sequence) nil t)
- (progn
- (forward-line 1)
- (setq end (point))
- (goto-char start)
- (setq permanent-flags
+ (when (and
+ ;; The EXAMINE was successful.
+ (search-forward (format "\n%d OK " group-sequence) nil t)
+ (progn
+ (forward-line 1)
+ (setq end (point))
+ (goto-char start)
+ (setq permanent-flags
+ (if (equal command "SELECT")
(and (search-forward "PERMANENTFLAGS "
- (or end (point-min)) t)
- (read (current-buffer))))
- (goto-char start)
- (setq uidnext
- (and (search-forward "UIDNEXT "
- (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 end (point-min)) t)
+ (read (current-buffer)))
+ 'not-scanned))
+ (goto-char start)
+ (setq uidnext
+ (and (search-forward "UIDNEXT "
+ (or end (point-min)) t)
+ (read (current-buffer))))
+ (goto-char start)
+ (setq uidvalidity
+ (and (re-search-forward "UIDVALIDITY \\([0-9]+\\)"
+ (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.
+ (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) articles)
+ (push (nconc (list group uidnext totalp permanent-flags uidvalidity
+ vanished highestmodseq)
+ articles)
groups)
+ (goto-char end)
(setq articles nil))))
groups))
(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)))))))))
+
(defun nnimap-possibly-change-group (group server)
(let ((open-result t))
(when (and server
(goto-char (point-min))
(while (and (memq (process-status process)
'(open run))
- (not (re-search-forward "^\\* .*\n" nil t)))
+ (not (re-search-forward "^[*.] .*\n" nil t)))
(nnheader-accept-process-output process)
(goto-char (point-min)))
(forward-line -1)
- (and (looking-at "\\* \\([A-Z0-9]+\\)")
+ (and (looking-at "[*.] \\([A-Z0-9]+\\)")
(match-string 1))))
(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 "Read %dKB" (/ (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))
(defun nnimap-parse-line (line)
(let (char result)
(with-temp-buffer
+ (mm-disable-multibyte)
(insert line)
(goto-char (point-min))
(while (not (eobp))
(push
(cond
((eql char ?\[)
- (split-string (buffer-substring
- (1+ (point)) (1- (search-forward "]")))))
+ (split-string
+ (buffer-substring
+ (1+ (point))
+ (1- (search-forward "]" (line-end-position) 'move)))))
((eql char ?\()
- (split-string (buffer-substring
- (1+ (point)) (1- (search-forward ")")))))
+ (split-string
+ (buffer-substring
+ (1+ (point))
+ (1- (search-forward ")" (line-end-position) 'move)))))
((eql char ?\")
(forward-char 1)
- (buffer-substring (point) (1- (search-forward "\""))))
+ (buffer-substring
+ (point)
+ (1- (or (search-forward "\"" (line-end-position) 'move)
+ (point)))))
(t
(buffer-substring (point) (if (search-forward " " nil t)
(1- (point))
(defun nnimap-split-incoming-mail ()
(with-current-buffer (nnimap-buffer)
(let ((nnimap-incoming-split-list nil)
- (nnmail-split-methods nnimap-split-methods)
+ (nnmail-split-methods (if (eq nnimap-split-methods 'default)
+ nnmail-split-methods
+ nnimap-split-methods))
+ (nnmail-split-fancy (or nnimap-split-fancy
+ nnmail-split-fancy))
(nnmail-inhibit-default-split-group t)
(groups (nnimap-get-groups))
new-articles)
(defun nnimap-mark-and-expunge-incoming (range)
(when range
(setq range (nnimap-article-ranges range))
+ (erase-buffer)
(let ((sequence
(nnimap-send-command
"UID STORE %s +FLAGS.SILENT (\\Deleted)" range)))
(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)