cl-stream/unistd-stream

diff --git a/fd-gray.asd b/fd-gray.asd
deleted file mode 100644
index 34f278d..0000000
--- a/fd-gray.asd
+++ /dev/null
@@ -1,35 +0,0 @@
-;;
-;;  fd-gray  -  Unix file descriptor gray streams for Common Lisp
-;;
-;;  Copyright 2017 Thomas de Grivel <thoxdg@gmail.com>
-;;
-;;  Permission to use, copy, modify, and distribute this software for any
-;;  purpose with or without fee is hereby granted, provided that the above
-;;  copyright notice and this permission notice appear in all copies.
-;;
-;;  THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-;;  WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-;;  MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-;;  ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-;;  ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-;;  OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
-;;
-
-(in-package :common-lisp-user)
-
-(defpackage :fd-gray.system
-  (:use :common-lisp :asdf))
-
-(in-package :fd-gray.system)
-
-(defsystem :fd-gray
-  :name "fd-gray"
-  :author "Thomas de Grivel <thoxdg@gmail.com>"
-  :version "0.1"
-  :description "Unix file descriptor gray streams for Common Lisp"
-  :depends-on ("cffi-unistd"
-	       "trivial-gray-streams")
-  :components
-  ((:file "package")
-   (:file "fd-gray" :depends-on ("package"))))
diff --git a/fd-gray.lisp b/fd-gray.lisp
deleted file mode 100644
index 5594b98..0000000
--- a/fd-gray.lisp
+++ /dev/null
@@ -1,247 +0,0 @@
-;;
-;;  fd-gray  -  Unix file descriptor gray streams for Common Lisp
-;;
-;;  Copyright 2017 Thomas de Grivel <thoxdg@gmail.com>
-;;
-;;  Permission to use, copy, modify, and distribute this software for any
-;;  purpose with or without fee is hereby granted, provided that the above
-;;  copyright notice and this permission notice appear in all copies.
-;;
-;;  THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-;;  WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-;;  MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-;;  ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-;;  ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-;;  OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
-;;
-
-(in-package :fd-gray)
-
-(deftype octet ()
-  `(unsigned-byte 8))
-
-(deftype fixnum+ (&optional (start 0))
-  `(integer ,start ,most-positive-fixnum))
-
-(defclass stream (trivial-gray-stream-mixin)
-  ((fd :initarg :fd
-       :reader stream-fd
-       :type file-descriptor)))
-
-(define-condition stream-error (cl:stream-error)
-  ()
-  (:documentation "Superclass for all errors related to
-fd gray streams."))
-
-(define-condition stream-closed-error (stream-error)
-  ()
-  (:report (lambda (condition stream)
-             (format stream "~S is closed."
-                     (stream-error-stream condition))))
-  (:documentation "An error that is signalled when someone is trying
-to read from or write to a closed fd gray stream."))
-
-(defgeneric check-if-open (stream))
-
-(defmethod check-if-open ((stream stream))
-  "Checks if STREAM is open and signals an error otherwise."
-  (unless (open-stream-p stream)
-    (error 'stream-closed-error
-           :stream stream)))
-
-(defmethod stream-element-type ((stream stream))
-  'octet)
-
-(defvar *buffer-size* 65536)
-
-(defclass input-stream (stream fundamental-binary-input-stream)
-  ((input-buffer :initform (cffi:foreign-alloc :unsigned-char
-					       :count *buffer-size*)
-		 :accessor input-buffer)
-   (input-index :initform 0
-		:accessor input-index
-		:type fixnum+)
-   (input-length :initform 0
-		 :accessor input-length
-		 :type fixnum+)
-   (input-max :initform *buffer-size*
-	      :reader input-max
-	      :type fixnum+)))
-
-(define-condition stream-input-error (stream-error)
-  ()
-  (:report (lambda (condition stream)
-             (format stream "input error on ~S"
-                     (stream-error-stream condition))))
-  (:documentation "An error that is signalled when an input error happens
-on a fd gray stream."))
-
-(defgeneric stream-input (stream))
-
-(defmethod stream-input ((stream input-stream))
-  "Fill buffer with file data.
-Tries to read once from input-length to input-max (end of buffer)."
-  (let* ((buffer (input-buffer stream))
-	 (length (input-length stream))
-	 (r (unistd:read (stream-fd stream)
-			 (cffi:mem-aptr buffer :unsigned-char length)
-			 (- (input-max stream) length))))
-    (cond ((= r 0)
-	   :eof)
-	  ((< r 0)
-	   (error 'stream-input-error :stream stream))
-	  (t
-	   (incf (input-length stream) r)
-	   r))))
-
-(defmethod stream-read-byte ((stream input-stream))
-  (check-if-open stream)
-  (let ((buffer (input-buffer stream)))
-    (with-accessors ((input-index input-index)) stream
-      (when (= input-index (input-length stream))
-	(setf input-index 0
-	      (input-length stream) 0)
-	(when (eq :eof (stream-input stream))
-	  (return-from stream-read-byte :eof)))
-      (let ((b (cffi:mem-aref buffer :unsigned-char input-index)))
-	(incf input-index)
-	b))))
-
-(defmethod stream-read-sequence ((stream input-stream)
-				 seq start end &key &allow-other-keys)
-  (check-if-open stream)
-  (let ((buffer (input-buffer stream)))
-    (with-accessors ((input-index input-index)) stream
-      (loop
-	 (unless (< start end)
-	   (return))
-	 (let ((e (min (- end start)
-		       (- (input-length stream) input-index))))
-	   (dotimes (i e)
-	     (setf (aref seq start)
-		   (cffi:mem-aref buffer :unsigned-char input-index))
-	     (incf start)
-	     (incf input-index))
-	   (when (= input-index (input-length stream))
-	     (setf input-index 0
-		   (input-length buffer) 0)
-	     (stream-input stream)))))))
-
-(defmethod close ((stream input-stream) &key abort)
-  (declare (ignore abort))
-  (cffi:foreign-free (input-buffer stream))
-  (setf (input-buffer stream) nil)
-  (unistd:close (stream-fd stream)))
-
-(defun input-stream (fd)
-  (make-instance 'input-stream :fd fd))
-
-(defmacro with-input-stream ((var fd) &body body)
-  (let ((stream (gensym "STREAM-")))
-    `(let ((,stream (input-stream ,fd)))
-       (unwind-protect (let ((,var ,stream))
-			 ,@body)
-	 (close ,stream)))))
-
-(defclass output-stream (stream fundamental-binary-output-stream)
-  ((output-buffer :initform (cffi:foreign-alloc :unsigned-char
-						:count *buffer-size*)
-		  :accessor output-buffer)
-   (output-index :initform 0
-		 :accessor output-index
-		 :type fixnum+)
-   (output-length :initform 0
-		  :accessor output-length
-		  :type fixnum+)
-   (output-max :initform *buffer-size*
-	       :reader output-max
-	       :type fixnum+)))
-
-(defgeneric stream-output (stream))
-
-(defmethod stream-output ((stream output-stream))
-  "Send buffer data to the file.
-Calls write with data ranging from output-index to output-length."
-  (let ((buffer (output-buffer stream)))
-    (with-accessors ((output-index output-index)) stream
-      (loop
-	 (when (= output-index (output-length buffer))
-	   (setf output-index 0
-		 (output-length buffer) 0)
-	   (return))
-	 (let ((r (unistd:write (stream-fd stream)
-				(cffi:mem-aptr buffer :unsigned-char output-index)
-				(- (output-length stream) output-index))))
-	   (incf output-index r))))))
-
-(defmethod stream-force-output ((stream output-stream))
-  (stream-output stream))
-
-(defmethod stream-finish-output ((stream output-stream))
-  (stream-output stream))
-
-(defmethod stream-write-byte ((stream output-stream) byte)
-  (check-if-open stream)
-  (let ((buffer (output-buffer stream)))
-    (when (= (output-length stream) (output-max stream))
-      (stream-finish-output stream))
-    (setf (cffi:mem-aref buffer :unsigned-char (input-length stream)) byte)
-    (incf (input-length stream)))
-  byte)
-
-(defmethod stream-write-sequence ((stream output-stream)
-				  seq start end &key &allow-other-keys)
-  (check-if-open stream)
-  (let ((buffer (output-buffer stream)))
-    (loop
-       (unless (< start end)
-	 (return))
-       (let ((e (min (- end start)
-		     (- (output-max stream) (output-length stream)))))
-	 (dotimes (i e)
-	   (setf (cffi:mem-aref buffer :unsigned-char (output-length stream))
-		 (aref seq start))
-	   (incf (output-length stream))
-	   (incf start))
-	 (when (= (output-length stream) (output-max stream))
-	   (stream-finish-output stream))))))
-
-(defmethod close ((stream output-stream) &key abort)
-  (declare (ignore abort))
-  (stream-finish-output stream)
-  (cffi:foreign-free (output-buffer stream))
-  (setf (output-buffer stream) nil)
-  (unistd:close (stream-fd stream)))
-
-(defun output-stream (fd)
-  (make-instance 'output-stream :fd fd))
-
-(defmacro with-output-stream ((var fd) &body body)
-  (let ((stream (gensym "STREAM-")))
-    `(let ((,stream (output-stream ,fd)))
-       (unwind-protect (let ((,var ,stream))
-			 ,@body)
-	 (close ,stream)))))
-
-(defclass io-stream (input-stream output-stream)
-  ())
-
-(defmethod close ((stream io-stream) &key abort)
-  (declare (ignore abort))
-  (stream-finish-output stream)
-  (cffi:foreign-free (input-buffer stream))
-  (setf (input-buffer stream) nil)
-  (cffi:foreign-free (output-buffer stream))
-  (setf (output-buffer stream) nil)
-  (unistd:close (stream-fd stream)))
-
-(defun io-stream (fd)
-  (make-instance 'io-stream :fd fd))
-
-(defmacro with-io-stream ((var fd) &body body)
-  (let ((stream (gensym "STREAM-")))
-    `(let ((,stream (io-stream ,fd)))
-       (unwind-protect (let ((,var ,stream))
-			 ,@body)
-	 (close ,stream)))))
diff --git a/fd-stream.asd b/fd-stream.asd
new file mode 100644
index 0000000..a9bba6d
--- /dev/null
+++ b/fd-stream.asd
@@ -0,0 +1,36 @@
+;;
+;;  fd-stream  -  Unix file descriptors layer for cl-stream
+;;
+;;  Copyright 2017 Thomas de Grivel <thoxdg@gmail.com>
+;;
+;;  Permission to use, copy, modify, and distribute this software for any
+;;  purpose with or without fee is hereby granted, provided that the above
+;;  copyright notice and this permission notice appear in all copies.
+;;
+;;  THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+;;  WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+;;  MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+;;  ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+;;  ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+;;  OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(in-package :common-lisp-user)
+
+(defpackage :fd-stream.system
+  (:use :common-lisp :asdf))
+
+(in-package :fd-stream.system)
+
+(defsystem :fd-stream
+  :name "fd-stream"
+  :author "Thomas de Grivel <thoxdg@gmail.com>"
+  :version "0.1"
+  :description "Unix file descriptor stream streams for Common Lisp"
+  :depends-on ("cffi-fcntl"
+	       "cffi-unistd"
+	       "cl-stream")
+  :components
+  ((:file "package")
+   (:file "fd-stream" :depends-on ("package"))))
diff --git a/fd-stream.lisp b/fd-stream.lisp
new file mode 100644
index 0000000..81283ed
--- /dev/null
+++ b/fd-stream.lisp
@@ -0,0 +1,141 @@
+;;
+;;  fd-stream  -  Unix file descriptors layer for cl-stream
+;;
+;;  Copyright 2017 Thomas de Grivel <thoxdg@gmail.com>
+;;
+;;  Permission to use, copy, modify, and distribute this software for any
+;;  purpose with or without fee is hereby granted, provided that the above
+;;  copyright notice and this permission notice appear in all copies.
+;;
+;;  THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+;;  WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+;;  MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+;;  ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+;;  ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+;;  OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(in-package :fd-stream)
+
+(deftype octet ()
+  `(unsigned-byte 8))
+
+(deftype fixnum+ (&optional (start 0))
+  `(integer ,start ,most-positive-fixnum))
+
+(defclass fd-stream (stream)
+  ((fd :initarg :fd
+       :reader stream-fd
+       :type file-descriptor)
+   (blocking-p :initarg :blocking-p
+	       :type boolean)))
+
+(defmethod stream-blocking-p ((stream fd-stream))
+  (or (when (slot-boundp stream 'blocking-p)
+	(slot-value stream 'blocking))
+      (setf (slot-value stream 'blocking-p)
+	    (let ((flags (fcntl:getfl (stream-fd stream))))
+	      (not (= 0 (logand fcntl:+o-nonblock+ flags)))))))
+
+(defmethod (setf stream-blocking-p) (value (stream fd-stream))
+  (let* ((fd (fd-stream-fd stream))
+	 (flags (fcntl:getfl fd))
+	 (o-nonblock (not (= 0 (logand fcntl:+o-nonblock+ flags)))))
+    (cond
+      ((and value o-nonblock)
+       t)
+      ((and (not value) (not o-nonblock))
+       nil)
+      (t
+       (fcntl:setfl fd (if value
+			   (logand (lognot fcntl:+o-nonblock+) flags)
+			   (logior fcntl:+o-nonblock+ flags)))
+       (setf (slot-value stream 'blocking-p) value)))))
+
+(defmethod stream-element-type ((stream fd-stream))
+  'octet)
+
+(defmethod close ((stream fd-stream))
+  (unistd:close (stream-fd stream))
+  (call-next-method))
+
+(defclass fd-input-stream (fd-stream buffered-input-stream)
+  ())
+
+(defmethod make-stream-input-buffer ((stream fd-input-stream))
+  (cffi:foreign-alloc :unsigned-char :count *default-buffer-size*))
+
+(defmethod stream-fill-input-buffer ((stream fd-input-stream))
+  (let* ((buffer (stream-input-buffer stream))
+	 (length (stream-input-length stream))
+	 (fd (stream-fd stream))
+	 (buf (cffi:mem-aptr buffer :unsigned-char length))
+	 (buflen (- (stream-input-buffer-size stream) length))
+	 (r (if (stream-blocking-p stream)
+		(unistd:read fd buf buflen)
+		(unistd:read-non-blocking fd buf buflen))))
+    (cond ((eq :non-blocking r)
+	   :non-blocking)
+	  ((= r 0)
+	   :eof)
+	  ((< r 0)
+	   (error 'stream-input-error :stream stream))
+	  (t
+	   (incf (stream-input-length stream) r)
+	   r))))
+
+(defmethod close ((stream fd-input-stream))
+  (call-next-method)
+  (cffi:foreign-free (stream-input-buffer stream)))
+
+(defun fd-input-stream (fd)
+  (make-instance 'fd-input-stream :fd fd))
+
+(defclass fd-output-stream (fd-stream buffered-output-stream)
+  ())
+
+(defmethod make-stream-output-buffer ((stream fd-output-stream))
+  (cffi:foreign-alloc :unsigned-char :count *default-buffer-size*))
+
+(defmethod stream-flush-output-buffer ((stream fd-output-stream))
+  (let ((buffer (stream-output-buffer stream)))
+    (let* ((fd (stream-fd stream))
+	   (index (stream-output-index stream))
+	   (buf (cffi:mem-aptr buffer :unsigned-char index))
+	   (buflen (- (stream-output-length stream) index))
+	   (r (if (stream-blocking-p stream)
+		  (unistd:write fd buf buflen)
+		  (unistd:write-non-blocking fd buf buflen))))
+      (cond ((eq :non-blocking r)
+	     :non-blocking)
+	    ((= 0 r)
+	     :eof)
+	    ((< r 0)
+	     (error 'stream-output-error :stream stream))
+	    (t
+	     (incf (stream-output-index stream) r)
+	     (when (= (stream-output-index stream)
+		      (stream-output-length stream))
+	       (setf (stream-output-index stream) 0
+		     (stream-output-length stream) 0))
+	     nil)))))
+
+(defmethod close ((stream fd-output-stream))
+  (flush stream)
+  (call-next-method)
+  (cffi:foreign-free (stream-output-buffer stream)))
+
+(defun fd-output-stream (fd)
+  (make-instance 'fd-output-stream :fd fd))
+
+(defclass fd-io-stream (fd-input-stream fd-output-stream)
+  ())
+
+(defmethod close ((stream fd-io-stream))
+  (call-next-method)
+  (cffi:foreign-free (stream-input-buffer stream))
+  (cffi:foreign-free (stream-output-buffer stream)))
+
+(defun fd-io-stream (fd)
+  (make-instance 'fd-io-stream :fd fd))
diff --git a/package.lisp b/package.lisp
index 69426c5..ef48d56 100644
--- a/package.lisp
+++ b/package.lisp
@@ -1,5 +1,5 @@
 ;;
-;;  fd-gray  -  Unix file descriptor gray streams for Common Lisp
+;;  fd-stream  -  Unix file descriptors layer for cl-stream
 ;;
 ;;  Copyright 2017 Thomas de Grivel <thoxdg@gmail.com>
 ;;
@@ -18,22 +18,18 @@
 
 (in-package :common-lisp)
 
-(defpackage :fd-gray
+(defpackage :fd-stream
   (:use
    :common-lisp
-   :trivial-gray-streams)
-  (:shadow
-   #:stream
-   #:stream-error)
+   :cl-stream)
+  #.(cl-stream:shadowing-import-from)
   (:export
-   #:stream
-   #:input-stream
-   #:with-input-stream
-   #:stream-input
-   #:output-stream
-   #:with-output-stream
-   #:stream-output
-   #:io-stream
-   #:with-io-stream
-   #:stream-error
-   #:stream-closed-error))
+   #:fd-stream
+   #:fd-input-stream
+   #:with-fd-input-stream
+   #:fd-output-stream
+   #:with-fd-output-stream
+   #:fd-io-stream
+   #:with-fd-io-stream
+   #:fd-stream-error
+   #:fd-stream-closed-error))