354 lines
9.8 KiB
Common Lisp
354 lines
9.8 KiB
Common Lisp
|
;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET -*-
|
||
|
|
;;;; SOCKET-OPTION, a high-level socket option get/set framework
|
||
|
|
|
||
|
|
;;;; See LICENSE for licensing information.
|
||
|
|
|
||
|
|
(in-package :usocket)
|
||
|
|
|
||
|
|
;; put here because option.lisp is for native backend only
|
||
|
|
(defparameter *backend* :native)
|
||
|
|
|
||
|
|
;;; Interface definition
|
||
|
|
|
||
|
|
(defgeneric socket-option (socket option &key)
|
||
|
|
(:documentation
|
||
|
|
"Get a socket's internal options"))
|
||
|
|
|
||
|
|
(defgeneric (setf socket-option) (new-value socket option &key)
|
||
|
|
(:documentation
|
||
|
|
"Set a socket's internal options"))
|
||
|
|
|
||
|
|
;;; Handling of wrong type of arguments
|
||
|
|
|
||
|
|
(defmethod socket-option ((socket usocket) (option t) &key)
|
||
|
|
(error 'type-error :datum option :expected-type 'keyword))
|
||
|
|
|
||
|
|
(defmethod (setf socket-option) (new-value (socket usocket) (option t) &key)
|
||
|
|
(declare (ignore new-value))
|
||
|
|
(socket-option socket option))
|
||
|
|
|
||
|
|
(defmethod socket-option ((socket usocket) (option symbol) &key)
|
||
|
|
(if (keywordp option)
|
||
|
|
(error 'unimplemented :feature option :context 'socket-option)
|
||
|
|
(error 'type-error :datum option :expected-type 'keyword)))
|
||
|
|
|
||
|
|
(defmethod (setf socket-option) (new-value (socket usocket) (option symbol) &key)
|
||
|
|
(declare (ignore new-value))
|
||
|
|
(socket-option socket option))
|
||
|
|
|
||
|
|
;;; Socket option: RECEIVE-TIMEOUT (SO_RCVTIMEO)
|
||
|
|
|
||
|
|
(defmethod socket-option ((usocket stream-usocket)
|
||
|
|
(option (eql :receive-timeout)) &key)
|
||
|
|
(declare (ignorable option))
|
||
|
|
(let ((socket (socket usocket)))
|
||
|
|
(declare (ignorable socket))
|
||
|
|
#+abcl
|
||
|
|
() ; TODO
|
||
|
|
#+allegro
|
||
|
|
() ; TODO
|
||
|
|
#+clisp
|
||
|
|
(socket:socket-options socket :so-rcvtimeo)
|
||
|
|
#+clozure
|
||
|
|
(ccl:stream-input-timeout socket)
|
||
|
|
#+cmu
|
||
|
|
(lisp::fd-stream-timeout (socket-stream usocket))
|
||
|
|
#+(or ecl clasp)
|
||
|
|
(sb-bsd-sockets:sockopt-receive-timeout socket)
|
||
|
|
#+lispworks
|
||
|
|
(get-socket-receive-timeout socket)
|
||
|
|
#+mcl
|
||
|
|
() ; TODO
|
||
|
|
#+mocl
|
||
|
|
() ; unknown
|
||
|
|
#+sbcl
|
||
|
|
(sb-impl::fd-stream-timeout (socket-stream usocket))
|
||
|
|
#+scl
|
||
|
|
())) ; TODO
|
||
|
|
|
||
|
|
(defmethod (setf socket-option) (new-value (usocket stream-usocket)
|
||
|
|
(option (eql :receive-timeout)) &key)
|
||
|
|
(declare (type number new-value) (ignorable new-value option))
|
||
|
|
(let ((socket (socket usocket))
|
||
|
|
(timeout new-value))
|
||
|
|
(declare (ignorable socket timeout))
|
||
|
|
#+abcl
|
||
|
|
() ; TODO
|
||
|
|
#+allegro
|
||
|
|
() ; TODO
|
||
|
|
#+clisp
|
||
|
|
(socket:socket-options socket :so-rcvtimeo timeout)
|
||
|
|
#+clozure
|
||
|
|
(setf (ccl:stream-input-timeout socket) timeout)
|
||
|
|
#+cmu
|
||
|
|
(setf (lisp::fd-stream-timeout (socket-stream usocket))
|
||
|
|
(coerce timeout 'integer))
|
||
|
|
#+(or ecl clasp)
|
||
|
|
(setf (sb-bsd-sockets:sockopt-receive-timeout socket) timeout)
|
||
|
|
#+lispworks
|
||
|
|
(set-socket-receive-timeout socket timeout)
|
||
|
|
#+mcl
|
||
|
|
() ; TODO
|
||
|
|
#+mocl
|
||
|
|
() ; unknown
|
||
|
|
#+sbcl
|
||
|
|
(setf (sb-impl::fd-stream-timeout (socket-stream usocket))
|
||
|
|
(coerce timeout 'single-float))
|
||
|
|
#+scl
|
||
|
|
() ; TODO
|
||
|
|
new-value))
|
||
|
|
|
||
|
|
;;; Socket option: SEND-TIMEOUT (SO_SNDTIMEO)
|
||
|
|
|
||
|
|
(defmethod socket-option ((usocket stream-usocket)
|
||
|
|
(option (eql :send-timeout)) &key)
|
||
|
|
(declare (ignorable option))
|
||
|
|
(let ((socket (socket usocket)))
|
||
|
|
(declare (ignorable socket))
|
||
|
|
#+abcl
|
||
|
|
() ; TODO
|
||
|
|
#+allegro
|
||
|
|
() ; TODO
|
||
|
|
#+clisp
|
||
|
|
(socket:socket-options socket :so-sndtimeo)
|
||
|
|
#+clozure
|
||
|
|
(ccl:stream-output-timeout socket)
|
||
|
|
#+cmu
|
||
|
|
(lisp::fd-stream-timeout (socket-stream usocket))
|
||
|
|
#+(or ecl clasp)
|
||
|
|
(sb-bsd-sockets:sockopt-send-timeout socket)
|
||
|
|
#+lispworks
|
||
|
|
(get-socket-send-timeout socket)
|
||
|
|
#+mcl
|
||
|
|
() ; TODO
|
||
|
|
#+mocl
|
||
|
|
() ; unknown
|
||
|
|
#+sbcl
|
||
|
|
(sb-impl::fd-stream-timeout (socket-stream usocket))
|
||
|
|
#+scl
|
||
|
|
())) ; TODO
|
||
|
|
|
||
|
|
(defmethod (setf socket-option) (new-value (usocket stream-usocket)
|
||
|
|
(option (eql :send-timeout)) &key)
|
||
|
|
(declare (type number new-value) (ignorable new-value option))
|
||
|
|
(let ((socket (socket usocket))
|
||
|
|
(timeout new-value))
|
||
|
|
(declare (ignorable socket timeout))
|
||
|
|
#+abcl
|
||
|
|
() ; TODO
|
||
|
|
#+allegro
|
||
|
|
() ; TODO
|
||
|
|
#+clisp
|
||
|
|
(socket:socket-options socket :so-sndtimeo timeout)
|
||
|
|
#+clozure
|
||
|
|
(setf (ccl:stream-output-timeout socket) timeout)
|
||
|
|
#+cmu
|
||
|
|
(setf (lisp::fd-stream-timeout (socket-stream usocket))
|
||
|
|
(coerce timeout 'integer))
|
||
|
|
#+(or ecl clasp)
|
||
|
|
(setf (sb-bsd-sockets:sockopt-send-timeout socket) timeout)
|
||
|
|
#+lispworks
|
||
|
|
(set-socket-send-timeout socket timeout)
|
||
|
|
#+mcl
|
||
|
|
() ; TODO
|
||
|
|
#+mocl
|
||
|
|
() ; unknown
|
||
|
|
#+sbcl
|
||
|
|
(setf (sb-impl::fd-stream-timeout (socket-stream usocket))
|
||
|
|
(coerce timeout 'single-float))
|
||
|
|
#+scl
|
||
|
|
() ; TODO
|
||
|
|
new-value))
|
||
|
|
|
||
|
|
;;; Socket option: REUSE-ADDRESS (SO_REUSEADDR), for TCP server
|
||
|
|
|
||
|
|
(defmethod socket-option ((usocket stream-server-usocket)
|
||
|
|
(option (eql :reuse-address)) &key)
|
||
|
|
(declare (ignorable option))
|
||
|
|
(let ((socket (socket usocket)))
|
||
|
|
(declare (ignorable socket))
|
||
|
|
#+abcl
|
||
|
|
() ; TODO
|
||
|
|
#+allegro
|
||
|
|
() ; TODO
|
||
|
|
#+clisp
|
||
|
|
(int->bool (socket:socket-options socket :so-reuseaddr))
|
||
|
|
#+clozure
|
||
|
|
(int->bool (get-socket-option-reuseaddr socket))
|
||
|
|
#+cmu
|
||
|
|
() ; TODO
|
||
|
|
#+lispworks
|
||
|
|
(get-socket-reuse-address socket)
|
||
|
|
#+mcl
|
||
|
|
() ; TODO
|
||
|
|
#+mocl
|
||
|
|
() ; unknown
|
||
|
|
#+(or ecl sbcl clasp)
|
||
|
|
(sb-bsd-sockets:sockopt-reuse-address socket)
|
||
|
|
#+scl
|
||
|
|
())) ; TODO
|
||
|
|
|
||
|
|
(defmethod (setf socket-option) (new-value (usocket stream-server-usocket)
|
||
|
|
(option (eql :reuse-address)) &key)
|
||
|
|
(declare (type boolean new-value) (ignorable new-value option))
|
||
|
|
(let ((socket (socket usocket)))
|
||
|
|
(declare (ignorable socket))
|
||
|
|
#+abcl
|
||
|
|
() ; TODO
|
||
|
|
#+allegro
|
||
|
|
(socket:set-socket-options socket option new-value)
|
||
|
|
#+clisp
|
||
|
|
(socket:socket-options socket :so-reuseaddr (bool->int new-value))
|
||
|
|
#+clozure
|
||
|
|
(set-socket-option-reuseaddr socket (bool->int new-value))
|
||
|
|
#+cmu
|
||
|
|
() ; TODO
|
||
|
|
#+lispworks
|
||
|
|
(set-socket-reuse-address socket new-value)
|
||
|
|
#+mcl
|
||
|
|
() ; TODO
|
||
|
|
#+mocl
|
||
|
|
() ; unknown
|
||
|
|
#+(or ecl sbcl clasp)
|
||
|
|
(setf (sb-bsd-sockets:sockopt-reuse-address socket) new-value)
|
||
|
|
#+scl
|
||
|
|
() ; TODO
|
||
|
|
new-value))
|
||
|
|
|
||
|
|
;;; Socket option: BROADCAST (SO_BROADCAST), for UDP client
|
||
|
|
|
||
|
|
(defmethod socket-option ((usocket datagram-usocket)
|
||
|
|
(option (eql :broadcast)) &key)
|
||
|
|
(declare (ignorable option))
|
||
|
|
(let ((socket (socket usocket)))
|
||
|
|
(declare (ignorable socket))
|
||
|
|
#+abcl
|
||
|
|
() ; TODO
|
||
|
|
#+allegro
|
||
|
|
() ; TODO
|
||
|
|
#+clisp
|
||
|
|
(int->bool (socket:socket-options socket :so-broadcast))
|
||
|
|
#+clozure
|
||
|
|
(int->bool (get-socket-option-broadcast socket))
|
||
|
|
#+cmu
|
||
|
|
() ; TODO
|
||
|
|
#+(or ecl clasp)
|
||
|
|
() ; TODO
|
||
|
|
#+lispworks
|
||
|
|
() ; TODO
|
||
|
|
#+mcl
|
||
|
|
() ; TODO
|
||
|
|
#+mocl
|
||
|
|
() ; unknown
|
||
|
|
#+sbcl
|
||
|
|
(sb-bsd-sockets:sockopt-broadcast socket)
|
||
|
|
#+scl
|
||
|
|
())) ; TODO
|
||
|
|
|
||
|
|
(defmethod (setf socket-option) (new-value (usocket datagram-usocket)
|
||
|
|
(option (eql :broadcast)) &key)
|
||
|
|
(declare (type boolean new-value)
|
||
|
|
(ignorable new-value option))
|
||
|
|
(let ((socket (socket usocket)))
|
||
|
|
(declare (ignorable socket))
|
||
|
|
#+abcl
|
||
|
|
() ; TODO
|
||
|
|
#+allegro
|
||
|
|
(socket:set-socket-options socket option new-value)
|
||
|
|
#+clisp
|
||
|
|
(socket:socket-options socket :so-broadcast (bool->int new-value))
|
||
|
|
#+clozure
|
||
|
|
(set-socket-option-broadcast socket (bool->int new-value))
|
||
|
|
#+cmu
|
||
|
|
() ; TODO
|
||
|
|
#+(or ecl clasp)
|
||
|
|
() ; TODO
|
||
|
|
#+lispworks
|
||
|
|
() ; TODO
|
||
|
|
#+mcl
|
||
|
|
() ; TODO
|
||
|
|
#+mocl
|
||
|
|
() ; unknown
|
||
|
|
#+sbcl
|
||
|
|
(setf (sb-bsd-sockets:sockopt-broadcast socket) new-value)
|
||
|
|
#+scl
|
||
|
|
() ; TODO
|
||
|
|
new-value))
|
||
|
|
|
||
|
|
;;; Socket option: TCP-NODELAY (TCP_NODELAY), for TCP client
|
||
|
|
|
||
|
|
(defmethod socket-option ((usocket stream-usocket)
|
||
|
|
(option (eql :tcp-no-delay)) &key)
|
||
|
|
(declare (ignorable option))
|
||
|
|
(socket-option usocket :tcp-nodelay))
|
||
|
|
|
||
|
|
(defmethod socket-option ((usocket stream-usocket)
|
||
|
|
(option (eql :tcp-nodelay)) &key)
|
||
|
|
(declare (ignorable option))
|
||
|
|
(let ((socket (socket usocket)))
|
||
|
|
(declare (ignorable socket))
|
||
|
|
#+abcl
|
||
|
|
() ; TODO
|
||
|
|
#+allegro
|
||
|
|
() ; TODO
|
||
|
|
#+clisp
|
||
|
|
(int->bool (socket:socket-options socket :tcp-nodelay))
|
||
|
|
#+clozure
|
||
|
|
(int->bool (get-socket-option-tcp-nodelay socket))
|
||
|
|
#+cmu
|
||
|
|
()
|
||
|
|
#+(or ecl clasp)
|
||
|
|
(sb-bsd-sockets::sockopt-tcp-nodelay socket)
|
||
|
|
#+lispworks
|
||
|
|
(int->bool (get-socket-tcp-nodelay socket))
|
||
|
|
#+mcl
|
||
|
|
() ; TODO
|
||
|
|
#+mocl
|
||
|
|
() ; unknown
|
||
|
|
#+sbcl
|
||
|
|
(sb-bsd-sockets::sockopt-tcp-nodelay socket)
|
||
|
|
#+scl
|
||
|
|
())) ; TODO
|
||
|
|
|
||
|
|
(defmethod (setf socket-option) (new-value (usocket stream-usocket)
|
||
|
|
(option (eql :tcp-no-delay)) &key)
|
||
|
|
(declare (ignorable option))
|
||
|
|
(setf (socket-option usocket :tcp-nodelay) new-value))
|
||
|
|
|
||
|
|
(defmethod (setf socket-option) (new-value (usocket stream-usocket)
|
||
|
|
(option (eql :tcp-nodelay)) &key)
|
||
|
|
(declare (type boolean new-value)
|
||
|
|
(ignorable new-value option))
|
||
|
|
(let ((socket (socket usocket)))
|
||
|
|
(declare (ignorable socket))
|
||
|
|
#+abcl
|
||
|
|
() ; TODO
|
||
|
|
#+allegro
|
||
|
|
(socket:set-socket-options socket :no-delay new-value)
|
||
|
|
#+clisp
|
||
|
|
(socket:socket-options socket :tcp-nodelay (bool->int new-value))
|
||
|
|
#+clozure
|
||
|
|
(set-socket-option-tcp-nodelay socket (bool->int new-value))
|
||
|
|
#+cmu
|
||
|
|
()
|
||
|
|
#+(or ecl clasp)
|
||
|
|
(setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value)
|
||
|
|
#+lispworks
|
||
|
|
(progn
|
||
|
|
#-(or lispworks4 lispworks5.0)
|
||
|
|
(comm::set-socket-tcp-nodelay socket new-value)
|
||
|
|
#+(or lispworks4 lispworks5.0)
|
||
|
|
(set-socket-tcp-nodelay socket (bool->int new-value)))
|
||
|
|
#+mcl
|
||
|
|
() ; TODO
|
||
|
|
#+mocl
|
||
|
|
() ; unknown
|
||
|
|
#+sbcl
|
||
|
|
(setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value)
|
||
|
|
#+scl
|
||
|
|
() ; TODO
|
||
|
|
new-value))
|
||
|
|
|
||
|
|
(eval-when (:load-toplevel :execute)
|
||
|
|
(export 'socket-option))
|