From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 23 May 2000 18:36:39 +0000 (+0000)
Subject: Implement WITH-OPEN-CONNECTION for use by M-x imail-copy-messages.
X-Git-Tag: 20090517-FFI~3703
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9d21efc45d03ab422d09a8d775022b0977f54026;p=mit-scheme.git

Implement WITH-OPEN-CONNECTION for use by M-x imail-copy-messages.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index afdd37eb1..0c416db51 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.88 2000/05/23 02:57:13 cph Exp $
+;;; $Id: imail-core.scm,v 1.89 2000/05/23 18:36:36 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -238,6 +238,12 @@
 ;; URL-PATTERN can contain wildcards.
 
 (define-generic available-folder-names (url-pattern))
+
+;; -------------------------------------------------------------------
+;; Keep a connection open to the server referenced by URL for the
+;; dynamic extent of THUNK.
+
+(define-generic with-open-connection (url thunk))
 
 ;;;; Folder type
 
@@ -303,15 +309,6 @@
 
 (define-generic %open-folder (url))
 
-(define (with-open-folder url thunk)
-  (let ((folder (get-memoized-folder url)))
-    (if folder
-	(thunk)
-	(let ((folder (%open-folder url)))
-	  (let ((v (thunk)))
-	    (close-folder folder)
-	    v)))))
-
 ;; -------------------------------------------------------------------
 ;; Close FOLDER, freeing up connections, memory, etc.  Subsequent use
 ;; of the folder must work, but may incur a significant time or space
diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index fef77ec39..4a2e472ae 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.38 2000/05/23 02:57:18 cph Exp $
+;;; $Id: imail-file.scm,v 1.39 2000/05/23 18:36:37 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -80,6 +80,10 @@
 (define-method available-folder-names ((url <file-url>))
   url
   (error "Unimplemented operation:" 'AVAILABLE-FOLDER-NAMES))
+
+(define-method with-open-connection ((url <file-url>) thunk)
+  url
+  (thunk))
 
 ;;;; Folder
 
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 02bb92ef1..c788646d5 100644
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.99 2000/05/23 05:32:20 cph Exp $
+;;; $Id: imail-top.scm,v 1.100 2000/05/23 18:36:39 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -1079,10 +1079,7 @@ This command is meant to be used to move the contents of a folder
   (lambda (url-string)
     (let ((folder (selected-folder))
 	  (to (imail-parse-partial-url url-string)))
-      ;; Kludge: by opening the folder, we prevent a condition where
-      ;; writing messages to an IMAP folder opens a new connection for
-      ;; each message.
-      (with-open-folder to
+      (with-open-connection to
 	(lambda ()
 	  (let ((n (folder-length folder)))
 	    (do ((i 0 (+ i 1)))