Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-cache.el @ 70:131b0175ea99 r20-0b30

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