Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-cache.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 131b0175ea99
children 360340f9fd5f
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;;; gnus-cache.el --- cache interface for Gnus 1 ;;; gnus-cache.el --- cache interface for Gnus
2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
3 3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Keywords: news 5 ;; Keywords: news
6 6
7 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
24 ;;; Commentary: 24 ;;; Commentary:
25 25
26 ;;; Code: 26 ;;; Code:
27 27
28 (require 'gnus) 28 (require 'gnus)
29 (eval-when-compile (require 'cl)) 29 (require 'gnus-int)
30 30 (require 'gnus-range)
31 (defvar gnus-cache-directory 31 (require 'gnus-start)
32 (eval-when-compile
33 (require 'gnus-sum))
34
35 (defgroup gnus-cache nil
36 "Cache interface."
37 :group 'gnus)
38
39 (defcustom gnus-cache-directory
32 (nnheader-concat gnus-directory "cache/") 40 (nnheader-concat gnus-directory "cache/")
33 "*The directory where cached articles will be stored.") 41 "*The directory where cached articles will be stored."
34 42 :group 'gnus-cache
35 (defvar gnus-cache-active-file 43 :type 'directory)
44
45 (defcustom gnus-cache-active-file
36 (concat (file-name-as-directory gnus-cache-directory) "active") 46 (concat (file-name-as-directory gnus-cache-directory) "active")
37 "*The cache active file.") 47 "*The cache active file."
38 48 :group 'gnus-cache
39 (defvar gnus-cache-enter-articles '(ticked dormant) 49 :type 'file)
40 "*Classes of articles to enter into the cache.") 50
41 51 (defcustom gnus-cache-enter-articles '(ticked dormant)
42 (defvar gnus-cache-remove-articles '(read) 52 "Classes of articles to enter into the cache."
43 "*Classes of articles to remove from the cache.") 53 :group 'gnus-cache
44 54 :type '(set (const ticked) (const dormant) (const unread) (const read)))
45 (defvar gnus-uncacheable-groups nil 55
56 (defcustom gnus-cache-remove-articles '(read)
57 "Classes of articles to remove from the cache."
58 :group 'gnus-cache
59 :type '(set (const ticked) (const dormant) (const unread) (const read)))
60
61 (defcustom gnus-uncacheable-groups nil
46 "*Groups that match this regexp will not be cached. 62 "*Groups that match this regexp will not be cached.
47 63
48 If you want to avoid caching your nnml groups, you could set this 64 If you want to avoid caching your nnml groups, you could set this
49 variable to \"^nnml\".") 65 variable to \"^nnml\"."
66 :group 'gnus-cache
67 :type '(choice (const :tag "off" nil)
68 regexp))
50 69
51 70
52 71
53 ;;; Internal variables. 72 ;;; Internal variables.
54 73
74 (defvar gnus-cache-removable-articles nil)
55 (defvar gnus-cache-buffer nil) 75 (defvar gnus-cache-buffer nil)
56 (defvar gnus-cache-active-hashtb nil) 76 (defvar gnus-cache-active-hashtb nil)
57 (defvar gnus-cache-active-altered nil) 77 (defvar gnus-cache-active-altered nil)
58 78
59 (eval-and-compile 79 (eval-and-compile
69 (when (or (file-exists-p gnus-cache-directory) 89 (when (or (file-exists-p gnus-cache-directory)
70 (and gnus-use-cache 90 (and gnus-use-cache
71 (not (eq gnus-use-cache 'passive)))) 91 (not (eq gnus-use-cache 'passive))))
72 (gnus-cache-read-active))) 92 (gnus-cache-read-active)))
73 93
74 (condition-case () 94 ;; Complexities of byte-compiling make this kludge necessary. Eeek.
75 (gnus-add-shutdown 'gnus-cache-close 'gnus) 95 (ignore-errors
76 ;; Complexities of byte-compiling makes this kludge necessary. Eeek. 96 (gnus-add-shutdown 'gnus-cache-close 'gnus))
77 (error nil))
78 97
79 (defun gnus-cache-close () 98 (defun gnus-cache-close ()
80 "Shut down the cache." 99 "Shut down the cache."
81 (gnus-cache-write-active) 100 (gnus-cache-write-active)
82 (gnus-cache-save-buffers) 101 (gnus-cache-save-buffers)
83 (setq gnus-cache-active-hashtb nil)) 102 (setq gnus-cache-active-hashtb nil))
84 103
85 (defun gnus-cache-save-buffers () 104 (defun gnus-cache-save-buffers ()
86 ;; save the overview buffer if it exists and has been modified 105 ;; save the overview buffer if it exists and has been modified
87 ;; delete empty cache subdirectories 106 ;; delete empty cache subdirectories
88 (if (null gnus-cache-buffer) 107 (when gnus-cache-buffer
89 ()
90 (let ((buffer (cdr gnus-cache-buffer)) 108 (let ((buffer (cdr gnus-cache-buffer))
91 (overview-file (gnus-cache-file-name 109 (overview-file (gnus-cache-file-name
92 (car gnus-cache-buffer) ".overview"))) 110 (car gnus-cache-buffer) ".overview")))
93 ;; write the overview only if it was modified 111 ;; write the overview only if it was modified
94 (if (buffer-modified-p buffer) 112 (when (buffer-modified-p buffer)
95 (save-excursion 113 (save-excursion
96 (set-buffer buffer) 114 (set-buffer buffer)
97 (if (> (buffer-size) 0) 115 (if (> (buffer-size) 0)
98 ;; non-empty overview, write it out 116 ;; Non-empty overview, write it to a file.
99 (progn 117 (gnus-write-buffer overview-file)
100 (gnus-make-directory (file-name-directory overview-file)) 118 ;; Empty overview file, remove it
101 (write-region (point-min) (point-max) 119 (when (file-exists-p overview-file)
102 overview-file nil 'quietly)) 120 (delete-file overview-file))
103 ;; empty overview file, remove it 121 ;; If possible, remove group's cache subdirectory.
104 (and (file-exists-p overview-file) 122 (condition-case nil
105 (delete-file overview-file)) 123 ;; FIXME: we can detect the error type and warn the user
106 ;; if possible, remove group's cache subdirectory 124 ;; of any inconsistencies (articles w/o nov entries?).
107 (condition-case nil 125 ;; for now, just be conservative...delete only if safe -- sj
108 ;; FIXME: we can detect the error type and warn the user 126 (delete-directory (file-name-directory overview-file))
109 ;; of any inconsistencies (articles w/o nov entries?). 127 (error nil)))))
110 ;; for now, just be conservative...delete only if safe -- sj 128 ;; Kill the buffer -- it's either unmodified or saved.
111 (delete-directory (file-name-directory overview-file))
112 (error nil)))))
113 ;; kill the buffer, it's either unmodified or saved
114 (gnus-kill-buffer buffer) 129 (gnus-kill-buffer buffer)
115 (setq gnus-cache-buffer nil)))) 130 (setq gnus-cache-buffer nil))))
116 131
117 (defun gnus-cache-possibly-enter-article 132 (defun gnus-cache-possibly-enter-article
118 (group article headers ticked dormant unread &optional force) 133 (group article headers ticked dormant unread &optional force)
119 (when (and (or force (not (eq gnus-use-cache 'passive))) 134 (when (and (or force (not (eq gnus-use-cache 'passive)))
120 (numberp article) 135 (numberp article)
121 (> article 0) 136 (> article 0)
122 (vectorp headers)) ; This might be a dummy article. 137 (vectorp headers))
138 ; This might be a dummy article.
123 ;; If this is a virtual group, we find the real group. 139 ;; If this is a virtual group, we find the real group.
124 (when (gnus-virtual-group-p group) 140 (when (gnus-virtual-group-p group)
125 (let ((result (nnvirtual-find-group-art 141 (let ((result (nnvirtual-find-group-art
126 (gnus-group-real-name group) article))) 142 (gnus-group-real-name group) article)))
127 (setq group (car result) 143 (setq group (car result)
128 headers (copy-sequence headers)) 144 headers (copy-sequence headers))
129 (mail-header-set-number headers (cdr result)))) 145 (mail-header-set-number headers (cdr result))))
130 (let ((number (mail-header-number headers)) 146 (let ((number (mail-header-number headers))
131 file dir) 147 file dir)
132 (when (and (> number 0) ; Reffed article. 148 (when (and (> number 0) ; Reffed article.
133 (or (not gnus-uncacheable-groups)
134 (not (string-match gnus-uncacheable-groups group)))
135 (or force 149 (or force
136 (gnus-cache-member-of-class 150 (and (or (not gnus-uncacheable-groups)
137 gnus-cache-enter-articles ticked dormant unread)) 151 (not (string-match
152 gnus-uncacheable-groups group)))
153 (gnus-cache-member-of-class
154 gnus-cache-enter-articles ticked dormant unread)))
138 (not (file-exists-p (setq file (gnus-cache-file-name 155 (not (file-exists-p (setq file (gnus-cache-file-name
139 group number))))) 156 group number)))))
140 ;; Possibly create the cache directory. 157 ;; Possibly create the cache directory.
141 (or (file-exists-p (setq dir (file-name-directory file))) 158 (gnus-make-directory (setq dir (file-name-directory file)))
142 (gnus-make-directory dir))
143 ;; Save the article in the cache. 159 ;; Save the article in the cache.
144 (if (file-exists-p file) 160 (if (file-exists-p file)
145 t ; The article already is saved. 161 t ; The article already is saved.
146 (save-excursion 162 (save-excursion
147 (set-buffer nntp-server-buffer) 163 (set-buffer nntp-server-buffer)
148 (let ((gnus-use-cache nil)) 164 (let ((gnus-use-cache nil))
149 (gnus-request-article-this-buffer number group)) 165 (gnus-request-article-this-buffer number group))
150 (when (> (buffer-size) 0) 166 (when (> (buffer-size) 0)
151 (write-region (point-min) (point-max) file nil 'quiet) 167 (gnus-write-buffer file)
152 (gnus-cache-change-buffer group) 168 (gnus-cache-change-buffer group)
153 (set-buffer (cdr gnus-cache-buffer)) 169 (set-buffer (cdr gnus-cache-buffer))
154 (goto-char (point-max)) 170 (goto-char (point-max))
155 (forward-line -1) 171 (forward-line -1)
156 (while (condition-case () 172 (while (condition-case ()
157 (and (not (bobp)) 173 (when (not (bobp))
158 (> (read (current-buffer)) number)) 174 (> (read (current-buffer)) number))
159 (error 175 (error
160 ;; The line was malformed, so we just remove it!! 176 ;; The line was malformed, so we just remove it!!
161 (gnus-delete-line) 177 (gnus-delete-line)
162 t)) 178 t))
163 (forward-line -1)) 179 (forward-line -1))
164 (if (bobp) 180 (if (bobp)
165 (if (not (eobp)) 181 (if (not (eobp))
166 (progn 182 (progn
167 (beginning-of-line) 183 (beginning-of-line)
168 (if (< (read (current-buffer)) number) 184 (when (< (read (current-buffer)) number)
169 (forward-line 1))) 185 (forward-line 1)))
170 (beginning-of-line)) 186 (beginning-of-line))
171 (forward-line 1)) 187 (forward-line 1))
172 (beginning-of-line) 188 (beginning-of-line)
173 ;; [number subject from date id references chars lines xref] 189 ;; [number subject from date id references chars lines xref]
174 (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n" 190 (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n"
213 (let ((articles gnus-cache-removable-articles) 229 (let ((articles gnus-cache-removable-articles)
214 (cache-articles gnus-newsgroup-cached) 230 (cache-articles gnus-newsgroup-cached)
215 article) 231 article)
216 (gnus-cache-change-buffer gnus-newsgroup-name) 232 (gnus-cache-change-buffer gnus-newsgroup-name)
217 (while articles 233 (while articles
218 (if (memq (setq article (pop articles)) cache-articles) 234 (when (memq (setq article (pop articles)) cache-articles)
219 ;; The article was in the cache, so we see whether we are 235 ;; The article was in the cache, so we see whether we are
220 ;; supposed to remove it from the cache. 236 ;; supposed to remove it from the cache.
221 (gnus-cache-possibly-remove-article 237 (gnus-cache-possibly-remove-article
222 article (memq article gnus-newsgroup-marked) 238 article (memq article gnus-newsgroup-marked)
223 (memq article gnus-newsgroup-dormant) 239 (memq article gnus-newsgroup-dormant)
224 (or (memq article gnus-newsgroup-unreads) 240 (or (memq article gnus-newsgroup-unreads)
225 (memq article gnus-newsgroup-unselected)))))) 241 (memq article gnus-newsgroup-unselected))))))
226 ;; The overview file might have been modified, save it 242 ;; The overview file might have been modified, save it
227 ;; safe because we're only called at group exit anyway. 243 ;; safe because we're only called at group exit anyway.
228 (gnus-cache-save-buffers))) 244 (gnus-cache-save-buffers)))
229 245
230 (defun gnus-cache-request-article (article group) 246 (defun gnus-cache-request-article (article group)
237 (insert-file-contents file) 253 (insert-file-contents file)
238 t))) 254 t)))
239 255
240 (defun gnus-cache-possibly-alter-active (group active) 256 (defun gnus-cache-possibly-alter-active (group active)
241 "Alter the ACTIVE info for GROUP to reflect the articles in the cache." 257 "Alter the ACTIVE info for GROUP to reflect the articles in the cache."
258 (when (equal group "no.norsk") (error "hie"))
242 (when gnus-cache-active-hashtb 259 (when gnus-cache-active-hashtb
243 (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) 260 (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
244 (and cache-active 261 (and cache-active
245 (< (car cache-active) (car active)) 262 (< (car cache-active) (car active))
246 (setcar active (car cache-active))) 263 (setcar active (car cache-active)))
300 Returns the list of articles entered." 317 Returns the list of articles entered."
301 (interactive "P") 318 (interactive "P")
302 (gnus-set-global-variables) 319 (gnus-set-global-variables)
303 (let ((articles (gnus-summary-work-articles n)) 320 (let ((articles (gnus-summary-work-articles n))
304 article out) 321 article out)
305 (while articles 322 (while (setq article (pop articles))
306 (setq article (pop articles)) 323 (if (natnump article)
307 (when (gnus-cache-possibly-enter-article 324 (when (gnus-cache-possibly-enter-article
308 gnus-newsgroup-name article (gnus-summary-article-header article) 325 gnus-newsgroup-name article
309 nil nil nil t) 326 (gnus-summary-article-header article)
310 (push article out)) 327 nil nil nil t)
328 (push article out))
329 (gnus-message 2 "Can't cache article %d" article))
311 (gnus-summary-remove-process-mark article) 330 (gnus-summary-remove-process-mark article)
312 (gnus-summary-update-secondary-mark article)) 331 (gnus-summary-update-secondary-mark article))
313 (gnus-summary-next-subject 1) 332 (gnus-summary-next-subject 1)
314 (gnus-summary-position-point) 333 (gnus-summary-position-point)
315 (nreverse out))) 334 (nreverse out)))
335 354
336 (defun gnus-cached-article-p (article) 355 (defun gnus-cached-article-p (article)
337 "Say whether ARTICLE is cached in the current group." 356 "Say whether ARTICLE is cached in the current group."
338 (memq article gnus-newsgroup-cached)) 357 (memq article gnus-newsgroup-cached))
339 358
359 (defun gnus-summary-insert-cached-articles ()
360 "Insert all the articles cached for this group into the current buffer."
361 (interactive)
362 (let ((cached gnus-newsgroup-cached)
363 (gnus-verbose (max 6 gnus-verbose)))
364 (unless cached
365 (error "No cached articles for this group"))
366 (while cached
367 (gnus-summary-goto-subject (pop cached) t))))
368
340 ;;; Internal functions. 369 ;;; Internal functions.
341 370
342 (defun gnus-cache-change-buffer (group) 371 (defun gnus-cache-change-buffer (group)
343 (and gnus-cache-buffer 372 (and gnus-cache-buffer
344 ;; See if the current group's overview cache has been loaded. 373 ;; See if the current group's overview cache has been loaded.
345 (or (string= group (car gnus-cache-buffer)) 374 (or (string= group (car gnus-cache-buffer))
346 ;; Another overview cache is current, save it. 375 ;; Another overview cache is current, save it.
347 (gnus-cache-save-buffers))) 376 (gnus-cache-save-buffers)))
348 ;; if gnus-cache buffer is nil, create it 377 ;; if gnus-cache buffer is nil, create it
349 (or gnus-cache-buffer 378 (unless gnus-cache-buffer
350 ;; Create cache buffer 379 ;; Create cache buffer
351 (save-excursion 380 (save-excursion
352 (setq gnus-cache-buffer 381 (setq gnus-cache-buffer
353 (cons group 382 (cons group
354 (set-buffer (get-buffer-create " *gnus-cache-overview*")))) 383 (set-buffer (get-buffer-create " *gnus-cache-overview*"))))
355 (buffer-disable-undo (current-buffer)) 384 (buffer-disable-undo (current-buffer))
356 ;; Insert the contents of this group's cache overview. 385 ;; Insert the contents of this group's cache overview.
357 (erase-buffer) 386 (erase-buffer)
358 (let ((file (gnus-cache-file-name group ".overview"))) 387 (let ((file (gnus-cache-file-name group ".overview")))
359 (and (file-exists-p file) 388 (when (file-exists-p file)
360 (insert-file-contents file))) 389 (nnheader-insert-file-contents file)))
361 ;; We have a fresh (empty/just loaded) buffer, 390 ;; We have a fresh (empty/just loaded) buffer,
362 ;; mark it as unmodified to save a redundant write later. 391 ;; mark it as unmodified to save a redundant write later.
363 (set-buffer-modified-p nil)))) 392 (set-buffer-modified-p nil))))
364 393
365 ;; Return whether an article is a member of a class. 394 ;; Return whether an article is a member of a class.
366 (defun gnus-cache-member-of-class (class ticked dormant unread) 395 (defun gnus-cache-member-of-class (class ticked dormant unread)
367 (or (and ticked (memq 'ticked class)) 396 (or (and ticked (memq 'ticked class))
368 (and dormant (memq 'dormant class)) 397 (and dormant (memq 'dormant class))
370 (and (not unread) (not ticked) (not dormant) (memq 'read class)))) 399 (and (not unread) (not ticked) (not dormant) (memq 'read class))))
371 400
372 (defun gnus-cache-file-name (group article) 401 (defun gnus-cache-file-name (group article)
373 (concat (file-name-as-directory gnus-cache-directory) 402 (concat (file-name-as-directory gnus-cache-directory)
374 (file-name-as-directory 403 (file-name-as-directory
375 (if (gnus-use-long-file-name 'not-cache) 404 (nnheader-translate-file-chars
376 group 405 (if (gnus-use-long-file-name 'not-cache)
377 (let ((group (nnheader-replace-chars-in-string group ?/ ?_))) 406 group
378 ;; Translate the first colon into a slash. 407 (let ((group (nnheader-replace-chars-in-string group ?/ ?_)))
379 (when (string-match ":" group) 408 ;; Translate the first colon into a slash.
380 (aset group (match-beginning 0) ?/)) 409 (when (string-match ":" group)
381 (nnheader-replace-chars-in-string group ?. ?/)))) 410 (aset group (match-beginning 0) ?/))
411 (nnheader-replace-chars-in-string group ?. ?/)))))
382 (if (stringp article) article (int-to-string article)))) 412 (if (stringp article) article (int-to-string article))))
383 413
384 (defun gnus-cache-update-article (group article) 414 (defun gnus-cache-update-article (group article)
385 "If ARTICLE is in the cache, remove it and re-enter it." 415 "If ARTICLE is in the cache, remove it and re-enter it."
386 (when (gnus-cache-possibly-remove-article article nil nil nil t) 416 (when (gnus-cache-possibly-remove-article article nil nil nil t)
408 gnus-cache-remove-articles ticked dormant unread))) 438 gnus-cache-remove-articles ticked dormant unread)))
409 (save-excursion 439 (save-excursion
410 (delete-file file) 440 (delete-file file)
411 (set-buffer (cdr gnus-cache-buffer)) 441 (set-buffer (cdr gnus-cache-buffer))
412 (goto-char (point-min)) 442 (goto-char (point-min))
413 (if (or (looking-at (concat (int-to-string number) "\t")) 443 (when (or (looking-at (concat (int-to-string number) "\t"))
414 (search-forward (concat "\n" (int-to-string number) "\t") 444 (search-forward (concat "\n" (int-to-string number) "\t")
415 (point-max) t)) 445 (point-max) t))
416 (delete-region (progn (beginning-of-line) (point)) 446 (delete-region (progn (beginning-of-line) (point))
417 (progn (forward-line 1) (point))))) 447 (progn (forward-line 1) (point)))))
418 (setq gnus-newsgroup-cached 448 (setq gnus-newsgroup-cached
419 (delq article gnus-newsgroup-cached)) 449 (delq article gnus-newsgroup-cached))
420 (gnus-summary-update-secondary-mark article) 450 (gnus-summary-update-secondary-mark article)
421 t))) 451 t)))
422 452
423 (defun gnus-cache-articles-in-group (group) 453 (defun gnus-cache-articles-in-group (group)
424 "Return a sorted list of cached articles in GROUP." 454 "Return a sorted list of cached articles in GROUP."
425 (let ((dir (file-name-directory (gnus-cache-file-name group 1))) 455 (let ((dir (file-name-directory (gnus-cache-file-name group 1))))
426 articles)
427 (when (file-exists-p dir) 456 (when (file-exists-p dir)
428 (sort (mapcar (lambda (name) (string-to-int name)) 457 (sort (mapcar (lambda (name) (string-to-int name))
429 (directory-files dir nil "^[0-9]+$" t)) 458 (directory-files dir nil "^[0-9]+$" t))
430 '<)))) 459 '<))))
431 460
432 (defun gnus-cache-braid-nov (group cached) 461 (defun gnus-cache-braid-nov (group cached)
433 (let ((cache-buf (get-buffer-create " *gnus-cache*")) 462 (let ((cache-buf (get-buffer-create " *gnus-cache*"))
453 (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") 482 (if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
454 nil t) 483 nil t)
455 (setq beg (progn (beginning-of-line) (point)) 484 (setq beg (progn (beginning-of-line) (point))
456 end (progn (end-of-line) (point))) 485 end (progn (end-of-line) (point)))
457 (setq beg nil))) 486 (setq beg nil)))
458 (if beg (progn (insert-buffer-substring cache-buf beg end) 487 (when beg
459 (insert "\n"))) 488 (insert-buffer-substring cache-buf beg end)
489 (insert "\n"))
460 (setq cached (cdr cached))) 490 (setq cached (cdr cached)))
461 (kill-buffer cache-buf))) 491 (kill-buffer cache-buf)))
462 492
463 (defun gnus-cache-braid-heads (group cached) 493 (defun gnus-cache-braid-heads (group cached)
464 (let ((cache-buf (get-buffer-create " *gnus-cache*"))) 494 (let ((cache-buf (get-buffer-create " *gnus-cache*")))
492 (setq cached (cdr cached))) 522 (setq cached (cdr cached)))
493 (kill-buffer cache-buf))) 523 (kill-buffer cache-buf)))
494 524
495 ;;;###autoload 525 ;;;###autoload
496 (defun gnus-jog-cache () 526 (defun gnus-jog-cache ()
497 "Go through all groups and put the articles into the cache." 527 "Go through all groups and put the articles into the cache.
528
529 Usage:
530 $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
498 (interactive) 531 (interactive)
499 (let ((gnus-mark-article-hook nil) 532 (let ((gnus-mark-article-hook nil)
500 (gnus-expert-user t) 533 (gnus-expert-user t)
501 (nnmail-spool-file nil) 534 (nnmail-spool-file nil)
502 (gnus-use-dribble-file nil) 535 (gnus-use-dribble-file nil)
507 ;; Go through all groups... 540 ;; Go through all groups...
508 (gnus-group-mark-buffer) 541 (gnus-group-mark-buffer)
509 (gnus-group-universal-argument 542 (gnus-group-universal-argument
510 nil nil 543 nil nil
511 (lambda () 544 (lambda ()
512 (gnus-summary-read-group nil nil t) 545 (interactive)
546 (gnus-summary-read-group (gnus-group-group-name) nil t)
513 ;; ... and enter the articles into the cache. 547 ;; ... and enter the articles into the cache.
514 (when (eq major-mode 'gnus-summary-mode) 548 (when (eq major-mode 'gnus-summary-mode)
515 (gnus-uu-mark-buffer) 549 (gnus-uu-mark-buffer)
516 (gnus-cache-enter-article) 550 (gnus-cache-enter-article)
517 (kill-buffer (current-buffer))))))) 551 (kill-buffer (current-buffer)))))))
518 552
519 (defun gnus-cache-read-active (&optional force) 553 (defun gnus-cache-read-active (&optional force)
520 "Read the cache active file." 554 "Read the cache active file."
521 (unless (file-exists-p gnus-cache-directory) 555 (gnus-make-directory gnus-cache-directory)
522 (make-directory gnus-cache-directory t))
523 (if (not (and (file-exists-p gnus-cache-active-file) 556 (if (not (and (file-exists-p gnus-cache-active-file)
524 (or force (not gnus-cache-active-hashtb)))) 557 (or force (not gnus-cache-active-hashtb))))
525 ;; There is no active file, so we generate one. 558 ;; There is no active file, so we generate one.
526 (gnus-cache-generate-active) 559 (gnus-cache-generate-active)
527 ;; We simply read the active file. 560 ;; We simply read the active file.
537 (defun gnus-cache-write-active (&optional force) 570 (defun gnus-cache-write-active (&optional force)
538 "Write the active hashtb to the active file." 571 "Write the active hashtb to the active file."
539 (when (or force 572 (when (or force
540 (and gnus-cache-active-hashtb 573 (and gnus-cache-active-hashtb
541 gnus-cache-active-altered)) 574 gnus-cache-active-altered))
542 (save-excursion 575 (nnheader-temp-write gnus-cache-active-file
543 (gnus-set-work-buffer)
544 (mapatoms 576 (mapatoms
545 (lambda (sym) 577 (lambda (sym)
546 (when (and sym (boundp sym)) 578 (when (and sym (boundp sym))
547 (insert (format "%s %d %d y\n" 579 (insert (format "%s %d %d y\n"
548 (symbol-name sym) (cdr (symbol-value sym)) 580 (symbol-name sym) (cdr (symbol-value sym))
549 (car (symbol-value sym)))))) 581 (car (symbol-value sym))))))
550 gnus-cache-active-hashtb) 582 gnus-cache-active-hashtb))
551 (gnus-make-directory (file-name-directory gnus-cache-active-file))
552 (write-region
553 (point-min) (point-max) gnus-cache-active-file nil 'silent))
554 ;; Mark the active hashtb as unaltered. 583 ;; Mark the active hashtb as unaltered.
555 (setq gnus-cache-active-altered nil))) 584 (setq gnus-cache-active-altered nil)))
556 585
557 (defun gnus-cache-update-active (group number &optional low) 586 (defun gnus-cache-update-active (group number &optional low)
558 "Update the upper bound of the active info of GROUP to NUMBER. 587 "Update the upper bound of the active info of GROUP to NUMBER.
562 ;; We just create a new active entry for this group. 591 ;; We just create a new active entry for this group.
563 (gnus-sethash group (cons number number) gnus-cache-active-hashtb) 592 (gnus-sethash group (cons number number) gnus-cache-active-hashtb)
564 ;; Update the lower or upper bound. 593 ;; Update the lower or upper bound.
565 (if low 594 (if low
566 (setcar active number) 595 (setcar active number)
567 (setcdr active number)) 596 (setcdr active number)))
568 ;; Mark the active hashtb as altered. 597 ;; Mark the active hashtb as altered.
569 (setq gnus-cache-active-altered t)))) 598 (setq gnus-cache-active-altered t)))
570 599
571 ;;;###autoload 600 ;;;###autoload
572 (defun gnus-cache-generate-active (&optional directory) 601 (defun gnus-cache-generate-active (&optional directory)
573 "Generate the cache active file." 602 "Generate the cache active file."
574 (interactive) 603 (interactive)
617 (interactive (list gnus-cache-directory)) 646 (interactive (list gnus-cache-directory))
618 (gnus-cache-close) 647 (gnus-cache-close)
619 (let ((nnml-generate-active-function 'identity)) 648 (let ((nnml-generate-active-function 'identity))
620 (nnml-generate-nov-databases-1 dir))) 649 (nnml-generate-nov-databases-1 dir)))
621 650
651 (defun gnus-cache-move-cache (dir)
652 "Move the cache tree to somewhere else."
653 (interactive "DMove the cache tree to: ")
654 (rename-file gnus-cache-directory dir))
655
622 (provide 'gnus-cache) 656 (provide 'gnus-cache)
623 657
624 ;;; gnus-cache.el ends here 658 ;;; gnus-cache.el ends here