From 873449c33f41f1bc3e82b650d1e8417fcd20f758 Mon Sep 17 00:00:00 2001
From: Stelian Ionescu <sionescu@common-lisp.net>
Date: Sat, 6 Dec 2008 15:23:40 +0100
Subject: [PATCH] Check stream writing for EPIPE and signal a HANGUP if so.

---
 io.streams.asd                           |  3 ++-
 io.streams/gray/conditions.lisp          | 13 +++++++++++++
 io.streams/gray/gray-stream-methods.lisp | 33 ++++++++++++++++++++++++--------
 io.streams/gray/pkgdcl.lisp              |  3 +++
 4 files changed, 43 insertions(+), 9 deletions(-)
 create mode 100644 io.streams/gray/conditions.lisp

diff --git a/io.streams.asd b/io.streams.asd
index 8ee5829..26e3458 100644
--- a/io.streams.asd
+++ b/io.streams.asd
@@ -11,7 +11,8 @@
   :components
   ((:file "pkgdcl")
    (:file "classes" :depends-on ("pkgdcl"))
+   (:file "conditions" :depends-on ("pkgdcl"))
    (:file "buffer" :depends-on ("pkgdcl" "classes"))
    (:file "fd-mixin" :depends-on ("pkgdcl" "classes"))
    (:file "gray-stream-methods"
-          :depends-on ("pkgdcl" "classes" "buffer" "fd-mixin"))))
+          :depends-on ("pkgdcl" "classes" "conditions" "buffer" "fd-mixin"))))
diff --git a/io.streams/gray/conditions.lisp b/io.streams/gray/conditions.lisp
new file mode 100644
index 0000000..0716f52
--- /dev/null
+++ b/io.streams/gray/conditions.lisp
@@ -0,0 +1,13 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
+;;;
+;;; --- Gray stream conditions.
+;;;
+
+(in-package :io.streams)
+
+(define-condition hangup (stream-error) ()
+  (:report (lambda (c s)
+             (format s "Stream ~S hang up."
+                     (stream-error-stream c))))
+  (:documentation "Condition signaled when the underlying device of a stream
+is closed by the remote end while writing to it."))
diff --git a/io.streams/gray/gray-stream-methods.lisp b/io.streams/gray/gray-stream-methods.lisp
index b35b8eb..aaf7b90 100644
--- a/io.streams/gray/gray-stream-methods.lisp
+++ b/io.streams/gray/gray-stream-methods.lisp
@@ -1,6 +1,6 @@
 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
 ;;;
-;;; --- Implementation using gray streams.
+;;; --- Implementation using Gray streams.
 ;;;
 
 (in-package :io.streams)
@@ -186,8 +186,19 @@
                    (dirtyp dirtyp))
       stream
     (when (or dirtyp (iobuf-full-p ob))
-      (%write-octets-from-iobuf write-fn fd ob)
-      (setf dirtyp nil))))
+      (multiple-value-bind (bytes-written hangup-p)
+          (%write-octets-from-iobuf write-fn fd ob)
+        (setf dirtyp nil)
+        (return* (values bytes-written hangup-p))))
+    (values 0)))
+
+(defmacro with-hangup-guard (stream &body body)
+  (with-gensyms (bytes-written hangup-p)
+    `(multiple-value-bind (,bytes-written ,hangup-p)
+         (progn ,@body)
+       (declare (ignore ,bytes-written))
+       (when (eq :hangup ,hangup-p)
+         (error 'hangup :stream ,stream)))))
 
 (defmethod stream-clear-output ((stream dual-channel-gray-stream))
   (with-accessors ((ob output-buffer-of)
@@ -203,7 +214,8 @@
                    (ob output-buffer-of)
                    (dirtyp dirtyp))
       stream
-    (%write-octets-from-iobuf write-fn fd ob)
+    (with-hangup-guard stream
+      (%write-octets-from-iobuf write-fn fd ob))
     (setf dirtyp nil)))
 
 (defmethod stream-force-output ((stream dual-channel-gray-stream))
@@ -220,11 +232,15 @@
              (iobuf-copy-from-lisp-array array start ob
                                          (iobuf-end ob) octets-needed)
              (incf (iobuf-end ob) octets-needed)
-             (flush-obuf-if-needed stream))
+             (with-hangup-guard stream
+               (flush-obuf-if-needed stream)))
             (t
              (with-pointer-to-vector-data (ptr array)
-               (%write-octets-from-iobuf write-fn fd ob)
-               (%write-octets-from-foreign-memory write-fn fd (inc-pointer ptr start) octets-needed))))
+               (with-hangup-guard stream
+                 (%write-octets-from-iobuf write-fn fd ob))
+               (with-hangup-guard stream
+                 (%write-octets-from-foreign-memory
+                  write-fn fd (inc-pointer ptr start) octets-needed)))))
       (values array))))
 
 (defun %write-vector-ub8 (stream vector start end)
@@ -497,7 +513,8 @@
   (check-type integer ub8 "an unsigned 8-bit value")
   (with-accessors ((ob output-buffer-of))
       stream
-    (flush-obuf-if-needed stream)
+    (with-hangup-guard stream
+      (flush-obuf-if-needed stream))
     (iobuf-push-octet ob integer)))
 
 ;;;; Buffer-related stuff
diff --git a/io.streams/gray/pkgdcl.lisp b/io.streams/gray/pkgdcl.lisp
index c238dc5..99c8f1a 100644
--- a/io.streams/gray/pkgdcl.lisp
+++ b/io.streams/gray/pkgdcl.lisp
@@ -14,6 +14,9 @@
    #:dual-channel-single-fd-mixin
    #:dual-channel-single-fd-gray-stream
 
+   ;; Conditions
+   #:hangup
+
    ;; Types
    #:sb16
    #:sb32
-- 
2.11.4.GIT