1 |
;;; gnus-cache.el --- cache interface for Gnus |
;;; gnus-cache.el --- cache interface for Gnus |
2 |
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 |
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 |
3 |
;; Free Software Foundation, Inc. |
;; Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
33 |
(require 'gnus-range) |
(require 'gnus-range) |
34 |
(require 'gnus-start) |
(require 'gnus-start) |
35 |
(eval-when-compile |
(eval-when-compile |
36 |
|
(if (not (fboundp 'gnus-agent-load-alist)) |
37 |
|
(defun gnus-agent-load-alist (group))) |
38 |
(require 'gnus-sum)) |
(require 'gnus-sum)) |
39 |
|
|
40 |
(defcustom gnus-cache-active-file |
(defcustom gnus-cache-active-file |
162 |
(when (and number |
(when (and number |
163 |
(> number 0) ; Reffed article. |
(> number 0) ; Reffed article. |
164 |
(or force |
(or force |
165 |
(and (or (not gnus-cacheable-groups) |
(and (gnus-cache-fully-p group) |
|
(string-match gnus-cacheable-groups group)) |
|
|
(or (not gnus-uncacheable-groups) |
|
|
(not (string-match |
|
|
gnus-uncacheable-groups group))) |
|
166 |
(gnus-cache-member-of-class |
(gnus-cache-member-of-class |
167 |
gnus-cache-enter-articles ticked dormant unread))) |
gnus-cache-enter-articles ticked dormant unread))) |
168 |
(not (file-exists-p (setq file (gnus-cache-file-name |
(not (file-exists-p (setq file (gnus-cache-file-name |
181 |
(when (> (buffer-size) 0) |
(when (> (buffer-size) 0) |
182 |
(let ((coding-system-for-write gnus-cache-coding-system)) |
(let ((coding-system-for-write gnus-cache-coding-system)) |
183 |
(gnus-write-buffer file)) |
(gnus-write-buffer file)) |
184 |
(setq headers (nnheader-parse-head t)) |
(nnheader-remove-body) |
185 |
|
(setq headers (nnheader-parse-naked-head)) |
186 |
(mail-header-set-number headers number) |
(mail-header-set-number headers number) |
187 |
(gnus-cache-change-buffer group) |
(gnus-cache-change-buffer group) |
188 |
(set-buffer (cdr gnus-cache-buffer)) |
(set-buffer (cdr gnus-cache-buffer)) |
208 |
(nnheader-insert-nov headers) |
(nnheader-insert-nov headers) |
209 |
;; Update the active info. |
;; Update the active info. |
210 |
(set-buffer gnus-summary-buffer) |
(set-buffer gnus-summary-buffer) |
211 |
(gnus-cache-update-active group number) |
(gnus-cache-possibly-update-active group (cons number number)) |
212 |
(push article gnus-newsgroup-cached) |
(setq gnus-newsgroup-cached |
213 |
|
(gnus-add-to-sorted-list gnus-newsgroup-cached article)) |
214 |
(gnus-summary-update-secondary-mark article)) |
(gnus-summary-update-secondary-mark article)) |
215 |
t)))))) |
t)))))) |
216 |
|
|
235 |
|
|
236 |
(defun gnus-cache-possibly-remove-articles-1 () |
(defun gnus-cache-possibly-remove-articles-1 () |
237 |
"Possibly remove some of the removable articles." |
"Possibly remove some of the removable articles." |
238 |
(unless (eq gnus-use-cache 'passive) |
(when (gnus-cache-fully-p gnus-newsgroup-name) |
239 |
(let ((articles gnus-cache-removable-articles) |
(let ((articles gnus-cache-removable-articles) |
240 |
(cache-articles gnus-newsgroup-cached) |
(cache-articles gnus-newsgroup-cached) |
241 |
article) |
article) |
283 |
;; the normal way. |
;; the normal way. |
284 |
(let ((gnus-use-cache nil)) |
(let ((gnus-use-cache nil)) |
285 |
(gnus-retrieve-headers articles group fetch-old)) |
(gnus-retrieve-headers articles group fetch-old)) |
286 |
(let ((uncached-articles (gnus-sorted-intersection |
(let ((uncached-articles (gnus-sorted-difference articles cached)) |
|
(gnus-sorted-complement articles cached) |
|
|
articles)) |
|
287 |
(cache-file (gnus-cache-file-name group ".overview")) |
(cache-file (gnus-cache-file-name group ".overview")) |
288 |
type) |
type) |
289 |
;; We first retrieve all the headers that we don't have in |
;; We first retrieve all the headers that we don't have in |
333 |
(when (gnus-cache-possibly-enter-article |
(when (gnus-cache-possibly-enter-article |
334 |
gnus-newsgroup-name article |
gnus-newsgroup-name article |
335 |
nil nil nil t) |
nil nil nil t) |
336 |
|
(setq gnus-newsgroup-undownloaded (delq article gnus-newsgroup-undownloaded)) |
337 |
(push article out)) |
(push article out)) |
338 |
(gnus-message 2 "Can't cache article %d" article)) |
(gnus-message 2 "Can't cache article %d" article)) |
339 |
|
(gnus-summary-update-download-mark article) |
340 |
(gnus-summary-update-secondary-mark article)) |
(gnus-summary-update-secondary-mark article)) |
341 |
(gnus-summary-next-subject 1) |
(gnus-summary-next-subject 1) |
342 |
(gnus-summary-position-point) |
(gnus-summary-position-point) |
343 |
(nreverse out))) |
(nreverse out))) |
344 |
|
|
345 |
(defun gnus-cache-remove-article (n) |
(defun gnus-cache-remove-article (&optional n) |
346 |
"Remove the next N articles from the cache. |
"Remove the next N articles from the cache. |
347 |
If not given a prefix, use the process marked articles instead. |
If not given a prefix, use the process marked articles instead. |
348 |
Returns the list of articles removed." |
Returns the list of articles removed." |
354 |
(setq article (pop articles)) |
(setq article (pop articles)) |
355 |
(gnus-summary-remove-process-mark article) |
(gnus-summary-remove-process-mark article) |
356 |
(when (gnus-cache-possibly-remove-article article nil nil nil t) |
(when (gnus-cache-possibly-remove-article article nil nil nil t) |
357 |
|
(when gnus-newsgroup-agentized |
358 |
|
(let ((alist (gnus-agent-load-alist gnus-newsgroup-name))) |
359 |
|
(unless (cdr (assoc article alist)) |
360 |
|
(setq gnus-newsgroup-undownloaded |
361 |
|
(gnus-add-to-sorted-list |
362 |
|
gnus-newsgroup-undownloaded article))))) |
363 |
(push article out)) |
(push article out)) |
364 |
|
(gnus-summary-update-download-mark article) |
365 |
(gnus-summary-update-secondary-mark article)) |
(gnus-summary-update-secondary-mark article)) |
366 |
(gnus-summary-next-subject 1) |
(gnus-summary-next-subject 1) |
367 |
(gnus-summary-position-point) |
(gnus-summary-position-point) |
374 |
(defun gnus-summary-insert-cached-articles () |
(defun gnus-summary-insert-cached-articles () |
375 |
"Insert all the articles cached for this group into the current buffer." |
"Insert all the articles cached for this group into the current buffer." |
376 |
(interactive) |
(interactive) |
377 |
(let ((cached (sort (copy-sequence gnus-newsgroup-cached) '>)) |
(let ((gnus-verbose (max 6 gnus-verbose))) |
378 |
(gnus-verbose (max 6 gnus-verbose))) |
(if (not gnus-newsgroup-cached) |
379 |
(unless cached |
(gnus-message 3 "No cached articles for this group") |
380 |
(gnus-message 3 "No cached articles for this group")) |
(gnus-summary-goto-subjects gnus-newsgroup-cached)))) |
|
(while cached |
|
|
(gnus-summary-goto-subject (pop cached) t)))) |
|
381 |
|
|
382 |
(defalias 'gnus-summary-limit-include-cached |
(defun gnus-summary-limit-include-cached () |
383 |
'gnus-summary-insert-cached-articles) |
"Limit the summary buffer to articles that are cached." |
384 |
|
(interactive) |
385 |
|
(let ((gnus-verbose (max 6 gnus-verbose))) |
386 |
|
(if gnus-newsgroup-cached |
387 |
|
(progn |
388 |
|
(gnus-summary-limit gnus-newsgroup-cached) |
389 |
|
(gnus-summary-position-point)) |
390 |
|
(gnus-message 3 "No cached articles for this group")))) |
391 |
|
|
392 |
;;; Internal functions. |
;;; Internal functions. |
393 |
|
|
434 |
?. ?_))) |
?. ?_))) |
435 |
;; Translate the first colon into a slash. |
;; Translate the first colon into a slash. |
436 |
(when (string-match ":" group) |
(when (string-match ":" group) |
437 |
(aset group (match-beginning 0) ?/)) |
(setq group (concat (substring group 0 (match-beginning 0)) |
438 |
|
"/" (substring group (match-end 0))))) |
439 |
(nnheader-replace-chars-in-string group ?. ?/))) |
(nnheader-replace-chars-in-string group ?. ?/))) |
440 |
t) |
t) |
441 |
gnus-cache-directory)))) |
gnus-cache-directory)))) |
473 |
(when (or (looking-at (concat (int-to-string number) "\t")) |
(when (or (looking-at (concat (int-to-string number) "\t")) |
474 |
(search-forward (concat "\n" (int-to-string number) "\t") |
(search-forward (concat "\n" (int-to-string number) "\t") |
475 |
(point-max) t)) |
(point-max) t)) |
476 |
(delete-region (progn (beginning-of-line) (point)) |
(gnus-delete-line))) |
477 |
(progn (forward-line 1) (point))))) |
(unless (setq gnus-newsgroup-cached |
478 |
(setq gnus-newsgroup-cached |
(delq article gnus-newsgroup-cached)) |
479 |
(delq article gnus-newsgroup-cached)) |
(gnus-sethash gnus-newsgroup-name nil gnus-cache-active-hashtb) |
480 |
|
(setq gnus-cache-active-altered t)) |
481 |
(gnus-summary-update-secondary-mark article) |
(gnus-summary-update-secondary-mark article) |
482 |
t))) |
t))) |
483 |
|
|
491 |
(directory-files dir nil "^[0-9]+$" t)) |
(directory-files dir nil "^[0-9]+$" t)) |
492 |
'<)) |
'<)) |
493 |
;; Update the cache active file, just to synch more. |
;; Update the cache active file, just to synch more. |
494 |
(when articles |
(if articles |
495 |
(gnus-cache-update-active group (car articles) t) |
(progn |
496 |
(gnus-cache-update-active group (car (last articles)))) |
(gnus-cache-update-active group (car articles) t) |
497 |
|
(gnus-cache-update-active group (car (last articles)))) |
498 |
|
(when (gnus-gethash group gnus-cache-active-hashtb) |
499 |
|
(gnus-sethash group nil gnus-cache-active-hashtb) |
500 |
|
(setq gnus-cache-active-altered t))) |
501 |
articles))) |
articles))) |
502 |
|
|
503 |
(defun gnus-cache-braid-nov (group cached &optional file) |
(defun gnus-cache-braid-nov (group cached &optional file) |
521 |
(< (read (current-buffer)) (car cached))) |
(< (read (current-buffer)) (car cached))) |
522 |
(forward-line 1)) |
(forward-line 1)) |
523 |
(beginning-of-line) |
(beginning-of-line) |
524 |
(save-excursion |
(set-buffer cache-buf) |
525 |
(set-buffer cache-buf) |
(if (search-forward (concat "\n" (int-to-string (car cached)) "\t") |
526 |
(if (search-forward (concat "\n" (int-to-string (car cached)) "\t") |
nil t) |
527 |
nil t) |
(setq beg (gnus-point-at-bol) |
528 |
(setq beg (progn (beginning-of-line) (point)) |
end (progn (end-of-line) (point))) |
529 |
end (progn (end-of-line) (point))) |
(setq beg nil)) |
530 |
(setq beg nil))) |
(set-buffer nntp-server-buffer) |
531 |
(when beg |
(when beg |
532 |
(insert-buffer-substring cache-buf beg end) |
(insert-buffer-substring cache-buf beg end) |
533 |
(insert "\n")) |
(insert "\n")) |
549 |
(car cached))) |
(car cached))) |
550 |
(search-forward "\n.\n" nil 'move)) |
(search-forward "\n.\n" nil 'move)) |
551 |
(beginning-of-line) |
(beginning-of-line) |
552 |
(save-excursion |
(set-buffer cache-buf) |
553 |
(set-buffer cache-buf) |
(erase-buffer) |
554 |
(erase-buffer) |
(let ((coding-system-for-read |
555 |
(let ((coding-system-for-read |
gnus-cache-coding-system)) |
556 |
gnus-cache-coding-system)) |
(insert-file-contents (gnus-cache-file-name group (car cached)))) |
557 |
(insert-file-contents (gnus-cache-file-name group (car cached)))) |
(goto-char (point-min)) |
558 |
(goto-char (point-min)) |
(insert "220 ") |
559 |
(insert "220 ") |
(princ (car cached) (current-buffer)) |
560 |
(princ (car cached) (current-buffer)) |
(insert " Article retrieved.\n") |
561 |
(insert " Article retrieved.\n") |
(search-forward "\n\n" nil 'move) |
562 |
(search-forward "\n\n" nil 'move) |
(delete-region (point) (point-max)) |
563 |
(delete-region (point) (point-max)) |
(forward-char -1) |
564 |
(forward-char -1) |
(insert ".") |
565 |
(insert ".")) |
(set-buffer nntp-server-buffer) |
566 |
(insert-buffer-substring cache-buf) |
(insert-buffer-substring cache-buf) |
567 |
(setq cached (cdr cached))) |
(setq cached (cdr cached))) |
568 |
(kill-buffer cache-buf))) |
(kill-buffer cache-buf))) |
622 |
;; Mark the active hashtb as unaltered. |
;; Mark the active hashtb as unaltered. |
623 |
(setq gnus-cache-active-altered nil))) |
(setq gnus-cache-active-altered nil))) |
624 |
|
|
625 |
|
(defun gnus-cache-possibly-update-active (group active) |
626 |
|
"Update active info bounds of GROUP with ACTIVE if necessary. |
627 |
|
The update is performed if ACTIVE contains a higher or lower bound |
628 |
|
than the current." |
629 |
|
(let ((lower t) (higher t)) |
630 |
|
(if gnus-cache-active-hashtb |
631 |
|
(let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) |
632 |
|
(when cache-active |
633 |
|
(unless (< (car active) (car cache-active)) |
634 |
|
(setq lower nil)) |
635 |
|
(unless (> (cdr active) (cdr cache-active)) |
636 |
|
(setq higher nil)))) |
637 |
|
(gnus-cache-read-active)) |
638 |
|
(when lower |
639 |
|
(gnus-cache-update-active group (car active) t)) |
640 |
|
(when higher |
641 |
|
(gnus-cache-update-active group (cdr active))))) |
642 |
|
|
643 |
(defun gnus-cache-update-active (group number &optional low) |
(defun gnus-cache-update-active (group number &optional low) |
644 |
"Update the upper bound of the active info of GROUP to NUMBER. |
"Update the upper bound of the active info of GROUP to NUMBER. |
645 |
If LOW, update the lower bound instead." |
If LOW, update the lower bound instead." |
677 |
(gnus-message 5 "Generating the cache active file...") |
(gnus-message 5 "Generating the cache active file...") |
678 |
(setq gnus-cache-active-hashtb (gnus-make-hashtable 123))) |
(setq gnus-cache-active-hashtb (gnus-make-hashtable 123))) |
679 |
(when (string-match "^\\(nn[^_]+\\)_" group) |
(when (string-match "^\\(nn[^_]+\\)_" group) |
680 |
(setq group (replace-match "\\1:" t t group))) |
(setq group (replace-match "\\1:" t nil group))) |
681 |
;; Separate articles from all other files and directories. |
;; Separate articles from all other files and directories. |
682 |
(while files |
(while files |
683 |
(if (string-match "^[0-9]+$" (file-name-nondirectory (car files))) |
(if (string-match "^[0-9]+$" (file-name-nondirectory (car files))) |
706 |
(interactive (list gnus-cache-directory)) |
(interactive (list gnus-cache-directory)) |
707 |
(gnus-cache-close) |
(gnus-cache-close) |
708 |
(let ((nnml-generate-active-function 'identity)) |
(let ((nnml-generate-active-function 'identity)) |
709 |
(nnml-generate-nov-databases-1 dir))) |
(nnml-generate-nov-databases-1 dir)) |
710 |
|
(gnus-cache-open)) |
711 |
|
|
712 |
(defun gnus-cache-move-cache (dir) |
(defun gnus-cache-move-cache (dir) |
713 |
"Move the cache tree to somewhere else." |
"Move the cache tree to somewhere else." |
714 |
(interactive "FMove the cache tree to: ") |
(interactive "FMove the cache tree to: ") |
715 |
(rename-file gnus-cache-directory dir)) |
(rename-file gnus-cache-directory dir)) |
716 |
|
|
717 |
|
(defun gnus-cache-fully-p (&optional group) |
718 |
|
"Returns non-nil if the cache should be fully used. |
719 |
|
If GROUP is non-nil, also cater to `gnus-cacheable-groups' and |
720 |
|
`gnus-uncacheable-groups'." |
721 |
|
(and gnus-use-cache |
722 |
|
(not (eq gnus-use-cache 'passive)) |
723 |
|
(if (null group) |
724 |
|
t |
725 |
|
(and (or (not gnus-cacheable-groups) |
726 |
|
(string-match gnus-cacheable-groups group)) |
727 |
|
(or (not gnus-uncacheable-groups) |
728 |
|
(not (string-match gnus-uncacheable-groups group))))))) |
729 |
|
|
730 |
(provide 'gnus-cache) |
(provide 'gnus-cache) |
731 |
|
|
732 |
;;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a |
;;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a |