From 9a8d8742f0b27cd4426d4892656542efea682f1d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 12 Jun 2001 00:47:39 +0000 Subject: [PATCH] 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. --- v7/src/imail/imail-core.scm | 25 +++++++++++-------------- v7/src/imail/imail-file.scm | 11 ++++++----- v7/src/imail/imail-imap.scm | 35 +++++++++++++++++++++-------------- v7/src/imail/imail-rmail.scm | 14 ++++++++------ v7/src/imail/imail-umail.scm | 14 ++++++++------ 5 files changed, 54 insertions(+), 45 deletions(-) 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 ) no-defer?) +(define-method close-resource ((folder ) no-defer?) no-defer? + (save-resource folder) (discard-file-folder-messages folder) (discard-file-folder-xstring folder)) @@ -489,10 +490,10 @@ (define-class ( (constructor (locator))) ()) -(define-method %open-resource ((url )) - (make-file-container url)) +(define-method open-resource ((url )) + (maybe-make-resource url make-file-container)) -(define-method %close-resource ((container ) no-defer?) +(define-method close-resource ((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 ( (constructor (locator))) () +(define-class () (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 '(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 )) - (let* ((connection (guarantee-imap-folder-open folder)) (messages (messages-satisfying folder @@ -1481,13 +1487,12 @@ ;;;; Folder operations -(define-method %open-resource ((url )) - (let ((folder (make-imap-folder url))) - (reset-imap-folder! folder) +(define-method open-resource ((url )) + (let ((folder (maybe-make-resource url make-imap-folder))) (guarantee-imap-folder-open folder) folder)) -(define-method %close-resource ((folder ) no-defer?) +(define-method close-resource ((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 )) - (let ((container (make-imap-container url))) +(define-method open-resource ((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 ) no-defer?) +(define-method close-resource ((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 )) - (if (not (file-readable? (pathname-url-pathname url))) - (error:bad-range-argument url 'OPEN-RESOURCE)) - (make-rmail-folder url)) - (define-method %create-resource ((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 )) + (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 ( 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 )) - (if (not (file-readable? (pathname-url-pathname url))) - (error:bad-range-argument url 'OPEN-RESOURCE)) - (make-umail-folder url)) - (define-method %create-resource ((url )) (if (file-exists? (pathname-url-pathname url)) (error:bad-range-argument url 'CREATE-RESOURCE)) @@ -55,6 +50,13 @@ (define-class ( (constructor (locator))) ()) +(define-method open-resource ((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 ( -- 2.25.1