1 ;;; gnus-cache.el --- cache interface for Gnus
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
28 (eval-when-compile (require 'cl
))
37 (defgroup gnus-cache nil
41 (defcustom gnus-cache-directory
42 (nnheader-concat gnus-directory
"cache/")
43 "*The directory where cached articles will be stored."
47 (defcustom gnus-cache-active-file
48 (concat (file-name-as-directory gnus-cache-directory
) "active")
49 "*The cache active file."
53 (defcustom gnus-cache-enter-articles
'(ticked dormant
)
54 "Classes of articles to enter into the cache."
56 :type
'(set (const ticked
) (const dormant
) (const unread
) (const read
)))
58 (defcustom gnus-cache-remove-articles
'(read)
59 "Classes of articles to remove from the cache."
61 :type
'(set (const ticked
) (const dormant
) (const unread
) (const read
)))
63 (defcustom gnus-uncacheable-groups nil
64 "*Groups that match this regexp will not be cached.
66 If you want to avoid caching your nnml groups, you could set this
67 variable to \"^nnml\"."
69 :type
'(choice (const :tag
"off" nil
)
74 ;;; Internal variables.
76 (defvar gnus-cache-removable-articles nil
)
77 (defvar gnus-cache-buffer nil
)
78 (defvar gnus-cache-active-hashtb nil
)
79 (defvar gnus-cache-active-altered nil
)
82 (autoload 'nnml-generate-nov-databases-1
"nnml")
83 (autoload 'nnvirtual-find-group-art
"nnvirtual"))
87 ;;; Functions called from Gnus.
89 (defun gnus-cache-open ()
90 "Initialize the cache."
91 (when (or (file-exists-p gnus-cache-directory
)
93 (not (eq gnus-use-cache
'passive
))))
94 (gnus-cache-read-active)))
96 ;; Complexities of byte-compiling make this kludge necessary. Eeek.
98 (gnus-add-shutdown 'gnus-cache-close
'gnus
))
100 (defun gnus-cache-close ()
101 "Shut down the cache."
102 (gnus-cache-write-active)
103 (gnus-cache-save-buffers)
104 (setq gnus-cache-active-hashtb nil
))
106 (defun gnus-cache-save-buffers ()
107 ;; save the overview buffer if it exists and has been modified
108 ;; delete empty cache subdirectories
109 (when gnus-cache-buffer
110 (let ((buffer (cdr gnus-cache-buffer
))
111 (overview-file (gnus-cache-file-name
112 (car gnus-cache-buffer
) ".overview")))
113 ;; write the overview only if it was modified
114 (when (buffer-modified-p buffer
)
117 (if (> (buffer-size) 0)
118 ;; Non-empty overview, write it to a file.
119 (gnus-write-buffer overview-file
)
120 ;; Empty overview file, remove it
121 (when (file-exists-p overview-file
)
122 (delete-file overview-file
))
123 ;; If possible, remove group's cache subdirectory.
125 ;; FIXME: we can detect the error type and warn the user
126 ;; of any inconsistencies (articles w/o nov entries?).
127 ;; for now, just be conservative...delete only if safe -- sj
128 (delete-directory (file-name-directory overview-file
))
130 ;; Kill the buffer -- it's either unmodified or saved.
131 (gnus-kill-buffer buffer
)
132 (setq gnus-cache-buffer nil
))))
134 (defun gnus-cache-possibly-enter-article
135 (group article headers ticked dormant unread
&optional force
)
136 (when (and (or force
(not (eq gnus-use-cache
'passive
)))
139 (vectorp headers
)) ; This might be a dummy article.
140 ;; If this is a virtual group, we find the real group.
141 (when (gnus-virtual-group-p group
)
142 (let ((result (nnvirtual-find-group-art
143 (gnus-group-real-name group
) article
)))
144 (setq group
(car result
)
145 headers
(copy-sequence headers
))
146 (mail-header-set-number headers
(cdr result
))))
147 (let ((number (mail-header-number headers
))
149 (when (and (> number
0) ; Reffed article.
151 (and (or (not gnus-uncacheable-groups
)
153 gnus-uncacheable-groups group
)))
154 (gnus-cache-member-of-class
155 gnus-cache-enter-articles ticked dormant unread
)))
156 (not (file-exists-p (setq file
(gnus-cache-file-name
158 ;; Possibly create the cache directory.
159 (gnus-make-directory (setq dir
(file-name-directory file
)))
160 ;; Save the article in the cache.
161 (if (file-exists-p file
)
162 t
; The article already is saved.
164 (set-buffer nntp-server-buffer
)
165 (let ((gnus-use-cache nil
))
166 (gnus-request-article-this-buffer number group
))
167 (when (> (buffer-size) 0)
168 (gnus-write-buffer file
)
169 (gnus-cache-change-buffer group
)
170 (set-buffer (cdr gnus-cache-buffer
))
171 (goto-char (point-max))
173 (while (condition-case ()
175 (> (read (current-buffer)) number
))
177 ;; The line was malformed, so we just remove it!!
185 (when (< (read (current-buffer)) number
)
190 ;; [number subject from date id references chars lines xref]
191 (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n"
192 (mail-header-number headers
)
193 (mail-header-subject headers
)
194 (mail-header-from headers
)
195 (mail-header-date headers
)
196 (mail-header-id headers
)
197 (or (mail-header-references headers
) "")
198 (or (mail-header-chars headers
) "")
199 (or (mail-header-lines headers
) "")
200 (or (mail-header-xref headers
) "")))
201 ;; Update the active info.
202 (set-buffer gnus-summary-buffer
)
203 (gnus-cache-update-active group number
)
204 (push article gnus-newsgroup-cached
)
205 (gnus-summary-update-secondary-mark article
))
208 (defun gnus-cache-enter-remove-article (article)
209 "Mark ARTICLE for later possible removal."
211 (push article gnus-cache-removable-articles
)))
213 (defun gnus-cache-possibly-remove-articles ()
214 "Possibly remove some of the removable articles."
215 (if (not (gnus-virtual-group-p gnus-newsgroup-name
))
216 (gnus-cache-possibly-remove-articles-1)
217 (let ((arts gnus-cache-removable-articles
)
220 (when (setq ga
(nnvirtual-find-group-art
221 (gnus-group-real-name gnus-newsgroup-name
) (pop arts
)))
222 (let ((gnus-cache-removable-articles (list (cdr ga
)))
223 (gnus-newsgroup-name (car ga
)))
224 (gnus-cache-possibly-remove-articles-1)))))
225 (setq gnus-cache-removable-articles nil
)))
227 (defun gnus-cache-possibly-remove-articles-1 ()
228 "Possibly remove some of the removable articles."
229 (unless (eq gnus-use-cache
'passive
)
230 (let ((articles gnus-cache-removable-articles
)
231 (cache-articles gnus-newsgroup-cached
)
233 (gnus-cache-change-buffer gnus-newsgroup-name
)
235 (when (memq (setq article
(pop articles
)) cache-articles
)
236 ;; The article was in the cache, so we see whether we are
237 ;; supposed to remove it from the cache.
238 (gnus-cache-possibly-remove-article
239 article
(memq article gnus-newsgroup-marked
)
240 (memq article gnus-newsgroup-dormant
)
241 (or (memq article gnus-newsgroup-unreads
)
242 (memq article gnus-newsgroup-unselected
))))))
243 ;; The overview file might have been modified, save it
244 ;; safe because we're only called at group exit anyway.
245 (gnus-cache-save-buffers)))
247 (defun gnus-cache-request-article (article group
)
248 "Retrieve ARTICLE in GROUP from the cache."
249 (let ((file (gnus-cache-file-name group article
))
250 (buffer-read-only nil
))
251 (when (file-exists-p file
)
253 (gnus-kill-all-overlays)
254 (insert-file-contents file
)
257 (defun gnus-cache-possibly-alter-active (group active
)
258 "Alter the ACTIVE info for GROUP to reflect the articles in the cache."
259 (when (equal group
"no.norsk") (error "hie"))
260 (when gnus-cache-active-hashtb
261 (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb
)))
263 (< (car cache-active
) (car active
))
264 (setcar active
(car cache-active
)))
266 (> (cdr cache-active
) (cdr active
))
267 (setcdr active
(cdr cache-active
))))))
269 (defun gnus-cache-retrieve-headers (articles group
&optional fetch-old
)
270 "Retrieve the headers for ARTICLES in GROUP."
272 (setq gnus-newsgroup-cached
(gnus-cache-articles-in-group group
))))
274 ;; No cached articles here, so we just retrieve them
276 (let ((gnus-use-cache nil
))
277 (gnus-retrieve-headers articles group fetch-old
))
278 (let ((uncached-articles (gnus-sorted-intersection
279 (gnus-sorted-complement articles cached
)
281 (cache-file (gnus-cache-file-name group
".overview"))
283 ;; We first retrieve all the headers that we don't have in
285 (let ((gnus-use-cache nil
))
286 (when uncached-articles
287 (setq type
(and articles
288 (gnus-retrieve-headers
289 uncached-articles group fetch-old
)))))
290 (gnus-cache-save-buffers)
291 ;; Then we insert the cached headers.
294 ((not (file-exists-p cache-file
))
295 ;; There are no cached headers.
298 ;; There were no uncached headers (or retrieval was
299 ;; unsuccessful), so we use the cached headers exclusively.
300 (set-buffer nntp-server-buffer
)
302 (insert-file-contents cache-file
)
305 ;; We have both cached and uncached NOV headers, so we
307 (gnus-cache-braid-nov group cached
)
311 (gnus-cache-braid-heads group
(gnus-sorted-intersection
315 (defun gnus-cache-enter-article (&optional n
)
316 "Enter the next N articles into the cache.
317 If not given a prefix, use the process marked articles instead.
318 Returns the list of articles entered."
320 (gnus-set-global-variables)
321 (let ((articles (gnus-summary-work-articles n
))
323 (while (setq article
(pop articles
))
324 (if (natnump article
)
325 (when (gnus-cache-possibly-enter-article
326 gnus-newsgroup-name article
327 (gnus-summary-article-header article
)
330 (gnus-message 2 "Can't cache article %d" article
))
331 (gnus-summary-remove-process-mark article
)
332 (gnus-summary-update-secondary-mark article
))
333 (gnus-summary-next-subject 1)
334 (gnus-summary-position-point)
337 (defun gnus-cache-remove-article (n)
338 "Remove the next N articles from the cache.
339 If not given a prefix, use the process marked articles instead.
340 Returns the list of articles removed."
342 (gnus-set-global-variables)
343 (gnus-cache-change-buffer gnus-newsgroup-name
)
344 (let ((articles (gnus-summary-work-articles n
))
347 (setq article
(pop articles
))
348 (when (gnus-cache-possibly-remove-article article nil nil nil t
)
350 (gnus-summary-remove-process-mark article
)
351 (gnus-summary-update-secondary-mark article
))
352 (gnus-summary-next-subject 1)
353 (gnus-summary-position-point)
356 (defun gnus-cached-article-p (article)
357 "Say whether ARTICLE is cached in the current group."
358 (memq article gnus-newsgroup-cached
))
360 (defun gnus-summary-insert-cached-articles ()
361 "Insert all the articles cached for this group into the current buffer."
363 (let ((cached gnus-newsgroup-cached
)
364 (gnus-verbose (max 6 gnus-verbose
)))
366 (error "No cached articles for this group"))
368 (gnus-summary-goto-subject (pop cached
) t
))))
370 ;;; Internal functions.
372 (defun gnus-cache-change-buffer (group)
373 (and gnus-cache-buffer
374 ;; See if the current group's overview cache has been loaded.
375 (or (string= group
(car gnus-cache-buffer
))
376 ;; Another overview cache is current, save it.
377 (gnus-cache-save-buffers)))
378 ;; if gnus-cache buffer is nil, create it
379 (unless gnus-cache-buffer
380 ;; Create cache buffer
382 (setq gnus-cache-buffer
384 (set-buffer (get-buffer-create " *gnus-cache-overview*"))))
385 (buffer-disable-undo (current-buffer))
386 ;; Insert the contents of this group's cache overview.
388 (let ((file (gnus-cache-file-name group
".overview")))
389 (when (file-exists-p file
)
390 (nnheader-insert-file-contents file
)))
391 ;; We have a fresh (empty/just loaded) buffer,
392 ;; mark it as unmodified to save a redundant write later.
393 (set-buffer-modified-p nil
))))
395 ;; Return whether an article is a member of a class.
396 (defun gnus-cache-member-of-class (class ticked dormant unread
)
397 (or (and ticked
(memq 'ticked class
))
398 (and dormant
(memq 'dormant class
))
399 (and unread
(memq 'unread class
))
400 (and (not unread
) (not ticked
) (not dormant
) (memq 'read class
))))
402 (defun gnus-cache-file-name (group article
)
403 (concat (file-name-as-directory gnus-cache-directory
)
404 (file-name-as-directory
405 (nnheader-translate-file-chars
406 (if (gnus-use-long-file-name 'not-cache
)
408 (let ((group (nnheader-replace-chars-in-string group ?
/ ?_
)))
409 ;; Translate the first colon into a slash.
410 (when (string-match ":" group
)
411 (aset group
(match-beginning 0) ?
/))
412 (nnheader-replace-chars-in-string group ?. ?
/)))))
413 (if (stringp article
) article
(int-to-string article
))))
415 (defun gnus-cache-update-article (group article
)
416 "If ARTICLE is in the cache, remove it and re-enter it."
417 (when (gnus-cache-possibly-remove-article article nil nil nil t
)
418 (let ((gnus-use-cache nil
))
419 (gnus-cache-possibly-enter-article
420 gnus-newsgroup-name article
(gnus-summary-article-header article
)
423 (defun gnus-cache-possibly-remove-article (article ticked dormant unread
425 "Possibly remove ARTICLE from the cache."
426 (let ((group gnus-newsgroup-name
)
429 ;; If this is a virtual group, we find the real group.
430 (when (gnus-virtual-group-p group
)
431 (let ((result (nnvirtual-find-group-art
432 (gnus-group-real-name group
) article
)))
433 (setq group
(car result
)
434 number
(cdr result
))))
435 (setq file
(gnus-cache-file-name group number
))
436 (when (and (file-exists-p file
)
438 (gnus-cache-member-of-class
439 gnus-cache-remove-articles ticked dormant unread
)))
442 (set-buffer (cdr gnus-cache-buffer
))
443 (goto-char (point-min))
444 (when (or (looking-at (concat (int-to-string number
) "\t"))
445 (search-forward (concat "\n" (int-to-string number
) "\t")
447 (delete-region (progn (beginning-of-line) (point))
448 (progn (forward-line 1) (point)))))
449 (setq gnus-newsgroup-cached
450 (delq article gnus-newsgroup-cached
))
451 (gnus-summary-update-secondary-mark article
)
454 (defun gnus-cache-articles-in-group (group)
455 "Return a sorted list of cached articles in GROUP."
456 (let ((dir (file-name-directory (gnus-cache-file-name group
1))))
457 (when (file-exists-p dir
)
458 (sort (mapcar (lambda (name) (string-to-int name
))
459 (directory-files dir nil
"^[0-9]+$" t
))
462 (defun gnus-cache-braid-nov (group cached
)
463 (let ((cache-buf (get-buffer-create " *gnus-cache*"))
465 (gnus-cache-save-buffers)
467 (set-buffer cache-buf
)
468 (buffer-disable-undo (current-buffer))
470 (insert-file-contents (gnus-cache-file-name group
".overview"))
471 (goto-char (point-min))
473 (goto-char (point-min)))
474 (set-buffer nntp-server-buffer
)
475 (goto-char (point-min))
477 (while (and (not (eobp))
478 (< (read (current-buffer)) (car cached
)))
482 (set-buffer cache-buf
)
483 (if (search-forward (concat "\n" (int-to-string (car cached
)) "\t")
485 (setq beg
(progn (beginning-of-line) (point))
486 end
(progn (end-of-line) (point)))
489 (insert-buffer-substring cache-buf beg end
)
491 (setq cached
(cdr cached
)))
492 (kill-buffer cache-buf
)))
494 (defun gnus-cache-braid-heads (group cached
)
495 (let ((cache-buf (get-buffer-create " *gnus-cache*")))
497 (set-buffer cache-buf
)
498 (buffer-disable-undo (current-buffer))
500 (set-buffer nntp-server-buffer
)
501 (goto-char (point-min))
503 (while (and (not (eobp))
504 (looking-at "2.. +\\([0-9]+\\) ")
505 (< (progn (goto-char (match-beginning 1))
506 (read (current-buffer)))
508 (search-forward "\n.\n" nil
'move
))
511 (set-buffer cache-buf
)
513 (insert-file-contents (gnus-cache-file-name group
(car cached
)))
514 (goto-char (point-min))
516 (princ (car cached
) (current-buffer))
517 (insert " Article retrieved.\n")
518 (search-forward "\n\n" nil
'move
)
519 (delete-region (point) (point-max))
522 (insert-buffer-substring cache-buf
)
523 (setq cached
(cdr cached
)))
524 (kill-buffer cache-buf
)))
527 (defun gnus-jog-cache ()
528 "Go through all groups and put the articles into the cache.
531 $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
533 (let ((gnus-mark-article-hook nil
)
535 (nnmail-spool-file nil
)
536 (gnus-use-dribble-file nil
)
537 (gnus-novice-user nil
)
538 (gnus-large-newsgroup nil
))
541 ;; Go through all groups...
542 (gnus-group-mark-buffer)
543 (gnus-group-universal-argument
547 (gnus-summary-read-group (gnus-group-group-name) nil t
)
548 ;; ... and enter the articles into the cache.
549 (when (eq major-mode
'gnus-summary-mode
)
550 (gnus-uu-mark-buffer)
551 (gnus-cache-enter-article)
552 (kill-buffer (current-buffer)))))))
554 (defun gnus-cache-read-active (&optional force
)
555 "Read the cache active file."
556 (gnus-make-directory gnus-cache-directory
)
557 (if (not (and (file-exists-p gnus-cache-active-file
)
558 (or force
(not gnus-cache-active-hashtb
))))
559 ;; There is no active file, so we generate one.
560 (gnus-cache-generate-active)
561 ;; We simply read the active file.
563 (gnus-set-work-buffer)
564 (insert-file-contents gnus-cache-active-file
)
565 (gnus-active-to-gnus-format
566 nil
(setq gnus-cache-active-hashtb
568 (count-lines (point-min) (point-max)))))
569 (setq gnus-cache-active-altered nil
))))
571 (defun gnus-cache-write-active (&optional force
)
572 "Write the active hashtb to the active file."
574 (and gnus-cache-active-hashtb
575 gnus-cache-active-altered
))
576 (nnheader-temp-write gnus-cache-active-file
579 (when (and sym
(boundp sym
))
580 (insert (format "%s %d %d y\n"
581 (symbol-name sym
) (cdr (symbol-value sym
))
582 (car (symbol-value sym
))))))
583 gnus-cache-active-hashtb
))
584 ;; Mark the active hashtb as unaltered.
585 (setq gnus-cache-active-altered nil
)))
587 (defun gnus-cache-update-active (group number
&optional low
)
588 "Update the upper bound of the active info of GROUP to NUMBER.
589 If LOW, update the lower bound instead."
590 (let ((active (gnus-gethash group gnus-cache-active-hashtb
)))
592 ;; We just create a new active entry for this group.
593 (gnus-sethash group
(cons number number
) gnus-cache-active-hashtb
)
594 ;; Update the lower or upper bound.
596 (setcar active number
)
597 (setcdr active number
)))
598 ;; Mark the active hashtb as altered.
599 (setq gnus-cache-active-altered t
)))
602 (defun gnus-cache-generate-active (&optional directory
)
603 "Generate the cache active file."
605 (let* ((top (null directory
))
606 (directory (expand-file-name (or directory gnus-cache-directory
)))
607 (files (directory-files directory
'full
))
612 (concat "^" (file-name-as-directory
613 (expand-file-name gnus-cache-directory
)))
614 (directory-file-name directory
))
615 (nnheader-replace-chars-in-string
616 (substring (directory-file-name directory
) (match-end 0))
620 (gnus-message 5 "Generating the cache active file...")
621 (setq gnus-cache-active-hashtb
(gnus-make-hashtable 123)))
622 ;; Separate articles from all other files and directories.
624 (if (string-match "^[0-9]+$" (file-name-nondirectory (car files
)))
625 (push (string-to-int (file-name-nondirectory (pop files
))) nums
)
626 (push (pop files
) alphs
)))
627 ;; If we have nums, then this is probably a valid group.
628 (when (setq nums
(sort nums
'<))
629 (gnus-sethash group
(cons (car nums
) (gnus-last-element nums
))
630 gnus-cache-active-hashtb
))
631 ;; Go through all the other files.
633 (when (and (file-directory-p (car alphs
))
634 (not (string-match "^\\.\\.?$"
635 (file-name-nondirectory (car alphs
)))))
636 ;; We descend directories.
637 (gnus-cache-generate-active (car alphs
)))
638 (setq alphs
(cdr alphs
)))
639 ;; Write the new active file.
641 (gnus-cache-write-active t
)
642 (gnus-message 5 "Generating the cache active file...done"))))
645 (defun gnus-cache-generate-nov-databases (dir)
646 "Generate NOV files recursively starting in DIR."
647 (interactive (list gnus-cache-directory
))
649 (let ((nnml-generate-active-function 'identity
))
650 (nnml-generate-nov-databases-1 dir
)))
652 (defun gnus-cache-move-cache (dir)
653 "Move the cache tree to somewhere else."
654 (interactive "DMove the cache tree to: ")
655 (rename-file gnus-cache-directory dir
))
657 (provide 'gnus-cache
)
659 ;;; gnus-cache.el ends here