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 afdd37eb13000627ae24be36d198fd1e9517baf2..0c416db51bb9a1f8212eb7377b2b196b280d6456 100644 (file)
--- 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))
 \f
 ;;;; 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 fef77ec393339ea1eaa408a665c5e5f1564430cd..4a2e472ae944842db1b61ffda37c35fd45278676 100644 (file)
--- 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))
 \f
 ;;;; Folder
 

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 02bb92ef19d53ca2078f0ec1129d7ec1f231764d..c788646d5afbfd2065897ab8d480510ec453d0d2 100644 (file)
--- 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)))