From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 19 Dec 1996 04:48:35 +0000 (+0000)
Subject: Reimplement code to purge pre-read headers and bodies.  New code calls
X-Git-Tag: 20090517-FFI~5296
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=eb898345aa6f7653b9c9aab9d9aad0a4927efea7;p=mit-scheme.git

Reimplement code to purge pre-read headers and bodies.  New code calls
predicate with a header instead of with a message number, deletes
message-id entries properly, and eliminates any body without a
corresponding header.
---

diff --git a/v7/src/edwin/nntp.scm b/v7/src/edwin/nntp.scm
index f339c8444..fb582bc94 100644
--- a/v7/src/edwin/nntp.scm
+++ b/v7/src/edwin/nntp.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: nntp.scm,v 1.12 1996/10/28 00:13:58 cph Exp $
+;;;	$Id: nntp.scm,v 1.13 1996/12/19 04:48:35 cph Exp $
 ;;;
 ;;;	Copyright (c) 1995-96 Massachusetts Institute of Technology
 ;;;
@@ -837,46 +837,48 @@
 	    (set-news-group:%body-gdbf! group #f)
 	    (delete-file-no-errors (news-group:header-gdbf-pathname group))
 	    (delete-file-no-errors (news-group:body-gdbf-pathname group)))
-	  (let ((purge
-		 (lambda (gdbf body?)
-		   (let ((keys
-			  (let loop ((key (gdbm-firstkey gdbf)) (keys '()))
-			    (if (not key)
-				keys
-				(loop (gdbm-nextkey gdbf key)
-				      (if (predicate
-					   (or (string->number key)
-					       (string->number
-						(gdbm-fetch gdbf key)))
-					   body?)
-					  (cons key keys)
-					  keys))))))
-		     (if (not (null? keys))
-			 (begin
-			   (with-gdbf-fast gdbf
-			     (lambda ()
-			       (for-each (lambda (key) (gdbm-delete gdbf key))
-					 keys)))
-			   (gdbm-reorganize gdbf))))
-		   (gdbm-close gdbf))))
-	    (let ((gdbf (news-group:header-gdbf group #f)))
-	      (if gdbf (purge gdbf #f))
-	      (set-news-group:%header-gdbf! group #f))
-	    (let ((gdbf (news-group:body-gdbf group #f)))
-	      (if gdbf (purge gdbf #t))
-	      (set-news-group:%body-gdbf! group #f))))))
-
-(define (with-gdbf-fast gdbf thunk)
-  #|
-  (dynamic-wind (lambda ()
-		  (gdbm-setopt gdbf gdbm_fastmode 1))
-		thunk
-		(lambda ()
-		  (gdbm-sync gdbf)
-		  (gdbm-setopt gdbf gdbm_fastmode 0)))
-  |#
-  gdbf
-  (thunk))
+	  (purge-pre-read-headers-1 group predicate))))
+
+(define (purge-pre-read-headers-1 group predicate)
+  (let ((header-gdbf (news-group:header-gdbf group #f))
+	(body-gdbf (news-group:body-gdbf group #f)))
+    (cond (header-gdbf
+	   ;; Purge all headers satisfying PREDICATE.
+	   (gdbm-purge header-gdbf
+	     (lambda (key)
+	       (and (string->number key)
+		    (let ((header (parse-header group (get-header group key))))
+		      (or (not (news-header? header))
+			  (predicate header))))))
+	   ;; Purge all orphaned message-id entries.
+	   (gdbm-purge header-gdbf
+	     (lambda (key)
+	       (and (not (string->number key))
+		    (not (gdbm-fetch header-gdbf
+				     (gdbm-fetch header-gdbf key))))))
+	   (gdbm-reorganize header-gdbf)
+	   (if body-gdbf
+	       (begin
+		 ;; Purge all orphaned bodies.
+		 (gdbm-purge body-gdbf
+		   (lambda (key)
+		     (not (gdbm-fetch header-gdbf key))))
+		 (gdbm-reorganize body-gdbf)
+		 (gdbm-close body-gdbf)
+		 (set-news-group:%body-gdbf! group #f)))
+	   (gdbm-close header-gdbf)
+	   (set-news-group:%header-gdbf! group #f))
+	  (body-gdbf
+	   (gdbm-close body-gdbf)
+	   (set-news-group:%body-gdbf! group #f)
+	   (delete-file-no-errors (news-group:body-gdbf-pathname group))))))
+
+(define (gdbm-purge gdbf predicate)
+  (let loop ((key (gdbm-firstkey gdbf)) (keys '()))
+    (if (not key)
+	(for-each (lambda (key) (gdbm-delete gdbf key)) keys)
+	(loop (gdbm-nextkey gdbf key)
+	      (if (predicate key) (cons key keys) keys)))))
 
 ;;;; Read Headers