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))) +