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