*** empty log message ***
[gnus] / lisp / nndraft.el
1 ;;; nndraft.el --- draft article access for Gnus
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Keywords: news
6
7 ;; This file is part of GNU Emacs.
8
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 ;; GNU General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
23
24 ;;; Commentary:
25
26 ;;; Code:
27
28 (require 'nnheader)
29 (require 'nnmail)
30 (require 'gnus-start)
31 (require 'nnmh)
32 (require 'nnoo)
33 (eval-when-compile (require 'cl))
34
35 (nnoo-declare nndraft
36   nnmh)
37
38 (defvoo nndraft-directory (nnheader-concat message-directory "drafts/")
39   "Where nndraft will store its files."
40   nnmh-current-directory)
41
42 \f
43
44 (defvoo nndraft-current-group "" nil nnmh-current-group)
45 (defvoo nndraft-top-directory nil nil nnmh-directory)
46 (defvoo nndraft-get-new-mail nil nil nnmh-get-new-mail)
47
48 (defconst nndraft-version "nndraft 1.0")
49 (defvoo nndraft-status-string "" nnmh-status-string)
50
51 \f
52
53 ;;; Interface functions.
54
55 (nnoo-define-basics nndraft)
56
57 (deffoo nndraft-open-server (server &optional defs)
58   (push `(nndraft-current-group
59           ,(file-name-nondirectory (directory-file-name nndraft-directory)))
60         defs)
61   (push `(nndraft-top-directory
62           ,(file-name-directory (directory-file-name nndraft-directory)))
63         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   (save-excursion
80     (set-buffer nntp-server-buffer)
81     (erase-buffer)
82     (let* ((buf (get-buffer-create " *draft headers*"))
83            article)
84       (set-buffer buf)
85       (buffer-disable-undo (current-buffer))
86       (erase-buffer)
87       ;; We don't support fetching by Message-ID.
88       (if (stringp (car articles))
89           'headers
90         (while articles
91           (set-buffer buf)
92           (when (nndraft-request-article
93                  (setq article (pop articles)) group server (current-buffer))
94             (goto-char (point-min))
95             (if (search-forward "\n\n" nil t)
96                 (forward-line -1)
97               (goto-char (point-max)))
98             (delete-region (point) (point-max))
99             (set-buffer nntp-server-buffer)
100             (goto-char (point-max))
101             (insert (format "221 %d Article retrieved.\n" article))
102             (insert-buffer-substring buf)
103             (insert ".\n")))
104
105         (nnheader-fold-continuation-lines)
106         'headers))))
107
108 (deffoo nndraft-request-article (id &optional group server buffer)
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                  (nnmail-find-file newest))
118         (save-excursion
119           (set-buffer nntp-server-buffer)
120           (goto-char (point-min))
121           ;; If there's a mail header separator in this file,
122           ;; we remove it.
123           (when (re-search-forward
124                  (concat "^" mail-header-separator "$") nil t)
125             (replace-match "" t t)))
126         t))))
127
128 (deffoo nndraft-request-restore-buffer (article &optional group server)
129   "Request a new buffer that is restored to the state of ARTICLE."
130   (when (nndraft-request-article article group server (current-buffer))
131     (let ((gnus-verbose-backends nil))
132       (nndraft-request-expire-articles (list article) group server t))
133     t))
134
135 (deffoo nndraft-request-update-info (group info &optional server)
136   (setcar (cddr info) nil)
137   (let (marks)
138     (when (setq marks (nth 3 info))
139       (setcar (nthcdr 3 info)
140               (if (assq 'unsend marks)
141                   (list (assq 'unsend marks))
142                 nil))))
143   t)
144
145 (deffoo nndraft-request-associate-buffer (group)
146   "Associate the current buffer with some article in the draft group."
147   (let ((gnus-verbose-backends nil)
148         (buf (current-buffer))
149          article file)
150     (nnheader-temp-write nil
151       (insert-buffer buf)
152       (setq article (cdr (nndraft-request-accept-article
153                           group (nnoo-current-server 'nndraft) t 'noinsert)))
154       (setq file (nndraft-article-filename article)))
155     (setq buffer-file-name file)
156     (setq buffer-auto-save-file-name (make-auto-save-file-name))
157     (clear-visited-file-modtime)
158     article))
159
160 (deffoo nndraft-request-expire-articles (articles group &optional server force)
161   (let* ((nnmh-allow-delete-final t)
162          (res (nndraft-execute-nnmh-command
163                `(nnmh-request-expire-articles
164                  ',articles group ,server ,force)))
165          article)
166     ;; Delete all the "state" files of articles that have been expired.
167     (while articles
168       (unless (memq (setq article (pop articles)) res)
169         (let ((auto (nndraft-auto-save-file-name
170                      (nndraft-article-filename article))))
171           (when (file-exists-p auto)
172             (funcall nnmail-delete-file-function auto)))))
173     res))
174
175 (deffoo nndraft-request-accept-article (group &optional server last noinsert)
176   (let ((gnus-verbose-backends nil))
177     (nndraft-execute-nnmh-command
178      `(nnmh-request-accept-article group ,server ,last noinsert))))
179
180 (deffoo nndraft-request-create-group (group &optional server args)
181   (if (file-exists-p nndraft-directory)
182       (if (file-directory-p nndraft-directory)
183           t
184         nil)
185     (condition-case ()
186         (progn
187           (gnus-make-directory nndraft-directory)
188           t)
189       (file-error nil))))
190
191 \f
192 ;;; Low-Level Interface
193
194 (defun nndraft-execute-nnmh-command (command)
195   (let* ((dir (directory-file-name (expand-file-name nndraft-directory)))
196          (group (file-name-nondirectory dir))
197          (nnmh-directory (file-name-directory dir))
198          (nnmail-keep-last-article nil)
199          (nnmh-get-new-mail nil))
200     (eval command)))
201
202 (defun nndraft-article-filename (article &rest args)
203   (apply 'concat
204          (file-name-as-directory nndraft-directory)
205          (int-to-string article)
206          args))
207
208 (defun nndraft-auto-save-file-name (file)
209   (save-excursion
210     (prog1
211         (progn
212           (set-buffer (get-buffer-create " *draft tmp*"))
213           (setq buffer-file-name file)
214           (make-auto-save-file-name))
215       (kill-buffer (current-buffer)))))
216
217 (nnoo-map-functions nndraft
218   (nnmh-retrieve-headers 0 nndraft-current-group 0 0)
219   (nnmh-request-group nndraft-current-group 0 0)
220   (nnmh-close-group nndraft-current-group 0)
221   (nnmh-request-list (nnoo-current-server 'nndraft) nndraft-directory)
222   (nnmh-request-newsgroups (nnoo-current-server 'nndraft) nndraft-directory))
223
224 (provide 'nndraft)
225
226 ;;; nndraft.el ends here