X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnimap.el;h=eaf0f5ccf0087d29907ecd9f5b8afc4042071ca4;hp=998f50431cab6027e9e91c501e322899853edd7c;hb=a10e061d0e6d4792608c61659d34a0c770c1129b;hpb=586b9b22b277798623e2d4c983c36891e0fd61fb diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 998f50431..eaf0f5ccf 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -1,6 +1,6 @@ ;;; nnimap.el --- IMAP interface for Gnus -;; Copyright (C) 2010-2011 Free Software Foundation, Inc. +;; Copyright (C) 2010-2012 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)) @@ -45,7 +49,6 @@ (require 'tls) (require 'parse-time) (require 'nnmail) -(require 'proto-stream) (autoload 'auth-source-forget+ "auth-source") (autoload 'auth-source-search "auth-source") @@ -55,16 +58,21 @@ (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 'undecided - "How nnimap will talk to the IMAP server. -Values are `ssl', `network', `network-only, `starttls' or -`shell'. The default is to try `ssl' first, and then -`network'.") + "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) @@ -126,7 +134,7 @@ textual parts.") (defstruct nnimap group process commands capabilities select-result newlinep server - last-command-time greeting examined stream-type) + last-command-time greeting examined stream-type initial-resync) (defvar nnimap-object nil) @@ -160,6 +168,8 @@ textual parts.") nnmail-extra-headers)))) (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old) + (when group + (setq group (nnimap-decode-gnus-group group))) (with-current-buffer nntp-server-buffer (erase-buffer) (when (nnimap-possibly-change-group group server) @@ -179,25 +189,35 @@ textual parts.") (defun nnimap-transform-headers () (goto-char (point-min)) - (let (article bytes lines size string) + (let (article lines size string) (block nil (while (not (eobp)) - (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)")) + (while (not (looking-at "\\* [0-9]+ FETCH")) (delete-region (point) (progn (forward-line 1) (point))) (when (eobp) (return))) - (setq article (match-string 1)) + (goto-char (match-end 0)) ;; Unfold quoted {number} strings. - (while (re-search-forward "[^]][ (]{\\([0-9]+\\)}\r?\n" - (1+ (line-end-position)) t) + (while (re-search-forward + "[^]][ (]{\\([0-9]+\\)}\r?\n" + (save-excursion + ;; Start of the header section. + (or (re-search-forward "] {[0-9]+}\r?\n" nil t) + ;; Start of the next FETCH. + (re-search-forward "\\* [0-9]+ FETCH" nil t) + (point-max))) + t) (setq size (string-to-number (match-string 1))) (delete-region (+ (match-beginning 0) 2) (point)) (setq string (buffer-substring (point) (+ (point) size))) (delete-region (point) (+ (point) size)) - (insert (format "%S" string))) - (setq bytes (nnimap-get-length) - lines nil) + (insert (format "%S" (mm-subst-char-in-string ?\n ?\s string)))) (beginning-of-line) + (setq article + (and (re-search-forward "UID \\([0-9]+\\)" (line-end-position) + t) + (match-string 1))) + (setq lines nil) (setq size (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)" (line-end-position) @@ -208,9 +228,14 @@ textual parts.") (let ((structure (ignore-errors (read (current-buffer))))) (while (and (consp structure) - (not (stringp (car structure)))) + (not (atom (car structure)))) (setq structure (car structure))) - (setq lines (nth 7 structure)))) + (setq lines (if (and + (stringp (car structure)) + (equal (upcase (nth 0 structure)) "MESSAGE") + (equal (upcase (nth 1 structure)) "RFC822")) + (nth 9 structure) + (nth 7 structure))))) (delete-region (line-beginning-position) (line-end-position)) (insert (format "211 %s Article retrieved." article)) (forward-line 1) @@ -254,18 +279,20 @@ textual parts.") result)) (mapconcat #'identity (nreverse result) ","))))) -(deffoo nnimap-open-server (server &optional defs) +(deffoo nnimap-open-server (server &optional defs no-reconnect) (if (nnimap-server-opened server) t (unless (assq 'nnimap-address defs) (setq defs (append defs (list (list 'nnimap-address server))))) (nnoo-change-server 'nnimap server defs) - (or (nnimap-find-connection nntp-server-buffer) - (nnimap-open-connection nntp-server-buffer)))) + (if no-reconnect + (nnimap-find-connection nntp-server-buffer) + (or (nnimap-find-connection nntp-server-buffer) + (nnimap-open-connection nntp-server-buffer))))) (defun nnimap-make-process-buffer (buffer) (with-current-buffer - (generate-new-buffer (format "*nnimap %s %s %s*" + (generate-new-buffer (format " *nnimap %s %s %s*" nnimap-address nnimap-server-port (gnus-buffer-exists-p buffer))) (mm-disable-multibyte) @@ -273,17 +300,22 @@ textual parts.") (gnus-add-buffer) (set (make-local-variable 'after-change-functions) nil) (set (make-local-variable 'nnimap-object) - (make-nnimap :server (nnoo-current-server 'nnimap))) + (make-nnimap :server (nnoo-current-server 'nnimap) + :initial-resync 0)) (push (list buffer (current-buffer)) nnimap-connection-alist) (push (current-buffer) nnimap-process-buffers) (current-buffer))) -(defun nnimap-credentials (address ports) - (let ((found (nth 0 (auth-source-search :max 1 - :host address - :port ports - :require '(:user :secret) - :create t)))) +(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))) @@ -326,6 +358,11 @@ textual parts.") nil stream))) +(defun nnimap-map-port (port) + (if (equal port "imaps") + "993" + port)) + (defun nnimap-open-connection-1 (buffer) (unless nnimap-keepalive-timer (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15) @@ -333,11 +370,9 @@ textual parts.") (with-current-buffer (nnimap-make-process-buffer buffer) (let* ((coding-system-for-read 'binary) (coding-system-for-write 'binary) - (port nil) (ports (cond - ((or (eq nnimap-stream 'network) - (eq nnimap-stream 'starttls)) + ((memq nnimap-stream '(network plain starttls)) (nnheader-message 7 "Opening connection to %s..." nnimap-address) '("imap" "143")) @@ -351,27 +386,44 @@ textual parts.") '("imaps" "imap" "993" "143")) (t (error "Unknown stream type: %s" nnimap-stream)))) - (proto-stream-always-use-starttls t) login-result credentials) (when nnimap-server-port (push nnimap-server-port ports)) - (destructuring-bind (stream greeting capabilities stream-type) - (open-protocol-stream - "*nnimap*" (current-buffer) nnimap-address (car ports) - :type nnimap-stream - :shell-command nnimap-shell-program - :capability-command "1 CAPABILITY\r\n" - :success " OK " - :starttls-function - (lambda (capabilities) - (when (gnus-string-match-p "STARTTLS" capabilities) - "1 STARTTLS\r\n"))) + (let* ((stream-list + (open-protocol-stream + "*nnimap*" (current-buffer) nnimap-address + (nnimap-map-port (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)) + + (when (and (fboundp 'set-network-process-option) ;; Not in XEmacs. + (fboundp 'process-type) ;; Emacs 22 doesn't provide it. + (eq (process-type stream) 'network)) + ;; Use TCP-keepalive so that connections that pass through a NAT + ;; router don't hang when left idle. + (set-network-process-option stream :keepalive t)) + (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) + nnimap-address (car ports) nnimap-stream) 'no-connect) (gnus-set-process-query-on-exit-flag stream nil) (if (not (gnus-string-match-p "[*.] \\(OK\\|PREAUTH\\)" greeting)) @@ -393,17 +445,25 @@ textual parts.") (list nnimap-address (nnoo-current-server 'nnimap))) - ports)))) + ports + nnimap-user)))) (setq nnimap-object nil) (let ((nnimap-inhibit-logging t)) (setq login-result (nnimap-login (car credentials) (cadr credentials)))) (if (car login-result) - ;; 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))) + (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) @@ -492,6 +552,8 @@ textual parts.") nnimap-status-string) (deffoo nnimap-request-article (article &optional group server to-buffer) + (when group + (setq group (nnimap-decode-gnus-group group))) (with-current-buffer nntp-server-buffer (let ((result (nnimap-possibly-change-group group server)) parts structure) @@ -518,12 +580,13 @@ 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 group + (setq group (nnimap-decode-gnus-group group))) (when (nnimap-possibly-change-group group server) (with-current-buffer (nnimap-buffer) (when (stringp article) @@ -630,12 +693,13 @@ textual parts.") (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 "Content-type: %s/%s" + (downcase (nth 0 bit)) + (downcase (nth 1 bit)))) + (if (member-ignore-case "CHARSET" (nth 2 bit)) (insert (format - "; charset=%S\n" (cadr (member "CHARSET" (nth 2 bit))))) + "; charset=%S\n" + (cadr (member-ignore-case "CHARSET" (nth 2 bit))))) (insert "\n")) (insert (format "Content-transfer-encoding: %s\n" (nth 5 bit))) @@ -670,7 +734,11 @@ textual parts.") (incf num))) (nreverse parts))) +(defun nnimap-decode-gnus-group (group) + (decode-coding-string group 'utf-8)) + (deffoo nnimap-request-group (group &optional server dont-check info) + (setq group (nnimap-decode-gnus-group group)) (let ((result (nnimap-possibly-change-group ;; Don't SELECT the group if we're going to select it ;; later, anyway. @@ -720,16 +788,19 @@ textual parts.") t)))) (deffoo nnimap-request-create-group (group &optional server args) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group nil server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "CREATE %S" (utf7-encode group t)))))) (deffoo nnimap-request-delete-group (group &optional force server) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group nil server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "DELETE %S" (utf7-encode group t)))))) (deffoo nnimap-request-rename-group (group new-name &optional server) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group nil server) (with-current-buffer (nnimap-buffer) (nnimap-unselect-group) @@ -744,6 +815,7 @@ textual parts.") (nnimap-command "EXAMINE DOES.NOT.EXIST")) (deffoo nnimap-request-expunge-group (group &optional server) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group group server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "EXPUNGE"))))) @@ -771,6 +843,7 @@ textual parts.") (deffoo nnimap-request-move-article (article group server accept-form &optional last internal-move-group) + (setq group (nnimap-decode-gnus-group group)) (with-temp-buffer (mm-disable-multibyte) (when (funcall (if internal-move-group @@ -799,6 +872,7 @@ textual parts.") result))))))) (deffoo nnimap-request-expire-articles (articles group &optional server force) + (setq group (nnimap-decode-gnus-group group)) (cond ((null articles) nil) @@ -854,15 +928,18 @@ textual parts.") (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))) + (if (and target + (not (eq target 'delete))) + (if (or (gnus-request-group target t) + (gnus-request-create-group target)) + (progn + (nnmail-expiry-target-group target group) + (nnheader-message 7 "Expiring article %s:%d to %s" + group article target)) + (setq target nil)) + (nnheader-message 7 "Expiring article %s:%d" group article)) (when target (push article deleted-articles)))))))) ;; Change back to the current group again. @@ -903,7 +980,7 @@ textual parts.") (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))))) + (car (last (cdr (assoc "SEARCH" (cdr result)))))) (string-to-number article)))))) (defun nnimap-delete-article (articles) @@ -923,11 +1000,14 @@ textual parts.") "delete this article now")))))) (deffoo nnimap-request-scan (&optional group server) + (when group + (setq group (nnimap-decode-gnus-group group))) (when (and (nnimap-possibly-change-group nil server) nnimap-inbox nnimap-split-methods) (nnheader-message 7 "nnimap %s splitting mail..." server) - (nnimap-split-incoming-mail))) + (nnimap-split-incoming-mail) + (nnheader-message 7 "nnimap %s splitting mail...done" server))) (defun nnimap-marks-to-flags (marks) (let (flags flag) @@ -937,6 +1017,7 @@ textual parts.") flags)) (deffoo nnimap-request-update-group-status (group status &optional server) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group nil server) (let ((command (assoc status @@ -947,6 +1028,7 @@ textual parts.") (nnimap-command "%s %S" (cadr command) (utf7-encode group t))))))) (deffoo nnimap-request-set-mark (group actions &optional server) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group group server) (let (sequence) (with-current-buffer (nnimap-buffer) @@ -966,11 +1048,12 @@ textual parts.") ((eq action 'set) "")) (mapconcat #'identity flags " "))))))) ;; Wait for the last command to complete to avoid later - ;; syncronisation problems with the stream. + ;; synchronization problems with the stream. (when sequence (nnimap-wait-for-response sequence)))))) (deffoo nnimap-request-accept-article (group &optional server last) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group nil server) (nnmail-check-syntax) (let ((message-id (message-field-value "message-id")) @@ -1047,6 +1130,7 @@ textual parts.") result)) (deffoo nnimap-request-replace-article (article group buffer) + (setq group (nnimap-decode-gnus-group group)) (let (group-art) (when (and (nnimap-possibly-change-group group nil) ;; Put the article into the group. @@ -1077,9 +1161,9 @@ textual parts.") (separator (read (current-buffer))) (group (read (current-buffer)))) (unless (member '%NoSelect flags) - (push (if (stringp group) - group - (format "%s" group)) + (push (utf7-decode (if (stringp group) + group + (format "%s" group)) t) groups)))) (nreverse groups))) @@ -1138,29 +1222,35 @@ textual parts.") (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)))) + (insert (format "%S 0 1 y\n" (utf7-encode group))))) t))) (deffoo nnimap-retrieve-group-data-early (server infos) - (when (nnimap-possibly-change-group nil server) + (when (and (nnimap-possibly-change-group nil server) + infos) (with-current-buffer (nnimap-buffer) (erase-buffer) (setf (nnimap-group nnimap-object) nil) + (setf (nnimap-initial-resync nnimap-object) 0) (let ((qresyncp (nnimap-capability "QRESYNC")) - params groups sequences active uidvalidity modseq group) + params groups sequences active uidvalidity modseq group + unexist) ;; Go through the infos and gather the data needed to know ;; what and how to request the data. (dolist (info infos) (setq params (gnus-info-params info) - group (gnus-group-real-name (gnus-info-group info)) + group (nnimap-decode-gnus-group + (gnus-group-real-name (gnus-info-group info))) active (cdr (assq 'active params)) + unexist (assq 'unexist (gnus-info-marks info)) uidvalidity (cdr (assq 'uidvalidity params)) modseq (cdr (assq 'modseq params))) (setf (nnimap-examined nnimap-object) group) (if (and qresyncp uidvalidity active - modseq) + modseq + unexist) (push (list (nnimap-send-command "EXAMINE %S (%s (%s %s))" (utf7-encode group t) @@ -1169,12 +1259,7 @@ textual parts.") 'qresync nil group 'qresync) sequences) - (let ((start - (if (and active uidvalidity) - ;; Fetch the last 100 flags. - (max 1 (- (cdr active) 100)) - 1)) - (command + (let ((command (if uidvalidity "EXAMINE" ;; If we don't have a UIDVALIDITY, then this is @@ -1182,7 +1267,13 @@ textual parts.") ;; have to do a SELECT (which is slower than an ;; examine), but will tell us whether the group ;; is read-only or not. - "SELECT"))) + "SELECT")) + start) + (if (and active uidvalidity unexist) + ;; Fetch the last 100 flags. + (setq start (max 1 (- (cdr active) 100))) + (incf (nnimap-initial-resync nnimap-object)) + (setq start 1)) (push (list (nnimap-send-command "%s %S" command (utf7-encode group t)) (nnimap-send-command "UID FETCH %d:* FLAGS" start) @@ -1201,7 +1292,11 @@ textual parts.") (deffoo nnimap-finish-retrieve-group-infos (server infos sequences) (when (and sequences - (nnimap-possibly-change-group nil server)) + (nnimap-possibly-change-group nil server t) + ;; Check that the process is still alive. + (get-buffer-process (nnimap-buffer)) + (memq (process-status (get-buffer-process (nnimap-buffer))) + '(open run))) (with-current-buffer (nnimap-buffer) ;; Wait for the final data to trickle in. (when (nnimap-wait-for-response (if (eq (cadar sequences) 'qresync) @@ -1224,13 +1319,15 @@ textual parts.") (active (gnus-active group))) (when active (insert (format "%S %d %d y\n" - (gnus-group-real-name group) + (decode-coding-string + (gnus-group-real-name group) 'utf-8) (cdr active) (car active))))))))))) (defun nnimap-update-infos (flags infos) (dolist (info infos) - (let* ((group (gnus-group-real-name (gnus-info-group info))) + (let* ((group (nnimap-decode-gnus-group + (gnus-group-real-name (gnus-info-group info)))) (marks (cdr (assoc group flags)))) (when marks (nnimap-update-info info marks))))) @@ -1254,7 +1351,8 @@ textual parts.") (cdr (assq 'uidvalidity (gnus-info-params info))))) (and old-uidvalidity (not (equal old-uidvalidity uidvalidity)) - (> start-article 1))) + (or (not start-article) + (> start-article 1)))) (gnus-group-remove-parameter info 'uidvalidity) (gnus-group-remove-parameter info 'modseq)) ;; We have the data needed to update. @@ -1351,6 +1449,20 @@ textual parts.") (setq new-marks (gnus-range-nconcat old-marks new-marks))) (when new-marks (push (cons (car type) new-marks) marks))))) + ;; Keep track of non-existing articles. + (let* ((old-unexists (assq 'unexist marks)) + (unexists + (if completep + (gnus-range-difference + (gnus-active group) + (gnus-compress-sequence existing)) + (gnus-add-to-range + (cdr old-unexists) + (gnus-list-range-difference + existing (gnus-active group)))))) + (if old-unexists + (setcdr old-unexists unexists) + (push (cons 'unexist unexists) marks))) (gnus-info-set-marks info marks t)))) ;; Tell Gnus whether there are any \Recent messages in any of ;; the groups. @@ -1394,6 +1506,14 @@ textual parts.") (gnus-sorted-complement existing new-marks)))) (when ticks (push (cons (car type) ticks) marks))) + (gnus-info-set-marks info marks t)) + ;; Add vanished to the list of unexisting articles. + (when vanished + (let* ((old-unexists (assq 'unexist marks)) + (unexists (gnus-range-add (cdr old-unexists) vanished))) + (if old-unexists + (setcdr old-unexists unexists) + (push (cons 'unexist unexists) marks))) (gnus-info-set-marks info marks t)))) (defun nnimap-imap-ranges-to-gnus-ranges (irange) @@ -1446,9 +1566,15 @@ textual parts.") (defun nnimap-parse-flags (sequences) (goto-char (point-min)) - ;; Change \Delete etc to %Delete, so that the reader can read it. + ;; Change \Delete etc to %Delete, so that the Emacs Lisp 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) @@ -1483,14 +1609,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. @@ -1504,18 +1630,7 @@ textual parts.") (goto-char end)) (while (re-search-forward "^\\* [0-9]+ FETCH " start t) (let ((p (point))) - ;; FIXME: For FETCH lines like "* 2971 FETCH (FLAGS (%Recent) UID - ;; 12509 MODSEQ (13419098521433281274))" we get an - ;; overflow-error. The handler simply deletes that large number - ;; and reads again. But maybe there's a better fix... - (setq elems (condition-case nil (read (current-buffer)) - (overflow-error - ;; After an overflow-error, point is just after - ;; the too large number. So delete it and try - ;; again. - (delete-region (point) (progn (backward-word) (point))) - (goto-char p) - (read (current-buffer))))) + (setq elems (read (current-buffer))) (push (cons (cadr (memq 'UID elems)) (cadr (memq 'FLAGS elems))) articles))) @@ -1523,7 +1638,9 @@ textual parts.") vanished highestmodseq) articles) groups) - (goto-char end) + (if (eq flag-sequence 'qresync) + (goto-char end) + (setq end (point))) (setq articles nil)))) groups)) @@ -1537,32 +1654,29 @@ textual parts.") (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 - "(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)))) - (when result - (gnus-fetch-headers - (and (car result) (delete 0 (mapcar #'string-to-number - (cdr (assoc "SEARCH" (cdr result)))))) - nil t)))) +(autoload 'nnir-search-thread "nnir") -(defun nnimap-possibly-change-group (group server) +(deffoo nnimap-request-thread (header &optional group server) + (when group + (setq group (nnimap-decode-gnus-group group))) + (if gnus-refer-thread-use-nnir + (nnir-search-thread header) + (when (nnimap-possibly-change-group group server) + (let* ((cmd (nnimap-make-thread-query header)) + (result (with-current-buffer (nnimap-buffer) + (nnimap-command "UID SEARCH %s" cmd)))) + (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 &optional no-reconnect) (let ((open-result t)) (when (and server (not (nnimap-server-opened server))) - (setq open-result (nnimap-open-server server))) + (setq open-result (nnimap-open-server server nil no-reconnect))) (cond ((not open-result) nil) @@ -1609,13 +1723,18 @@ textual parts.") (nnimap-wait-for-response nnimap-sequence)) nnimap-sequence) +(defvar nnimap-record-commands nil + "If non-nil, log commands to the \"*imap log*\" buffer.") + (defun nnimap-log-command (command) - (with-current-buffer (get-buffer-create "*imap log*") - (goto-char (point-max)) - (insert (format-time-string "%H:%M:%S") " " - (if nnimap-inhibit-logging - "(inhibited)\n" - command))) + (when nnimap-record-commands + (with-current-buffer (get-buffer-create "*imap log*") + (goto-char (point-max)) + (insert (format-time-string "%H:%M:%S") + " [" nnimap-address "] " + (if nnimap-inhibit-logging + "(inhibited)\n" + command)))) command) (defun nnimap-command (&rest args) @@ -1666,11 +1785,23 @@ textual parts.") (looking-at "\\*")))) (not (looking-at (format "%d .*\n" sequence))))) (when messagep - (nnheader-message 7 "nnimap read %dk" (/ (buffer-size) 1000))) + (nnheader-message-maybe + 7 "nnimap read %dk from %s%s" (/ (buffer-size) 1000) + nnimap-address + (if (not (zerop (nnimap-initial-resync nnimap-object))) + (format " (initial sync of %d group%s; please wait)" + (nnimap-initial-resync nnimap-object) + (if (= (nnimap-initial-resync nnimap-object) 1) + "" + "s")) + ""))) (nnheader-accept-process-output process) (goto-char (point-max))) + (setf (nnimap-initial-resync nnimap-object) 0) 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). @@ -1762,19 +1893,28 @@ 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 () (with-current-buffer (nnimap-buffer) (let ((nnimap-incoming-split-list nil) - (nnmail-split-methods (if (eq nnimap-split-methods 'default) - nnmail-split-methods - nnimap-split-methods)) + (nnmail-split-methods + (cond + ((eq nnimap-split-methods 'default) + nnmail-split-methods) + (nnimap-split-methods + nnimap-split-methods) + (nnimap-split-fancy + 'nnmail-split-fancy))) (nnmail-split-fancy (or nnimap-split-fancy nnmail-split-fancy)) (nnmail-inhibit-default-split-group t) @@ -1878,7 +2018,7 @@ textual parts.") (let (article bytes) (block nil (while (not (eobp)) - (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)")) + (while (not (looking-at "\\* [0-9]+ FETCH.+UID \\([0-9]+\\)")) (delete-region (point) (progn (forward-line 1) (point))) (when (eobp) (return))) @@ -1911,6 +2051,21 @@ textual parts.") group-art)) nnimap-incoming-split-list))) +(defun nnimap-make-thread-query (header) + (let* ((id (mail-header-id header)) + (refs (split-string + (or (mail-header-references header) + ""))) + (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))))) + + (provide 'nnimap) ;;; nnimap.el ends here