From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 20 May 2000 19:09:58 +0000 (+0000)
Subject: Split off broken-pipe detection code.  This has little effect now but
X-Git-Tag: 20090517-FFI~3772
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=75afc4d499b1eabca339e27090c0a8eb96ce67ff;p=mit-scheme.git

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 2a2d0bf5c..a076e6223 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.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)))))
 
 (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 15f99a68c..cb5ba56f9 100644
--- 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?))
 
+;;;; 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))
+
 ;;;; Ordered-string-vector completion
 
 (define (hash-table/ordered-key-vector table <)