;;; Code:
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
(eval-and-compile
(require 'nnheader))
(require 'nnoo)
(require 'netrc)
(require 'utf7)
+(require 'tls)
(require 'parse-time)
+(require 'nnmail)
+
+(eval-when-compile
+ (require 'gnus-sum))
(autoload 'auth-source-forget-user-or-password "auth-source")
(autoload 'auth-source-user-or-password "auth-source")
"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.")
+
+(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")
(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)
(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
(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))
(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)))))
(with-current-buffer buffer
(when (and nnimap-object
(nnimap-last-command-time nnimap-object)
- (> (time-to-seconds
+ (> (gnus-float-time
(time-subtract
now
(nnimap-last-command-time nnimap-object)))
(* 5 60)))
(nnimap-send-command "NOOP")))))))
+(declare-function gnutls-negotiate "gnutls"
+ (proc type &optional priority-string trustfiles keyfiles))
+
(defun nnimap-open-connection (buffer)
(unless nnimap-keepalive-timer
(setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
(port nil)
(ports
(cond
- ((eq nnimap-stream 'network)
+ ((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
"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)
- (starttls-open-stream
- "*nnimap*" (current-buffer) nnimap-address
- (setq port (or nnimap-server-port "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"))))
'("imap"))
- ((eq nnimap-stream 'ssl)
- (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"))))
+ ((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)
+ "*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)))
'(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)
+ (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
#'upcase
(nnimap-find-parameter
"CAPABILITY" (cdr (nnimap-command "CAPABILITY")))))
- (when (eq nnimap-stream 'starttls)
- (nnimap-command "STARTTLS")
- (starttls-negotiate (nnimap-process nnimap-object)))
(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)
+ (nnimap-capability "STARTTLS"))
+ (eq nnimap-stream 'starttls))
+ (fboundp 'open-gnutls-stream))
+ (nnimap-command "STARTTLS")
+ (gnutls-negotiate (nnimap-process nnimap-object) nil))
+ ((and (eq nnimap-stream 'network)
+ (nnimap-capability "STARTTLS"))
+ (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)
;; 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 (and (nnimap-capability "AUTH=PLAIN")
+ (nnimap-capability "LOGINDISABLED"))
+ (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.
(delete-process (nnimap-process nnimap-object))
(setq nnimap-object nil))))
(when nnimap-object
- (when (member "QRESYNC" (nnimap-capabilities nnimap-object))
+ (when (nnimap-capability "QRESYNC")
(nnimap-command "ENABLE QRESYNC"))
- t)))))))
+ (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)
result))
(deffoo nnimap-close-server (&optional server)
- t)
+ (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 ()
t)
(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
(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))
(delete-region (point) (point-max)))
t)))
+(defun nnimap-capability (capability)
+ (member capability (nnimap-capabilities nnimap-object)))
+
(defun nnimap-ver4-p ()
- (member "IMAP4REV1" (nnimap-capabilities nnimap-object)))
+ (nnimap-capability "IMAP4REV1"))
(defun nnimap-get-partial-article (article parts structure)
(let ((result
(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)))
(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 (and dont-check
+ (assoc group nnimap-current-infos))
+ nil
+ group)
+ server))
articles active marks high low)
(with-current-buffer nntp-server-buffer
(when result
(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
(nnimap-parse-flags
- (list (list group-sequence flag-sequence 1 group)))))
- (when info
- (nnimap-update-infos marks (list info)))
+ (list (list group-sequence flag-sequence
+ 1 group "SELECT")))))
+ (when (and info
+ marks)
+ (nnimap-update-infos marks (list info))
+ (nnimap-store-info info (gnus-active (gnus-info-group info))))
(goto-char (point-max))
(let ((uidnext (nth 5 (car marks))))
- (setq high (if uidnext<
projects / gnus / blobdiff