From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 29 Dec 1998 04:09:50 +0000 (+0000)
Subject: Implement variable news-group-cache-policy to control disk cacheing of
X-Git-Tag: 20090517-FFI~4705
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=acfd5506439eb7c3a561f17b27f42c7d8b1de8ac;p=mit-scheme.git
Implement variable news-group-cache-policy to control disk cacheing of
news-group information.
---
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 72fd00d78..4e8b7f017 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: edwin.pkg,v 1.228 1998/12/29 04:08:17 cph Exp $
+$Id: edwin.pkg,v 1.229 1998/12/29 04:09:50 cph Exp $
Copyright (c) 1989-98 Massachusetts Institute of Technology
@@ -1741,13 +1741,13 @@ MIT in each case. |#
edwin-variable$news-automatically-collapse-threads
edwin-variable$news-common-mode-hook
edwin-variable$news-group-author-columns
+ edwin-variable$news-group-cache-policy
edwin-variable$news-group-ignore-hidden-subjects
edwin-variable$news-group-ignored-subject-retention
edwin-variable$news-group-keep-ignored-headers
edwin-variable$news-group-keep-seen-headers
edwin-variable$news-group-mode-hook
edwin-variable$news-group-show-author-name
- edwin-variable$news-group-show-cache-policy
edwin-variable$news-group-show-context-headers
edwin-variable$news-group-show-seen-headers
edwin-variable$news-hide-groups
diff --git a/v7/src/edwin/snr.scm b/v7/src/edwin/snr.scm
index 8dd6c82cd..97526c37b 100644
--- a/v7/src/edwin/snr.scm
+++ b/v7/src/edwin/snr.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: snr.scm,v 1.46 1998/12/29 02:35:22 cph Exp $
+;;; $Id: snr.scm,v 1.47 1998/12/29 04:08:26 cph Exp $
;;;
;;; Copyright (c) 1995-98 Massachusetts Institute of Technology
;;;
@@ -223,7 +223,7 @@ If true, all headers are kept.
Otherwise (the default), ignored headers aren't kept."
#f
boolean?)
-
+
(define-variable news-group-show-seen-headers
"Switch controlling whether already-seen headers are shown.
If true, group buffers show all headers.
@@ -243,6 +243,32 @@ If false, only the unread headers are fetched from the
server, and no additional context is available."
#t
boolean?)
+
+(define-variable news-group-cache-policy
+ "Controls how cacheing is used.
+The value of this variable is a list.
+The first element of the list describes the groups that are cached:
+ SUBSCRIBED only subscribed groups are cached
+ ALL all groups are cached
+ [list of group names] only named groups are cached
+The second element of the list is a list containing zero or more of
+the following symbols:
+ HEADERS headers are cached
+ BODIES bodies are cached
+The default value of this variable is (SUBSCRIBED (HEADERS BODIES))."
+ '(SUBSCRIBED (HEADERS BODIES))
+ (lambda (object)
+ (and (pair? object)
+ (or (eq? 'SUBSCRIBED (car object))
+ (eq? 'ALL (car object))
+ (list-of-strings? (car object)))
+ (pair? (cdr object))
+ (and (list? (cadr object))
+ (for-all? (cadr object)
+ (lambda (element)
+ (or (eq? 'HEADERS element)
+ (eq? 'BODIES element)))))
+ (null? (cddr object)))))
(define-command rnews
"Start a News reader.
@@ -842,7 +868,10 @@ Prompts for the News-group name, with completion."
(let ((group-names
(lambda () (nntp-connection:active-groups connection #f)))
(string->group
- (lambda (string) (find-active-news-group connection string))))
+ (lambda (string)
+ (let ((group (find-active-news-group connection string)))
+ (if group (news-group:apply-cache-policy group))
+ group))))
(string->group
(let ((convert
(lambda (vector) (map news-group:name (vector->list vector)))))
@@ -3999,7 +4028,18 @@ With prefix arg, replaces the file with the list information."
(set-news-group:ranges-marked! group (canonicalize-ranges ranges-marked))
(set-news-group:ranges-browsed! group (canonicalize-ranges ranges-browsed))
(news-group:clip-ranges! group)
+ (news-group:apply-cache-policy group)
group))
+
+(define (news-group:apply-cache-policy group)
+ (set-news-group:use-gdbm!
+ group
+ (let ((nggp (ref-variable news-group-cache-policy)))
+ (if (cond ((eq? 'ALL (car nggp)) #t)
+ ((eq? 'SUBSCRIBED (car nggp)) (news-group:subscribed? group))
+ (else (member (news-group:name group) (car nggp))))
+ (cadr nggp)
+ '()))))
(define (news-group:get-threads group argument buffer)
(let ((headers (news-group:get-headers group argument buffer))