X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=37956058f0e33af94f8d09357c7fb8ccf9df6e13;hb=948fb6f339533184dc61abd31473606e427efca6;hp=1109f1e89b00cd77889102e9be60095b76005a18;hpb=e9a458f0f737829c8c43ed1cbd4b4dcf0f833852;p=gnus diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 1109f1e89..37956058f 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -78,6 +78,9 @@ Uses the same syntax as nnmail-split-methods") (defvoo nnimap-split-fancy nil "Uses the same syntax as nnmail-split-fancy.") +(defvoo nnimap-unsplittable-articles '(%Deleted %Seen) + "Articles with the flags in the list will not be considered when splitting.") + (make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'" "Emacs 24.1") @@ -136,6 +139,16 @@ textual parts.") (defun nnimap-buffer () (nnimap-find-process-buffer nntp-server-buffer)) +(defun nnimap-header-parameters () + (format "(UID RFC822.SIZE BODYSTRUCTURE %s)" + (format + (if (nnimap-ver4-p) + "BODY.PEEK[HEADER.FIELDS %s]" + "RFC822.HEADER.LINES %s") + (append '(Subject From Date Message-Id + References In-Reply-To Xref) + nnmail-extra-headers)))) + (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old) (with-current-buffer nntp-server-buffer (erase-buffer) @@ -146,14 +159,7 @@ textual parts.") (nnimap-send-command "UID FETCH %s %s" (nnimap-article-ranges (gnus-compress-sequence articles)) - (format "(UID RFC822.SIZE BODYSTRUCTURE %s)" - (format - (if (nnimap-ver4-p) - "BODY.PEEK[HEADER.FIELDS %s]" - "RFC822.HEADER.LINES %s") - (append '(Subject From Date Message-Id - References In-Reply-To Xref) - nnmail-extra-headers)))) + (nnimap-header-parameters)) t) (nnimap-transform-headers)) (insert-buffer-substring @@ -171,7 +177,7 @@ textual parts.") (return))) (setq article (match-string 1)) ;; Unfold quoted {number} strings. - (while (re-search-forward "[^]] {\\([0-9]+\\)}\r\n" + (while (re-search-forward "[^]][ (]{\\([0-9]+\\)}\r\n" (1+ (line-end-position)) t) (setq size (string-to-number (match-string 1))) (delete-region (+ (match-beginning 0) 2) (point)) @@ -200,7 +206,8 @@ textual parts.") (insert (format "Chars: %s\n" size))) (when lines (insert (format "Lines: %s\n" lines))) - (re-search-forward "^\r$") + (unless (re-search-forward "^\r$" nil t) + (goto-char (point-max))) (delete-region (line-beginning-position) (line-end-position)) (insert ".") (forward-line 1))))) @@ -304,6 +311,8 @@ textual parts.") ((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 @@ -313,18 +322,24 @@ textual parts.") "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) - (let ((tls-program "openssl s_client %s -connect %h:%p -no_ssl2 -ign_eof -starttls imap")) + (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")) - 'starttls)) + (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) @@ -400,9 +415,18 @@ textual parts.") ;; physical address. (nnimap-credentials nnimap-address ports))))) (setq nnimap-object nil) - (setq login-result (nnimap-command "LOGIN %S %S" - (car credentials) - (cadr credentials))) + (setq login-result + (if (member "AUTH=PLAIN" + (nnimap-capabilities nnimap-object)) + (nnimap-command + "AUTHENTICATE PLAIN %s" + (base64-encode-string + (format "\000%s\000%s" + (nnimap-quote-specials (car credentials)) + (nnimap-quote-specials (cadr credentials))))) + (nnimap-command "LOGIN %S %S" + (car credentials) + (cadr credentials)))) (unless (car login-result) ;; If the login failed, then forget the credentials ;; that are now possibly cached. @@ -419,6 +443,16 @@ textual parts.") (nnimap-command "ENABLE QRESYNC")) (nnimap-process nnimap-object)))))))) +(defun nnimap-quote-specials (string) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "[\\\"]" nil t) + (forward-char -1) + (insert "\\") + (forward-char 1)) + (buffer-string))) + (defun nnimap-find-parameter (parameter elems) (let (result) (dolist (elem elems) @@ -435,6 +469,7 @@ textual parts.") (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 () @@ -468,7 +503,7 @@ textual parts.") (let ((start (point))) (forward-sexp 1) (downcase-region start (point)) - (goto-char (point)) + (goto-char start) (read (current-buffer)))) parts (nnimap-find-wanted-parts structure)))) (when (if parts @@ -481,12 +516,28 @@ textual parts.") (nnheader-ms-strip-cr) (cons group article))))))))) -(defun nnimap-get-whole-article (article) +(deffoo nnimap-request-head (article &optional group server to-buffer) + (when (nnimap-possibly-change-group group server) + (with-current-buffer (nnimap-buffer) + (when (stringp article) + (setq article (nnimap-find-article-by-message-id group article))) + (nnimap-get-whole-article + article (format "UID FETCH %%d %s" + (nnimap-header-parameters))) + (let ((buffer (current-buffer))) + (with-current-buffer (or to-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring buffer) + (nnheader-ms-strip-cr) + (cons group article)))))) + +(defun nnimap-get-whole-article (article &optional command) (let ((result (nnimap-command - (if (nnimap-ver4-p) - "UID FETCH %d BODY.PEEK[]" - "UID FETCH %d RFC822.PEEK") + (or 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)) @@ -556,9 +607,9 @@ textual parts.") (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)))) + (let ((has-boundary (member "boundary" bstruc))) + (when has-boundary + (setq boundary (cadr has-boundary))))) (when subp (insert (format "Content-type: multipart/%s; boundary=%S\n\n" (downcase type) boundary))) @@ -608,7 +659,13 @@ textual parts.") (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 @@ -625,6 +682,7 @@ textual parts.") (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 @@ -698,7 +756,11 @@ textual parts.") (deffoo nnimap-request-move-article (article group server accept-form &optional last internal-move-group) (with-temp-buffer - (when (nnimap-request-article article group server (current-buffer)) + (mm-disable-multibyte) + (when (funcall (if internal-move-group + 'nnimap-request-head + 'nnimap-request-article) + article group server (current-buffer)) ;; If the move is internal (on the same server), just do it the easy ;; way. (let ((message-id (message-field-value "message-id"))) @@ -728,7 +790,7 @@ textual parts.") ((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 @@ -753,8 +815,9 @@ textual parts.") (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 @@ -824,7 +887,7 @@ textual parts.") (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) @@ -863,7 +926,7 @@ textual parts.") (let ((message-id (message-field-value "message-id")) sequence message) (nnimap-add-cr) - (setq message (buffer-string)) + (setq message (buffer-substring-no-properties (point-min) (point-max))) (with-current-buffer (nnimap-buffer) (setq sequence (nnimap-send-command "APPEND %S {%d}" (utf7-encode group t) @@ -876,11 +939,22 @@ textual parts.") (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)))))))) +(deffoo nnimap-request-replace-article (article group buffer) + (let (group-art) + (when (and (nnimap-possibly-change-group group nil) + ;; Put the article into the group. + (with-current-buffer buffer + (setq group-art + (nnimap-request-accept-article group nil t)))) + (nnimap-delete-article (list article)) + ;; Return the new article number. + (cdr group-art)))) + (defun nnimap-add-cr () (goto-char (point-min)) (while (re-search-forward "\r?\n" nil t) @@ -957,7 +1031,6 @@ textual parts.") (with-current-buffer (nnimap-buffer) (erase-buffer) (setf (nnimap-group nnimap-object) nil) - ;; QRESYNC handling isn't implemented. (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 @@ -996,12 +1069,7 @@ textual parts.") (utf7-encode group t)) (nnimap-send-command "UID FETCH %d:* FLAGS" start) 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)))) sequences)))) (deffoo nnimap-finish-retrieve-group-infos (server infos sequences) @@ -1096,12 +1164,13 @@ textual parts.") (unless (eq permanent-flags 'not-scanned) (gnus-group-set-parameter info 'permanent-flags - (if (memq '%* permanent-flags) - t - nil))) + (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 (cdr (assq 'permanent-flags (gnus-info-params info))) + (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. @@ -1127,27 +1196,32 @@ textual parts.") (gnus-info-read info)) (gnus-info-read info)) read))) - (gnus-info-set-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)) - (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))))) + (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) @@ -1290,7 +1364,7 @@ textual parts.") (setq start end)) (setq start (point)) (goto-char end)) - (while (re-search-forward "\n* [0-9]+ FETCH " start t) + (while (re-search-forward "^\\* [0-9]+ FETCH " start t) (setq elems (read (current-buffer))) (push (cons (cadr (memq 'UID elems)) (cadr (memq 'FLAGS elems))) @@ -1310,6 +1384,25 @@ textual parts.") (setq nnimap-status-string "Read-only server") nil) +(deffoo nnimap-request-thread (id) + (let* ((refs (split-string + (or (mail-header-references (gnus-summary-article-header)) + ""))) + (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 @@ -1354,6 +1447,10 @@ textual parts.") (if (nnimap-newlinep nnimap-object) "" "\r")))) + ;; Some servers apparently can't have many outstanding + ;; commands, so throttle them. + (unless nnimap-streaming + (nnimap-wait-for-response nnimap-sequence)) nnimap-sequence) (defun nnimap-log-command (command) @@ -1406,7 +1503,7 @@ textual parts.") (point-min)) t))) (when messagep - (message "nnimap read %dk" (/ (buffer-size) 1000))) + (nnheader-message 7 "nnimap read %dk" (/ (buffer-size) 1000))) (nnheader-accept-process-output process) (goto-char (point-max))) openp) @@ -1433,6 +1530,7 @@ textual parts.") (defun nnimap-parse-line (line) (let (char result) (with-temp-buffer + (mm-disable-multibyte) (insert line) (goto-char (point-min)) (while (not (eobp)) @@ -1517,6 +1615,7 @@ textual parts.") new-articles) (erase-buffer) (nnimap-command "SELECT %S" nnimap-inbox) + (setf (nnimap-group nnimap-object) nnimap-inbox) (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*"))) (when new-articles (nnimap-fetch-inbox new-articles) @@ -1589,9 +1688,8 @@ textual parts.") (defun nnimap-new-articles (flags) (let (new) (dolist (elem flags) - (when (or (null (cdr elem)) - (and (not (memq '%Deleted (cdr elem))) - (not (memq '%Seen (cdr elem))))) + (unless (gnus-list-memq-of-list nnimap-unsplittable-articles + (cdr elem)) (push (car elem) new))) (gnus-compress-sequence (nreverse new))))