1 ;;; nnmbox.el --- mail mbox access for Gnus
3 ;; Copyright (C) 1995 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
6 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
7 ;; Keywords: news, mail
9 ;; This file is part of GNU Emacs.
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 2, or (at your option)
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.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
28 ;; For an overview of what the interface functions do, please see the
37 (defvar nnmbox-mbox-file
(expand-file-name "~/mbox")
38 "The name of the mail box file in the user's home directory.")
40 (defvar nnmbox-active-file
(expand-file-name "~/.mbox-active")
41 "The name of the active file for the mail box.")
43 (defvar nnmbox-get-new-mail t
44 "If non-nil, nnmbox will check the incoming mail file and split the mail.")
46 (defvar nnmbox-prepare-save-mail-hook nil
47 "Hook run narrowed to an article before saving.")
51 (defconst nnmbox-version
"nnmbox 1.0"
54 (defvar nnmbox-current-group nil
55 "Current nnmbox news group directory.")
57 (defconst nnmbox-mbox-buffer nil
)
59 (defvar nnmbox-status-string
"")
61 (defvar nnmbox-group-alist nil
)
62 (defvar nnmbox-active-timestamp nil
)
66 (defvar nnmbox-current-server nil
)
67 (defvar nnmbox-server-alist nil
)
68 (defvar nnmbox-server-variables
70 (list 'nnmbox-mbox-file nnmbox-mbox-file
)
71 (list 'nnmbox-active-file nnmbox-active-file
)
72 (list 'nnmbox-get-new-mail nnmbox-get-new-mail
)
73 '(nnmbox-current-group nil
)
74 '(nnmbox-status-string "")
75 '(nnmbox-group-alist nil
)))
79 ;;; Interface functions
81 (defun nnmbox-retrieve-headers (sequence &optional newsgroup server
)
83 (set-buffer nntp-server-buffer
)
85 (let ((number (length sequence
))
87 article art-string start stop
)
88 (nnmbox-possibly-change-newsgroup newsgroup
)
89 (if (stringp (car sequence
))
92 (setq article
(car sequence
))
93 (setq art-string
(nnmbox-article-string article
))
94 (set-buffer nnmbox-mbox-buffer
)
95 (if (or (search-forward art-string nil t
)
96 (progn (goto-char (point-min))
97 (search-forward art-string nil t
)))
102 (concat "^" rmail-unix-mail-delimiter
) nil t
)
104 (search-forward "\n\n" nil t
)
105 (setq stop
(1- (point)))
106 (set-buffer nntp-server-buffer
)
107 (insert (format "221 %d Article retrieved.\n" article
))
108 (insert-buffer-substring nnmbox-mbox-buffer start stop
)
109 (goto-char (point-max))
111 (setq sequence
(cdr sequence
))
112 (setq count
(1+ count
))
113 (and (numberp nnmail-large-newsgroup
)
114 (> number nnmail-large-newsgroup
)
116 gnus-verbose-backends
117 (message "nnmbox: Receiving headers... %d%%"
118 (/ (* count
100) number
))))
120 (and (numberp nnmail-large-newsgroup
)
121 (> number nnmail-large-newsgroup
)
122 gnus-verbose-backends
123 (message "nnmbox: Receiving headers...done"))
125 ;; Fold continuation lines.
126 (set-buffer nntp-server-buffer
)
127 (goto-char (point-min))
128 (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t
)
129 (replace-match " " t t
))
132 (defun nnmbox-open-server (server &optional defs
)
133 (nnheader-init-server-buffer)
134 (if (equal server nnmbox-current-server
)
136 (if nnmbox-current-server
137 (setq nnmbox-server-alist
138 (cons (list nnmbox-current-server
139 (nnheader-save-variables nnmbox-server-variables
))
140 nnmbox-server-alist
)))
141 (let ((state (assoc server nnmbox-server-alist
)))
144 (nnheader-restore-variables (nth 1 state
))
145 (setq nnmbox-server-alist
(delq state nnmbox-server-alist
)))
146 (nnheader-set-init-variables nnmbox-server-variables defs
)))
147 (setq nnmbox-current-server server
)))
149 (defun nnmbox-close-server (&optional server
)
152 (defun nnmbox-server-opened (&optional server
)
153 (and (equal server nnmbox-current-server
)
155 (buffer-name nnmbox-mbox-buffer
)
157 (buffer-name nntp-server-buffer
)))
159 (defun nnmbox-status-message (&optional server
)
160 nnmbox-status-string
)
162 (defun nnmbox-request-article (article &optional newsgroup server buffer
)
163 (nnmbox-possibly-change-newsgroup newsgroup
)
164 (if (stringp article
)
167 (set-buffer nnmbox-mbox-buffer
)
168 (goto-char (point-min))
169 (if (search-forward (nnmbox-article-string article
) nil t
)
171 (re-search-backward (concat "^" rmail-unix-mail-delimiter
) nil t
)
174 (or (and (re-search-forward
175 (concat "^" rmail-unix-mail-delimiter
) nil t
)
177 (goto-char (point-max)))
179 (let ((nntp-server-buffer (or buffer nntp-server-buffer
)))
180 (set-buffer nntp-server-buffer
)
182 (insert-buffer-substring nnmbox-mbox-buffer start stop
)
183 (goto-char (point-min))
184 (while (looking-at "From ")
186 (insert "X-From-Line: ")
190 (defun nnmbox-request-group (group &optional server dont-check
)
192 (if (nnmbox-possibly-change-newsgroup group
)
195 (nnmbox-get-new-mail group
)
197 (set-buffer nntp-server-buffer
)
199 (let ((active (assoc group nnmbox-group-alist
)))
200 (insert (format "211 %d %d %d %s\n"
201 (1+ (- (cdr (car (cdr active
)))
202 (car (car (cdr active
)))))
203 (car (car (cdr active
)))
204 (cdr (car (cdr active
)))
208 (defun nnmbox-close-group (group &optional server
)
211 (defun nnmbox-request-list (&optional server
)
212 (if server
(nnmbox-get-new-mail))
214 (or (nnmail-find-file nnmbox-active-file
)
216 (setq nnmbox-group-alist
(nnmail-get-active))
217 (nnmail-save-active nnmbox-group-alist nnmbox-active-file
)
218 (nnmail-find-file nnmbox-active-file
)))))
220 (defun nnmbox-request-newgroups (date &optional server
)
221 (nnmbox-request-list server
))
223 (defun nnmbox-request-list-newsgroups (&optional server
)
224 (setq nnmbox-status-string
"nnmbox: LIST NEWSGROUPS is not implemented.")
227 (defun nnmbox-request-post (&optional server
)
228 (mail-send-and-exit nil
))
230 (defalias 'nnmbox-request-post-buffer
'nnmail-request-post-buffer
)
232 (defun nnmbox-request-expire-articles
233 (articles newsgroup
&optional server force
)
234 (nnmbox-possibly-change-newsgroup newsgroup
)
235 (let* ((days (or (and nnmail-expiry-wait-function
236 (funcall nnmail-expiry-wait-function newsgroup
))
240 (nnmail-activate 'nnmbox
)
243 (set-buffer nnmbox-mbox-buffer
)
244 (while (and articles is-old
)
245 (goto-char (point-min))
246 (if (search-forward (nnmbox-article-string (car articles
)) nil t
)
249 (> (nnmail-days-between
250 (current-time-string)
252 (point) (progn (end-of-line) (point))))
255 (and gnus-verbose-backends
256 (message "Deleting article %s..." (car articles
)))
257 (nnmbox-delete-mail))
258 (setq rest
(cons (car articles
) rest
))))
259 (setq articles
(cdr articles
)))
261 ;; Find the lowest active article in this group.
262 (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist
))))
263 (goto-char (point-min))
264 (while (and (not (search-forward
265 (nnmbox-article-string (car active
)) nil t
))
266 (<= (car active
) (cdr active
)))
267 (setcar active
(1+ (car active
)))
268 (goto-char (point-min))))
269 (nnmail-save-active nnmbox-group-alist nnmbox-active-file
)
270 (nconc rest articles
))))
272 (defun nnmbox-request-move-article
273 (article group server accept-form
&optional last
)
274 (nnmbox-possibly-change-newsgroup group
)
275 (let ((buf (get-buffer-create " *nnmbox move*"))
278 (nnmbox-request-article article group server
)
281 (buffer-disable-undo (current-buffer))
283 (insert-buffer-substring nntp-server-buffer
)
284 (goto-char (point-min))
285 (while (re-search-forward
287 (save-excursion (search-forward "\n\n" nil t
) (point)) t
)
288 (delete-region (progn (beginning-of-line) (point))
289 (progn (forward-line 1) (point))))
290 (setq result
(eval accept-form
))
294 (set-buffer nnmbox-mbox-buffer
)
295 (goto-char (point-min))
296 (if (search-forward (nnmbox-article-string article
) nil t
)
297 (nnmbox-delete-mail))
298 (and last
(save-buffer))))
301 (defun nnmbox-request-accept-article (group &optional last
)
302 (let ((buf (current-buffer))
304 (goto-char (point-min))
305 (if (looking-at "X-From-Line: ")
306 (replace-match "From ")
307 (insert "From nobody " (current-time-string) "\n"))
309 (nnmail-activate 'nnmbox
)
312 (goto-char (point-min))
313 (search-forward "\n\n" nil t
)
315 (while (re-search-backward "^X-Gnus-Newsgroup: " nil t
)
316 (delete-region (point) (progn (forward-line 1) (point))))
317 (setq result
(nnmbox-save-mail (and (stringp group
) group
))))
319 (set-buffer nnmbox-mbox-buffer
)
320 (insert-buffer-substring buf
)
321 (and last
(save-buffer))
323 (nnmail-save-active nnmbox-group-alist nnmbox-active-file
))
326 (defun nnmbox-request-replace-article (article group buffer
)
327 (nnmbox-possibly-change-newsgroup group
)
329 (set-buffer nnmbox-mbox-buffer
)
330 (goto-char (point-min))
331 (if (not (search-forward (nnmbox-article-string article
) nil t
))
333 (nnmbox-delete-mail t t
)
334 (insert-buffer-substring buffer
)
339 ;;; Internal functions.
341 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
342 ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
344 (defun nnmbox-delete-mail (&optional force leave-delim
)
345 ;; Delete the current X-Gnus-Newsgroup line.
348 (progn (beginning-of-line) (point))
349 (progn (forward-line 1) (point))))
350 ;; Beginning of the article.
355 (re-search-backward (concat "^" rmail-unix-mail-delimiter
) nil t
)
356 (if leave-delim
(progn (forward-line 1) (point))
357 (match-beginning 0)))
360 (or (and (re-search-forward (concat "^" rmail-unix-mail-delimiter
)
362 (if (and (not (bobp)) leave-delim
)
363 (progn (forward-line -
2) (point))
364 (match-beginning 0)))
366 (goto-char (point-min))
367 ;; Only delete the article if no other groups owns it as well.
368 (if (or force
(not (re-search-forward "^X-Gnus-Newsgroup: " nil t
)))
369 (delete-region (point-min) (point-max))))))
371 (defun nnmbox-possibly-change-newsgroup (newsgroup)
372 (if (or (not nnmbox-mbox-buffer
)
373 (not (buffer-name nnmbox-mbox-buffer
)))
375 (set-buffer (setq nnmbox-mbox-buffer
376 (nnheader-find-file-noselect
377 nnmbox-mbox-file nil
'raw
)))
378 (buffer-disable-undo (current-buffer))))
379 (if (not nnmbox-group-alist
)
380 (nnmail-activate 'nnmbox
))
382 (if (assoc newsgroup nnmbox-group-alist
)
383 (setq nnmbox-current-group newsgroup
))))
385 (defun nnmbox-article-string (article)
386 (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group
":"
387 (int-to-string article
) " "))
389 (defun nnmbox-save-mail (&optional group
)
390 "Called narrowed to an article."
391 (let* ((nnmail-split-methods
392 (if group
(list (list group
"")) nnmail-split-methods
))
393 (group-art (nreverse (nnmail-article-group 'nnmbox-active-number
))))
394 (nnmail-insert-lines)
395 (nnmail-insert-xref group-art
)
396 (nnmbox-insert-newsgroup-line group-art
)
397 (run-hooks 'nnml-prepare-save-mail-hook
)
400 (defun nnmbox-insert-newsgroup-line (group-art)
402 (goto-char (point-min))
403 (if (search-forward "\n\n" nil t
)
407 (insert (format "X-Gnus-Newsgroup: %s:%d %s\n"
408 (car (car group-art
)) (cdr (car group-art
))
409 (current-time-string)))
410 (setq group-art
(cdr group-art
)))))
413 (defun nnmbox-active-number (group)
414 ;; Find the next article number in GROUP.
415 (let ((active (car (cdr (assoc group nnmbox-group-alist
)))))
417 (setcdr active
(1+ (cdr active
)))
418 ;; This group is new, so we create a new entry for it.
419 ;; This might be a bit naughty... creating groups on the drop of
420 ;; a hat, but I don't know...
421 (setq nnmbox-group-alist
(cons (list group
(setq active
(cons 1 1)))
422 nnmbox-group-alist
)))
425 (defun nnmbox-read-mbox ()
426 (nnmail-activate 'nnmbox
)
427 (if (not (file-exists-p nnmbox-mbox-file
))
428 (write-region 1 1 nnmbox-mbox-file t
'nomesg
))
429 (if (and nnmbox-mbox-buffer
430 (buffer-name nnmbox-mbox-buffer
)
432 (set-buffer nnmbox-mbox-buffer
)
433 (= (buffer-size) (nth 7 (file-attributes nnmbox-mbox-file
)))))
436 (let ((delim (concat "^" rmail-unix-mail-delimiter
))
438 (set-buffer (setq nnmbox-mbox-buffer
439 (nnheader-find-file-noselect
440 nnmbox-mbox-file nil
'raw
)))
441 (buffer-disable-undo (current-buffer))
442 (goto-char (point-min))
443 (while (re-search-forward delim nil t
)
444 (setq start
(match-beginning 0))
445 (if (not (search-forward "\nX-Gnus-Newsgroup: "
450 (re-search-forward delim nil t
)
456 (narrow-to-region start end
)
457 (nnmbox-save-mail))))
460 (defun nnmbox-get-new-mail (&optional group
)
461 "Read new incoming mail."
462 (let* ((spools (nnmail-get-spool-files group
))
466 (if (or (not nnmbox-get-new-mail
) (not nnmail-spool-file
))
468 ;; We go through all the existing spool files and split the
472 (file-exists-p (car spools
))
473 (> (nth 7 (file-attributes (car spools
))) 0)
475 (and gnus-verbose-backends
476 (message "nnmbox: Reading incoming mail..."))
477 (if (not (setq incoming
480 (concat nnmbox-mbox-file
"-Incoming"))))
482 (setq incomings
(cons incoming incomings
))
484 (setq group
(nnmail-get-split-group (car spools
) group-in
))
485 (let ((in-buf (nnmail-split-incoming
486 incoming
'nnmbox-save-mail t group
)))
487 (set-buffer nnmbox-mbox-buffer
)
488 (goto-char (point-max))
489 (insert-buffer-substring in-buf
)
490 (kill-buffer in-buf
))))))
491 (setq spools
(cdr spools
)))
492 ;; If we did indeed read any incoming spools, we save all info.
493 (and (buffer-modified-p nnmbox-mbox-buffer
)
495 (nnmail-save-active nnmbox-group-alist nnmbox-active-file
)
496 (set-buffer nnmbox-mbox-buffer
)
498 (if incomings
(run-hooks 'nnmail-read-incoming-hook
))
500 (setq incoming
(car incomings
))
501 (and nnmail-delete-incoming
502 (file-exists-p incoming
)
503 (file-writable-p incoming
)
504 (delete-file incoming
))
505 (setq incomings
(cdr incomings
))))))
510 ;;; nnmbox.el ends here