New directory
[bpt/emacs.git] / lisp / gnus / gnus-cache.el
CommitLineData
eec82323 1;;; gnus-cache.el --- cache interface for Gnus
16409b0b
GM
2;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
3;; Free Software Foundation, Inc.
eec82323 4
6748645f 5;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
eec82323
LMI
6;; Keywords: news
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26
27;;; Code:
28
7df7482d
RS
29(eval-when-compile (require 'cl))
30
eec82323
LMI
31(require 'gnus)
32(require 'gnus-int)
33(require 'gnus-range)
34(require 'gnus-start)
35(eval-when-compile
36 (require 'gnus-sum))
37
eec82323 38(defcustom gnus-cache-active-file
6ab8077a 39 (expand-file-name "active" gnus-cache-directory)
eec82323
LMI
40 "*The cache active file."
41 :group 'gnus-cache
42 :type 'file)
43
44(defcustom gnus-cache-enter-articles '(ticked dormant)
45 "Classes of articles to enter into the cache."
46 :group 'gnus-cache
47 :type '(set (const ticked) (const dormant) (const unread) (const read)))
48
49(defcustom gnus-cache-remove-articles '(read)
50 "Classes of articles to remove from the cache."
51 :group 'gnus-cache
52 :type '(set (const ticked) (const dormant) (const unread) (const read)))
53
6748645f
LMI
54(defcustom gnus-cacheable-groups nil
55 "*Groups that match this regexp will be cached.
56
57If you only want to cache your nntp groups, you could set this
58variable to \"^nntp\".
59
60If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
61it's not cached."
62 :group 'gnus-cache
63 :type '(choice (const :tag "off" nil)
16409b0b 64 regexp))
6748645f 65
eec82323
LMI
66(defcustom gnus-uncacheable-groups nil
67 "*Groups that match this regexp will not be cached.
68
69If you want to avoid caching your nnml groups, you could set this
6748645f
LMI
70variable to \"^nnml\".
71
72If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
73it's not cached."
eec82323
LMI
74 :group 'gnus-cache
75 :type '(choice (const :tag "off" nil)
76 regexp))
77
6748645f
LMI
78(defvar gnus-cache-overview-coding-system 'raw-text
79 "Coding system used on Gnus cache files.")
80
16409b0b
GM
81(defvar gnus-cache-coding-system 'raw-text
82 "Coding system used on Gnus cache files.")
83
eec82323
LMI
84\f
85
86;;; Internal variables.
87
88(defvar gnus-cache-removable-articles nil)
89(defvar gnus-cache-buffer nil)
90(defvar gnus-cache-active-hashtb nil)
91(defvar gnus-cache-active-altered nil)
92
93(eval-and-compile
94 (autoload 'nnml-generate-nov-databases-1 "nnml")
95 (autoload 'nnvirtual-find-group-art "nnvirtual"))
96
97\f
98
99;;; Functions called from Gnus.
100
101(defun gnus-cache-open ()
102 "Initialize the cache."
103 (when (or (file-exists-p gnus-cache-directory)
104 (and gnus-use-cache
105 (not (eq gnus-use-cache 'passive))))
106 (gnus-cache-read-active)))
107
108;; Complexities of byte-compiling make this kludge necessary. Eeek.
109(ignore-errors
110 (gnus-add-shutdown 'gnus-cache-close 'gnus))
111
112(defun gnus-cache-close ()
113 "Shut down the cache."
114 (gnus-cache-write-active)
115 (gnus-cache-save-buffers)
116 (setq gnus-cache-active-hashtb nil))
117
118(defun gnus-cache-save-buffers ()
119 ;; save the overview buffer if it exists and has been modified
120 ;; delete empty cache subdirectories
121 (when gnus-cache-buffer
122 (let ((buffer (cdr gnus-cache-buffer))
123 (overview-file (gnus-cache-file-name
124 (car gnus-cache-buffer) ".overview")))
125 ;; write the overview only if it was modified
126 (when (buffer-modified-p buffer)
127 (save-excursion
128 (set-buffer buffer)
129 (if (> (buffer-size) 0)
130 ;; Non-empty overview, write it to a file.
6748645f
LMI
131 (let ((coding-system-for-write
132 gnus-cache-overview-coding-system))
133 (gnus-write-buffer overview-file))
eec82323
LMI
134 ;; Empty overview file, remove it
135 (when (file-exists-p overview-file)
136 (delete-file overview-file))
137 ;; If possible, remove group's cache subdirectory.
138 (condition-case nil
139 ;; FIXME: we can detect the error type and warn the user
140 ;; of any inconsistencies (articles w/o nov entries?).
141 ;; for now, just be conservative...delete only if safe -- sj
142 (delete-directory (file-name-directory overview-file))
143 (error nil)))))
144 ;; Kill the buffer -- it's either unmodified or saved.
145 (gnus-kill-buffer buffer)
146 (setq gnus-cache-buffer nil))))
147
148(defun gnus-cache-possibly-enter-article
16409b0b 149 (group article ticked dormant unread &optional force)
eec82323
LMI
150 (when (and (or force (not (eq gnus-use-cache 'passive)))
151 (numberp article)
16409b0b
GM
152 (> article 0)) ; This might be a dummy article.
153 (let ((number article) file headers)
154 ;; If this is a virtual group, we find the real group.
155 (when (gnus-virtual-group-p group)
156 (let ((result (nnvirtual-find-group-art
157 (gnus-group-real-name group) article)))
158 (setq group (car result)
159 number (cdr result))))
a8151ef7
LMI
160 (when (and number
161 (> number 0) ; Reffed article.
eec82323 162 (or force
6748645f
LMI
163 (and (or (not gnus-cacheable-groups)
164 (string-match gnus-cacheable-groups group))
165 (or (not gnus-uncacheable-groups)
eec82323
LMI
166 (not (string-match
167 gnus-uncacheable-groups group)))
168 (gnus-cache-member-of-class
169 gnus-cache-enter-articles ticked dormant unread)))
170 (not (file-exists-p (setq file (gnus-cache-file-name
171 group number)))))
172 ;; Possibly create the cache directory.
6748645f 173 (gnus-make-directory (file-name-directory file))
eec82323
LMI
174 ;; Save the article in the cache.
175 (if (file-exists-p file)
176 t ; The article already is saved.
177 (save-excursion
178 (set-buffer nntp-server-buffer)
16409b0b
GM
179 (require 'gnus-art)
180 (let ((gnus-use-cache nil)
181 (gnus-article-decode-hook nil))
eec82323
LMI
182 (gnus-request-article-this-buffer number group))
183 (when (> (buffer-size) 0)
16409b0b
GM
184 (let ((coding-system-for-write gnus-cache-coding-system))
185 (gnus-write-buffer file))
186 (setq headers (nnheader-parse-head t))
187 (mail-header-set-number headers number)
eec82323
LMI
188 (gnus-cache-change-buffer group)
189 (set-buffer (cdr gnus-cache-buffer))
190 (goto-char (point-max))
191 (forward-line -1)
192 (while (condition-case ()
193 (when (not (bobp))
194 (> (read (current-buffer)) number))
195 (error
196 ;; The line was malformed, so we just remove it!!
197 (gnus-delete-line)
198 t))
199 (forward-line -1))
200 (if (bobp)
201 (if (not (eobp))
202 (progn
203 (beginning-of-line)
204 (when (< (read (current-buffer)) number)
205 (forward-line 1)))
206 (beginning-of-line))
207 (forward-line 1))
208 (beginning-of-line)
16409b0b 209 (nnheader-insert-nov headers)
eec82323
LMI
210 ;; Update the active info.
211 (set-buffer gnus-summary-buffer)
212 (gnus-cache-update-active group number)
213 (push article gnus-newsgroup-cached)
214 (gnus-summary-update-secondary-mark article))
215 t))))))
216
217(defun gnus-cache-enter-remove-article (article)
218 "Mark ARTICLE for later possible removal."
219 (when article
220 (push article gnus-cache-removable-articles)))
221
222(defun gnus-cache-possibly-remove-articles ()
223 "Possibly remove some of the removable articles."
224 (if (not (gnus-virtual-group-p gnus-newsgroup-name))
225 (gnus-cache-possibly-remove-articles-1)
226 (let ((arts gnus-cache-removable-articles)
227 ga)
228 (while arts
229 (when (setq ga (nnvirtual-find-group-art
230 (gnus-group-real-name gnus-newsgroup-name) (pop arts)))
231 (let ((gnus-cache-removable-articles (list (cdr ga)))
232 (gnus-newsgroup-name (car ga)))
233 (gnus-cache-possibly-remove-articles-1)))))
234 (setq gnus-cache-removable-articles nil)))
235
236(defun gnus-cache-possibly-remove-articles-1 ()
237 "Possibly remove some of the removable articles."
238 (unless (eq gnus-use-cache 'passive)
239 (let ((articles gnus-cache-removable-articles)
240 (cache-articles gnus-newsgroup-cached)
241 article)
242 (gnus-cache-change-buffer gnus-newsgroup-name)
243 (while articles
244 (when (memq (setq article (pop articles)) cache-articles)
245 ;; The article was in the cache, so we see whether we are
246 ;; supposed to remove it from the cache.
247 (gnus-cache-possibly-remove-article
248 article (memq article gnus-newsgroup-marked)
249 (memq article gnus-newsgroup-dormant)
250 (or (memq article gnus-newsgroup-unreads)
251 (memq article gnus-newsgroup-unselected))))))
252 ;; The overview file might have been modified, save it
253 ;; safe because we're only called at group exit anyway.
254 (gnus-cache-save-buffers)))
255
256(defun gnus-cache-request-article (article group)
257 "Retrieve ARTICLE in GROUP from the cache."
258 (let ((file (gnus-cache-file-name group article))
259 (buffer-read-only nil))
260 (when (file-exists-p file)
261 (erase-buffer)
262 (gnus-kill-all-overlays)
16409b0b
GM
263 (let ((coding-system-for-read gnus-cache-coding-system))
264 (insert-file-contents file))
eec82323
LMI
265 t)))
266
267(defun gnus-cache-possibly-alter-active (group active)
268 "Alter the ACTIVE info for GROUP to reflect the articles in the cache."
eec82323
LMI
269 (when gnus-cache-active-hashtb
270 (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
a8151ef7
LMI
271 (when cache-active
272 (when (< (car cache-active) (car active))
273 (setcar active (car cache-active)))
274 (when (> (cdr cache-active) (cdr active))
275 (setcdr active (cdr cache-active)))))))
eec82323
LMI
276
277(defun gnus-cache-retrieve-headers (articles group &optional fetch-old)
278 "Retrieve the headers for ARTICLES in GROUP."
279 (let ((cached
280 (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group))))
281 (if (not cached)
282 ;; No cached articles here, so we just retrieve them
283 ;; the normal way.
284 (let ((gnus-use-cache nil))
285 (gnus-retrieve-headers articles group fetch-old))
286 (let ((uncached-articles (gnus-sorted-intersection
287 (gnus-sorted-complement articles cached)
288 articles))
289 (cache-file (gnus-cache-file-name group ".overview"))
290 type)
291 ;; We first retrieve all the headers that we don't have in
292 ;; the cache.
293 (let ((gnus-use-cache nil))
294 (when uncached-articles
295 (setq type (and articles
296 (gnus-retrieve-headers
297 uncached-articles group fetch-old)))))
298 (gnus-cache-save-buffers)
299 ;; Then we insert the cached headers.
300 (save-excursion
301 (cond
302 ((not (file-exists-p cache-file))
303 ;; There are no cached headers.
304 type)
305 ((null type)
306 ;; There were no uncached headers (or retrieval was
307 ;; unsuccessful), so we use the cached headers exclusively.
308 (set-buffer nntp-server-buffer)
309 (erase-buffer)
a1506d29 310 (let ((coding-system-for-read
16409b0b
GM
311 gnus-cache-overview-coding-system))
312 (insert-file-contents cache-file))
eec82323
LMI
313 'nov)
314 ((eq type 'nov)
315 ;; We have both cached and uncached NOV headers, so we
316 ;; braid them.
317 (gnus-cache-braid-nov group cached)
318 type)
319 (t
320 ;; We braid HEADs.
321 (gnus-cache-braid-heads group (gnus-sorted-intersection
322 cached articles))
323 type)))))))
324
325(defun gnus-cache-enter-article (&optional n)
326 "Enter the next N articles into the cache.
327If not given a prefix, use the process marked articles instead.
328Returns the list of articles entered."
329 (interactive "P")
eec82323
LMI
330 (let ((articles (gnus-summary-work-articles n))
331 article out)
332 (while (setq article (pop articles))
6748645f 333 (gnus-summary-remove-process-mark article)
eec82323
LMI
334 (if (natnump article)
335 (when (gnus-cache-possibly-enter-article
336 gnus-newsgroup-name article
eec82323
LMI
337 nil nil nil t)
338 (push article out))
339 (gnus-message 2 "Can't cache article %d" article))
eec82323
LMI
340 (gnus-summary-update-secondary-mark article))
341 (gnus-summary-next-subject 1)
342 (gnus-summary-position-point)
343 (nreverse out)))
344
345(defun gnus-cache-remove-article (n)
346 "Remove the next N articles from the cache.
347If not given a prefix, use the process marked articles instead.
348Returns the list of articles removed."
349 (interactive "P")
eec82323
LMI
350 (gnus-cache-change-buffer gnus-newsgroup-name)
351 (let ((articles (gnus-summary-work-articles n))
352 article out)
353 (while articles
354 (setq article (pop articles))
6748645f 355 (gnus-summary-remove-process-mark article)
eec82323
LMI
356 (when (gnus-cache-possibly-remove-article article nil nil nil t)
357 (push article out))
eec82323
LMI
358 (gnus-summary-update-secondary-mark article))
359 (gnus-summary-next-subject 1)
360 (gnus-summary-position-point)
361 (nreverse out)))
362
363(defun gnus-cached-article-p (article)
364 "Say whether ARTICLE is cached in the current group."
365 (memq article gnus-newsgroup-cached))
366
367(defun gnus-summary-insert-cached-articles ()
368 "Insert all the articles cached for this group into the current buffer."
369 (interactive)
16409b0b 370 (let ((cached (sort (copy-sequence gnus-newsgroup-cached) '>))
eec82323
LMI
371 (gnus-verbose (max 6 gnus-verbose)))
372 (unless cached
6748645f 373 (gnus-message 3 "No cached articles for this group"))
eec82323
LMI
374 (while cached
375 (gnus-summary-goto-subject (pop cached) t))))
376
6748645f
LMI
377(defalias 'gnus-summary-limit-include-cached
378 'gnus-summary-insert-cached-articles)
379
eec82323
LMI
380;;; Internal functions.
381
382(defun gnus-cache-change-buffer (group)
383 (and gnus-cache-buffer
384 ;; See if the current group's overview cache has been loaded.
385 (or (string= group (car gnus-cache-buffer))
386 ;; Another overview cache is current, save it.
387 (gnus-cache-save-buffers)))
388 ;; if gnus-cache buffer is nil, create it
389 (unless gnus-cache-buffer
390 ;; Create cache buffer
391 (save-excursion
392 (setq gnus-cache-buffer
393 (cons group
6748645f
LMI
394 (set-buffer (gnus-get-buffer-create
395 " *gnus-cache-overview*"))))
eec82323
LMI
396 ;; Insert the contents of this group's cache overview.
397 (erase-buffer)
398 (let ((file (gnus-cache-file-name group ".overview")))
399 (when (file-exists-p file)
400 (nnheader-insert-file-contents file)))
401 ;; We have a fresh (empty/just loaded) buffer,
402 ;; mark it as unmodified to save a redundant write later.
403 (set-buffer-modified-p nil))))
404
405;; Return whether an article is a member of a class.
406(defun gnus-cache-member-of-class (class ticked dormant unread)
407 (or (and ticked (memq 'ticked class))
408 (and dormant (memq 'dormant class))
409 (and unread (memq 'unread class))
410 (and (not unread) (not ticked) (not dormant) (memq 'read class))))
411
412(defun gnus-cache-file-name (group article)
6ab8077a
DL
413 (expand-file-name
414 (if (stringp article) article (int-to-string article))
415 (file-name-as-directory
416 (expand-file-name
417 (nnheader-translate-file-chars
418 (if (gnus-use-long-file-name 'not-cache)
419 group
420 (let ((group (nnheader-replace-duplicate-chars-in-string
421 (nnheader-replace-chars-in-string group ?/ ?_)
422 ?. ?_)))
423 ;; Translate the first colon into a slash.
424 (when (string-match ":" group)
425 (aset group (match-beginning 0) ?/))
426 (nnheader-replace-chars-in-string group ?. ?/)))
427 t)
428 gnus-cache-directory))))
eec82323
LMI
429
430(defun gnus-cache-update-article (group article)
431 "If ARTICLE is in the cache, remove it and re-enter it."
6748645f 432 (gnus-cache-change-buffer group)
16409b0b 433 (when (gnus-cache-possibly-remove-article article nil nil nil t)
eec82323
LMI
434 (let ((gnus-use-cache nil))
435 (gnus-cache-possibly-enter-article
16409b0b 436 gnus-newsgroup-name article
eec82323
LMI
437 nil nil nil t))))
438
439(defun gnus-cache-possibly-remove-article (article ticked dormant unread
440 &optional force)
441 "Possibly remove ARTICLE from the cache."
442 (let ((group gnus-newsgroup-name)
443 (number article)
444 file)
445 ;; If this is a virtual group, we find the real group.
446 (when (gnus-virtual-group-p group)
447 (let ((result (nnvirtual-find-group-art
448 (gnus-group-real-name group) article)))
449 (setq group (car result)
450 number (cdr result))))
451 (setq file (gnus-cache-file-name group number))
452 (when (and (file-exists-p file)
453 (or force
454 (gnus-cache-member-of-class
455 gnus-cache-remove-articles ticked dormant unread)))
456 (save-excursion
457 (delete-file file)
458 (set-buffer (cdr gnus-cache-buffer))
459 (goto-char (point-min))
460 (when (or (looking-at (concat (int-to-string number) "\t"))
461 (search-forward (concat "\n" (int-to-string number) "\t")
462 (point-max) t))
463 (delete-region (progn (beginning-of-line) (point))
464 (progn (forward-line 1) (point)))))
465 (setq gnus-newsgroup-cached
466 (delq article gnus-newsgroup-cached))
467 (gnus-summary-update-secondary-mark article)
468 t)))
469
470(defun gnus-cache-articles-in-group (group)
471 "Return a sorted list of cached articles in GROUP."
a8151ef7
LMI
472 (let ((dir (file-name-directory (gnus-cache-file-name group 1)))
473 articles)
eec82323 474 (when (file-exists-p dir)
a8151ef7
LMI
475 (setq articles
476 (sort (mapcar (lambda (name) (string-to-int name))
477 (directory-files dir nil "^[0-9]+$" t))
478 '<))
479 ;; Update the cache active file, just to synch more.
480 (when articles
481 (gnus-cache-update-active group (car articles) t)
482 (gnus-cache-update-active group (car (last articles))))
483 articles)))
484
485(defun gnus-cache-braid-nov (group cached &optional file)
6748645f 486 (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))
eec82323
LMI
487 beg end)
488 (gnus-cache-save-buffers)
489 (save-excursion
490 (set-buffer cache-buf)
eec82323 491 (erase-buffer)
a1506d29 492 (let ((coding-system-for-read
16409b0b 493 gnus-cache-overview-coding-system))
a1506d29 494 (insert-file-contents
16409b0b 495 (or file (gnus-cache-file-name group ".overview"))))
eec82323
LMI
496 (goto-char (point-min))
497 (insert "\n")
498 (goto-char (point-min)))
499 (set-buffer nntp-server-buffer)
500 (goto-char (point-min))
501 (while cached
502 (while (and (not (eobp))
503 (< (read (current-buffer)) (car cached)))
504 (forward-line 1))
505 (beginning-of-line)
506 (save-excursion
507 (set-buffer cache-buf)
508 (if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
509 nil t)
510 (setq beg (progn (beginning-of-line) (point))
511 end (progn (end-of-line) (point)))
512 (setq beg nil)))
513 (when beg
514 (insert-buffer-substring cache-buf beg end)
515 (insert "\n"))
516 (setq cached (cdr cached)))
517 (kill-buffer cache-buf)))
518
519(defun gnus-cache-braid-heads (group cached)
6748645f 520 (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")))
eec82323
LMI
521 (save-excursion
522 (set-buffer cache-buf)
eec82323
LMI
523 (erase-buffer))
524 (set-buffer nntp-server-buffer)
525 (goto-char (point-min))
526 (while cached
527 (while (and (not (eobp))
528 (looking-at "2.. +\\([0-9]+\\) ")
529 (< (progn (goto-char (match-beginning 1))
530 (read (current-buffer)))
531 (car cached)))
532 (search-forward "\n.\n" nil 'move))
533 (beginning-of-line)
534 (save-excursion
535 (set-buffer cache-buf)
536 (erase-buffer)
a1506d29 537 (let ((coding-system-for-read
16409b0b
GM
538 gnus-cache-coding-system))
539 (insert-file-contents (gnus-cache-file-name group (car cached))))
eec82323
LMI
540 (goto-char (point-min))
541 (insert "220 ")
542 (princ (car cached) (current-buffer))
543 (insert " Article retrieved.\n")
544 (search-forward "\n\n" nil 'move)
545 (delete-region (point) (point-max))
546 (forward-char -1)
547 (insert "."))
548 (insert-buffer-substring cache-buf)
549 (setq cached (cdr cached)))
550 (kill-buffer cache-buf)))
551
552;;;###autoload
553(defun gnus-jog-cache ()
554 "Go through all groups and put the articles into the cache.
555
556Usage:
557$ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
558 (interactive)
559 (let ((gnus-mark-article-hook nil)
560 (gnus-expert-user t)
561 (nnmail-spool-file nil)
16409b0b 562 (mail-sources nil)
eec82323
LMI
563 (gnus-use-dribble-file nil)
564 (gnus-novice-user nil)
565 (gnus-large-newsgroup nil))
566 ;; Start Gnus.
567 (gnus)
568 ;; Go through all groups...
569 (gnus-group-mark-buffer)
a8151ef7
LMI
570 (gnus-group-iterate nil
571 (lambda (group)
572 (let (gnus-auto-select-next)
573 (gnus-summary-read-group group nil t)
574 ;; ... and enter the articles into the cache.
575 (when (eq major-mode 'gnus-summary-mode)
576 (gnus-uu-mark-buffer)
577 (gnus-cache-enter-article)
578 (kill-buffer (current-buffer))))))))
eec82323
LMI
579
580(defun gnus-cache-read-active (&optional force)
581 "Read the cache active file."
582 (gnus-make-directory gnus-cache-directory)
a8151ef7 583 (if (or (not (file-exists-p gnus-cache-active-file))
6748645f 584 (zerop (nth 7 (file-attributes gnus-cache-active-file)))
a8151ef7 585 force)
eec82323
LMI
586 ;; There is no active file, so we generate one.
587 (gnus-cache-generate-active)
588 ;; We simply read the active file.
589 (save-excursion
590 (gnus-set-work-buffer)
16409b0b 591 (nnheader-insert-file-contents gnus-cache-active-file)
eec82323
LMI
592 (gnus-active-to-gnus-format
593 nil (setq gnus-cache-active-hashtb
594 (gnus-make-hashtable
595 (count-lines (point-min) (point-max)))))
596 (setq gnus-cache-active-altered nil))))
597
598(defun gnus-cache-write-active (&optional force)
599 "Write the active hashtb to the active file."
600 (when (or force
601 (and gnus-cache-active-hashtb
602 gnus-cache-active-altered))
16409b0b 603 (gnus-write-active-file gnus-cache-active-file gnus-cache-active-hashtb t)
eec82323
LMI
604 ;; Mark the active hashtb as unaltered.
605 (setq gnus-cache-active-altered nil)))
606
607(defun gnus-cache-update-active (group number &optional low)
608 "Update the upper bound of the active info of GROUP to NUMBER.
609If LOW, update the lower bound instead."
610 (let ((active (gnus-gethash group gnus-cache-active-hashtb)))
611 (if (null active)
612 ;; We just create a new active entry for this group.
613 (gnus-sethash group (cons number number) gnus-cache-active-hashtb)
614 ;; Update the lower or upper bound.
615 (if low
616 (setcar active number)
617 (setcdr active number)))
618 ;; Mark the active hashtb as altered.
619 (setq gnus-cache-active-altered t)))
620
621;;;###autoload
622(defun gnus-cache-generate-active (&optional directory)
623 "Generate the cache active file."
624 (interactive)
625 (let* ((top (null directory))
626 (directory (expand-file-name (or directory gnus-cache-directory)))
627 (files (directory-files directory 'full))
628 (group
629 (if top
630 ""
631 (string-match
6748645f
LMI
632 (concat "^" (regexp-quote
633 (file-name-as-directory
634 (expand-file-name gnus-cache-directory))))
eec82323
LMI
635 (directory-file-name directory))
636 (nnheader-replace-chars-in-string
637 (substring (directory-file-name directory) (match-end 0))
638 ?/ ?.)))
639 nums alphs)
640 (when top
641 (gnus-message 5 "Generating the cache active file...")
642 (setq gnus-cache-active-hashtb (gnus-make-hashtable 123)))
6748645f
LMI
643 (when (string-match "^\\(nn[^_]+\\)_" group)
644 (setq group (replace-match "\\1:" t t group)))
eec82323
LMI
645 ;; Separate articles from all other files and directories.
646 (while files
647 (if (string-match "^[0-9]+$" (file-name-nondirectory (car files)))
648 (push (string-to-int (file-name-nondirectory (pop files))) nums)
649 (push (pop files) alphs)))
650 ;; If we have nums, then this is probably a valid group.
651 (when (setq nums (sort nums '<))
652 (gnus-sethash group (cons (car nums) (gnus-last-element nums))
653 gnus-cache-active-hashtb))
654 ;; Go through all the other files.
655 (while alphs
656 (when (and (file-directory-p (car alphs))
6748645f 657 (not (string-match "^\\."
eec82323
LMI
658 (file-name-nondirectory (car alphs)))))
659 ;; We descend directories.
660 (gnus-cache-generate-active (car alphs)))
661 (setq alphs (cdr alphs)))
662 ;; Write the new active file.
663 (when top
664 (gnus-cache-write-active t)
665 (gnus-message 5 "Generating the cache active file...done"))))
666
667;;;###autoload
668(defun gnus-cache-generate-nov-databases (dir)
669 "Generate NOV files recursively starting in DIR."
670 (interactive (list gnus-cache-directory))
671 (gnus-cache-close)
672 (let ((nnml-generate-active-function 'identity))
673 (nnml-generate-nov-databases-1 dir)))
674
675(defun gnus-cache-move-cache (dir)
676 "Move the cache tree to somewhere else."
a8151ef7 677 (interactive "FMove the cache tree to: ")
eec82323
LMI
678 (rename-file gnus-cache-directory dir))
679
680(provide 'gnus-cache)
681
682;;; gnus-cache.el ends here