X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/733afdf4d9df952a2d06c40b067de3a62bceb26b..bca46f6bc64a99a1cdeceaa8cdd4eb6e1b9c8f21:/lisp/gnus/nnimap.el diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index e76ead515c..f41f4af71b 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -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) @@ -182,7 +190,7 @@ textual parts.") (let (article bytes 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.+UID \\([0-9]+\\)")) (delete-region (point) (progn (forward-line 1) (point))) (when (eobp) (return))) @@ -278,13 +286,14 @@ textual parts.") (push (current-buffer) nnimap-process-buffers) (current-buffer))) -(defun nnimap-credentials (address ports) +(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 @@ -339,8 +348,7 @@ textual parts.") (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")) @@ -354,21 +362,29 @@ 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 (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)) (setf (nnimap-process nnimap-object) stream) (setf (nnimap-stream-type nnimap-object) stream-type) (if (not stream) @@ -396,17 +412,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) @@ -521,10 +545,9 @@ 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 (nnimap-possibly-change-group group server) @@ -857,15 +880,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. @@ -906,7 +932,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) @@ -930,7 +956,8 @@ textual parts.") 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) @@ -1080,9 +1107,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))) @@ -1141,7 +1168,7 @@ 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) @@ -1204,6 +1231,10 @@ textual parts.") (deffoo nnimap-finish-retrieve-group-infos (server infos sequences) (when (and sequences + ;; Check that the process is still alive. + (get-buffer-process (nnimap-buffer)) + (memq (process-status (get-buffer-process (nnimap-buffer))) + '(open run)) (nnimap-possibly-change-group nil server)) (with-current-buffer (nnimap-buffer) ;; Wait for the final data to trickle in. @@ -1452,6 +1483,11 @@ textual parts.") ;; Change \Delete etc to %Delete, so that the 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) @@ -1491,9 +1527,9 @@ textual parts.") (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. @@ -1507,18 +1543,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))) @@ -1540,26 +1565,18 @@ 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)))) +(deffoo nnimap-request-thread (header &optional group server) + (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) (let ((open-result t)) @@ -1674,6 +1691,8 @@ textual parts.") (goto-char (point-max))) 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). @@ -1765,19 +1784,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) @@ -1881,7 +1909,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))) @@ -1914,6 +1942,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