Mercurial > emacs

comparison lisp/gnus/nnmbox.el @ 88155:d7ddb3e565de

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
sync with trunk
author Henrik Enberg <henrik.enberg@telia.com>
date Mon, 16 Jan 2006 00:03:54 +0000
parents 0d8b17d428b5
children
comparison
equal deleted inserted replaced
88154:8ce476d3ba36 88155:d7ddb3e565de
1 ;;; nnmbox.el --- mail mbox access for Gnus 1 ;;; nnmbox.el --- mail mbox access for Gnus
2 2
3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 ;; Free Software Foundation, Inc. 4 ;; 2004, 2005 Free Software Foundation, Inc.
5 5
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 7 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
8 ;; Keywords: news, mail 8 ;; Keywords: news, mail
9 9
10 ;; This file is part of GNU Emacs. 10 ;; This file is part of GNU Emacs.
11 11
12 ;; GNU Emacs is free software; you can redistribute it and/or modify 12 ;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;; the Free Software Foundation; either version 2, or (at your option) 14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version. 15 ;; any later version.
16 16
17 ;; You should have received a copy of the GNU General Public License 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 18 ;; along with GNU Emacs; see the file COPYING. If not, write to the
19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 19 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 ;; Boston, MA 02111-1307, USA. 20 ;; Boston, MA 02110-1301, USA.
21 21
22 ;;; Commentary: 22 ;;; Commentary:
23 23
24 ;; For an overview of what the interface functions do, please see the 24 ;; For an overview of what the interface functions do, please see the
25 ;; Gnus sources. 25 ;; Gnus sources.
28 28
29 (require 'nnheader) 29 (require 'nnheader)
30 (require 'message) 30 (require 'message)
31 (require 'nnmail) 31 (require 'nnmail)
32 (require 'nnoo) 32 (require 'nnoo)
33 (require 'gnus-range)
33 (eval-when-compile (require 'cl)) 34 (eval-when-compile (require 'cl))
34 35
35 (nnoo-declare nnmbox) 36 (nnoo-declare nnmbox)
36 37
37 (defvoo nnmbox-mbox-file (expand-file-name "~/mbox") 38 (defvoo nnmbox-mbox-file (expand-file-name "~/mbox")
52 "nnmbox version.") 53 "nnmbox version.")
53 54
54 (defvoo nnmbox-current-group nil 55 (defvoo nnmbox-current-group nil
55 "Current nnmbox news group directory.") 56 "Current nnmbox news group directory.")
56 57
57 (defconst nnmbox-mbox-buffer nil) 58 (defvar nnmbox-mbox-buffer nil)
58 59
59 (defvoo nnmbox-status-string "") 60 (defvoo nnmbox-status-string "")
60 61
61 (defvoo nnmbox-group-alist nil) 62 (defvoo nnmbox-group-alist nil)
62 (defvoo nnmbox-active-timestamp nil) 63 (defvoo nnmbox-active-timestamp nil)
64 (defvoo nnmbox-file-coding-system mm-binary-coding-system) 65 (defvoo nnmbox-file-coding-system mm-binary-coding-system)
65 (defvoo nnmbox-file-coding-system-for-write nil) 66 (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 mm-binary-coding-system)
67 (defvoo nnmbox-active-file-coding-system-for-write nil) 68 (defvoo nnmbox-active-file-coding-system-for-write nil)
68 69
70 (defvar nnmbox-group-building-active-articles nil)
71 (defvar nnmbox-group-active-articles nil)
69 72
70 73
71 ;;; Interface functions 74 ;;; Interface functions
72 75
73 (nnoo-define-basics nnmbox) 76 (nnoo-define-basics nnmbox)
76 (save-excursion 79 (save-excursion
77 (set-buffer nntp-server-buffer) 80 (set-buffer nntp-server-buffer)
78 (erase-buffer) 81 (erase-buffer)
79 (let ((number (length sequence)) 82 (let ((number (length sequence))
80 (count 0) 83 (count 0)
81 article art-string start stop) 84 article start stop)
82 (nnmbox-possibly-change-newsgroup newsgroup server) 85 (nnmbox-possibly-change-newsgroup newsgroup server)
83 (while sequence 86 (while sequence
84 (setq article (car sequence)) 87 (setq article (car sequence))
85 (setq art-string (nnmbox-article-string article))
86 (set-buffer nnmbox-mbox-buffer) 88 (set-buffer nnmbox-mbox-buffer)
87 (when (or (search-forward art-string nil t) 89 (when (nnmbox-find-article article)
88 (progn (goto-char (point-min))
89 (search-forward art-string nil t)))
90 (setq start 90 (setq start
91 (save-excursion 91 (save-excursion
92 (re-search-backward 92 (re-search-backward
93 (concat "^" message-unix-mail-delimiter) nil t) 93 (concat "^" message-unix-mail-delimiter) nil t)
94 (point))) 94 (point)))
146 146
147 (deffoo nnmbox-request-article (article &optional newsgroup server buffer) 147 (deffoo nnmbox-request-article (article &optional newsgroup server buffer)
148 (nnmbox-possibly-change-newsgroup newsgroup server) 148 (nnmbox-possibly-change-newsgroup newsgroup server)
149 (save-excursion 149 (save-excursion
150 (set-buffer nnmbox-mbox-buffer) 150 (set-buffer nnmbox-mbox-buffer)
151 (goto-char (point-min)) 151 (when (nnmbox-find-article article)
152 (when (search-forward (nnmbox-article-string article) nil t)
153 (let (start stop) 152 (let (start stop)
154 (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) 153 (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
155 (setq start (point)) 154 (setq start (point))
156 (forward-line 1) 155 (forward-line 1)
157 (or (and (re-search-forward 156 (or (and (re-search-forward
168 (delete-char 5) 167 (delete-char 5)
169 (insert "X-From-Line: ") 168 (insert "X-From-Line: ")
170 (forward-line 1)) 169 (forward-line 1))
171 (if (numberp article) 170 (if (numberp article)
172 (cons nnmbox-current-group article) 171 (cons nnmbox-current-group article)
173 (nnmbox-article-group-number))))))) 172 (nnmbox-article-group-number nil)))))))
174 173
175 (deffoo nnmbox-request-group (group &optional server dont-check) 174 (deffoo nnmbox-request-group (group &optional server dont-check)
176 (nnmbox-possibly-change-newsgroup nil server) 175 (nnmbox-possibly-change-newsgroup nil server)
177 (let ((active (cadr (assoc group nnmbox-group-alist)))) 176 (let ((active (cadr (assoc group nnmbox-group-alist))))
178 (cond 177 (cond
252 (nnmail-activate 'nnmbox) 251 (nnmail-activate 'nnmbox)
253 252
254 (save-excursion 253 (save-excursion
255 (set-buffer nnmbox-mbox-buffer) 254 (set-buffer nnmbox-mbox-buffer)
256 (while (and articles is-old) 255 (while (and articles is-old)
257 (goto-char (point-min)) 256 (when (nnmbox-find-article (car articles))
258 (when (search-forward (nnmbox-article-string (car articles)) nil t)
259 (if (setq is-old 257 (if (setq is-old
260 (nnmail-expired-article-p 258 (nnmail-expired-article-p
261 newsgroup 259 newsgroup
262 (buffer-substring 260 (buffer-substring
263 (point) (progn (end-of-line) (point))) force)) 261 (point) (progn (end-of-line) (point))) force))
267 (nnmbox-request-article (car articles) 265 (nnmbox-request-article (car articles)
268 newsgroup server 266 newsgroup server
269 (current-buffer)) 267 (current-buffer))
270 (let ((nnml-current-directory nil)) 268 (let ((nnml-current-directory nil))
271 (nnmail-expiry-target-group 269 (nnmail-expiry-target-group
272 nnmail-expiry-target newsgroup)))) 270 nnmail-expiry-target newsgroup)))
271 (nnmbox-possibly-change-newsgroup newsgroup server))
273 (nnheader-message 5 "Deleting article %d in %s..." 272 (nnheader-message 5 "Deleting article %d in %s..."
274 (car articles) newsgroup) 273 (car articles) newsgroup)
275 (nnmbox-delete-mail)) 274 (nnmbox-delete-mail))
276 (push (car articles) rest))) 275 (push (car articles) rest)))
277 (setq articles (cdr articles))) 276 (setq articles (cdr articles)))
278 (nnmbox-save-buffer) 277 (nnmbox-save-buffer)
279 ;; Find the lowest active article in this group. 278 ;; Find the lowest active article in this group.
280 (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist)))) 279 (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
281 (goto-char (point-min)) 280 (while (and (not (nnmbox-find-article (car active)))
282 (while (and (not (search-forward
283 (nnmbox-article-string (car active)) nil t))
284 (<= (car active) (cdr active))) 281 (<= (car active) (cdr active)))
285 (setcar active (1+ (car active))) 282 (setcar active (1+ (car active)))))
286 (goto-char (point-min))))
287 (nnmbox-save-active nnmbox-group-alist nnmbox-active-file) 283 (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
288 (nconc rest articles)))) 284 (nconc rest articles))))
289 285
290 (deffoo nnmbox-request-move-article 286 (deffoo nnmbox-request-move-article
291 (article group server accept-form &optional last) 287 (article group server accept-form &optional last)
299 (insert-buffer-substring nntp-server-buffer) 295 (insert-buffer-substring nntp-server-buffer)
300 (goto-char (point-min)) 296 (goto-char (point-min))
301 (while (re-search-forward 297 (while (re-search-forward
302 "^X-Gnus-Newsgroup:" 298 "^X-Gnus-Newsgroup:"
303 (save-excursion (search-forward "\n\n" nil t) (point)) t) 299 (save-excursion (search-forward "\n\n" nil t) (point)) t)
304 (delete-region (progn (beginning-of-line) (point)) 300 (gnus-delete-line))
305 (progn (forward-line 1) (point))))
306 (setq result (eval accept-form)) 301 (setq result (eval accept-form))
307 (kill-buffer buf) 302 (kill-buffer buf)
308 result) 303 result)
309 (save-excursion 304 (save-excursion
310 (nnmbox-possibly-change-newsgroup group server) 305 (nnmbox-possibly-change-newsgroup group server)
311 (set-buffer nnmbox-mbox-buffer) 306 (set-buffer nnmbox-mbox-buffer)
312 (goto-char (point-min)) 307 (when (nnmbox-find-article article)
313 (when (search-forward (nnmbox-article-string article) nil t)
314 (nnmbox-delete-mail)) 308 (nnmbox-delete-mail))
315 (and last (nnmbox-save-buffer)))) 309 (and last (nnmbox-save-buffer))))
316 result)) 310 result))
317 311
318 (deffoo nnmbox-request-accept-article (group &optional server last) 312 (deffoo nnmbox-request-accept-article (group &optional server last)
335 (search-forward "\n\n" nil t) 329 (search-forward "\n\n" nil t)
336 (forward-line -1) 330 (forward-line -1)
337 (while (re-search-backward "^X-Gnus-Newsgroup: " nil t) 331 (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
338 (delete-region (point) (progn (forward-line 1) (point)))) 332 (delete-region (point) (progn (forward-line 1) (point))))
339 (when nnmail-cache-accepted-message-ids 333 (when nnmail-cache-accepted-message-ids
340 (nnmail-cache-insert (nnmail-fetch-field "message-id"))) 334 (nnmail-cache-insert (nnmail-fetch-field "message-id")
335 group
336 (nnmail-fetch-field "subject")
337 (nnmail-fetch-field "from")))
341 (setq result (if (stringp group) 338 (setq result (if (stringp group)
342 (list (cons group (nnmbox-active-number group))) 339 (list (cons group (nnmbox-active-number group)))
343 (nnmail-article-group 'nnmbox-active-number))) 340 (nnmail-article-group 'nnmbox-active-number)))
344 (if (and (null result) 341 (if (and (null result)
345 (yes-or-no-p "Moved to `junk' group; delete article? ")) 342 (yes-or-no-p "Moved to `junk' group; delete article? "))
358 355
359 (deffoo nnmbox-request-replace-article (article group buffer) 356 (deffoo nnmbox-request-replace-article (article group buffer)
360 (nnmbox-possibly-change-newsgroup group) 357 (nnmbox-possibly-change-newsgroup group)
361 (save-excursion 358 (save-excursion
362 (set-buffer nnmbox-mbox-buffer) 359 (set-buffer nnmbox-mbox-buffer)
363 (goto-char (point-min)) 360 (if (not (nnmbox-find-article article))
364 (if (not (search-forward (nnmbox-article-string article) nil t))
365 nil 361 nil
366 (nnmbox-delete-mail t t) 362 (nnmbox-delete-mail t t)
367 (insert-buffer-substring buffer) 363 (insert-buffer-substring buffer)
368 (nnmbox-save-buffer) 364 (nnmbox-save-buffer)
369 t))) 365 t)))
403 (while (search-forward ident nil t) 399 (while (search-forward ident nil t)
404 (replace-match new-ident t t) 400 (replace-match new-ident t t)
405 (setq found t)) 401 (setq found t))
406 (when found 402 (when found
407 (nnmbox-save-buffer)))) 403 (nnmbox-save-buffer))))
404 (let ((entry (assoc group nnmbox-group-active-articles)))
405 (when entry
406 (setcar entry new-name)))
408 (let ((entry (assoc group nnmbox-group-alist))) 407 (let ((entry (assoc group nnmbox-group-alist)))
409 (when entry 408 (when entry
410 (setcar entry new-name)) 409 (setcar entry new-name))
411 (setq nnmbox-current-group nil) 410 (setq nnmbox-current-group nil)
412 ;; Save the new group alist. 411 ;; Save the new group alist.
419 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup 418 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
420 ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox 419 ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
421 ;; delimiter line. 420 ;; delimiter line.
422 (defun nnmbox-delete-mail (&optional force leave-delim) 421 (defun nnmbox-delete-mail (&optional force leave-delim)
423 ;; Delete the current X-Gnus-Newsgroup line. 422 ;; Delete the current X-Gnus-Newsgroup line.
423 ;; First delete record of active article, unless the article is being
424 ;; replaced, indicated by FORCE being non-nil.
425 (if (not force)
426 (nnmbox-record-deleted-article (nnmbox-article-group-number t)))
424 (or force 427 (or force
425 (delete-region 428 (gnus-delete-line))
426 (progn (beginning-of-line) (point))
427 (progn (forward-line 1) (point))))
428 ;; Beginning of the article. 429 ;; Beginning of the article.
429 (save-excursion 430 (save-excursion
430 (save-restriction 431 (save-restriction
431 (narrow-to-region 432 (narrow-to-region
432 (save-excursion 433 (save-excursion
440 (if (and (not (bobp)) leave-delim) 441 (if (and (not (bobp)) leave-delim)
441 (progn (forward-line -2) (point)) 442 (progn (forward-line -2) (point))
442 (match-beginning 0))) 443 (match-beginning 0)))
443 (point-max)))) 444 (point-max))))
444 (goto-char (point-min)) 445 (goto-char (point-min))
445 ;; Only delete the article if no other groups owns it as well. 446 ;; Only delete the article if no other group owns it as well.
446 (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) 447 (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
447 (delete-region (point-min) (point-max)))))) 448 (delete-region (point-min) (point-max))))))
448 449
449 (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server) 450 (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server)
450 (when (and server 451 (when (and server
451 (not (nnmbox-server-opened server))) 452 (not (nnmbox-server-opened server)))
452 (nnmbox-open-server server)) 453 (nnmbox-open-server server))
453 (when (or (not nnmbox-mbox-buffer) 454 (when (or (not nnmbox-mbox-buffer)
454 (not (buffer-name nnmbox-mbox-buffer))) 455 (not (buffer-name nnmbox-mbox-buffer)))
455 (save-excursion 456 (nnmbox-read-mbox))
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) 457 (when (not nnmbox-group-alist)
464 (nnmail-activate 'nnmbox)) 458 (nnmail-activate 'nnmbox))
465 (if newsgroup 459 (if newsgroup
466 (when (assoc newsgroup nnmbox-group-alist) 460 (when (assoc newsgroup nnmbox-group-alist)
467 (setq nnmbox-current-group newsgroup)) 461 (setq nnmbox-current-group newsgroup))
471 (if (numberp article) 465 (if (numberp article)
472 (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":" 466 (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
473 (int-to-string article) " ") 467 (int-to-string article) " ")
474 (concat "\nMessage-ID: " article))) 468 (concat "\nMessage-ID: " article)))
475 469
476 (defun nnmbox-article-group-number () 470 (defun nnmbox-article-group-number (this-line)
477 (save-excursion 471 (save-excursion
478 (goto-char (point-min)) 472 (if this-line
473 (beginning-of-line)
474 (goto-char (point-min)))
479 (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " 475 (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
480 nil t) 476 nil t)
481 (cons (buffer-substring (match-beginning 1) (match-end 1)) 477 (cons (buffer-substring (match-beginning 1) (match-end 1))
482 (string-to-int 478 (string-to-number
483 (buffer-substring (match-beginning 2) (match-end 2))))))) 479 (buffer-substring (match-beginning 2) (match-end 2)))))))
480
481 (defun nnmbox-in-header-p (pos)
482 "Return non-nil if POS is in the header of an article."
483 (save-excursion
484 (goto-char pos)
485 (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
486 (search-forward "\n\n" nil t)
487 (< pos (point))))
488
489 (defun nnmbox-find-article (article)
490 "Leaves point on the relevant X-Gnus-Newsgroup line if found."
491 ;; Check that article is in the active range first, to avoid an
492 ;; expensive exhaustive search if it isn't.
493 (if (and (numberp article)
494 (not (nnmbox-is-article-active-p article)))
495 nil
496 (let ((art-string (nnmbox-article-string article))
497 (found nil))
498 ;; There is the possibility that the X-Gnus-Newsgroup line appears
499 ;; in the body of an article (for instance, if an article has been
500 ;; forwarded from someone using Gnus as their mailer), so check
501 ;; that the line is actually part of the article header.
502 (or (and (search-forward art-string nil t)
503 (nnmbox-in-header-p (point)))
504 (progn
505 (goto-char (point-min))
506 (while (and (not found)
507 (search-forward art-string nil t))
508 (setq found (nnmbox-in-header-p (point))))
509 found)))))
510
511 (defun nnmbox-record-active-article (group-art)
512 (let* ((group (car group-art))
513 (article (cdr group-art))
514 (entry
515 (or (assoc group nnmbox-group-active-articles)
516 (progn
517 (push (list group)
518 nnmbox-group-active-articles)
519 (car nnmbox-group-active-articles)))))
520 ;; add article to index, either by building complete list
521 ;; in reverse order, or as a list of ranges.
522 (if (not nnmbox-group-building-active-articles)
523 (setcdr entry (gnus-add-to-range (cdr entry) (list article)))
524 (when (memq article (cdr entry))
525 (switch-to-buffer nnmbox-mbox-buffer)
526 (error "Article %s:%d already exists!" group article))
527 (when (and (cadr entry) (< article (cadr entry)))
528 (switch-to-buffer nnmbox-mbox-buffer)
529 (error "Article %s:%d out of order" group article))
530 (setcdr entry (cons article (cdr entry))))))
531
532 (defun nnmbox-record-deleted-article (group-art)
533 (let* ((group (car group-art))
534 (article (cdr group-art))
535 (entry
536 (or (assoc group nnmbox-group-active-articles)
537 (progn
538 (push (list group)
539 nnmbox-group-active-articles)
540 (car nnmbox-group-active-articles)))))
541 ;; remove article from index
542 (setcdr entry (gnus-remove-from-range (cdr entry) (list article)))))
543
544 (defun nnmbox-is-article-active-p (article)
545 (gnus-member-of-range
546 article
547 (cdr (assoc nnmbox-current-group
548 nnmbox-group-active-articles))))
484 549
485 (defun nnmbox-save-mail (group-art) 550 (defun nnmbox-save-mail (group-art)
486 "Called narrowed to an article." 551 "Called narrowed to an article."
487 (let ((delim (concat "^" message-unix-mail-delimiter))) 552 (let ((delim (concat "^" message-unix-mail-delimiter)))
488 (goto-char (point-min)) 553 (goto-char (point-min))
496 (beginning-of-line) 561 (beginning-of-line)
497 (insert "> ")) 562 (insert "> "))
498 (nnmail-insert-lines) 563 (nnmail-insert-lines)
499 (nnmail-insert-xref group-art) 564 (nnmail-insert-xref group-art)
500 (nnmbox-insert-newsgroup-line group-art) 565 (nnmbox-insert-newsgroup-line group-art)
566 (let ((alist group-art))
567 (while alist
568 (nnmbox-record-active-article (car alist))
569 (setq alist (cdr alist))))
501 (run-hooks 'nnmail-prepare-save-mail-hook) 570 (run-hooks 'nnmail-prepare-save-mail-hook)
502 (run-hooks 'nnmbox-prepare-save-mail-hook) 571 (run-hooks 'nnmbox-prepare-save-mail-hook)
503 group-art)) 572 group-art))
504 573
505 (defun nnmbox-insert-newsgroup-line (group-art) 574 (defun nnmbox-insert-newsgroup-line (group-art)
528 597
529 (defun nnmbox-create-mbox () 598 (defun nnmbox-create-mbox ()
530 (when (not (file-exists-p nnmbox-mbox-file)) 599 (when (not (file-exists-p nnmbox-mbox-file))
531 (let ((nnmail-file-coding-system 600 (let ((nnmail-file-coding-system
532 (or nnmbox-file-coding-system-for-write 601 (or nnmbox-file-coding-system-for-write
533 nnmbox-file-coding-system))) 602 nnmbox-file-coding-system))
603 (dir (file-name-directory nnmbox-mbox-file)))
604 (and dir (gnus-make-directory dir))
534 (nnmail-write-region (point-min) (point-min) 605 (nnmail-write-region (point-min) (point-min)
535 nnmbox-mbox-file t 'nomesg)))) 606 nnmbox-mbox-file t 'nomesg))))
536 607
537 (defun nnmbox-read-mbox () 608 (defun nnmbox-read-mbox ()
538 (nnmail-activate 'nnmbox) 609 (nnmail-activate 'nnmbox)
544 (= (buffer-size) (nnheader-file-size nnmbox-mbox-file)))) 615 (= (buffer-size) (nnheader-file-size nnmbox-mbox-file))))
545 () 616 ()
546 (save-excursion 617 (save-excursion
547 (let ((delim (concat "^" message-unix-mail-delimiter)) 618 (let ((delim (concat "^" message-unix-mail-delimiter))
548 (alist nnmbox-group-alist) 619 (alist nnmbox-group-alist)
549 start end number) 620 (nnmbox-group-building-active-articles t)
621 start end end-header number)
550 (set-buffer (setq nnmbox-mbox-buffer 622 (set-buffer (setq nnmbox-mbox-buffer
551 (let ((nnheader-file-coding-system 623 (let ((nnheader-file-coding-system
552 nnmbox-file-coding-system)) 624 nnmbox-file-coding-system))
553 (nnheader-find-file-noselect 625 (nnheader-find-file-noselect
554 nnmbox-mbox-file nil t)))) 626 nnmbox-mbox-file t t))))
555 (mm-enable-multibyte) 627 (mm-enable-multibyte)
556 (buffer-disable-undo) 628 (buffer-disable-undo)
557 629
558 ;; Go through the group alist and compare against 630 ;; Go through the group alist and compare against the mbox file.
559 ;; the mbox file.
560 (while alist 631 (while alist
561 (goto-char (point-max)) 632 (goto-char (point-max))
562 (when (and (re-search-backward 633 (when (and (re-search-backward
563 (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) " 634 (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
564 (caar alist)) nil t) 635 (caar alist)) nil t)
568 (match-beginning 1) (match-end 1)))) 639 (match-beginning 1) (match-end 1))))
569 (cdadar alist))) 640 (cdadar alist)))
570 (setcdr (cadar alist) number)) 641 (setcdr (cadar alist) number))
571 (setq alist (cdr alist))) 642 (setq alist (cdr alist)))
572 643
644 ;; Examine all articles for our private X-Gnus-Newsgroup
645 ;; headers. This is done primarily as a consistency check, but
646 ;; it is convenient for building an index of the articles
647 ;; present, to avoid costly searches for missing articles
648 ;; (eg. when expiring articles).
573 (goto-char (point-min)) 649 (goto-char (point-min))
650 (setq nnmbox-group-active-articles nil)
574 (while (re-search-forward delim nil t) 651 (while (re-search-forward delim nil t)
575 (setq start (match-beginning 0)) 652 (setq start (match-beginning 0))
576 (unless (search-forward 653 (save-excursion
577 "\nX-Gnus-Newsgroup: " 654 (search-forward "\n\n" nil t)
578 (save-excursion 655 (setq end-header (point))
579 (setq end 656 (setq end (or (and
580 (or 657 (re-search-forward delim nil t)
581 (and 658 (match-beginning 0))
582 ;; skip to end of headers first, since mail 659 (point-max))))
583 ;; which has been respooled has additional 660 (if (search-forward "\nX-Gnus-Newsgroup: " end-header t)
584 ;; "From nobody" lines. 661 ;; Build a list of articles in each group, remembering
585 (search-forward "\n\n" nil t) 662 ;; that each article may be in more than one group.
586 (re-search-forward delim nil t) 663 (progn
587 (match-beginning 0)) 664 (nnmbox-record-active-article (nnmbox-article-group-number t))
588 (point-max)))) 665 (while (search-forward "\nX-Gnus-Newsgroup: " end-header t)
589 t) 666 (nnmbox-record-active-article (nnmbox-article-group-number t))))
667 ;; The article is either new, or for some other reason
668 ;; hasn't got our private headers, so add them now. The
669 ;; only situation I've encountered when the X-Gnus-Newsgroup
670 ;; header is missing is if the article contains a forwarded
671 ;; message which does contain that header line (earlier
672 ;; versions of Gnus didn't restrict their search to the
673 ;; headers). In this case, there is an Xref line which
674 ;; provides the relevant information to construct the
675 ;; missing header(s).
590 (save-excursion 676 (save-excursion
591 (save-restriction 677 (save-restriction
592 (narrow-to-region start end) 678 (narrow-to-region start end)
593 (nnmbox-save-mail 679 (if (re-search-forward "\nXref: [^ ]+" end-header t)
594 (nnmail-article-group 'nnmbox-active-number))))) 680 ;; generate headers from Xref:
595 (goto-char end)))))) 681 (let (alist)
682 (while (re-search-forward " \\([^:]+\\):\\([0-9]+\\)" end-header t)
683 (push (cons (match-string 1)
684 (string-to-number (match-string 2))) alist))
685 (nnmbox-insert-newsgroup-line alist))
686 ;; this is really a new article
687 (nnmbox-save-mail
688 (nnmail-article-group 'nnmbox-active-number))))))
689 (goto-char end))
690 ;; put article lists in order
691 (setq alist nnmbox-group-active-articles)
692 (while alist
693 (setcdr (car alist) (gnus-compress-sequence (nreverse (cdar alist))))
694 (setq alist (cdr alist)))))))
596 695
597 (provide 'nnmbox) 696 (provide 'nnmbox)
598 697
698 ;;; arch-tag: 611dd95f-be37-413a-b3ae-8b059ba93659
599 ;;; nnmbox.el ends here 699 ;;; nnmbox.el ends here