cgit.sxemacs.org Git - gnus/blob - lisp/nnimap.el

   1 ;;; nnimap.el --- IMAP interface for Gnus
   2
   3 ;; Copyright (C) 2010-2015 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   ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for
  32   ;; `make-network-stream'.
  33   (unless (fboundp 'open-protocol-stream)
  34     (require 'proto-stream)))
  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
  49 (autoload 'auth-source-forget+ "auth-source")
  50 (autoload 'auth-source-search "auth-source")
  51
  52 (nnoo-declare nnimap)
  53
  54 (defvoo nnimap-address nil
  55   "The address of the IMAP server.")
  56
  57 (defvoo nnimap-user nil
  58   "Username to use for authentication to the IMAP server.")
  59
  60 (defvoo nnimap-server-port nil
  61   "The IMAP port used.
  62 If nnimap-stream is `ssl', this will default to `imaps'.  If not,
  63 it will default to `imap'.")
  64
  65 (defvoo nnimap-stream 'undecided
  66   "How nnimap talks to the IMAP server.
  67 The value should be either `undecided', `ssl' or `tls',
  68 `network', `starttls', `plain', or `shell'.
  69
  70 If the value is `undecided', nnimap tries `ssl' first, then falls
  71 back on `network'.")
  72
  73 (defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
  74                                  (if (listp imap-shell-program)
  75                                      (car imap-shell-program)
  76                                    imap-shell-program)
  77                                "ssh %s imapd"))
  78
  79 (defvoo nnimap-inbox nil
  80   "The mail box where incoming mail arrives and should be split out of.
  81 This can be a string or a list of strings
  82 For example, \"INBOX\" or (\"INBOX\" \"SENT\").")
  83
  84 (defvoo nnimap-split-methods nil
  85   "How mail is split.
  86 Uses the same syntax as `nnmail-split-methods'.")
  87
  88 (defvoo nnimap-split-fancy nil
  89   "Uses the same syntax as `nnmail-split-fancy'.")
  90
  91 (defvoo nnimap-unsplittable-articles '(%Deleted %Seen)
  92   "Articles with the flags in the list will not be considered when splitting.")
  93
  94 (make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'."
  95                         "Emacs 24.1")
  96
  97 (defvoo nnimap-authenticator nil
  98   "How nnimap authenticate itself to the server.
  99 Possible choices are nil (use default methods), `anonymous',
 100 `login', `plain' and `cram-md5'.")
 101
 102 (defvoo nnimap-expunge t
 103   "If non-nil, expunge articles after deleting them.
 104 This is always done if the server supports UID EXPUNGE, but it's
 105 not done by default on servers that doesn't support that command.")
 106
 107 (defvoo nnimap-streaming t
 108   "If non-nil, try to use streaming commands with IMAP servers.
 109 Switching this off will make nnimap slower, but it helps with
 110 some servers.")
 111
 112 (defvoo nnimap-connection-alist nil)
 113
 114 (defvoo nnimap-current-infos nil)
 115
 116 (defvoo nnimap-fetch-partial-articles nil
 117   "If non-nil, Gnus will fetch partial articles.
 118 If t, Gnus will fetch only the first part.  If a string, it
 119 will fetch all parts that have types that match that string.  A
 120 likely value would be \"text/\" to automatically fetch all
 121 textual parts.")
 122
 123 (defgroup nnimap nil
 124   "IMAP for Gnus."
 125   :group 'gnus)
 126
 127 (defcustom nnimap-request-articles-find-limit nil
 128   "Limit the number of articles to look for after moving an article."
 129   :type '(choice (const nil) integer)
 130   :version "24.4"
 131   :group 'nnimap)
 132
 133 (defvar nnimap-process nil)
 134
 135 (defvar nnimap-status-string "")
 136
 137 (defvar nnimap-split-download-body-default nil
 138   "Internal variable with default value for `nnimap-split-download-body'.")
 139
 140 (defvar nnimap-keepalive-timer nil)
 141 (defvar nnimap-process-buffers nil)
 142
 143 (defstruct nnimap
 144   group process commands capabilities select-result newlinep server
 145   last-command-time greeting examined stream-type initial-resync)
 146
 147 (defvar nnimap-object nil)
 148
 149 (defvar nnimap-mark-alist
 150   '((read "\\Seen" %Seen)
 151     (tick "\\Flagged" %Flagged)
 152     (reply "\\Answered" %Answered)
 153     (expire "gnus-expire")
 154     (dormant "gnus-dormant")
 155     (score "gnus-score")
 156     (save "gnus-save")
 157     (download "gnus-download")
 158     (forward "gnus-forward")))
 159
 160 (defvar nnimap-quirks
 161   '(("QRESYNC" "Zimbra" "QRESYNC ")))
 162
 163 (defvar nnimap-inhibit-logging nil)
 164
 165 (defun nnimap-buffer ()
 166   (nnimap-find-process-buffer nntp-server-buffer))
 167
 168 (defun nnimap-header-parameters ()
 169   (let (params)
 170     (push "UID" params)
 171     (push "RFC822.SIZE" params)
 172     (when (nnimap-capability "X-GM-EXT-1")
 173       (push "X-GM-LABELS" params))
 174     (push "BODYSTRUCTURE" params)
 175     (push (format
 176            (if (nnimap-ver4-p)
 177                "BODY.PEEK[HEADER.FIELDS %s]"
 178              "RFC822.HEADER.LINES %s")
 179            (append '(Subject From Date Message-Id
 180                              References In-Reply-To Xref)
 181                    nnmail-extra-headers))
 182           params)
 183     (format "%s" (nreverse params))))
 184
 185 (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old)
 186   (when group
 187     (setq group (nnimap-decode-gnus-group group)))
 188   (with-current-buffer nntp-server-buffer
 189     (erase-buffer)
 190     (when (nnimap-change-group group server)
 191       (with-current-buffer (nnimap-buffer)
 192         (erase-buffer)
 193         (nnimap-wait-for-response
 194          (nnimap-send-command
 195           "UID FETCH %s %s"
 196           (nnimap-article-ranges (gnus-compress-sequence articles))
 197           (nnimap-header-parameters))
 198          t)
 199         (nnimap-transform-headers)
 200         (nnheader-remove-cr-followed-by-lf))
 201       (insert-buffer-substring
 202        (nnimap-find-process-buffer (current-buffer))))
 203     'headers))
 204
 205 (defun nnimap-transform-headers ()
 206   (goto-char (point-min))
 207   (let (article lines size string labels)
 208     (block nil
 209       (while (not (eobp))
 210         (while (not (looking-at "\\* [0-9]+ FETCH"))
 211           (delete-region (point) (progn (forward-line 1) (point)))
 212           (when (eobp)
 213             (return)))
 214         (goto-char (match-end 0))
 215         ;; Unfold quoted {number} strings.
 216         (while (re-search-forward
 217                 "[^]][ (]{\\([0-9]+\\)}\r?\n"
 218                 (save-excursion
 219                   ;; Start of the header section.
 220                   (or (re-search-forward "] {[0-9]+}\r?\n" nil t)
 221                       ;; Start of the next FETCH.
 222                       (re-search-forward "\\* [0-9]+ FETCH" nil t)
 223                       (point-max)))
 224                 t)
 225           (setq size (string-to-number (match-string 1)))
 226           (delete-region (+ (match-beginning 0) 2) (point))
 227           (setq string (buffer-substring (point) (+ (point) size)))
 228           (delete-region (point) (+ (point) size))
 229           (insert (format "%S" (mm-subst-char-in-string ?\n ?\s string))))
 230         (beginning-of-line)
 231         (setq article
 232               (and (re-search-forward "UID \\([0-9]+\\)" (line-end-position)
 233                                       t)
 234                    (match-string 1)))
 235         (setq lines nil)
 236         (setq size
 237               (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)"
 238                                       (line-end-position)
 239                                       t)
 240                    (match-string 1)))
 241         (beginning-of-line)
 242         (when (search-forward "X-GM-LABELS" (line-end-position) t)
 243           (setq labels (ignore-errors (read (current-buffer)))))
 244         (beginning-of-line)
 245         (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
 246           (let ((structure (ignore-errors
 247                              (read (current-buffer)))))
 248             (while (and (consp structure)
 249                         (not (atom (car structure))))
 250               (setq structure (car structure)))
 251             (setq lines (if (and
 252                              (stringp (car structure))
 253                              (equal (upcase (nth 0 structure)) "MESSAGE")
 254                              (equal (upcase (nth 1 structure)) "RFC822"))
 255                             (nth 9 structure)
 256                           (nth 7 structure)))))
 257         (delete-region (line-beginning-position) (line-end-position))
 258         (insert (format "211 %s Article retrieved." article))
 259         (forward-line 1)
 260         (when size
 261           (insert (format "Chars: %s\n" size)))
 262         (when lines
 263           (insert (format "Lines: %s\n" lines)))
 264         (when labels
 265           (insert (format "X-GM-LABELS: %s\n" labels)))
 266         ;; Most servers have a blank line after the headers, but
 267         ;; Davmail doesn't.
 268         (unless (re-search-forward "^\r$\\|^)\r?$" nil t)
 269           (goto-char (point-max)))
 270         (delete-region (line-beginning-position) (line-end-position))
 271         (insert ".")
 272         (forward-line 1)))))
 273
 274 (defun nnimap-unfold-quoted-lines ()
 275   ;; Unfold quoted {number} strings.
 276   (let (size string)
 277     (while (re-search-forward " {\\([0-9]+\\)}\r?\n" nil t)
 278       (setq size (string-to-number (match-string 1)))
 279       (delete-region (1+ (match-beginning 0)) (point))
 280       (setq string (buffer-substring (point) (+ (point) size)))
 281       (delete-region (point) (+ (point) size))
 282       (insert (format "%S" string)))))
 283
 284 (defun nnimap-get-length ()
 285   (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t)
 286        (string-to-number (match-string 1))))
 287
 288 (defun nnimap-article-ranges (ranges)
 289   (let (result)
 290     (cond
 291      ((numberp ranges)
 292       (number-to-string ranges))
 293      ((numberp (cdr ranges))
 294       (format "%d:%d" (car ranges) (cdr ranges)))
 295      (t
 296       (dolist (elem ranges)
 297         (push
 298          (if (consp elem)
 299              (format "%d:%d" (car elem) (cdr elem))
 300            (number-to-string elem))
 301          result))
 302       (mapconcat #'identity (nreverse result) ",")))))
 303
 304 (deffoo nnimap-open-server (server &optional defs no-reconnect)
 305   (if (nnimap-server-opened server)
 306       t
 307     (unless (assq 'nnimap-address defs)
 308       (setq defs (append defs (list (list 'nnimap-address server)))))
 309     (nnoo-change-server 'nnimap server defs)
 310     (if no-reconnect
 311         (nnimap-find-connection nntp-server-buffer)
 312       (or (nnimap-find-connection nntp-server-buffer)
 313           (nnimap-open-connection nntp-server-buffer)))))
 314
 315 (defun nnimap-make-process-buffer (buffer)
 316   (with-current-buffer
 317       (generate-new-buffer (format " *nnimap %s %s %s*"
 318                                    nnimap-address nnimap-server-port
 319                                    (gnus-buffer-exists-p buffer)))
 320     (mm-disable-multibyte)
 321     (buffer-disable-undo)
 322     (gnus-add-buffer)
 323     (set (make-local-variable 'after-change-functions) nil)
 324     (set (make-local-variable 'nnimap-object)
 325          (make-nnimap :server (nnoo-current-server 'nnimap)
 326                       :initial-resync 0))
 327     (push (list buffer (current-buffer)) nnimap-connection-alist)
 328     (push (current-buffer) nnimap-process-buffers)
 329     (current-buffer)))
 330
 331 (defun nnimap-credentials (address ports user)
 332   (let* ((auth-source-creation-prompts
 333           '((user  . "IMAP user at %h: ")
 334             (secret . "IMAP password for %u@%h: ")))
 335          (found (nth 0 (auth-source-search :max 1
 336                                            :host address
 337                                            :port ports
 338                                            :user user
 339                                            :require '(:user :secret)
 340                                            :create t))))
 341     (if found
 342         (list (plist-get found :user)
 343               (let ((secret (plist-get found :secret)))
 344                 (if (functionp secret)
 345                     (funcall secret)
 346                   secret))
 347               (plist-get found :save-function))
 348       nil)))
 349
 350 (defun nnimap-keepalive ()
 351   (let ((now (current-time)))
 352     (dolist (buffer nnimap-process-buffers)
 353       (when (buffer-name buffer)
 354         (with-current-buffer buffer
 355           (when (and nnimap-object
 356                      (nnimap-last-command-time nnimap-object)
 357                      (> (gnus-float-time
 358                          (time-subtract
 359                           now
 360                           (nnimap-last-command-time nnimap-object)))
 361                         ;; More than five minutes since the last command.
 362                         (* 5 60)))
 363             (ignore-errors              ;E.g. "buffer foo has no process".
 364               (nnimap-send-command "NOOP"))))))))
 365
 366 (defun nnimap-open-connection (buffer)
 367   ;; Be backwards-compatible -- the earlier value of nnimap-stream was
 368   ;; `ssl' when nnimap-server-port was nil.  Sort of.
 369   (when (and nnimap-server-port
 370              (eq nnimap-stream 'undecided))
 371     (setq nnimap-stream 'ssl))
 372   (let ((stream
 373          (if (eq nnimap-stream 'undecided)
 374              (loop for type in '(ssl network)
 375                    for stream = (let ((nnimap-stream type))
 376                                   (nnimap-open-connection-1 buffer))
 377                    while (eq stream 'no-connect)
 378                    finally (return stream))
 379            (nnimap-open-connection-1 buffer))))
 380     (if (eq stream 'no-connect)
 381         nil
 382       stream)))
 383
 384 (defun nnimap-map-port (port)
 385   (if (equal port "imaps")
 386       "993"
 387     port))
 388
 389 (defun nnimap-open-connection-1 (buffer)
 390   (unless nnimap-keepalive-timer
 391     (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
 392                                               #'nnimap-keepalive)))
 393   (with-current-buffer (nnimap-make-process-buffer buffer)
 394     (let* ((coding-system-for-read 'binary)
 395            (coding-system-for-write 'binary)
 396            (ports
 397             (cond
 398              ((memq nnimap-stream '(network plain starttls))
 399               (nnheader-message 7 "Opening connection to %s..."
 400                                 nnimap-address)
 401               '("imap" "143"))
 402              ((eq nnimap-stream 'shell)
 403               (nnheader-message 7 "Opening connection to %s via shell..."
 404                                 nnimap-address)
 405               '("imap"))
 406              ((memq nnimap-stream '(ssl tls))
 407               (nnheader-message 7 "Opening connection to %s via tls..."
 408                                 nnimap-address)
 409               '("imaps" "imap" "993" "143"))
 410              (t
 411               (error "Unknown stream type: %s" nnimap-stream))))
 412            login-result credentials)
 413       (when nnimap-server-port
 414         (push nnimap-server-port ports))
 415       (let* ((stream-list
 416               (open-protocol-stream
 417                "*nnimap*" (current-buffer) nnimap-address
 418                (nnimap-map-port (car ports))
 419                :type nnimap-stream
 420                :warn-unless-encrypted t
 421                :return-list t
 422                :shell-command nnimap-shell-program
 423                :capability-command "1 CAPABILITY\r\n"
 424                :end-of-command "\r\n"
 425                :success " OK "
 426                :starttls-function
 427                (lambda (capabilities)
 428                  (when (gnus-string-match-p "STARTTLS" capabilities)
 429                    "1 STARTTLS\r\n"))))
 430              (stream (car stream-list))
 431              (props (cdr stream-list))
 432              (greeting (plist-get props :greeting))
 433              (capabilities (plist-get props :capabilities))
 434              (stream-type (plist-get props :type)))
 435         (when (and stream (not (memq (process-status stream) '(open run))))
 436           (setq stream nil))
 437
 438         (when (and (fboundp 'set-network-process-option) ;; Not in XEmacs.
 439                    (fboundp 'process-type) ;; Emacs 22 doesn't provide it.
 440                    (eq (process-type stream) 'network))
 441           ;; Use TCP-keepalive so that connections that pass through a NAT
 442           ;; router don't hang when left idle.
 443           (set-network-process-option stream :keepalive t))
 444
 445         (setf (nnimap-process nnimap-object) stream)
 446         (setf (nnimap-stream-type nnimap-object) stream-type)
 447         (if (not stream)
 448             (progn
 449               (nnheader-report 'nnimap "Unable to contact %s:%s via %s"
 450                                nnimap-address (car ports) nnimap-stream)
 451               'no-connect)
 452           (gnus-set-process-query-on-exit-flag stream nil)
 453           (if (not (gnus-string-match-p "[*.] \\(OK\\|PREAUTH\\)" greeting))
 454               (nnheader-report 'nnimap "%s" greeting)
 455             ;; Store the greeting (for debugging purposes).
 456             (setf (nnimap-greeting nnimap-object) greeting)
 457             (setf (nnimap-capabilities nnimap-object)
 458                   (mapcar #'upcase
 459                           (split-string capabilities)))
 460             (unless (gnus-string-match-p "[*.] PREAUTH" greeting)
 461               (if (not (setq credentials
 462                              (if (eq nnimap-authenticator 'anonymous)
 463                                  (list "anonymous"
 464                                        (message-make-address))
 465                                ;; Look for the credentials based on
 466                                ;; the virtual server name and the address
 467                                (nnimap-credentials
 468                                 (gnus-delete-duplicates
 469                                  (list
 470                                   (nnoo-current-server 'nnimap)
 471                                   nnimap-address))
 472                                 ports
 473                                 nnimap-user))))
 474                   (setq nnimap-object nil)
 475                 (let ((nnimap-inhibit-logging t))
 476                   (setq login-result
 477                         (nnimap-login (car credentials) (cadr credentials))))
 478                 (if (car login-result)
 479                     (progn
 480                       ;; Save the credentials if a save function exists
 481                       ;; (such a function will only be passed if a new
 482                       ;; token was created).
 483                       (when (functionp (nth 2 credentials))
 484                         (funcall (nth 2 credentials)))
 485                       ;; See if CAPABILITY is set as part of login
 486                       ;; response.
 487                       (dolist (response (cddr login-result))
 488                         (when (string= "CAPABILITY" (upcase (car response)))
 489                           (setf (nnimap-capabilities nnimap-object)
 490                                 (mapcar #'upcase (cdr response))))))
 491                   ;; If the login failed, then forget the credentials
 492                   ;; that are now possibly cached.
 493                   (dolist (host (list (nnoo-current-server 'nnimap)
 494                                       nnimap-address))
 495                     (dolist (port ports)
 496                       (auth-source-forget+ :host host :port port)))
 497                   (delete-process (nnimap-process nnimap-object))
 498                   (setq nnimap-object nil))))
 499             (when nnimap-object
 500               (when (nnimap-capability "QRESYNC")
 501                 (nnimap-command "ENABLE QRESYNC"))
 502               (nnheader-message 7 "Opening connection to %s...done"
 503                                 nnimap-address)
 504               (nnimap-process nnimap-object))))))))
 505
 506 (autoload 'rfc2104-hash "rfc2104")
 507
 508 (defun nnimap-login (user password)
 509   (cond
 510    ;; Prefer plain LOGIN if it's enabled (since it requires fewer
 511    ;; round trips than CRAM-MD5, and it's less likely to be buggy),
 512    ;; and we're using an encrypted connection.
 513    ((and (not (nnimap-capability "LOGINDISABLED"))
 514          (eq (nnimap-stream-type nnimap-object) 'tls)
 515          (or (null nnimap-authenticator)
 516              (eq nnimap-authenticator 'login)))
 517     (nnimap-command "LOGIN %S %S" user password))
 518    ((and (nnimap-capability "AUTH=CRAM-MD5")
 519          (or (null nnimap-authenticator)
 520              (eq nnimap-authenticator 'cram-md5)))
 521     (erase-buffer)
 522     (let ((sequence (nnimap-send-command "AUTHENTICATE CRAM-MD5"))
 523           (challenge (nnimap-wait-for-line "^\\+\\(.*\\)\n")))
 524       (process-send-string
 525        (get-buffer-process (current-buffer))
 526        (concat
 527         (base64-encode-string
 528          (concat user " "
 529                  (rfc2104-hash 'md5 64 16 password
 530                                (base64-decode-string challenge))))
 531         "\r\n"))
 532       (nnimap-wait-for-response sequence)))
 533    ((and (not (nnimap-capability "LOGINDISABLED"))
 534          (or (null nnimap-authenticator)
 535              (eq nnimap-authenticator 'login)))
 536     (nnimap-command "LOGIN %S %S" user password))
 537    ((and (nnimap-capability "AUTH=PLAIN")
 538          (or (null nnimap-authenticator)
 539              (eq nnimap-authenticator 'plain)))
 540     (nnimap-command
 541      "AUTHENTICATE PLAIN %s"
 542      (base64-encode-string
 543       (format "\000%s\000%s"
 544               (nnimap-quote-specials user)
 545               (nnimap-quote-specials password)))))))
 546
 547 (defun nnimap-quote-specials (string)
 548   (with-temp-buffer
 549     (insert string)
 550     (goto-char (point-min))
 551     (while (re-search-forward "[\\\"]" nil t)
 552       (forward-char -1)
 553       (insert "\\")
 554       (forward-char 1))
 555     (buffer-string)))
 556
 557 (defun nnimap-find-parameter (parameter elems)
 558   (let (result)
 559     (dolist (elem elems)
 560       (cond
 561        ((equal (car elem) parameter)
 562         (setq result (cdr elem)))
 563        ((and (equal (car elem) "OK")
 564              (consp (cadr elem))
 565              (equal (caadr elem) parameter))
 566         (setq result (cdr (cadr elem))))))
 567     result))
 568
 569 (deffoo nnimap-close-server (&optional server)
 570   (when (nnoo-change-server 'nnimap server nil)
 571     (ignore-errors
 572       (delete-process (get-buffer-process (nnimap-buffer))))
 573     (nnoo-close-server 'nnimap server)
 574     t))
 575
 576 (deffoo nnimap-request-close ()
 577   t)
 578
 579 (deffoo nnimap-server-opened (&optional server)
 580   (and (nnoo-current-server-p 'nnimap server)
 581        nntp-server-buffer
 582        (gnus-buffer-live-p nntp-server-buffer)
 583        (nnimap-find-connection nntp-server-buffer)))
 584
 585 (deffoo nnimap-status-message (&optional server)
 586   nnimap-status-string)
 587
 588 (deffoo nnimap-request-article (article &optional group server to-buffer)
 589   (when group
 590     (setq group (nnimap-decode-gnus-group group)))
 591   (with-current-buffer nntp-server-buffer
 592     (let ((result (nnimap-change-group group server))
 593           parts structure)
 594       (when (stringp article)
 595         (setq article (nnimap-find-article-by-message-id group server article)))
 596       (when (and result
 597                  article)
 598         (erase-buffer)
 599         (with-current-buffer (nnimap-buffer)
 600           (erase-buffer)
 601           (when nnimap-fetch-partial-articles
 602             (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article)
 603             (goto-char (point-min))
 604             (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t)
 605               (setq structure (ignore-errors
 606                                 (let ((start (point)))
 607                                   (forward-sexp 1)
 608                                   (downcase-region start (point))
 609                                   (goto-char start)
 610                                   (read (current-buffer))))
 611                     parts (nnimap-find-wanted-parts structure))))
 612           (when (if parts
 613                     (nnimap-get-partial-article article parts structure)
 614                   (nnimap-get-whole-article article))
 615             (let ((buffer (current-buffer)))
 616               (with-current-buffer (or to-buffer nntp-server-buffer)
 617                 (nnheader-insert-buffer-substring buffer)
 618                 (nnheader-ms-strip-cr)))
 619             (cons group article)))))))
 620
 621 (deffoo nnimap-request-head (article &optional group server to-buffer)
 622   (when group
 623     (setq group (nnimap-decode-gnus-group group)))
 624   (when (nnimap-change-group group server)
 625     (with-current-buffer (nnimap-buffer)
 626       (when (stringp article)
 627         (setq article (nnimap-find-article-by-message-id group server article)))
 628       (if (null article)
 629           nil
 630         (nnimap-get-whole-article
 631          article (format "UID FETCH %%d %s"
 632                          (nnimap-header-parameters)))
 633         (let ((buffer (current-buffer)))
 634           (with-current-buffer (or to-buffer nntp-server-buffer)
 635             (erase-buffer)
 636             (insert-buffer-substring buffer)
 637             (nnheader-ms-strip-cr)
 638             (cons group article)))))))
 639
 640 (deffoo nnimap-request-articles (articles &optional group server)
 641   (when group
 642     (setq group (nnimap-decode-gnus-group group)))
 643   (with-current-buffer nntp-server-buffer
 644     (let ((result (nnimap-change-group group server)))
 645       (when result
 646         (erase-buffer)
 647         (with-current-buffer (nnimap-buffer)
 648           (erase-buffer)
 649           (when (nnimap-command
 650                  (if (nnimap-ver4-p)
 651                      "UID FETCH %s BODY.PEEK[]"
 652                    "UID FETCH %s RFC822.PEEK")
 653                  (nnimap-article-ranges (gnus-compress-sequence articles)))
 654             (let ((buffer (current-buffer)))
 655               (with-current-buffer nntp-server-buffer
 656                 (nnheader-insert-buffer-substring buffer)
 657                 (nnheader-ms-strip-cr)))
 658             t))))))
 659
 660 (defun nnimap-get-whole-article (article &optional command)
 661   (let ((result
 662          (nnimap-command
 663           (or command
 664               (if (nnimap-ver4-p)
 665                   "UID FETCH %d BODY.PEEK[]"
 666                 "UID FETCH %d RFC822.PEEK"))
 667           article)))
 668     ;; Check that we really got an article.
 669     (goto-char (point-min))
 670     (unless (re-search-forward "\\* [0-9]+ FETCH" nil t)
 671       (setq result nil))
 672     (when result
 673       ;; Remove any data that may have arrived before the FETCH data.
 674       (beginning-of-line)
 675       (unless (bobp)
 676         (delete-region (point-min) (point)))
 677       (let ((bytes (nnimap-get-length)))
 678         (delete-region (line-beginning-position)
 679                        (progn (forward-line 1) (point)))
 680         (goto-char (+ (point) bytes))
 681         (delete-region (point) (point-max)))
 682       t)))
 683
 684 (defun nnimap-capability (capability)
 685   (member capability (nnimap-capabilities nnimap-object)))
 686
 687 (defun nnimap-ver4-p ()
 688   (nnimap-capability "IMAP4REV1"))
 689
 690 (defun nnimap-get-partial-article (article parts structure)
 691   (let ((result
 692          (nnimap-command
 693           "UID FETCH %d (%s %s)"
 694           article
 695           (if (nnimap-ver4-p)
 696               "BODY.PEEK[HEADER]"
 697             "RFC822.HEADER")
 698           (if (nnimap-ver4-p)
 699               (mapconcat (lambda (part)
 700                            (format "BODY.PEEK[%s]" part))
 701                          parts " ")
 702             (mapconcat (lambda (part)
 703                          (format "RFC822.PEEK[%s]" part))
 704                        parts " ")))))
 705     (when result
 706       (nnimap-convert-partial-article structure))))
 707
 708 (defun nnimap-convert-partial-article (structure)
 709   ;; First just skip past the headers.
 710   (goto-char (point-min))
 711   (let ((bytes (nnimap-get-length))
 712         id parts)
 713     ;; Delete "FETCH" line.
 714     (delete-region (line-beginning-position)
 715                    (progn (forward-line 1) (point)))
 716     (goto-char (+ (point) bytes))
 717     ;; Collect all the body parts.
 718     (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]")
 719       (setq id (match-string 1)
 720             bytes (or (nnimap-get-length) 0))
 721       (beginning-of-line)
 722       (delete-region (point) (progn (forward-line 1) (point)))
 723       (push (list id (buffer-substring (point) (+ (point) bytes)))
 724             parts)
 725       (delete-region (point) (+ (point) bytes)))
 726     ;; Delete trailing junk.
 727     (delete-region (point) (point-max))
 728     ;; Now insert all the parts again where they fit in the structure.
 729     (nnimap-insert-partial-structure structure parts)
 730     t))
 731
 732 (defun nnimap-insert-partial-structure (structure parts &optional subp)
 733   (let (type boundary)
 734     (let ((bstruc structure))
 735       (while (consp (car bstruc))
 736         (pop bstruc))
 737       (setq type (car bstruc))
 738       (setq bstruc (car (cdr bstruc)))
 739       (let ((has-boundary (member "boundary" bstruc)))
 740         (when has-boundary
 741           (setq boundary (cadr has-boundary)))))
 742     (when subp
 743       (insert (format "Content-type: multipart/%s; boundary=%S\n\n"
 744                       (downcase type) boundary)))
 745     (while (not (stringp (car structure)))
 746       (insert "\n--" boundary "\n")
 747       (if (consp (caar structure))
 748           (nnimap-insert-partial-structure (pop structure) parts t)
 749         (let ((bit (pop structure)))
 750           (insert (format "Content-type: %s/%s"
 751                           (downcase (nth 0 bit))
 752                           (downcase (nth 1 bit))))
 753           (if (member-ignore-case "CHARSET" (nth 2 bit))
 754               (insert (format
 755                        "; charset=%S\n"
 756                        (cadr (member-ignore-case "CHARSET" (nth 2 bit)))))
 757             (insert "\n"))
 758           (insert (format "Content-transfer-encoding: %s\n"
 759                           (nth 5 bit)))
 760           (insert "\n")
 761           (when (assoc (nth 9 bit) parts)
 762             (insert (cadr (assoc (nth 9 bit) parts)))))))
 763     (insert "\n--" boundary "--\n")))
 764
 765 (defun nnimap-find-wanted-parts (structure)
 766   (message-flatten-list (nnimap-find-wanted-parts-1 structure "")))
 767
 768 (defun nnimap-find-wanted-parts-1 (structure prefix)
 769   (let ((num 1)
 770         parts)
 771     (while (consp (car structure))
 772       (let ((sub (pop structure)))
 773         (if (consp (car sub))
 774             (push (nnimap-find-wanted-parts-1
 775                    sub (if (string= prefix "")
 776                            (number-to-string num)
 777                          (format "%s.%s" prefix num)))
 778                   parts)
 779           (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))
 780                 (id (if (string= prefix "")
 781                         (number-to-string num)
 782                       (format "%s.%s" prefix num))))
 783             (setcar (nthcdr 9 sub) id)
 784             (when (if (eq nnimap-fetch-partial-articles t)
 785                       (equal id "1")
 786                     (string-match nnimap-fetch-partial-articles type))
 787               (push id parts))))
 788         (incf num)))
 789     (nreverse parts)))
 790
 791 (defun nnimap-decode-gnus-group (group)
 792   (decode-coding-string group 'utf-8))
 793
 794 (deffoo nnimap-request-group (group &optional server dont-check info)
 795   (setq group (nnimap-decode-gnus-group group))
 796   (let ((result (nnimap-change-group
 797                  ;; Don't SELECT the group if we're going to select it
 798                  ;; later, anyway.
 799                  (if (and (not dont-check)
 800                           (assoc group nnimap-current-infos))
 801                      nil
 802                    group)
 803                  server))
 804         articles active marks high low)
 805     (with-current-buffer nntp-server-buffer
 806       (when result
 807         (when (and info
 808                    (or (not dont-check)
 809                        (not (setq active
 810                                   (nth 2 (assoc group nnimap-current-infos))))))
 811           (let ((sequences (nnimap-retrieve-group-data-early
 812                             server (list info))))
 813             (nnimap-finish-retrieve-group-infos server (list info) sequences
 814                                                 t)
 815             (setq active (nth 2 (assoc group nnimap-current-infos)))))
 816         (erase-buffer)
 817         (insert (format "211 %d %d %d %S\n"
 818                         (- (cdr active) (car active))
 819                         (car active)
 820                         (cdr active)
 821                         group))
 822         t))))
 823
 824 (deffoo nnimap-request-scan-group (group &optional server info)
 825   (setq group (nnimap-decode-gnus-group group))
 826   (let (marks high low)
 827     (with-current-buffer (nnimap-buffer)
 828       (erase-buffer)
 829       (let ((group-sequence
 830              (nnimap-send-command "SELECT %S" (utf7-encode group t)))
 831             (flag-sequence
 832              (nnimap-send-command "UID FETCH 1:* FLAGS")))
 833         (setf (nnimap-group nnimap-object) group)
 834         (nnimap-wait-for-response flag-sequence)
 835         (setq marks
 836               (nnimap-flags-to-marks
 837                (nnimap-parse-flags
 838                 (list (list group-sequence flag-sequence
 839                             1 group "SELECT")))))
 840         (when (and info
 841                    marks)
 842           (nnimap-update-infos marks (list info))
 843           (nnimap-store-info info (gnus-active (gnus-info-group info))))
 844         (goto-char (point-max))
 845         (let ((uidnext (nth 5 (car marks))))
 846           (setq high (or (if uidnext
 847                              (1- uidnext)
 848                            (nth 3 (car marks)))
 849                          0)
 850                 low (or (nth 4 (car marks)) uidnext 1)))))
 851     (with-current-buffer nntp-server-buffer
 852       (erase-buffer)
 853       (insert
 854        (format
 855         "211 %d %d %d %S\n" (1+ (- high low)) low high group))
 856       t)))
 857
 858 (deffoo nnimap-request-create-group (group &optional server args)
 859   (setq group (nnimap-decode-gnus-group group))
 860   (when (nnimap-change-group nil server)
 861     (with-current-buffer (nnimap-buffer)
 862       (car (nnimap-command "CREATE %S" (utf7-encode group t))))))
 863
 864 (deffoo nnimap-request-delete-group (group &optional force server)
 865   (setq group (nnimap-decode-gnus-group group))
 866   (when (nnimap-change-group nil server)
 867     (with-current-buffer (nnimap-buffer)
 868       (car (nnimap-command "DELETE %S" (utf7-encode group t))))))
 869
 870 (deffoo nnimap-request-rename-group (group new-name &optional server)
 871   (setq group (nnimap-decode-gnus-group group))
 872   (when (nnimap-change-group nil server)
 873     (with-current-buffer (nnimap-buffer)
 874       (nnimap-unselect-group)
 875       (car (nnimap-command "RENAME %S %S"
 876                            (utf7-encode group t) (utf7-encode new-name t))))))
 877
 878 (defun nnimap-unselect-group ()
 879   ;; Make sure we don't have this group open read/write by asking
 880   ;; to examine a mailbox that doesn't exist.  This seems to be
 881   ;; the only way that allows us to reliably go back to unselected
 882   ;; state on Courier.
 883   (nnimap-command "EXAMINE DOES.NOT.EXIST"))
 884
 885 (deffoo nnimap-request-expunge-group (group &optional server)
 886   (setq group (nnimap-decode-gnus-group group))
 887   (when (nnimap-change-group group server)
 888     (with-current-buffer (nnimap-buffer)
 889       (car (nnimap-command "EXPUNGE")))))
 890
 891 (defun nnimap-get-flags (spec)
 892   (let ((articles nil)
 893         elems end)
 894     (with-current-buffer (nnimap-buffer)
 895       (erase-buffer)
 896       (nnimap-wait-for-response (nnimap-send-command
 897                                  "UID FETCH %s FLAGS" spec))
 898       (setq end (point))
 899       (subst-char-in-region (point-min) (point-max)
 900                             ?\\ ?% t)
 901       (goto-char (point-min))
 902       (while (search-forward " FETCH " end t)
 903         (setq elems (read (current-buffer)))
 904         (push (cons (cadr (memq 'UID elems))
 905                     (cadr (memq 'FLAGS elems)))
 906               articles)))
 907     (nreverse articles)))
 908
 909 (deffoo nnimap-close-group (group &optional server)
 910   t)
 911
 912 (deffoo nnimap-request-move-article (article group server accept-form
 913                                              &optional last internal-move-group)
 914   (setq group (nnimap-decode-gnus-group group))
 915   (when internal-move-group
 916     (setq internal-move-group (nnimap-decode-gnus-group internal-move-group)))
 917   (with-temp-buffer
 918     (mm-disable-multibyte)
 919     (when (funcall (if internal-move-group
 920                        'nnimap-request-head
 921                      'nnimap-request-article)
 922                    article group server (current-buffer))
 923       ;; If the move is internal (on the same server), just do it the easy
 924       ;; way.
 925       (let ((message-id (message-field-value "message-id")))
 926         (if internal-move-group
 927             (let ((result
 928                    (with-current-buffer (nnimap-buffer)
 929                      (nnimap-command "UID COPY %d %S"
 930                                      article
 931                                      (utf7-encode internal-move-group t)))))
 932               (when (car result)
 933                 (nnimap-delete-article article)
 934                 (cons internal-move-group
 935                       (or (nnimap-find-uid-response "COPYUID" (cadr result))
 936                           (nnimap-find-article-by-message-id
 937                            internal-move-group server message-id
 938                            nnimap-request-articles-find-limit)))))
 939           ;; Move the article to a different method.
 940           (let ((result (eval accept-form)))
 941             (when result
 942               (nnimap-change-group group server)
 943               (nnimap-delete-article article)
 944               result)))))))
 945
 946 (deffoo nnimap-request-expire-articles (articles group &optional server force)
 947   (setq group (nnimap-decode-gnus-group group))
 948   (cond
 949    ((null articles)
 950     nil)
 951    ((not (nnimap-change-group group server))
 952     articles)
 953    ((and force
 954          (eq nnmail-expiry-target 'delete))
 955     (unless (nnimap-delete-article (gnus-compress-sequence articles))
 956       (nnheader-message 7 "Article marked for deletion, but not expunged."))
 957     nil)
 958    (t
 959     (let ((deletable-articles
 960            (if (or force
 961                    (eq nnmail-expiry-wait 'immediate))
 962                articles
 963              (gnus-sorted-intersection
 964               articles
 965               (nnimap-find-expired-articles group)))))
 966       (if (null deletable-articles)
 967           articles
 968         (if (eq nnmail-expiry-target 'delete)
 969             (nnimap-delete-article (gnus-compress-sequence deletable-articles))
 970           (setq deletable-articles
 971                 (nnimap-process-expiry-targets
 972                  deletable-articles group server)))
 973         ;; Return the articles we didn't delete.
 974         (gnus-sorted-complement articles deletable-articles))))))
 975
 976 (defun nnimap-process-expiry-targets (articles group server)
 977   (let ((deleted-articles nil))
 978     (cond
 979      ;; shortcut further processing if we're going to delete the articles
 980      ((eq nnmail-expiry-target 'delete)
 981       (setq deleted-articles articles)
 982       t)
 983      ;; or just move them to another folder on the same IMAP server
 984      ((and (not (functionp nnmail-expiry-target))
 985            (gnus-server-equal (gnus-group-method nnmail-expiry-target)
 986                               (gnus-server-to-method
 987                                (format "nnimap:%s" server))))
 988       (and (nnimap-change-group group server)
 989            (with-current-buffer (nnimap-buffer)
 990              (nnheader-message 7 "Expiring articles from %s: %s" group articles)
 991              (nnimap-command
 992               "UID COPY %s %S"
 993               (nnimap-article-ranges (gnus-compress-sequence articles))
 994               (utf7-encode (gnus-group-real-name nnmail-expiry-target) t))
 995              (setq deleted-articles articles)))
 996       t)
 997      (t
 998       (dolist (article articles)
 999         (let ((target nnmail-expiry-target))
1000           (with-temp-buffer
1001             (mm-disable-multibyte)
1002             (when (nnimap-request-article article group server (current-buffer))
1003               (when (functionp target)
1004                 (setq target (funcall target group)))
1005               (if (and target
1006                        (not (eq target 'delete)))
1007                   (if (or (gnus-request-group target t)
1008                           (gnus-request-create-group target))
1009                       (progn
1010                         (nnmail-expiry-target-group target group)
1011                         (nnheader-message 7 "Expiring article %s:%d to %s"
1012                                           group article target))
1013                     (setq target nil))
1014                 (nnheader-message 7 "Expiring article %s:%d" group article))
1015               (when target
1016                 (push article deleted-articles))))))
1017       (setq deleted-articles (nreverse deleted-articles))))
1018     ;; Change back to the current group again.
1019     (nnimap-change-group group server)
1020     (nnimap-delete-article (gnus-compress-sequence deleted-articles))
1021     deleted-articles))
1022
1023 (defun nnimap-find-expired-articles (group)
1024   (let ((cutoff (nnmail-expired-article-p group nil nil)))
1025     (when cutoff
1026       (with-current-buffer (nnimap-buffer)
1027         (let ((result
1028                (nnimap-command
1029                 "UID SEARCH SENTBEFORE %s"
1030                 (format-time-string
1031                  (format "%%d-%s-%%Y"
1032                          (upcase
1033                           (car (rassoc (nth 4 (decode-time cutoff))
1034                                        parse-time-months))))
1035                  cutoff))))
1036           (and (car result)
1037                (delete 0 (mapcar #'string-to-number
1038                                  (cdr (assoc "SEARCH" (cdr result)))))))))))
1039
1040 (defun nnimap-find-article-by-message-id (group server message-id
1041                                                 &optional limit)
1042   "Search for message with MESSAGE-ID in GROUP from SERVER.
1043 If LIMIT, first try to limit the search to the N last articles."
1044   (with-current-buffer (nnimap-buffer)
1045     (erase-buffer)
1046     (let* ((change-group-result (nnimap-change-group group server nil t))
1047            (number-of-article
1048             (and (listp change-group-result)
1049                  (catch 'found
1050                    (dolist (result (cdr change-group-result))
1051                      (when (equal "EXISTS" (cadr result))
1052                        (throw 'found (car result)))))))
1053            (sequence
1054             (nnimap-send-command
1055              "UID SEARCH%s HEADER Message-Id %S"
1056              (if (and limit number-of-article)
1057                  ;; The -1 is because IMAP message
1058                  ;; numbers are one-based rather than
1059                  ;; zero-based.
1060                  (format " %s:*" (- (string-to-number number-of-article)
1061                                     limit -1))
1062                "")
1063              message-id)))
1064       (when (nnimap-wait-for-response sequence)
1065         (let ((article (car (last (cdr (assoc "SEARCH"
1066                                               (nnimap-parse-response)))))))
1067           (if article
1068               (string-to-number article)
1069             (when (and limit number-of-article)
1070               (nnimap-find-article-by-message-id group server message-id))))))))
1071
1072 (defun nnimap-delete-article (articles)
1073   (with-current-buffer (nnimap-buffer)
1074     (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
1075                     (nnimap-article-ranges articles))
1076     (cond
1077      ((nnimap-capability "UIDPLUS")
1078       (nnimap-command "UID EXPUNGE %s"
1079                       (nnimap-article-ranges articles))
1080       t)
1081      (nnimap-expunge
1082       (nnimap-command "EXPUNGE")
1083       t)
1084      (t (gnus-message 7 (concat "nnimap: nnimap-expunge is not set and the "
1085                                 "server doesn't support UIDPLUS, so we won't "
1086                                 "delete this article now"))))))
1087
1088 (deffoo nnimap-request-scan (&optional group server)
1089   (when group
1090     (setq group (nnimap-decode-gnus-group group)))
1091   (when (and (nnimap-change-group nil server)
1092              nnimap-inbox
1093              nnimap-split-methods)
1094     (nnheader-message 7 "nnimap %s splitting mail..." server)
1095     (if (listp nnimap-inbox)
1096        (dolist (nnimap-inbox nnimap-inbox)
1097          (nnimap-split-incoming-mail))
1098       (nnimap-split-incoming-mail))
1099     (nnheader-message 7 "nnimap %s splitting mail...done" server)))
1100
1101 (defun nnimap-marks-to-flags (marks)
1102   (let (flags flag)
1103     (dolist (mark marks)
1104       (when (setq flag (cadr (assq mark nnimap-mark-alist)))
1105         (push flag flags)))
1106     flags))
1107
1108 (deffoo nnimap-request-update-group-status (group status &optional server)
1109   (setq group (nnimap-decode-gnus-group group))
1110   (when (nnimap-change-group nil server)
1111     (let ((command (assoc
1112                     status
1113                     '((subscribe "SUBSCRIBE")
1114                       (unsubscribe "UNSUBSCRIBE")))))
1115       (when command
1116         (with-current-buffer (nnimap-buffer)
1117           (nnimap-command "%s %S" (cadr command) (utf7-encode group t)))))))
1118
1119 (deffoo nnimap-request-set-mark (group actions &optional server)
1120   (setq group (nnimap-decode-gnus-group group))
1121   (when (nnimap-change-group group server)
1122     (let (sequence)
1123       (with-current-buffer (nnimap-buffer)
1124         (erase-buffer)
1125         ;; Just send all the STORE commands without waiting for
1126         ;; response.  If they're successful, they're successful.
1127         (dolist (action actions)
1128           (destructuring-bind (range action marks) action
1129             (let ((flags (nnimap-marks-to-flags marks)))
1130               (when flags
1131                 (setq sequence (nnimap-send-command
1132                                 "UID STORE %s %sFLAGS.SILENT (%s)"
1133                                 (nnimap-article-ranges range)
1134                                 (cond
1135                                  ((eq action 'del) "-")
1136                                  ((eq action 'add) "+")
1137                                  ((eq action 'set) ""))
1138                                 (mapconcat #'identity flags " ")))))))
1139         ;; Wait for the last command to complete to avoid later
1140         ;; synchronization problems with the stream.
1141         (when sequence
1142           (nnimap-wait-for-response sequence))))))
1143
1144 (deffoo nnimap-request-accept-article (group &optional server last)
1145   (unless group
1146     ;; We're respooling.  Find out where mail splitting would place
1147     ;; this article.
1148     (setq group
1149           (caar
1150            (nnmail-article-group
1151             ;; We don't really care about the article number, because
1152             ;; that's determined by the IMAP server later.  So just
1153             ;; return the group name.
1154             `(lambda (group)
1155                (list (list group)))))))
1156   (setq group (nnimap-decode-gnus-group group))
1157   (when (nnimap-change-group nil server)
1158     (nnmail-check-syntax)
1159     (let ((message-id (message-field-value "message-id"))
1160           sequence message)
1161       (nnimap-add-cr)
1162       (setq message (buffer-substring-no-properties (point-min) (point-max)))
1163       (with-current-buffer (nnimap-buffer)
1164         (when (setq message (or (nnimap-process-quirk "OK Gimap " 'append message)
1165                                 message))
1166           ;; If we have this group open read-only, then unselect it
1167           ;; before appending to it.
1168           (when (equal (nnimap-examined nnimap-object) group)
1169             (nnimap-unselect-group))
1170           (erase-buffer)
1171           (setq sequence (nnimap-send-command
1172                           "APPEND %S {%d}" (utf7-encode group t)
1173                           (length message)))
1174           (unless nnimap-streaming
1175             (nnimap-wait-for-connection "^[+]"))
1176           (process-send-string (get-buffer-process (current-buffer)) message)
1177           (process-send-string (get-buffer-process (current-buffer))
1178                                (if (nnimap-newlinep nnimap-object)
1179                                    "\n"
1180                                  "\r\n"))
1181           (let ((result (nnimap-get-response sequence)))
1182             (if (not (nnimap-ok-p result))
1183                 (progn
1184                   (nnheader-report 'nnimap "%s" result)
1185                   nil)
1186               (cons group
1187                     (or (nnimap-find-uid-response "APPENDUID" (car result))
1188                         (nnimap-find-article-by-message-id
1189                          group server message-id
1190                          nnimap-request-articles-find-limit))))))))))
1191
1192 (defun nnimap-process-quirk (greeting-match type data)
1193   (when (and (nnimap-greeting nnimap-object)
1194              (string-match greeting-match (nnimap-greeting nnimap-object))
1195              (eq type 'append)
1196              (string-match "\000" data))
1197     (let ((choice (gnus-multiple-choice
1198                    "Message contains NUL characters.  Delete, continue, abort? "
1199                    '((?d "Delete NUL characters")
1200                      (?c "Try to APPEND the message as is")
1201                      (?a "Abort")))))
1202       (cond
1203        ((eq choice ?a)
1204         (nnheader-report 'nnimap "Aborted APPEND due to NUL characters"))
1205        ((eq choice ?c)
1206         data)
1207        (t
1208         (with-temp-buffer
1209           (insert data)
1210           (goto-char (point-min))
1211           (while (search-forward "\000" nil t)
1212             (replace-match "" t t))
1213           (buffer-string)))))))
1214
1215 (defun nnimap-ok-p (value)
1216   (and (consp value)
1217        (consp (car value))
1218        (equal (caar value) "OK")))
1219
1220 (defun nnimap-find-uid-response (name list)
1221   (let ((result (car (last (nnimap-find-response-element name list)))))
1222     (and result
1223          (string-to-number result))))
1224
1225 (defun nnimap-find-response-element (name list)
1226   (let (result)
1227     (dolist (elem list)
1228       (when (and (consp elem)
1229                  (equal name (car elem)))
1230         (setq result elem)))
1231     result))
1232
1233 (deffoo nnimap-request-replace-article (article group buffer)
1234   (setq group (nnimap-decode-gnus-group group))
1235   (let (group-art)
1236     (when (and (nnimap-change-group group)
1237                ;; Put the article into the group.
1238                (with-current-buffer buffer
1239                  (setq group-art
1240                        (nnimap-request-accept-article group nil t))))
1241       (nnimap-delete-article (list article))
1242       ;; Return the new article number.
1243       (cdr group-art))))
1244
1245 (defun nnimap-add-cr ()
1246   (goto-char (point-min))
1247   (while (re-search-forward "\r?\n" nil t)
1248     (replace-match "\r\n" t t)))
1249
1250 (defun nnimap-get-groups ()
1251   (erase-buffer)
1252   (let ((sequence (nnimap-send-command "LIST \"\" \"*\""))
1253         groups)
1254     (nnimap-wait-for-response sequence)
1255     (subst-char-in-region (point-min) (point-max)
1256                           ?\\ ?% t)
1257     (goto-char (point-min))
1258     (nnimap-unfold-quoted-lines)
1259     (goto-char (point-min))
1260     (while (search-forward "* LIST " nil t)
1261       (let ((flags (read (current-buffer)))
1262             (separator (read (current-buffer)))
1263             (group (read (current-buffer))))
1264         (unless (member '%NoSelect flags)
1265           (push (utf7-decode (if (stringp group)
1266                                  group
1267                                (format "%s" group)) t)
1268                 groups))))
1269     (nreverse groups)))
1270
1271 (defun nnimap-get-responses (sequences)
1272   (let (responses)
1273     (dolist (sequence sequences)
1274       (goto-char (point-min))
1275       (when (re-search-forward (format "^%d " sequence) nil t)
1276         (push (list sequence (nnimap-parse-response))
1277               responses)))
1278     responses))
1279
1280 (deffoo nnimap-request-list (&optional server)
1281   (when (nnimap-change-group nil server)
1282     (with-current-buffer nntp-server-buffer
1283       (erase-buffer)
1284       (let ((groups
1285              (with-current-buffer (nnimap-buffer)
1286                (nnimap-get-groups)))
1287             sequences responses)
1288         (when groups
1289           (with-current-buffer (nnimap-buffer)
1290             (setf (nnimap-group nnimap-object) nil)
1291             (dolist (group groups)
1292               (setf (nnimap-examined nnimap-object) group)
1293               (push (list (nnimap-send-command "EXAMINE %S"
1294                                                (utf7-encode group t))
1295                           group)
1296                     sequences))
1297             (nnimap-wait-for-response (caar sequences))
1298             (setq responses
1299                   (nnimap-get-responses (mapcar #'car sequences))))
1300           (dolist (response responses)
1301             (let* ((sequence (car response))
1302                    (response (cadr response))
1303                    (group (cadr (assoc sequence sequences)))
1304                    (egroup (encode-coding-string group 'utf-8)))
1305               (when (and group
1306                          (equal (caar response) "OK"))
1307                 (let ((uidnext (nnimap-find-parameter "UIDNEXT" response))
1308                       highest exists)
1309                   (dolist (elem response)
1310                     (when (equal (cadr elem) "EXISTS")
1311                       (setq exists (string-to-number (car elem)))))
1312                   (when uidnext
1313                     (setq highest (1- (string-to-number (car uidnext)))))
1314                   (cond
1315                    ((null highest)
1316                     (insert (format "%S 0 1 y\n" egroup)))
1317                    ((zerop exists)
1318                     ;; Empty group.
1319                     (insert (format "%S %d %d y\n" egroup
1320                                     highest (1+ highest))))
1321                    (t
1322                     ;; Return the widest possible range.
1323                     (insert (format "%S %d 1 y\n" egroup
1324                                     (or highest exists)))))))))
1325           t)))))
1326
1327 (deffoo nnimap-request-newgroups (date &optional server)
1328   (when (nnimap-change-group nil server)
1329     (with-current-buffer nntp-server-buffer
1330       (erase-buffer)
1331       (dolist (group (with-current-buffer (nnimap-buffer)
1332                        (nnimap-get-groups)))
1333         (unless (assoc group nnimap-current-infos)
1334           ;; Insert dummy numbers here -- they don't matter.
1335           (insert (format "%S 0 1 y\n" (encode-coding-string group 'utf-8)))))
1336       t)))
1337
1338 (deffoo nnimap-retrieve-group-data-early (server infos)
1339   (when (and (nnimap-change-group nil server)
1340              infos)
1341     (with-current-buffer (nnimap-buffer)
1342       (erase-buffer)
1343       (setf (nnimap-group nnimap-object) nil)
1344       (setf (nnimap-initial-resync nnimap-object) 0)
1345       (let ((qresyncp (nnimap-capability "QRESYNC"))
1346             params groups sequences active uidvalidity modseq group
1347             unexist)
1348         ;; Go through the infos and gather the data needed to know
1349         ;; what and how to request the data.
1350         (dolist (info infos)
1351           (setq params (gnus-info-params info)
1352                 group (nnimap-decode-gnus-group
1353                        (gnus-group-real-name (gnus-info-group info)))
1354                 active (cdr (assq 'active params))
1355                 unexist (assq 'unexist (gnus-info-marks info))
1356                 uidvalidity (cdr (assq 'uidvalidity params))
1357                 modseq (cdr (assq 'modseq params)))
1358           (setf (nnimap-examined nnimap-object) group)
1359           (if (and qresyncp
1360                    uidvalidity
1361                    active
1362                    modseq
1363                    unexist)
1364               (push
1365                (list (nnimap-send-command "EXAMINE %S (%s (%s %s))"
1366                                           (utf7-encode group t)
1367                                           (nnimap-quirk "QRESYNC")
1368                                           uidvalidity modseq)
1369                      'qresync
1370                      nil group 'qresync)
1371                sequences)
1372             (let ((command
1373                    (if uidvalidity
1374                        "EXAMINE"
1375                      ;; If we don't have a UIDVALIDITY, then this is
1376                      ;; the first time we've seen the group, so we
1377                      ;; have to do a SELECT (which is slower than an
1378                      ;; examine), but will tell us whether the group
1379                      ;; is read-only or not.
1380                      "SELECT"))
1381                   start)
1382               (if (and active uidvalidity unexist)
1383                   ;; Fetch the last 100 flags.
1384                   (setq start (max 1 (- (cdr active) 100)))
1385                 (incf (nnimap-initial-resync nnimap-object))
1386                 (setq start 1))
1387               (push (list (nnimap-send-command "%s %S" command
1388                                                (utf7-encode group t))
1389                           (nnimap-send-command "UID FETCH %d:* FLAGS" start)
1390                           start group command)
1391                     sequences))))
1392         sequences))))
1393
1394 (defun nnimap-quirk (command)
1395   (let ((quirk (assoc command nnimap-quirks)))
1396     ;; If this server is of a type that matches a quirk, then return
1397     ;; the "quirked" command instead of the proper one.
1398     (if (or (null quirk)
1399             (not (string-match (nth 1 quirk) (nnimap-greeting nnimap-object))))
1400         command
1401       (nth 2 quirk))))
1402
1403 (deffoo nnimap-finish-retrieve-group-infos (server infos sequences
1404                                                    &optional dont-insert)
1405   (when (and sequences
1406              (nnimap-change-group nil server t)
1407              ;; Check that the process is still alive.
1408              (get-buffer-process (nnimap-buffer))
1409              (memq (process-status (get-buffer-process (nnimap-buffer)))
1410                    '(open run)))
1411     (with-current-buffer (nnimap-buffer)
1412       ;; Wait for the final data to trickle in.
1413       (when (nnimap-wait-for-response (if (eq (cadar sequences) 'qresync)
1414                                           (caar sequences)
1415                                         (cadar sequences))
1416                                       t)
1417         ;; Now we should have most of the data we need, no matter
1418         ;; whether we're QRESYNCING, fetching all the flags from
1419         ;; scratch, or just fetching the last 100 flags per group.
1420         (nnimap-update-infos (nnimap-flags-to-marks
1421                               (nnimap-parse-flags
1422                                (nreverse sequences)))
1423                              infos)
1424         (unless dont-insert
1425           ;; Finally, just return something resembling an active file in
1426           ;; the nntp buffer, so that the agent can save the info, too.
1427           (with-current-buffer nntp-server-buffer
1428             (erase-buffer)
1429             (dolist (info infos)
1430               (let* ((group (gnus-info-group info))
1431                      (active (gnus-active group)))
1432                 (when active
1433                   (insert (format "%S %d %d y\n"
1434                                   (decode-coding-string
1435                                    (gnus-group-real-name group) 'utf-8)
1436                                   (cdr active)
1437                                   (car active))))))))))))
1438
1439 (defun nnimap-update-infos (flags infos)
1440   (dolist (info infos)
1441     (let* ((group (nnimap-decode-gnus-group
1442                    (gnus-group-real-name (gnus-info-group info))))
1443            (marks (cdr (assoc group flags))))
1444       (when marks
1445         (nnimap-update-info info marks)))))
1446
1447 (defun nnimap-update-info (info marks)
1448   (destructuring-bind (existing flags high low uidnext start-article
1449                                 permanent-flags uidvalidity
1450                                 vanished highestmodseq) marks
1451     (cond
1452      ;; Ignore groups with no UIDNEXT/marks.  This happens for
1453      ;; completely empty groups.
1454      ((and (not existing)
1455            (not uidnext))
1456       (let ((active (cdr (assq 'active (gnus-info-params info)))))
1457         (when active
1458           (gnus-set-active (gnus-info-group info) active))))
1459      ;; We have a mismatch between the old and new UIDVALIDITY
1460      ;; identifiers, so we have to re-request the group info (the next
1461      ;; time).  This virtually never happens.
1462      ((let ((old-uidvalidity
1463              (cdr (assq 'uidvalidity (gnus-info-params info)))))
1464         (and old-uidvalidity
1465              (not (equal old-uidvalidity uidvalidity))
1466              (or (not start-article)
1467                  (> start-article 1))))
1468       (gnus-group-remove-parameter info 'uidvalidity)
1469       (gnus-group-remove-parameter info 'modseq))
1470      ;; We have the data needed to update.
1471      (t
1472       (let* ((group (gnus-info-group info))
1473              (completep (and start-article
1474                              (= start-article 1)))
1475              (active (or (gnus-active group)
1476                          (cdr (assq 'active (gnus-info-params info))))))
1477         (when uidnext
1478           (setq high (1- uidnext)))
1479         ;; First set the active ranges based on high/low.
1480         (if (or completep
1481                 (not (gnus-active group)))
1482             (gnus-set-active group
1483                              (cond
1484                               (active
1485                                (cons (min (or low (car active))
1486                                           (car active))
1487                                      (max (or high (cdr active))
1488                                           (cdr active))))
1489                               ((and low high)
1490                                (cons low high))
1491                               (uidnext
1492                                ;; No articles in this group.
1493                                (cons uidnext (1- uidnext)))
1494                               (start-article
1495                                (cons start-article (1- start-article)))
1496                               (t
1497                                ;; No articles and no uidnext.
1498                                nil)))
1499           (gnus-set-active group
1500                            (cons (car active)
1501                                  (or high (1- uidnext)))))
1502         ;; See whether this is a read-only group.
1503         (unless (eq permanent-flags 'not-scanned)
1504           (gnus-group-set-parameter
1505            info 'permanent-flags
1506            (and (or (memq '%* permanent-flags)
1507                     (memq '%Seen permanent-flags))
1508                 permanent-flags)))
1509         ;; Update marks and read articles if this isn't a
1510         ;; read-only IMAP group.
1511         (when (setq permanent-flags
1512                     (cdr (assq 'permanent-flags (gnus-info-params info))))
1513           (if (and highestmodseq
1514                    (not start-article))
1515               ;; We've gotten the data by QRESYNCing.
1516               (nnimap-update-qresync-info
1517                info existing (nnimap-imap-ranges-to-gnus-ranges vanished) flags)
1518             ;; Do normal non-QRESYNC flag updates.
1519             ;; Update the list of read articles.
1520             (let* ((unread
1521                     (gnus-compress-sequence
1522                      (gnus-set-difference
1523                       (gnus-set-difference
1524                        existing
1525                        (gnus-sorted-union
1526                         (cdr (assoc '%Seen flags))
1527                         (cdr (assoc '%Deleted flags))))
1528                       (cdr (assoc '%Flagged flags)))))
1529                    (read (gnus-range-difference
1530                           (cons start-article high) unread)))
1531               (when (> start-article 1)
1532                 (setq read
1533                       (gnus-range-nconcat
1534                        (if (> start-article 1)
1535                            (gnus-sorted-range-intersection
1536                             (cons 1 (1- start-article))
1537                             (gnus-info-read info))
1538                          (gnus-info-read info))
1539                        read)))
1540               (when (or (not (listp permanent-flags))
1541                         (memq '%Seen permanent-flags))
1542                 (gnus-info-set-read info read))
1543               ;; Update the marks.
1544               (setq marks (gnus-info-marks info))
1545               (dolist (type (cdr nnimap-mark-alist))
1546                 (when (or (not (listp permanent-flags))
1547                           (memq (car (assoc (caddr type) flags))
1548                                 permanent-flags)
1549                           (memq '%* permanent-flags))
1550                   (let ((old-marks (assoc (car type) marks))
1551                         (new-marks
1552                          (gnus-compress-sequence
1553                           (cdr (or (assoc (caddr type) flags) ; %Flagged
1554                                    (assoc (intern (cadr type) obarray) flags)
1555                                    (assoc (cadr type) flags)))))) ; "\Flagged"
1556                     (setq marks (delq old-marks marks))
1557                     (pop old-marks)
1558                     (when (and old-marks
1559                                (> start-article 1))
1560                       (setq old-marks (gnus-range-difference
1561                                        old-marks
1562                                        (cons start-article high)))
1563                       (setq new-marks (gnus-range-nconcat old-marks new-marks)))
1564                     (when new-marks
1565                       (push (cons (car type) new-marks) marks)))))
1566               ;; Keep track of non-existing articles.
1567               (let* ((old-unexists (assq 'unexist marks))
1568                      (active (gnus-active group))
1569                      (unexists
1570                       (if completep
1571                           (gnus-range-difference
1572                            active
1573                            (gnus-compress-sequence existing))
1574                         (gnus-add-to-range
1575                          (cdr old-unexists)
1576                          (gnus-list-range-difference
1577                           existing (gnus-active group))))))
1578                 (when (> (car active) 1)
1579                   (setq unexists (gnus-range-add
1580                                   (cons 1 (1- (car active)))
1581                                   unexists)))
1582                 (if old-unexists
1583                     (setcdr old-unexists unexists)
1584                   (push (cons 'unexist unexists) marks)))
1585               (gnus-info-set-marks info marks t))))
1586         ;; Tell Gnus whether there are any \Recent messages in any of
1587         ;; the groups.
1588         (let ((recent (cdr (assoc '%Recent flags))))
1589           (when (and active
1590                      recent
1591                      (> (car (last recent)) (cdr active)))
1592             (push (list (cons (gnus-group-real-name group) 0))
1593                   nnmail-split-history)))
1594         ;; Note the active level for the next run-through.
1595         (gnus-group-set-parameter info 'active (gnus-active group))
1596         (gnus-group-set-parameter info 'uidvalidity uidvalidity)
1597         (gnus-group-set-parameter info 'modseq highestmodseq)
1598         (nnimap-store-info info (gnus-active group)))))))
1599
1600 (defun nnimap-update-qresync-info (info existing vanished flags)
1601   ;; Add all the vanished articles to the list of read articles.
1602   (gnus-info-set-read
1603    info
1604    (gnus-add-to-range
1605     (gnus-add-to-range
1606      (gnus-range-add (gnus-info-read info)
1607                      vanished)
1608      (cdr (assq '%Flagged flags)))
1609     (cdr (assq '%Seen flags))))
1610   (let ((marks (gnus-info-marks info)))
1611     (dolist (type (cdr nnimap-mark-alist))
1612       (let ((ticks (assoc (car type) marks))
1613             (new-marks
1614              (cdr (or (assoc (caddr type) flags) ; %Flagged
1615                       (assoc (intern (cadr type) obarray) flags)
1616                       (assoc (cadr type) flags))))) ; "\Flagged"
1617         (setq marks (delq ticks marks))
1618         (pop ticks)
1619         ;; Add the new marks we got.
1620         (setq ticks (gnus-add-to-range ticks new-marks))
1621         ;; Remove the marks from messages that don't have them.
1622         (setq ticks (gnus-remove-from-range
1623                      ticks
1624                      (gnus-compress-sequence
1625                       (gnus-sorted-complement existing new-marks))))
1626         (when ticks
1627           (push (cons (car type) ticks) marks)))
1628       (gnus-info-set-marks info marks t))
1629     ;; Add vanished to the list of unexisting articles.
1630     (when vanished
1631       (let* ((old-unexists (assq 'unexist marks))
1632              (unexists (gnus-range-add (cdr old-unexists) vanished)))
1633         (if old-unexists
1634             (setcdr old-unexists unexists)
1635           (push (cons 'unexist unexists) marks)))
1636       (gnus-info-set-marks info marks t))))
1637
1638 (defun nnimap-imap-ranges-to-gnus-ranges (irange)
1639   (if (zerop (length irange))
1640       nil
1641     (let ((result nil))
1642       (dolist (elem (split-string irange ","))
1643         (push
1644          (if (string-match ":" elem)
1645              (let ((numbers (split-string elem ":")))
1646                (cons (string-to-number (car numbers))
1647                      (string-to-number (cadr numbers))))
1648            (string-to-number elem))
1649          result))
1650       (nreverse result))))
1651
1652 (defun nnimap-store-info (info active)
1653   (let* ((group (gnus-group-real-name (gnus-info-group info)))
1654          (entry (assoc group nnimap-current-infos)))
1655     (if entry
1656         (setcdr entry (list info active))
1657       (push (list group info active) nnimap-current-infos))))
1658
1659 (defun nnimap-flags-to-marks (groups)
1660   (let (data group totalp uidnext articles start-article mark permanent-flags
1661              uidvalidity vanished highestmodseq)
1662     (dolist (elem groups)
1663       (setq group (car elem)
1664             uidnext (nth 1 elem)
1665             start-article (nth 2 elem)
1666             permanent-flags (nth 3 elem)
1667             uidvalidity (nth 4 elem)
1668             vanished (nth 5 elem)
1669             highestmodseq (nth 6 elem)
1670             articles (nthcdr 7 elem))
1671       (let ((high (caar articles))
1672             marks low existing)
1673         (dolist (article articles)
1674           (setq low (car article))
1675           (push (car article) existing)
1676           (dolist (flag (cdr article))
1677             (setq mark (assoc flag marks))
1678             (if (not mark)
1679                 (push (list flag (car article)) marks)
1680               (setcdr mark (cons (car article) (cdr mark))))))
1681         (push (list group existing marks high low uidnext start-article
1682                     permanent-flags uidvalidity vanished highestmodseq)
1683               data)))
1684     data))
1685
1686 (defun nnimap-parse-flags (sequences)
1687   (goto-char (point-min))
1688   ;; Change \Delete etc to %Delete, so that the Emacs Lisp reader can
1689   ;; read it.
1690   (subst-char-in-region (point-min) (point-max)
1691                         ?\\ ?% t)
1692   ;; Remove any MODSEQ entries in the buffer, because they may contain
1693   ;; numbers that are too large for 32-bit Emacsen.
1694   (while (re-search-forward " MODSEQ ([0-9]+)" nil t)
1695     (replace-match "" t t))
1696   (goto-char (point-min))
1697   (let (start end articles groups uidnext elems permanent-flags
1698               uidvalidity vanished highestmodseq)
1699     (dolist (elem sequences)
1700       (destructuring-bind (group-sequence flag-sequence totalp group command)
1701           elem
1702         (setq start (point))
1703         (when (and
1704                ;; The EXAMINE was successful.
1705                (search-forward (format "\n%d OK " group-sequence) nil t)
1706                (progn
1707                  (forward-line 1)
1708                  (setq end (point))
1709                  (goto-char start)
1710                  (setq permanent-flags
1711                        (if (equal command "SELECT")
1712                            (and (search-forward "PERMANENTFLAGS "
1713                                                 (or end (point-min)) t)
1714                                 (read (current-buffer)))
1715                          'not-scanned))
1716                  (goto-char start)
1717                  (setq uidnext
1718                        (and (search-forward "UIDNEXT "
1719                                             (or end (point-min)) t)
1720                             (read (current-buffer))))
1721                  (goto-char start)
1722                  (setq uidvalidity
1723                        (and (re-search-forward "UIDVALIDITY \\([0-9]+\\)"
1724                                                (or end (point-min)) t)
1725                             ;; Store UIDVALIDITY as a string, as it's
1726                             ;; too big for 32-bit Emacsen, usually.
1727                             (match-string 1)))
1728                  (goto-char start)
1729                  (setq vanished
1730                        (and (eq flag-sequence 'qresync)
1731                             (re-search-forward "^\\* VANISHED .*? \\([0-9:,]+\\)"
1732                                                (or end (point-min)) t)
1733                             (match-string 1)))
1734                  (goto-char start)
1735                  (setq highestmodseq
1736                        (and (re-search-forward "HIGHESTMODSEQ \\([0-9]+\\)"
1737                                             (or end (point-min)) t)
1738                             (match-string 1)))
1739                  (goto-char end)
1740                  (forward-line -1))
1741                ;; The UID FETCH FLAGS was successful.
1742                (or (eq flag-sequence 'qresync)
1743                    (search-forward (format "\n%d OK " flag-sequence) nil t)))
1744           (if (eq flag-sequence 'qresync)
1745               (progn
1746                 (goto-char start)
1747                 (setq start end))
1748             (setq start (point))
1749             (goto-char end))
1750           (while (re-search-forward "^\\* [0-9]+ FETCH " start t)
1751             (let ((p (point)))
1752               (setq elems (read (current-buffer)))
1753               (push (cons (cadr (memq 'UID elems))
1754                           (cadr (memq 'FLAGS elems)))
1755                     articles)))
1756           (push (nconc (list group uidnext totalp permanent-flags uidvalidity
1757                              vanished highestmodseq)
1758                        articles)
1759                 groups)
1760           (if (eq flag-sequence 'qresync)
1761               (goto-char end)
1762             (setq end (point)))
1763           (setq articles nil))))
1764     groups))
1765
1766 (defun nnimap-find-process-buffer (buffer)
1767   (cadr (assoc buffer nnimap-connection-alist)))
1768
1769 (deffoo nnimap-request-post (&optional server)
1770   (setq nnimap-status-string "Read-only server")
1771   nil)
1772
1773 (defvar gnus-refer-thread-use-nnir) ;; gnus-sum.el
1774 (declare-function gnus-fetch-headers "gnus-sum"
1775                   (articles &optional limit force-new dependencies))
1776
1777 (autoload 'nnir-search-thread "nnir")
1778
1779 (deffoo nnimap-request-thread (header &optional group server)
1780   (when group
1781     (setq group (nnimap-decode-gnus-group group)))
1782   (if gnus-refer-thread-use-nnir
1783       (nnir-search-thread header)
1784     (when (nnimap-change-group group server)
1785       (let* ((cmd (nnimap-make-thread-query header))
1786              (result (with-current-buffer (nnimap-buffer)
1787                        (nnimap-command  "UID SEARCH %s" cmd))))
1788         (when result
1789           (gnus-fetch-headers
1790            (and (car result)
1791                 (delete 0 (mapcar #'string-to-number
1792                                   (cdr (assoc "SEARCH" (cdr result))))))
1793            nil t))))))
1794
1795 (defun nnimap-change-group (group &optional server no-reconnect read-only)
1796   "Change group to GROUP if non-nil.
1797 If SERVER is set, check that server is connected, otherwise retry
1798 to reconnect, unless NO-RECONNECT is set to t.  Return nil if
1799 unsuccessful in connecting.
1800 If GROUP is nil, return t.
1801 If READ-ONLY is set, send EXAMINE rather than SELECT to the server.
1802 Return the server's response to the SELECT or EXAMINE command."
1803   (let ((open-result t))
1804     (when (and server
1805                (not (nnimap-server-opened server)))
1806       (setq open-result (nnimap-open-server server nil no-reconnect)))
1807     (cond
1808      ((not open-result)
1809       nil)
1810      ((not group)
1811       t)
1812      (t
1813       (with-current-buffer (nnimap-buffer)
1814         (let ((result (nnimap-command "%s %S"
1815                                       (if read-only
1816                                           "EXAMINE"
1817                                         "SELECT")
1818                                       (utf7-encode group t))))
1819           (when (car result)
1820             (setf (nnimap-group nnimap-object) group
1821                   (nnimap-select-result nnimap-object) result)
1822             result)))))))
1823
1824 (defun nnimap-find-connection (buffer)
1825   "Find the connection delivering to BUFFER."
1826   (let ((entry (assoc buffer nnimap-connection-alist)))
1827     (when entry
1828       (if (and (buffer-name (cadr entry))
1829                (get-buffer-process (cadr entry))
1830                (memq (process-status (get-buffer-process (cadr entry)))
1831                      '(open run)))
1832           (get-buffer-process (cadr entry))
1833         (setq nnimap-connection-alist (delq entry nnimap-connection-alist))
1834         nil))))
1835
1836 (defvar nnimap-sequence 0)
1837
1838 (defun nnimap-send-command (&rest args)
1839   (setf (nnimap-last-command-time nnimap-object) (current-time))
1840   (process-send-string
1841    (get-buffer-process (current-buffer))
1842    (nnimap-log-command
1843     (format "%d %s%s\n"
1844             (incf nnimap-sequence)
1845             (apply #'format args)
1846             (if (nnimap-newlinep nnimap-object)
1847                 ""
1848               "\r"))))
1849   ;; Some servers apparently can't have many outstanding
1850   ;; commands, so throttle them.
1851   (unless nnimap-streaming
1852     (nnimap-wait-for-response nnimap-sequence))
1853   nnimap-sequence)
1854
1855 (defvar nnimap-record-commands nil
1856   "If non-nil, log commands to the \"*imap log*\" buffer.")
1857
1858 (defun nnimap-log-buffer ()
1859   (let ((name "*imap log*"))
1860     (or (get-buffer name)
1861         (with-current-buffer (get-buffer-create name)
1862           (when (boundp 'window-point-insertion-type)
1863             (make-local-variable 'window-point-insertion-type)
1864             (setq window-point-insertion-type t))
1865           (current-buffer)))))
1866
1867 (defun nnimap-log-command (command)
1868   (when nnimap-record-commands
1869     (with-current-buffer (nnimap-log-buffer)
1870       (goto-char (point-max))
1871       (insert (format-time-string "%H:%M:%S")
1872               " [" nnimap-address "] "
1873               (if nnimap-inhibit-logging
1874                   "(inhibited)\n"
1875                 command))))
1876   command)
1877
1878 (defun nnimap-command (&rest args)
1879   (erase-buffer)
1880   (let* ((sequence (apply #'nnimap-send-command args))
1881          (response (nnimap-get-response sequence)))
1882     (if (equal (caar response) "OK")
1883         (cons t response)
1884       (nnheader-report 'nnimap "%s"
1885                        (mapconcat (lambda (a)
1886                                     (format "%s" a))
1887                                   (car response) " "))
1888       nil)))
1889
1890 (defun nnimap-get-response (sequence)
1891   (nnimap-wait-for-response sequence)
1892   (nnimap-parse-response))
1893
1894 (defun nnimap-wait-for-connection (&optional regexp)
1895   (nnimap-wait-for-line (or regexp "^[*.] .*\n") "[*.] \\([A-Z0-9]+\\)"))
1896
1897 (defun nnimap-wait-for-line (regexp &optional response-regexp)
1898   (let ((process (get-buffer-process (current-buffer))))
1899     (goto-char (point-min))
1900     (while (and (memq (process-status process)
1901                       '(open run))
1902                 (not (re-search-forward regexp nil t)))
1903       (nnheader-accept-process-output process)
1904       (goto-char (point-min)))
1905     (forward-line -1)
1906     (and (looking-at (or response-regexp regexp))
1907          (match-string 1))))
1908
1909 (defun nnimap-wait-for-response (sequence &optional messagep)
1910   (let ((process (get-buffer-process (current-buffer)))
1911         openp)
1912     (condition-case nil
1913         (progn
1914           (goto-char (point-max))
1915           (while (and (setq openp (memq (process-status process)
1916                                         '(open run)))
1917                       (progn
1918                         ;; Skip past any "*" lines that the server has
1919                         ;; output.
1920                         (while (and (not (bobp))
1921                                     (progn
1922                                       (forward-line -1)
1923                                       (looking-at "\\*\\|[0-9]+ OK NOOP"))))
1924                         (not (looking-at (format "%d .*\n" sequence)))))
1925             (when messagep
1926               (nnheader-message-maybe
1927                7 "nnimap read %dk from %s%s" (/ (buffer-size) 1000)
1928                nnimap-address
1929                (if (not (zerop (nnimap-initial-resync nnimap-object)))
1930                    (format " (initial sync of %d group%s; please wait)"
1931                            (nnimap-initial-resync nnimap-object)
1932                            (if (= (nnimap-initial-resync nnimap-object) 1)
1933                                ""
1934                              "s"))
1935                  "")))
1936             (nnheader-accept-process-output process)
1937             (goto-char (point-max)))
1938           (setf (nnimap-initial-resync nnimap-object) 0)
1939           openp)
1940       (quit
1941        (when debug-on-quit
1942          (debug "Quit"))
1943        ;; The user hit C-g while we were waiting: kill the process, in case
1944        ;; it's a gnutls-cli process that's stuck (tends to happen a lot behind
1945        ;; NAT routers).
1946        (delete-process process)
1947        nil))))
1948
1949 (defun nnimap-parse-response ()
1950   (let ((lines (split-string (nnimap-last-response-string) "\r\n" t))
1951         result)
1952     (dolist (line lines)
1953       (push (cdr (nnimap-parse-line line)) result))
1954     ;; Return the OK/error code first, and then all the "continuation
1955     ;; lines" afterwards.
1956     (cons (pop result)
1957           (nreverse result))))
1958
1959 ;; Parse an IMAP response line lightly.  They look like
1960 ;; "* OK [UIDVALIDITY 1164213559] UIDs valid", typically, so parse
1961 ;; the lines into a list of strings and lists of string.
1962 (defun nnimap-parse-line (line)
1963   (let (char result)
1964     (with-temp-buffer
1965       (mm-disable-multibyte)
1966       (insert line)
1967       (goto-char (point-min))
1968       (while (not (eobp))
1969         (if (eql (setq char (following-char)) ? )
1970             (forward-char 1)
1971           (push
1972            (cond
1973             ((eql char ?\[)
1974              (split-string
1975               (buffer-substring
1976                (1+ (point))
1977                (if (search-forward "]" (line-end-position) 'move)
1978                    (1- (point))
1979                  (point)))))
1980             ((eql char ?\()
1981              (split-string
1982               (buffer-substring
1983                (1+ (point))
1984                (if (search-forward ")" (line-end-position) 'move)
1985                    (1- (point))
1986                  (point)))))
1987             ((eql char ?\")
1988              (forward-char 1)
1989              (buffer-substring
1990               (point)
1991               (1- (or (search-forward "\"" (line-end-position) 'move)
1992                       (point)))))
1993             (t
1994              (buffer-substring (point) (if (search-forward " " nil t)
1995                                            (1- (point))
1996                                          (goto-char (point-max))))))
1997            result)))
1998       (nreverse result))))
1999
2000 (defun nnimap-last-response-string ()
2001   (save-excursion
2002     (forward-line 1)
2003     (let ((end (point)))
2004       (forward-line -1)
2005       (when (not (bobp))
2006         (forward-line -1)
2007         (while (and (not (bobp))
2008                     (eql (following-char) ?*))
2009           (forward-line -1))
2010         (unless (eql (following-char) ?*)
2011           (forward-line 1)))
2012       (buffer-substring (point) end))))
2013
2014 (defvar nnimap-incoming-split-list nil)
2015
2016 (defun nnimap-fetch-inbox (articles)
2017   (erase-buffer)
2018   (nnimap-wait-for-response
2019    (nnimap-send-command
2020     "UID FETCH %s %s"
2021     (nnimap-article-ranges articles)
2022     (format "(UID %s%s)"
2023             (format
2024              (if (nnimap-ver4-p)
2025                  "BODY.PEEK"
2026                "RFC822.PEEK"))
2027             (cond
2028              (nnimap-split-download-body-default
2029               "[]")
2030              ((nnimap-ver4-p)
2031               "[HEADER]")
2032              (t
2033               "[1]"))))
2034    t))
2035
2036 (defun nnimap-split-incoming-mail ()
2037   (with-current-buffer (nnimap-buffer)
2038     (let ((nnimap-incoming-split-list nil)
2039           (nnmail-split-methods
2040            (cond
2041             ((eq nnimap-split-methods 'default)
2042              nnmail-split-methods)
2043             (nnimap-split-methods
2044              nnimap-split-methods)
2045             (nnimap-split-fancy
2046              'nnmail-split-fancy)))
2047           (nnmail-split-fancy (or nnimap-split-fancy
2048                                   nnmail-split-fancy))
2049           (nnmail-inhibit-default-split-group t)
2050           (groups (nnimap-get-groups))
2051           new-articles)
2052       (erase-buffer)
2053       (nnimap-command "SELECT %S" nnimap-inbox)
2054       (setf (nnimap-group nnimap-object) nnimap-inbox)
2055       (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*")))
2056       (when new-articles
2057         (nnimap-fetch-inbox new-articles)
2058         (nnimap-transform-split-mail)
2059         (nnheader-ms-strip-cr)
2060         (nnmail-cache-open)
2061         (nnmail-split-incoming (current-buffer)
2062                                #'nnimap-save-mail-spec
2063                                nil nil
2064                                #'nnimap-dummy-active-number
2065                                #'nnimap-save-mail-spec)
2066         (when nnimap-incoming-split-list
2067           (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list))
2068                 sequences junk-articles)
2069             ;; Create any groups that doesn't already exist on the
2070             ;; server first.
2071             (dolist (spec specs)
2072               (when (and (not (member (car spec) groups))
2073                          (not (eq (car spec) 'junk)))
2074                 (nnimap-command "CREATE %S" (utf7-encode (car spec) t))))
2075             ;; Then copy over all the messages.
2076             (erase-buffer)
2077             (dolist (spec specs)
2078               (let ((group (car spec))
2079                     (ranges (cdr spec)))
2080                 (if (eq group 'junk)
2081                     (setq junk-articles ranges)
2082                   (push (list (nnimap-send-command
2083                                "UID COPY %s %S"
2084                                (nnimap-article-ranges ranges)
2085                                (utf7-encode group t))
2086                               ranges)
2087                         sequences))))
2088             ;; Wait for the last COPY response...
2089             (when sequences
2090               (nnimap-wait-for-response (caar sequences))
2091               ;; And then mark the successful copy actions as deleted,
2092               ;; and possibly expunge them.
2093               (nnimap-mark-and-expunge-incoming
2094                (nnimap-parse-copied-articles sequences)))
2095             (nnimap-mark-and-expunge-incoming junk-articles)))))))
2096
2097 (defun nnimap-mark-and-expunge-incoming (range)
2098   (when range
2099     (setq range (nnimap-article-ranges range))
2100     (erase-buffer)
2101     (let ((sequence
2102            (nnimap-send-command
2103             "UID STORE %s +FLAGS.SILENT (\\Deleted)" range)))
2104       (cond
2105        ;; If the server supports it, we now delete the message we have
2106        ;; just copied over.
2107        ((nnimap-capability "UIDPLUS")
2108         (setq sequence (nnimap-send-command "UID EXPUNGE %s" range)))
2109        ;; If it doesn't support UID EXPUNGE, then we only expunge if the
2110        ;; user has configured it.
2111        (nnimap-expunge
2112         (setq sequence (nnimap-send-command "EXPUNGE"))))
2113       (nnimap-wait-for-response sequence))))
2114
2115 (defun nnimap-parse-copied-articles (sequences)
2116   (let (sequence copied range)
2117     (goto-char (point-min))
2118     (while (re-search-forward "^\\([0-9]+\\) OK\\b" nil t)
2119       (setq sequence (string-to-number (match-string 1)))
2120       (when (setq range (cadr (assq sequence sequences)))
2121         (push (gnus-uncompress-range range) copied)))
2122     (gnus-compress-sequence (sort (apply #'nconc copied) #'<))))
2123
2124 (defun nnimap-new-articles (flags)
2125   (let (new)
2126     (dolist (elem flags)
2127       (unless (gnus-list-memq-of-list nnimap-unsplittable-articles
2128                                       (cdr elem))
2129         (push (car elem) new)))
2130     (gnus-compress-sequence (nreverse new))))
2131
2132 (defun nnimap-make-split-specs (list)
2133   (let ((specs nil)
2134         entry)
2135     (dolist (elem list)
2136       (destructuring-bind (article spec) elem
2137         (dolist (group (delete nil (mapcar #'car spec)))
2138           (unless (setq entry (assoc group specs))
2139             (push (setq entry (list group)) specs))
2140           (setcdr entry (cons article (cdr entry))))))
2141     (dolist (entry specs)
2142       (setcdr entry (gnus-compress-sequence (sort (cdr entry) #'<))))
2143     specs))
2144
2145 (defun nnimap-transform-split-mail ()
2146   (goto-char (point-min))
2147   (let (article bytes)
2148     (block nil
2149       (while (not (eobp))
2150         (while (not (looking-at "\\* [0-9]+ FETCH.+UID \\([0-9]+\\)"))
2151           (delete-region (point) (progn (forward-line 1) (point)))
2152           (when (eobp)
2153             (return)))
2154         (setq article (match-string 1)
2155               bytes (nnimap-get-length))
2156         (delete-region (line-beginning-position) (line-end-position))
2157         ;; Insert MMDF separator, and a way to remember what this
2158         ;; article UID is.
2159         (insert (format "\^A\^A\^A\^A\n\nX-nnimap-article: %s" article))
2160         (forward-char (1+ bytes))
2161         (setq bytes (nnimap-get-length))
2162         (delete-region (line-beginning-position) (line-end-position))
2163         ;; There's a body; skip past that.
2164         (when bytes
2165           (forward-char (1+ bytes))
2166           (delete-region (line-beginning-position) (line-end-position)))))))
2167
2168 (defun nnimap-dummy-active-number (group &optional server)
2169   1)
2170
2171 (defun nnimap-save-mail-spec (group-art &optional server full-nov)
2172   (let (article)
2173     (goto-char (point-min))
2174     (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t))
2175         (error "Invalid nnimap mail")
2176       (setq article (string-to-number (match-string 1))))
2177     (push (list article
2178                 (if (eq group-art 'junk)
2179                     (list (cons 'junk 1))
2180                   group-art))
2181           nnimap-incoming-split-list)))
2182
2183 (defun nnimap-make-thread-query (header)
2184   (let* ((id  (mail-header-id header))
2185          (refs (split-string
2186                 (or (mail-header-references header)
2187                     "")))
2188          (value
2189           (format
2190            "(OR HEADER REFERENCES %S HEADER Message-Id %S)"
2191            id id)))
2192     (dolist (refid refs value)
2193       (setq value (format
2194                    "(OR (OR HEADER Message-Id %S HEADER REFERENCES %S) %s)"
2195                    refid refid value)))))
2196
2197
2198 (provide 'nnimap)
2199
2200 ;;; nnimap.el ends here