3 ;;; **********************************************************************
4 ;;; This code was written by Paul Foley and has been placed in the public
8 ;;; Sbcl port by Rudi Schlatte.
10 (in-package "SB-SIMPLE-STREAMS")
13 ;;; **********************************************************************
15 ;;; Socket-simple-stream and socket-base-simple-stream
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
20 (socket :initform nil :type (or sb-bsd-sockets:socket null)
23 (def-stream-class socket-base-simple-stream (dual-channel-simple-stream)
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)))
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)
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)
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
63 (sb-unix:unix-close fd)
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)
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)
86 (defmethod device-open ((stream socket-base-simple-stream) options)
90 (defmethod device-write ((stream socket-base-simple-stream) buffer