contrib/sb-simple-streams/socket.lisp

   1 ;;; -*- lisp -*-
   2 ;;;
   3 ;;; **********************************************************************
   4 ;;; This code was written by Paul Foley and has been placed in the public
   5 ;;; domain.
   6 ;;;
   7
   8 ;;; Sbcl port by Rudi Schlatte.
   9
  10 (in-package "SB-SIMPLE-STREAMS")
  11
  12 ;;;
  13 ;;; **********************************************************************
  14 ;;;
  15 ;;; Socket-simple-stream and socket-base-simple-stream
  16
  17 (def-stream-class socket-simple-stream (dual-channel-simple-stream)
  18   (;; keep the socket around; it could be handy e.g. for querying peer
  19    ;; host/port
  20    (socket :initform nil :type (or sb-bsd-sockets:socket null)
  21            :initarg :socket)))
  22
  23 (defmethod print-object ((object socket-simple-stream) stream)
  24   (print-unreadable-object (object stream :type nil :identity nil)
  25     (with-stream-class (socket-simple-stream object)
  26       (cond ((not (any-stream-instance-flags object :simple))
  27              (princ "Invalid " stream))
  28             ((not (any-stream-instance-flags object :input :output))
  29              (princ "Closed " stream)))
  30       (format stream "~:(~A~)"
  31               (type-of object))
  32       (when (any-stream-instance-flags object :input :output)
  33         (multiple-value-bind (host port)
  34             (sb-bsd-sockets:socket-peername (sm socket object))
  35           (format stream " connected to host ~S, port ~S" host port))))))
  36
  37 (def-stream-class socket-base-simple-stream (dual-channel-simple-stream)
  38   ())
  39
  40 (defmethod device-open ((stream socket-simple-stream) options)
  41   (let* ((remote-host (getf options :remote-host))
  42          (remote-port (getf options :remote-port))
  43          (socket (make-instance 'sb-bsd-sockets:inet-socket
  44                                 :type :stream :protocol :tcp)))
  45     (unless (and remote-host remote-port)
  46       (error "device-open on ~S requires :remote-host and :remote-port arguments"
  47              'socket-simple-stream))
  48     (with-stream-class (socket-simple-stream stream)
  49       (ecase (getf options :direction :input)
  50         (:input (add-stream-instance-flags stream :input))
  51         (:output (add-stream-instance-flags stream :output))
  52         (:io (add-stream-instance-flags stream :input :output)))
  53       (setf (sm socket stream) socket)
  54       (sb-bsd-sockets:socket-connect socket remote-host remote-port)
  55       (let ((fd (sb-bsd-sockets:socket-file-descriptor socket)))
  56         (when fd
  57           (add-stream-instance-flags stream :dual :simple)
  58           (when (any-stream-instance-flags stream :input)
  59             (setf (sm input-handle stream) fd)
  60             (unless (sm buffer stream)
  61               (let ((length (device-buffer-length stream)))
  62                 (setf (sm buffer stream) (allocate-buffer length)
  63                       (sm buffpos stream) 0
  64                       (sm buffer-ptr stream) 0
  65                       (sm buf-len stream) length))))
  66           (when (any-stream-instance-flags stream :output)
  67             (setf (sm output-handle stream) fd)
  68             (unless (sm out-buffer stream)
  69               (let ((length (device-buffer-length stream)))
  70                 (setf (sm out-buffer stream) (allocate-buffer length)
  71                       (sm outpos stream) 0
  72                       (sm max-out-pos stream) length)))
  73             (setf (sm control-out stream) *std-control-out-table*))
  74           (sb-ext:cancel-finalization socket)
  75           (sb-ext:finalize stream
  76                            (lambda ()
  77                              (sb-unix:unix-close fd)
  78                              (format *debug-io*
  79                                      "~&;;; ** closed socket (fd ~D)~%" fd))
  80                            :dont-save t)
  81           ;; this should be done with (setf stream-external-format)
  82           (let ((efmt (getf options :external-format :default)))
  83             (compose-encapsulating-streams stream efmt)
  84             (install-dual-channel-character-strategy (melding-stream stream)
  85                                                      efmt))
  86           stream)))))
  87
  88 (defmethod device-close ((stream socket-simple-stream) abort)
  89   (with-stream-class (socket-simple-stream stream)
  90     (sb-unix:unix-close (or (sm input-handle stream)
  91                             (sm output-handle stream)))
  92     (when (sm buffer stream)
  93       (free-buffer (sm buffer stream))
  94       (setf (sm buffer stream) nil))
  95     (when (sm out-buffer stream)
  96       (free-buffer (sm out-buffer stream))
  97       (setf (sm out-buffer stream) nil))
  98     (sb-ext:cancel-finalization stream)
  99     t))
 100
 101 (defmethod device-open ((stream socket-base-simple-stream) options)
 102   #| do something |#
 103   stream)
 104
 105 (defmethod device-write ((stream socket-base-simple-stream) buffer
 106                          start end blocking)
 107   ;; @@2
 108   (call-next-method))
 109