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

   1 ;;; nndraft.el --- draft article access for Gnus
   2
   3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
   4 ;;   2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'nnheader)
  29 (require 'nnmail)
  30 (require 'gnus-start)
  31 (require 'nnmh)
  32 (require 'nnoo)
  33 (require 'mm-util)
  34 (eval-when-compile (require 'cl))
  35
  36 (nnoo-declare nndraft
  37   nnmh)
  38
  39 (defvoo nndraft-directory (nnheader-concat gnus-directory "drafts/")
  40   "Where nndraft will store its files."
  41   nnmh-directory)
  42
  43 (defvar nndraft-required-headers '(Date)
  44   "*Headers to be generated when saving a draft message.
  45 The headers in this variable and the ones in `message-required-headers'
  46 are generated if and only if they are also in `message-draft-headers'.")
  47
  48 \f
  49
  50 (defvoo nndraft-current-group "" nil nnmh-current-group)
  51 (defvoo nndraft-get-new-mail nil nil nnmh-get-new-mail)
  52 (defvoo nndraft-current-directory nil nil nnmh-current-directory)
  53
  54 (defconst nndraft-version "nndraft 1.0")
  55 (defvoo nndraft-status-string "" nil nnmh-status-string)
  56
  57 \f
  58
  59 ;;; Interface functions.
  60
  61 (nnoo-define-basics nndraft)
  62
  63 (deffoo nndraft-open-server (server &optional defs)
  64   (nnoo-change-server 'nndraft server defs)
  65   (cond
  66    ((not (file-exists-p nndraft-directory))
  67     (nndraft-close-server)
  68     (nnheader-report 'nndraft "No such file or directory: %s"
  69                      nndraft-directory))
  70    ((not (file-directory-p (file-truename nndraft-directory)))
  71     (nndraft-close-server)
  72     (nnheader-report 'nndraft "Not a directory: %s" nndraft-directory))
  73    (t
  74     (nnheader-report 'nndraft "Opened server %s using directory %s"
  75                      server nndraft-directory)
  76     t)))
  77
  78 (deffoo nndraft-retrieve-headers (articles &optional group server fetch-old)
  79   (nndraft-possibly-change-group group)
  80   (with-current-buffer nntp-server-buffer
  81     (erase-buffer)
  82     (let (article lines chars)
  83       ;; We don't support fetching by Message-ID.
  84       (if (stringp (car articles))
  85           'headers
  86         (while articles
  87           (narrow-to-region (point) (point))
  88           (when (nndraft-request-article
  89                  (setq article (pop articles)) group server (current-buffer))
  90             (goto-char (point-min))
  91             (if (search-forward "\n\n" nil t)
  92                 (forward-line -1)
  93               (goto-char (point-max)))
  94             (setq lines (count-lines (point) (point-max))
  95                   chars (- (point-max) (point)))
  96             (delete-region (point) (point-max))
  97             (goto-char (point-min))
  98             (insert (format "221 %d Article retrieved.\n" article))
  99             (insert (format "Lines: %d\nChars: %d\n" lines chars))
 100             (widen)
 101             (goto-char (point-max))
 102             (insert ".\n")))
 103
 104         (nnheader-fold-continuation-lines)
 105         'headers))))
 106
 107 (deffoo nndraft-request-article (id &optional group server buffer)
 108   (nndraft-possibly-change-group group)
 109   (when (numberp id)
 110     ;; We get the newest file of the auto-saved file and the
 111     ;; "real" file.
 112     (let* ((file (nndraft-article-filename id))
 113            (auto (nndraft-auto-save-file-name file))
 114            (newest (if (file-newer-than-file-p file auto) file auto))
 115            (nntp-server-buffer (or buffer nntp-server-buffer)))
 116       (when (and (file-exists-p newest)
 117                  (let ((nnmail-file-coding-system
 118                         (if (file-newer-than-file-p file auto)
 119                             (if (member group '("drafts" "delayed"))
 120                                 message-draft-coding-system
 121                               mm-text-coding-system)
 122                           mm-auto-save-coding-system)))
 123                    (nnmail-find-file newest)))
 124         (with-current-buffer nntp-server-buffer
 125           (goto-char (point-min))
 126           ;; If there's a mail header separator in this file,
 127           ;; we remove it.
 128           (when (re-search-forward
 129                  (concat "^" (regexp-quote mail-header-separator) "$") nil t)
 130             (replace-match "" t t)))
 131         t))))
 132
 133 (deffoo nndraft-request-restore-buffer (article &optional group server)
 134   "Request a new buffer that is restored to the state of ARTICLE."
 135   (nndraft-possibly-change-group group)
 136   (when (nndraft-request-article article group server (current-buffer))
 137     (message-remove-header "xref")
 138     (message-remove-header "lines")
 139     ;; Articles in nndraft:queue are considered as sent messages.  The
 140     ;; Date field should be the time when they are sent.
 141     ;;(message-remove-header "date")
 142     t))
 143
 144 (deffoo nndraft-request-update-info (group info &optional server)
 145   (nndraft-possibly-change-group group)
 146   (gnus-info-set-read