Split off broken-pipe detection code. This has little effect now but

will be useful later when I improve the error recovery.

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 2a2d0bf5c4d5a27d0651a8275182f5bb8b64c109..a076e62234507eb2fb6ac02b9dd565a70dbd77a6 100644 (file)
--- 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.61 2000/05/19 21:02:20 cph Exp $
+;;; $Id: imail-imap.scm,v 1.62 2000/05/20 19:09:49 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -866,26 +866,18 @@
        (error msg))))
 
 (define (imap:command connection command . arguments)
-  (bind-condition-handler (list condition-type:system-call-error)
-      (lambda (condition)
-       (if (and (memq (system-call-name condition) '(READ WRITE))
-                (eq? 'BROKEN-PIPE (system-call-error condition)))
-           (begin
-             (close-imap-connection connection)
-             (error "Connection to IMAP server broken; please try again."))))
-    (lambda ()
-      (imap:wait-for-tagged-response connection
-                                    (imap:send-command connection
-                                                       command arguments)
-                                    (if (eq? command 'UID)
-                                        (car arguments)
-                                        command)))))
-
-(define system-call-name
-  (condition-accessor condition-type:system-call-error 'SYSTEM-CALL))
-
-(define system-call-error
-  (condition-accessor condition-type:system-call-error 'ERROR-TYPE))
+  (handle-broken-pipe
+   (lambda (condition)
+     condition
+     (close-imap-connection connection)
+     (error "Connection to IMAP server broken; please try again."))
+   (lambda ()
+     (imap:wait-for-tagged-response
+      connection
+      (imap:send-command connection command arguments)
+      (if (eq? command 'UID)
+         (car arguments)
+         command)))))
 \f
 (define imail-trace? #f)
 (define imail-trace-output)

diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm
index 15f99a68cb5e823857c786fd5eb534242b96b4f0..cb5ba56f9a4354444e4a5c0f80a0ccf37421a4ed 100644 (file)
--- a/v7/src/imail/imail-util.scm
+++ b/v7/src/imail/imail-util.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-util.scm,v 1.19 2000/05/20 03:24:31 cph Exp $
+;;; $Id: imail-util.scm,v 1.20 2000/05/20 19:09:58 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -242,6 +242,35 @@
   (list-transform-negative (map string-trim (burst-string string #\, #f))
     string-null?))
 \f
+;;;; Broken-pipe handler
+
+(define (handle-broken-pipe handler thunk)
+  (bind-condition-handler (list condition-type:system-call-error
+                               condition-type:derived-port-error)
+      (lambda (condition)
+       (if (or (broken-pipe? condition)
+               (derived-broken-pipe? condition))
+           (handler condition)))
+    thunk))
+
+(define (broken-pipe? condition)
+  (and (eq? (condition/type condition) condition-type:system-call-error)
+       (eq? (system-call-name condition) 'WRITE)
+       (eq? (system-call-error condition) 'BROKEN-PIPE)))
+
+(define system-call-name
+  (condition-accessor condition-type:system-call-error 'SYSTEM-CALL))
+
+(define system-call-error
+  (condition-accessor condition-type:system-call-error 'ERROR-TYPE))
+
+(define (derived-broken-pipe? condition)
+  (and (eq? (condition/type condition) condition-type:derived-port-error)
+       (broken-pipe? (derived-condition condition))))
+
+(define derived-port-condition
+  (condition-accessor condition-type:derived-port-error 'CONDITION))
+\f
 ;;;; Ordered-string-vector completion
 
 (define (hash-table/ordered-key-vector table <)