Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-cache.el @ 108:360340f9fd5f r20-1b6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b6
author cvs
date Mon, 13 Aug 2007 09:18:39 +0200
parents 0d2f883870bc
children fe104dbd9147
comparison
equal deleted inserted replaced
107:523141596bda 108:360340f9fd5f
40 (nnheader-concat gnus-directory "cache/") 40 (nnheader-concat gnus-directory "cache/")
41 "*The directory where cached articles will be stored." 41 "*The directory where cached articles will be stored."
42 :group 'gnus-cache 42 :group 'gnus-cache
43 :type 'directory) 43 :type 'directory)
44 44
45 (defcustom gnus-cache-active-file 45 (defcustom gnus-cache-active-file
46 (concat (file-name-as-directory gnus-cache-directory) "active") 46 (concat (file-name-as-directory gnus-cache-directory) "active")
47 "*The cache active file." 47 "*The cache active file."
48 :group 'gnus-cache 48 :group 'gnus-cache
49 :type 'file) 49 :type 'file)
50 50
127 (error nil))))) 127 (error nil)))))
128 ;; Kill the buffer -- it's either unmodified or saved. 128 ;; Kill the buffer -- it's either unmodified or saved.
129 (gnus-kill-buffer buffer) 129 (gnus-kill-buffer buffer)
130 (setq gnus-cache-buffer nil)))) 130 (setq gnus-cache-buffer nil))))
131 131
132 (defun gnus-cache-possibly-enter-article 132 (defun gnus-cache-possibly-enter-article
133 (group article headers ticked dormant unread &optional force) 133 (group article headers ticked dormant unread &optional force)
134 (when (and (or force (not (eq gnus-use-cache 'passive))) 134 (when (and (or force (not (eq gnus-use-cache 'passive)))
135 (numberp article) 135 (numberp article)
136 (> article 0) 136 (> article 0)
137 (vectorp headers)) 137 (vectorp headers))
138 ; This might be a dummy article. 138 ; This might be a dummy article.
139 ;; If this is a virtual group, we find the real group. 139 ;; If this is a virtual group, we find the real group.
140 (when (gnus-virtual-group-p group) 140 (when (gnus-virtual-group-p group)
141 (let ((result (nnvirtual-find-group-art 141 (let ((result (nnvirtual-find-group-art
142 (gnus-group-real-name group) article))) 142 (gnus-group-real-name group) article)))
143 (setq group (car result) 143 (setq group (car result)
144 headers (copy-sequence headers)) 144 headers (copy-sequence headers))
145 (mail-header-set-number headers (cdr result)))) 145 (mail-header-set-number headers (cdr result))))
146 (let ((number (mail-header-number headers)) 146 (let ((number (mail-header-number headers))
256 (defun gnus-cache-possibly-alter-active (group active) 256 (defun gnus-cache-possibly-alter-active (group active)
257 "Alter the ACTIVE info for GROUP to reflect the articles in the cache." 257 "Alter the ACTIVE info for GROUP to reflect the articles in the cache."
258 (when (equal group "no.norsk") (error "hie")) 258 (when (equal group "no.norsk") (error "hie"))
259 (when gnus-cache-active-hashtb 259 (when gnus-cache-active-hashtb
260 (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) 260 (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
261 (and cache-active 261 (and cache-active
262 (< (car cache-active) (car active)) 262 (< (car cache-active) (car active))
263 (setcar active (car cache-active))) 263 (setcar active (car cache-active)))
264 (and cache-active 264 (and cache-active
265 (> (cdr cache-active) (cdr active)) 265 (> (cdr cache-active) (cdr active))
266 (setcdr active (cdr cache-active)))))) 266 (setcdr active (cdr cache-active))))))
267 267
268 (defun gnus-cache-retrieve-headers (articles group &optional fetch-old) 268 (defun gnus-cache-retrieve-headers (articles group &optional fetch-old)
269 "Retrieve the headers for ARTICLES in GROUP." 269 "Retrieve the headers for ARTICLES in GROUP."
270 (let ((cached 270 (let ((cached
271 (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))) 271 (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group))))
272 (if (not cached) 272 (if (not cached)
273 ;; No cached articles here, so we just retrieve them 273 ;; No cached articles here, so we just retrieve them
274 ;; the normal way. 274 ;; the normal way.
275 (let ((gnus-use-cache nil)) 275 (let ((gnus-use-cache nil))
277 (let ((uncached-articles (gnus-sorted-intersection 277 (let ((uncached-articles (gnus-sorted-intersection
278 (gnus-sorted-complement articles cached) 278 (gnus-sorted-complement articles cached)
279 articles)) 279 articles))
280 (cache-file (gnus-cache-file-name group ".overview")) 280 (cache-file (gnus-cache-file-name group ".overview"))
281 type) 281 type)
282 ;; We first retrieve all the headers that we don't have in 282 ;; We first retrieve all the headers that we don't have in
283 ;; the cache. 283 ;; the cache.
284 (let ((gnus-use-cache nil)) 284 (let ((gnus-use-cache nil))
285 (when uncached-articles 285 (when uncached-articles
286 (setq type (and articles 286 (setq type (and articles
287 (gnus-retrieve-headers 287 (gnus-retrieve-headers
288 uncached-articles group fetch-old))))) 288 uncached-articles group fetch-old)))))
289 (gnus-cache-save-buffers) 289 (gnus-cache-save-buffers)
290 ;; Then we insert the cached headers. 290 ;; Then we insert the cached headers.
291 (save-excursion 291 (save-excursion
292 (cond 292 (cond
293 ((not (file-exists-p cache-file)) 293 ((not (file-exists-p cache-file))
294 ;; There are no cached headers. 294 ;; There are no cached headers.
295 type) 295 type)
296 ((null type) 296 ((null type)
297 ;; There were no uncached headers (or retrieval was 297 ;; There were no uncached headers (or retrieval was
298 ;; unsuccessful), so we use the cached headers exclusively. 298 ;; unsuccessful), so we use the cached headers exclusively.
299 (set-buffer nntp-server-buffer) 299 (set-buffer nntp-server-buffer)
300 (erase-buffer) 300 (erase-buffer)
301 (insert-file-contents cache-file) 301 (insert-file-contents cache-file)
302 'nov) 302 'nov)
319 (gnus-set-global-variables) 319 (gnus-set-global-variables)
320 (let ((articles (gnus-summary-work-articles n)) 320 (let ((articles (gnus-summary-work-articles n))
321 article out) 321 article out)
322 (while (setq article (pop articles)) 322 (while (setq article (pop articles))
323 (if (natnump article) 323 (if (natnump article)
324 (when (gnus-cache-possibly-enter-article 324 (when (gnus-cache-possibly-enter-article
325 gnus-newsgroup-name article 325 gnus-newsgroup-name article
326 (gnus-summary-article-header article) 326 (gnus-summary-article-header article)
327 nil nil nil t) 327 nil nil nil t)
328 (push article out)) 328 (push article out))
329 (gnus-message 2 "Can't cache article %d" article)) 329 (gnus-message 2 "Can't cache article %d" article))
330 (gnus-summary-remove-process-mark article) 330 (gnus-summary-remove-process-mark article)
385 ;; Insert the contents of this group's cache overview. 385 ;; Insert the contents of this group's cache overview.
386 (erase-buffer) 386 (erase-buffer)
387 (let ((file (gnus-cache-file-name group ".overview"))) 387 (let ((file (gnus-cache-file-name group ".overview")))
388 (when (file-exists-p file) 388 (when (file-exists-p file)
389 (nnheader-insert-file-contents file))) 389 (nnheader-insert-file-contents file)))
390 ;; We have a fresh (empty/just loaded) buffer, 390 ;; We have a fresh (empty/just loaded) buffer,
391 ;; mark it as unmodified to save a redundant write later. 391 ;; mark it as unmodified to save a redundant write later.
392 (set-buffer-modified-p nil)))) 392 (set-buffer-modified-p nil))))
393 393
394 ;; Return whether an article is a member of a class. 394 ;; Return whether an article is a member of a class.
395 (defun gnus-cache-member-of-class (class ticked dormant unread) 395 (defun gnus-cache-member-of-class (class ticked dormant unread)
413 413
414 (defun gnus-cache-update-article (group article) 414 (defun gnus-cache-update-article (group article)
415 "If ARTICLE is in the cache, remove it and re-enter it." 415 "If ARTICLE is in the cache, remove it and re-enter it."
416 (when (gnus-cache-possibly-remove-article article nil nil nil t) 416 (when (gnus-cache-possibly-remove-article article nil nil nil t)
417 (let ((gnus-use-cache nil)) 417 (let ((gnus-use-cache nil))
418 (gnus-cache-possibly-enter-article 418 (gnus-cache-possibly-enter-article
419 gnus-newsgroup-name article (gnus-summary-article-header article) 419 gnus-newsgroup-name article (gnus-summary-article-header article)
420 nil nil nil t)))) 420 nil nil nil t))))
421 421
422 (defun gnus-cache-possibly-remove-article (article ticked dormant unread 422 (defun gnus-cache-possibly-remove-article (article ticked dormant unread
423 &optional force) 423 &optional force)
424 "Possibly remove ARTICLE from the cache." 424 "Possibly remove ARTICLE from the cache."
425 (let ((group gnus-newsgroup-name) 425 (let ((group gnus-newsgroup-name)
426 (number article) 426 (number article)
427 file) 427 file)
428 ;; If this is a virtual group, we find the real group. 428 ;; If this is a virtual group, we find the real group.
429 (when (gnus-virtual-group-p group) 429 (when (gnus-virtual-group-p group)
430 (let ((result (nnvirtual-find-group-art 430 (let ((result (nnvirtual-find-group-art
431 (gnus-group-real-name group) article))) 431 (gnus-group-real-name group) article)))
432 (setq group (car result) 432 (setq group (car result)
433 number (cdr result)))) 433 number (cdr result))))
434 (setq file (gnus-cache-file-name group number)) 434 (setq file (gnus-cache-file-name group number))
435 (when (and (file-exists-p file) 435 (when (and (file-exists-p file)
537 (gnus-large-newsgroup nil)) 537 (gnus-large-newsgroup nil))
538 ;; Start Gnus. 538 ;; Start Gnus.
539 (gnus) 539 (gnus)
540 ;; Go through all groups... 540 ;; Go through all groups...
541 (gnus-group-mark-buffer) 541 (gnus-group-mark-buffer)
542 (gnus-group-universal-argument 542 (gnus-group-universal-argument
543 nil nil 543 nil nil
544 (lambda () 544 (lambda ()
545 (interactive) 545 (interactive)
546 (gnus-summary-read-group (gnus-group-group-name) nil t) 546 (gnus-summary-read-group (gnus-group-group-name) nil t)
547 ;; ... and enter the articles into the cache. 547 ;; ... and enter the articles into the cache.
548 (when (eq major-mode 'gnus-summary-mode) 548 (when (eq major-mode 'gnus-summary-mode)
560 ;; We simply read the active file. 560 ;; We simply read the active file.
561 (save-excursion 561 (save-excursion
562 (gnus-set-work-buffer) 562 (gnus-set-work-buffer)
563 (insert-file-contents gnus-cache-active-file) 563 (insert-file-contents gnus-cache-active-file)
564 (gnus-active-to-gnus-format 564 (gnus-active-to-gnus-format
565 nil (setq gnus-cache-active-hashtb 565 nil (setq gnus-cache-active-hashtb
566 (gnus-make-hashtable 566 (gnus-make-hashtable
567 (count-lines (point-min) (point-max))))) 567 (count-lines (point-min) (point-max)))))
568 (setq gnus-cache-active-altered nil)))) 568 (setq gnus-cache-active-altered nil))))
569 569
570 (defun gnus-cache-write-active (&optional force) 570 (defun gnus-cache-write-active (&optional force)
571 "Write the active hashtb to the active file." 571 "Write the active hashtb to the active file."
572 (when (or force 572 (when (or force
573 (and gnus-cache-active-hashtb 573 (and gnus-cache-active-hashtb
574 gnus-cache-active-altered)) 574 gnus-cache-active-altered))
602 "Generate the cache active file." 602 "Generate the cache active file."
603 (interactive) 603 (interactive)
604 (let* ((top (null directory)) 604 (let* ((top (null directory))
605 (directory (expand-file-name (or directory gnus-cache-directory))) 605 (directory (expand-file-name (or directory gnus-cache-directory)))
606 (files (directory-files directory 'full)) 606 (files (directory-files directory 'full))
607 (group 607 (group
608 (if top 608 (if top
609 "" 609 ""
610 (string-match 610 (string-match
611 (concat "^" (file-name-as-directory 611 (concat "^" (file-name-as-directory
612 (expand-file-name gnus-cache-directory))) 612 (expand-file-name gnus-cache-directory)))
613 (directory-file-name directory)) 613 (directory-file-name directory))
614 (nnheader-replace-chars-in-string 614 (nnheader-replace-chars-in-string
615 (substring (directory-file-name directory) (match-end 0)) 615 (substring (directory-file-name directory) (match-end 0))
616 ?/ ?.))) 616 ?/ ?.)))
617 nums alphs) 617 nums alphs)
618 (when top 618 (when top
619 (gnus-message 5 "Generating the cache active file...") 619 (gnus-message 5 "Generating the cache active file...")
652 "Move the cache tree to somewhere else." 652 "Move the cache tree to somewhere else."
653 (interactive "DMove the cache tree to: ") 653 (interactive "DMove the cache tree to: ")
654 (rename-file gnus-cache-directory dir)) 654 (rename-file gnus-cache-directory dir))
655 655
656 (provide 'gnus-cache) 656 (provide 'gnus-cache)
657 657
658 ;;; gnus-cache.el ends here 658 ;;; gnus-cache.el ends here