diff lisp/gnus/nnmbox.el @ 89971:cce1c0ee76ee

Revision: [e-mail]--gnu-2004/emacs--unicode--0--patch-36 Merge from emacs--cvs-trunk--0, emacs--gnus--5.10, gnus--rel--5.10 Patches applied: * [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-523 Merge from emacs--gnus--5.10, gnus--rel--5.10 * [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-524 - [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-534 Update from CVS * [e-mail]--gnu-2004/emacs--gnus--5.10--base-0 tag of [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-464 * [e-mail]--gnu-2004/emacs--gnus--5.10--patch-1 Import from CVS branch gnus-5_10-branch * [e-mail]--gnu-2004/emacs--gnus--5.10--patch-2 Merge from [e-mail]--2004/emacs--multi-tty--0, emacs--cvs-trunk--0 * [e-mail]--gnu-2004/emacs--gnus--5.10--patch-3 Merge from gnus--rel--5.10 * [e-mail]--gnu-2004/emacs--gnus--5.10--patch-4 Merge from gnus--rel--5.10 * [e-mail]--gnu-2004/gnus--rel--5.10--patch-18 Update from CVS * [e-mail]--gnu-2004/gnus--rel--5.10--patch-19 Remove autoconf-generated files from archive * [e-mail]--gnu-2004/gnus--rel--5.10--patch-20 Update from CVS

--- a/lisp/gnus/nnmbox.el	Sun Sep 05 01:53:47 2004 +0000
+++ b/lisp/gnus/nnmbox.el	Thu Sep 09 09:36:36 2004 +0000
@@ -1,10 +1,10 @@
 ;;; nnmbox.el --- mail mbox access for Gnus
 
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
 ;;	Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <[e-mail]>
-;; 	Masanobu UMEDA <[e-mail]>
+;;	Masanobu UMEDA <[e-mail]>
 ;; Keywords: news, mail
 
 ;; This file is part of GNU Emacs.
@@ -30,6 +30,7 @@
 (require 'message)
 (require 'nnmail)
 (require 'nnoo)
+(require 'gnus-range)
 (eval-when-compile (require 'cl))
 
 (nnoo-declare nnmbox)
@@ -54,7 +55,7 @@
 (defvoo nnmbox-current-group nil
   "Current nnmbox news group directory.")
 
-(defconst nnmbox-mbox-buffer nil)
+(defvar nnmbox-mbox-buffer nil)
 
 (defvoo nnmbox-status-string "")
 
@@ -66,6 +67,8 @@
 (defvoo nnmbox-active-file-coding-system mm-binary-coding-system)
 (defvoo nnmbox-active-file-coding-system-for-write nil)
 
+(defvar nnmbox-group-building-active-articles nil)
+(defvar nnmbox-group-active-articles nil)
 
 
 ;;; Interface functions
@@ -78,15 +81,12 @@
     (erase-buffer)
     (let ((number (length sequence))
 	  (count 0)
-	  article art-string start stop)
+	  article start stop)
       (nnmbox-possibly-change-newsgroup newsgroup server)
       (while sequence
 	(setq article (car sequence))
-	(setq art-string (nnmbox-article-string article))
 	(set-buffer nnmbox-mbox-buffer)
-	(when (or (search-forward art-string nil t)
-		  (progn (goto-char (point-min))
-			 (search-forward art-string nil t)))
+	(when (nnmbox-find-article article)
 	  (setq start
 		(save-excursion
 		  (re-search-backward
@@ -148,8 +148,7 @@
   (nnmbox-possibly-change-newsgroup newsgroup server)
   (save-excursion
     (set-buffer nnmbox-mbox-buffer)
-    (goto-char (point-min))
-    (when (search-forward (nnmbox-article-string article) nil t)
+    (when (nnmbox-find-article article)
       (let (start stop)
 	(re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
 	(setq start (point))
@@ -170,7 +169,7 @@
 	    (forward-line 1))
 	  (if (numberp article)
 	      (cons nnmbox-current-group article)
-	    (nnmbox-article-group-number)))))))
+	    (nnmbox-article-group-number nil)))))))
 
 (deffoo nnmbox-request-group (group &optional server dont-check)
   (nnmbox-possibly-change-newsgroup nil server)
@@ -254,8 +253,7 @@
     (save-excursion
       (set-buffer nnmbox-mbox-buffer)
       (while (and articles is-old)
-	(goto-char (point-min))
-	(when (search-forward (nnmbox-article-string (car articles)) nil t)
+	(when (nnmbox-find-article (car articles))
 	  (if (setq is-old
 		    (nnmail-expired-article-p
 		     newsgroup
@@ -269,7 +267,8 @@
 					     (current-buffer))
 		    (let ((nnml-current-directory nil))
 		      (nnmail-expiry-target-group
-		       nnmail-expiry-target newsgroup))))
+		       nnmail-expiry-target newsgroup)))
+		  (nnmbox-possibly-change-newsgroup newsgroup server))
 		(nnheader-message 5 "Deleting article %d in %s..."
 				  (car articles) newsgroup)
 		(nnmbox-delete-mail))
@@ -278,12 +277,9 @@
       (nnmbox-save-buffer)
       ;; Find the lowest active article in this group.
       (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
-	(goto-char (point-min))
-	(while (and (not (search-forward
-			  (nnmbox-article-string (car active)) nil t))
+	(while (and (not (nnmbox-find-article (car active)))
 		    (<= (car active) (cdr active)))
-	  (setcar active (1+ (car active)))
-	  (goto-char (point-min))))
+	  (setcar active (1+ (car active)))))
       (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
       (nconc rest articles))))
 
@@ -301,16 +297,14 @@
        (while (re-search-forward
 	       "^X-Gnus-Newsgroup:"
 	       (save-excursion (search-forward "\n\n" nil t) (point)) t)
-	 (delete-region (progn (beginning-of-line) (point))
-			(progn (forward-line 1) (point))))
+	 (gnus-delete-line))
        (setq result (eval accept-form))
        (kill-buffer buf)
        result)
      (save-excursion
        (nnmbox-possibly-change-newsgroup group server)
        (set-buffer nnmbox-mbox-buffer)
-       (goto-char (point-min))
-       (when (search-forward (nnmbox-article-string article) nil t)
+       (when (nnmbox-find-article article)
 	 (nnmbox-delete-mail))
        (and last (nnmbox-save-buffer))))
     result))
@@ -337,7 +331,10 @@
        (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
 	 (delete-region (point) (progn (forward-line 1) (point))))
        (when nnmail-cache-accepted-message-ids
-	 (nnmail-cache-insert (nnmail-fetch-field "message-id")))
+	 (nnmail-cache-insert (nnmail-fetch-field "message-id") 
+			      group
+			      (nnmail-fetch-field "subject")
+			      (nnmail-fetch-field "from")))
        (setq result (if (stringp group)
 			(list (cons group (nnmbox-active-number group)))
 		      (nnmail-article-group 'nnmbox-active-number)))
@@ -360,8 +357,7 @@
   (nnmbox-possibly-change-newsgroup group)
   (save-excursion
     (set-buffer nnmbox-mbox-buffer)
-    (goto-char (point-min))
-    (if (not (search-forward (nnmbox-article-string article) nil t))
+    (if (not (nnmbox-find-article article))
 	nil
       (nnmbox-delete-mail t t)
       (insert-buffer-substring buffer)
@@ -405,6 +401,9 @@
 	(setq found t))
       (when found
 	(nnmbox-save-buffer))))
+  (let ((entry (assoc group nnmbox-group-active-articles)))
+    (when entry
+      (setcar entry new-name)))
   (let ((entry (assoc group nnmbox-group-alist)))
     (when entry
       (setcar entry new-name))
@@ -421,10 +420,12 @@
 ;; delimiter line.
 (defun nnmbox-delete-mail (&optional force leave-delim)
   ;; Delete the current X-Gnus-Newsgroup line.
+  ;; First delete record of active article, unless the article is being
+  ;; replaced, indicated by FORCE being non-nil.
+  (if (not force)
+      (nnmbox-record-deleted-article (nnmbox-article-group-number t)))
   (or force
-      (delete-region
-       (progn (beginning-of-line) (point))
-       (progn (forward-line 1) (point))))
+      (gnus-delete-line))
   ;; Beginning of the article.
   (save-excursion
     (save-restriction
@@ -442,7 +443,7 @@
 		    (match-beginning 0)))
 	     (point-max))))
       (goto-char (point-min))
-      ;; Only delete the article if no other groups owns it as well.
+      ;; Only delete the article if no other group owns it as well.
       (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
 	(delete-region (point-min) (point-max))))))
 
@@ -452,14 +453,7 @@
     (nnmbox-open-server server))
   (when (or (not nnmbox-mbox-buffer)
 	    (not (buffer-name nnmbox-mbox-buffer)))
-    (save-excursion
-      (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)))
+    (nnmbox-read-mbox))
   (when (not nnmbox-group-alist)
     (nnmail-activate 'nnmbox))
   (if newsgroup
@@ -473,15 +467,86 @@
 	      (int-to-string article) " ")
     (concat "\nMessage-ID: " article)))
 
-(defun nnmbox-article-group-number ()
+(defun nnmbox-article-group-number (this-line)
   (save-excursion
-    (goto-char (point-min))
+    (if this-line
+	(beginning-of-line)
+      (goto-char (point-min)))
     (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
 			     nil t)
       (cons (buffer-substring (match-beginning 1) (match-end 1))
 	    (string-to-int
 	     (buffer-substring (match-beginning 2) (match-end 2)))))))
 
+(defun nnmbox-in-header-p (pos)
+  "Return non-nil if POS is in the header of an article."
+  (save-excursion
+    (goto-char pos)
+    (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
+    (search-forward "\n\n" nil t)
+    (< pos (point))))
+
+(defun nnmbox-find-article (article)
+  "Leaves point on the relevant X-Gnus-Newsgroup line if found."
+  ;; Check that article is in the active range first, to avoid an
+  ;; expensive exhaustive search if it isn't.
+  (if (and (numberp article)
+	   (not (nnmbox-is-article-active-p article)))
+      nil
+    (let ((art-string (nnmbox-article-string article))
+	  (found nil))
+      ;; There is the possibility that the X-Gnus-Newsgroup line appears
+      ;; in the body of an article (for instance, if an article has been
+      ;; forwarded from someone using Gnus as their mailer), so check
+      ;; that the line is actually part of the article header.
+      (or (and (search-forward art-string nil t)
+	       (nnmbox-in-header-p (point)))
+	  (progn
+	    (goto-char (point-min))
+	    (while (and (not found)
+			(search-forward art-string nil t))
+	      (setq found (nnmbox-in-header-p (point))))
+	    found)))))
+
+(defun nnmbox-record-active-article (group-art)
+  (let* ((group (car group-art))
+	 (article (cdr group-art))
+	 (entry
+	  (or (assoc group nnmbox-group-active-articles)
+	      (progn
+		(push (list group)
+		      nnmbox-group-active-articles)
+		(car nnmbox-group-active-articles)))))
+    ;; add article to index, either by building complete list
+    ;; in reverse order, or as a list of ranges.
+    (if (not nnmbox-group-building-active-articles)
+	(setcdr entry (gnus-add-to-range (cdr entry) (list article)))
+      (when (memq article (cdr entry))
+	(switch-to-buffer nnmbox-mbox-buffer)
+	(error "Article %s:%d already exists!" group article))
+      (when (and (cadr entry) (< article (cadr entry)))
+	(switch-to-buffer nnmbox-mbox-buffer)
+	(error "Article %s:%d out of order" group article))
+      (setcdr entry (cons article (cdr entry))))))
+
+(defun nnmbox-record-deleted-article (group-art)
+  (let* ((group (car group-art))
+	 (article (cdr group-art))
+	 (entry
+	  (or (assoc group nnmbox-group-active-articles)
+	      (progn
+		(push (list group)
+		      nnmbox-group-active-articles)
+		(car nnmbox-group-active-articles)))))
+    ;; remove article from index
+    (setcdr entry (gnus-remove-from-range (cdr entry) (list article)))))
+
+(defun nnmbox-is-article-active-p (article)
+  (gnus-member-of-range
+   article
+   (cdr (assoc nnmbox-current-group
+	       nnmbox-group-active-articles))))
+
 (defun nnmbox-save-mail (group-art)
   "Called narrowed to an article."
   (let ((delim (concat "^" message-unix-mail-delimiter)))
@@ -498,6 +563,10 @@
     (nnmail-insert-lines)
     (nnmail-insert-xref group-art)
     (nnmbox-insert-newsgroup-line group-art)
+    (let ((alist group-art))
+      (while alist
+	(nnmbox-record-active-article (car alist))
+	(setq alist (cdr alist))))
     (run-hooks 'nnmail-prepare-save-mail-hook)
     (run-hooks 'nnmbox-prepare-save-mail-hook)
     group-art))
@@ -530,7 +599,9 @@
   (when (not (file-exists-p nnmbox-mbox-file))
     (let ((nnmail-file-coding-system
 	   (or nnmbox-file-coding-system-for-write
-	       nnmbox-file-coding-system)))
+	       nnmbox-file-coding-system))
+	  (dir (file-name-directory nnmbox-mbox-file)))
+      (and dir (gnus-make-directory dir))
       (nnmail-write-region (point-min) (point-min)
 			   nnmbox-mbox-file t 'nomesg))))
 
@@ -546,17 +617,17 @@
     (save-excursion
       (let ((delim (concat "^" message-unix-mail-delimiter))
 	    (alist nnmbox-group-alist)
-	    start end number)
+	    (nnmbox-group-building-active-articles t)
+	    start end end-header number)
 	(set-buffer (setq nnmbox-mbox-buffer
 			  (let ((nnheader-file-coding-system
 				 nnmbox-file-coding-system))
 			    (nnheader-find-file-noselect
-			     nnmbox-mbox-file nil t))))
+			     nnmbox-mbox-file t t))))
 	(mm-enable-multibyte)
 	(buffer-disable-undo)
 
-	;; Go through the group alist and compare against
-	;; the mbox file.
+	;; Go through the group alist and compare against the mbox file.
 	(while alist
 	  (goto-char (point-max))
 	  (when (and (re-search-backward
@@ -570,29 +641,57 @@
 	    (setcdr (cadar alist) number))
 	  (setq alist (cdr alist)))
 
+	;; Examine all articles for our private X-Gnus-Newsgroup
+	;; headers.  This is done primarily as a consistency check, but
+	;; it is convenient for building an index of the articles
+	;; present, to avoid costly searches for missing articles
+	;; (eg. when expiring articles).
 	(goto-char (point-min))
+	(setq nnmbox-group-active-articles nil)
 	(while (re-search-forward delim nil t)
 	  (setq start (match-beginning 0))
-	  (unless (search-forward
-		   "\nX-Gnus-Newsgroup: "
-		   (save-excursion
-		     (setq end
-			   (or
-			    (and
-			     ;; skip to end of headers first, since mail
-			     ;; which has been respooled has additional
-			     ;; "From nobody" lines.
-			     (search-forward "\n\n" nil t)
-			     (re-search-forward delim nil t)
-			     (match-beginning 0))
-			    (point-max))))
-		   t)
+	  (save-excursion
+	    (search-forward "\n\n" nil t)
+	    (setq end-header (point))
+	    (setq end (or (and
+			   (re-search-forward delim nil t)
+			   (match-beginning 0))
+			  (point-max))))
+	  (if (search-forward "\nX-Gnus-Newsgroup: " end-header t)
+	      ;; Build a list of articles in each group, remembering
+	      ;; that each article may be in more than one group.
+	      (progn
+		(nnmbox-record-active-article (nnmbox-article-group-number t))
+		(while (search-forward "\nX-Gnus-Newsgroup: " end-header t)
+		  (nnmbox-record-active-article (nnmbox-article-group-number t))))
+	    ;; The article is either new, or for some other reason
+	    ;; hasn't got our private headers, so add them now.  The
+	    ;; only situation I've encountered when the X-Gnus-Newsgroup
+	    ;; header is missing is if the article contains a forwarded
+	    ;; message which does contain that header line (earlier
+	    ;; versions of Gnus didn't restrict their search to the
+	    ;; headers).  In this case, there is an Xref line which
+	    ;; provides the relevant information to construct the
+	    ;; missing header(s).
 	    (save-excursion
 	      (save-restriction
 		(narrow-to-region start end)
-		(nnmbox-save-mail
-		 (nnmail-article-group 'nnmbox-active-number)))))
-	  (goto-char end))))))
+		(if (re-search-forward "\nXref: [^ ]+" end-header t)
+		    ;; generate headers from Xref:
+		    (let (alist)
+		      (while (re-search-forward " \\([^:]+\\):\\([0-9]+\\)" end-header t)
+			(push (cons (match-string 1)
+				    (string-to-int (match-string 2))) alist))
+		      (nnmbox-insert-newsgroup-line alist))
+		  ;; this is really a new article
+		  (nnmbox-save-mail
+		   (nnmail-article-group 'nnmbox-active-number))))))
+	  (goto-char end))
+	;; put article lists in order
+	(setq alist nnmbox-group-active-articles)
+	(while alist
+	  (setcdr (car alist) (gnus-compress-sequence (nreverse (cdar alist))))
+	  (setq alist (cdr alist)))))))
 
 (provide 'nnmbox)