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