/[emacs]/emacs/lisp/gnus/nnmbox.el
ViewVC logotype

Diff of /emacs/lisp/gnus/nnmbox.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7.6.1 by handa, Fri Mar 12 00:03:11 2004 UTC revision 1.7.6.2 by miles, Thu Sep 9 09:36:26 2004 UTC
# Line 1  Line 1 
1  ;;; nnmbox.el --- mail mbox access for Gnus  ;;; nnmbox.el --- mail mbox access for Gnus
2    
3  ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000  ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
4  ;;      Free Software Foundation, Inc.  ;;      Free Software Foundation, Inc.
5    
6  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7  ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>  ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
8  ;; Keywords: news, mail  ;; Keywords: news, mail
9    
10  ;; This file is part of GNU Emacs.  ;; This file is part of GNU Emacs.
# Line 30  Line 30 
30  (require 'message)  (require 'message)
31  (require 'nnmail)  (require 'nnmail)
32  (require 'nnoo)  (require 'nnoo)
33    (require 'gnus-range)
34  (eval-when-compile (require 'cl))  (eval-when-compile (require 'cl))
35    
36  (nnoo-declare nnmbox)  (nnoo-declare nnmbox)
# Line 54  Line 55 
55  (defvoo nnmbox-current-group nil  (defvoo nnmbox-current-group nil
56    "Current nnmbox news group directory.")    "Current nnmbox news group directory.")
57    
58  (defconst nnmbox-mbox-buffer nil)  (defvar nnmbox-mbox-buffer nil)
59    
60  (defvoo nnmbox-status-string "")  (defvoo nnmbox-status-string "")
61    
# Line 66  Line 67 
67  (defvoo nnmbox-active-file-coding-system mm-binary-coding-system)  (defvoo nnmbox-active-file-coding-system mm-binary-coding-system)
68  (defvoo nnmbox-active-file-coding-system-for-write nil)  (defvoo nnmbox-active-file-coding-system-for-write nil)
69    
70    (defvar nnmbox-group-building-active-articles nil)
71    (defvar nnmbox-group-active-articles nil)
72    
73    
74  ;;; Interface functions  ;;; Interface functions
# Line 78  Line 81 
81      (erase-buffer)      (erase-buffer)
82      (let ((number (length sequence))      (let ((number (length sequence))
83            (count 0)            (count 0)
84            article art-string start stop)            article start stop)
85        (nnmbox-possibly-change-newsgroup newsgroup server)        (nnmbox-possibly-change-newsgroup newsgroup server)
86        (while sequence        (while sequence
87          (setq article (car sequence))          (setq article (car sequence))
         (setq art-string (nnmbox-article-string article))  
88          (set-buffer nnmbox-mbox-buffer)          (set-buffer nnmbox-mbox-buffer)
89          (when (or (search-forward art-string nil t)          (when (nnmbox-find-article article)
                   (progn (goto-char (point-min))  
                          (search-forward art-string nil t)))  
90            (setq start            (setq start
91                  (save-excursion                  (save-excursion
92                    (re-search-backward                    (re-search-backward
# Line 148  Line 148 
148    (nnmbox-possibly-change-newsgroup newsgroup server)    (nnmbox-possibly-change-newsgroup newsgroup server)
149    (save-excursion    (save-excursion
150      (set-buffer nnmbox-mbox-buffer)      (set-buffer nnmbox-mbox-buffer)
151      (goto-char (point-min))      (when (nnmbox-find-article article)
     (when (search-forward (nnmbox-article-string article) nil t)  
152        (let (start stop)        (let (start stop)
153          (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)          (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
154          (setq start (point))          (setq start (point))
# Line 170  Line 169 
169              (forward-line 1))              (forward-line 1))
170            (if (numberp article)            (if (numberp article)
171                (cons nnmbox-current-group article)                (cons nnmbox-current-group article)
172              (nnmbox-article-group-number)))))))              (nnmbox-article-group-number nil)))))))
173    
174  (deffoo nnmbox-request-group (group &optional server dont-check)  (deffoo nnmbox-request-group (group &optional server dont-check)
175    (nnmbox-possibly-change-newsgroup nil server)    (nnmbox-possibly-change-newsgroup nil server)
# Line 254  Line 253 
253      (save-excursion      (save-excursion
254        (set-buffer nnmbox-mbox-buffer)        (set-buffer nnmbox-mbox-buffer)
255        (while (and articles is-old)        (while (and articles is-old)
256          (goto-char (point-min))          (when (nnmbox-find-article (car articles))
         (when (search-forward (nnmbox-article-string (car articles)) nil t)  
257            (if (setq is-old            (if (setq is-old
258                      (nnmail-expired-article-p                      (nnmail-expired-article-p
259                       newsgroup                       newsgroup
# Line 269  Line 267 
267                                               (current-buffer))                                               (current-buffer))
268                      (let ((nnml-current-directory nil))                      (let ((nnml-current-directory nil))
269                        (nnmail-expiry-target-group                        (nnmail-expiry-target-group
270                         nnmail-expiry-target newsgroup))))                         nnmail-expiry-target newsgroup)))
271                      (nnmbox-possibly-change-newsgroup newsgroup server))
272                  (nnheader-message 5 "Deleting article %d in %s..."                  (nnheader-message 5 "Deleting article %d in %s..."
273                                    (car articles) newsgroup)                                    (car articles) newsgroup)
274                  (nnmbox-delete-mail))                  (nnmbox-delete-mail))
# Line 278  Line 277 
277        (nnmbox-save-buffer)        (nnmbox-save-buffer)
278        ;; Find the lowest active article in this group.        ;; Find the lowest active article in this group.
279        (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))        (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
280          (goto-char (point-min))          (while (and (not (nnmbox-find-article (car active)))
         (while (and (not (search-forward  
                           (nnmbox-article-string (car active)) nil t))  
281                      (<= (car active) (cdr active)))                      (<= (car active) (cdr active)))
282            (setcar active (1+ (car active)))            (setcar active (1+ (car active)))))
           (goto-char (point-min))))  
283        (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)        (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
284        (nconc rest articles))))        (nconc rest articles))))
285    
# Line 301  Line 297 
297         (while (re-search-forward         (while (re-search-forward
298                 "^X-Gnus-Newsgroup:"                 "^X-Gnus-Newsgroup:"
299                 (save-excursion (search-forward "\n\n" nil t) (point)) t)                 (save-excursion (search-forward "\n\n" nil t) (point)) t)
300           (delete-region (progn (beginning-of-line) (point))           (gnus-delete-line))
                         (progn (forward-line 1) (point))))  
301         (setq result (eval accept-form))         (setq result (eval accept-form))
302         (kill-buffer buf)         (kill-buffer buf)
303         result)         result)
304       (save-excursion       (save-excursion
305         (nnmbox-possibly-change-newsgroup group server)         (nnmbox-possibly-change-newsgroup group server)
306         (set-buffer nnmbox-mbox-buffer)         (set-buffer nnmbox-mbox-buffer)
307         (goto-char (point-min))         (when (nnmbox-find-article article)
        (when (search-forward (nnmbox-article-string article) nil t)  
308           (nnmbox-delete-mail))           (nnmbox-delete-mail))
309         (and last (nnmbox-save-buffer))))         (and last (nnmbox-save-buffer))))
310      result))      result))
# Line 337  Line 331 
331         (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)         (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
332           (delete-region (point) (progn (forward-line 1) (point))))           (delete-region (point) (progn (forward-line 1) (point))))
333         (when nnmail-cache-accepted-message-ids         (when nnmail-cache-accepted-message-ids
334           (nnmail-cache-insert (nnmail-fetch-field "message-id")))           (nnmail-cache-insert (nnmail-fetch-field "message-id")
335                                  group
336                                  (nnmail-fetch-field "subject")
337                                  (nnmail-fetch-field "from")))
338         (setq result (if (stringp group)         (setq result (if (stringp group)
339                          (list (cons group (nnmbox-active-number group)))                          (list (cons group (nnmbox-active-number group)))
340                        (nnmail-article-group 'nnmbox-active-number)))                        (nnmail-article-group 'nnmbox-active-number)))
# Line 360  Line 357 
357    (nnmbox-possibly-change-newsgroup group)    (nnmbox-possibly-change-newsgroup group)
358    (save-excursion    (save-excursion
359      (set-buffer nnmbox-mbox-buffer)      (set-buffer nnmbox-mbox-buffer)
360      (goto-char (point-min))      (if (not (nnmbox-find-article article))
     (if (not (search-forward (nnmbox-article-string article) nil t))  
361          nil          nil
362        (nnmbox-delete-mail t t)        (nnmbox-delete-mail t t)
363        (insert-buffer-substring buffer)        (insert-buffer-substring buffer)
# Line 405  Line 401 
401          (setq found t))          (setq found t))
402        (when found        (when found
403          (nnmbox-save-buffer))))          (nnmbox-save-buffer))))
404      (let ((entry (assoc group nnmbox-group-active-articles)))
405        (when entry
406          (setcar entry new-name)))
407    (let ((entry (assoc group nnmbox-group-alist)))    (let ((entry (assoc group nnmbox-group-alist)))
408      (when entry      (when entry
409        (setcar entry new-name))        (setcar entry new-name))
# Line 421  Line 420 
420  ;; delimiter line.  ;; delimiter line.
421  (defun nnmbox-delete-mail (&optional force leave-delim)  (defun nnmbox-delete-mail (&optional force leave-delim)
422    ;; Delete the current X-Gnus-Newsgroup line.    ;; 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)))
427    (or force    (or force
428        (delete-region        (gnus-delete-line))
        (progn (beginning-of-line) (point))  
        (progn (forward-line 1) (point))))  
429    ;; Beginning of the article.    ;; Beginning of the article.
430    (save-excursion    (save-excursion
431      (save-restriction      (save-restriction
# Line 442  Line 443 
443                      (match-beginning 0)))                      (match-beginning 0)))
444               (point-max))))               (point-max))))
445        (goto-char (point-min))        (goto-char (point-min))
446        ;; Only delete the article if no other groups owns it as well.        ;; Only delete the article if no other group owns it as well.
447        (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))        (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
448          (delete-region (point-min) (point-max))))))          (delete-region (point-min) (point-max))))))
449    
# Line 452  Line 453 
453      (nnmbox-open-server server))      (nnmbox-open-server server))
454    (when (or (not nnmbox-mbox-buffer)    (when (or (not nnmbox-mbox-buffer)
455              (not (buffer-name nnmbox-mbox-buffer)))              (not (buffer-name nnmbox-mbox-buffer)))
456      (save-excursion      (nnmbox-read-mbox))
       (set-buffer (setq nnmbox-mbox-buffer  
                         (let ((nnheader-file-coding-system  
                                nnmbox-file-coding-system))  
                           (nnheader-find-file-noselect  
                            nnmbox-mbox-file nil t))))  
       (mm-enable-multibyte)  
       (buffer-disable-undo)))  
457    (when (not nnmbox-group-alist)    (when (not nnmbox-group-alist)
458      (nnmail-activate 'nnmbox))      (nnmail-activate 'nnmbox))
459    (if newsgroup    (if newsgroup
# Line 473  Line 467 
467                (int-to-string article) " ")                (int-to-string article) " ")
468      (concat "\nMessage-ID: " article)))      (concat "\nMessage-ID: " article)))
469    
470  (defun nnmbox-article-group-number ()  (defun nnmbox-article-group-number (this-line)
471    (save-excursion    (save-excursion
472      (goto-char (point-min))      (if this-line
473            (beginning-of-line)
474          (goto-char (point-min)))
475      (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "      (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
476                               nil t)                               nil t)
477        (cons (buffer-substring (match-beginning 1) (match-end 1))        (cons (buffer-substring (match-beginning 1) (match-end 1))
478              (string-to-int              (string-to-int
479               (buffer-substring (match-beginning 2) (match-end 2)))))))               (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))))
549    
550  (defun nnmbox-save-mail (group-art)  (defun nnmbox-save-mail (group-art)
551    "Called narrowed to an article."    "Called narrowed to an article."
552    (let ((delim (concat "^" message-unix-mail-delimiter)))    (let ((delim (concat "^" message-unix-mail-delimiter)))
# Line 498  Line 563 
563      (nnmail-insert-lines)      (nnmail-insert-lines)
564      (nnmail-insert-xref group-art)      (nnmail-insert-xref group-art)
565      (nnmbox-insert-newsgroup-line group-art)      (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))))
570      (run-hooks 'nnmail-prepare-save-mail-hook)      (run-hooks 'nnmail-prepare-save-mail-hook)
571      (run-hooks 'nnmbox-prepare-save-mail-hook)      (run-hooks 'nnmbox-prepare-save-mail-hook)
572      group-art))      group-art))
# Line 530  Line 599 
599    (when (not (file-exists-p nnmbox-mbox-file))    (when (not (file-exists-p nnmbox-mbox-file))
600      (let ((nnmail-file-coding-system      (let ((nnmail-file-coding-system
601             (or nnmbox-file-coding-system-for-write             (or nnmbox-file-coding-system-for-write
602                 nnmbox-file-coding-system)))                 nnmbox-file-coding-system))
603              (dir (file-name-directory nnmbox-mbox-file)))
604          (and dir (gnus-make-directory dir))
605        (nnmail-write-region (point-min) (point-min)        (nnmail-write-region (point-min) (point-min)
606                             nnmbox-mbox-file t 'nomesg))))                             nnmbox-mbox-file t 'nomesg))))
607    
# Line 546  Line 617 
617      (save-excursion      (save-excursion
618        (let ((delim (concat "^" message-unix-mail-delimiter))        (let ((delim (concat "^" message-unix-mail-delimiter))
619              (alist nnmbox-group-alist)              (alist nnmbox-group-alist)
620              start end number)              (nnmbox-group-building-active-articles t)
621                start end end-header number)
622          (set-buffer (setq nnmbox-mbox-buffer          (set-buffer (setq nnmbox-mbox-buffer
623                            (let ((nnheader-file-coding-system                            (let ((nnheader-file-coding-system
624                                   nnmbox-file-coding-system))                                   nnmbox-file-coding-system))
625                              (nnheader-find-file-noselect                              (nnheader-find-file-noselect
626                               nnmbox-mbox-file nil t))))                               nnmbox-mbox-file t t))))
627          (mm-enable-multibyte)          (mm-enable-multibyte)
628          (buffer-disable-undo)          (buffer-disable-undo)
629    
630          ;; Go through the group alist and compare against          ;; Go through the group alist and compare against the mbox file.
         ;; the mbox file.  
631          (while alist          (while alist
632            (goto-char (point-max))            (goto-char (point-max))
633            (when (and (re-search-backward            (when (and (re-search-backward
# Line 570  Line 641 
641              (setcdr (cadar alist) number))              (setcdr (cadar alist) number))
642            (setq alist (cdr alist)))            (setq alist (cdr alist)))
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).
649          (goto-char (point-min))          (goto-char (point-min))
650            (setq nnmbox-group-active-articles nil)
651          (while (re-search-forward delim nil t)          (while (re-search-forward delim nil t)
652            (setq start (match-beginning 0))            (setq start (match-beginning 0))
653            (unless (search-forward            (save-excursion
654                     "\nX-Gnus-Newsgroup: "              (search-forward "\n\n" nil t)
655                     (save-excursion              (setq end-header (point))
656                       (setq end              (setq end (or (and
657                             (or                             (re-search-forward delim nil t)
658                              (and                             (match-beginning 0))
659                               ;; skip to end of headers first, since mail                            (point-max))))
660                               ;; which has been respooled has additional            (if (search-forward "\nX-Gnus-Newsgroup: " end-header t)
661                               ;; "From nobody" lines.                ;; Build a list of articles in each group, remembering
662                               (search-forward "\n\n" nil t)                ;; that each article may be in more than one group.
663                               (re-search-forward delim nil t)                (progn
664                               (match-beginning 0))                  (nnmbox-record-active-article (nnmbox-article-group-number t))
665                              (point-max))))                  (while (search-forward "\nX-Gnus-Newsgroup: " end-header t)
666                     t)                    (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).
676              (save-excursion              (save-excursion
677                (save-restriction                (save-restriction
678                  (narrow-to-region start end)                  (narrow-to-region start end)
679                  (nnmbox-save-mail                  (if (re-search-forward "\nXref: [^ ]+" end-header t)
680                   (nnmail-article-group 'nnmbox-active-number)))))                      ;; generate headers from Xref:
681            (goto-char end))))))                      (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)))))))
695    
696  (provide 'nnmbox)  (provide 'nnmbox)
697    

Legend:
Removed from v.1.7.6.1  
changed lines
  Added in v.1.7.6.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26