(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")
(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")
(defstruct nnimap
group process commands capabilities select-result newlinep server
- last-command-time greeting)
+ last-command-time greeting examined)
(defvar nnimap-object nil)
(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))
(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 "subr" (fn file &optional arglist fileonly))
+(declare-function gnutls-negotiate "gnutls"
+ (proc type &optional priority-string trustfiles keyfiles))
(defun nnimap-open-connection (buffer)
(unless nnimap-keepalive-timer
(setf (nnimap-greeting nnimap-object)
(buffer-substring (line-beginning-position)
(line-end-position)))
- ;; Store the capabilities.
- (setf (nnimap-capabilities nnimap-object)
- (mapcar
- #'upcase
- (nnimap-find-parameter
- "CAPABILITY" (cdr (nnimap-command "CAPABILITY")))))
+ (nnimap-get-capabilities)
(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)
- (member "STARTTLS"
- (nnimap-capabilities nnimap-object)))
+ (nnimap-capability "STARTTLS"))
(eq nnimap-stream 'starttls))
(fboundp 'open-gnutls-stream))
(nnimap-command "STARTTLS")
- (gnutls-negotiate (nnimap-process nnimap-object) nil))
+ (gnutls-negotiate (nnimap-process nnimap-object) nil)
+ ;; Get the capabilities again -- they may have changed
+ ;; after doing STARTTLS.
+ (nnimap-get-capabilities))
((and (eq nnimap-stream 'network)
- (member "STARTTLS" (nnimap-capabilities nnimap-object)))
+ (nnimap-capability "STARTTLS"))
(let ((nnimap-stream 'starttls))
(let ((tls-process
(nnimap-open-connection buffer)))
;; 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"))
(nnimap-process nnimap-object))))))))
+(defun nnimap-get-capabilities ()
+ (setf (nnimap-capabilities nnimap-object)
+ (mapcar
+ #'upcase
+ (nnimap-find-parameter
+ "CAPABILITY" (cdr (nnimap-command "CAPABILITY"))))))
+
+(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)
(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
(let ((result (nnimap-possibly-change-group
;; Don't SELECT the group if we're going to select it
;; later, anyway.
- (if dont-check
+ (if (and dont-check
+ (assoc group nnimap-current-infos))
nil
group)
server))
1 group "SELECT")))))
(when (and info
marks)
- (nnimap-update-infos marks (list info)))
+ (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 (or (if uidnext
(deffoo nnimap-request-rename-group (group new-name &optional server)
(when (nnimap-possibly-change-group nil server)
(with-current-buffer (nnimap-buffer)
- ;; Make sure we don't have this group open read/write by asking
- ;; to examine a mailbox that doesn't exist. This seems to be
- ;; the only way that allows us to reliably go back to unselected
- ;; state on Courier.
- (nnimap-command "EXAMINE DOES.NOT.EXIST")
- (setf (nnimap-group nnimap-object) nil)
+ (nnimap-unselect-group)
(car (nnimap-command "RENAME %S %S"
(utf7-encode group t) (utf7-encode new-name t))))))
+(defun nnimap-unselect-group ()
+ ;; Make sure we don't have this group open read/write by asking
+ ;; to examine a mailbox that doesn't exist. This seems to be
+ ;; the only way that allows us to reliably go back to unselected
+ ;; state on Courier.
+ (nnimap-command "EXAMINE DOES.NOT.EXIST"))
+
(deffoo nnimap-request-expunge-group (group &optional server)
(when (nnimap-possibly-change-group group server)
(with-current-buffer (nnimap-buffer)
(if internal-move-group
(let ((result
(with-current-buffer (nnimap-buffer)
+ ;; Clear all flags before moving.
+ (nnimap-send-command "UID STORE %d FLAGS.SILENT ()"
+ article)
(nnimap-command "UID COPY %d %S"
article
(utf7-encode internal-move-group t)))))
(defun nnimap-find-article-by-message-id (group message-id)
(with-current-buffer (nnimap-buffer)
(erase-buffer)
- (setf (nnimap-group nnimap-object) nil)
- (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
+ (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)
(nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
(nnimap-article-ranges articles))
(cond
- ((member "UIDPLUS" (nnimap-capabilities nnimap-object))
+ ((nnimap-capability "UIDPLUS")
(nnimap-command "UID EXPUNGE %s"
(nnimap-article-ranges articles))
t)
(nnimap-add-cr)
(setq message (buffer-substring-no-properties (point-min) (point-max)))
(with-current-buffer (nnimap-buffer)
+ ;; If we have this group open read-only, then unselect it
+ ;; before appending to it.
+ (when (equal (nnimap-examined nnimap-object) group)
+ (nnimap-unselect-group))
+ (erase-buffer)
(setq sequence (nnimap-send-command
"APPEND %S {%d}" (utf7-encode group t)
(length message)))
+ (unless nnimap-streaming
+ (nnimap-wait-for-connection "^[+]"))
(process-send-string (get-buffer-process (current-buffer)) message)
(process-send-string (get-buffer-process (current-buffer))
(if (nnimap-newlinep nnimap-object)
(with-current-buffer (nnimap-buffer)
(setf (nnimap-group nnimap-object) nil)
(dolist (group groups)
+ (setf (nnimap-examined nnimap-object) group)
(push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
group)
sequences))
(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)))
+ (let ((qresyncp (nnimap-capability "QRESYNC"))
params groups sequences active uidvalidity modseq group)
;; Go through the infos and gather the data needed to know
;; what and how to request the data.
active (cdr (assq 'active params))
uidvalidity (cdr (assq 'uidvalidity params))
modseq (cdr (assq 'modseq params)))
+ (setf (nnimap-examined nnimap-object) group)
(if (and qresyncp
uidvalidity
modseq)
(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)
(not (gnus-active group)))
(gnus-set-active group
(cond
+ (active
+ (cons (min (or low (car active))
+ (car active))
+ (max (or high (cdr active))
+ (cdr active))))
((and low high)
(cons low high))
(uidnext
;; No articles in this group.
(cons uidnext (1- uidnext)))
- (active
- active)
(start-article
(cons start-article (1- start-article)))
(t
(setq marks (gnus-info-marks info))
(dolist (type (cdr nnimap-mark-alist))
(when (or (not (listp permanent-flags))
- (memq (assoc (caddr type) flags) permanent-flags)
+ (memq (car (assoc (caddr type) flags))
+ permanent-flags)
(memq '%* permanent-flags))
(let ((old-marks (assoc (car type) marks))
(new-marks
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)))))))))
+ (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))))))
+ nil t)))
(defun nnimap-possibly-change-group (group server)
(let ((open-result t))
(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)
(nnimap-wait-for-response sequence)
(nnimap-parse-response))
-(defun nnimap-wait-for-connection ()
+(defun nnimap-wait-for-connection (&optional regexp)
+ (unless regexp
+ (setq regexp "^[*.] .*\n"))
(let ((process (get-buffer-process (current-buffer))))
(goto-char (point-min))
(while (and (memq (process-status process)
'(open run))
- (not (re-search-forward "^[*.] .*\n" nil t)))
+ (not (re-search-forward regexp nil t)))
(nnheader-accept-process-output process)
(goto-char (point-min)))
(forward-line -1)
(split-string
(buffer-substring
(1+ (point))
- (1- (search-forward "]" (line-end-position) 'move)))))
+ (if (search-forward "]" (line-end-position) 'move)
+ (1- (point))
+ (point)))))
((eql char ?\()
(split-string
(buffer-substring
(1+ (point))
- (1- (search-forward ")" (line-end-position) 'move)))))
+ (if (search-forward ")" (line-end-position) 'move)
+ (1- (point))
+ (point)))))
((eql char ?\")
(forward-char 1)
(buffer-substring
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)
(cond
;; If the server supports it, we now delete the message we have
;; just copied over.
- ((member "UIDPLUS" (nnimap-capabilities nnimap-object))
+ ((nnimap-capability "UIDPLUS")
(setq sequence (nnimap-send-command "UID EXPUNGE %s" range)))
;; If it doesn't support UID EXPUNGE, then we only expunge if the
;; user has configured it.
(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))))
projects / gnus / blobdiff