net-sbcl.lisp

   1 (in-package :common-net)
   2
   3 (require :sb-bsd-sockets)
   4
   5 ;;; Gray stream methods
   6
   7 ;; Redefine stream-socket with Gray superclasses. I know it's ugly,
   8 ;; but I just don't know of a better way to do it.
   9 (defclass stream-socket (socket sb-gray:fundamental-input-stream sb-gray:fundamental-output-stream)
  10   ((mode :initform :byte)
  11    (byte-buffer :initform (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t)
  12                 :type (array (unsigned-byte 8)))
  13    (byte-read-pos :initform 0 :type integer)
  14    (byte-write-pos :initform 0 :type integer)
  15    (char-buffer :initform (make-array '(16) :element-type 'character :adjustable t :fill-pointer 0)
  16                 :type (array character))
  17    (char-read-pos :initform 0 :type integer)
  18    encoder decoder))
  19
  20 (macrolet ((simple (name)
  21              `(defmethod
  22                   ,(intern (symbol-name name) (find-package :sb-gray)) ((socket stream-socket))
  23                 (,(intern (concatenate 'string "GRAY-" (symbol-name name)) (symbol-package 'stream-socket)) socket)))
  24            (simple-null (name)
  25              `(defmethod
  26                   ,(intern (symbol-name name) (find-package :sb-gray)) ((socket stream-socket))
  27                 nil)))
  28   (simple stream-element-type)
  29   (simple open-stream-p)
  30   (simple stream-read-byte)
  31   (simple stream-read-char)
  32   (simple stream-read-char-no-hang)
  33   (simple stream-peek-char)
  34   (simple stream-listen)
  35   (simple-null stream-line-column)
  36   (simple-null stream-finish-output)
  37   (simple-null stream-force-output)
  38   (simple-null stream-clear-output))
  39
  40 (defmethod sb-gray:stream-write-byte ((socket stream-socket) byte)
  41   (gray-stream-write-char socket byte))
  42
  43 (defmethod sb-gray:stream-unread-char ((socket stream-socket) char)
  44   (gray-stream-unread-char socket char))
  45
  46 (defmethod sb-gray:stream-write-char ((socket stream-socket) char)
  47   (gray-stream-write-char socket char))
  48
  49 (defmethod close ((socket stream-socket) &key abort)
  50   (declare (ignore abort))
  51   (prog1
  52       (call-next-method)
  53     (close-socket socket)))
  54
  55 (defmethod sb-gray:stream-start-line-p ((socket stream-socket))
  56   (eql (sb-gray:stream-line-column socket) 0))
  57
  58 (defmethod sb-gray:stream-fresh-line ((socket stream-socket))
  59   (unless (sb-gray:stream-start-line-p socket)
  60     (sb-gray:stream-terpri socket)
  61     t))
  62
  63 (defmethod sb-gray:stream-write-string ((socket stream-socket) string &optional (start 0) (end (length string)))
  64   (sb-gray:stream-write-sequence socket string start end))
  65
  66 (defmethod sb-gray:stream-terpri ((socket stream-socket))
  67   (sb-gray:stream-write-char socket #\newline))
  68
  69 (defmethod sb-gray:stream-read-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq)))
  70   (gray-stream-read-sequence socket seq start end))
  71
  72 (defmethod sb-gray:stream-write-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq)))
  73   (gray-stream-write-sequence socket seq start end))
  74
  75 ;;; Necessary SBCL gray-stream extensions
  76
  77 (defmethod sb-gray:stream-line-length ((socket stream-socket))
  78   nil)