code.delx.au - gnu-emacs/blob - lisp/gnus/nnimap.el

   1 ;;; nnimap.el --- IMAP interface for Gnus
   2
   3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;         Simon Josefsson <simon@josefsson.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  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.
  14
  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.
  19
  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/>.
  22
  23 ;;; Commentary:
  24
  25 ;; nnimap interfaces Gnus with IMAP servers.
  26
  27 ;;; Code:
  28
  29 (eval-and-compile
  30   (require 'nnheader))
  31
  32 (eval-when-compile
  33   (require 'cl))
  34
  35 (require 'nnheader)
  36 (require 'gnus-util)
  37 (require 'gnus)
  38 (require 'nnoo)
  39 (require 'netrc)
  40 (require 'parse-time)
  41
  42 (nnoo-declare nnimap)
  43
  44 (defvoo nnimap-address nil
  45   "The address of the IMAP server.")
  46
  47 (defvoo nnimap-server-port nil
  48   "The IMAP port used.
  49 If nnimap-stream is `ssl', this will default to `imaps'.  If not,
  50 it will default to `imap'.")
  51
  52 (defvoo nnimap-stream 'ssl
  53   "How nnimap will talk to the IMAP server.
  54 Values are `ssl', `network', `starttls' or `shell'.")
  55
  56 (defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
  57                                  (if (listp imap-shell-program)
  58                                      (car imap-shell-program)
  59                                    imap-shell-program)
  60                                "ssh %s imapd"))
  61
  62 (defvoo nnimap-inbox nil
  63   "The mail box where incoming mail arrives and should be split out of.")
  64
  65 (defvoo nnimap-split-methods nil
  66   "How mail is split.
  67 Uses the same syntax as nnmail-split-methods")
  68
  69 (defvoo nnimap-authenticator nil
  70   "How nnimap authenticate itself to the server.
  71 Possible choices are nil (use default methods) or `anonymous'.")
  72
  73 (defvoo nnimap-expunge t
  74   "If non-nil, expunge articles after deleting them.
  75 This is always done if the server supports UID EXPUNGE, but it's
  76 not done by default on servers that doesn't support that command.")
  77
  78 (defvoo nnimap-streaming t
  79   "If non-nil, try to use streaming commands with IMAP servers.
  80 Switching this off will make nnimap slower, but it helps with
  81 some servers.")
  82
  83 (defvoo nnimap-connection-alist nil)
  84
  85 (defvoo nnimap-current-infos nil)
  86
  87 (defvar nnimap-process nil)
  88
  89 (defvar nnimap-status-string "")
  90
  91 (defvar nnimap-split-download-body-default nil
  92   "Internal variable with default value for `nnimap-split-download-body'.")
  93
  94 (defvar nnimap-keepalive-timer nil)
  95 (defvar nnimap-process-buffers nil)
  96
  97 (defstruct nnimap
  98   group process commands capabilities select-result newlinep server
  99   last-command-time)
 100
 101 (defvar nnimap-object nil)
 102
 103 (defvar nnimap-mark-alist
 104   '((read "\\Seen" %Seen)
 105     (tick "\\Flagged" %Flagged)
 106     (reply "\\Answered" %Answered)
 107     (expire "gnus-expire")
 108     (dormant "gnus-dormant")
 109     (score "gnus-score")
 110     (save "gnus-save")
 111     (download "gnus-download")
 112     (forward "gnus-forward")))
 113
 114 (defun nnimap-buffer ()
 115   (nnimap-find-process-buffer nntp-server-buffer))
 116
 117 (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old)
 118   (with-current-buffer nntp-server-buffer
 119     (erase-buffer)
 120     (when (nnimap-possibly-change-group group server)
 121       (with-current-buffer (nnimap-buffer)
 122         (nnimap-send-command "SELECT %S" (utf7-encode group t))
 123         (erase-buffer)
 124         (nnimap-wait-for-response
 125          (nnimap-send-command
 126           "UID FETCH %s %s"
 127           (nnimap-article-ranges (gnus-compress-sequence articles))
 128           (format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
 129                   (format
 130                    (if (nnimap-ver4-p)
 131                        "BODY.PEEK[HEADER.FIELDS %s]"
 132                      "RFC822.HEADER.LINES %s")
 133                    (append '(Subject From Date Message-Id
 134                                      References In-Reply-To Xref)
 135                            nnmail-extra-headers))))
 136          t)
 137         (nnimap-transform-headers))
 138       (insert-buffer-substring
 139        (nnimap-find-process-buffer (current-buffer))))
 140     'headers))
 141
 142 (defun nnimap-transform-headers ()
 143   (goto-char (point-min))
 144   (let (article bytes lines size string)
 145     (block nil
 146       (while (not (eobp))
 147         (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
 148           (delete-region (point) (progn (forward-line 1) (point)))
 149           (when (eobp)
 150             (return)))
 151         (setq article (match-string 1))
 152         ;; Unfold quoted {number} strings.
 153         (while (re-search-forward "[^]] {\\([0-9]+\\)}\r\n"
 154                                   (1+ (line-end-position)) t)
 155           (setq size (string-to-number (match-string 1)))
 156           (delete-region (+ (match-beginning 0) 2) (point))
 157           (setq string (delete-region (point) (+ (point) size)))
 158           (insert (format "%S" string)))
 159         (setq bytes (nnimap-get-length)
 160               lines nil)
 161         (beginning-of-line)
 162         (setq size
 163               (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)"
 164                                       (line-end-position)
 165                                       t)
 166                    (match-string 1)))
 167         (beginning-of-line)
 168         (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
 169           (let ((structure (ignore-errors
 170                              (read (current-buffer)))))
 171             (while (and (consp structure)
 172                         (not (stringp (car structure))))
 173               (setq structure (car structure)))
 174             (setq lines (nth 7 structure))))
 175         (delete-region (line-beginning-position) (line-end-position))
 176         (insert (format "211 %s Article retrieved." article))
 177         (forward-line 1)
 178         (when size
 179           (insert (format "Chars: %s\n" size)))
 180         (when lines
 181           (insert (format "Lines: %s\n" lines)))
 182         (re-search-forward "^\r$")
 183         (delete-region (line-beginning-position) (line-end-position))
 184         (insert ".")
 185         (forward-line 1)))))
 186
 187 (defun nnimap-get-length ()
 188   (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t)
 189        (string-to-number (match-string 1))))
 190
 191 (defun nnimap-article-ranges (ranges)
 192   (let (result)
 193     (cond
 194      ((numberp ranges)
 195       (number-to-string ranges))
 196      ((numberp (cdr ranges))
 197       (format "%d:%d" (car ranges) (cdr ranges)))
 198      (t
 199       (dolist (elem ranges)
 200         (push
 201          (if (consp elem)
 202              (format "%d:%d" (car elem) (cdr elem))
 203            (number-to-string elem))
 204          result))
 205       (mapconcat #'identity (nreverse result) ",")))))
 206
 207 (deffoo nnimap-open-server (server &optional defs)
 208   (if (nnimap-server-opened server)
 209       t
 210     (unless (assq 'nnimap-address defs)
 211       (setq defs (append defs (list (list 'nnimap-address server)))))
 212     (nnoo-change-server 'nnimap server defs)
 213     (or (nnimap-find-connection nntp-server-buffer)
 214         (nnimap-open-connection nntp-server-buffer))))
 215
 216 (defun nnimap-make-process-buffer (buffer)
 217   (with-current-buffer
 218       (generate-new-buffer (format "*nnimap %s %s %s*"
 219                                    nnimap-address nnimap-server-port
 220                                    (gnus-buffer-exists-p buffer)))
 221     (mm-disable-multibyte)
 222     (buffer-disable-undo)
 223     (gnus-add-buffer)
 224     (set (make-local-variable 'after-change-functions) nil)
 225     (set (make-local-variable 'nnimap-object)
 226          (make-nnimap :server (nnoo-current-server 'nnimap)))
 227     (push (list buffer (current-buffer)) nnimap-connection-alist)
 228     (push (current-buffer) nnimap-process-buffers)
 229     (current-buffer)))
 230
 231 (defun nnimap-open-shell-stream (name buffer host port)
 232   (let ((process-connection-type nil))
 233     (start-process name buffer shell-file-name
 234                    shell-command-switch
 235                    (format-spec
 236                     nnimap-shell-program
 237                     (format-spec-make
 238                      ?s host
 239                      ?p port)))))
 240
 241 (defun nnimap-credentials (address ports)
 242   (let (port credentials)
 243     ;; Request the credentials from all ports, but only query on the
 244     ;; last port if all the previous ones have failed.
 245     (while (and (null credentials)
 246                 (setq port (pop ports)))
 247       (setq credentials
 248             (auth-source-user-or-password
 249              '("login" "password") address port nil (null ports))))
 250     credentials))
 251
 252 (defun nnimap-keepalive ()
 253   (let ((now (current-time)))
 254     (dolist (buffer nnimap-process-buffers)
 255       (when (buffer-name buffer)
 256         (with-current-buffer buffer
 257           (when (and nnimap-object
 258                      (nnimap-last-command-time nnimap-object)
 259                      (> (time-to-seconds
 260                          (time-subtract
 261                           now
 262                           (nnimap-last-command-time nnimap-object)))
 263                         ;; More than five minutes since the last command.
 264                         (* 5 60)))
 265             (nnimap-send-command "NOOP")))))))
 266
 267 (defun nnimap-open-connection (buffer)
 268   (unless nnimap-keepalive-timer
 269     (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
 270                                               'nnimap-keepalive)))
 271   (with-current-buffer (nnimap-make-process-buffer buffer)
 272     (let* ((coding-system-for-read 'binary)
 273            (coding-system-for-write 'binary)
 274            (port nil)
 275            (ports
 276             (cond
 277              ((eq nnimap-stream 'network)
 278               (open-network-stream
 279                "*nnimap*" (current-buffer) nnimap-address
 280                (setq port
 281                      (or nnimap-server-port
 282                          (if (netrc-find-service-number "imap")
 283                              "imap"
 284                            "143"))))
 285               '("143" "imap"))
 286              ((eq nnimap-stream 'shell)
 287               (nnimap-open-shell-stream
 288                "*nnimap*" (current-buffer) nnimap-address
 289                (setq port (or nnimap-server-port "imap")))
 290               '("imap"))
 291              ((eq nnimap-stream 'starttls)
 292               (starttls-open-stream
 293                "*nnimap*" (current-buffer) nnimap-address
 294                (setq port (or nnimap-server-port "imap")))
 295               '("imap"))
 296              ((eq nnimap-stream 'ssl)
 297               (open-tls-stream
 298                "*nnimap*" (current-buffer) nnimap-address
 299                (setq port
 300                      (or nnimap-server-port
 301                          (if (netrc-find-service-number "imaps")
 302                              "imaps"
 303                            "993"))))
 304               '("143" "993" "imap" "imaps"))))
 305            connection-result login-result credentials)
 306       (setf (nnimap-process nnimap-object)
 307             (get-buffer-process (current-buffer)))
 308       (if (not (and (nnimap-process nnimap-object)
 309                     (memq (process-status (nnimap-process nnimap-object))
 310                           '(open run))))
 311           (nnheader-report 'nnimap "Unable to contact %s:%s via %s"
 312                            nnimap-address port nnimap-stream)
 313         (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil)
 314         (if (not (setq connection-result (nnimap-wait-for-connection)))
 315             (nnheader-report 'nnimap
 316                              "%s" (buffer-substring
 317                                    (point) (line-end-position)))
 318           (when (eq nnimap-stream 'starttls)
 319             (nnimap-command "STARTTLS")
 320             (starttls-negotiate (nnimap-process nnimap-object)))
 321           (unless (equal connection-result "PREAUTH")
 322             (if (not (setq credentials
 323                            (if (eq nnimap-authenticator 'anonymous)
 324                                (list "anonymous"
 325                                      (message-make-address))
 326                              (nnimap-credentials
 327                               nnimap-address
 328                               (if nnimap-server-port
 329                                   (cons (format "%s" nnimap-server-port) ports)
 330                                 ports)))))
 331                 (setq nnimap-object nil)
 332               (setq login-result (nnimap-command "LOGIN %S %S"
 333                                                  (car credentials)
 334                                                  (cadr credentials)))
 335               (unless (car login-result)
 336                 (delete-process (nnimap-process nnimap-object))
 337                 (setq nnimap-object nil))))
 338           (when nnimap-object
 339             (setf (nnimap-capabilities nnimap-object)
 340                   (mapcar
 341                    #'upcase
 342                    (or (nnimap-find-parameter "CAPABILITY" (cdr login-result))
 343                        (nnimap-find-parameter
 344                         "CAPABILITY" (cdr (nnimap-command "CAPABILITY"))))))
 345             (when (member "QRESYNC" (nnimap-capabilities nnimap-object))
 346               (nnimap-command "ENABLE QRESYNC"))
 347             t))))))
 348
 349 (defun nnimap-find-parameter (parameter elems)
 350   (let (result)
 351     (dolist (elem elems)
 352       (cond
 353        ((equal (car elem) parameter)
 354         (setq result (cdr elem)))
 355        ((and (equal (car elem) "OK")
 356              (consp (cadr elem))
 357              (equal (caadr elem) parameter))
 358         (setq result (cdr (cadr elem))))))
 359     result))
 360
 361 (deffoo nnimap-close-server (&optional server)
 362   t)
 363
 364 (deffoo nnimap-request-close ()
 365   t)
 366
 367 (deffoo nnimap-server-opened (&optional server)
 368   (and (nnoo-current-server-p 'nnimap server)
 369        nntp-server-buffer
 370        (gnus-buffer-live-p nntp-server-buffer)
 371        (nnimap-find-connection nntp-server-buffer)))
 372
 373 (deffoo nnimap-status-message (&optional server)
 374   nnimap-status-string)
 375
 376 (deffoo nnimap-request-article (article &optional group server to-buffer)
 377   (with-current-buffer nntp-server-buffer
 378     (let ((result (nnimap-possibly-change-group group server))
 379           parts structure)
 380       (when (stringp article)
 381         (setq article (nnimap-find-article-by-message-id group article)))
 382       (when (and result
 383                  article)
 384         (erase-buffer)
 385         (with-current-buffer (nnimap-buffer)
 386           (erase-buffer)
 387           (when gnus-fetch-partial-articles
 388             (if (eq gnus-fetch-partial-articles t)
 389                 (setq parts '(1))
 390               (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article)
 391               (goto-char (point-min))
 392               (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t)
 393                 (setq structure (ignore-errors (read (current-buffer)))
 394                       parts (nnimap-find-wanted-parts structure)))))
 395           (when (if parts
 396                     (nnimap-get-partial-article article parts structure)
 397                   (nnimap-get-whole-article article))
 398             (let ((buffer (current-buffer)))
 399               (with-current-buffer (or to-buffer nntp-server-buffer)
 400                 (erase-buffer)
 401                 (insert-buffer-substring buffer)
 402                 (nnheader-ms-strip-cr)
 403                 (cons group article)))))))))
 404
 405 (defun nnimap-get-whole-article (article)
 406   (let ((result
 407          (nnimap-command
 408           (if (nnimap-ver4-p)
 409               "UID FETCH %d BODY.PEEK[]"
 410             "UID FETCH %d RFC822.PEEK")
 411           article)))
 412     ;; Check that we really got an article.
 413     (goto-char (point-min))
 414     (unless (looking-at "\\* [0-9]+ FETCH")
 415       (setq result nil))
 416     (when result
 417       (goto-char (point-min))
 418       (let ((bytes (nnimap-get-length)))
 419         (delete-region (line-beginning-position)
 420                        (progn (forward-line 1) (point)))
 421         (goto-char (+ (point) bytes))
 422         (delete-region (point) (point-max)))
 423       t)))
 424
 425 (defun nnimap-ver4-p ()
 426   (member "IMAP4REV1" (nnimap-capabilities nnimap-object)))
 427
 428 (defun nnimap-get-partial-article (article parts structure)
 429   (let ((result
 430          (nnimap-command
 431           "UID FETCH %d (%s %s)"
 432           article
 433           (if (nnimap-ver4-p)
 434               "BODY.PEEK[HEADER]"
 435             "RFC822.HEADER")
 436           (if (nnimap-ver4-p)
 437               (mapconcat (lambda (part)
 438                            (format "BODY.PEEK[%s]" part))
 439                          parts " ")
 440             (mapconcat (lambda (part)
 441                          (format "RFC822.PEEK[%s]" part))
 442                        parts " ")))))
 443     (when result
 444       (nnimap-convert-partial-article structure))))
 445
 446 (defun nnimap-convert-partial-article (structure)
 447   ;; First just skip past the headers.
 448   (goto-char (point-min))
 449   (let ((bytes (nnimap-get-length))
 450         id parts)
 451     ;; Delete "FETCH" line.
 452     (delete-region (line-beginning-position)
 453                    (progn (forward-line 1) (point)))
 454     (goto-char (+ (point) bytes))
 455     ;; Collect all the body parts.
 456     (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]")
 457       (setq id (match-string 1)
 458             bytes (nnimap-get-length))
 459       (beginning-of-line)
 460       (delete-region (point) (progn (forward-line 1) (point)))
 461       (push (list id (buffer-substring (point) (+ (point) bytes)))
 462             parts)
 463       (delete-region (point) (+ (point) bytes)))
 464     ;; Delete trailing junk.
 465     (delete-region (point) (point-max))
 466     ;; Now insert all the parts again where they fit in the structure.
 467     (nnimap-insert-partial-structure structure parts)
 468     t))
 469
 470 (defun nnimap-insert-partial-structure (structure parts &optional subp)
 471   (let ((type (car (last structure 4)))
 472         (boundary (cadr (member "BOUNDARY" (car (last structure 3))))))
 473     (when subp
 474       (insert (format "Content-type: multipart/%s; boundary=%S\n\n"
 475                       (downcase type) boundary)))
 476     (while (not (stringp (car structure)))
 477       (insert "\n--" boundary "\n")
 478       (if (consp (caar structure))
 479           (nnimap-insert-partial-structure (pop structure) parts t)
 480         (let ((bit (pop structure)))
 481           (insert (format  "Content-type: %s/%s"
 482                            (downcase (nth 0 bit))
 483                            (downcase (nth 1 bit))))
 484           (if (member "CHARSET" (nth 2 bit))
 485               (insert (format
 486                        "; charset=%S\n" (cadr (member "CHARSET" (nth 2 bit)))))
 487             (insert "\n"))
 488           (insert (format "Content-transfer-encoding: %s\n"
 489                           (nth 5 bit)))
 490           (insert "\n")
 491           (when (assoc (nth 9 bit) parts)
 492             (insert (cadr (assoc (nth 9 bit) parts)))))))
 493     (insert "\n--" boundary "--\n")))
 494
 495 (defun nnimap-find-wanted-parts (structure)
 496   (message-flatten-list (nnimap-find-wanted-parts-1 structure "")))
 497
 498 (defun nnimap-find-wanted-parts-1 (structure prefix)
 499   (let ((num 1)
 500         parts)
 501     (while (consp (car structure))
 502       (let ((sub (pop structure)))
 503         (if (consp (car sub))
 504             (push (nnimap-find-wanted-parts-1
 505                    sub (if (string= prefix "")
 506                            (number-to-string num)
 507                          (format "%s.%s" prefix num)))
 508                   parts)
 509           (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))
 510                 (id (if (string= prefix "")
 511                         (number-to-string num)
 512                       (format "%s.%s" prefix num))))
 513             (setcar (nthcdr 9 sub) id)
 514             (when (string-match gnus-fetch-partial-articles type)
 515               (push id parts))))
 516         (incf num)))
 517     (nreverse parts)))
 518
 519 (deffoo nnimap-request-group (group &optional server dont-check info)
 520   (let ((result (nnimap-possibly-change-group group server))
 521         articles active marks high low)
 522     (with-current-buffer nntp-server-buffer
 523       (when result
 524         (if (and dont-check
 525                  (setq active (nth 2 (assoc group nnimap-current-infos))))
 526             (insert (format "211 %d %d %d %S\n"
 527                             (- (cdr active) (car active))
 528                             (car active)
 529                             (cdr active)
 530                             group))
 531           (with-current-buffer (nnimap-buffer)
 532             (erase-buffer)
 533             (let ((group-sequence
 534                    (nnimap-send-command "SELECT %S" (utf7-encode group t)))
 535                   (flag-sequence
 536                    (nnimap-send-command "UID FETCH 1:* FLAGS")))
 537               (nnimap-wait-for-response flag-sequence)
 538               (setq marks
 539                     (nnimap-flags-to-marks
 540                      (nnimap-parse-flags
 541                       (list (list group-sequence flag-sequence 1 group)))))
 542               (when info
 543                 (nnimap-update-infos marks (list info)))
 544               (goto-char (point-max))
 545               (let ((uidnext (nth 5 (car marks))))
 546                 (setq high (if uidnext
 547                                (1- uidnext)
 548                              (nth 3 (car marks)))
 549                       low (or (nth 4 (car marks)) uidnext)))))
 550           (erase-buffer)
 551           (insert
 552            (format
 553             "211 %d %d %d %S\n" (1+ (- high low)) low high group)))
 554         t))))
 555
 556 (deffoo nnimap-request-create-group (group &optional server args)
 557   (when (nnimap-possibly-change-group nil server)
 558     (with-current-buffer (nnimap-buffer)
 559       (car (nnimap-command "CREATE %S" (utf7-encode group t))))))
 560
 561 (deffoo nnimap-request-delete-group (group &optional force server)
 562   (when (nnimap-possibly-change-group nil server)
 563     (with-current-buffer (nnimap-buffer)
 564       (car (nnimap-command "DELETE %S" (utf7-encode group t))))))
 565
 566 (deffoo nnimap-request-expunge-group (group &optional server)
 567   (when (nnimap-possibly-change-group group server)
 568     (with-current-buffer (nnimap-buffer)
 569       (car (nnimap-command "EXPUNGE")))))
 570
 571 (defun nnimap-get-flags (spec)
 572   (let ((articles nil)
 573         elems)
 574     (with-current-buffer (nnimap-buffer)
 575       (erase-buffer)
 576       (nnimap-wait-for-response (nnimap-send-command
 577                                  "UID FETCH %s FLAGS" spec))
 578       (goto-char (point-min))
 579       (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" nil t)
 580         (setq elems (nnimap-parse-line (match-string 1)))
 581         (push (cons (string-to-number (cadr (member "UID" elems)))
 582                     (cadr (member "FLAGS" elems)))
 583               articles)))
 584     (nreverse articles)))
 585
 586 (deffoo nnimap-close-group (group &optional server)
 587   t)
 588
 589 (deffoo nnimap-request-move-article (article group server accept-form
 590                                              &optional last internal-move-group)
 591   (with-temp-buffer
 592     (when (nnimap-request-article article group server (current-buffer))
 593       ;; If the move is internal (on the same server), just do it the easy
 594       ;; way.
 595       (let ((message-id (message-field-value "message-id")))
 596         (if internal-move-group
 597             (let ((result
 598                    (with-current-buffer (nnimap-buffer)
 599                      (nnimap-command "UID COPY %d %S"
 600                                      article
 601                                      (utf7-encode internal-move-group t)))))
 602               (when (car result)
 603                 (nnimap-delete-article article)
 604                 (cons internal-move-group
 605                       (nnimap-find-article-by-message-id
 606                        internal-move-group message-id))))
 607           ;; Move the article to a different method.
 608           (let ((result (eval accept-form)))
 609             (when result
 610               (nnimap-delete-article article)
 611               result)))))))
 612
 613 (deffoo nnimap-request-expire-articles (articles group &optional server force)
 614   (cond
 615    ((null articles)
 616     nil)
 617    ((not (nnimap-possibly-change-group group server))
 618     articles)
 619    ((and force
 620          (eq nnmail-expiry-target 'delete))
 621     (unless (nnimap-delete-article articles)
 622       (message "Article marked for deletion, but not expunged."))
 623     nil)
 624    (t
 625     (let ((deletable-articles
 626            (if (or force
 627                    (eq nnmail-expiry-wait 'immediate))
 628                articles
 629              (gnus-sorted-intersection
 630               articles
 631               (nnimap-find-expired-articles group)))))
 632       (if (null deletable-articles)
 633           articles
 634         (if (eq nnmail-expiry-target 'delete)
 635             (nnimap-delete-article deletable-articles)
 636           (setq deletable-articles
 637                 (nnimap-process-expiry-targets
 638                  deletable-articles group server)))
 639         ;; Return the articles we didn't delete.
 640         (gnus-sorted-complement articles deletable-articles))))))
 641
 642 (defun nnimap-process-expiry-targets (articles group server)
 643   (let ((deleted-articles nil))
 644     (dolist (article articles)
 645       (let ((target nnmail-expiry-target))
 646         (with-temp-buffer
 647           (when (nnimap-request-article article group server (current-buffer))
 648             (message "Expiring article %s:%d" group article)
 649             (when (functionp target)
 650               (setq target (funcall target group)))
 651             (when (and target
 652                        (not (eq target 'delete)))
 653               (if (or (gnus-request-group target t)
 654                       (gnus-request-create-group target))
 655                   (nnmail-expiry-target-group target group)
 656                 (setq target nil)))
 657             (when target
 658               (push article deleted-articles))))))
 659     ;; Change back to the current group again.
 660     (nnimap-possibly-change-group group server)
 661     (setq deleted-articles (nreverse deleted-articles))
 662     (nnimap-delete-article deleted-articles)
 663     deleted-articles))
 664
 665 (defun nnimap-find-expired-articles (group)
 666   (let ((cutoff (nnmail-expired-article-p group nil nil)))
 667     (with-current-buffer (nnimap-buffer)
 668       (let ((result
 669              (nnimap-command
 670               "UID SEARCH SENTBEFORE %s"
 671               (format-time-string
 672                (format "%%d-%s-%%Y"
 673                        (upcase
 674                         (car (rassoc (nth 4 (decode-time cutoff))
 675                                      parse-time-months))))
 676                cutoff))))
 677         (and (car result)
 678              (delete 0 (mapcar #'string-to-number
 679                                (cdr (assoc "SEARCH" (cdr result))))))))))
 680
 681
 682 (defun nnimap-find-article-by-message-id (group message-id)
 683   (when (nnimap-possibly-change-group group nil)
 684     (with-current-buffer (nnimap-buffer)
 685       (let ((result
 686              (nnimap-command "UID SEARCH HEADER Message-Id %S" message-id))
 687             article)
 688         (when (car result)
 689           ;; Select the last instance of the message in the group.
 690           (and (setq article
 691                      (car (last (assoc "SEARCH" (cdr result)))))
 692                (string-to-number article)))))))
 693
 694 (defun nnimap-delete-article (articles)
 695   (with-current-buffer (nnimap-buffer)
 696     (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
 697                     (nnimap-article-ranges articles))
 698     (cond
 699      ((member "UIDPLUS" (nnimap-capabilities nnimap-object))
 700       (nnimap-command "UID EXPUNGE %s"
 701                       (nnimap-article-ranges articles))
 702       t)
 703      (nnimap-expunge
 704       (nnimap-command "EXPUNGE")
 705       t)
 706      (t (gnus-message 7 (concat "nnimap: nnimap-expunge is not set and the "
 707                                 "server doesn't support UIDPLUS, so we won't "
 708                                 "delete this article now"))))))
 709
 710 (deffoo nnimap-request-scan (&optional group server)
 711   (when (and (nnimap-possibly-change-group nil server)
 712              nnimap-inbox
 713              nnimap-split-methods)
 714     (message "nnimap %s splitting mail..." server)
 715     (nnimap-split-incoming-mail)))
 716
 717 (defun nnimap-marks-to-flags (marks)
 718   (let (flags flag)
 719     (dolist (mark marks)
 720       (when (setq flag (cadr (assq mark nnimap-mark-alist)))
 721         (push flag flags)))
 722     flags))
 723
 724 (deffoo nnimap-request-set-mark (group actions &optional server)
 725   (when (nnimap-possibly-change-group group server)
 726     (let (sequence)
 727       (with-current-buffer (nnimap-buffer)
 728         ;; Just send all the STORE commands without waiting for
 729         ;; response.  If they're successful, they're successful.
 730         (dolist (action actions)
 731           (destructuring-bind (range action marks) action
 732             (let ((flags (nnimap-marks-to-flags marks)))
 733               (when flags
 734                 (setq sequence (nnimap-send-command
 735                                 "UID STORE %s %sFLAGS.SILENT (%s)"
 736                                 (nnimap-article-ranges range)
 737                                 (if (eq action 'del)
 738                                     "-"
 739                                   "+")
 740                                 (mapconcat #'identity flags " ")))))))
 741         ;; Wait for the last command to complete to avoid later
 742         ;; syncronisation problems with the stream.
 743         (when sequence
 744           (nnimap-wait-for-response sequence))))))
 745
 746 (deffoo nnimap-request-accept-article (group &optional server last)
 747   (when (nnimap-possibly-change-group nil server)
 748     (nnmail-check-syntax)
 749     (let ((message (buffer-string))
 750           (message-id (message-field-value "message-id"))
 751           sequence)
 752       (with-current-buffer (nnimap-buffer)
 753         (setq sequence (nnimap-send-command
 754                         "APPEND %S {%d}" (utf7-encode group t)
 755                         (length message)))
 756         (process-send-string (get-buffer-process (current-buffer)) message)
 757         (process-send-string (get-buffer-process (current-buffer))
 758                              (if (nnimap-newlinep nnimap-object)
 759                                  "\n"
 760                                "\r\n"))
 761         (let ((result (nnimap-get-response sequence)))
 762           (when result
 763             (cons group
 764                   (nnimap-find-article-by-message-id group message-id))))))))
 765
 766 (defun nnimap-add-cr ()
 767   (goto-char (point-min))
 768   (while (re-search-forward "\r?\n" nil t)
 769     (replace-match "\r\n" t t)))
 770
 771 (defun nnimap-get-groups ()
 772   (let ((result (nnimap-command "LIST \"\" \"*\""))
 773         groups)
 774     (when (car result)
 775       (dolist (line (cdr result))
 776         (when (and (equal (car line) "LIST")
 777                    (not (and (caadr line)
 778                              (string-match "noselect" (caadr line)))))
 779           (push (car (last line)) groups)))
 780       (nreverse groups))))
 781
 782 (deffoo nnimap-request-list (&optional server)
 783   (nnimap-possibly-change-group nil server)
 784   (with-current-buffer nntp-server-buffer
 785     (erase-buffer)
 786     (let ((groups
 787            (with-current-buffer (nnimap-buffer)
 788              (nnimap-get-groups)))
 789           sequences responses)
 790       (when groups
 791         (with-current-buffer (nnimap-buffer)
 792           (setf (nnimap-group nnimap-object) nil)
 793           (dolist (group groups)
 794             (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
 795                         group)
 796                   sequences))
 797           (nnimap-wait-for-response (caar sequences))
 798           (setq responses
 799                 (nnimap-get-responses (mapcar #'car sequences))))
 800         (dolist (response responses)
 801           (let* ((sequence (car response))
 802                  (response (cadr response))
 803                  (group (cadr (assoc sequence sequences))))
 804             (when (and group
 805                        (equal (caar response) "OK"))
 806               (let ((uidnext (nnimap-find-parameter "UIDNEXT" response))
 807                     highest exists)
 808                 (dolist (elem response)
 809                   (when (equal (cadr elem) "EXISTS")
 810                     (setq exists (string-to-number (car elem)))))
 811                 (when uidnext
 812                   (setq highest (1- (string-to-number (car uidnext)))))
 813                 (cond
 814                  ((null highest)
 815                   (insert (format "%S 0 1 y\n" (utf7-decode group t))))
 816                  ((zerop exists)
 817                   ;; Empty group.
 818                   (insert (format "%S %d %d y\n"
 819                                   (utf7-decode group t) highest (1+ highest))))
 820                  (t
 821                   ;; Return the widest possible range.
 822                   (insert (format "%S %d 1 y\n" (utf7-decode group t)
 823                                   (or highest exists)))))))))
 824         t))))
 825
 826 (deffoo nnimap-retrieve-group-data-early (server infos)
 827   (when (nnimap-possibly-change-group nil server)
 828     (with-current-buffer (nnimap-buffer)
 829       ;; QRESYNC handling isn't implemented.
 830       (let ((qresyncp (member "notQRESYNC" (nnimap-capabilities nnimap-object)))
 831             marks groups sequences)
 832         ;; Go through the infos and gather the data needed to know
 833         ;; what and how to request the data.
 834         (dolist (info infos)
 835           (setq marks (gnus-info-marks info))
 836           (push (list (gnus-group-real-name (gnus-info-group info))
 837                       (cdr (assq 'active marks))
 838                       (cdr (assq 'uid marks)))
 839                 groups))
 840         ;; Then request the data.
 841         (erase-buffer)
 842         (setf (nnimap-group nnimap-object) nil)
 843         (dolist (elem groups)
 844           (if (and qresyncp
 845                    (nth 2 elem))
 846               (push
 847                (list 'qresync
 848                      (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))"
 849                                           (car elem)
 850                                           (car (nth 2 elem))
 851                                           (cdr (nth 2 elem)))
 852                      nil
 853                      (car elem))
 854                sequences)
 855             (let ((start
 856                    (if (nth 1 elem)
 857                        ;; Fetch the last 100 flags.
 858                        (max 1 (- (cdr (nth 1 elem)) 100))
 859                      1)))
 860               (push (list (nnimap-send-command "EXAMINE %S" (car elem))
 861                           (nnimap-send-command "UID FETCH %d:* FLAGS" start)
 862                           start
 863                           (car elem))
 864                     sequences)))
 865           ;; Some servers apparently can't have many outstanding
 866           ;; commands, so throttle them.
 867           (when (and (not nnimap-streaming)
 868                      (car sequences))
 869             (nnimap-wait-for-response (caar sequences))))
 870         sequences))))
 871
 872 (deffoo nnimap-finish-retrieve-group-infos (server infos sequences)
 873   (when (and sequences
 874              (nnimap-possibly-change-group nil server))
 875     (with-current-buffer (nnimap-buffer)
 876       ;; Wait for the final data to trickle in.
 877       (when (nnimap-wait-for-response (cadar sequences))
 878         ;; Now we should have all the data we need, no matter whether
 879         ;; we're QRESYNCING, fetching all the flags from scratch, or
 880         ;; just fetching the last 100 flags per group.
 881         (nnimap-update-infos (nnimap-flags-to-marks
 882                               (nnimap-parse-flags
 883                                (nreverse sequences)))
 884                              infos)
 885         ;; Finally, just return something resembling an active file in
 886         ;; the nntp buffer, so that the agent can save the info, too.
 887         (with-current-buffer nntp-server-buffer
 888           (erase-buffer)
 889           (dolist (info infos)
 890             (let* ((group (gnus-info-group info))
 891                    (active (gnus-active group)))
 892               (when active
 893                 (insert (format "%S %d %d y\n"
 894                                 (gnus-group-real-name group)
 895                                 (cdr active)
 896                                 (car active)))))))))))
 897
 898 (defun nnimap-update-infos (flags infos)
 899   (dolist (info infos)
 900     (let ((group (gnus-group-real-name (gnus-info-group info))))
 901       (nnimap-update-info info (cdr (assoc group flags))))))
 902
 903 (defun nnimap-update-info (info marks)
 904   (when marks
 905     (destructuring-bind (existing flags high low uidnext start-article
 906                                   permanent-flags) marks
 907       (let ((group (gnus-info-group info))
 908             (completep (and start-article
 909                             (= start-article 1))))
 910         (when uidnext
 911           (setq high (1- uidnext)))
 912         ;; First set the active ranges based on high/low.
 913         (if (or completep
 914                 (not (gnus-active group)))
 915             (gnus-set-active group
 916                              (cond
 917                               ((and low high)
 918                                (cons low high))
 919                               (uidnext
 920                                ;; No articles in this group.
 921                                (cons uidnext (1- uidnext)))
 922                               (start-article
 923                                (cons start-article (1- start-article)))
 924                               (t
 925                                ;; No articles and no uidnext.
 926                                nil)))
 927           (setcdr (gnus-active group) (or high (1- uidnext))))
 928         (when (and (not high)
 929                    uidnext)
 930           (setq high (1- uidnext)))
 931         ;; Then update the list of read articles.
 932         (let* ((unread
 933                 (gnus-compress-sequence
 934                  (gnus-set-difference
 935                   (gnus-set-difference
 936                    existing
 937                    (cdr (assoc '%Seen flags)))
 938                   (cdr (assoc '%Flagged flags)))))
 939                (read (gnus-range-difference
 940                       (cons start-article high) unread)))
 941           (when (> start-article 1)
 942             (setq read
 943                   (gnus-range-nconcat
 944                    (if (> start-article 1)
 945                        (gnus-sorted-range-intersection
 946                         (cons 1 (1- start-article))
 947                         (gnus-info-read info))
 948                      (gnus-info-read info))
 949                    read)))
 950           (gnus-info-set-read info read)
 951           ;; Update the marks.
 952           (setq marks (gnus-info-marks info))
 953           ;; Note the active level for the next run-through.
 954           (let ((active (assq 'active marks)))
 955             (if active
 956                 (setcdr active (gnus-active group))
 957               (push (cons 'active (gnus-active group)) marks)))
 958           (dolist (type (cdr nnimap-mark-alist))
 959             (let ((old-marks (assoc (car type) marks))
 960                   (new-marks
 961                    (gnus-compress-sequence
 962                     (cdr (or (assoc (caddr type) flags)     ; %Flagged
 963                              (assoc (intern (cadr type) obarray) flags)
 964                              (assoc (cadr type) flags)))))) ; "\Flagged"
 965               (setq marks (delq old-marks marks))
 966               (pop old-marks)
 967               (when (and old-marks
 968                          (> start-article 1))
 969                 (setq old-marks (gnus-range-difference
 970                                  old-marks
 971                                  (cons start-article high)))
 972                 (setq new-marks (gnus-range-nconcat old-marks new-marks)))
 973               (when new-marks
 974                 (push (cons (car type) new-marks) marks)))
 975             (gnus-info-set-marks info marks t)
 976             (nnimap-store-info info (gnus-active group))))))))
 977
 978 (defun nnimap-store-info (info active)
 979   (let* ((group (gnus-group-real-name (gnus-info-group info)))
 980          (entry (assoc group nnimap-current-infos)))
 981     (if entry
 982         (setcdr entry (list info active))
 983       (push (list group info active) nnimap-current-infos))))
 984
 985 (defun nnimap-flags-to-marks (groups)
 986   (let (data group totalp uidnext articles start-article mark permanent-flags)
 987     (dolist (elem groups)
 988       (setq group (car elem)
 989             uidnext (nth 1 elem)
 990             start-article (nth 2 elem)
 991             permanent-flags (nth 3 elem)
 992             articles (nthcdr 4 elem))
 993       (let ((high (caar articles))
 994             marks low existing)
 995         (dolist (article articles)
 996           (setq low (car article))
 997           (push (car article) existing)
 998           (dolist (flag (cdr article))
 999             (setq mark (assoc flag marks))
1000             (if (not mark)
1001                 (push (list flag (car article)) marks)
1002               (setcdr mark (cons (car article) (cdr mark))))))
1003         (push (list group existing marks high low uidnext start-article
1004                     permanent-flags)
1005               data)))
1006     data))
1007
1008 (defun nnimap-parse-flags (sequences)
1009   (goto-char (point-min))
1010   ;; Change \Delete etc to %Delete, so that the reader can read it.
1011   (subst-char-in-region (point-min) (point-max)
1012                         ?\\ ?% t)
1013   (let (start end articles groups uidnext elems permanent-flags)
1014     (dolist (elem sequences)
1015       (destructuring-bind (group-sequence flag-sequence totalp group) elem
1016         (setq start (point))
1017         ;; The EXAMINE was successful.
1018         (when (and (search-forward (format "\n%d OK " group-sequence) nil t)
1019                    (progn
1020                      (forward-line 1)
1021                      (setq end (point))
1022                      (goto-char start)
1023                      (setq permanent-flags
1024                            (and (search-forward "PERMANENTFLAGS "
1025                                                  (or end (point-min)) t)
1026                                 (read (current-buffer))))
1027                      (goto-char start)
1028                      (setq uidnext
1029                            (and (search-forward "UIDNEXT "
1030                                                  (or end (point-min)) t)
1031                                 (read (current-buffer))))
1032                      (goto-char end)
1033                      (forward-line -1))
1034                    ;; The UID FETCH FLAGS was successful.
1035                    (search-forward (format "\n%d OK " flag-sequence) nil t))
1036           (setq start (point))
1037           (goto-char end)
1038           (while (search-forward " FETCH " start t)
1039             (setq elems (read (current-buffer)))
1040             (push (cons (cadr (memq 'UID elems))
1041                         (cadr (memq 'FLAGS elems)))
1042                   articles))
1043           (push (nconc (list group uidnext totalp permanent-flags) articles)
1044                 groups)
1045           (setq articles nil))))
1046     groups))
1047
1048 (defun nnimap-find-process-buffer (buffer)
1049   (cadr (assoc buffer nnimap-connection-alist)))
1050
1051 (deffoo nnimap-request-post (&optional server)
1052   (setq nnimap-status-string "Read-only server")
1053   nil)
1054
1055 (defun nnimap-possibly-change-group (group server)
1056   (let ((open-result t))
1057     (when (and server
1058                (not (nnimap-server-opened server)))
1059       (setq open-result (nnimap-open-server server)))
1060     (cond
1061      ((not open-result)
1062       nil)
1063      ((not group)
1064       t)
1065      (t
1066       (with-current-buffer (nnimap-buffer)
1067         (if (equal group (nnimap-group nnimap-object))
1068             t
1069           (let ((result (nnimap-command "SELECT %S" (utf7-encode group t))))
1070             (when (car result)
1071               (setf (nnimap-group nnimap-object) group
1072                     (nnimap-select-result nnimap-object) result)
1073               result))))))))
1074
1075 (defun nnimap-find-connection (buffer)
1076   "Find the connection delivering to BUFFER."
1077   (let ((entry (assoc buffer nnimap-connection-alist)))
1078     (when entry
1079       (if (and (buffer-name (cadr entry))
1080                (get-buffer-process (cadr entry))
1081                (memq (process-status (get-buffer-process (cadr entry)))
1082                      '(open run)))
1083           (get-buffer-process (cadr entry))
1084         (setq nnimap-connection-alist (delq entry nnimap-connection-alist))
1085         nil))))
1086
1087 (defvar nnimap-sequence 0)
1088
1089 (defun nnimap-send-command (&rest args)
1090   (process-send-string
1091    (get-buffer-process (current-buffer))
1092    (nnimap-log-command
1093     (format "%d %s%s\n"
1094             (incf nnimap-sequence)
1095             (apply #'format args)
1096             (if (nnimap-newlinep nnimap-object)
1097                 ""
1098               "\r"))))
1099   nnimap-sequence)
1100
1101 (defun nnimap-log-command (command)
1102   (with-current-buffer (get-buffer-create "*imap log*")
1103     (goto-char (point-max))
1104     (insert (format-time-string "%H:%M:%S") " " command))
1105   command)
1106
1107 (defun nnimap-command (&rest args)
1108   (erase-buffer)
1109   (setf (nnimap-last-command-time nnimap-object) (current-time))
1110   (let* ((sequence (apply #'nnimap-send-command args))
1111          (response (nnimap-get-response sequence)))
1112     (if (equal (caar response) "OK")
1113         (cons t response)
1114       (nnheader-report 'nnimap "%s"
1115                        (mapconcat (lambda (a)
1116                                     (format "%s" a))
1117                                   (car response) " "))
1118       nil)))
1119
1120 (defun nnimap-get-response (sequence)
1121   (nnimap-wait-for-response sequence)
1122   (nnimap-parse-response))
1123
1124 (defun nnimap-wait-for-connection ()
1125   (let ((process (get-buffer-process (current-buffer))))
1126     (goto-char (point-min))
1127     (while (and (memq (process-status process)
1128                       '(open run))
1129                 (not (re-search-forward "^\\* .*\n" nil t)))
1130       (nnheader-accept-process-output process)
1131       (goto-char (point-min)))
1132     (forward-line -1)
1133     (and (looking-at "\\* \\([A-Z0-9]+\\)")
1134          (match-string 1))))
1135
1136 (defun nnimap-wait-for-response (sequence &optional messagep)
1137   (let ((process (get-buffer-process (current-buffer)))
1138         openp)
1139     (goto-char (point-max))
1140     (while (and (setq openp (memq (process-status process)
1141                                   '(open run)))
1142                 (not (re-search-backward
1143                       (format "^%d .*\n" sequence)
1144                       (if nnimap-streaming
1145                           (max (point-min) (- (point) 500))
1146                         (point-min))
1147                       t)))
1148       (when messagep
1149         (message "Read %dKB" (/ (buffer-size) 1000)))
1150       (nnheader-accept-process-output process)
1151       (goto-char (point-max)))
1152     openp))
1153
1154 (defun nnimap-parse-response ()
1155   (let ((lines (split-string (nnimap-last-response-string) "\r\n" t))
1156         result)
1157     (dolist (line lines)
1158       (push (cdr (nnimap-parse-line line)) result))
1159     ;; Return the OK/error code first, and then all the "continuation
1160     ;; lines" afterwards.
1161     (cons (pop result)
1162           (nreverse result))))
1163
1164 ;; Parse an IMAP response line lightly.  They look like
1165 ;; "* OK [UIDVALIDITY 1164213559] UIDs valid", typically, so parse
1166 ;; the lines into a list of strings and lists of string.
1167 (defun nnimap-parse-line (line)
1168   (let (char result)
1169     (with-temp-buffer
1170       (insert line)
1171       (goto-char (point-min))
1172       (while (not (eobp))
1173         (if (eql (setq char (following-char)) ? )
1174             (forward-char 1)
1175           (push
1176            (cond
1177             ((eql char ?\[)
1178              (split-string (buffer-substring
1179                             (1+ (point)) (1- (search-forward "]")))))
1180             ((eql char ?\()
1181              (split-string (buffer-substring
1182                             (1+ (point)) (1- (search-forward ")")))))
1183             ((eql char ?\")
1184              (forward-char 1)
1185              (buffer-substring (point) (1- (search-forward "\""))))
1186             (t
1187              (buffer-substring (point) (if (search-forward " " nil t)
1188                                            (1- (point))
1189                                          (goto-char (point-max))))))
1190            result)))
1191       (nreverse result))))
1192
1193 (defun nnimap-last-response-string ()
1194   (save-excursion
1195     (forward-line 1)
1196     (let ((end (point)))
1197       (forward-line -1)
1198       (when (not (bobp))
1199         (forward-line -1)
1200         (while (and (not (bobp))
1201                     (eql (following-char) ?*))
1202           (forward-line -1))
1203         (unless (eql (following-char) ?*)
1204           (forward-line 1)))
1205       (buffer-substring (point) end))))
1206
1207 (defun nnimap-get-responses (sequences)
1208   (let (responses)
1209     (dolist (sequence sequences)
1210       (goto-char (point-min))
1211       (when (re-search-forward (format "^%d " sequence) nil t)
1212         (push (list sequence (nnimap-parse-response))
1213               responses)))
1214     responses))
1215
1216 (defvar nnimap-incoming-split-list nil)
1217
1218 (defun nnimap-fetch-inbox (articles)
1219   (erase-buffer)
1220   (nnimap-wait-for-response
1221    (nnimap-send-command
1222     "UID FETCH %s %s"
1223     (nnimap-article-ranges articles)
1224     (format "(UID %s%s)"
1225             (format
1226              (if (nnimap-ver4-p)
1227                  "BODY.PEEK[HEADER] BODY.PEEK"
1228                "RFC822.PEEK"))
1229             (if nnimap-split-download-body-default
1230                 "[]"
1231               "[1]")))
1232    t))
1233
1234 (defun nnimap-split-incoming-mail ()
1235   (with-current-buffer (nnimap-buffer)
1236     (let ((nnimap-incoming-split-list nil)
1237           (nnmail-split-methods nnimap-split-methods)
1238           (nnmail-inhibit-default-split-group t)
1239           (groups (nnimap-get-groups))
1240           new-articles)
1241       (erase-buffer)
1242       (nnimap-command "SELECT %S" nnimap-inbox)
1243       (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*")))
1244       (when new-articles
1245         (nnimap-fetch-inbox new-articles)
1246         (nnimap-transform-split-mail)
1247         (nnheader-ms-strip-cr)
1248         (nnmail-cache-open)
1249         (nnmail-split-incoming (current-buffer)
1250                                #'nnimap-save-mail-spec
1251                                nil nil
1252                                #'nnimap-dummy-active-number
1253                                #'nnimap-save-mail-spec)
1254         (when nnimap-incoming-split-list
1255           (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list))
1256                 sequences junk-articles)
1257             ;; Create any groups that doesn't already exist on the
1258             ;; server first.
1259             (dolist (spec specs)
1260               (when (and (not (member (car spec) groups))
1261                          (not (eq (car spec) 'junk)))
1262                 (nnimap-command "CREATE %S" (utf7-encode (car spec) t))))
1263             ;; Then copy over all the messages.
1264             (erase-buffer)
1265             (dolist (spec specs)
1266               (let ((group (car spec))
1267                     (ranges (cdr spec)))
1268                 (if (eq group 'junk)
1269                     (setq junk-articles ranges)
1270                   (push (list (nnimap-send-command
1271                                "UID COPY %s %S"
1272                                (nnimap-article-ranges ranges)
1273                                (utf7-encode group t))
1274                               ranges)
1275                         sequences))))
1276             ;; Wait for the last COPY response...
1277             (when sequences
1278               (nnimap-wait-for-response (caar sequences))
1279               ;; And then mark the successful copy actions as deleted,
1280               ;; and possibly expunge them.
1281               (nnimap-mark-and-expunge-incoming
1282                (nnimap-parse-copied-articles sequences)))
1283             (nnimap-mark-and-expunge-incoming junk-articles)))))))
1284
1285 (defun nnimap-mark-and-expunge-incoming (range)
1286   (when range
1287     (setq range (nnimap-article-ranges range))
1288     (let ((sequence
1289            (nnimap-send-command
1290             "UID STORE %s +FLAGS.SILENT (\\Deleted)" range)))
1291       (cond
1292        ;; If the server supports it, we now delete the message we have
1293        ;; just copied over.
1294        ((member "UIDPLUS" (nnimap-capabilities nnimap-object))
1295         (setq sequence (nnimap-send-command "UID EXPUNGE %s" range)))
1296        ;; If it doesn't support UID EXPUNGE, then we only expunge if the
1297        ;; user has configured it.
1298        (nnimap-expunge
1299         (setq sequence (nnimap-send-command "EXPUNGE"))))
1300       (nnimap-wait-for-response sequence))))
1301
1302 (defun nnimap-parse-copied-articles (sequences)
1303   (let (sequence copied range)
1304     (goto-char (point-min))
1305     (while (re-search-forward "^\\([0-9]+\\) OK " nil t)
1306       (setq sequence (string-to-number (match-string 1)))
1307       (when (setq range (cadr (assq sequence sequences)))
1308         (push (gnus-uncompress-range range) copied)))
1309     (gnus-compress-sequence (sort (apply #'nconc copied) #'<))))
1310
1311 (defun nnimap-new-articles (flags)
1312   (let (new)
1313     (dolist (elem flags)
1314       (when (or (null (cdr elem))
1315                 (and (not (memq '%Deleted (cdr elem)))
1316                      (not (memq '%Seen (cdr elem)))))
1317         (push (car elem) new)))
1318     (gnus-compress-sequence (nreverse new))))
1319
1320 (defun nnimap-make-split-specs (list)
1321   (let ((specs nil)
1322         entry)
1323     (dolist (elem list)
1324       (destructuring-bind (article spec) elem
1325         (dolist (group (delete nil (mapcar #'car spec)))
1326           (unless (setq entry (assoc group specs))
1327             (push (setq entry (list group)) specs))
1328           (setcdr entry (cons article (cdr entry))))))
1329     (dolist (entry specs)
1330       (setcdr entry (gnus-compress-sequence (sort (cdr entry) #'<))))
1331     specs))
1332
1333 (defun nnimap-transform-split-mail ()
1334   (goto-char (point-min))
1335   (let (article bytes)
1336     (block nil
1337       (while (not (eobp))
1338         (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
1339           (delete-region (point) (progn (forward-line 1) (point)))
1340           (when (eobp)
1341             (return)))
1342         (setq article (match-string 1)
1343               bytes (nnimap-get-length))
1344         (delete-region (line-beginning-position) (line-end-position))
1345         ;; Insert MMDF separator, and a way to remember what this
1346         ;; article UID is.
1347         (insert (format "\^A\^A\^A\^A\n\nX-nnimap-article: %s" article))
1348         (forward-char (1+ bytes))
1349         (setq bytes (nnimap-get-length))
1350         (delete-region (line-beginning-position) (line-end-position))
1351         (forward-char (1+ bytes))
1352         (delete-region (line-beginning-position) (line-end-position))))))
1353
1354 (defun nnimap-dummy-active-number (group &optional server)
1355   1)
1356
1357 (defun nnimap-save-mail-spec (group-art &optional server full-nov)
1358   (let (article)
1359     (goto-char (point-min))
1360     (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t))
1361         (error "Invalid nnimap mail")
1362       (setq article (string-to-number (match-string 1))))
1363     (push (list article
1364                 (if (eq group-art 'junk)
1365                     (list (cons 'junk 1))
1366                   group-art))
1367           nnimap-incoming-split-list)))
1368
1369 (provide 'nnimap)
1370
1371 ;;; nnimap.el ends here