1 ;;; nnimap.el --- IMAP interface for Gnus
3 ;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Simon Josefsson <simon@josefsson.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; nnimap interfaces Gnus with IMAP servers.
29 ;; For Emacs <22.2 and XEmacs.
31 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
35 ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for
36 ;; `make-network-stream'.
37 (unless (fboundp 'open-protocol-stream)
38 (require 'proto-stream)))
53 (autoload 'auth-source-forget+ "auth-source")
54 (autoload 'auth-source-search "auth-source")
58 (defvoo nnimap-address nil
59 "The address of the IMAP server.")
61 (defvoo nnimap-user nil
62 "Username to use for authentication to the IMAP server.")
64 (defvoo nnimap-server-port nil
66 If nnimap-stream is `ssl', this will default to `imaps'. If not,
67 it will default to `imap'.")
69 (defvoo nnimap-stream 'undecided
70 "How nnimap talks to the IMAP server.
71 The value should be either `undecided', `ssl' or `tls',
72 `network', `starttls', `plain', or `shell'.
74 If the value is `undecided', nnimap tries `ssl' first, then falls
77 (defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
78 (if (listp imap-shell-program)
79 (car imap-shell-program)
83 (defvoo nnimap-inbox nil
84 "The mail box where incoming mail arrives and should be split out of.
85 This can be a string or a list of strings
86 For example, \"INBOX\" or (\"INBOX\" \"SENT\").")
88 (defvoo nnimap-split-methods nil
90 Uses the same syntax as `nnmail-split-methods'.")
92 (defvoo nnimap-split-fancy nil
93 "Uses the same syntax as `nnmail-split-fancy'.")
95 (defvoo nnimap-unsplittable-articles '(%Deleted %Seen)
96 "Articles with the flags in the list will not be considered when splitting.")
98 (make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'"
101 (defvoo nnimap-authenticator nil
102 "How nnimap authenticate itself to the server.
103 Possible choices are nil (use default methods), `anonymous',
104 `login', `plain' and `cram-md5'.")
106 (defvoo nnimap-expunge t
107 "If non-nil, expunge articles after deleting them.
108 This is always done if the server supports UID EXPUNGE, but it's
109 not done by default on servers that doesn't support that command.")
111 (defvoo nnimap-streaming t
112 "If non-nil, try to use streaming commands with IMAP servers.
113 Switching this off will make nnimap slower, but it helps with
116 (defvoo nnimap-connection-alist nil)
118 (defvoo nnimap-current-infos nil)
120 (defvoo nnimap-fetch-partial-articles nil
121 "If non-nil, Gnus will fetch partial articles.
122 If t, Gnus will fetch only the first part. If a string, it
123 will fetch all parts that have types that match that string. A
124 likely value would be \"text/\" to automatically fetch all
131 (defcustom nnimap-request-articles-find-limit nil
132 "Limit the number of articles to look for after moving an article."
137 (defvar nnimap-process nil)
139 (defvar nnimap-status-string "")
141 (defvar nnimap-split-download-body-default nil
142 "Internal variable with default value for `nnimap-split-download-body'.")
144 (defvar nnimap-keepalive-timer nil)
145 (defvar nnimap-process-buffers nil)
148 group process commands capabilities select-result newlinep server
149 last-command-time greeting examined stream-type initial-resync)
151 (defvar nnimap-object nil)
153 (defvar nnimap-mark-alist
154 '((read "\\Seen" %Seen)
155 (tick "\\Flagged" %Flagged)
156 (reply "\\Answered" %Answered)
157 (expire "gnus-expire")
158 (dormant "gnus-dormant")
161 (download "gnus-download")
162 (forward "gnus-forward")))
164 (defvar nnimap-quirks
165 '(("QRESYNC" "Zimbra" "QRESYNC ")))
167 (defvar nnimap-inhibit-logging nil)
169 (defun nnimap-buffer ()
170 (nnimap-find-process-buffer nntp-server-buffer))
172 (defun nnimap-header-parameters ()
173 (format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
176 "BODY.PEEK[HEADER.FIELDS %s]"
177 "RFC822.HEADER.LINES %s")
178 (append '(Subject From Date Message-Id
179 References In-Reply-To Xref)
180 nnmail-extra-headers))))
182 (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old)
184 (setq group (nnimap-decode-gnus-group group)))
185 (with-current-buffer nntp-server-buffer
187 (when (nnimap-change-group group server)
188 (with-current-buffer (nnimap-buffer)
190 (nnimap-wait-for-response
193 (nnimap-article-ranges (gnus-compress-sequence articles))
194 (nnimap-header-parameters))
196 (nnimap-transform-headers)
197 (nnheader-remove-cr-followed-by-lf))
198 (insert-buffer-substring
199 (nnimap-find-process-buffer (current-buffer))))
202 (defun nnimap-transform-headers ()
203 (goto-char (point-min))
204 (let (article lines size string)
207 (while (not (looking-at "\\* [0-9]+ FETCH"))
208 (delete-region (point) (progn (forward-line 1) (point)))
211 (goto-char (match-end 0))
212 ;; Unfold quoted {number} strings.
213 (while (re-search-forward
214 "[^]][ (]{\\([0-9]+\\)}\r?\n"
216 ;; Start of the header section.
217 (or (re-search-forward "] {[0-9]+}\r?\n" nil t)
218 ;; Start of the next FETCH.
219 (re-search-forward "\\* [0-9]+ FETCH" nil t)
222 (setq size (string-to-number (match-string 1)))
223 (delete-region (+ (match-beginning 0) 2) (point))
224 (setq string (buffer-substring (point) (+ (point) size)))
225 (delete-region (point) (+ (point) size))
226 (insert (format "%S" (mm-subst-char-in-string ?\n ?\s string))))
229 (and (re-search-forward "UID \\([0-9]+\\)" (line-end-position)
234 (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)"
239 (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
240 (let ((structure (ignore-errors
241 (read (current-buffer)))))
242 (while (and (consp structure)
243 (not (atom (car structure))))
244 (setq structure (car structure)))
246 (stringp (car structure))
247 (equal (upcase (nth 0 structure)) "MESSAGE")
248 (equal (upcase (nth 1 structure)) "RFC822"))
250 (nth 7 structure)))))
251 (delete-region (line-beginning-position) (line-end-position))
252 (insert (format "211 %s Article retrieved." article))
255 (insert (format "Chars: %s\n" size)))
257 (insert (format "Lines: %s\n" lines)))
258 (unless (re-search-forward "^\r$" nil t)
259 (goto-char (point-max)))
260 (delete-region (line-beginning-position) (line-end-position))
264 (defun nnimap-unfold-quoted-lines ()
265 ;; Unfold quoted {number} strings.
267 (while (re-search-forward " {\\([0-9]+\\)}\r?\n" nil t)
268 (setq size (string-to-number (match-string 1)))
269 (delete-region (1+ (match-beginning 0)) (point))
270 (setq string (buffer-substring (point) (+ (point) size)))
271 (delete-region (point) (+ (point) size))
272 (insert (format "%S" string)))))
274 (defun nnimap-get-length ()
275 (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t)
276 (string-to-number (match-string 1))))
278 (defun nnimap-article-ranges (ranges)
282 (number-to-string ranges))
283 ((numberp (cdr ranges))
284 (format "%d:%d" (car ranges) (cdr ranges)))
286 (dolist (elem ranges)
289 (format "%d:%d" (car elem) (cdr elem))
290 (number-to-string elem))
292 (mapconcat #'identity (nreverse result) ",")))))
294 (deffoo nnimap-open-server (server &optional defs no-reconnect)
295 (if (nnimap-server-opened server)
297 (unless (assq 'nnimap-address defs)
298 (setq defs (append defs (list (list 'nnimap-address server)))))
299 (nnoo-change-server 'nnimap server defs)
301 (nnimap-find-connection nntp-server-buffer)
302 (or (nnimap-find-connection nntp-server-buffer)
303 (nnimap-open-connection nntp-server-buffer)))))
305 (defun nnimap-make-process-buffer (buffer)
307 (generate-new-buffer (format " *nnimap %s %s %s*"
308 nnimap-address nnimap-server-port
309 (gnus-buffer-exists-p buffer)))
310 (mm-disable-multibyte)
311 (buffer-disable-undo)
313 (set (make-local-variable 'after-change-functions) nil)
314 (set (make-local-variable 'nnimap-object)
315 (make-nnimap :server (nnoo-current-server 'nnimap)
317 (push (list buffer (current-buffer)) nnimap-connection-alist)
318 (push (current-buffer) nnimap-process-buffers)
321 (defun nnimap-credentials (address ports user)
322 (let* ((auth-source-creation-prompts
323 '((user . "IMAP user at %h: ")
324 (secret . "IMAP password for %u@%h: ")))
325 (found (nth 0 (auth-source-search :max 1
329 :require '(:user :secret)
332 (list (plist-get found :user)
333 (let ((secret (plist-get found :secret)))
334 (if (functionp secret)
337 (plist-get found :save-function))
340 (defun nnimap-keepalive ()
341 (let ((now (current-time)))
342 (dolist (buffer nnimap-process-buffers)
343 (when (buffer-name buffer)
344 (with-current-buffer buffer
345 (when (and nnimap-object
346 (nnimap-last-command-time nnimap-object)
350 (nnimap-last-command-time nnimap-object)))
351 ;; More than five minutes since the last command.
353 (ignore-errors ;E.g. "buffer foo has no process".
354 (nnimap-send-command "NOOP"))))))))
356 (defun nnimap-open-connection (buffer)
357 ;; Be backwards-compatible -- the earlier value of nnimap-stream was
358 ;; `ssl' when nnimap-server-port was nil. Sort of.
359 (when (and nnimap-server-port
360 (eq nnimap-stream 'undecided))
361 (setq nnimap-stream 'ssl))
363 (if (eq nnimap-stream 'undecided)
364 (loop for type in '(ssl network)
365 for stream = (let ((nnimap-stream type))
366 (nnimap-open-connection-1 buffer))
367 while (eq stream 'no-connect)
368 finally (return stream))
369 (nnimap-open-connection-1 buffer))))
370 (if (eq stream 'no-connect)
374 (defun nnimap-map-port (port)
375 (if (equal port "imaps")
379 (defun nnimap-open-connection-1 (buffer)
380 (unless nnimap-keepalive-timer
381 (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
382 #'nnimap-keepalive)))
383 (with-current-buffer (nnimap-make-process-buffer buffer)
384 (let* ((coding-system-for-read 'binary)
385 (coding-system-for-write 'binary)
388 ((memq nnimap-stream '(network plain starttls))
389 (nnheader-message 7 "Opening connection to %s..."
392 ((eq nnimap-stream 'shell)
393 (nnheader-message 7 "Opening connection to %s via shell..."
396 ((memq nnimap-stream '(ssl tls))
397 (nnheader-message 7 "Opening connection to %s via tls..."
399 '("imaps" "imap" "993" "143"))
401 (error "Unknown stream type: %s" nnimap-stream))))
402 login-result credentials)
403 (when nnimap-server-port
404 (push nnimap-server-port ports))
406 (open-protocol-stream
407 "*nnimap*" (current-buffer) nnimap-address
408 (nnimap-map-port (car ports))
411 :shell-command nnimap-shell-program
412 :capability-command "1 CAPABILITY\r\n"
413 :end-of-command "\r\n"
416 (lambda (capabilities)
417 (when (gnus-string-match-p "STARTTLS" capabilities)
419 (stream (car stream-list))
420 (props (cdr stream-list))
421 (greeting (plist-get props :greeting))
422 (capabilities (plist-get props :capabilities))
423 (stream-type (plist-get props :type)))
424 (when (and stream (not (memq (process-status stream) '(open run))))
427 (when (and (fboundp 'set-network-process-option) ;; Not in XEmacs.
428 (fboundp 'process-type) ;; Emacs 22 doesn't provide it.
429 (eq (process-type stream) 'network))
430 ;; Use TCP-keepalive so that connections that pass through a NAT
431 ;; router don't hang when left idle.
432 (set-network-process-option stream :keepalive t))
434 (setf (nnimap-process nnimap-object) stream)
435 (setf (nnimap-stream-type nnimap-object) stream-type)
438 (nnheader-report 'nnimap "Unable to contact %s:%s via %s"
439 nnimap-address (car ports) nnimap-stream)
441 (gnus-set-process-query-on-exit-flag stream nil)
442 (if (not (gnus-string-match-p "[*.] \\(OK\\|PREAUTH\\)" greeting))
443 (nnheader-report 'nnimap "%s" greeting)
444 ;; Store the greeting (for debugging purposes).
445 (setf (nnimap-greeting nnimap-object) greeting)
446 (setf (nnimap-capabilities nnimap-object)
448 (split-string capabilities)))
449 (unless (gnus-string-match-p "[*.] PREAUTH" greeting)
450 (if (not (setq credentials
451 (if (eq nnimap-authenticator 'anonymous)
453 (message-make-address))
454 ;; Look for the credentials based on
455 ;; the virtual server name and the address
457 (gnus-delete-duplicates
460 (nnoo-current-server 'nnimap)))
463 (setq nnimap-object nil)
464 (let ((nnimap-inhibit-logging t))
466 (nnimap-login (car credentials) (cadr credentials))))
467 (if (car login-result)
469 ;; Save the credentials if a save function exists
470 ;; (such a function will only be passed if a new
471 ;; token was created).
472 (when (functionp (nth 2 credentials))
473 (funcall (nth 2 credentials)))
474 ;; See if CAPABILITY is set as part of login
476 (dolist (response (cddr login-result))
477 (when (string= "CAPABILITY" (upcase (car response)))
478 (setf (nnimap-capabilities nnimap-object)
479 (mapcar #'upcase (cdr response))))))
480 ;; If the login failed, then forget the credentials
481 ;; that are now possibly cached.
482 (dolist (host (list (nnoo-current-server 'nnimap)
485 (auth-source-forget+ :host host :port port)))
486 (delete-process (nnimap-process nnimap-object))
487 (setq nnimap-object nil))))
489 (when (nnimap-capability "QRESYNC")
490 (nnimap-command "ENABLE QRESYNC"))
491 (nnheader-message 7 "Opening connection to %s...done"
493 (nnimap-process nnimap-object))))))))
495 (autoload 'rfc2104-hash "rfc2104")
497 (defun nnimap-login (user password)
499 ;; Prefer plain LOGIN if it's enabled (since it requires fewer
500 ;; round trips than CRAM-MD5, and it's less likely to be buggy),
501 ;; and we're using an encrypted connection.
502 ((and (not (nnimap-capability "LOGINDISABLED"))
503 (eq (nnimap-stream-type nnimap-object) 'tls)
504 (or (null nnimap-authenticator)
505 (eq nnimap-authenticator 'login)))
506 (nnimap-command "LOGIN %S %S" user password))
507 ((and (nnimap-capability "AUTH=CRAM-MD5")
508 (or (null nnimap-authenticator)
509 (eq nnimap-authenticator 'cram-md5)))
511 (let ((sequence (nnimap-send-command "AUTHENTICATE CRAM-MD5"))
512 (challenge (nnimap-wait-for-line "^\\+\\(.*\\)\n")))
514 (get-buffer-process (current-buffer))
516 (base64-encode-string
518 (rfc2104-hash 'md5 64 16 password
519 (base64-decode-string challenge))))
521 (nnimap-wait-for-response sequence)))
522 ((and (not (nnimap-capability "LOGINDISABLED"))
523 (or (null nnimap-authenticator)
524 (eq nnimap-authenticator 'login)))
525 (nnimap-command "LOGIN %S %S" user password))
526 ((and (nnimap-capability "AUTH=PLAIN")
527 (or (null nnimap-authenticator)
528 (eq nnimap-authenticator 'plain)))
530 "AUTHENTICATE PLAIN %s"
531 (base64-encode-string
532 (format "\000%s\000%s"
533 (nnimap-quote-specials user)
534 (nnimap-quote-specials password)))))))
536 (defun nnimap-quote-specials (string)
539 (goto-char (point-min))
540 (while (re-search-forward "[\\\"]" nil t)
546 (defun nnimap-find-parameter (parameter elems)
550 ((equal (car elem) parameter)
551 (setq result (cdr elem)))
552 ((and (equal (car elem) "OK")
554 (equal (caadr elem) parameter))
555 (setq result (cdr (cadr elem))))))
558 (deffoo nnimap-close-server (&optional server)
559 (when (nnoo-change-server 'nnimap server nil)
561 (delete-process (get-buffer-process (nnimap-buffer))))
562 (nnoo-close-server 'nnimap server)
565 (deffoo nnimap-request-close ()
568 (deffoo nnimap-server-opened (&optional server)
569 (and (nnoo-current-server-p 'nnimap server)
571 (gnus-buffer-live-p nntp-server-buffer)
572 (nnimap-find-connection nntp-server-buffer)))
574 (deffoo nnimap-status-message (&optional server)
575 nnimap-status-string)
577 (deffoo nnimap-request-article (article &optional group server to-buffer)
579 (setq group (nnimap-decode-gnus-group group)))
580 (with-current-buffer nntp-server-buffer
581 (let ((result (nnimap-change-group group server))
583 (when (stringp article)
584 (setq article (nnimap-find-article-by-message-id group server article)))
588 (with-current-buffer (nnimap-buffer)
590 (when nnimap-fetch-partial-articles
591 (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article)
592 (goto-char (point-min))
593 (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t)
594 (setq structure (ignore-errors
595 (let ((start (point)))
597 (downcase-region start (point))
599 (read (current-buffer))))
600 parts (nnimap-find-wanted-parts structure))))
602 (nnimap-get-partial-article article parts structure)
603 (nnimap-get-whole-article article))
604 (let ((buffer (current-buffer)))
605 (with-current-buffer (or to-buffer nntp-server-buffer)
606 (nnheader-insert-buffer-substring buffer)
607 (nnheader-ms-strip-cr)))
608 (cons group article)))))))
610 (deffoo nnimap-request-head (article &optional group server to-buffer)
612 (setq group (nnimap-decode-gnus-group group)))
613 (when (nnimap-change-group group server)
614 (with-current-buffer (nnimap-buffer)
615 (when (stringp article)
616 (setq article (nnimap-find-article-by-message-id group server article)))
619 (nnimap-get-whole-article
620 article (format "UID FETCH %%d %s"
621 (nnimap-header-parameters)))
622 (let ((buffer (current-buffer)))
623 (with-current-buffer (or to-buffer nntp-server-buffer)
625 (insert-buffer-substring buffer)
626 (nnheader-ms-strip-cr)
627 (cons group article)))))))
629 (defun nnimap-get-whole-article (article &optional command)
634 "UID FETCH %d BODY.PEEK[]"
635 "UID FETCH %d RFC822.PEEK"))
637 ;; Check that we really got an article.
638 (goto-char (point-min))
639 (unless (re-search-forward "\\* [0-9]+ FETCH" nil t)
642 ;; Remove any data that may have arrived before the FETCH data.
645 (delete-region (point-min) (point)))
646 (let ((bytes (nnimap-get-length)))
647 (delete-region (line-beginning-position)
648 (progn (forward-line 1) (point)))
649 (goto-char (+ (point) bytes))
650 (delete-region (point) (point-max)))
653 (defun nnimap-capability (capability)
654 (member capability (nnimap-capabilities nnimap-object)))
656 (defun nnimap-ver4-p ()
657 (nnimap-capability "IMAP4REV1"))
659 (defun nnimap-get-partial-article (article parts structure)
662 "UID FETCH %d (%s %s)"
668 (mapconcat (lambda (part)
669 (format "BODY.PEEK[%s]" part))
671 (mapconcat (lambda (part)
672 (format "RFC822.PEEK[%s]" part))
675 (nnimap-convert-partial-article structure))))
677 (defun nnimap-convert-partial-article (structure)
678 ;; First just skip past the headers.
679 (goto-char (point-min))
680 (let ((bytes (nnimap-get-length))
682 ;; Delete "FETCH" line.
683 (delete-region (line-beginning-position)
684 (progn (forward-line 1) (point)))
685 (goto-char (+ (point) bytes))
686 ;; Collect all the body parts.
687 (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]")
688 (setq id (match-string 1)
689 bytes (or (nnimap-get-length) 0))
691 (delete-region (point) (progn (forward-line 1) (point)))
692 (push (list id (buffer-substring (point) (+ (point) bytes)))
694 (delete-region (point) (+ (point) bytes)))
695 ;; Delete trailing junk.
696 (delete-region (point) (point-max))
697 ;; Now insert all the parts again where they fit in the structure.
698 (nnimap-insert-partial-structure structure parts)
701 (defun nnimap-insert-partial-structure (structure parts &optional subp)
703 (let ((bstruc structure))
704 (while (consp (car bstruc))
706 (setq type (car bstruc))
707 (setq bstruc (car (cdr bstruc)))
708 (let ((has-boundary (member "boundary" bstruc)))
710 (setq boundary (cadr has-boundary)))))
712 (insert (format "Content-type: multipart/%s; boundary=%S\n\n"
713 (downcase type) boundary)))
714 (while (not (stringp (car structure)))
715 (insert "\n--" boundary "\n")
716 (if (consp (caar structure))
717 (nnimap-insert-partial-structure (pop structure) parts t)
718 (let ((bit (pop structure)))
719 (insert (format "Content-type: %s/%s"
720 (downcase (nth 0 bit))
721 (downcase (nth 1 bit))))
722 (if (member-ignore-case "CHARSET" (nth 2 bit))
725 (cadr (member-ignore-case "CHARSET" (nth 2 bit)))))
727 (insert (format "Content-transfer-encoding: %s\n"
730 (when (assoc (nth 9 bit) parts)
731 (insert (cadr (assoc (nth 9 bit) parts)))))))
732 (insert "\n--" boundary "--\n")))
734 (defun nnimap-find-wanted-parts (structure)
735 (message-flatten-list (nnimap-find-wanted-parts-1 structure "")))
737 (defun nnimap-find-wanted-parts-1 (structure prefix)
740 (while (consp (car structure))
741 (let ((sub (pop structure)))
742 (if (consp (car sub))
743 (push (nnimap-find-wanted-parts-1
744 sub (if (string= prefix "")
745 (number-to-string num)
746 (format "%s.%s" prefix num)))
748 (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))
749 (id (if (string= prefix "")
750 (number-to-string num)
751 (format "%s.%s" prefix num))))
752 (setcar (nthcdr 9 sub) id)
753 (when (if (eq nnimap-fetch-partial-articles t)
755 (string-match nnimap-fetch-partial-articles type))
760 (defun nnimap-decode-gnus-group (group)
761 (decode-coding-string group 'utf-8))
763 (deffoo nnimap-request-group (group &optional server dont-check info)
764 (setq group (nnimap-decode-gnus-group group))
765 (let ((result (nnimap-change-group
766 ;; Don't SELECT the group if we're going to select it
768 (if (and (not dont-check)
769 (assoc group nnimap-current-infos))
773 articles active marks high low)
774 (with-current-buffer nntp-server-buffer
777 (setq active (nth 2 (assoc group nnimap-current-infos))))
778 (insert (format "211 %d %d %d %S\n"
779 (- (cdr active) (car active))
783 (with-current-buffer (nnimap-buffer)
785 (let ((group-sequence
786 (nnimap-send-command "SELECT %S" (utf7-encode group t)))
788 (nnimap-send-command "UID FETCH 1:* FLAGS")))
789 (setf (nnimap-group nnimap-object) group)
790 (nnimap-wait-for-response flag-sequence)
792 (nnimap-flags-to-marks
794 (list (list group-sequence flag-sequence
795 1 group "SELECT")))))
798 (nnimap-update-infos marks (list info))
799 (nnimap-store-info info (gnus-active (gnus-info-group info))))
800 (goto-char (point-max))
801 (let ((uidnext (nth 5 (car marks))))
802 (setq high (or (if uidnext
806 low (or (nth 4 (car marks)) uidnext 1)))))
810 "211 %d %d %d %S\n" (1+ (- high low)) low high group)))
813 (deffoo nnimap-request-create-group (group &optional server args)
814 (setq group (nnimap-decode-gnus-group group))
815 (when (nnimap-change-group nil server)
816 (with-current-buffer (nnimap-buffer)
817 (car (nnimap-command "CREATE %S" (utf7-encode group t))))))
819 (deffoo nnimap-request-delete-group (group &optional force server)
820 (setq group (nnimap-decode-gnus-group group))
821 (when (nnimap-change-group nil server)
822 (with-current-buffer (nnimap-buffer)
823 (car (nnimap-command "DELETE %S" (utf7-encode group t))))))
825 (deffoo nnimap-request-rename-group (group new-name &optional server)
826 (setq group (nnimap-decode-gnus-group group))
827 (when (nnimap-change-group nil server)
828 (with-current-buffer (nnimap-buffer)
829 (nnimap-unselect-group)
830 (car (nnimap-command "RENAME %S %S"
831 (utf7-encode group t) (utf7-encode new-name t))))))
833 (defun nnimap-unselect-group ()
834 ;; Make sure we don't have this group open read/write by asking
835 ;; to examine a mailbox that doesn't exist. This seems to be
836 ;; the only way that allows us to reliably go back to unselected
838 (nnimap-command "EXAMINE DOES.NOT.EXIST"))
840 (deffoo nnimap-request-expunge-group (group &optional server)
841 (setq group (nnimap-decode-gnus-group group))
842 (when (nnimap-change-group group server)
843 (with-current-buffer (nnimap-buffer)
844 (car (nnimap-command "EXPUNGE")))))
846 (defun nnimap-get-flags (spec)
849 (with-current-buffer (nnimap-buffer)
851 (nnimap-wait-for-response (nnimap-send-command
852 "UID FETCH %s FLAGS" spec))
854 (subst-char-in-region (point-min) (point-max)
856 (goto-char (point-min))
857 (while (search-forward " FETCH " end t)
858 (setq elems (read (current-buffer)))
859 (push (cons (cadr (memq 'UID elems))
860 (cadr (memq 'FLAGS elems)))
862 (nreverse articles)))
864 (deffoo nnimap-close-group (group &optional server)
867 (deffoo nnimap-request-move-article (article group server accept-form
868 &optional last internal-move-group)
869 (setq group (nnimap-decode-gnus-group group))
870 (when internal-move-group
871 (setq internal-move-group (nnimap-decode-gnus-group internal-move-group)))
873 (mm-disable-multibyte)
874 (when (funcall (if internal-move-group
876 'nnimap-request-article)
877 article group server (current-buffer))
878 ;; If the move is internal (on the same server), just do it the easy
880 (let ((message-id (message-field-value "message-id")))
881 (if internal-move-group
883 (with-current-buffer (nnimap-buffer)
884 (nnimap-command "UID COPY %d %S"
886 (utf7-encode internal-move-group t)))))
888 (nnimap-delete-article article)
889 (cons internal-move-group
890 (or (nnimap-find-uid-response "COPYUID" (cadr result))
891 (nnimap-find-article-by-message-id
892 internal-move-group server message-id
893 nnimap-request-articles-find-limit)))))
894 ;; Move the article to a different method.
895 (let ((result (eval accept-form)))
897 (nnimap-change-group group server)
898 (nnimap-delete-article article)
901 (deffoo nnimap-request-expire-articles (articles group &optional server force)
902 (setq group (nnimap-decode-gnus-group group))
906 ((not (nnimap-change-group group server))
909 (eq nnmail-expiry-target 'delete))
910 (unless (nnimap-delete-article (gnus-compress-sequence articles))
911 (nnheader-message 7 "Article marked for deletion, but not expunged."))
914 (let ((deletable-articles
916 (eq nnmail-expiry-wait 'immediate))
918 (gnus-sorted-intersection
920 (nnimap-find-expired-articles group)))))
921 (if (null deletable-articles)
923 (if (eq nnmail-expiry-target 'delete)
924 (nnimap-delete-article (gnus-compress-sequence deletable-articles))
925 (setq deletable-articles
926 (nnimap-process-expiry-targets
927 deletable-articles group server)))
928 ;; Return the articles we didn't delete.
929 (gnus-sorted-complement articles deletable-articles))))))
931 (defun nnimap-process-expiry-targets (articles group server)
932 (let ((deleted-articles nil))
934 ;; shortcut further processing if we're going to delete the articles
935 ((eq nnmail-expiry-target 'delete)
936 (setq deleted-articles articles)
938 ;; or just move them to another folder on the same IMAP server
939 ((and (not (functionp nnmail-expiry-target))
940 (gnus-server-equal (gnus-group-method nnmail-expiry-target)
941 (gnus-server-to-method
942 (format "nnimap:%s" server))))
943 (and (nnimap-change-group group server)
944 (with-current-buffer (nnimap-buffer)
945 (nnheader-message 7 "Expiring articles from %s: %s" group articles)
948 (nnimap-article-ranges (gnus-compress-sequence articles))
949 (utf7-encode (gnus-group-real-name nnmail-expiry-target) t))
950 (setq deleted-articles articles)))
953 (dolist (article articles)
954 (let ((target nnmail-expiry-target))
956 (mm-disable-multibyte)
957 (when (nnimap-request-article article group server (current-buffer))
958 (when (functionp target)
959 (setq target (funcall target group)))
961 (not (eq target 'delete)))
962 (if (or (gnus-request-group target t)
963 (gnus-request-create-group target))
965 (nnmail-expiry-target-group target group)
966 (nnheader-message 7 "Expiring article %s:%d to %s"
967 group article target))
969 (nnheader-message 7 "Expiring article %s:%d" group article))
971 (push article deleted-articles))))))))
972 ;; Change back to the current group again.
973 (nnimap-change-group group server)
974 (setq deleted-articles (nreverse deleted-articles))
975 (nnimap-delete-article (gnus-compress-sequence deleted-articles))
978 (defun nnimap-find-expired-articles (group)
979 (let ((cutoff (nnmail-expired-article-p group nil nil)))
980 (with-current-buffer (nnimap-buffer)
983 "UID SEARCH SENTBEFORE %s"
987 (car (rassoc (nth 4 (decode-time cutoff))
988 parse-time-months))))
991 (delete 0 (mapcar #'string-to-number
992 (cdr (assoc "SEARCH" (cdr result))))))))))
995 (defun nnimap-find-article-by-message-id (group server message-id
997 "Search for message with MESSAGE-ID in GROUP from SERVER.
998 If LIMIT, first try to limit the search to the N last articles."
999 (with-current-buffer (nnimap-buffer)
1001 (let* ((change-group-result (nnimap-change-group group server nil t))
1003 (and (listp change-group-result)
1005 (dolist (result (cdr change-group-result))
1006 (when (equal "EXISTS" (cadr result))
1007 (throw 'found (car result)))))))
1009 (nnimap-send-command
1010 "UID SEARCH%s HEADER Message-Id %S"
1011 (if (and limit number-of-article)
1012 ;; The -1 is because IMAP message
1013 ;; numbers are one-based rather than
1015 (format " %s:*" (- (string-to-number number-of-article)
1019 (when (nnimap-wait-for-response sequence)
1020 (let ((article (car (last (cdr (assoc "SEARCH"
1021 (nnimap-parse-response)))))))
1023 (string-to-number article)
1024 (when (and limit number-of-article)
1025 (nnimap-find-article-by-message-id group server message-id))))))))
1027 (defun nnimap-delete-article (articles)
1028 (with-current-buffer (nnimap-buffer)
1029 (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
1030 (nnimap-article-ranges articles))
1032 ((nnimap-capability "UIDPLUS")
1033 (nnimap-command "UID EXPUNGE %s"
1034 (nnimap-article-ranges articles))
1037 (nnimap-command "EXPUNGE")
1039 (t (gnus-message 7 (concat "nnimap: nnimap-expunge is not set and the "
1040 "server doesn't support UIDPLUS, so we won't "
1041 "delete this article now"))))))
1043 (deffoo nnimap-request-scan (&optional group server)
1045 (setq group (nnimap-decode-gnus-group group)))
1046 (when (and (nnimap-change-group nil server)
1048 nnimap-split-methods)
1049 (nnheader-message 7 "nnimap %s splitting mail..." server)
1050 (if (listp nnimap-inbox)
1051 (dolist (nnimap-inbox nnimap-inbox)
1052 (nnimap-split-incoming-mail))
1053 (nnimap-split-incoming-mail))
1054 (nnheader-message 7 "nnimap %s splitting mail...done" server)))
1056 (defun nnimap-marks-to-flags (marks)
1058 (dolist (mark marks)
1059 (when (setq flag (cadr (assq mark nnimap-mark-alist)))
1063 (deffoo nnimap-request-update-group-status (group status &optional server)
1064 (setq group (nnimap-decode-gnus-group group))
1065 (when (nnimap-change-group nil server)
1066 (let ((command (assoc
1068 '((subscribe "SUBSCRIBE")
1069 (unsubscribe "UNSUBSCRIBE")))))
1071 (with-current-buffer (nnimap-buffer)
1072 (nnimap-command "%s %S" (cadr command) (utf7-encode group t)))))))
1074 (deffoo nnimap-request-set-mark (group actions &optional server)
1075 (setq group (nnimap-decode-gnus-group group))
1076 (when (nnimap-change-group group server)
1078 (with-current-buffer (nnimap-buffer)
1080 ;; Just send all the STORE commands without waiting for
1081 ;; response. If they're successful, they're successful.
1082 (dolist (action actions)
1083 (destructuring-bind (range action marks) action
1084 (let ((flags (nnimap-marks-to-flags marks)))
1086 (setq sequence (nnimap-send-command
1087 "UID STORE %s %sFLAGS.SILENT (%s)"
1088 (nnimap-article-ranges range)
1090 ((eq action 'del) "-")
1091 ((eq action 'add) "+")
1092 ((eq action 'set) ""))
1093 (mapconcat #'identity flags " ")))))))
1094 ;; Wait for the last command to complete to avoid later
1095 ;; synchronization problems with the stream.
1097 (nnimap-wait-for-response sequence))))))
1099 (deffoo nnimap-request-accept-article (group &optional server last)
1100 (setq group (nnimap-decode-gnus-group group))
1101 (when (nnimap-change-group nil server)
1102 (nnmail-check-syntax)
1103 (let ((message-id (message-field-value "message-id"))
1106 (setq message (buffer-substring-no-properties (point-min) (point-max)))
1107 (with-current-buffer (nnimap-buffer)
1108 (when (setq message (or (nnimap-process-quirk "OK Gimap " 'append message)
1110 ;; If we have this group open read-only, then unselect it
1111 ;; before appending to it.
1112 (when (equal (nnimap-examined nnimap-object) group)
1113 (nnimap-unselect-group))
1115 (setq sequence (nnimap-send-command
1116 "APPEND %S {%d}" (utf7-encode group t)
1118 (unless nnimap-streaming
1119 (nnimap-wait-for-connection "^[+]"))
1120 (process-send-string (get-buffer-process (current-buffer)) message)
1121 (process-send-string (get-buffer-process (current-buffer))
1122 (if (nnimap-newlinep nnimap-object)
1125 (let ((result (nnimap-get-response sequence)))
1126 (if (not (nnimap-ok-p result))
1128 (nnheader-report 'nnimap "%s" result)
1131 (or (nnimap-find-uid-response "APPENDUID" (car result))
1132 (nnimap-find-article-by-message-id
1133 group server message-id
1134 nnimap-request-articles-find-limit))))))))))
1136 (defun nnimap-process-quirk (greeting-match type data)
1137 (when (and (nnimap-greeting nnimap-object)
1138 (string-match greeting-match (nnimap-greeting nnimap-object))
1140 (string-match "\000" data))
1141 (let ((choice (gnus-multiple-choice
1142 "Message contains NUL characters. Delete, continue, abort? "
1143 '((?d "Delete NUL characters")
1144 (?c "Try to APPEND the message as is")
1148 (nnheader-report 'nnimap "Aborted APPEND due to NUL characters"))
1154 (goto-char (point-min))
1155 (while (search-forward "\000" nil t)
1156 (replace-match "" t t))
1157 (buffer-string)))))))
1159 (defun nnimap-ok-p (value)
1162 (equal (caar value) "OK")))
1164 (defun nnimap-find-uid-response (name list)
1165 (let ((result (car (last (nnimap-find-response-element name list)))))
1167 (string-to-number result))))
1169 (defun nnimap-find-response-element (name list)
1172 (when (and (consp elem)
1173 (equal name (car elem)))
1174 (setq result elem)))
1177 (deffoo nnimap-request-replace-article (article group buffer)
1178 (setq group (nnimap-decode-gnus-group group))
1180 (when (and (nnimap-change-group group)
1181 ;; Put the article into the group.
1182 (with-current-buffer buffer
1184 (nnimap-request-accept-article group nil t))))
1185 (nnimap-delete-article (list article))
1186 ;; Return the new article number.
1189 (defun nnimap-add-cr ()
1190 (goto-char (point-min))
1191 (while (re-search-forward "\r?\n" nil t)
1192 (replace-match "\r\n" t t)))
1194 (defun nnimap-get-groups ()
1196 (let ((sequence (nnimap-send-command "LIST \"\" \"*\""))
1198 (nnimap-wait-for-response sequence)
1199 (subst-char-in-region (point-min) (point-max)
1201 (goto-char (point-min))
1202 (nnimap-unfold-quoted-lines)
1203 (goto-char (point-min))
1204 (while (search-forward "* LIST " nil t)
1205 (let ((flags (read (current-buffer)))
1206 (separator (read (current-buffer)))
1207 (group (read (current-buffer))))
1208 (unless (member '%NoSelect flags)
1209 (push (utf7-decode (if (stringp group)
1211 (format "%s" group)) t)
1215 (defun nnimap-get-responses (sequences)
1217 (dolist (sequence sequences)
1218 (goto-char (point-min))
1219 (when (re-search-forward (format "^%d " sequence) nil t)
1220 (push (list sequence (nnimap-parse-response))
1224 (deffoo nnimap-request-list (&optional server)
1225 (when (nnimap-change-group nil server)
1226 (with-current-buffer nntp-server-buffer
1229 (with-current-buffer (nnimap-buffer)
1230 (nnimap-get-groups)))
1231 sequences responses)
1233 (with-current-buffer (nnimap-buffer)
1234 (setf (nnimap-group nnimap-object) nil)
1235 (dolist (group groups)
1236 (setf (nnimap-examined nnimap-object) group)
1237 (push (list (nnimap-send-command "EXAMINE %S"