1 ;;; nnmbox.el --- mail mbox access for Gnus
3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
4 ;; Free Software Foundation, Inc.
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
8 ;; Keywords: news, mail
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with GNU Emacs; see the file COPYING. If not, write to the
19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 ;; Boston, MA 02111-1307, USA.
24 ;; For an overview of what the interface functions do, please see the
33 (eval-when-compile (require 'cl
))
37 (defvoo nnmbox-mbox-file
(expand-file-name "~/mbox")
38 "The name of the mail box file in the user's home directory.")
40 (defvoo nnmbox-active-file
(expand-file-name "~/.mbox-active")
41 "The name of the active file for the mail box.")
43 (defvoo nnmbox-get-new-mail t
44 "If non-nil, nnmbox will check the incoming mail file and split the mail.")
46 (defvoo nnmbox-prepare-save-mail-hook nil
47 "Hook run narrowed to an article before saving.")
51 (defconst nnmbox-version
"nnmbox 1.0"
54 (defvoo nnmbox-current-group nil
55 "Current nnmbox news group directory.")
57 (defconst nnmbox-mbox-buffer nil
)
59 (defvoo nnmbox-status-string
"")
61 (defvoo nnmbox-group-alist nil
)
62 (defvoo nnmbox-active-timestamp nil
)
64 (defvoo nnmbox-file-coding-system mm-binary-coding-system
)
65 (defvoo nnmbox-file-coding-system-for-write nil
)
66 (defvoo nnmbox-active-file-coding-system mm-binary-coding-system
)
67 (defvoo nnmbox-active-file-coding-system-for-write nil
)
71 ;;; Interface functions
73 (nnoo-define-basics nnmbox
)
75 (deffoo nnmbox-retrieve-headers
(sequence &optional newsgroup server fetch-old
)
77 (set-buffer nntp-server-buffer
)
79 (let ((number (length sequence
))
81 article art-string start stop
)
82 (nnmbox-possibly-change-newsgroup newsgroup server
)
84 (setq article
(car sequence
))
85 (setq art-string
(nnmbox-article-string article
))
86 (set-buffer nnmbox-mbox-buffer
)
87 (when (or (search-forward art-string nil t
)
88 (progn (goto-char (point-min))
89 (search-forward art-string nil t
)))
93 (concat "^" message-unix-mail-delimiter
) nil t
)
95 (search-forward "\n\n" nil t
)
96 (setq stop
(1- (point)))
97 (set-buffer nntp-server-buffer
)
98 (insert (format "221 %d Article retrieved.\n" article
))
99 (insert-buffer-substring nnmbox-mbox-buffer start stop
)
100 (goto-char (point-max))
102 (setq sequence
(cdr sequence
))
103 (setq count
(1+ count
))
104 (and (numberp nnmail-large-newsgroup
)
105 (> number nnmail-large-newsgroup
)
107 (nnheader-message 5 "nnmbox: Receiving headers... %d%%"
108 (/ (* count
100) number
))))
110 (and (numberp nnmail-large-newsgroup
)
111 (> number nnmail-large-newsgroup
)
112 (nnheader-message 5 "nnmbox: Receiving headers...done"))
114 (set-buffer nntp-server-buffer
)
115 (nnheader-fold-continuation-lines)
118 (deffoo nnmbox-open-server
(server &optional defs
)
119 (nnoo-change-server 'nnmbox server defs
)
122 ((not (file-exists-p nnmbox-mbox-file
))
123 (nnmbox-close-server)
124 (nnheader-report 'nnmbox
"No such file: %s" nnmbox-mbox-file
))
125 ((file-directory-p nnmbox-mbox-file
)
126 (nnmbox-close-server)
127 (nnheader-report 'nnmbox
"Not a regular file: %s" nnmbox-mbox-file
))
129 (nnheader-report 'nnmbox
"Opened server %s using mbox %s" server
133 (deffoo nnmbox-close-server
(&optional server
)
134 (when (and nnmbox-mbox-buffer
135 (buffer-name nnmbox-mbox-buffer
))
136 (kill-buffer nnmbox-mbox-buffer
))
137 (nnoo-close-server 'nnmbox server
)
140 (deffoo nnmbox-server-opened
(&optional server
)
141 (and (nnoo-current-server-p 'nnmbox server
)
143 (buffer-name nnmbox-mbox-buffer
)
145 (buffer-name nntp-server-buffer
)))
147 (deffoo nnmbox-request-article
(article &optional newsgroup server buffer
)
148 (nnmbox-possibly-change-newsgroup newsgroup server
)
150 (set-buffer nnmbox-mbox-buffer
)
151 (goto-char (point-min))
152 (when (search-forward (nnmbox-article-string article
) nil t
)
154 (re-search-backward (concat "^" message-unix-mail-delimiter
) nil t
)
157 (or (and (re-search-forward
158 (concat "^" message-unix-mail-delimiter
) nil t
)
160 (goto-char (point-max)))
162 (let ((nntp-server-buffer (or buffer nntp-server-buffer
)))
163 (set-buffer nntp-server-buffer
)
165 (insert-buffer-substring nnmbox-mbox-buffer start stop
)
166 (goto-char (point-min))
167 (while (looking-at "From ")
169 (insert "X-From-Line: ")
171 (if (numberp article
)
172 (cons nnmbox-current-group article
)
173 (nnmbox-article-group-number)))))))
175 (deffoo nnmbox-request-group
(group &optional server dont-check
)
176 (nnmbox-possibly-change-newsgroup nil server
)
177 (let ((active (cadr (assoc group nnmbox-group-alist
))))
180 (null (nnmbox-possibly-change-newsgroup group server
)))
181 (nnheader-report 'nnmbox
"No such group: %s" group
))
183 (nnheader-report 'nnmbox
"Selected group %s" group
)
184 (nnheader-insert ""))
186 (nnheader-report 'nnmbox
"Selected group %s" group
)
187 (nnheader-insert "211 %d %d %d %s\n"
188 (1+ (- (cdr active
) (car active
)))
189 (car active
) (cdr active
) group
)))))
191 (defun nnmbox-save-buffer ()
192 (let ((coding-system-for-write
193 (or nnmbox-file-coding-system-for-write
194 nnmbox-file-coding-system
)))
197 (defun nnmbox-save-active (group-alist active-file
)
198 (let ((nnmail-active-file-coding-system
199 (or nnmbox-active-file-coding-system-for-write
200 nnmbox-active-file-coding-system
)))
201 (nnmail-save-active group-alist active-file
)))
203 (deffoo nnmbox-request-scan
(&optional group server
)
204 (nnmbox-possibly-change-newsgroup group server
)
210 (set-buffer nnmbox-mbox-buffer
)
211 (nnmbox-save-buffer)))
212 (file-name-directory nnmbox-mbox-file
)
216 (let ((in-buf (current-buffer)))
217 (set-buffer nnmbox-mbox-buffer
)
218 (goto-char (point-max))
219 (insert-buffer-substring in-buf
)))
220 (nnmbox-save-active nnmbox-group-alist nnmbox-active-file
))))
222 (deffoo nnmbox-close-group
(group &optional server
)
225 (deffoo nnmbox-request-create-group
(group &optional server args
)
226 (nnmail-activate 'nnmbox
)
227 (unless (assoc group nnmbox-group-alist
)
228 (push (list group
(cons 1 0))
230 (nnmbox-save-active nnmbox-group-alist nnmbox-active-file
))
233 (deffoo nnmbox-request-list
(&optional server
)
235 (let ((nnmail-file-coding-system
236 nnmbox-active-file-coding-system
))
237 (nnmail-find-file nnmbox-active-file
))
238 (setq nnmbox-group-alist
(nnmail-get-active))
241 (deffoo nnmbox-request-newgroups
(date &optional server
)
242 (nnmbox-request-list server
))
244 (deffoo nnmbox-request-list-newsgroups
(&optional server
)
245 (nnheader-report 'nnmbox
"LIST NEWSGROUPS is not implemented."))
247 (deffoo nnmbox-request-expire-articles
248 (articles newsgroup
&optional server force
)
249 (nnmbox-possibly-change-newsgroup newsgroup server
)
252 (nnmail-activate 'nnmbox
)
255 (set-buffer nnmbox-mbox-buffer
)
256 (while (and articles is-old
)
257 (goto-char (point-min))
258 (when (search-forward (nnmbox-article-string (car articles
)) nil t
)
260 (nnmail-expired-article-p
263 (point) (progn (end-of-line) (point))) force
))
265 (nnheader-message 5 "Deleting article %d in %s..."
266 (car articles
) newsgroup
)
267 (nnmbox-delete-mail))
268 (push (car articles
) rest
)))
269 (setq articles
(cdr articles
)))
271 ;; Find the lowest active article in this group.
272 (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist
))))
273 (goto-char (point-min))
274 (while (and (not (search-forward
275 (nnmbox-article-string (car active
)) nil t
))
276 (<= (car active
) (cdr active
)))
277 (setcar active
(1+ (car active
)))
278 (goto-char (point-min))))
279 (nnmbox-save-active nnmbox-group-alist nnmbox-active-file
)
280 (nconc rest articles
))))
282 (deffoo nnmbox-request-move-article
283 (article group server accept-form
&optional last
)
284 (let ((buf (get-buffer-create " *nnmbox move*"))
287 (nnmbox-request-article article group server
)
291 (insert-buffer-substring nntp-server-buffer
)
292 (goto-char (point-min))
293 (while (re-search-forward
295 (save-excursion (search-forward "\n\n" nil t
) (point)) t
)
296 (delete-region (progn (beginning-of-line) (point))
297 (progn (forward-line 1) (point))))
298 (setq result
(eval accept-form
))
302 (nnmbox-possibly-change-newsgroup group server
)
303 (set-buffer nnmbox-mbox-buffer
)
304 (goto-char (point-min))
305 (when (search-forward (nnmbox-article-string article
) nil t
)
306 (nnmbox-delete-mail))
307 (and last
(nnmbox-save-buffer))))
310 (deffoo nnmbox-request-accept-article
(group &optional server last
)
311 (nnmbox-possibly-change-newsgroup group server
)
312 (nnmail-check-syntax)
313 (let ((buf (current-buffer))
315 (goto-char (point-min))
316 ;; The From line may have been quoted by movemail.
317 (when (looking-at (concat ">" message-unix-mail-delimiter
))
319 (if (looking-at "X-From-Line: ")
320 (replace-match "From ")
321 (insert "From nobody " (current-time-string) "\n"))
323 (nnmail-activate 'nnmbox
)
326 (goto-char (point-min))
327 (search-forward "\n\n" nil t
)
329 (while (re-search-backward "^X-Gnus-Newsgroup: " nil t
)
330 (delete-region (point) (progn (forward-line 1) (point))))
331 (when nnmail-cache-accepted-message-ids
332 (nnmail-cache-insert (nnmail-fetch-field "message-id")))
333 (setq result
(if (stringp group
)
334 (list (cons group
(nnmbox-active-number group
)))
335 (nnmail-article-group 'nnmbox-active-number
)))
336 (if (and (null result
)
337 (yes-or-no-p "Moved to `junk' group; delete article? "))
339 (setq result
(car (nnmbox-save-mail result
)))))
341 (set-buffer nnmbox-mbox-buffer
)
342 (goto-char (point-max))
343 (insert-buffer-substring buf
)
345 (when nnmail-cache-accepted-message-ids
346 (nnmail-cache-close))
347 (nnmbox-save-active nnmbox-group-alist nnmbox-active-file
)
348 (nnmbox-save-buffer))))
351 (deffoo nnmbox-request-replace-article
(article group buffer
)
352 (nnmbox-possibly-change-newsgroup group
)
354 (set-buffer nnmbox-mbox-buffer
)
355 (goto-char (point-min))
356 (if (not (search-forward (nnmbox-article-string article
) nil t
))
358 (nnmbox-delete-mail t t
)
359 (insert-buffer-substring buffer
)
363 (deffoo nnmbox-request-delete-group
(group &optional force server
)
364 (nnmbox-possibly-change-newsgroup group server
)
365 ;; Delete all articles in GROUP.
367 () ; Don't delete the articles.
369 (set-buffer nnmbox-mbox-buffer
)
370 (goto-char (point-min))
371 ;; Delete all articles in this group.
372 (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group
":"))
374 (while (search-forward ident nil t
)
376 (nnmbox-delete-mail))
378 (nnmbox-save-buffer)))))
379 ;; Remove the group from all structures.
380 (setq nnmbox-group-alist
381 (delq (assoc group nnmbox-group-alist
) nnmbox-group-alist
)
382 nnmbox-current-group nil
)
383 ;; Save the active file.
384 (nnmbox-save-active nnmbox-group-alist nnmbox-active-file
)
387 (deffoo nnmbox-request-rename-group
(group new-name
&optional server
)
388 (nnmbox-possibly-change-newsgroup group server
)
390 (set-buffer nnmbox-mbox-buffer
)
391 (goto-char (point-min))
392 (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group
":"))
393 (new-ident (concat "\nX-Gnus-Newsgroup: " new-name
":"))
395 (while (search-forward ident nil t
)
396 (replace-match new-ident t t
)
399 (nnmbox-save-buffer))))
400 (let ((entry (assoc group nnmbox-group-alist
)))
402 (setcar entry new-name
))
403 (setq nnmbox-current-group nil
)
404 ;; Save the new group alist.
405 (nnmbox-save-active nnmbox-group-alist nnmbox-active-file
)
409 ;;; Internal functions.
411 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
412 ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
414 (defun nnmbox-delete-mail (&optional force leave-delim
)
415 ;; Delete the current X-Gnus-Newsgroup line.
418 (progn (beginning-of-line) (point))
419 (progn (forward-line 1) (point))))
420 ;; Beginning of the article.
425 (re-search-backward (concat "^" message-unix-mail-delimiter
) nil t
)
426 (if leave-delim
(progn (forward-line 1) (point))
427 (match-beginning 0)))
430 (or (and (re-search-forward (concat "^" message-unix-mail-delimiter
)
432 (if (and (not (bobp)) leave-delim
)
433 (progn (forward-line -
2) (point))
434 (match-beginning 0)))
436 (goto-char (point-min))
437 ;; Only delete the article if no other groups owns it as well.
438 (when (or force
(not (re-search-forward "^X-Gnus-Newsgroup: " nil t
)))
439 (delete-region (point-min) (point-max))))))
441 (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server
)
443 (not (nnmbox-server-opened server
)))
444 (nnmbox-open-server server
))
445 (when (or (not nnmbox-mbox-buffer
)
446 (not (buffer-name nnmbox-mbox-buffer
)))
448 (set-buffer (setq nnmbox-mbox-buffer
449 (let ((nnheader-file-coding-system
450 nnmbox-file-coding-system
))
451 (nnheader-find-file-noselect
452 nnmbox-mbox-file nil t
))))
453 (mm-enable-multibyte)
454 (buffer-disable-undo)))
455 (when (not nnmbox-group-alist
)
456 (nnmail-activate 'nnmbox
))
458 (when (assoc newsgroup nnmbox-group-alist
)
459 (setq nnmbox-current-group newsgroup
))
462 (defun nnmbox-article-string (article)
463 (if (numberp article
)
464 (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group
":"
465 (int-to-string article
) " ")
466 (concat "\nMessage-ID: " article
)))
468 (defun nnmbox-article-group-number ()
470 (goto-char (point-min))
471 (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
473 (cons (buffer-substring (match-beginning 1) (match-end 1))
475 (buffer-substring (match-beginning 2) (match-end 2)))))))
477 (defun nnmbox-save-mail (group-art)
478 "Called narrowed to an article."
479 (let ((delim (concat "^" message-unix-mail-delimiter
)))
480 (goto-char (point-min))
481 ;; This might come from somewhere else.
482 (unless (looking-at delim
)
483 (insert "From nobody " (current-time-string) "\n")
484 (goto-char (point-min)))
485 ;; Quote all "From " lines in the article.
487 (while (re-search-forward delim nil t
)
490 (nnmail-insert-lines)
491 (nnmail-insert-xref group-art
)
492 (nnmbox-insert-newsgroup-line group-art
)
493 (run-hooks 'nnmail-prepare-save-mail-hook
)
494 (run-hooks 'nnmbox-prepare-save-mail-hook
)
497 (defun nnmbox-insert-newsgroup-line (group-art)
499 (goto-char (point-min))
500 (when (search-forward "\n\n" nil t
)
503 (insert (format "X-Gnus-Newsgroup: %s:%d %s\n"
504 (caar group-art
) (cdar group-art
)
505 (current-time-string)))
506 (setq group-art
(cdr group-art
))))
509 (defun nnmbox-active-number (group)
510 ;; Find the next article number in GROUP.
511 (let ((active (cadr (assoc group nnmbox-group-alist
))))
513 (setcdr active
(1+ (cdr active
)))
514 ;; This group is new, so we create a new entry for it.
515 ;; This might be a bit naughty... creating groups on the drop of
516 ;; a hat, but I don't know...
517 (push (list group
(setq active
(cons 1 1)))
521 (defun nnmbox-create-mbox ()
522 (when (not (file-exists-p nnmbox-mbox-file
))
523 (let ((nnmail-file-coding-system
524 (or nnmbox-file-coding-system-for-write
525 nnmbox-file-coding-system
)))
526 (nnmail-write-region 1 1 nnmbox-mbox-file t
'nomesg
))))
528 (defun nnmbox-read-mbox ()
529 (nnmail-activate 'nnmbox
)
531 (if (and nnmbox-mbox-buffer
532 (buffer-name nnmbox-mbox-buffer
)
534 (set-buffer nnmbox-mbox-buffer
)
535 (= (buffer-size) (nnheader-file-size nnmbox-mbox-file
))))
538 (let ((delim (concat "^" message-unix-mail-delimiter
))
539 (alist nnmbox-group-alist
)
541 (set-buffer (setq nnmbox-mbox-buffer
542 (let ((nnheader-file-coding-system
543 nnmbox-file-coding-system
))
544 (nnheader-find-file-noselect
545 nnmbox-mbox-file nil t
))))
546 (mm-enable-multibyte)
547 (buffer-disable-undo)
549 ;; Go through the group alist and compare against
552 (goto-char (point-max))
553 (when (and (re-search-backward
554 (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
559 (match-beginning 1) (match-end 1))))
561 (setcdr (cadar alist
) number
))
562 (setq alist
(cdr alist
)))
564 (goto-char (point-min))
565 (while (re-search-forward delim nil t
)
566 (setq start
(match-beginning 0))
567 (unless (search-forward
568 "\nX-Gnus-Newsgroup: "
573 ;; skip to end of headers first, since mail
574 ;; which has been respooled has additional
575 ;; "From nobody" lines.
576 (search-forward "\n\n" nil t
)
577 (re-search-forward delim nil t
)
583 (narrow-to-region start end
)
585 (nnmail-article-group 'nnmbox-active-number
)))))
590 ;;; nnmbox.el ends here