X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=1730bd4252c660b41b6f2fad5d94b5fe060cc3be;hb=4bc48529523159c55dcd62d5a6be60521540b371;hp=33c6cd3aa39c35604455fd00384fd17fe090479f;hpb=85df3b08e325e1bd9207087db369d0cbbcf3bb8b;p=gnus diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 33c6cd3aa..1730bd425 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -1,6 +1,6 @@ ;;; nnimap.el --- IMAP interface for Gnus -;; Copyright (C) 2010-2012 Free Software Foundation, Inc. +;; Copyright (C) 2010-2014 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Simon Josefsson @@ -26,10 +26,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-and-compile (require 'nnheader) ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for @@ -82,7 +78,8 @@ back on `network'.") (defvoo nnimap-inbox nil "The mail box where incoming mail arrives and should be split out of. -For example, \"INBOX\".") +This can be a string or a list of strings +For example, \"INBOX\" or (\"INBOX\" \"SENT\").") (defvoo nnimap-split-methods nil "How mail is split. @@ -94,12 +91,13 @@ Uses the same syntax as `nnmail-split-methods'.") (defvoo nnimap-unsplittable-articles '(%Deleted %Seen) "Articles with the flags in the list will not be considered when splitting.") -(make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'" +(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'.") +Possible choices are nil (use default methods), `anonymous', +`login', `plain' and `cram-md5'.") (defvoo nnimap-expunge t "If non-nil, expunge articles after deleting them. @@ -117,11 +115,21 @@ some servers.") (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 +If t, Gnus 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.") +(defgroup nnimap nil + "IMAP for Gnus." + :group 'gnus) + +(defcustom nnimap-request-articles-find-limit nil + "Limit the number of articles to look for after moving an article." + :type '(choice (const nil) integer) + :version "24.4" + :group 'nnimap) + (defvar nnimap-process nil) (defvar nnimap-status-string "") @@ -172,7 +180,7 @@ textual parts.") (setq group (nnimap-decode-gnus-group group))) (with-current-buffer nntp-server-buffer (erase-buffer) - (when (nnimap-possibly-change-group group server) + (when (nnimap-change-group group server) (with-current-buffer (nnimap-buffer) (erase-buffer) (nnimap-wait-for-response @@ -243,7 +251,9 @@ textual parts.") (insert (format "Chars: %s\n" size))) (when lines (insert (format "Lines: %s\n" lines))) - (unless (re-search-forward "^\r$" nil t) + ;; Most servers have a blank line after the headers, but + ;; Davmail doesn't. + (unless (re-search-forward "^\r$\\|^)\r?$" nil t) (goto-char (point-max))) (delete-region (line-beginning-position) (line-end-position)) (insert ".") @@ -338,7 +348,8 @@ textual parts.") (nnimap-last-command-time nnimap-object))) ;; More than five minutes since the last command. (* 5 60))) - (nnimap-send-command "NOOP"))))))) + (ignore-errors ;E.g. "buffer foo has no process". + (nnimap-send-command "NOOP")))))))) (defun nnimap-open-connection (buffer) ;; Be backwards-compatible -- the earlier value of nnimap-stream was @@ -366,7 +377,7 @@ textual parts.") (defun nnimap-open-connection-1 (buffer) (unless nnimap-keepalive-timer (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15) - 'nnimap-keepalive))) + #'nnimap-keepalive))) (with-current-buffer (nnimap-make-process-buffer buffer) (let* ((coding-system-for-read 'binary) (coding-system-for-write 'binary) @@ -443,8 +454,8 @@ textual parts.") (nnimap-credentials (gnus-delete-duplicates (list - nnimap-address - (nnoo-current-server 'nnimap))) + (nnoo-current-server 'nnimap) + nnimap-address)) ports nnimap-user)))) (setq nnimap-object nil) @@ -475,6 +486,8 @@ textual parts.") (when nnimap-object (when (nnimap-capability "QRESYNC") (nnimap-command "ENABLE QRESYNC")) + (nnheader-message 7 "Opening connection to %s...done" + nnimap-address) (nnimap-process nnimap-object)))))))) (autoload 'rfc2104-hash "rfc2104") @@ -485,9 +498,13 @@ textual parts.") ;; round trips than CRAM-MD5, and it's less likely to be buggy), ;; and we're using an encrypted connection. ((and (not (nnimap-capability "LOGINDISABLED")) - (eq (nnimap-stream-type nnimap-object) 'tls)) + (eq (nnimap-stream-type nnimap-object) 'tls) + (or (null nnimap-authenticator) + (eq nnimap-authenticator 'login))) (nnimap-command "LOGIN %S %S" user password)) - ((nnimap-capability "AUTH=CRAM-MD5") + ((and (nnimap-capability "AUTH=CRAM-MD5") + (or (null nnimap-authenticator) + (eq nnimap-authenticator 'cram-md5))) (erase-buffer) (let ((sequence (nnimap-send-command "AUTHENTICATE CRAM-MD5")) (challenge (nnimap-wait-for-line "^\\+\\(.*\\)\n"))) @@ -500,9 +517,13 @@ textual parts.") (base64-decode-string challenge)))) "\r\n")) (nnimap-wait-for-response sequence))) - ((not (nnimap-capability "LOGINDISABLED")) + ((and (not (nnimap-capability "LOGINDISABLED")) + (or (null nnimap-authenticator) + (eq nnimap-authenticator 'login))) (nnimap-command "LOGIN %S %S" user password)) - ((nnimap-capability "AUTH=PLAIN") + ((and (nnimap-capability "AUTH=PLAIN") + (or (null nnimap-authenticator) + (eq nnimap-authenticator 'plain))) (nnimap-command "AUTHENTICATE PLAIN %s" (base64-encode-string @@ -555,10 +576,10 @@ textual parts.") (when group (setq group (nnimap-decode-gnus-group group))) (with-current-buffer nntp-server-buffer - (let ((result (nnimap-possibly-change-group group server)) + (let ((result (nnimap-change-group group server)) parts structure) (when (stringp article) - (setq article (nnimap-find-article-by-message-id group article))) + (setq article (nnimap-find-article-by-message-id group server article))) (when (and result article) (erase-buffer) @@ -587,10 +608,10 @@ textual parts.") (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) + (when (nnimap-change-group group server) (with-current-buffer (nnimap-buffer) (when (stringp article) - (setq article (nnimap-find-article-by-message-id group article))) + (setq article (nnimap-find-article-by-message-id group server article))) (if (null article) nil (nnimap-get-whole-article @@ -603,6 +624,26 @@ textual parts.") (nnheader-ms-strip-cr) (cons group article))))))) +(deffoo nnimap-request-articles (articles &optional group server) + (when group + (setq group (nnimap-decode-gnus-group group))) + (with-current-buffer nntp-server-buffer + (let ((result (nnimap-change-group group server))) + (when result + (erase-buffer) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + (when (nnimap-command + (if (nnimap-ver4-p) + "UID FETCH %s BODY.PEEK[]" + "UID FETCH %s RFC822.PEEK") + (nnimap-article-ranges (gnus-compress-sequence articles))) + (let ((buffer (current-buffer))) + (with-current-buffer nntp-server-buffer + (nnheader-insert-buffer-substring buffer) + (nnheader-ms-strip-cr))) + t)))))) + (defun nnimap-get-whole-article (article &optional command) (let ((result (nnimap-command @@ -739,7 +780,7 @@ textual parts.") (deffoo nnimap-request-group (group &optional server dont-check info) (setq group (nnimap-decode-gnus-group group)) - (let ((result (nnimap-possibly-change-group + (let ((result (nnimap-change-group ;; Don't SELECT the group if we're going to select it ;; later, anyway. (if (and (not dont-check) @@ -789,19 +830,19 @@ textual parts.") (deffoo nnimap-request-create-group (group &optional server args) (setq group (nnimap-decode-gnus-group group)) - (when (nnimap-possibly-change-group nil server) + (when (nnimap-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) + (when (nnimap-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) + (when (nnimap-change-group nil server) (with-current-buffer (nnimap-buffer) (nnimap-unselect-group) (car (nnimap-command "RENAME %S %S" @@ -816,7 +857,7 @@ textual parts.") (deffoo nnimap-request-expunge-group (group &optional server) (setq group (nnimap-decode-gnus-group group)) - (when (nnimap-possibly-change-group group server) + (when (nnimap-change-group group server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "EXPUNGE"))))) @@ -844,6 +885,8 @@ textual parts.") (deffoo nnimap-request-move-article (article group server accept-form &optional last internal-move-group) (setq group (nnimap-decode-gnus-group group)) + (when internal-move-group + (setq internal-move-group (nnimap-decode-gnus-group internal-move-group))) (with-temp-buffer (mm-disable-multibyte) (when (funcall (if internal-move-group @@ -864,11 +907,12 @@ textual parts.") (cons internal-move-group (or (nnimap-find-uid-response "COPYUID" (cadr result)) (nnimap-find-article-by-message-id - internal-move-group message-id))))) + internal-move-group server message-id + nnimap-request-articles-find-limit))))) ;; Move the article to a different method. (let ((result (eval accept-form))) (when result - (nnimap-possibly-change-group group server) + (nnimap-change-group group server) (nnimap-delete-article article) result))))))) @@ -877,7 +921,7 @@ textual parts.") (cond ((null articles) nil) - ((not (nnimap-possibly-change-group group server)) + ((not (nnimap-change-group group server)) articles) ((and force (eq nnmail-expiry-target 'delete)) @@ -914,7 +958,7 @@ textual parts.") (gnus-server-equal (gnus-group-method nnmail-expiry-target) (gnus-server-to-method (format "nnimap:%s" server)))) - (and (nnimap-possibly-change-group group server) + (and (nnimap-change-group group server) (with-current-buffer (nnimap-buffer) (nnheader-message 7 "Expiring articles from %s: %s" group articles) (nnimap-command @@ -944,7 +988,7 @@ textual parts.") (when target (push article deleted-articles)))))))) ;; Change back to the current group again. - (nnimap-possibly-change-group group server) + (nnimap-change-group group server) (setq deleted-articles (nreverse deleted-articles)) (nnimap-delete-article (gnus-compress-sequence deleted-articles)) deleted-articles)) @@ -966,23 +1010,37 @@ textual parts.") (cdr (assoc "SEARCH" (cdr result)))))))))) -(defun nnimap-find-article-by-message-id (group message-id) +(defun nnimap-find-article-by-message-id (group server message-id + &optional limit) + "Search for message with MESSAGE-ID in GROUP from SERVER. +If LIMIT, first try to limit the search to the N last articles." (with-current-buffer (nnimap-buffer) (erase-buffer) - (unless (equal group (nnimap-group nnimap-object)) - (setf (nnimap-group nnimap-object) nil) - (setf (nnimap-examined nnimap-object) group) - (nnimap-send-command "EXAMINE %S" (utf7-encode group t))) - (let ((sequence - (nnimap-send-command "UID SEARCH HEADER Message-Id %S" message-id)) - article result) - (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 (cdr (assoc "SEARCH" (cdr result)))))) - (string-to-number article)))))) + (let* ((change-group-result (nnimap-change-group group server nil t)) + (number-of-article + (and (listp change-group-result) + (catch 'found + (dolist (result (cdr change-group-result)) + (when (equal "EXISTS" (cadr result)) + (throw 'found (car result))))))) + (sequence + (nnimap-send-command + "UID SEARCH%s HEADER Message-Id %S" + (if (and limit number-of-article) + ;; The -1 is because IMAP message + ;; numbers are one-based rather than + ;; zero-based. + (format " %s:*" (- (string-to-number number-of-article) + limit -1)) + "") + message-id))) + (when (nnimap-wait-for-response sequence) + (let ((article (car (last (cdr (assoc "SEARCH" + (nnimap-parse-response))))))) + (if article + (string-to-number article) + (when (and limit number-of-article) + (nnimap-find-article-by-message-id group server message-id)))))))) (defun nnimap-delete-article (articles) (with-current-buffer (nnimap-buffer) @@ -1003,11 +1061,14 @@ textual parts.") (deffoo nnimap-request-scan (&optional group server) (when group (setq group (nnimap-decode-gnus-group group))) - (when (and (nnimap-possibly-change-group nil server) + (when (and (nnimap-change-group nil server) nnimap-inbox nnimap-split-methods) (nnheader-message 7 "nnimap %s splitting mail..." server) - (nnimap-split-incoming-mail) + (if (listp nnimap-inbox) + (dolist (nnimap-inbox nnimap-inbox) + (nnimap-split-incoming-mail)) + (nnimap-split-incoming-mail)) (nnheader-message 7 "nnimap %s splitting mail...done" server))) (defun nnimap-marks-to-flags (marks) @@ -1019,7 +1080,7 @@ textual parts.") (deffoo nnimap-request-update-group-status (group status &optional server) (setq group (nnimap-decode-gnus-group group)) - (when (nnimap-possibly-change-group nil server) + (when (nnimap-change-group nil server) (let ((command (assoc status '((subscribe "SUBSCRIBE") @@ -1030,7 +1091,7 @@ textual parts.") (deffoo nnimap-request-set-mark (group actions &optional server) (setq group (nnimap-decode-gnus-group group)) - (when (nnimap-possibly-change-group group server) + (when (nnimap-change-group group server) (let (sequence) (with-current-buffer (nnimap-buffer) (erase-buffer) @@ -1054,8 +1115,16 @@ textual parts.") (nnimap-wait-for-response sequence)))))) (deffoo nnimap-request-accept-article (group &optional server last) + (unless group + ;; We're respooling. Find out where mail splitting would place + ;; this article. + (setq group + (caar + (nnmail-article-group + `(lambda (group) + (nnml-active-number group ,server)))))) (setq group (nnimap-decode-gnus-group group)) - (when (nnimap-possibly-change-group nil server) + (when (nnimap-change-group nil server) (nnmail-check-syntax) (let ((message-id (message-field-value "message-id")) sequence message) @@ -1087,7 +1156,8 @@ textual parts.") (cons group (or (nnimap-find-uid-response "APPENDUID" (car result)) (nnimap-find-article-by-message-id - group message-id)))))))))) + group server message-id + nnimap-request-articles-find-limit)))))))))) (defun nnimap-process-quirk (greeting-match type data) (when (and (nnimap-greeting nnimap-object) @@ -1133,7 +1203,7 @@ textual parts.") (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) + (when (and (nnimap-change-group group) ;; Put the article into the group. (with-current-buffer buffer (setq group-art @@ -1168,8 +1238,17 @@ textual parts.") groups)))) (nreverse groups))) +(defun nnimap-get-responses (sequences) + (let (responses) + (dolist (sequence sequences) + (goto-char (point-min)) + (when (re-search-forward (format "^%d " sequence) nil t) + (push (list sequence (nnimap-parse-response)) + responses))) + responses)) + (deffoo nnimap-request-list (&optional server) - (when (nnimap-possibly-change-group nil server) + (when (nnimap-change-group nil server) (with-current-buffer nntp-server-buffer (erase-buffer) (let ((groups @@ -1216,7 +1295,7 @@ textual parts.") t))))) (deffoo nnimap-request-newgroups (date &optional server) - (when (nnimap-possibly-change-group nil server) + (when (nnimap-change-group nil server) (with-current-buffer nntp-server-buffer (erase-buffer) (dolist (group (with-current-buffer (nnimap-buffer) @@ -1227,7 +1306,7 @@ textual parts.") t))) (deffoo nnimap-retrieve-group-data-early (server infos) - (when (and (nnimap-possibly-change-group nil server) + (when (and (nnimap-change-group nil server) infos) (with-current-buffer (nnimap-buffer) (erase-buffer) @@ -1293,7 +1372,7 @@ textual parts.") (deffoo nnimap-finish-retrieve-group-infos (server infos sequences) (when (and sequences - (nnimap-possibly-change-group nil server t) + (nnimap-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))) @@ -1411,7 +1490,9 @@ textual parts.") (gnus-set-difference (gnus-set-difference existing - (cdr (assoc '%Seen flags))) + (gnus-sorted-union + (cdr (assoc '%Seen flags)) + (cdr (assoc '%Deleted flags)))) (cdr (assoc '%Flagged flags))))) (read (gnus-range-difference (cons start-article high) unread))) @@ -1452,15 +1533,20 @@ textual parts.") (push (cons (car type) new-marks) marks))))) ;; Keep track of non-existing articles. (let* ((old-unexists (assq 'unexist marks)) + (active (gnus-active group)) (unexists (if completep (gnus-range-difference - (gnus-active group) + active (gnus-compress-sequence existing)) (gnus-add-to-range (cdr old-unexists) (gnus-list-range-difference existing (gnus-active group)))))) + (when (> (car active) 1) + (setq unexists (gnus-range-add + (cons 1 (1- (car active))) + unexists))) (if old-unexists (setcdr old-unexists unexists) (push (cons 'unexist unexists) marks))) @@ -1652,6 +1738,7 @@ textual parts.") (setq nnimap-status-string "Read-only server") nil) +(defvar gnus-refer-thread-use-nnir) ;; gnus-sum.el (declare-function gnus-fetch-headers "gnus-sum" (articles &optional limit force-new dependencies)) @@ -1662,7 +1749,7 @@ textual parts.") (setq group (nnimap-decode-gnus-group group))) (if gnus-refer-thread-use-nnir (nnir-search-thread header) - (when (nnimap-possibly-change-group group server) + (when (nnimap-change-group group server) (let* ((cmd (nnimap-make-thread-query header)) (result (with-current-buffer (nnimap-buffer) (nnimap-command "UID SEARCH %s" cmd)))) @@ -1673,7 +1760,14 @@ textual parts.") (cdr (assoc "SEARCH" (cdr result)))))) nil t)))))) -(defun nnimap-possibly-change-group (group server &optional no-reconnect) +(defun nnimap-change-group (group &optional server no-reconnect read-only) + "Change group to GROUP if non-nil. +If SERVER is set, check that server is connected, otherwise retry +to reconnect, unless NO-RECONNECT is set to t. Return nil if +unsuccessful in connecting. +If GROUP is nil, return t. +If READ-ONLY is set, send EXAMINE rather than SELECT to the server. +Return the server's response to the SELECT or EXAMINE command." (let ((open-result t)) (when (and server (not (nnimap-server-opened server))) @@ -1685,13 +1779,15 @@ textual parts.") t) (t (with-current-buffer (nnimap-buffer) - (if (equal group (nnimap-group nnimap-object)) - t - (let ((result (nnimap-command "SELECT %S" (utf7-encode group t)))) - (when (car result) - (setf (nnimap-group nnimap-object) group - (nnimap-select-result nnimap-object) result) - result)))))))) + (let ((result (nnimap-command "%s %S" + (if read-only + "EXAMINE" + "SELECT") + (utf7-encode group t)))) + (when (car result) + (setf (nnimap-group nnimap-object) group + (nnimap-select-result nnimap-object) result) + result))))))) (defun nnimap-find-connection (buffer) "Find the connection delivering to BUFFER." @@ -1727,15 +1823,24 @@ textual parts.") (defvar nnimap-record-commands nil "If non-nil, log commands to the \"*imap log*\" buffer.") +(defun nnimap-log-buffer () + (let ((name "*imap log*")) + (or (get-buffer name) + (with-current-buffer (get-buffer-create name) + (when (boundp 'window-point-insertion-type) + (make-local-variable 'window-point-insertion-type) + (setq window-point-insertion-type t)) + (current-buffer))))) + (defun nnimap-log-command (command) (when nnimap-record-commands - (with-current-buffer (get-buffer-create "*imap log*") + (with-current-buffer (nnimap-log-buffer) (goto-char (point-max)) (insert (format-time-string "%H:%M:%S") - " [" nnimap-address "] " - (if nnimap-inhibit-logging - "(inhibited)\n" - command)))) + " [" nnimap-address "] " + (if nnimap-inhibit-logging + "(inhibited)\n" + command)))) command) (defun nnimap-command (&rest args) @@ -1874,15 +1979,6 @@ textual parts.") (forward-line 1))) (buffer-substring (point) end)))) -(defun nnimap-get-responses (sequences) - (let (responses) - (dolist (sequence sequences) - (goto-char (point-min)) - (when (re-search-forward (format "^%d " sequence) nil t) - (push (list sequence (nnimap-parse-response)) - responses))) - responses)) - (defvar nnimap-incoming-split-list nil) (defun nnimap-fetch-inbox (articles)