From 4604020523aaf0a8af1d189b86c6b64dacf132cb Mon Sep 17 00:00:00 2001 From: Stelian Ionescu Date: Sun, 29 Apr 2007 17:15:24 +0200 Subject: [PATCH] Separated DUAL-CHANNEL-GRAY-STREAM implementation from that of ACTIVE-SOCKET. Signed-off-by: Stelian Ionescu --- sockets/base-sockets.lisp | 33 +++++++++++-- sockets/gray-stream-methods.lisp | 77 ++++++++++++++++-------------- sockets/socket-methods.lisp | 100 +++++++++++++++++++-------------------- 3 files changed, 119 insertions(+), 91 deletions(-) diff --git a/sockets/base-sockets.lisp b/sockets/base-sockets.lisp index c32145e..911fe06 100644 --- a/sockets/base-sockets.lisp +++ b/sockets/base-sockets.lisp @@ -49,7 +49,28 @@ (deftype stream-position () '(unsigned-byte 64)) -(defclass dual-channel-gray-stream (fundamental-binary-input-stream +(defclass dual-channel-fd-stream-mixin () + ((input-fd :initform nil :accessor input-fd-of) + (output-fd :initform nil :accessor output-fd-of))) + +(defclass dual-channel-single-fd-stream-mixin (dual-channel-fd-stream-mixin) ()) + +(defgeneric fd-of (stream) + (:method ((stream dual-channel-single-fd-stream-mixin)) + (with-accessors ((fd-in input-fd-of) + (fd-out output-fd-of)) stream + (assert (eql fd-in fd-out)) + (values fd-in)))) +(defgeneric (setf fd-of) (fd stream) + (:method (fd (stream dual-channel-single-fd-stream-mixin)) + (with-accessors ((fd-in input-fd-of) + (fd-out output-fd-of)) stream + (assert (eql fd-in fd-out)) + (setf fd-in fd fd-out fd) + (values fd-in)))) + +(defclass dual-channel-gray-stream (dual-channel-fd-stream-mixin + fundamental-binary-input-stream fundamental-binary-output-stream fundamental-character-input-stream fundamental-character-output-stream) @@ -75,10 +96,12 @@ ;;; ;;; ;;;;;;;;;;;;;;; -(defclass socket () - ((fd :initform nil :reader socket-fd) - (family :initarg :family :reader socket-family) - (protocol :initarg :protocol :reader socket-protocol))) +(defclass socket (dual-channel-single-fd-stream-mixin) + ((family :initarg :family :accessor socket-family) + (protocol :initarg :protocol :accessor socket-protocol))) + +(defgeneric socket-fd (socket)) +(defgeneric (setf socket-fd) (fd socket)) (defgeneric socket-type (socket)) diff --git a/sockets/gray-stream-methods.lisp b/sockets/gray-stream-methods.lisp index 739fc39..1335e90 100644 --- a/sockets/gray-stream-methods.lisp +++ b/sockets/gray-stream-methods.lisp @@ -21,7 +21,11 @@ (in-package :net.sockets) -(define-constant +max-octets-per-char+ 6) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; +;; Instance Initialization ;; +;; ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; TODO: use the buffer pool ;; TODO: handle instance reinitialization @@ -48,11 +52,11 @@ ;; ;; ;;;;;;;;;;;;;;;;;;;; -(defmethod stream-element-type ((stream active-socket)) +(defmethod stream-element-type ((stream dual-channel-gray-stream)) '(unsigned-byte 8)) ;; TODO: use the buffer pool -(defmethod close :around ((stream active-socket) &key abort) +(defmethod close :around ((stream dual-channel-gray-stream) &key abort) (unless abort (finish-output stream)) (with-accessors ((ib input-buffer-of) (ob output-buffer-of)) stream @@ -71,7 +75,7 @@ ;; ;; ;;;;;;;;;;;;;;;;;;; -(defmethod stream-clear-input ((stream active-socket)) +(defmethod stream-clear-input ((stream dual-channel-gray-stream)) (with-accessors ((ib input-buffer-of)) stream (iobuf-reset ib) nil)) @@ -95,7 +99,7 @@ (defun %read-into-simple-array-ub8 (stream array start end) (declare (type dual-channel-gray-stream stream)) (with-accessors ((ib input-buffer-of) - (fd socket-fd)) stream + (fd input-fd-of)) stream (let ((octets-needed (- end start))) (loop :with array-offset := start :for octets-in-buffer := (iobuf-length ib) @@ -128,7 +132,7 @@ :finally (return offset))) #-clisp -(defmethod stream-read-sequence ((stream active-socket) seq +(defmethod stream-read-sequence ((stream dual-channel-gray-stream) seq &optional (start 0) end) (setf (values start end) (%check-bounds seq start end)) (when (< start end) @@ -141,7 +145,7 @@ (%read-into-vector stream seq start end))))) #+clisp -(defmethod stream-read-byte-sequence ((stream active-socket) seq +(defmethod stream-read-byte-sequence ((stream dual-channel-gray-stream) seq &optional (start 0) end no-hang interactive) (declare (ignore no-hang interactive)) @@ -154,7 +158,7 @@ (%read-into-vector stream seq start end))))) #+clisp -(defmethod stream-read-char-sequence ((stream active-socket) seq +(defmethod stream-read-char-sequence ((stream dual-channel-gray-stream) seq &optional (start 0) end) (setf (values start end) (%check-bounds seq start end)) (when (< start end) @@ -214,37 +218,38 @@ (when (buffer-emptyp) (return-from %flush-obuf (values t bytes-written))) (when (zerop timeout-var) (return-from %flush-obuf (values nil :timeout))))))))) +;; TODO: add timeout support (defun %flush-obuf-if-needed (stream) (declare (type dual-channel-gray-stream stream)) - (with-accessors ((fd socket-fd) (ob output-buffer-of) + (with-accessors ((fd output-fd-of) (ob output-buffer-of) (must-flush-output-p must-flush-output-p)) stream (when (or must-flush-output-p (iobuf-full-p ob)) (%flush-obuf ob fd) (setf must-flush-output-p nil)))) -(defmethod stream-clear-output ((stream active-socket)) +(defmethod stream-clear-output ((stream dual-channel-gray-stream)) (with-accessors ((ob output-buffer-of) (must-flush-output-p must-flush-output-p) - (fd socket-fd)) stream + (fd output-fd-of)) stream (iobuf-reset ob) (setf must-flush-output-p nil) nil)) -(defmethod stream-finish-output ((stream active-socket)) +(defmethod stream-finish-output ((stream dual-channel-gray-stream)) (with-accessors ((ob output-buffer-of) (must-flush-output-p must-flush-output-p) - (fd socket-fd)) stream + (fd output-fd-of)) stream (%flush-obuf ob fd) (setf must-flush-output-p nil) nil)) -(defmethod stream-force-output ((stream active-socket)) +(defmethod stream-force-output ((stream dual-channel-gray-stream)) (setf (must-flush-output-p stream) t)) (defun %write-simple-array-ub8 (stream array start end) (declare (type dual-channel-gray-stream stream)) (with-accessors ((ob output-buffer-of) - (fd socket-fd)) stream + (fd output-fd-of)) stream (let ((octets-needed (- end start))) (if (<= octets-needed (iobuf-end-space-length ob)) (progn @@ -272,7 +277,7 @@ :finally (return vector))) #-clisp -(defmethod stream-write-sequence ((stream active-socket) seq +(defmethod stream-write-sequence ((stream dual-channel-gray-stream) seq &optional (start 0) end) (setf (values start end) (%check-bounds seq start end)) (when (< start end) @@ -287,7 +292,7 @@ (%write-vector stream seq start end))))) #+clisp -(defmethod stream-write-byte-sequence ((stream active-socket) seq +(defmethod stream-write-byte-sequence ((stream dual-channel-gray-stream) seq &optional (start 0) end no-hang interactive) (declare (ignore no-hang interactive)) @@ -302,7 +307,7 @@ (%write-vector stream seq start end))))) #+clisp -(defmethod stream-write-char-sequence ((stream active-socket) seq +(defmethod stream-write-char-sequence ((stream dual-channel-gray-stream) seq &optional (start 0) end) (setf (values start end) (%check-bounds seq start end)) (when (< start end) @@ -337,12 +342,14 @@ (incf (iobuf-start ib) 2) (return #\Newline)))))))) +(define-constant +max-octets-per-char+ 6) + ;; FIXME: currently we return :EOF when read(2) returns 0 ;; we should distinguish hard end-of-files(EOF and buffer empty) ;; from soft end-of-files(EOF and *some* bytes still in the buffer ;; but not enough to make a full character) -(defmethod stream-read-char ((stream active-socket)) - (with-accessors ((fd socket-fd) (ib input-buffer-of) +(defmethod stream-read-char ((stream dual-channel-gray-stream)) + (with-accessors ((fd input-fd-of) (ib input-buffer-of) (unread-index ibuf-unread-index-of) (ef external-format-of)) stream (setf unread-index (iobuf-start ib)) @@ -400,8 +407,8 @@ (incf (iobuf-start ib) 2) (return #\Newline)))))))) -(defmethod stream-read-char-no-hang ((stream active-socket)) - (with-accessors ((fd socket-fd) (ib input-buffer-of) +(defmethod stream-read-char-no-hang ((stream dual-channel-gray-stream)) + (with-accessors ((fd input-fd-of) (ib input-buffer-of) (ef external-format-of)) stream (let ((str (make-string 1)) (ret nil) @@ -434,7 +441,7 @@ (char str 0))))) (defun %stream-unread-char (stream) - (declare (type active-socket stream)) + (declare (type dual-channel-gray-stream stream)) (with-accessors ((ib input-buffer-of) (unread-index ibuf-unread-index-of)) stream (symbol-macrolet ((start (iobuf-start ib))) @@ -445,7 +452,7 @@ (error "No uncommitted character to unread"))))) nil) -(defmethod stream-unread-char ((stream active-socket) character) +(defmethod stream-unread-char ((stream dual-channel-gray-stream) character) ;; unreading anything but the latest character is wrong, ;; but checking is not mandated by the standard #+iolib-debug @@ -458,16 +465,16 @@ #-iolib-debug (%stream-unread-char stream)) -(defmethod stream-peek-char ((stream active-socket)) +(defmethod stream-peek-char ((stream dual-channel-gray-stream)) (let ((char (stream-read-char stream))) (cond ((eql char :eof) :eof) (t (%stream-unread-char stream) (values char))))) -;; (defmethod stream-read-line ((stream active-socket)) +;; (defmethod stream-read-line ((stream dual-channel-gray-stream)) ;; ) -(defmethod stream-listen ((stream active-socket)) +(defmethod stream-listen ((stream dual-channel-gray-stream)) (let ((char (stream-read-char-no-hang stream))) (cond ((characterp char) (stream-unread-char stream char) @@ -482,7 +489,7 @@ ;; ;; ;;;;;;;;;;;;;;;;;;;;;; -(defmethod stream-write-char ((stream active-socket) +(defmethod stream-write-char ((stream dual-channel-gray-stream) (character character)) (%flush-obuf-if-needed stream) (if (eql character #\Newline) @@ -490,13 +497,13 @@ ;; FIXME: avoid consing a string here. At worst, declare it dynamic-extent (stream-write-string stream (make-string 1 :initial-element character)))) -(defmethod stream-start-line-p ((stream active-socket)) +(defmethod stream-start-line-p ((stream dual-channel-gray-stream)) (values nil)) -(defmethod stream-terpri ((stream active-socket)) +(defmethod stream-terpri ((stream dual-channel-gray-stream)) (write-char #\Newline stream) nil) -(defmethod stream-fresh-line ((stream active-socket)) +(defmethod stream-fresh-line ((stream dual-channel-gray-stream)) (write-char #\Newline stream) t) (define-constant +unix-line-terminator+ @@ -512,7 +519,7 @@ (:dos (%write-simple-array-ub8 stream +dos-line-terminator+ 0 2)) (:mac (%write-simple-array-ub8 stream +mac-line-terminator+ 0 1)))) -(defmethod stream-write-string ((stream active-socket) +(defmethod stream-write-string ((stream dual-channel-gray-stream) (string string) &optional (start 0) end) (setf (values start end) (%check-bounds string start end)) @@ -538,8 +545,8 @@ ;; ;; ;;;;;;;;;;;;;;;;;; -(defmethod stream-read-byte ((stream active-socket)) - (with-accessors ((fd socket-fd) +(defmethod stream-read-byte ((stream dual-channel-gray-stream)) + (with-accessors ((fd input-fd-of) (ib input-buffer-of)) stream (flet ((fill-buf-or-eof () (iobuf-reset ib) @@ -555,7 +562,7 @@ ;; ;; ;;;;;;;;;;;;;;;;;;; -(defmethod stream-write-byte ((stream active-socket) integer) +(defmethod stream-write-byte ((stream dual-channel-gray-stream) integer) (check-type integer ub8 "an unsigned 8-bit value") (with-accessors ((ob output-buffer-of)) stream (%flush-obuf-if-needed stream) diff --git a/sockets/socket-methods.lisp b/sockets/socket-methods.lisp index fb1aa14..d1b04e9 100644 --- a/sockets/socket-methods.lisp +++ b/sockets/socket-methods.lisp @@ -59,21 +59,27 @@ (string protocol)))))))) (values sf st sp))) +(defmethod socket-fd ((socket socket)) + (fd-of socket)) +(defmethod (setf socket-fd) (fd (socket socket)) + (setf (fd-of socket) fd)) + (defmethod shared-initialize :after ((socket socket) slot-names &key file-descriptor family type (protocol :default)) (declare (ignore slot-names)) (when (socket-open-p socket) (close socket)) - (with-slots (fd (fam family) (proto protocol)) socket - (multiple-value-bind (sf st sp) - (translate-make-socket-keywords-to-constants family type protocol) - (if file-descriptor - (setf fd file-descriptor) - (setf fd (with-socket-error-filter - (et:socket sf st sp)))) - (setf fam family - proto protocol)))) + (with-accessors ((fd fd-of) + (fam socket-family) + (proto socket-protocol)) socket + (setf fd (or file-descriptor + (multiple-value-bind (sf st sp) + (translate-make-socket-keywords-to-constants family type protocol) + (with-socket-error-filter + (et:socket sf st sp))))) + (setf fam family + proto protocol))) (defmethod socket-type ((socket stream-socket)) :stream) @@ -93,7 +99,7 @@ (multiple-value-bind (addr port) (remote-name socket) (format stream " connected to ~A/~A" (sockaddr->presentation addr) port)) - (if (slot-value socket 'fd) + (if (fd-of socket) (format stream ", unconnected") (format stream ", closed"))))) @@ -107,7 +113,7 @@ "waiting for connections @" "bound to") (sockaddr->presentation addr) port)) - (if (slot-value socket 'fd) + (if (fd-of socket) (format stream ", unbound") (format stream ", closed"))))) @@ -116,7 +122,7 @@ (format stream "active local stream socket" ) (if (socket-connected-p socket) (format stream " connected") - (if (slot-value socket 'fd) + (if (fd-of socket) (format stream ", unconnected") (format stream ", closed"))))) @@ -129,7 +135,7 @@ "waiting for connections @" "bound to") (sockaddr->presentation (socket-address socket))) - (if (slot-value socket 'fd) + (if (fd-of socket) (format stream ", unbound") (format stream ", closed"))))) @@ -138,7 +144,7 @@ (format stream "local datagram socket" ) (if (socket-connected-p socket) (format stream " connected") - (if (slot-value socket 'fd) + (if (fd-of socket) (format stream ", unconnected") (format stream ", closed"))))) @@ -149,7 +155,7 @@ (multiple-value-bind (addr port) (remote-name socket) (format stream " connected to ~A/~A" (sockaddr->presentation addr) port)) - (if (slot-value socket 'fd) + (if (fd-of socket) (format stream ", unconnected") (format stream ", closed"))))) @@ -160,10 +166,10 @@ (defmethod close :around ((socket socket) &key abort) (declare (ignore abort)) - (when (slot-value socket 'fd) + (when (fd-of socket) (with-socket-error-filter - (et:close (socket-fd socket)))) - (setf (slot-value socket 'fd) nil) + (et:close (fd-of socket)))) + (setf (fd-of socket) nil) (call-next-method) (values socket)) @@ -178,7 +184,7 @@ (declare (ignore socket abort))) (defmethod socket-open-p ((socket socket)) - (unless (slot-value socket 'fd) + (unless (fd-of socket) (return-from socket-open-p nil)) (with-socket-error-filter (handler-case @@ -187,8 +193,7 @@ (with-foreign-pointer (size et:size-of-socklen) (setf (mem-ref size :socklen) et:size-of-sockaddr-storage) - (et:getsockname (socket-fd socket) - ss size) + (et:getsockname (fd-of socket) ss size) t)) (unix-error (err) (case (error-identifier err) @@ -204,14 +209,14 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod socket-non-blocking ((socket socket)) - (with-slots (fd) socket + (with-accessors ((fd fd-of)) socket (let ((current-flags (with-socket-error-filter (et:fcntl fd et:f-getfl)))) (logtest et:o-nonblock current-flags)))) (defmethod (setf socket-non-blocking) (value (socket socket)) (check-type value boolean "a boolean value") - (with-slots (fd) socket + (with-accessors ((fd fd-of)) socket (with-socket-error-filter (let* ((current-flags (et:fcntl fd et:f-getfl)) (new-flags (if value @@ -233,8 +238,7 @@ (setf (mem-ref size :socklen) et:size-of-sockaddr-storage) (with-socket-error-filter - (et:getsockname (socket-fd socket) - ss size)) + (et:getsockname (fd-of socket) ss size)) (return-from local-name (sockaddr-storage->sockaddr ss))))) @@ -245,8 +249,7 @@ (setf (mem-ref size :socklen) et:size-of-sockaddr-storage) (with-socket-error-filter - (et:getsockname (socket-fd socket) - sun size)) + (et:getsockname (fd-of socket) sun size)) (return-from local-name (sockaddr-un->sockaddr sun))))) @@ -268,8 +271,7 @@ (setf (mem-ref size :socklen) et:size-of-sockaddr-storage) (with-socket-error-filter - (et:getpeername (socket-fd socket) - ss size)) + (et:getpeername (fd-of socket) ss size)) (return-from remote-name (sockaddr-storage->sockaddr ss))))) @@ -280,8 +282,7 @@ (setf (mem-ref size :socklen) et:size-of-sockaddr-storage) (with-socket-error-filter - (et:getpeername (socket-fd socket) - sun size)) + (et:getpeername (fd-of socket) sun size)) (return-from remote-name (sockaddr-un->sockaddr sun))))) @@ -312,16 +313,16 @@ (address ipv4addr) &key (port 0)) (if (eql (socket-family socket) :ipv6) - (bind-ipv6-address (socket-fd socket) + (bind-ipv6-address (fd-of socket) (map-ipv4-vector-to-ipv6 (name address)) port) - (bind-ipv4-address (socket-fd socket) (name address) port)) + (bind-ipv4-address (fd-of socket) (name address) port)) (values socket)) (defmethod bind-address ((socket internet-socket) (address ipv6addr) &key (port 0)) - (bind-ipv6-address (socket-fd socket) (name address) port) + (bind-ipv6-address (fd-of socket) (name address) port) (values socket)) (defmethod bind-address :before ((socket local-socket) @@ -334,7 +335,7 @@ (with-foreign-object (sun 'et:sockaddr-un) (make-sockaddr-un sun (name address)) (with-socket-error-filter - (et:bind (socket-fd socket) sun et:size-of-sockaddr-un))) + (et:bind (fd-of socket) sun et:size-of-sockaddr-un))) (values socket)) (defmethod bind-address :after ((socket socket) @@ -351,7 +352,7 @@ +max-backlog-size+))) (check-type backlog unsigned-byte "a non-negative integer") (with-socket-error-filter - (et:listen (socket-fd socket) backlog)) + (et:listen (fd-of socket) backlog)) (setf (slot-value socket 'listening) t) (values socket)) @@ -384,8 +385,7 @@ (if wait ;; do a "normal" accept ;; Note: the socket may already be in non-blocking mode - (setf client-fd (et:accept (socket-fd socket) - ss size)) + (setf client-fd (et:accept (fd-of socket) ss size)) ;; set the socket to non-blocking mode before calling accept() ;; if there's no new connection return NIL (unwind-protect @@ -394,8 +394,7 @@ (setf non-blocking-state (socket-non-blocking socket)) ;; switch the socket to non-blocking mode (setf (socket-non-blocking socket) t) - (setf client-fd (et:accept (socket-fd socket) - ss size))) + (setf client-fd (et:accept (fd-of socket) ss size))) ;; restoring the socket's non-blocking state (setf (socket-non-blocking socket) non-blocking-state))) ;; the socket is marked non-blocking and there's no new connection @@ -436,15 +435,15 @@ (defmethod connect ((socket internet-socket) (address ipv4addr) &key (port 0)) (if (eql (socket-family socket) :ipv6) - (ipv6-connect (socket-fd socket) + (ipv6-connect (fd-of socket) (map-ipv4-vector-to-ipv6 (name address)) port) - (ipv4-connect (socket-fd socket) (name address) port)) + (ipv4-connect (fd-of socket) (name address) port)) (values socket)) (defmethod connect ((socket internet-socket) (address ipv6addr) &key (port 0)) - (ipv6-connect (socket-fd socket) (name address) port) + (ipv6-connect (fd-of socket) (name address) port) (values socket)) (defmethod connect ((socket local-socket) @@ -452,7 +451,7 @@ (with-foreign-object (sun 'et:sockaddr-un) (make-sockaddr-un sun (name address)) (with-socket-error-filter - (et:connect (socket-fd socket) sun et:size-of-sockaddr-un))) + (et:connect (fd-of socket) sun et:size-of-sockaddr-un))) (values socket)) (defmethod connect ((socket passive-socket) @@ -461,7 +460,7 @@ (error "You cannot connect passive sockets.")) (defmethod socket-connected-p ((socket socket)) - (unless (slot-value socket 'fd) + (unless (fd-of socket) (return-from socket-connected-p nil)) (with-socket-error-filter (handler-case @@ -470,8 +469,7 @@ (with-foreign-pointer (size et:size-of-socklen) (setf (mem-ref size :socklen) et:size-of-sockaddr-storage) - (et:getpeername (socket-fd socket) - ss size) + (et:getpeername (fd-of socket) ss size) t)) (et:unix-error-notconn (err) (declare (ignore err)) @@ -486,7 +484,7 @@ (check-type direction (member :read :write :read-write) "valid direction specifier") (with-socket-error-filter - (et:shutdown (socket-fd socket) + (et:shutdown (fd-of socket) (ecase direction (:read et:shut-rd) (:write et:shut-wr) @@ -543,7 +541,7 @@ (incf-pointer buff-sap start-offset) (with-socket-error-filter (return-from socket-send - (et:sendto (socket-fd socket) + (et:sendto (fd-of socket) buff-sap bufflen flags (if remote-address ss (null-pointer)) @@ -584,7 +582,7 @@ (incf-pointer buff-sap start-offset) (with-socket-error-filter (setf bytes-received - (et:recvfrom (socket-fd socket) + (et:recvfrom (fd-of socket) buff-sap bufflen flags ss size))))) @@ -616,4 +614,4 @@ (with-foreign-object (sin 'et:sockaddr-in) (et:bzero sin et:size-of-sockaddr-in) (setf (foreign-slot-value sin 'et:sockaddr-in 'et:addr) et:af-unspec) - (et:connect (socket-fd socket) sin et:size-of-sockaddr-in)))) + (et:connect (fd-of socket) sin et:size-of-sockaddr-in)))) -- 2.11.4.GIT