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