(require 'gnus)
(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
(defvoo nnimap-inbox nil
"The mail box where incoming mail arrives and should be split out of.")
+(defvoo nnimap-split-methods 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-fetch-partial-articles nil
- "If non-nil, nnimap will fetch partial articles.
-If t, nnimap will fetch only the first part. If a string, it
-will fetch all parts that have types that match that string. A
-likely value would be \"text/\" to automatically fetch all
-textual parts.")
-
(defvoo nnimap-expunge t
"If non-nil, expunge articles after deleting them.
This is always done if the server supports UID EXPUNGE, but it's
not done by default on servers that doesn't support that command.")
+(defvoo nnimap-streaming t
+ "If non-nil, try to use streaming commands with IMAP servers.
+Switching this off will make nnimap slower, but it helps with
+some servers.")
(defvoo nnimap-connection-alist nil)
(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 "")
(defstruct nnimap
group process commands capabilities select-result newlinep server
- last-command-time)
+ last-command-time greeting)
(defvar nnimap-object nil)
(download "gnus-download")
(forward "gnus-forward")))
-(defvar nnimap-split-methods nil)
-
(defun nnimap-buffer ()
(nnimap-find-process-buffer nntp-server-buffer))
(erase-buffer)
(when (nnimap-possibly-change-group group server)
(with-current-buffer (nnimap-buffer)
- (nnimap-send-command "SELECT %S" (utf7-encode group t))
(erase-buffer)
(nnimap-wait-for-response
(nnimap-send-command
(nnimap-article-ranges (gnus-compress-sequence articles))
(format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
(format
- (if (member "IMAP4REV1"
- (nnimap-capabilities nnimap-object))
+ (if (nnimap-ver4-p)
"BODY.PEEK[HEADER.FIELDS %s]"
"RFC822.HEADER.LINES %s")
(append '(Subject From Date Message-Id
?s host
?p port)))))
-(defun nnimap-credentials (address ports)
+(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.
(setq port (pop ports)))
(setq credentials
(auth-source-user-or-password
- '("login" "password") address port nil (null ports))))
+ '("login" "password") address port nil
+ (if inhibit-create
+ nil
+ (null ports)))))
credentials))
(defun nnimap-keepalive ()
(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)
- (ports
- (cond
- ((eq nnimap-stream 'network)
- (open-network-stream
- "*nnimap*" (current-buffer) nnimap-address
- (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
- (or nnimap-server-port "imap"))
- '("imap"))
- ((eq nnimap-stream 'starttls)
- (starttls-open-stream
- "*nnimap*" (current-buffer) nnimap-address
- (or nnimap-server-port "imap"))
- '("imap"))
- ((eq nnimap-stream 'ssl)
- (open-tls-stream
- "*nnimap*" (current-buffer) nnimap-address
- (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)))
- (when (and (nnimap-process nnimap-object)
- (memq (process-status (nnimap-process nnimap-object))
- '(open run)))
- (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil)
- (when (setq connection-result (nnimap-wait-for-connection))
- (when (eq nnimap-stream 'starttls)
- (nnimap-send-command "STARTTLS")
- (starttls-negotiate (nnimap-process nnimap-object)))
- (unless (equal connection-result "PREAUTH")
- (if (not (setq credentials
- (if (eq nnimap-authenticator 'anonymous)
- (list "anonymous"
- (message-make-address))
- (nnimap-credentials
- nnimap-address
- (if nnimap-server-port
- (cons (format "%s" nnimap-server-port) ports)
- ports)))))
- (setq nnimap-object nil)
- (setq login-result (nnimap-command "LOGIN %S %S"
- (car credentials)
- (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)))
+ (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)))
+ ;; 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-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-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))))
+ t))
(deffoo nnimap-request-close ()
t)
(deffoo nnimap-request-article (article &optional group server to-buffer)
(with-current-buffer nntp-server-buffer
(let ((result (nnimap-possibly-change-group group server))
- parts)
+ parts structure)
(when (stringp article)
(setq article (nnimap-find-article-by-message-id group article)))
(when (and result
(with-current-buffer (nnimap-buffer)
(erase-buffer)
(when nnimap-fetch-partial-articles
- (if (eq nnimap-fetch-partial-articles t)
- (setq parts '(1))
- (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article)
- (goto-char (point-min))
- (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t)
- (let ((structure (ignore-errors (read (current-buffer)))))
- (setq parts (nnimap-find-wanted-parts structure))))))
- (setq result
- (nnimap-command
- (if (member "IMAP4REV1" (nnimap-capabilities nnimap-object))
- "UID FETCH %d BODY.PEEK[]"
- "UID FETCH %d RFC822.PEEK")
- article))
- ;; Check that we really got an article.
- (goto-char (point-min))
- (unless (looking-at "\\* [0-9]+ FETCH")
- (setq result nil)))
- (let ((buffer (nnimap-find-process-buffer (current-buffer))))
- (when (car result)
- (with-current-buffer (or to-buffer nntp-server-buffer)
- (insert-buffer-substring buffer)
- (goto-char (point-min))
- (let ((bytes (nnimap-get-length)))
- (delete-region (line-beginning-position)
- (progn (forward-line 1) (point)))
- (goto-char (+ (point) bytes))
- (delete-region (point) (point-max))
- (nnheader-ms-strip-cr))
- (cons group article))))))))
+ (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 (point))
+ (read (current-buffer))))
+ parts (nnimap-find-wanted-parts structure))))
+ (when (if parts
+ (nnimap-get-partial-article article parts structure)
+ (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)))))))))
+
+(defun nnimap-get-whole-article (article)
+ (let ((result
+ (nnimap-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))
+ (unless (re-search-forward "\\* [0-9]+ FETCH" nil t)
+ (setq result nil))
+ (when result
+ ;; Remove any data that may have arrived before the FETCH data.
+ (beginning-of-line)
+ (unless (bobp)
+ (delete-region (point-min) (point)))
+ (let ((bytes (nnimap-get-length)))
+ (delete-region (line-beginning-position)
+ (progn (forward-line 1) (point)))
+ (goto-char (+ (point) bytes))
+ (delete-region (point) (point-max)))
+ t)))
+
+(defun nnimap-ver4-p ()
+ (member "IMAP4REV1" (nnimap-capabilities nnimap-object)))
+
+(defun nnimap-get-partial-article (article parts structure)
+ (let ((result
+ (nnimap-command
+ "UID FETCH %d (%s %s)"
+ article
+ (if (nnimap-ver4-p)
+ "BODY.PEEK[HEADER]"
+ "RFC822.HEADER")
+ (if (nnimap-ver4-p)
+ (mapconcat (lambda (part)
+ (format "BODY.PEEK[%s]" part))
+ parts " ")
+ (mapconcat (lambda (part)
+ (format "RFC822.PEEK[%s]" part))
+ parts " ")))))
+ (when result
+ (nnimap-convert-partial-article structure))))
+
+(defun nnimap-convert-partial-article (structure)
+ ;; First just skip past the headers.
+ (goto-char (point-min))
+ (let ((bytes (nnimap-get-length))
+ id parts)
+ ;; Delete "FETCH" line.
+ (delete-region (line-beginning-position)
+ (progn (forward-line 1) (point)))
+ (goto-char (+ (point) bytes))
+ ;; Collect all the body parts.
+ (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]")
+ (setq id (match-string 1)
+ bytes (nnimap-get-length))
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (push (list id (buffer-substring (point) (+ (point) bytes)))
+ parts)
+ (delete-region (point) (+ (point) bytes)))
+ ;; Delete trailing junk.
+ (delete-region (point) (point-max))
+ ;; Now insert all the parts again where they fit in the structure.
+ (nnimap-insert-partial-structure structure parts)
+ t))
+
+(defun nnimap-insert-partial-structure (structure parts &optional subp)
+ (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)))
+ (while (not (stringp (car structure)))
+ (insert "\n--" boundary "\n")
+ (if (consp (caar structure))
+ (nnimap-insert-partial-structure (pop structure) parts t)
+ (let ((bit (pop structure)))
+ (insert (format "Content-type: %s/%s"
+ (downcase (nth 0 bit))
+ (downcase (nth 1 bit))))
+ (if (member "CHARSET" (nth 2 bit))
+ (insert (format
+ "; charset=%S\n" (cadr (member "CHARSET" (nth 2 bit)))))
+ (insert "\n"))
+ (insert (format "Content-transfer-encoding: %s\n"
+ (nth 5 bit)))
+ (insert "\n")
+ (when (assoc (nth 9 bit) parts)
+ (insert (cadr (assoc (nth 9 bit) parts)))))))
+ (insert "\n--" boundary "--\n")))
(defun nnimap-find-wanted-parts (structure)
(message-flatten-list (nnimap-find-wanted-parts-1 structure "")))
(number-to-string num)
(format "%s.%s" prefix num)))
parts)
- (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub))))
- (when (string-match nnimap-fetch-partial-articles type)
- (push (if (string= prefix "")
+ (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))
+ (id (if (string= prefix "")
(number-to-string num)
- (format "%s.%s" prefix num))
- parts)))
- (incf num))))
+ (format "%s.%s" prefix num))))
+ (setcar (nthcdr 9 sub) id)
+ (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)
(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)
+ (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)))
articles)
((and force
(eq nnmail-expiry-target 'delete))
- (unless (nnimap-delete-article articles)
+ (unless (nnimap-delete-article (gnus-compress-sequence articles))
(message "Article marked for deletion, but not expunged."))
nil)
(t
(if (null deletable-articles)
articles
(if (eq nnmail-expiry-target 'delete)
- (nnimap-delete-article deletable-articles)
+ (nnimap-delete-article (gnus-compress-sequence deletable-articles))
(setq deletable-articles
(nnimap-process-expiry-targets
deletable-articles group server)))
;; Change back to the current group again.
(nnimap-possibly-change-group group server)
(setq deleted-articles (nreverse deleted-articles))
- (nnimap-delete-article deleted-articles)
+ (nnimap-delete-article (gnus-compress-sequence deleted-articles))
deleted-articles))
(defun nnimap-find-expired-articles (group)
(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 (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)
"\n"
"\r\n"))
(let ((result (nnimap-get-response sequence)))
- (when result
+ (if (not (car result))
+ (progn
+ (message "%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))"
+ group 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 group)
(nnimap-send-command "UID FETCH %d:* FLAGS" start)
- start
- (car elem))
- sequences))))
+ 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))))
(deffoo nnimap-finish-retrieve-group-infos (server infos sequences)
(nnimap-possibly-change-group nil server))
(with-current-buffer (nnimap-buffer)
;; Wait for the final data to trickle in.
- (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.
- (nnimap-update-infos (nnimap-flags-to-marks
- (nnimap-parse-flags
- (nreverse sequences)))
- infos)
- ;; Finally, just return something resembling an active file in
- ;; the nntp buffer, so that the agent can save the info, too.
- (with-current-buffer nntp-server-buffer
- (erase-buffer)
- (dolist (info infos)
- (let* ((group (gnus-info-group info))
- (active (gnus-active group)))
- (when active
- (insert (format "%S %d %d y\n"
- (gnus-group-real-name group)
- (cdr active)
- (car active))))))))))
+ (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)))
+ infos)
+ ;; Finally, just return something resembling an active file in
+ ;; the nntp buffer, so that the agent can save the info, too.
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (dolist (info infos)
+ (let* ((group (gnus-info-group info))
+ (active (gnus-active group)))
+ (when active
+ (insert (format "%S %d %d y\n"
+ (gnus-group-real-name group)
+ (cdr active)
+ (car active)))))))))))
(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.
(if (or completep
(not (gnus-active group)))
(gnus-set-active group
- (if (and low high)
- (cons low high)
+ (cond
+ ((and low high)
+ (cons low high))
+ (uidnext
;; No articles in this group.
- (cons uidnext (1- uidnext))))
- (setcdr (gnus-active group) (or high (1- uidnext))))
- (unless high
- (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))))))))
+ (cons uidnext (1- uidnext)))
+ (active
+ active)
+ (start-article
+ (cons start-article (1- start-article)))
+ (t
+ ;; No articles and no uidnext.
+ nil)))
+ (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
+ (if (memq '%* permanent-flags)
+ t
+ nil)))
+ ;; Update marks and read articles if this isn't a
+ ;; read-only IMAP group.
+ (when (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)))
+ (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)))
+ (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-range-add (gnus-info-read info)
+ vanished))
+ (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)
+ (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 (search-forward " 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))
(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))))
- (goto-char (point-max))
- (while (and (memq (process-status process)
- '(open run))
- (not (re-search-backward (format "^%d .*\n" sequence)
- (max (point-min) (- (point) 500))
- t)))
- (when messagep
- (message "Read %dKB" (/ (buffer-size) 1000)))
- (nnheader-accept-process-output process)
- (goto-char (point-max)))))
+ (let ((process (get-buffer-process (current-buffer)))
+ 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
+ (message "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))
(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))
(nnimap-article-ranges articles)
(format "(UID %s%s)"
(format
- (if (member "IMAP4REV1"
- (nnimap-capabilities nnimap-object))
+ (if (nnimap-ver4-p)
"BODY.PEEK[HEADER] BODY.PEEK"
"RFC822.PEEK"))
(if nnimap-split-download-body-default
(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)))
projects / gnus / blobdiff