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

   1 ;;; nnimap.el --- IMAP interface for Gnus
   2
   3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;         Simon Josefsson <simon@josefsson.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; nnimap interfaces Gnus with IMAP servers.
  26
  27 ;;; Code:
  28
  29 (eval-and-compile
  30   (require 'nnheader))
  31
  32 (eval-when-compile
  33   (require 'cl))
  34
  35 (require 'nnheader)
  36 (require 'gnus-util)
  37 (require 'gnus)
  38 (require 'nnoo)
  39 (require 'netrc)
  40 (require 'utf7)
  41 (require 'tls)
  42 (require 'parse-time)
  43
  44 (autoload 'auth-source-forget-user-or-password "auth-source")
  45 (autoload 'auth-source-user-or-password "auth-source")
  46
  47 (nnoo-declare nnimap)
  48
  49 (defvoo nnimap-address nil
  50   "The address of the IMAP server.")
  51
  52 (defvoo nnimap-server-port nil
  53   "The IMAP port used.
  54 If nnimap-stream is `ssl', this will default to `imaps'.  If not,
  55 it will default to `imap'.")
  56
  57 (defvoo nnimap-stream 'ssl
  58   "How nnimap will talk to the IMAP server.
  59 Values are `ssl', `network', `starttls' or `shell'.")
  60
  61 (defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
  62                                  (if (listp imap-shell-program)
  63                                      (car imap-shell-program)
  64                                    imap-shell-program)
  65                                "ssh %s imapd"))
  66
  67 (defvoo nnimap-inbox nil
  68   "The mail box where incoming mail arrives and should be split out of.")
  69
  70 (defvoo nnimap-split-methods nil
  71   "How mail is split.
  72 Uses the same syntax as nnmail-split-methods")
  73
  74 (defvoo nnimap-split-fancy nil
  75   "Uses the same syntax as nnmail-split-fancy.")
  76
  77 (make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'"
  78                         "Emacs 24.1")
  79
  80 (defvoo nnimap-authenticator nil
  81   "How nnimap authenticate itself to the server.
  82 Possible choices are nil (use default methods) or `anonymous'.")
  83
  84 (defvoo nnimap-expunge t
  85   "If non-nil, expunge articles after deleting them.
  86 This is always done if the server supports UID EXPUNGE, but it's
  87 not done by default on servers that doesn't support that command.")
  88
  89 (defvoo nnimap-streaming t
  90   "If non-nil, try to use streaming commands with IMAP servers.
  91 Switching this off will make nnimap slower, but it helps with
  92 some servers.")
  93
  94 (defvoo nnimap-connection-alist nil)
  95
  96 (defvoo nnimap-current-infos nil)
  97
  98 (defvoo nnimap-fetch-partial-articles nil
  99   "If non-nil, Gnus will fetch partial articles.
 100 If t, nnimap will fetch only the first part.  If a string, it
 101 will fetch all parts that have types that match that string.  A
 102 likely value would be \"text/\" to automatically fetch all
 103 textual parts.")
 104
 105 (defvar nnimap-process nil)
 106
 107 (defvar nnimap-status-string "")
 108
 109 (defvar nnimap-split-download-body-default nil
 110   "Internal variable with default value for `nnimap-split-download-body'.")
 111
 112 (defvar nnimap-keepalive-timer nil)
 113 (defvar nnimap-process-buffers nil)
 114
 115 (defstruct nnimap
 116   group process commands capabilities select-result newlinep server
 117   last-command-time greeting)
 118
 119 (defvar nnimap-object nil)
 120
 121 (defvar nnimap-mark-alist
 122   '((read "\\Seen" %Seen)
 123     (tick "\\Flagged" %Flagged)
 124     (reply "\\Answered" %Answered)
 125     (expire "gnus-expire")
 126     (dormant "gnus-dormant")
 127     (score "gnus-score")
 128     (save "gnus-save")
 129     (download "gnus-download")
 130     (forward "gnus-forward")))
 131
 132 (defun nnimap-buffer ()
 133   (nnimap-find-process-buffer nntp-server-buffer))
 134
 135 (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old)
 136   (with-current-buffer nntp-server-buffer
 137     (erase-buffer)
 138     (when (nnimap-possibly-change-group group server)
 139       (with-current-buffer (nnimap-buffer)
 140         (erase-buffer)
 141         (nnimap-wait-for-response
 142          (nnimap-send-command
 143           "UID FETCH %s %s"
 144           (nnimap-article-ranges (gnus-compress-sequence articles))
 145           (format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
 146                   (format
 147                    (if (nnimap-ver4-p)
 148                        "BODY.PEEK[HEADER.FIELDS %s]"
 149                      "RFC822.HEADER.LINES %s")
 150                    (append '(Subject From Date Message-Id
 151                                      References In-Reply-To Xref)
 152                            nnmail-extra-headers))))
 153          t)
 154         (nnimap-transform-headers))
 155       (insert-buffer-substring
 156        (nnimap-find-process-buffer (current-buffer))))
 157     'headers))
 158
 159 (defun nnimap-transform-headers ()
 160   (goto-char (point-min))
 161   (let (article bytes lines size string)
 162     (block nil
 163       (while (not (eobp))
 164         (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
 165           (delete-region (point) (progn (forward-line 1) (point)))
 166           (when (eobp)
 167             (return)))
 168         (setq article (match-string 1))
 169         ;; Unfold quoted {number} strings.
 170         (while (re-search-forward "[^]] {\\([0-9]+\\)}\r\n"
 171                                   (1+ (line-end-position)) t)
 172           (setq size (string-to-number (match-string 1)))
 173           (delete-region (+ (match-beginning 0) 2) (point))
 174           (setq string (delete-region (point) (+ (point) size)))
 175           (insert (format "%S" string)))
 176         (setq bytes (nnimap-get-length)
 177               lines nil)
 178         (beginning-of-line)
 179         (setq size
 180               (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)"
 181                                       (line-end-position)
 182                                       t)
 183                    (match-string 1)))
 184         (beginning-of-line)
 185         (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
 186           (let ((structure (ignore-errors
 187                              (read (current-buffer)))))
 188             (while (and (consp structure)
 189                         (not (stringp (car structure))))
 190               (setq structure (car structure)))
 191             (setq lines (nth 7 structure))))
 192         (delete-region (line-beginning-position) (line-end-position))
 193         (insert (format "211 %s Article retrieved." article))
 194         (forward-line 1)
 195         (when size
 196           (insert (format "Chars: %s\n" size)))
 197         (when lines
 198           (insert (format "Lines: %s\n" lines)))
 199         (re-search-forward "^\r$")
 200         (delete-region (line-beginning-position) (line-end-position))
 201         (insert ".")
 202         (forward-line 1)))))
 203
 204 (defun nnimap-get-length ()
 205   (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t)
 206        (string-to-number (match-string 1))))
 207
 208 (defun nnimap-article-ranges (ranges)
 209   (let (result)
 210     (cond
 211      ((numberp ranges)
 212       (number-to-string ranges))
 213      ((numberp (cdr ranges))
 214       (format "%d:%d" (car ranges) (cdr ranges)))
 215