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