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 (def-stream-class socket-base-simple-stream (dual-channel-simple-stream)
  24   ())
  25
  26 (defmethod device-open ((stream socket-simple-stream) options)
  27   (let* ((remote-host (getf options :remote-host))
  28          (remote-port (getf options :remote-port))
  29          (socket (make-instance 'sb-bsd-sockets:inet-socket
  30                                 :type :stream :protocol :tcp)))
  31     (unless (and remote-host remote-port)
  32       (error "~S requires :remote-host and :remote-port arguments"
  33              'socket-simple-stream))
  34     (with-stream-class (socket-simple-stream stream)
  35       (ecase (getf options :direction :input)
  36         (:input (add-stream-instance-flags stream :input))
  37         (:output (add-stream-instance-flags stream :output))
  38         (:io (add-stream-instance-flags stream :input :output)))
  39       (setf (sm socket stream) socket)
  40       (sb-bsd-sockets:socket-connect socket remote-host remote-port)
  41       (let ((fd (sb-bsd-sockets:socket-file-descriptor socket)))
  42         (when fd
  43           (add-stream-instance-flags stream :dual :simple)
  44           (when (any-stream-instance-flags stream :input)
  45             (setf (sm input-handle stream) fd)
  46             (unless (sm buffer stream)
  47               (let ((length (device-buffer-length stream)))
  48                 (setf (sm buffer stream) (allocate-buffer length)
  49                       (sm buffpos stream) 0
  50                       (sm buffer-ptr stream) 0
  51                       (sm buf-len stream) length))))
  52           (when (any-stream-instance-flags stream :output)
  53             (setf (sm output-handle stream) fd)
  54             (unless (sm out-buffer stream)
  55               (let ((length (device-buffer-length stream)))
  56                 (setf (sm out-buffer stream) (allocate-buffer length)
  57                       (sm outpos stream) 0
  58                       (sm max-out-pos stream) length)))
  59             (setf (sm control-out stream) *std-control-out-table*))
  60           (sb-ext:cancel-finalization socket)
  61           (sb-ext:finalize stream
  62                            (lambda ()
  63                              (sb-unix:unix-close fd)
  64                              (format *debug-io*
  65                                      "~&;;; ** closed socket (fd ~D)~%" fd)))
  66           ;; this should be done with (setf stream-external-format)
  67           (let ((efmt (getf options :external-format :default)))
  68             (compose-encapsulating-streams stream efmt)
  69             (install-dual-channel-character-strategy (melding-stream stream)
  70                                                      efmt))
  71           stream)))))
  72
  73 (defmethod device-close ((stream socket-simple-stream) abort)
  74   (with-stream-class (socket-simple-stream stream)
  75     (sb-unix:unix-close (or (sm input-handle stream)
  76                             (sm output-handle stream)))
  77     (when (sm buffer stream)
  78       (free-buffer (sm buffer stream))
  79       (setf (sm buffer stream) nil))
  80     (when (sm out-buffer stream)
  81       (free-buffer (sm out-buffer stream))
  82       (setf (sm out-buffer stream) nil))
  83     (sb-ext:cancel-finalization stream)
  84     t))
  85
  86 (defmethod device-open ((stream socket-base-simple-stream) options)
  87   #| do something |#
  88   stream)
  89
  90 (defmethod device-write ((stream socket-base-simple-stream) buffer
  91                          start end blocking)
  92   ;; @@2
  93   (call-next-method))
  94