1 ;;; gnus-cache.el --- cache interface for Gnus
2 ;; Copyright (C) 1995,96 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.
29 (eval-when-compile (require 'cl
))
31 (defvar gnus-cache-directory
32 (nnheader-concat gnus-directory
"cache/")
33 "*The directory where cached articles will be stored.")
35 (defvar gnus-cache-active-file
36 (concat (file-name-as-directory gnus-cache-directory
) "active")
37 "*The cache active file.")
39 (defvar gnus-cache-enter-articles
'(ticked dormant
)
40 "*Classes of articles to enter into the cache.")
42 (defvar gnus-cache-remove-articles
'(read)
43 "*Classes of articles to remove from the cache.")
45 (defvar gnus-uncacheable-groups nil
46 "*Groups that match this regexp will not be cached.
48 If you want to avoid caching your nnml groups, you could set this
49 variable to \"^nnml\".")
53 ;;; Internal variables.
55 (defvar gnus-cache-buffer nil
)
56 (defvar gnus-cache-active-hashtb nil
)
57 (defvar gnus-cache-active-altered nil
)
60 (autoload 'nnml-generate-nov-databases-1
"nnml")
61 (autoload 'nnvirtual-find-group-art
"nnvirtual"))
65 ;;; Functions called from Gnus.
67 (defun gnus-cache-open ()
68 "Initialize the cache."
69 (when (or (file-exists-p gnus-cache-directory
)
71 (not (eq gnus-use-cache
'passive
))))
72 (gnus-cache-read-active)))
74 (gnus-add-shutdown 'gnus-cache-close
'gnus
)
76 (defun gnus-cache-close ()
77 "Shut down the cache."
78 (gnus-cache-write-active)
79 (gnus-cache-save-buffers)
80 (setq gnus-cache-active-hashtb nil
))
82 (defun gnus-cache-save-buffers ()
83 ;; save the overview buffer if it exists and has been modified
84 ;; delete empty cache subdirectories
85 (if (null gnus-cache-buffer
)
87 (let ((buffer (cdr gnus-cache-buffer
))
88 (overview-file (gnus-cache-file-name
89 (car gnus-cache-buffer
) ".overview")))
90 ;; write the overview only if it was modified
91 (if (buffer-modified-p buffer
)
94 (if (> (buffer-size) 0)
95 ;; non-empty overview, write it out
97 (gnus-make-directory (file-name-directory overview-file
))
98 (write-region (point-min) (point-max)
99 overview-file nil
'quietly
))
100 ;; empty overview file, remove it
101 (and (file-exists-p overview-file
)
102 (delete-file overview-file
))
103 ;; if possible, remove group's cache subdirectory
105 ;; FIXME: we can detect the error type and warn the user
106 ;; of any inconsistencies (articles w/o nov entries?).
107 ;; for now, just be conservative...delete only if safe -- sj
108 (delete-directory (file-name-directory overview-file
))
110 ;; kill the buffer, it's either unmodified or saved
111 (gnus-kill-buffer buffer
)
112 (setq gnus-cache-buffer nil
))))
114 (defun gnus-cache-possibly-enter-article
115 (group article headers ticked dormant unread
&optional force
)
116 (when (and (or force
(not (eq gnus-use-cache
'passive
)))
119 (vectorp headers
)) ; This might be a dummy article.
120 ;; If this is a virtual group, we find the real group.
121 (when (gnus-virtual-group-p group
)
122 (let ((result (nnvirtual-find-group-art
123 (gnus-group-real-name group
) article
)))
124 (setq group
(car result
)
125 headers
(copy-sequence headers
))
126 (mail-header-set-number headers
(cdr result
))))
127 (let ((number (mail-header-number headers
))
129 (when (and (> number
0) ; Reffed article.
130 (or (not gnus-uncacheable-groups
)
131 (not (string-match gnus-uncacheable-groups group
)))
133 (gnus-cache-member-of-class
134 gnus-cache-enter-articles ticked dormant unread
))
135 (not (file-exists-p (setq file
(gnus-cache-file-name
137 ;; Possibly create the cache directory.
138 (or (file-exists-p (setq dir
(file-name-directory file
)))
139 (gnus-make-directory dir
))
140 ;; Save the article in the cache.
141 (if (file-exists-p file
)
142 t
; The article already is saved.
144 (set-buffer nntp-server-buffer
)
145 (let ((gnus-use-cache nil
))
146 (gnus-request-article-this-buffer number group
))
147 (when (> (buffer-size) 0)
148 (write-region (point-min) (point-max) file nil
'quiet
)
149 (gnus-cache-change-buffer group
)
150 (set-buffer (cdr gnus-cache-buffer
))
151 (goto-char (point-max))
153 (while (condition-case ()
155 (> (read (current-buffer)) number
))
157 ;; The line was malformed, so we just remove it!!
165 (if (< (read (current-buffer)) number
)
170 ;; [number subject from date id references chars lines xref]
171 (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n"
172 (mail-header-number headers
)
173 (mail-header-subject headers
)
174 (mail-header-from headers
)
175 (mail-header-date headers
)
176 (mail-header-id headers
)
177 (or (mail-header-references headers
) "")
178 (or (mail-header-chars headers
) "")
179 (or (mail-header-lines headers
) "")
180 (or (mail-header-xref headers
) "")))
181 ;; Update the active info.
182 (set-buffer gnus-summary-buffer
)
183 (gnus-cache-update-active group number
)
184 (push article gnus-newsgroup-cached
)
185 (gnus-summary-update-secondary-mark article
))
188 (defun gnus-cache-enter-remove-article (article)
189 "Mark ARTICLE for later possible removal."
191 (push article gnus-cache-removable-articles
)))
193 (defun gnus-cache-possibly-remove-articles ()
194 "Possibly remove some of the removable articles."
195 (if (not (gnus-virtual-group-p gnus-newsgroup-name
))
196 (gnus-cache-possibly-remove-articles-1)
197 (let ((arts gnus-cache-removable-articles
)
200 (when (setq ga
(nnvirtual-find-group-art
201 (gnus-group-real-name gnus-newsgroup-name
) (pop arts
)))
202 (let ((gnus-cache-removable-articles (list (cdr ga
)))
203 (gnus-newsgroup-name (car ga
)))
204 (gnus-cache-possibly-remove-articles-1)))))
205 (setq gnus-cache-removable-articles nil
)))
207 (defun gnus-cache-possibly-remove-articles-1 ()
208 "Possibly remove some of the removable articles."
209 (unless (eq gnus-use-cache
'passive
)
210 (let ((articles gnus-cache-removable-articles
)
211 (cache-articles gnus-newsgroup-cached
)
213 (gnus-cache-change-buffer gnus-newsgroup-name
)
215 (if (memq (setq article
(pop articles
)) cache-articles
)
216 ;; The article was in the cache, so we see whether we are
217 ;; supposed to remove it from the cache.
218 (gnus-cache-possibly-remove-article
219 article
(memq article gnus-newsgroup-marked
)
220 (memq article gnus-newsgroup-dormant
)
221 (or (memq article gnus-newsgroup-unreads
)
222 (memq article gnus-newsgroup-unselected
))))))
223 ;; The overview file might have been modified, save it
224 ;; safe because we're only called at group exit anyway.
225 (gnus-cache-save-buffers)))
227 (defun gnus-cache-request-article (article group
)
228 "Retrieve ARTICLE in GROUP from the cache."
229 (let ((file (gnus-cache-file-name group article
))
230 (buffer-read-only nil
))
231 (when (file-exists-p file
)
233 (gnus-kill-all-overlays)
234 (insert-file-contents file
)
237 (defun gnus-cache-possibly-alter-active (group active
)
238 "Alter the ACTIVE info for GROUP to reflect the articles in the cache."
239 (when gnus-cache-active-hashtb
240 (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb
)))
242 (< (car cache-active
) (car active
))
243 (setcar active
(car cache-active
)))
245 (> (cdr cache-active
) (cdr active
))
246 (setcdr active
(cdr cache-active
))))))
248 (defun gnus-cache-retrieve-headers (articles group
&optional fetch-old
)
249 "Retrieve the headers for ARTICLES in GROUP."
251 (setq gnus-newsgroup-cached
(gnus-cache-articles-in-group group
))))
253 ;; No cached articles here, so we just retrieve them
255 (let ((gnus-use-cache nil
))
256 (gnus-retrieve-headers articles group fetch-old
))
257 (let ((uncached-articles (gnus-sorted-intersection
258 (gnus-sorted-complement articles cached
)
260 (cache-file (gnus-cache-file-name group
".overview"))
262 ;; We first retrieve all the headers that we don't have in
264 (let ((gnus-use-cache nil
))
265 (when uncached-articles
266 (setq type
(and articles
267 (gnus-retrieve-headers
268 uncached-articles group fetch-old
)))))
269 (gnus-cache-save-buffers)
270 ;; Then we insert the cached headers.
273 ((not (file-exists-p cache-file
))
274 ;; There are no cached headers.
277 ;; There were no uncached headers (or retrieval was
278 ;; unsuccessful), so we use the cached headers exclusively.
279 (set-buffer nntp-server-buffer
)
281 (insert-file-contents cache-file
)
284 ;; We have both cached and uncached NOV headers, so we
286 (gnus-cache-braid-nov group cached
)
290 (gnus-cache-braid-heads group
(gnus-sorted-intersection
294 (defun gnus-cache-enter-article (&optional n
)
295 "Enter the next N articles into the cache.
296 If not given a prefix, use the process marked articles instead.
297 Returns the list of articles entered."
299 (gnus-set-global-variables)
300 (let ((articles (gnus-summary-work-articles n
))
303 (setq article
(pop articles
))
304 (when (gnus-cache-possibly-enter-article
305 gnus-newsgroup-name article
(gnus-summary-article-header article
)
308 (gnus-summary-remove-process-mark article
)
309 (gnus-summary-update-secondary-mark article
))
310 (gnus-summary-next-subject 1)
311 (gnus-summary-position-point)
314 (defun gnus-cache-remove-article (n)
315 "Remove the next N articles from the cache.
316 If not given a prefix, use the process marked articles instead.
317 Returns the list of articles removed."
319 (gnus-set-global-variables)
320 (gnus-cache-change-buffer gnus-newsgroup-name
)
321 (let ((articles (gnus-summary-work-articles n
))
324 (setq article
(pop articles
))
325 (when (gnus-cache-possibly-remove-article article nil nil nil t
)
327 (gnus-summary-remove-process-mark article
)
328 (gnus-summary-update-secondary-mark article
))
329 (gnus-summary-next-subject 1)
330 (gnus-summary-position-point)
333 (defun gnus-cached-article-p (article)
334 "Say whether ARTICLE is cached in the current group."
335 (memq article gnus-newsgroup-cached
))
337 ;;; Internal functions.
339 (defun gnus-cache-change-buffer (group)
340 (and gnus-cache-buffer
341 ;; See if the current group's overview cache has been loaded.
342 (or (string= group
(car gnus-cache-buffer
))
343 ;; Another overview cache is current, save it.
344 (gnus-cache-save-buffers)))
345 ;; if gnus-cache buffer is nil, create it
346 (or gnus-cache-buffer
347 ;; Create cache buffer
349 (setq gnus-cache-buffer
351 (set-buffer (get-buffer-create " *gnus-cache-overview*"))))
352 (buffer-disable-undo (current-buffer))
353 ;; Insert the contents of this group's cache overview.
355 (let ((file (gnus-cache-file-name group
".overview")))
356 (and (file-exists-p file
)
357 (insert-file-contents file
)))
358 ;; We have a fresh (empty/just loaded) buffer,
359 ;; mark it as unmodified to save a redundant write later.
360 (set-buffer-modified-p nil
))))
362 ;; Return whether an article is a member of a class.
363 (defun gnus-cache-member-of-class (class ticked dormant unread
)
364 (or (and ticked
(memq 'ticked class
))
365 (and dormant
(memq 'dormant class
))
366 (and unread
(memq 'unread class
))
367 (and (not unread
) (not ticked
) (not dormant
) (memq 'read class
))))
369 (defun gnus-cache-file-name (group article
)
370 (concat (file-name-as-directory gnus-cache-directory
)
371 (file-name-as-directory
372 (if (gnus-use-long-file-name 'not-cache
)
374 (let ((group (concat group
"")))
375 (if (string-match ":" group
)
376 (aset group
(match-beginning 0) ?
/))
377 (nnheader-replace-chars-in-string group ?. ?
/))))
378 (if (stringp article
) article
(int-to-string article
))))
380 (defun gnus-cache-update-article (group article
)
381 "If ARTICLE is in the cache, remove it and re-enter it."
382 (when (gnus-cache-possibly-remove-article article nil nil nil t
)
383 (let ((gnus-use-cache nil
))
384 (gnus-cache-possibly-enter-article
385 gnus-newsgroup-name article
(gnus-summary-article-header article
)
388 (defun gnus-cache-possibly-remove-article (article ticked dormant unread
390 "Possibly remove ARTICLE from the cache."
391 (let ((group gnus-newsgroup-name
)
394 ;; If this is a virtual group, we find the real group.
395 (when (gnus-virtual-group-p group
)
396 (let ((result (nnvirtual-find-group-art
397 (gnus-group-real-name group
) article
)))
398 (setq group
(car result
)
399 number
(cdr result
))))
400 (setq file
(gnus-cache-file-name group number
))
401 (when (and (file-exists-p file
)
403 (gnus-cache-member-of-class
404 gnus-cache-remove-articles ticked dormant unread
)))
407 (set-buffer (cdr gnus-cache-buffer
))
408 (goto-char (point-min))
409 (if (or (looking-at (concat (int-to-string number
) "\t"))
410 (search-forward (concat "\n" (int-to-string number
) "\t")
412 (delete-region (progn (beginning-of-line) (point))
413 (progn (forward-line 1) (point)))))
414 (setq gnus-newsgroup-cached
415 (delq article gnus-newsgroup-cached
))
416 (gnus-summary-update-secondary-mark article
)
419 (defun gnus-cache-articles-in-group (group)
420 "Return a sorted list of cached articles in GROUP."
421 (let ((dir (file-name-directory (gnus-cache-file-name group
1)))
423 (when (file-exists-p dir
)
424 (sort (mapcar (lambda (name) (string-to-int name
))
425 (directory-files dir nil
"^[0-9]+$" t
))
428 (defun gnus-cache-braid-nov (group cached
)
429 (let ((cache-buf (get-buffer-create " *gnus-cache*"))
431 (gnus-cache-save-buffers)
433 (set-buffer cache-buf
)
434 (buffer-disable-undo (current-buffer))
436 (insert-file-contents (gnus-cache-file-name group
".overview"))
437 (goto-char (point-min))
439 (goto-char (point-min)))
440 (set-buffer nntp-server-buffer
)
441 (goto-char (point-min))
443 (while (and (not (eobp))
444 (< (read (current-buffer)) (car cached
)))
448 (set-buffer cache-buf
)
449 (if (search-forward (concat "\n" (int-to-string (car cached
)) "\t")
451 (setq beg
(progn (beginning-of-line) (point))
452 end
(progn (end-of-line) (point)))
454 (if beg
(progn (insert-buffer-substring cache-buf beg end
)
456 (setq cached
(cdr cached
)))
457 (kill-buffer cache-buf
)))
459 (defun gnus-cache-braid-heads (group cached
)
460 (let ((cache-buf (get-buffer-create " *gnus-cache*")))
462 (set-buffer cache-buf
)
463 (buffer-disable-undo (current-buffer))
465 (set-buffer nntp-server-buffer
)
466 (goto-char (point-min))
468 (while (and (not (eobp))
469 (looking-at "2.. +\\([0-9]+\\) ")
470 (< (progn (goto-char (match-beginning 1))
471 (read (current-buffer)))
473 (search-forward "\n.\n" nil
'move
))
476 (set-buffer cache-buf
)
478 (insert-file-contents (gnus-cache-file-name group
(car cached
)))
479 (goto-char (point-min))
481 (princ (car cached
) (current-buffer))
482 (insert " Article retrieved.\n")
483 (search-forward "\n\n" nil
'move
)
484 (delete-region (point) (point-max))
487 (insert-buffer-substring cache-buf
)
488 (setq cached
(cdr cached
)))
489 (kill-buffer cache-buf
)))
492 (defun gnus-jog-cache ()
493 "Go through all groups and put the articles into the cache."
495 (let ((gnus-mark-article-hook nil
)
497 (nnmail-spool-file nil
)
498 (gnus-use-dribble-file nil
)
499 (gnus-novice-user nil
)
500 (gnus-large-newsgroup nil
))
503 ;; Go through all groups...
504 (gnus-group-mark-buffer)
505 (gnus-group-universal-argument
508 (gnus-summary-read-group nil nil t
)
509 ;; ... and enter the articles into the cache.
510 (when (eq major-mode
'gnus-summary-mode
)
511 (gnus-uu-mark-buffer)
512 (gnus-cache-enter-article)
513 (kill-buffer (current-buffer)))))))
515 (defun gnus-cache-read-active (&optional force
)
516 "Read the cache active file."
517 (unless (file-exists-p gnus-cache-directory
)
518 (make-directory gnus-cache-directory t
))
519 (if (not (and (file-exists-p gnus-cache-active-file
)
520 (or force
(not gnus-cache-active-hashtb
))))
521 ;; There is no active file, so we generate one.
522 (gnus-cache-generate-active)
523 ;; We simply read the active file.
525 (gnus-set-work-buffer)
526 (insert-file-contents gnus-cache-active-file
)
527 (gnus-active-to-gnus-format
528 nil
(setq gnus-cache-active-hashtb
530 (count-lines (point-min) (point-max)))))
531 (setq gnus-cache-active-altered nil
))))
533 (defun gnus-cache-write-active (&optional force
)
534 "Write the active hashtb to the active file."
536 (and gnus-cache-active-hashtb
537 gnus-cache-active-altered
))
539 (gnus-set-work-buffer)
542 (when (and sym
(boundp sym
))
543 (insert (format "%s %d %d y\n"
544 (symbol-name sym
) (cdr (symbol-value sym
))
545 (car (symbol-value sym
))))))
546 gnus-cache-active-hashtb
)
547 (gnus-make-directory (file-name-directory gnus-cache-active-file
))
549 (point-min) (point-max) gnus-cache-active-file nil
'silent
))
550 ;; Mark the active hashtb as unaltered.
551 (setq gnus-cache-active-altered nil
)))
553 (defun gnus-cache-update-active (group number
&optional low
)
554 "Update the upper bound of the active info of GROUP to NUMBER.
555 If LOW, update the lower bound instead."
556 (let ((active (gnus-gethash group gnus-cache-active-hashtb
)))
558 ;; We just create a new active entry for this group.
559 (gnus-sethash group
(cons number number
) gnus-cache-active-hashtb
)
560 ;; Update the lower or upper bound.
562 (setcar active number
)
563 (setcdr active number
))
564 ;; Mark the active hashtb as altered.
565 (setq gnus-cache-active-altered t
))))
568 (defun gnus-cache-generate-active (&optional directory
)
569 "Generate the cache active file."
571 (let* ((top (null directory
))
572 (directory (expand-file-name (or directory gnus-cache-directory
)))
573 (files (directory-files directory
'full
))
578 (concat "^" (file-name-as-directory
579 (expand-file-name gnus-cache-directory
)))
580 (directory-file-name directory
))
581 (nnheader-replace-chars-in-string
582 (substring (directory-file-name directory
) (match-end 0))
586 (gnus-message 5 "Generating the cache active file...")
587 (setq gnus-cache-active-hashtb
(gnus-make-hashtable 123)))
588 ;; Separate articles from all other files and directories.
590 (if (string-match "^[0-9]+$" (file-name-nondirectory (car files
)))
591 (push (string-to-int (file-name-nondirectory (pop files
))) nums
)
592 (push (pop files
) alphs
)))
593 ;; If we have nums, then this is probably a valid group.
594 (when (setq nums
(sort nums
'<))
595 (gnus-sethash group
(cons (car nums
) (gnus-last-element nums
))
596 gnus-cache-active-hashtb
))
597 ;; Go through all the other files.
599 (when (and (file-directory-p (car alphs
))
600 (not (string-match "^\\.\\.?$"
601 (file-name-nondirectory (car alphs
)))))
602 ;; We descend directories.
603 (gnus-cache-generate-active (car alphs
)))
604 (setq alphs
(cdr alphs
)))
605 ;; Write the new active file.
607 (gnus-cache-write-active t
)
608 (gnus-message 5 "Generating the cache active file...done"))))
611 (defun gnus-cache-generate-nov-databases (dir)
612 "Generate NOV files recursively starting in DIR."
613 (interactive (list gnus-cache-directory
))
615 (let ((nnml-generate-active-function 'identity
))
616 (nnml-generate-nov-databases-1 dir
)))
618 (provide 'gnus-cache
)
620 ;;; gnus-cache.el ends here