X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-cache.el;h=822996069ccc7a1a64774208c58172847d5818f9;hp=5ff49faa7b76bd18445a02b1a74ca63c94aca651;hb=b7df893161350265e845a70d711a97a32536a221;hpb=d3ac8b73ea597fcf8ccfd6f1ea7275f91eb40bf9

diff --git a/lisp/gnus-cache.el b/lisp/gnus-cache.el
index 5ff49faa7..822996069 100644
--- a/lisp/gnus-cache.el
+++ b/lisp/gnus-cache.el
@@ -1,16 +1,17 @@
 ;;; gnus-cache.el --- cache interface for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
-;;        Free Software Foundation, Inc.
+
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;;   2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news
 
 ;; This file is part of GNU Emacs.
 
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,21 +19,24 @@
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;; Commentary:
 
 ;;; Code:
 
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+  (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
 (eval-when-compile (require 'cl))
 
 (require 'gnus)
+(require 'gnus-sum)
+
 (eval-when-compile
   (unless (fboundp 'gnus-agent-load-alist)
-      (defun gnus-agent-load-alist (group)))
-  (require 'gnus-sum))
+    (defun gnus-agent-load-alist (group))))
 
 (defcustom gnus-cache-active-file
   (expand-file-name "active" gnus-cache-directory)
@@ -90,9 +94,10 @@ it's not cached."
 (defvar gnus-cache-active-altered nil)
 (defvar gnus-cache-total-fetched-hashtb nil)
 
-(eval-and-compile
-  (autoload 'nnml-generate-nov-databases-1 "nnml")
-  (autoload 'nnvirtual-find-group-art "nnvirtual"))
+(declare-function nnvirtual-find-group-art "nnvirtual" (group article))
+
+(autoload 'nnml-generate-nov-databases-directory "nnml")
+(autoload 'nnvirtual-find-group-art "nnvirtual")
 
 
 
@@ -123,24 +128,24 @@ it's not cached."
 	  (overview-file (gnus-cache-file-name
 			  (car gnus-cache-buffer) ".overview")))
       ;; write the overview only if it was modified
-      (when (and (buffer-live-p buffer)
-		 (buffer-modified-p buffer))
+      (when (and (buffer-live-p buffer) (buffer-modified-p buffer))
 	(with-current-buffer buffer
 	  (if (> (buffer-size) 0)
 	      ;; Non-empty overview, write it to a file.
 	      (let ((coding-system-for-write
 		     gnus-cache-overview-coding-system))
 		(gnus-write-buffer overview-file))
-	    ;; Empty overview file, remove it
-	    (when (file-exists-p overview-file)
-	      (delete-file overview-file))
-	    ;; If possible, remove group's cache subdirectory.
-	    (condition-case nil
-		;; FIXME: we can detect the error type and warn the user
-		;; of any inconsistencies (articles w/o nov entries?).
-		;; for now, just be conservative...delete only if safe -- sj
-		(delete-directory (file-name-directory overview-file))
-	      (error)))
+	    (let ((file-name-coding-system nnmail-pathname-coding-system))
+	      ;; Empty overview file, remove it
+	      (when (file-exists-p overview-file)
+		(delete-file overview-file))
+	      ;; If possible, remove group's cache subdirectory.
+	      (condition-case nil
+		  ;; FIXME: we can detect the error type and warn the user
+		  ;; of any inconsistencies (articles w/o nov entries?).
+		  ;; for now, just be conservative...delete only if safe -- sj
+		  (delete-directory (file-name-directory overview-file))
+		(error))))
 
 	  (gnus-cache-update-overview-total-fetched-for
 	   (car gnus-cache-buffer) overview-file)))
@@ -153,7 +158,9 @@ it's not cached."
   (when (and (or force (not (eq gnus-use-cache 'passive)))
 	     (numberp article)
 	     (> article 0))		; This might be a dummy article.
-    (let ((number article) file headers)
+    (let ((number article)
+	  file headers lines-chars
+	  (file-name-coding-system nnmail-pathname-coding-system))
       ;; If this is a virtual group, we find the real group.
       (when (gnus-virtual-group-p group)
 	(let ((result (nnvirtual-find-group-art
@@ -173,8 +180,7 @@ it's not cached."
 	;; Save the article in the cache.
 	(if (file-exists-p file)
 	    t				; The article already is saved.
-	  (save-excursion
-	    (set-buffer nntp-server-buffer)
+	  (with-current-buffer nntp-server-buffer
 	    (require 'gnus-art)
 	    (let ((gnus-use-cache nil)
 		  (gnus-article-decode-hook nil))
@@ -183,9 +189,12 @@ it's not cached."
 	      (let ((coding-system-for-write gnus-cache-coding-system))
 		(gnus-write-buffer file)
 		(gnus-cache-update-file-total-fetched-for group file))
+	      (setq lines-chars (nnheader-get-lines-and-char))
 	      (nnheader-remove-body)
 	      (setq headers (nnheader-parse-naked-head))
 	      (mail-header-set-number headers number)
+	      (mail-header-set-lines headers (car lines-chars))
+	      (mail-header-set-chars headers (cadr lines-chars))
 	      (gnus-cache-change-buffer group)
 	      (set-buffer (cdr gnus-cache-buffer))
 	      (goto-char (point-max))
@@ -238,12 +247,10 @@ it's not cached."
 (defun gnus-cache-possibly-remove-articles-1 ()
   "Possibly remove some of the removable articles."
   (when (gnus-cache-fully-p gnus-newsgroup-name)
-    (let ((articles gnus-cache-removable-articles)
-	  (cache-articles gnus-newsgroup-cached)
-	  article)
+    (let ((cache-articles gnus-newsgroup-cached))
       (gnus-cache-change-buffer gnus-newsgroup-name)
-      (while articles
-	(when (memq (setq article (pop articles)) cache-articles)
+      (dolist (article gnus-cache-removable-articles)
+	(when (memq article cache-articles)
 	  ;; The article was in the cache, so we see whether we are
 	  ;; supposed to remove it from the cache.
 	  (gnus-cache-possibly-remove-article
@@ -258,7 +265,8 @@ it's not cached."
 (defun gnus-cache-request-article (article group)
   "Retrieve ARTICLE in GROUP from the cache."
   (let ((file (gnus-cache-file-name group article))
-	(buffer-read-only nil))
+	(buffer-read-only nil)
+	(file-name-coding-system nnmail-pathname-coding-system))
     (when (file-exists-p file)
       (erase-buffer)
       (gnus-kill-all-overlays)
@@ -287,7 +295,8 @@ it's not cached."
 	  (gnus-retrieve-headers articles group fetch-old))
       (let ((uncached-articles (gnus-sorted-difference articles cached))
 	    (cache-file (gnus-cache-file-name group ".overview"))
-	    type)
+	    type
+	    (file-name-coding-system nnmail-pathname-coding-system))
 	;; We first retrieve all the headers that we don't have in
 	;; the cache.
 	(let ((gnus-use-cache nil))
@@ -327,9 +336,8 @@ it's not cached."
 If not given a prefix, use the process marked articles instead.
 Returns the list of articles entered."
   (interactive "P")
-  (let ((articles (gnus-summary-work-articles n))
-	article out)
-    (while (setq article (pop articles))
+  (let (out)
+    (dolist (article (gnus-summary-work-articles n))
       (gnus-summary-remove-process-mark article)
       (if (natnump article)
 	  (when (gnus-cache-possibly-enter-article
@@ -350,17 +358,15 @@ If not given a prefix, use the process marked articles instead.
 Returns the list of articles removed."
   (interactive "P")
   (gnus-cache-change-buffer gnus-newsgroup-name)
-  (let ((articles (gnus-summary-work-articles n))
-	article out)
-    (while articles
-      (setq article (pop articles))
+  (let (out)
+    (dolist (article (gnus-summary-work-articles n))
       (gnus-summary-remove-process-mark article)
       (when (gnus-cache-possibly-remove-article article nil nil nil t)
         (when gnus-newsgroup-agentized
           (let ((alist (gnus-agent-load-alist gnus-newsgroup-name)))
             (unless (cdr (assoc article alist))
               (setq gnus-newsgroup-undownloaded
-                    (gnus-add-to-sorted-list 
+                    (gnus-add-to-sorted-list
                      gnus-newsgroup-undownloaded article)))))
 	(push article out))
       (gnus-summary-update-download-mark article)
@@ -409,7 +415,8 @@ Returns the list of articles removed."
 			       " *gnus-cache-overview*"))))
       ;; Insert the contents of this group's cache overview.
       (erase-buffer)
-      (let ((file (gnus-cache-file-name group ".overview")))
+      (let ((file (gnus-cache-file-name group ".overview"))
+	    (file-name-coding-system nnmail-pathname-coding-system))
 	(when (file-exists-p file)
 	  (nnheader-insert-file-contents file)))
       ;; We have a fresh (empty/just loaded) buffer,
@@ -423,7 +430,43 @@ Returns the list of articles removed."
       (and unread (memq 'unread class))
       (and (not unread) (not ticked) (not dormant) (memq 'read class))))
 
+(defvar gnus-cache-decoded-group-names nil
+  "Alist of original group names and decoded group names.
+Decoding is done according to `gnus-group-name-charset-method-alist'
+or `gnus-group-name-charset-group-alist'.")
+
+(defvar gnus-cache-unified-group-names nil
+  "Alist of unified decoded group names and original group names.
+A group name is decoded according to
+`gnus-group-name-charset-method-alist' or
+`gnus-group-name-charset-group-alist' first, and is encoded and
+decoded again according to `nnmail-pathname-coding-system',
+`file-name-coding-system', or `default-file-name-coding-system'.
+
+It is used when asking for a original group name from a cache
+directory name, in which non-ASCII characters might have been unified
+into the ones of a certain charset particularly if the `utf-8' coding
+system for example was used.")
+
+(defun gnus-cache-decoded-group-name (group)
+  "Return a decoded group name of GROUP."
+  (or (cdr (assoc group gnus-cache-decoded-group-names))
+      (let ((decoded (gnus-group-decoded-name group))
+	    (coding (or nnmail-pathname-coding-system
+			(and (boundp 'file-name-coding-system)
+			     file-name-coding-system)
+			(and (boundp 'default-file-name-coding-system)
+			     default-file-name-coding-system))))
+	(push (cons group decoded) gnus-cache-decoded-group-names)
+	(push (cons (mm-decode-coding-string
+		     (mm-encode-coding-string decoded coding)
+		     coding)
+		    group)
+	      gnus-cache-unified-group-names)
+	decoded)))
+
 (defun gnus-cache-file-name (group article)
+  (setq group (gnus-cache-decoded-group-name group))
   (expand-file-name
    (if (stringp article) article (int-to-string article))
    (file-name-as-directory
@@ -456,7 +499,8 @@ Returns the list of articles removed."
   "Possibly remove ARTICLE from the cache."
   (let ((group gnus-newsgroup-name)
 	(number article)
-	file)
+	file
+	(file-name-coding-system nnmail-pathname-coding-system))
     ;; If this is a virtual group, we find the real group.
     (when (gnus-virtual-group-p group)
       (let ((result (nnvirtual-find-group-art
@@ -488,10 +532,11 @@ Returns the list of articles removed."
 (defun gnus-cache-articles-in-group (group)
   "Return a sorted list of cached articles in GROUP."
   (let ((dir (file-name-directory (gnus-cache-file-name group 1)))
-	articles)
+	articles
+	(file-name-coding-system nnmail-pathname-coding-system))
     (when (file-exists-p dir)
       (setq articles
-	    (sort (mapcar (lambda (name) (string-to-int name))
+	    (sort (mapcar (lambda (name) (string-to-number name))
 			  (directory-files dir nil "^[0-9]+$" t))
 		  '<))
       ;; Update the cache active file, just to synch more.
@@ -508,11 +553,10 @@ Returns the list of articles removed."
   (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))
 	beg end)
     (gnus-cache-save-buffers)
-    (save-excursion
-      (set-buffer cache-buf)
+    (with-current-buffer cache-buf
       (erase-buffer)
-      (let ((coding-system-for-read
-	     gnus-cache-overview-coding-system))
+      (let ((coding-system-for-read gnus-cache-overview-coding-system)
+	    (file-name-coding-system nnmail-pathname-coding-system))
 	(insert-file-contents
 	 (or file (gnus-cache-file-name group ".overview"))))
       (goto-char (point-min))
@@ -540,35 +584,33 @@ Returns the list of articles removed."
 
 (defun gnus-cache-braid-heads (group cached)
   (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")))
-    (save-excursion
-      (set-buffer cache-buf)
+    (with-current-buffer cache-buf
       (erase-buffer))
     (set-buffer nntp-server-buffer)
     (goto-char (point-min))
-    (while cached
+    (dolist (entry cached)
       (while (and (not (eobp))
 		  (looking-at "2.. +\\([0-9]+\\) ")
 		  (< (progn (goto-char (match-beginning 1))
 			    (read (current-buffer)))
-		     (car cached)))
+		     entry))
 	(search-forward "\n.\n" nil 'move))
       (beginning-of-line)
       (set-buffer cache-buf)
       (erase-buffer)
-      (let ((coding-system-for-read
-	     gnus-cache-coding-system))
-	(insert-file-contents (gnus-cache-file-name group (car cached))))
+      (let ((coding-system-for-read gnus-cache-coding-system)
+	    (file-name-coding-system nnmail-pathname-coding-system))
+	(insert-file-contents (gnus-cache-file-name group entry)))
       (goto-char (point-min))
       (insert "220 ")
-      (princ (car cached) (current-buffer))
+      (princ (pop cached) (current-buffer))
       (insert " Article retrieved.\n")
       (search-forward "\n\n" nil 'move)
       (delete-region (point) (point-max))
       (forward-char -1)
       (insert ".")
       (set-buffer nntp-server-buffer)
-      (insert-buffer-substring cache-buf)
-      (setq cached (cdr cached)))
+      (insert-buffer-substring cache-buf))
     (kill-buffer cache-buf)))
 
 ;;;###autoload
@@ -580,7 +622,6 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
   (interactive)
   (let ((gnus-mark-article-hook nil)
 	(gnus-expert-user t)
-	(nnmail-spool-file nil)
 	(mail-sources nil)
 	(gnus-use-dribble-file nil)
 	(gnus-novice-user nil)
@@ -664,6 +705,7 @@ If LOW, update the lower bound instead."
   (interactive)
   (let* ((top (null directory))
 	 (directory (expand-file-name (or directory gnus-cache-directory)))
+	 (file-name-coding-system nnmail-pathname-coding-system)
 	 (files (directory-files directory 'full))
 	 (group
 	  (if top
@@ -685,20 +727,25 @@ If LOW, update the lower bound instead."
     ;; Separate articles from all other files and directories.
     (while files
       (if (string-match "^[0-9]+$" (file-name-nondirectory (car files)))
-	  (push (string-to-int (file-name-nondirectory (pop files))) nums)
+	  (push (string-to-number (file-name-nondirectory (pop files))) nums)
 	(push (pop files) alphs)))
     ;; If we have nums, then this is probably a valid group.
     (when (setq nums (sort nums '<))
-      (gnus-sethash group (cons (car nums) (gnus-last-element nums))
+      ;; Use non-decoded group name.
+      ;; FIXME: this is kind of a workaround.  The active file should
+      ;; be updated at the time articles are cached.  It will make
+      ;; `gnus-cache-unified-group-names' needless.
+      (gnus-sethash (or (cdr (assoc group gnus-cache-unified-group-names))
+			group)
+		    (cons (car nums) (gnus-last-element nums))
 		    gnus-cache-active-hashtb))
     ;; Go through all the other files.
-    (while alphs
-      (when (and (file-directory-p (car alphs))
+    (dolist (file alphs)
+      (when (and (file-directory-p file)
 		 (not (string-match "^\\."
-				    (file-name-nondirectory (car alphs)))))
+				    (file-name-nondirectory file))))
 	;; We descend directories.
-	(gnus-cache-generate-active (car alphs)))
-      (setq alphs (cdr alphs)))
+	(gnus-cache-generate-active file)))
     ;; Write the new active file.
     (when top
       (gnus-cache-write-active t)
@@ -710,7 +757,7 @@ If LOW, update the lower bound instead."
   (interactive (list gnus-cache-directory))
   (gnus-cache-close)
   (let ((nnml-generate-active-function 'identity))
-    (nnml-generate-nov-databases-1 dir))
+    (nnml-generate-nov-databases-directory dir))
 
   (setq gnus-cache-total-fetched-hashtb nil)
 
@@ -736,11 +783,14 @@ If GROUP is non-nil, also cater to `gnus-cacheable-groups' and
 
 ;;;###autoload
 (defun gnus-cache-rename-group (old-group new-group)
-  "Rename OLD-GROUP as NEW-GROUP.  Always updates the cache, even when
-disabled, as the old cache files would corrupt gnus when the cache was
-next enabled. Depends upon the caller to determine whether group renaming is supported."
+  "Rename OLD-GROUP as NEW-GROUP.
+Always updates the cache, even when disabled, as the old cache
+files would corrupt Gnus when the cache was next enabled.  It
+depends on the caller to determine whether group renaming is
+supported."
   (let ((old-dir (gnus-cache-file-name old-group ""))
-	(new-dir (gnus-cache-file-name new-group "")))
+	(new-dir (gnus-cache-file-name new-group ""))
+	(file-name-coding-system nnmail-pathname-coding-system))
     (gnus-rename-file old-dir new-dir t))
 
   (gnus-cache-rename-group-total-fetched-for old-group new-group)
@@ -748,9 +798,12 @@ next enabled. Depends upon the caller to determine whether group renaming is sup
   (let ((no-save gnus-cache-active-hashtb))
     (unless gnus-cache-active-hashtb
       (gnus-cache-read-active))
-    (let* ((old-group-hash-value (gnus-gethash old-group gnus-cache-active-hashtb))
-	   (new-group-hash-value (gnus-gethash new-group gnus-cache-active-hashtb))
-	   (delta                (or old-group-hash-value new-group-hash-value)))
+    (let* ((old-group-hash-value
+	    (gnus-gethash old-group gnus-cache-active-hashtb))
+	   (new-group-hash-value
+	    (gnus-gethash new-group gnus-cache-active-hashtb))
+	   (delta
+	    (or old-group-hash-value new-group-hash-value)))
       (gnus-sethash new-group old-group-hash-value gnus-cache-active-hashtb)
       (gnus-sethash old-group nil gnus-cache-active-hashtb)
 
@@ -760,11 +813,14 @@ next enabled. Depends upon the caller to determine whether group renaming is sup
 
 ;;;###autoload
 (defun gnus-cache-delete-group (group)
-  "Delete GROUP.  Always updates the cache, even when
-disabled, as the old cache files would corrupt gnus when the cache was
-next enabled. Depends upon the caller to determine whether group deletion is supported."
-  (let ((dir (gnus-cache-file-name group "")))
-    (gnus-delete-file dir))
+  "Delete GROUP from the cache.
+Always updates the cache, even when disabled, as the old cache
+files would corrupt gnus when the cache was next enabled.
+Depends upon the caller to determine whether group deletion is
+supported."
+  (let ((dir (gnus-cache-file-name group ""))
+	(file-name-coding-system nnmail-pathname-coding-system))
+    (gnus-delete-directory dir))
 
   (gnus-cache-delete-group-total-fetched-for group)
 
@@ -786,8 +842,7 @@ next enabled. Depends upon the caller to determine whether group deletion is sup
 	    ,@body)
      (when (and gnus-cache-need-update-total-fetched-for
 		(not gnus-cache-inhibit-update-total-fetched-for))
-	(save-excursion
-	  (set-buffer gnus-group-buffer)
+	(with-current-buffer gnus-group-buffer
 	  (setq gnus-cache-need-update-total-fetched-for nil)
 	  (gnus-group-update-group ,group t)))))
 
@@ -802,14 +857,15 @@ next enabled. Depends upon the caller to determine whether group deletion is sup
 
        (if file
 	   (setq size (or (nth 7 (file-attributes file)) 0))
-	 (let ((files (directory-files (gnus-cache-file-name group "") 
-				       t nil t))
-	       file attrs)
+	 (let* ((file-name-coding-system nnmail-pathname-coding-system)
+		(files (directory-files (gnus-cache-file-name group "")
+					t nil t))
+		file attrs)
 	   (setq size 0.0)
 	   (while (setq file (pop files))
 	     (setq attrs (file-attributes file))
 	     (unless (nth 0 attrs)
-	       (incf size (float (nth 7 attrs)))))))	     
+	       (incf size (float (nth 7 attrs)))))))
 
        (setq gnus-cache-need-update-total-fetched-for t)
 
@@ -820,9 +876,10 @@ next enabled. Depends upon the caller to determine whether group deletion is sup
     (gnus-cache-with-refreshed-group
      group
      (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb)
-		       (gnus-sethash group (make-list 2 0) 
+		       (gnus-sethash group (make-list 2 0)
 				     gnus-cache-total-fetched-hashtb)))
-	    (size (or (nth 7 (file-attributes 
+	    (file-name-coding-system nnmail-pathname-coding-system)
+	    (size (or (nth 7 (file-attributes
 			      (or file
 				  (gnus-cache-file-name group ".overview"))))
 		      0)))
@@ -843,16 +900,17 @@ next enabled. Depends upon the caller to determine whether group deletion is sup
 
 (defun gnus-cache-total-fetched-for (group &optional no-inhibit)
   "Get total disk space used by the cache for the specified GROUP."
-  (unless gnus-cache-total-fetched-hashtb
-    (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1024)))
-
-  (let* ((entry (gnus-gethash group gnus-cache-total-fetched-hashtb)))
-    (if entry
-	(apply '+ entry)
-      (let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit)))
-	(+ 
-	 (gnus-cache-update-overview-total-fetched-for group nil)
-	 (gnus-cache-update-file-total-fetched-for     group nil))))))
+  (unless (equal group "dummy.group")
+    (unless gnus-cache-total-fetched-hashtb
+      (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1024)))
+
+    (let* ((entry (gnus-gethash group gnus-cache-total-fetched-hashtb)))
+      (if entry
+	  (apply '+ entry)
+	(let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit)))
+	  (+
+	   (gnus-cache-update-overview-total-fetched-for group nil)
+	   (gnus-cache-update-file-total-fetched-for     group nil)))))))
 
 (provide 'gnus-cache)