From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 12 Jun 2001 00:47:39 +0000 (+0000)
Subject: Change OPEN-RESOURCE and CLOSE-RESOURCE so that all of their behavior
X-Git-Tag: 20090517-FFI~2714
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9a8d8742f0b27cd4426d4892656542efea682f1d;p=mit-scheme.git

Change OPEN-RESOURCE and CLOSE-RESOURCE so that all of their behavior
is pushed down into the type-dependent modules.  (Previously, they had
some type-independent code.)  This, plus one explicit call, now means
that the STATUS modification event is now consistently signalled
whenever the connection status changes.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index b8b80b457..3a7ab3d6b 100644
--- a/v7/src/imail/imail-core.scm
+++ b/v7/src/imail/imail-core.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-core.scm,v 1.143 2001/06/04 17:38:50 cph Exp $
+;;; $Id: imail-core.scm,v 1.144 2001/06/12 00:47:19 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -420,6 +420,10 @@
   (if (not (container? container))
       (error:wrong-type-argument container "IMAIL container" procedure)))
 
+(define (maybe-make-resource url constructor)
+  (or (get-memoized-resource url)
+      (memoize-resource (constructor url))))
+
 (define (get-memoized-resource url #!optional error?)
   (or (let ((resource (hash-table/get memoized-resources url #f)))
 	(and resource
@@ -435,10 +439,12 @@
       (and (if (default-object? error?) #f error?)
 	   (error "URL has no associated resource:" url))))
 
-(define (memoize-resource resource close)
+(define (memoize-resource resource)
   (hash-table/put! memoized-resources
 		   (resource-locator resource)
-		   (weak-cons resource close))
+		   (weak-cons resource
+			      (lambda (resource)
+				(close-resource resource #t))))
   resource)
 
 (define (unmemoize-resource url)
@@ -463,12 +469,7 @@
 ;; -------------------------------------------------------------------
 ;; Open the resource named URL.
 
-(define (open-resource url)
-  (or (get-memoized-resource url)
-      (memoize-resource (%open-resource url)
-			(lambda (resource) (close-resource resource #t)))))
-
-(define-generic %open-resource (url))
+(define-generic open-resource (url))
 
 (define (with-open-resource url procedure)
   (let ((resource #f))
@@ -489,11 +490,7 @@
 ;; space penalty.  NO-DEFER? means that the resource must be closed
 ;; immediately, and not deferred.
 
-(define (close-resource resource no-defer?)
-  (save-resource resource)
-  (%close-resource resource no-defer?))
-
-(define-generic %close-resource (resource no-defer?))
+(define-generic close-resource (resource no-defer?))
 
 ;; -------------------------------------------------------------------
 ;; Return the number of messages in FOLDER.
diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 923b5e35d..ea87b8c15 100644
--- a/v7/src/imail/imail-file.scm
+++ b/v7/src/imail/imail-file.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-file.scm,v 1.77 2001/06/03 01:42:31 cph Exp $
+;;; $Id: imail-file.scm,v 1.78 2001/06/12 00:47:24 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -289,8 +289,9 @@
 (define (file-folder-pathname folder)
   (pathname-url-pathname (resource-locator folder)))
 
-(define-method %close-resource ((folder <file-folder>) no-defer?)
+(define-method close-resource ((folder <file-folder>) no-defer?)
   no-defer?
+  (save-resource folder)
   (discard-file-folder-messages folder)
   (discard-file-folder-xstring folder))
 
@@ -489,10 +490,10 @@
 
 (define-class (<file-container> (constructor (locator))) (<container>))
 
-(define-method %open-resource ((url <directory-url>))
-  (make-file-container url))
+(define-method open-resource ((url <directory-url>))
+  (maybe-make-resource url make-file-container))
 
-(define-method %close-resource ((container <file-container>) no-defer?)
+(define-method close-resource ((container <file-container>) no-defer?)
   container no-defer?
   unspecific)
 
diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index a850234bc..257147e83 100644
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.179 2001/06/03 06:00:18 cph Exp $
+;;; $Id: imail-imap.scm,v 1.180 2001/06/12 00:47:32 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -749,7 +749,7 @@
 
 ;;;; Folder and container datatypes
 
-(define-class (<imap-folder> (constructor (locator))) (<folder>)
+(define-class <imap-folder> (<folder>)
   (connection define standard
 	      initial-value #f)
   (read-only? define standard)
@@ -770,6 +770,13 @@
   (connection define standard
 	      initial-value #f))
 
+(define make-imap-folder
+  (let ((constructor (instance-constructor <imap-folder> '(LOCATOR))))
+    (lambda (url)
+      (let ((folder (constructor url)))
+	(reset-imap-folder! folder)
+	folder))))
+
 (define (reset-imap-folder! folder)
   (without-interrupts
    (lambda ()
@@ -1126,7 +1133,6 @@
 				  '(BODYSTRUCTURE)))))
 
 (define-method preload-folder-outlines ((folder <imap-folder>))
-  
   (let* ((connection (guarantee-imap-folder-open folder))
 	 (messages
 	  (messages-satisfying folder
@@ -1481,13 +1487,12 @@
 
 ;;;; Folder operations
 
-(define-method %open-resource ((url <imap-folder-url>))
-  (let ((folder (make-imap-folder url)))
-    (reset-imap-folder! folder)
+(define-method open-resource ((url <imap-folder-url>))
+  (let ((folder (maybe-make-resource url make-imap-folder)))
     (guarantee-imap-folder-open folder)
     folder))
 
-(define-method %close-resource ((folder <imap-folder>) no-defer?)
+(define-method close-resource ((folder <imap-folder>) no-defer?)
   (close-imap-folder folder no-defer?))
 
 (define (close-imap-folder folder no-defer?)
@@ -1559,18 +1564,20 @@
 
 ;;;; Container operations
 
-(define-method %open-resource ((url <imap-container-url>))
-  (let ((container (make-imap-container url)))
+(define-method open-resource ((url <imap-container-url>))
+  (let ((container (maybe-make-resource url make-imap-container)))
     (guarantee-imap-connection-open
      (without-interrupts
       (lambda ()
-	(let ((connection (get-compatible-imap-connection url)))
-	  (set-imap-container-connection! container connection)
-	  (increment-connection-reference-count! connection)
-	  connection))))
+	(or (imap-container-connection container)
+	    (let ((connection (get-compatible-imap-connection url)))
+	      (set-imap-container-connection! container connection)
+	      (increment-connection-reference-count! connection)
+	      connection)))))
+    (object-modified! container 'STATUS)
     container))
 
-(define-method %close-resource ((container <imap-container>) no-defer?)
+(define-method close-resource ((container <imap-container>) no-defer?)
   (let ((connection
 	 (without-interrupts
 	  (lambda ()
diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index e81cffb50..52099ede8 100644
--- a/v7/src/imail/imail-rmail.scm
+++ b/v7/src/imail/imail-rmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-rmail.scm,v 1.67 2001/05/24 01:13:57 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.68 2001/06/12 00:47:36 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -38,11 +38,6 @@
 
 ;;;; Server operations
 
-(define-method %open-resource ((url <rmail-url>))
-  (if (not (file-readable? (pathname-url-pathname url)))
-      (error:bad-range-argument url 'OPEN-RESOURCE))
-  (make-rmail-folder url))
-
 (define-method %create-resource ((url <rmail-url>))
   (if (file-exists? (pathname-url-pathname url))
       (error:bad-range-argument url 'CREATE-RESOURCE))
@@ -78,6 +73,13 @@
 	(make-header-field "Note" "If you are seeing it in rmail,")
 	(make-header-field "Note" "it means the file has no messages in it.")))
 
+(define-method open-resource ((url <rmail-url>))
+  (if (file-readable? (pathname-url-pathname url))
+      (maybe-make-resource url make-rmail-folder)
+      (begin
+	(unmemoize-resource url)
+	(error:bad-range-argument url 'OPEN-RESOURCE))))
+
 ;;;; Message
 
 (define-class (<rmail-message>
diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index edb0941db..23f5496d2 100644
--- a/v7/src/imail/imail-umail.scm
+++ b/v7/src/imail/imail-umail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-umail.scm,v 1.48 2001/05/24 01:14:10 cph Exp $
+;;; $Id: imail-umail.scm,v 1.49 2001/06/12 00:47:39 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -35,11 +35,6 @@
 
 ;;;; Server operations
 
-(define-method %open-resource ((url <umail-url>))
-  (if (not (file-readable? (pathname-url-pathname url)))
-      (error:bad-range-argument url 'OPEN-RESOURCE))
-  (make-umail-folder url))
-
 (define-method %create-resource ((url <umail-url>))
   (if (file-exists? (pathname-url-pathname url))
       (error:bad-range-argument url 'CREATE-RESOURCE))
@@ -55,6 +50,13 @@
 
 (define-class (<umail-folder> (constructor (locator))) (<file-folder>))
 
+(define-method open-resource ((url <umail-url>))
+  (if (file-readable? (pathname-url-pathname url))
+      (maybe-make-resource url make-umail-folder)
+      (begin
+	(unmemoize-resource url)
+	(error:bad-range-argument url 'OPEN-RESOURCE))))
+
 ;;;; Message
 
 (define-class (<umail-message>