Mercurial > emacs
comparison lisp/gnus/nnmbox.el @ 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 22 Jul 2004 16:45:51 +0000 |
parents | 695cf19ef79e |
children | 88db2adda4b7 cce1c0ee76ee |
comparison
equal
deleted
inserted
replaced
56503:8bbd2323fbf2 | 82951:0fde48feb604 |
---|---|
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 ;; 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 |
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-int |
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-int (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 |
599 ;;; arch-tag: 611dd95f-be37-413a-b3ae-8b059ba93659 | 698 ;;; arch-tag: 611dd95f-be37-413a-b3ae-8b059ba93659 |
600 ;;; nnmbox.el ends here | 699 ;;; nnmbox.el ends here |