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