[usocket-cvs] r127 - in trivial-usocket: . branches tags trunk trunk/test

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Mon Dec 18 17:16:57 2006
New Revision: 127

Added:
   trivial-usocket/
   trivial-usocket/branches/
   trivial-usocket/tags/
   trivial-usocket/trunk/   (props changed)
   trivial-usocket/trunk/test/
   trivial-usocket/trunk/trivial-usocket.asd
   trivial-usocket/trunk/trivial-usocket.lisp
Log:
Start independent trivial-usocket project, a trivial-sockets migration path to
usocket.

Added: trivial-usocket/trunk/trivial-usocket.asd
==============================================================================
--- (empty file)
+++ trivial-usocket/trunk/trivial-usocket.asd	Mon Dec 18 17:16:57 2006
@@ -0,0 +1,19 @@
+
+;;;; $Id$
+;;;; $URL$
+
+;;;; See the LICENSE file for licensing information.
+
+(cl:defpackage #:trivial-usocket-system
+    (:use #:cl #:asdf))
+
+(cl:in-package #:trivial-usocket-system)
+
+(defsystem trivial-usocket
+    :name "trivial-usocket"
+    :author "Erik Huelsmann"
+    :version "0.2.0-dev"
+    :licence "MIT"
+    :description "trivial-sockets compatibility layer for usocket"
+    :depends-on (#:usocket #:trivial-gray-streams)
+    :components ((:file "trivial-usocket")))

Added: trivial-usocket/trunk/trivial-usocket.lisp
==============================================================================
--- (empty file)
+++ trivial-usocket/trunk/trivial-usocket.lisp	Mon Dec 18 17:16:57 2006
@@ -0,0 +1,170 @@
+
+;;;; $Id$
+;;;; $URL$
+
+;;;; See the LICENSE file for licensing information.
+
+(defpackage :trivial-usocket
+  (:use #:cl
+        #:trivial-gray-streams
+        #:usocket)
+  (:export #:open-stream
+           #:usocket
+           #:unsupported))
+
+(in-package :trivial-usocket)
+
+;; Condition raised by operations with unsupported arguments
+;; For trivial-sockets compatibility.
+
+(define-condition unsupported (error)
+  ((feature :initarg :feature :reader unsupported-feature)))
+
+
+(defclass usocket-mixin (trivial-gray-stream-mixin)
+  ((socket
+    :initarg :usocket
+    :accessor usocket
+    :documentation ""))
+  (:documentation "A stream which forwards all calls to the stream
+associated with the socket, still allowing the original socket to be
+retrieved."))
+
+;; retrieval of the socket is something not all implementations allow
+;; for the streams they associate with the sockets; that's why we have
+;; a special stream which does allow it.
+
+
+;; We need to implement these symbols (for forwarding-stream-mixin):
+
+(defmethod stream-read-char ((stream usocket-mixin))
+  (read-char (socket-stream (usocket stream)) nil :eof))
+
+(defmethod stream-unread-char ((stream usocket-mixin) char)
+  (unread-char char (socket-stream (usocket stream))))
+
+(defmethod stream-read-char-no-hang ((stream usocket-mixin))
+  (read-char-no-hang (socket-stream (usocket stream))))
+
+(defmethod stream-peek-char ((stream usocket-mixin))
+  (peek-char nil (socket-stream (usocket stream)) nil :eof))
+
+(defmethod stream-listen ((stream usocket-mixin))
+  (listen (socket-stream (usocket stream))))
+
+(defmethod stream-read-line ((stream usocket-mixin))
+  (let ((line (read-line (socket-stream (usocket stream)) nil :eof)))
+    (if (eq line :eof)
+        (values "" t)
+      (values line nil))))
+
+(defmethod stream-clear-input ((stream usocket-mixin))
+  (clear-input (socket-stream (usocket stream))))
+
+(defmethod stream-write-char ((stream usocket-mixin) char)
+  (write-char char (socket-stream (usocket stream))))
+
+(defmethod stream-line-column ((stream usocket-mixin))
+  nil)
+
+(defmethod stream-start-line-p ((stream usocket-mixin))
+  nil)
+
+(defmethod stream-write-string ((stream usocket-mixin)
+                                string &optional start end)
+  (write-string string (socket-stream (usocket stream))
+                :start (or start 0)
+                :end (or end (length string))))
+
+(defmethod stream-terpri ((stream usocket-mixin))
+  (terpri (socket-stream (usocket stream))))
+
+(defmethod stream-fresh-line ((stream usocket-mixin))
+  (fresh-line (socket-stream (usocket stream))))
+
+(defmethod stream-finish-output ((stream usocket-mixin))
+  (finish-output (socket-stream (usocket stream))))
+
+(defmethod stream-force-output ((stream usocket-mixin))
+  (force-output (socket-stream (usocket stream))))
+
+(defmethod stream-clear-output ((non-stream usocket-mixin))
+  (clear-output (socket-stream (usocket non-stream))))
+
+(defmethod stream-advance-to-column ((stream usocket-mixin) column)
+  nil)
+
+(defmethod close ((stream usocket-mixin) &key abort)
+  (close (socket-stream (usocket stream)) :abort abort))
+
+(defmethod stream-read-byte ((non-stream usocket-mixin))
+  (read-byte (socket-stream (usocket non-stream)) nil :eof))
+
+(defmethod stream-write-byte ((non-stream usocket-mixin) integer)
+  (write-byte integer (socket-stream (usocket non-stream))))
+
+(defmethod stream-read-sequence ((stream usocket-mixin) seq start end
+                                 &key &allow-other-keys)
+  (read-sequence seq (socket-stream (usocket stream))
+                 :start (or start 0)
+                 :end (or end (length seq))))
+
+(defmethod stream-write-sequence ((stream usocket-mixin) seq start end
+                                  &key &allow-other-keys)
+  (write-sequence seq (socket-stream (usocket stream))
+                  :start (or start 0)
+                  :end (or end (length seq))))
+
+
+;; We also need to implement forwarding streams:
+;;
+;; forwarding-input-stream
+;; forwarding-output-stream
+;; forwarding-io-stream
+;;
+;; which are derived from their ancestors (fundamental-*) and
+;; the forwarding mixin.
+
+(defclass usocket-input-stream (fundamental-input-stream usocket-mixin)
+  ())
+
+(defclass usocket-output-stream (fundamental-output-stream usocket-mixin)
+  ())
+
+(defclass usocket-io-stream (fundamental-input-stream
+                             fundamental-output-stream
+                             usocket-mixin)
+  ())
+
+(defun wrap-usocket-stream (usocket &rest rest)
+  ""
+  (let* ((ustream (socket-stream usocket))
+         (istream-p (input-stream-p ustream))
+         (ostream-p (output-stream-p ustream)))
+    (apply #'make-instance
+           (cond
+            ((and istream-p ostream-p)
+             'usocket-io-stream)
+            (istream-p 'usocket-input-stream)
+            (ostream-p 'usocket-output-stream)
+            (t (error "Unsupported stream type")))
+           :usocket usocket
+           rest)))
+
+(defun open-stream (peer-host peer-port
+                              &key (local-host :any)
+                                   (local-port 0)
+                                   (external-format :default)
+                                   (element-type 'character)
+                                   (protocol :tcp))
+  (unless (eq protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  (unless (and (eql local-host :any) (eql local-port 0))
+    (error 'unsupported :feature :bind))
+  (unless (eql external-format :default)
+    (error 'unsupported :feature :external-format))
+  (unless (eql element-type 'character)
+    (error 'unsupported :feature :element-type))
+  (let ((socket (socket-connect peer-host peer-port)))
+    (wrap-usocket-stream socket)))
+