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

   1 ;;; nnimap.el --- IMAP interface for Gnus
   2
   3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;         Simon Josefsson <simon@josefsson.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; nnimap interfaces Gnus with IMAP servers.
  26
  27 ;;; Code:
  28
  29 (eval-and-compile
  30   (require 'nnheader))
  31
  32 (nnoo-declare nnimap)
  33
  34 (defvoo nnimap-address nil
  35   "The address of the IMAP server.")
  36
  37 (defvoo nnimap-server-port nil
  38   "The IMAP port used.
  39 If nnimap-stream is `ssl', this will default to `imaps'.  If not,
  40 it will default to `imap'.")
  41
  42 (defvoo nnimap-stream 'ssl
  43   "How nnimap will talk to the IMAP server.
  44 Values are `ssl' and `network'.")
  45
  46 (defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
  47                                  (if (listp imap-shell-program)
  48                                      (car imap-shell-program)
  49                                    imap-shell-program)
  50                                "ssh %s imapd"))
  51
  52 (defvoo nnimap-inbox nil
  53   "The mail box where incoming mail arrives and should be split out of.")
  54
  55 (defvoo nnimap-expunge-inbox nil
  56   "If non-nil, expunge the inbox after fetching mail.
  57 This is always done if the server supports UID EXPUNGE, but it's
  58 not done by default on servers that doesn't support that command.")
  59
  60 (defvoo nnimap-connection-alist nil)
  61 (defvar nnimap-process nil)
  62
  63 (defvar nnimap-status-string "")
  64
  65 (defvar nnimap-split-download-body-default nil
  66   "Internal variable with default value for `nnimap-split-download-body'.")
  67
  68 (defstruct nnimap
  69   group process commands capabilities)
  70
  71 (defvar nnimap-object nil)
  72
  73 (defvar nnimap-mark-alist
  74   '((read "\\Seen")
  75     (tick "\\Flagged")
  76     (reply "\\Answered")
  77     (expire "gnus-expire")
  78     (dormant "gnus-dormant")
  79     (score "gnus-score")
  80     (save "gnus-save")
  81     (download "gnus-download")
  82     (forward "gnus-forward")))
  83
  84 (defvar nnimap-split-methods nil)
  85
  86 (defun nnimap-buffer ()
  87   (nnimap-find-process-buffer nntp-server-buffer))
  88
  89 (defmacro nnimap-with-process-buffer (&rest body)
  90   `(with-current-buffer (nnimap-find-process-buffer (current-buffer))
  91      ,@body))
  92
  93 (defun nnimap-retrieve-headers (articles &optional group server fetch-old)
  94   (with-current-buffer nntp-server-buffer
  95     (erase-buffer)
  96     (when (nnimap-possibly-change-group group server)
  97       (with-current-buffer (nnimap-buffer)
  98         (nnimap-send-command "SELECT %S" (utf7-encode group t))
  99         (erase-buffer)
 100         (nnimap-wait-for-response
 101          (nnimap-send-command
 102           "UID FETCH %s %s"
 103           (nnimap-article-ranges (gnus-compress-sequence articles))
 104           (format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
 105                   (format
 106                    (if (member "IMAP4rev1"
 107                                (nnimap-capabilities nnimap-object))
 108                        "BODY.PEEK[HEADER.FIELDS %s]"
 109                      "RFC822.HEADER.LINES %s")
 110                    (append '(Subject From Date Message-Id
 111                                      References In-Reply-To Xref)
 112                            nnmail-extra-headers))))
 113          t)
 114         (nnimap-transform-headers))
 115       (insert-buffer-substring
 116        (nnimap-find-process-buffer (current-buffer))))
 117     t))
 118
 119 (defun nnimap-transform-headers ()
 120   (goto-char (point-min))
 121   (let (article bytes lines)
 122     (block nil
 123       (while (not (eobp))
 124         (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
 125           (delete-region (point) (progn (forward-line 1) (point)))
 126           (when (eobp)
 127             (return)))
 128         (setq article (match-string 1)
 129               bytes (nnimap-get-length)
 130               lines nil)
 131         (beginning-of-line)
 132         (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
 133           (let ((structure (ignore-errors (read (current-buffer)))))
 134             (while (and (consp structure)
 135                         (not (stringp (car structure))))
 136               (setq structure (car structure)))
 137             (setq lines (nth 7 structure))))
 138         (delete-region (line-beginning-position) (line-end-position))
 139         (insert (format "211 %s Article retrieved." article))
 140         (forward-line 1)
 141         (insert (format "Bytes: %d\n" bytes))
 142         (when lines
 143           (insert (format "Lines: %s\n" lines)))
 144         (re-search-forward "^\r$")
 145         (delete-region (line-beginning-position) (line-end-position))
 146         (insert ".")
 147         (forward-line 1)))))
 148
 149 (defun nnimap-get-length ()
 150   (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t)
 151        (string-to-number (match-string 1))))
 152
 153 (defun nnimap-article-ranges (ranges)
 154   (let (result)
 155     (cond
 156      ((numberp ranges)
 157       (number-to-string ranges))
 158      ((numberp (cdr ranges))
 159       (format "%d:%d" (car ranges) (cdr ranges)))
 160      (t
 161       (dolist (elem ranges)
 162         (push
 163          (if (consp elem)
 164              (format "%d:%d" (car elem) (cdr elem))
 165            (number-to-string elem))
 166          result))
 167       (mapconcat #'identity (nreverse result) ",")))))
 168
 169 (defun nnimap-open-server (server &optional defs)
 170   (if (nnimap-server-opened server)
 171       t
 172     (unless (assq 'nnimap-address defs)
 173       (setq defs (append defs (list (list 'nnimap-address server)))))
 174     (nnoo-change-server 'nnimap server defs)
 175     (or (nnimap-find-connection nntp-server-buffer)
 176         (nnimap-open-connection nntp-server-buffer))))
 177
 178 (defun nnimap-make-process-buffer (buffer)
 179   (with-current-buffer
 180       (generate-new-buffer (format "*nnimap %s %s %s*"
 181                                    nnimap-address nnimap-server-port
 182                                    (gnus-buffer-exists-p buffer)))
 183     (mm-disable-multibyte)
 184     (buffer-disable-undo)
 185     (gnus-add-buffer)
 186     (set (make-local-variable 'after-change-functions) nil)
 187     (set (make-local-variable 'nnimap-object) (make-nnimap))
 188     (push (list buffer (current-buffer)) nnimap-connection-alist)
 189     (current-buffer)))
 190
 191 (defun nnimap-open-shell-stream (name buffer host port)
 192   (let ((process (start-process name buffer shell-file-name
 193                                 shell-command-switch
 194                                 (format-spec
 195                                  nnimap-shell-program
 196                                  (format-spec-make
 197                                   ?s host
 198                                   ?p port)))))
 199     process))
 200
 201 (defun nnimap-open-connection (buffer)
 202   (with-current-buffer (nnimap-make-process-buffer buffer)
 203     (let* ((coding-system-for-read 'binary)
 204            (coding-system-for-write 'binary)
 205            (credentials
 206             (cond
 207              ((eq nnimap-stream 'network)
 208               (open-network-stream "*nnimap*" (current-buffer) nnimap-address
 209                                    (or nnimap-server-port "imap"))
 210               (netrc-credentials nnimap-address "imap"))
 211              ((eq nnimap-stream 'stream)
 212               (nnimap-open-shell-stream
 213                "*nnimap*" (current-buffer) nnimap-address
 214                (or nnimap-server-port "imap"))
 215               (netrc-credentials nnimap-address "imap"))
 216              ((eq nnimap-stream 'ssl)
 217               (open-tls-stream "*nnimap*" (current-buffer) nnimap-address
 218                                (or nnimap-server-port "imaps"))
 219               (netrc-credentials nnimap-address "imaps" "imap")))))
 220       (setf (nnimap-process nnimap-object)
 221             (get-buffer-process (current-buffer)))
 222       (unless credentials
 223         (delete-process (nnimap-process nnimap-object))
 224         (error "Can't find user name/password for %s" nnimap-address))
 225       (when (and (nnimap-process nnimap-object)
 226                  (memq (process-status (nnimap-process nnimap-object))
 227                        '(open run)))
 228         (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil)
 229         (let ((result (nnimap-command "LOGIN %S %S"
 230                                       (car credentials) (cadr credentials))))
 231           (unless (car result)
 232             (delete-process (nnimap-process nnimap-object))
 233             (error "Unable to login to the server: %s"
 234                    (mapconcat #'identity (cadr result) " ")))
 235           (setf (nnimap-capabilities nnimap-object)
 236                 (or (nnimap-find-parameter "CAPABILITY" (cdr result))
 237                     (nnimap-find-parameter
 238                      "CAPABILITY" (cdr (nnimap-command "CAPABILITY")))))
 239           (when (member "QRESYNC" (nnimap-capabilities nnimap-object))
 240             (nnimap-command "ENABLE QRESYNC"))
 241           t)))))
 242
 243 (defun nnimap-find-parameter (parameter elems)
 244   (let (result)
 245     (dolist (elem elems)
 246       (cond
 247        ((equal (car elem) parameter)
 248         (setq result (cdr elem)))
 249        ((and (equal (car elem) "OK")
 250              (consp (cadr elem))
 251              (equal (caadr elem) parameter))
 252         (setq result (cdr (cadr elem))))))
 253     result))
 254
 255 (defun nnimap-close-server (&optional server)
 256   t)
 257
 258 (defun nnimap-request-close ()
 259   t)
 260
 261 (defun nnimap-server-opened (&optional server)
 262   (and (nnoo-current-server-p 'nnimap server)
 263        nntp-server-buffer
 264        (gnus-buffer-live-p nntp-server-buffer)
 265        (nnimap-find-connection nntp-server-buffer)))
 266
 267 (defun nnimap-status-message (&optional server)
 268   nnimap-status-string)
 269
 270 (defun nnimap-request-article (article &optional group server to-buffer)
 271   (with-current-buffer nntp-server-buffer
 272     (let ((result (nnimap-possibly-change-group group server)))
 273       (when (stringp article)
 274         (setq article (nnimap-find-article-by-message-id group article)))
 275       (when (and result
 276                  article)
 277         (erase-buffer)
 278         (nnimap-with-process-buffer
 279          (erase-buffer)
 280          (setq result
 281                (nnimap-command
 282                 (if (member "IMAP4rev1" (nnimap-capabilities nnimap-object))
 283                     "UID FETCH %d BODY.PEEK[]"
 284                   "UID FETCH %d RFC822.PEEK")
 285                 article)))
 286         (let ((buffer (nnimap-find-process-buffer (current-buffer))))
 287           (when (car result)
 288             (with-current-buffer to-buffer
 289               (insert-buffer-substring buffer)
 290               (goto-char (point-min))
 291               (let ((bytes (nnimap-get-length)))
 292                 (delete-region (line-beginning-position)
 293                                (progn (forward-line 1) (point)))
 294                 (goto-char (+ (point) bytes))
 295                 (delete-region (point) (point-max))
 296                 (nnheader-ms-strip-cr))
 297               t)))))))
 298
 299 (defun nnimap-request-group (group &optional server dont-check)
 300   (with-current-buffer nntp-server-buffer
 301     (let ((result (nnimap-possibly-change-group group server))
 302           articles)
 303       (when result
 304         (setq articles (nnimap-get-flags "1:*"))
 305         (erase-buffer)
 306         (insert
 307          (format
 308           "211 %d %d %d %S\n"
 309           (length articles)
 310           (or (caar articles) 0)
 311           (or (caar (last articles)) 0)
 312           group))
 313         t))))
 314
 315 (defun nnimap-get-flags (spec)
 316   (let ((articles nil)
 317         elems)
 318     (with-current-buffer (nnimap-buffer)
 319       (erase-buffer)
 320       (nnimap-wait-for-response (nnimap-send-command
 321                                  "UID FETCH %s FLAGS" spec))
 322       (goto-char (point-min))
 323       (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" nil t)
 324         (setq elems (nnimap-parse-line (match-string 1)))
 325         (push (cons (string-to-number (cadr (member "UID" elems)))
 326                     (cadr (member "FLAGS" elems)))
 327               articles)))
 328     (nreverse articles)))
 329
 330 (defun nnimap-close-group (group &optional server)
 331   t)
 332
 333 (deffoo nnimap-request-move-article (article group server accept-form
 334                                              &optional last internal-move-group)
 335   (when (nnimap-possibly-change-group group server)
 336     ;; If the move is internal (on the same server), just do it the easy
 337     ;; way.
 338     (let ((message-id (message-field-value "message-id")))
 339       (if internal-move-group
 340           (let ((result
 341                  (with-current-buffer (nnimap-buffer)
 342                    (nnimap-command "UID COPY %d %S"
 343                                    article
 344                                    (utf7-encode internal-move-group t)))))
 345             (when (car result)
 346               (nnimap-delete-article article)
 347               (cons internal-move-group
 348                     (nnimap-find-article-by-message-id
 349                      internal-move-group message-id))))
 350         (with-temp-buffer
 351           (let ((result (eval accept-form)))
 352             (when result
 353               (nnimap-delete-article article)
 354               result)))))))
 355
 356 (deffoo nnimap-request-expire-articles (articles group &optional server force)
 357   (cond
 358    ((not (nnimap-possibly-change-group group server))
 359     articles)
 360    (force
 361     (unless (nnimap-delete-article articles)
 362       (message "Article marked for deletion, but not expunged."))
 363     nil)
 364    (t
 365     articles)))
 366
 367 (defun nnimap-find-article-by-message-id (group message-id)
 368   (when (nnimap-possibly-change-group group nil)
 369     (with-current-buffer (nnimap-buffer)
 370       (let ((result
 371              (nnimap-command "UID SEARCH HEADER Message-Id %S" message-id))
 372             article)
 373         (when (car result)
 374           ;; Select the last instance of the message in the group.
 375           (and (setq article
 376                      (car (last (assoc "SEARCH" (cdr result)))))
 377                (string-to-number article)))))))
 378
 379 (defun nnimap-delete-article (articles)
 380   (with-current-buffer (nnimap-buffer)
 381     (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
 382                     (nnimap-article-ranges articles))
 383     (when (member "UIDPLUS" (nnimap-capabilities nnimap-object))
 384       (nnimap-send-command "UID EXPUNGE %s"
 385                            (nnimap-article-ranges articles))
 386       t)))
 387
 388 (deffoo nnimap-request-scan (&optional group server)
 389   (when (and (nnimap-possibly-change-group nil server)
 390              (equal group nnimap-inbox)
 391              nnimap-inbox
 392              nnimap-split-methods)
 393     (nnimap-split-incoming-mail)))
 394
 395 (defun nnimap-marks-to-flags (marks)
 396   (let (flags flag)
 397     (dolist (mark marks)
 398       (when (setq flag (cadr (assq mark nnimap-mark-alist)))
 399         (push flag flags)))
 400     flags))
 401
 402 (defun nnimap-request-set-mark (group actions &optional server)
 403   (when (nnimap-possibly-change-group group server)
 404     (let (sequence)
 405       (with-current-buffer (nnimap-find-process-buffer nntp-server-buffer)
 406         ;; Just send all the STORE commands without waiting for
 407         ;; response.  If they're successful, they're successful.
 408         (dolist (action actions)
 409           (destructuring-bind (range action marks) action
 410             (let ((flags (nnimap-marks-to-flags marks)))
 411               (when flags
 412                 (setq sequence (nnimap-send-command
 413                                 "UID STORE %s %sFLAGS.SILENT (%s)"
 414                                 (nnimap-article-ranges range)
 415                                 (if (eq action 'del)
 416                                     "-"
 417                                   "+")
 418                                 (mapconcat #'identity flags " ")))))))
 419         ;; Wait for the last command to complete to avoid later
 420         ;; syncronisation problems with the stream.
 421         (nnimap-wait-for-response sequence)))))
 422
 423 (deffoo nnimap-request-accept-article (group &optional server last)
 424   (when (nnimap-possibly-change-group nil server)
 425     (nnmail-check-syntax)
 426     (let ((message (buffer-string))
 427           (message-id (message-field-value "message-id"))
 428           sequence)
 429       (with-current-buffer nntp-server-buffer
 430         (nnimap-with-process-buffer
 431          (setq sequence (nnimap-send-command
 432                          "APPEND %S {%d}" (utf7-encode group t)
 433                          (length message)))
 434          (process-send-string (get-buffer-process (current-buffer)) message)
 435          (process-send-string (get-buffer-process (current-buffer)) "\r\n")
 436          (let ((result (nnimap-get-response sequence)))
 437            (when result
 438              (cons group
 439                    (nnimap-find-article-by-message-id group message-id)))))))))
 440
 441 (defun nnimap-add-cr ()
 442   (goto-char (point-min))
 443   (while (re-search-forward "\r?\n" nil t)
 444     (replace-match "\r\n" t t)))
 445
 446 (defun nnimap-get-groups ()
 447   (let ((result (nnimap-command "LIST \"\" \"*\""))
 448         groups)
 449     (when (car result)
 450       (dolist (line (cdr result))
 451         (when (and (equal (car line) "LIST")
 452                    (not (string-match "noselect" (caadr line))))
 453           (push (car (last line)) groups)))
 454       (nreverse groups))))
 455
 456 (defun nnimap-request-list (&optional server)
 457   (nnimap-possibly-change-group nil server)
 458   (with-current-buffer nntp-server-buffer
 459     (erase-buffer)
 460     (let ((groups
 461            (nnimap-with-process-buffer
 462             (nnimap-get-groups)))
 463           sequences responses)
 464       (when groups
 465         (nnimap-with-process-buffer
 466          (dolist (group groups)
 467            (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
 468                        group)
 469                  sequences))
 470          (nnimap-wait-for-response (caar sequences))
 471          (setq responses
 472                (nnimap-get-responses (mapcar #'car sequences))))
 473         (dolist (response responses)
 474           (let* ((sequence (car response))
 475                  (response (cadr response))
 476                  (group (cadr (assoc sequence sequences))))
 477             (when (and group
 478                        (equal (caar response) "OK"))
 479               (let ((uidnext (nnimap-find-parameter "UIDNEXT" response))
 480                     highest exists)
 481                 (dolist (elem response)
 482                   (when (equal (cadr elem) "EXISTS")
 483                     (setq exists (string-to-number (car elem)))))
 484                 (when uidnext
 485                   (setq highest (1- (string-to-number (car uidnext)))))
 486                 (cond
 487                  ((null highest)
 488                   (insert (format "%S 0 1 y\n" (utf7-decode group t))))
 489                  ((zerop exists)
 490                   ;; Empty group.
 491                   (insert (format "%S %d %d y\n"
 492                                   (utf7-decode group t) highest (1+ highest))))
 493                  (t
 494                   ;; Return the widest possible range.
 495                   (insert (format "%S %d 1 y\n" (utf7-decode group t)
 496                                   (or highest exists)))))))))
 497         t))))
 498
 499 (defun nnimap-retrieve-group-data-early (server infos)
 500   (when (nnimap-possibly-change-group nil server)
 501     (with-current-buffer (nnimap-buffer)
 502       ;; QRESYNC handling isn't implemented.
 503       (let ((qresyncp (member "notQRESYNC" (nnimap-capabilities nnimap-object)))
 504             marks groups sequences)
 505         ;; Go through the infos and gather the data needed to know
 506         ;; what and how to request the data.
 507         (dolist (info infos)
 508           (setq marks (gnus-info-marks info))
 509           (push (list (gnus-group-real-name (gnus-info-group info))
 510                       (cdr (assq 'active marks))
 511                       (cdr (assq 'uid marks)))
 512                 groups))
 513         ;; Then request the data.
 514         (erase-buffer)
 515         (dolist (elem groups)
 516           (if (and qresyncp
 517                    (nth 2 elem))
 518               (push
 519                (list 'qresync
 520                      (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))"
 521                                           (car elem)
 522                                           (car (nth 2 elem))
 523                                           (cdr (nth 2 elem)))
 524                      nil
 525                      (car elem))
 526                sequences)
 527             (let ((start
 528                    (if (nth 1 elem)
 529                        ;; Fetch the last 100 flags.
 530                        (max 1 (- (cdr (nth 1 elem)) 100))
 531                      1)))
 532               (push (list (nnimap-send-command "EXAMINE %S" (car elem))
 533                           (nnimap-send-command "UID FETCH %d:* FLAGS" start)
 534                           start
 535                           (car elem))
 536                     sequences))))
 537         sequences))))
 538
 539 (defun nnimap-finish-retrieve-group-infos (server infos sequences)
 540   (when (nnimap-possibly-change-group nil server)
 541     (with-current-buffer (nnimap-buffer)
 542       ;; Wait for the final data to trickle in.
 543       (nnimap-wait-for-response (cadar sequences))
 544       ;; Now we should have all the data we need, no matter whether
 545       ;; we're QRESYNCING, fetching all the flags from scratch, or
 546       ;; just fetching the last 100 flags per group.
 547       (nnimap-update-infos (nnimap-flags-to-marks
 548                             (nnimap-parse-flags
 549                              (nreverse sequences)))
 550                            infos))))
 551
 552 (defun nnimap-update-infos (flags infos)
 553   (dolist (info infos)
 554     (let ((group (gnus-group-real-name (gnus-info-group info))))
 555       (nnimap-update-info info (cdr (assoc group flags))))))
 556
 557 (defun nnimap-update-info (info marks)
 558   (when marks
 559     (destructuring-bind (existing flags high low uidnext start-article) marks
 560       (let ((group (gnus-info-group info))
 561             (completep (and start-article
 562                             (= start-article 1))))
 563         ;; First set the active ranges based on high/low.
 564         (if completep
 565             (gnus-set-active group
 566                              (if high
 567                                  (cons low high)
 568                                ;; No articles in this group.
 569                                (cons (1- uidnext) uidnext)))
 570           (setcdr (gnus-active group) high))
 571         ;; Then update the list of read articles.
 572         (let* ((unread
 573                 (gnus-compress-sequence
 574                  (gnus-set-difference
 575                   (gnus-set-difference
 576                    existing
 577                    (cdr (assoc "\\Seen" flags)))
 578                   (cdr (assoc "\\Flagged" flags)))))
 579                (read (gnus-range-difference
 580                       (cons start-article high) unread)))
 581           (when (> start-article 1)
 582             (setq read
 583                   (gnus-range-nconcat
 584                    (gnus-sorted-range-intersection
 585                     (cons 1 start-article)
 586                     (gnus-info-read info))
 587                    read)))
 588           (gnus-info-set-read info read)
 589           ;; Update the marks.
 590           (setq marks (gnus-info-marks info))
 591           ;; Note the active level for the next run-through.
 592           (let ((active (assq 'active marks)))
 593             (if active
 594                 (setcdr active (gnus-active group))
 595               (push (cons 'active (gnus-active group)) marks)))
 596           (dolist (type (cdr nnimap-mark-alist))
 597             (let ((old-marks (assoc (car type) marks))
 598                   (new-marks (gnus-compress-sequence
 599                               (cdr (assoc (cadr type) flags)))))
 600               (setq marks (delq old-marks marks))
 601               (pop old-marks)
 602               (when (and old-marks
 603                          (> start-article 1))
 604                 (setq old-marks (gnus-range-difference
 605                                  (cons start-article high)
 606                                  old-marks))
 607                 (setq new-marks (gnus-range-nconcat old-marks new-marks)))
 608               (when new-marks
 609                 (push (cons (car type) new-marks) marks)))
 610             (gnus-info-set-marks info marks)))))))
 611
 612 (defun nnimap-flags-to-marks (groups)
 613   (let (data group totalp uidnext articles start-article mark)
 614     (dolist (elem groups)
 615       (setq group (car elem)
 616             uidnext (cadr elem)
 617             start-article (caddr elem)
 618             articles (cdddr elem))
 619       (let ((high (caar articles))
 620             marks low existing)
 621         (dolist (article articles)
 622           (setq low (car article))
 623           (push (car article) existing)
 624           (dolist (flag (cdr article))
 625             (setq mark (assoc flag marks))
 626             (if (not mark)
 627                 (push (list flag (car article)) marks)
 628               (setcdr mark (cons (car article) (cdr mark)))))
 629           (push (list group existing marks high low uidnext start-article)
 630                 data))))
 631     data))
 632
 633 (defun nnimap-parse-flags (sequences)
 634   (goto-char (point-min))
 635   (let (start end articles groups uidnext elems)
 636     (dolist (elem sequences)
 637       (destructuring-bind (group-sequence flag-sequence totalp group) elem
 638         ;; The EXAMINE was successful.
 639         (when (and (search-forward (format "\n%d OK " group-sequence) nil t)
 640                    (progn
 641                      (forward-line 1)
 642                      (setq start (point))
 643                      (if (re-search-backward "UIDNEXT \\([0-9]+\\)"
 644                                                (or end (point-min)) t)
 645                          (setq uidnext (string-to-number (match-string 1)))
 646                        (setq uidnext nil))
 647                      (goto-char start))
 648                    ;; The UID FETCH FLAGS was successful.
 649                    (search-forward (format "\n%d OK " flag-sequence) nil t))
 650           (setq end (point))
 651           (goto-char start)
 652           (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" end t)
 653             (setq elems (nnimap-parse-line (match-string 1)))
 654             (push (cons (string-to-number (cadr (member "UID" elems)))
 655                         (cadr (member "FLAGS" elems)))
 656                   articles))
 657           (push (nconc (list group uidnext totalp) articles) groups)
 658           (setq articles nil))))
 659     groups))
 660
 661 (defun nnimap-find-process-buffer (buffer)
 662   (cadr (assoc buffer nnimap-connection-alist)))
 663
 664 (defun nnimap-request-post (&optional server)
 665   (setq nnimap-status-string "Read-only server")
 666   nil)
 667
 668 (defun nnimap-possibly-change-group (group server)
 669   (when (and server
 670              (not (nnimap-server-opened server)))
 671     (nnimap-open-server server))
 672   (if (not group)
 673       t
 674     (with-current-buffer (nnimap-buffer)
 675       (if (equal group (nnimap-group nnimap-object))
 676           t
 677         (let ((result (nnimap-command "SELECT %S" (utf7-encode group t))))
 678           (when (car result)
 679             (setf (nnimap-group nnimap-object) group)
 680             result))))))
 681
 682 (defun nnimap-find-connection (buffer)
 683   "Find the connection delivering to BUFFER."
 684   (let ((entry (assoc buffer nnimap-connection-alist)))
 685     (when entry
 686       (if (and (buffer-name (cadr entry))
 687                (get-buffer-process (cadr entry))
 688                (memq (process-status (get-buffer-process (cadr entry)))
 689                      '(open run)))
 690           (get-buffer-process (cadr entry))
 691         (setq nnimap-connection-alist (delq entry nnimap-connection-alist))
 692         nil))))
 693
 694 (defvar nnimap-sequence 0)
 695
 696 (defun nnimap-send-command (&rest args)
 697   (process-send-string
 698    (get-buffer-process (current-buffer))
 699    (nnimap-log-command
 700     (format "%d %s\r\n"
 701             (incf nnimap-sequence)
 702             (apply #'format args))))
 703   nnimap-sequence)
 704
 705 (defun nnimap-log-command (command)
 706   (with-current-buffer (get-buffer-create "*imap log*")
 707     (goto-char (point-max))
 708     (insert (format-time-string "%H:%M:%S") " " command))
 709   command)
 710
 711 (defun nnimap-command (&rest args)
 712   (erase-buffer)
 713   (let* ((sequence (apply #'nnimap-send-command args))
 714          (response (nnimap-get-response sequence)))
 715     (if (equal (caar response) "OK")
 716         (cons t response)
 717       (nnheader-report 'nnimap "%s"
 718                        (mapconcat #'identity (car response) " "))
 719       nil)))
 720
 721 (defun nnimap-get-response (sequence)
 722   (nnimap-wait-for-response sequence)
 723   (nnimap-parse-response))
 724
 725 (defun nnimap-wait-for-response (sequence &optional messagep)
 726   (goto-char (point-max))
 727   (while (or (bobp)
 728              (progn
 729                (forward-line -1)
 730                (not (looking-at (format "^%d .*\n" sequence)))))
 731     (when messagep
 732       (message "Read %dKB" (/ (buffer-size) 1000)))
 733     (nnheader-accept-process-output (get-buffer-process (current-buffer)))
 734     (goto-char (point-max))))
 735
 736 (defun nnimap-parse-response ()
 737   (let ((lines (split-string (nnimap-last-response-string) "\r\n" t))
 738         result)
 739     (dolist (line lines)
 740       (push (cdr (nnimap-parse-line line)) result))
 741     ;; Return the OK/error code first, and then all the "continuation
 742     ;; lines" afterwards.
 743     (cons (pop result)
 744           (nreverse result))))
 745
 746 ;; Parse an IMAP response line lightly.  They look like
 747 ;; "* OK [UIDVALIDITY 1164213559] UIDs valid", typically, so parse
 748 ;; the lines into a list of strings and lists of string.
 749 (defun nnimap-parse-line (line)
 750   (let (char result)
 751     (with-temp-buffer
 752       (insert line)
 753       (goto-char (point-min))
 754       (while (not (eobp))
 755         (if (eql (setq char (following-char)) ? )
 756             (forward-char 1)
 757           (push
 758            (cond
 759             ((eql char ?\[)
 760              (split-string (buffer-substring
 761                             (1+ (point)) (1- (search-forward "]")))))
 762             ((eql char ?\()
 763              (split-string (buffer-substring
 764                             (1+ (point)) (1- (search-forward ")")))))
 765             ((eql char ?\")
 766              (forward-char 1)
 767              (buffer-substring (point) (1- (search-forward "\""))))
 768             (t
 769              (buffer-substring (point) (if (search-forward " " nil t)
 770                                            (1- (point))
 771                                          (goto-char (point-max))))))
 772            result)))
 773       (nreverse result))))
 774
 775 (defun nnimap-last-response-string ()
 776   (save-excursion
 777     (forward-line 1)
 778     (let ((end (point)))
 779       (forward-line -1)
 780       (when (not (bobp))
 781         (forward-line -1)
 782         (while (and (not (bobp))
 783                     (eql (following-char) ?*))
 784           (forward-line -1))
 785         (unless (eql (following-char) ?*)
 786           (forward-line 1)))
 787       (buffer-substring (point) end))))
 788
 789 (defun nnimap-get-responses (sequences)
 790   (let (responses)
 791     (dolist (sequence sequences)
 792       (goto-char (point-min))
 793       (when (re-search-forward (format "^%d " sequence) nil t)
 794         (push (list sequence (nnimap-parse-response))
 795               responses)))
 796     responses))
 797
 798 (defvar nnimap-incoming-split-list nil)
 799
 800 (defun nnimap-fetch-inbox (articles)
 801   (erase-buffer)
 802   (nnimap-wait-for-response
 803    (nnimap-send-command
 804     "UID FETCH %s %s"
 805     (nnimap-article-ranges articles)
 806     (format "(UID %s%s)"
 807             (format
 808              (if (member "IMAP4rev1"
 809                          (nnimap-capabilities nnimap-object))
 810                  "BODY.PEEK[HEADER] BODY.PEEK"
 811                "RFC822.PEEK"))
 812             (if nnimap-split-download-body-default
 813                 ""
 814               "[1]")))
 815    t))
 816
 817 (defun nnimap-split-incoming-mail ()
 818   (with-current-buffer (nnimap-buffer)
 819     (let ((nnimap-incoming-split-list nil)
 820           (nnmail-split-methods nnimap-split-methods)
 821           (nnmail-inhibit-default-split-group t)
 822           (groups (nnimap-get-groups))
 823           new-articles)
 824       (erase-buffer)
 825       (nnimap-command "SELECT %S" nnimap-inbox)
 826       (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*")))
 827       (when new-articles
 828         (nnimap-fetch-inbox new-articles)
 829         (nnimap-transform-split-mail)
 830         (nnheader-ms-strip-cr)
 831         (nnmail-cache-open)
 832         (nnmail-split-incoming (current-buffer)
 833                                #'nnimap-save-mail-spec
 834                                nil nil
 835                                #'nnimap-dummy-active-number)
 836         (when nnimap-incoming-split-list
 837           (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list))
 838                 sequences)
 839             ;; Create any groups that doesn't already exist on the
 840             ;; server first.
 841             (dolist (spec specs)
 842               (unless (member (car spec) groups)
 843                 (nnimap-command "CREATE %S" (utf7-encode (car spec) t))))
 844             ;; Then copy over all the messages.
 845             (erase-buffer)
 846             (dolist (spec specs)
 847               (let ((group (car spec))
 848                     (ranges (cdr spec)))
 849                 (push (list (nnimap-send-command "UID COPY %s %S"
 850                                                  (nnimap-article-ranges ranges)
 851                                                  (utf7-encode group t))
 852                             ranges)
 853                       sequences)))
 854             ;; Wait for the last COPY response...
 855             (when sequences
 856               (nnimap-wait-for-response (caar sequences))
 857               ;; And then mark the successful copy actions as deleted,
 858               ;; and possibly expunge them.
 859               (nnimap-mark-and-expunge-incoming
 860                (nnimap-parse-copied-articles sequences)))))))))
 861
 862 (defun nnimap-mark-and-expunge-incoming (range)
 863   (when range
 864     (setq range (nnimap-article-ranges range))
 865     (nnimap-send-command
 866      "UID STORE %s +FLAGS.SILENT (\\Deleted)" range)
 867     (cond
 868      ;; If the server supports it, we now delete the message we have
 869      ;; just copied over.
 870      ((member "UIDPLUS" (nnimap-capabilities nnimap-object))
 871       (nnimap-send-command "UID EXPUNGE %s" range))
 872      ;; If it doesn't support UID EXPUNGE, then we only expunge if the
 873      ;; user has configured it.
 874      (nnimap-expunge-inbox
 875       (nnimap-send-command "EXPUNGE")))))
 876
 877 (defun nnimap-parse-copied-articles (sequences)
 878   (let (sequence copied range)
 879     (goto-char (point-min))
 880     (while (re-search-forward "^\\([0-9]+\\) OK " nil t)
 881       (setq sequence (string-to-number (match-string 1)))
 882       (when (setq range (cadr (assq sequence sequences)))
 883         (push (gnus-uncompress-range range) copied)))
 884     (gnus-compress-sequence (sort (apply #'nconc copied) #'<))))
 885
 886 (defun nnimap-new-articles (flags)
 887   (let (new)
 888     (dolist (elem flags)
 889       (when (or (null (cdr elem))
 890                 (and (not (member "\\Deleted" (cdr elem)))
 891                      (not (member "\\Seen" (cdr elem)))))
 892         (push (car elem) new)))
 893     (gnus-compress-sequence (nreverse new))))
 894
 895 (defun nnimap-make-split-specs (list)
 896   (let ((specs nil)
 897         entry)
 898     (dolist (elem list)
 899       (destructuring-bind (article spec) elem
 900         (dolist (group (delete nil (mapcar #'car spec)))
 901           (unless (setq entry (assoc group specs))
 902             (push (setq entry (list group)) specs))
 903           (setcdr entry (cons article (cdr entry))))))
 904     (dolist (entry specs)
 905       (setcdr entry (gnus-compress-sequence (sort (cdr entry) #'<))))
 906     specs))
 907
 908 (defun nnimap-transform-split-mail ()
 909   (goto-char (point-min))
 910   (let (article bytes)
 911     (block nil
 912       (while (not (eobp))
 913         (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
 914           (delete-region (point) (progn (forward-line 1) (point)))
 915           (when (eobp)
 916             (return)))
 917         (setq article (match-string 1)
 918               bytes (nnimap-get-length))
 919         (delete-region (line-beginning-position) (line-end-position))
 920         ;; Insert MMDF separator, and a way to remember what this
 921         ;; article UID is.
 922         (insert (format "\^A\^A\^A\^A\n\nX-nnimap-article: %s" article))
 923         (forward-char (1+ bytes))
 924         (setq bytes (nnimap-get-length))
 925         (delete-region (line-beginning-position) (line-end-position))
 926         (forward-char (1+ bytes))
 927         (delete-region (line-beginning-position) (line-end-position))))))
 928
 929 (defun nnimap-dummy-active-number (group &optional server)
 930   1)
 931
 932 (defun nnimap-save-mail-spec (group-art &optional server full-nov)
 933   (let (article)
 934     (goto-char (point-min))
 935     (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t))
 936         (error "Invalid nnimap mail")
 937       (setq article (string-to-number (match-string 1))))
 938     (push (list article group-art)
 939           nnimap-incoming-split-list)))
 940
 941 (provide 'nnimap)
 942
 943 ;;; nnimap.el ends here