1 ;;; nndraft.el --- draft article access for Gnus
3 ;; Copyright (C) 1995-2018 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
8 ;; This file is part of GNU Emacs.
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.
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.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
35 ;; The nnoo-import at the end, I think.
36 (declare-function nndraft-request-list
"nndraft" (&rest args
) t
)
41 (defvoo nndraft-directory
(nnheader-concat gnus-directory
"drafts/")
42 "Where nndraft will store its files."
45 (defcustom nndraft-required-headers
'(Date)
46 "Headers to be generated when saving a draft message.
47 The headers in this variable and the ones in `message-required-headers'
48 are generated if and only if they are also in `message-draft-headers'."
50 :group
'message-headers
) ; FIXME wrong group
54 (defvoo nndraft-current-group
"" nil nnmh-current-group
)
55 (defvoo nndraft-get-new-mail nil nil nnmh-get-new-mail
)
56 (defvoo nndraft-current-directory nil nil nnmh-current-directory
)
58 (defconst nndraft-version
"nndraft 1.0")
59 (defvoo nndraft-status-string
"" nil nnmh-status-string
)
63 ;;; Interface functions.
65 (nnoo-define-basics nndraft
)
67 (deffoo nndraft-open-server
(server &optional defs
)
68 (nnoo-change-server 'nndraft server defs
)
70 ((not (file-exists-p nndraft-directory
))
71 (nndraft-close-server)
72 (nnheader-report 'nndraft
"No such file or directory: %s"
74 ((not (file-directory-p (file-truename nndraft-directory
)))
75 (nndraft-close-server)
76 (nnheader-report 'nndraft
"Not a directory: %s" nndraft-directory
))
78 (nnheader-report 'nndraft
"Opened server %s using directory %s"
79 server nndraft-directory
)
82 (deffoo nndraft-retrieve-headers
(articles &optional group server fetch-old
)
83 (nndraft-possibly-change-group group
)
84 (with-current-buffer nntp-server-buffer
86 (let (article lines chars
)
87 ;; We don't support fetching by Message-ID.
88 (if (stringp (car articles
))
91 (narrow-to-region (point) (point))
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
)
97 (goto-char (point-max)))
98 (setq lines
(count-lines (point) (point-max))
99 chars
(- (point-max) (point)))
100 (delete-region (point) (point-max))
101 (goto-char (point-min))
102 (insert (format "221 %d Article retrieved.\n" article
))
103 (insert (format "Lines: %d\nChars: %d\n" lines chars
))
105 (goto-char (point-max))
108 (nnheader-fold-continuation-lines)
111 (deffoo nndraft-request-article
(id &optional group server buffer
)
112 (nndraft-possibly-change-group group
)
114 ;; We get the newest file of the auto-saved file and the
116 (let* ((file (nndraft-article-filename id
))
117 (auto (nndraft-auto-save-file-name file
))
118 (newest (if (file-newer-than-file-p file auto
) file auto
))
119 (nntp-server-buffer (or buffer nntp-server-buffer
)))
120 (when (and (file-exists-p newest
)
121 (let ((nnmail-file-coding-system
122 (if (file-newer-than-file-p file auto
)
123 (if (member group
'("drafts" "delayed"))
124 message-draft-coding-system
125 mm-text-coding-system
)
126 mm-auto-save-coding-system
)))
127 (nnmail-find-file newest
)))
128 (with-current-buffer nntp-server-buffer
129 (goto-char (point-min))
130 ;; If there's a mail header separator in this file,
132 (when (re-search-forward
133 (concat "^" (regexp-quote mail-header-separator
) "$") nil t
)
134 (replace-match "" t t
)))
137 (deffoo nndraft-request-restore-buffer
(article &optional group server
)
138 "Request a new buffer that is restored to the state of ARTICLE."
139 (nndraft-possibly-change-group group
)
140 (when (nndraft-request-article article group server
(current-buffer))
141 (message-remove-header "xref")
142 (message-remove-header "lines")
143 ;; Articles in nndraft:queue are considered as sent messages. The
144 ;; Date field should be the time when they are sent.
145 ;;(message-remove-header "date")
148 (deffoo nndraft-request-update-info
(group info
&optional server
)
149 (nndraft-possibly-change-group group
)
152 (gnus-update-read-articles (gnus-group-prefixed-name group
'(nndraft ""))
153 (nndraft-articles) t
))
154 (let ((marks (nth 3 info
)))
156 ;; Nix out all marks except the `unsend'-able article marks.
157 (setcar (nthcdr 3 info
)
158 (if (assq 'unsend marks
)
159 (list (assq 'unsend marks
))
163 (defun nndraft-generate-headers ()
165 (message-generate-headers
166 (message-headers-to-generate
167 nndraft-required-headers message-draft-headers nil
))))
169 (defun nndraft-update-unread-articles ()
170 "Update groups' unread articles in the group buffer."
171 (nndraft-request-list)
172 (with-current-buffer gnus-group-buffer
173 (let* ((groups (mapcar (lambda (elem)
174 (gnus-group-prefixed-name (car elem
)
176 (nnmail-get-active)))
177 (gnus-group-marked (copy-sequence groups
))
178 ;; Don't send delayed articles.
179 (gnus-get-new-news-hook nil
)
180 (inhibit-read-only t
))
181 (gnus-group-get-new-news-this-group nil t
)
183 (dolist (group groups
)
184 (unless (and gnus-permanently-visible-groups
185 (string-match gnus-permanently-visible-groups
187 (gnus-group-goto-group group
)
188 (when (zerop (gnus-group-group-unread))
189 (gnus-delete-line))))))))
191 (deffoo nndraft-request-associate-buffer
(group)
192 "Associate the current buffer with some article in the draft group."
193 (nndraft-open-server "")
194 (nndraft-request-group group
)
195 (nndraft-possibly-change-group group
)
196 (let ((gnus-verbose-backends nil
)
197 (buf (current-buffer))
200 (insert-buffer-substring buf
)
201 (setq article
(nndraft-request-accept-article
202 group
(nnoo-current-server 'nndraft
) t
'noinsert
)
203 file
(nndraft-article-filename article
)))
204 (setq buffer-file-name
(expand-file-name file
)
205 buffer-auto-save-file-name
(make-auto-save-file-name))
206 (clear-visited-file-modtime)
207 (add-hook 'write-contents-functions
'nndraft-generate-headers nil t
)
208 (add-hook 'after-save-hook
'nndraft-update-unread-articles nil t
)
209 (message-add-action '(nndraft-update-unread-articles)
210 'exit
'postpone
'kill
)
213 (deffoo nndraft-request-group
(group &optional server dont-check info
)
214 (nndraft-possibly-change-group group
)
216 (let* ((pathname (nnmail-group-pathname group nndraft-directory
))
217 (file-name-coding-system nnmail-pathname-coding-system
)
219 (nnheader-re-read-dir pathname
)
220 (setq dir
(mapcar (lambda (name) (string-to-number (substring name
1)))
221 (ignore-errors (directory-files
222 pathname nil
"^#[0-9]+#$" t
))))
224 (unless (file-exists-p
225 (setq file
(expand-file-name (int-to-string n
) pathname
)))
226 (rename-file (nndraft-auto-save-file-name file
) file
)))))
227 (nnoo-parent-function 'nndraft
229 (list group server dont-check
)))
231 (deffoo nndraft-request-move-article
(article group server accept-form
232 &optional last move-is-internal
)
233 (nndraft-possibly-change-group group
)
234 (let ((buf (get-buffer-create " *nndraft move*"))
237 (nndraft-request-article article group server
)
238 (with-current-buffer buf
240 (insert-buffer-substring nntp-server-buffer
)
241 (setq result
(eval accept-form
))
242 (kill-buffer (current-buffer))
244 (null (nndraft-request-expire-articles (list article
) group server
'force
))
247 (deffoo nndraft-request-expire-articles
(articles group
&optional server force
)
248 (nndraft-possibly-change-group group
)
249 (let* ((nnmh-allow-delete-final t
)
250 (nnmail-expiry-target 'delete
)
251 ;; FIXME: If we want to move a draft message to an expiry group,
252 ;; there are things to have to improve:
253 ;; - Remove a header separator.
254 ;; - Encode it, including attachments, into a MIME message.
255 ;;(nnmail-expiry-target
256 ;; (or (gnus-group-find-parameter
257 ;; (gnus-group-prefixed-name group (list 'nndraft server))
259 ;; nnmail-expiry-target))
260 (res (nnoo-parent-function 'nndraft
261 'nnmh-request-expire-articles
262 (list articles group server force
)))
264 ;; Delete all the "state" files of articles that have been expired.
266 (unless (memq (setq article
(pop articles
)) res
)
267 (let ((auto (nndraft-auto-save-file-name
268 (nndraft-article-filename article
))))
269 (when (file-exists-p auto
)
270 (funcall nnmail-delete-file-function auto
)))
272 (let ((kept-new-versions 1)
273 (kept-old-versions 0))
274 (find-backup-file-name
275 (nndraft-article-filename article
))))
276 (when (file-exists-p backup
)
277 (funcall nnmail-delete-file-function backup
)))))
280 (deffoo nndraft-request-accept-article
(group &optional server last noinsert
)
281 (nndraft-possibly-change-group group
)
282 (let ((gnus-verbose-backends nil
))
283 (nnoo-parent-function 'nndraft
'nnmh-request-accept-article
284 (list group server last noinsert
))))
286 (deffoo nndraft-request-replace-article
(article group buffer
)
287 (nndraft-possibly-change-group group
)
288 (let ((nnmail-file-coding-system
289 (if (member group
'("drafts" "delayed"))
290 message-draft-coding-system
291 mm-text-coding-system
)))
292 (nnoo-parent-function 'nndraft
'nnmh-request-replace-article
293 (list article group buffer
))))
295 (deffoo nndraft-request-create-group
(group &optional server args
)
296 (nndraft-possibly-change-group group
)
297 (if (file-exists-p nndraft-current-directory
)
298 (if (file-directory-p nndraft-current-directory
)
303 (gnus-make-directory nndraft-current-directory
)
308 ;;; Low-Level Interface
310 (defun nndraft-possibly-change-group (group)
312 (not (equal group nndraft-current-group
)))
313 (nndraft-open-server "")
314 (setq nndraft-current-group group
)
315 (setq nndraft-current-directory
316 (nnheader-concat nndraft-directory group
))))
318 (defun nndraft-article-filename (article &rest args
)
320 (file-name-as-directory nndraft-current-directory
)
321 (int-to-string article
)
324 (defun nndraft-auto-save-file-name (file)
328 (set-buffer (get-buffer-create " *draft tmp*"))
329 (setq buffer-file-name file
)
330 (make-auto-save-file-name))
331 (kill-buffer (current-buffer)))))
333 (defun nndraft-articles ()
334 "Return the list of messages in the group."
335 (gnus-make-directory nndraft-current-directory
)
337 (mapcar 'string-to-number
338 (directory-files nndraft-current-directory nil
"\\`[0-9]+\\'" t
))
343 nnmh-retrieve-headers
350 ;;; nndraft.el ends here