X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-cache.el;h=b3cdb3b2b17019431d85efca6b399361830a7ac2;hp=e347135e22285492a84ab02ed3acf3a4aef96c5b;hb=23c6fe6e28b8b6f356bae60e2fc773c41cd8b540;hpb=b09a5bb4fbe14ae9769670d1131ab3b204dda4c9 diff --git a/lisp/gnus-cache.el b/lisp/gnus-cache.el index e347135e2..b3cdb3b2b 100644 --- a/lisp/gnus-cache.el +++ b/lisp/gnus-cache.el @@ -1,16 +1,16 @@ ;;; gnus-cache.el --- cache interface for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005 Free Software Foundation, Inc. + +;; Copyright (C) 1995-2013 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; 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 +18,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 . ;;; 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 +93,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") @@ -130,16 +134,17 @@ it's not cached." (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,8 @@ it's not cached." (numberp article) (> article 0)) ; This might be a dummy article. (let ((number article) - file headers lines-chars) + 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 +179,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)) @@ -259,7 +264,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) @@ -288,7 +294,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)) @@ -358,7 +365,7 @@ Returns the list of articles removed." (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) @@ -375,9 +382,14 @@ Returns the list of articles removed." "Insert all the articles cached for this group into the current buffer." (interactive) (let ((gnus-verbose (max 6 gnus-verbose))) - (if (not gnus-newsgroup-cached) - (gnus-message 3 "No cached articles for this group") - (gnus-summary-goto-subjects gnus-newsgroup-cached)))) + (cond + ((not gnus-newsgroup-cached) + (gnus-message 3 "No cached articles for this group")) + ;; This is faster if there are few articles to insert. + ((< (length gnus-newsgroup-cached) 20) + (gnus-summary-goto-subjects gnus-newsgroup-cached)) + (t + (gnus-summary-include-articles gnus-newsgroup-cached))))) (defun gnus-summary-limit-include-cached () "Limit the summary buffer to articles that are cached." @@ -407,7 +419,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, @@ -421,8 +434,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-group-decoded-name group)) + (setq group (gnus-cache-decoded-group-name group)) (expand-file-name (if (stringp article) article (int-to-string article)) (file-name-as-directory @@ -455,7 +503,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 @@ -487,7 +536,8 @@ 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-number name)) @@ -507,11 +557,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)) @@ -553,12 +602,12 @@ Returns the list of articles removed." (beginning-of-line) (set-buffer cache-buf) (erase-buffer) - (let ((coding-system-for-read - gnus-cache-coding-system)) + (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)) @@ -577,7 +626,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) @@ -661,6 +709,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 @@ -686,7 +735,13 @@ If LOW, update the lower bound instead." (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. (dolist (file alphs) @@ -706,7 +761,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) @@ -732,11 +787,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) @@ -744,9 +802,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) @@ -756,10 +817,13 @@ 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 ""))) + "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) @@ -782,8 +846,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))))) @@ -798,14 +861,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) @@ -816,9 +880,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))) @@ -839,18 +904,18 @@ 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) -;;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a ;;; gnus-cache.el ends here