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 (unless (eq nnmail-expiry-target
'delete
)
267 (nnmbox-request-article (car articles
)
270 (let ((nnml-current-directory nil
))
271 (nnmail-expiry-target-group
272 nnmail-expiry-target newsgroup
))))
273 (nnheader-message 5 "Deleting article %d in %s..."
274 (car articles
) newsgroup
)
275 (nnmbox-delete-mail))
276 (push (car articles
) rest
)))
277 (setq articles
(cdr articles
)))
279 ;; Find the lowest active article in this group.
280 (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist
))))
281 (goto-char (point-min))
282 (while (and (not (search-forward
283 (nnmbox-article-string (car active
)) nil t
))
284 (<= (car active
) (cdr active
)))
285 (setcar active
(1+ (car active
)))
286 (goto-char (point-min))))
287 (nnmbox-save-active nnmbox-group-alist nnmbox-active-file
)
288 (nconc rest articles
))))
290 (deffoo nnmbox-request-move-article
291 (article group server accept-form
&optional last
)
292 (let ((buf (get-buffer-create " *nnmbox move*"))
295 (nnmbox-request-article article group server
)
299 (insert-buffer-substring nntp-server-buffer
)
300 (goto-char (point-min))
301 (while (re-search-forward
303 (save-excursion (search-forward "\n\n" nil t
) (point)) t
)
304 (delete-region (progn (beginning-of-line) (point))
305 (progn (forward-line 1) (point))))
306 (setq result
(eval accept-form
))
310 (nnmbox-possibly-change-newsgroup group server
)
311 (set-buffer nnmbox-mbox-buffer
)
312 (goto-char (point-min))
313 (when (search-forward (nnmbox-article-string article
) nil t
)
314 (nnmbox-delete-mail))
315 (and last
(nnmbox-save-buffer))))
318 (deffoo nnmbox-request-accept-article
(group &optional server last
)
319 (nnmbox-possibly-change-newsgroup group server
)
320 (nnmail-check-syntax)
321 (let ((buf (current-buffer))
323 (goto-char (point-min))
324 ;; The From line may have been quoted by movemail.
325 (when (looking-at (concat ">" message-unix-mail-delimiter
))
327 (if (looking-at "X-From-Line: ")
328 (replace-match "From ")
329 (insert "From nobody " (current-time-string) "\n"))
331 (nnmail-activate 'nnmbox
)
334 (goto-char (point-min))
335 (search-forward "\n\n" nil t
)
337 (while (re-search-backward "^X-Gnus-Newsgroup: " nil t
)
338 (delete-region (point) (progn (forward-line 1) (point))))
339 (when nnmail-cache-accepted-message-ids
340 (nnmail-cache-insert (nnmail-fetch-field "message-id")))
341 (setq result
(if (stringp group
)
342 (list (cons group
(nnmbox-active-number group
)))
343 (nnmail-article-group 'nnmbox-active-number
)))
344 (if (and (null result
)
345 (yes-or-no-p "Moved to `junk' group; delete article? "))
347 (setq result
(car (nnmbox-save-mail result
)))))
349 (set-buffer nnmbox-mbox-buffer
)
350 (goto-char (point-max))
351 (insert-buffer-substring buf
)
353 (when nnmail-cache-accepted-message-ids
354 (nnmail-cache-close))
355 (nnmbox-save-active nnmbox-group-alist nnmbox-active-file
)
356 (nnmbox-save-buffer))))
359 (deffoo nnmbox-request-replace-article
(article group buffer
)
360 (nnmbox-possibly-change-newsgroup group
)
362 (set-buffer nnmbox-mbox-buffer
)
363 (goto-char (point-min))
364 (if (not (search-forward (nnmbox-article-string article
) nil t
))
366 (nnmbox-delete-mail t t
)
367 (insert-buffer-substring buffer
)
371 (deffoo nnmbox-request-delete-group
(group &optional force server
)
372 (nnmbox-possibly-change-newsgroup group server
)
373 ;; Delete all articles in GROUP.
375 () ; Don't delete the articles.
377 (set-buffer nnmbox-mbox-buffer
)
378 (goto-char (point-min))
379 ;; Delete all articles in this group.
380 (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group
":"))
382 (while (search-forward ident nil t
)
384 (nnmbox-delete-mail))
386 (nnmbox-save-buffer)))))
387 ;; Remove the group from all structures.
388 (setq nnmbox-group-alist
389 (delq (assoc group nnmbox-group-alist
) nnmbox-group-alist
)
390 nnmbox-current-group nil
)
391 ;; Save the active file.
392 (nnmbox-save-active nnmbox-group-alist nnmbox-active-file
)
395 (deffoo nnmbox-request-rename-group
(group new-name
&optional server
)
396 (nnmbox-possibly-change-newsgroup group server
)
398 (set-buffer nnmbox-mbox-buffer
)
399 (goto-char (point-min))
400 (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group
":"))
401 (new-ident (concat "\nX-Gnus-Newsgroup: " new-name
":"))
403 (while (search-forward ident nil t
)
404 (replace-match new-ident t t
)
407 (nnmbox-save-buffer))))
408 (let ((entry (assoc group nnmbox-group-alist
)))
410 (setcar entry new-name
))
411 (setq nnmbox-current-group nil
)
412 ;; Save the new group alist.
413 (nnmbox-save-active nnmbox-group-alist nnmbox-active-file
)
417 ;;; Internal functions.
419 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
420 ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
422 (defun nnmbox-delete-mail (&optional force leave-delim
)
423 ;; Delete the current X-Gnus-Newsgroup line.
426 (progn (beginning-of-line) (point))
427 (progn (forward-line 1) (point))))
428 ;; Beginning of the article.
433 (re-search-backward (concat "^" message-unix-mail-delimiter
) nil t
)
434 (if leave-delim
(progn (forward-line 1) (point))
435 (match-beginning 0)))
438 (or (and (re-search-forward (concat "^" message-unix-mail-delimiter
)
440 (if (and (not (bobp)) leave-delim
)
441 (progn (forward-line -
2) (point))
442 (match-beginning 0)))
444 (goto-char (point-min))
445 ;; Only delete the article if no other groups owns it as well.
446 (when (or force
(not (re-search-forward "^X-Gnus-Newsgroup: " nil t
)))
447 (delete-region (point-min) (point-max))))))
449 (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server
)
451 (not (nnmbox-server-opened server
)))
452 (nnmbox-open-server server
))
453 (when (or (not nnmbox-mbox-buffer
)
454 (not (buffer-name nnmbox-mbox-buffer
)))
456 (set-buffer (setq nnmbox-mbox-buffer
457 (let ((nnheader-file-coding-system
458 nnmbox-file-coding-system
))
459 (nnheader-find-file-noselect
460 nnmbox-mbox-file nil t
))))
461 (mm-enable-multibyte)
462 (buffer-disable-undo)))
463 (when (not nnmbox-group-alist
)
464 (nnmail-activate 'nnmbox
))
466 (when (assoc newsgroup nnmbox-group-alist
)
467 (setq nnmbox-current-group newsgroup
))
470 (defun nnmbox-article-string (article)
471 (if (numberp article
)
472 (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group
":"
473 (int-to-string article
) " ")
474 (concat "\nMessage-ID: " article
)))
476 (defun nnmbox-article-group-number ()
478 (goto-char (point-min))
479 (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
481 (cons (buffer-substring (match-beginning 1) (match-end 1))
483 (buffer-substring (match-beginning 2) (match-end 2)))))))
485 (defun nnmbox-save-mail (group-art)
486 "Called narrowed to an article."
487 (let ((delim (concat "^" message-unix-mail-delimiter
)))
488 (goto-char (point-min))
489 ;; This might come from somewhere else.
490 (unless (looking-at delim
)
491 (insert "From nobody " (current-time-string) "\n")
492 (goto-char (point-min)))
493 ;; Quote all "From " lines in the article.
495 (while (re-search-forward delim nil t
)
498 (nnmail-insert-lines)
499 (nnmail-insert-xref group-art
)
500 (nnmbox-insert-newsgroup-line group-art
)
501 (run-hooks 'nnmail-prepare-save-mail-hook
)
502 (run-hooks 'nnmbox-prepare-save-mail-hook
)
505 (defun nnmbox-insert-newsgroup-line (group-art)
507 (goto-char (point-min))
508 (when (search-forward "\n\n" nil t
)
511 (insert (format "X-Gnus-Newsgroup: %s:%d %s\n"
512 (caar group-art
) (cdar group-art
)
513 (current-time-string)))
514 (setq group-art
(cdr group-art
))))
517 (defun nnmbox-active-number (group)
518 ;; Find the next article number in GROUP.
519 (let ((active (cadr (assoc group nnmbox-group-alist
))))
521 (setcdr active
(1+ (cdr active
)))
522 ;; This group is new, so we create a new entry for it.
523 ;; This might be a bit naughty... creating groups on the drop of
524 ;; a hat, but I don't know...
525 (push (list group
(setq active
(cons 1 1)))
529 (defun nnmbox-create-mbox ()
530 (when (not (file-exists-p nnmbox-mbox-file
))
531 (let ((nnmail-file-coding-system
532 (or nnmbox-file-coding-system-for-write
533 nnmbox-file-coding-system
)))
534 (nnmail-write-region (point-min) (point-min)
535 nnmbox-mbox-file t
'nomesg
))))
537 (defun nnmbox-read-mbox ()
538 (nnmail-activate 'nnmbox
)
540 (if (and nnmbox-mbox-buffer
541 (buffer-name nnmbox-mbox-buffer
)
543 (set-buffer nnmbox-mbox-buffer
)
544 (= (buffer-size) (nnheader-file-size nnmbox-mbox-file
))))
547 (let ((delim (concat "^" message-unix-mail-delimiter
))
548 (alist nnmbox-group-alist
)
550 (set-buffer (setq nnmbox-mbox-buffer
551 (let ((nnheader-file-coding-system
552 nnmbox-file-coding-system
))
553 (nnheader-find-file-noselect
554 nnmbox-mbox-file nil t
))))
555 (mm-enable-multibyte)
556 (buffer-disable-undo)
558 ;; Go through the group alist and compare against
561 (goto-char (point-max))
562 (when (and (re-search-backward
563 (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
568 (match-beginning 1) (match-end 1))))
570 (setcdr (cadar alist
) number
))
571 (setq alist
(cdr alist
)))
573 (goto-char (point-min))
574 (while (re-search-forward delim nil t
)
575 (setq start
(match-beginning 0))
576 (unless (search-forward
577 "\nX-Gnus-Newsgroup: "
582 ;; skip to end of headers first, since mail
583 ;; which has been respooled has additional
584 ;; "From nobody" lines.
585 (search-forward "\n\n" nil t
)
586 (re-search-forward delim nil t
)
592 (narrow-to-region start end
)
594 (nnmail-article-group 'nnmbox-active-number
)))))
599 ;;; nnmbox.el ends here