1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
3 ;; Copyright (C) 2006, 2007 Stelian Ionescu
5 ;; This code is free software; you can redistribute it and/or
6 ;; modify it under the terms of the version 2.1 of
7 ;; the GNU Lesser General Public License as published by
8 ;; the Free Software Foundation, as clarified by the
9 ;; preamble found here:
10 ;; http://opensource.franz.com/preamble.html
12 ;; This program is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
17 ;; You should have received a copy of the GNU Lesser General
18 ;; Public License along with this library; if not, write to the
19 ;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
20 ;; Boston, MA 02110-1301, USA
22 (in-package :net.sockets
)
24 ;; TODO: manage socket options errors
25 (defun sockopt-error (retval level option action
&optional val1 val2
)
26 (declare (ignore retval level option action val1 val2
))
27 (error "Sockopt error !"))
33 (defun set-socket-option-bool (fd level option value
)
34 (with-foreign-object (optval :int
)
35 (setf (mem-ref optval
:int
) (lisp->c-bool value
))
36 (et:setsockopt fd level option optval et
:size-of-int
)
39 (defun set-socket-option-int (fd level option value
)
40 (with-foreign-object (optval :int
)
41 (setf (mem-ref optval
:int
) value
)
42 (et:setsockopt fd level option optval et
:size-of-int
)
45 (defun set-socket-option-linger (fd level option onoff linger
)
46 (with-foreign-object (optval 'et
:linger
)
47 (with-foreign-slots ((et:linger et
:onoff
) optval et
:linger
)
48 (setf et
:onoff
(lisp->c-bool onoff
)
50 (et:setsockopt fd level option optval et
:size-of-linger
)
53 (defun set-socket-option-timeval (fd level option sec usec
)
54 (with-foreign-object (optval 'et
:timeval
)
55 (with-foreign-slots ((et:sec et
:usec
) optval et
:timeval
)
58 (et:setsockopt fd level option optval et
:size-of-timeval
)
65 (defun get-socket-option-bool (fd level option
)
66 (with-foreign-objects ((optval :int
)
68 (setf (mem-ref optlen
:socklen
) et
:size-of-int
)
69 (et:getsockopt fd level option optval optlen
)
70 (values (c->lisp-bool
(mem-ref optval
:int
)))))
72 (defun get-socket-option-int (fd level option
)
73 (with-foreign-objects ((optval :int
)
75 (setf (mem-ref optlen
:socklen
) et
:size-of-int
)
76 (et:getsockopt fd level option optval optlen
)
77 (values (mem-ref optval
:int
))))
79 (defun get-socket-option-linger (fd level option
)
80 (with-foreign-objects ((optval 'et
:linger
)
82 (setf (mem-ref optlen
:socklen
) et
:size-of-linger
)
83 (et:getsockopt fd level option optval optlen
)
84 (with-foreign-slots ((et:linger et
:onoff
) optval et
:linger
)
85 (values (c->lisp-bool et
:onoff
) et
:linger
))))
87 (defun get-socket-option-timeval (fd level option
)
88 (with-foreign-objects ((optval 'et
:timeval
)
90 (setf (mem-ref optlen
:socklen
) et
:size-of-timeval
)
91 (et:getsockopt fd level option optval optlen
)
92 (with-foreign-slots ((et:sec et
:usec
) optval et
:timeval
)
93 (values et
:sec et
:usec
))))
100 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
101 (defun make-sockopt-helper-name (action value-type
)
102 (concat-symbol action
106 (defvar +helper-args-map
+
109 (:linger
(onoff linger
))
110 (:timeval
(sec usec
)))))
112 (defmacro define-get-sockopt
(os eql-name helper-get level optname
)
113 `(defmethod get-socket-option ((socket socket
) (option-name (eql ,eql-name
)))
114 ,(if (member os
*features
*)
115 `(with-socket-error-filter
116 (,helper-get
(socket-fd socket
) ,level
,optname
))
117 `(error 'option-not-available option-name
))))
119 (defmacro define-set-sockopt
(os eql-name args helper-set level optname
)
120 `(defmethod set-socket-option ((socket socket
) (option-name (eql ,eql-name
)) &key
,@args
)
121 ,@(if (member os
*features
*)
122 `((with-socket-error-filter
123 (,helper-set
(socket-fd socket
) ,level
,optname
,@args
)))
124 `((declare (ignore ,@args
))
125 (error 'option-not-available option-name
)))))
127 (defmacro define-socket-option
(name action optname level argtype os
)
128 (declare (type symbol action
)
129 (type symbol argtype
)
131 (let ((eql-name (ensure-keyword name
))
132 (args (second (assoc argtype
+helper-args-map
+)))
133 (helper-get (make-sockopt-helper-name :get argtype
))
134 (helper-set (make-sockopt-helper-name :set argtype
)))
138 (when (member action
(list :get
:get-and-set
))
139 `(define-get-sockopt ,os
,eql-name
,helper-get
,level
,optname
))
140 (when (member action
(list :set
:get-and-set
))
141 `(define-set-sockopt ,os
,eql-name
,args
,helper-set
,level
,optname
)))))))
143 ;;;;;;;;;;;;;;;;;;;;;
144 ;; Generic options ;;
145 ;;;;;;;;;;;;;;;;;;;;;
146 (define-socket-option accept-connections
:get et
:so-acceptconn et
:sol-socket
:bool
:unix
)
147 (define-socket-option broadcast
:get-and-set et
:so-broadcast et
:sol-socket
:bool
:unix
)
148 (define-socket-option debug
:get-and-set et
:so-debug et
:sol-socket
:bool
:unix
)
149 (define-socket-option dont-route
:get-and-set et
:so-dontroute et
:sol-socket
:bool
:unix
)
150 (define-socket-option error
:get et
:so-error et
:sol-socket
:int
:unix
)
151 (define-socket-option keep-alive
:get-and-set et
:so-keepalive et
:sol-socket
:bool
:unix
)
152 (define-socket-option linger
:get-and-set et
:so-linger et
:sol-socket
:linger
:unix
)
153 (define-socket-option oob-inline
:get-and-set et
:so-oobinline et
:sol-socket
:bool
:unix
)
154 (define-socket-option receive-buffer
:get-and-set et
:so-rcvbuf et
:sol-socket
:int
:unix
)
155 (define-socket-option send-buffer
:get-and-set et
:so-sndbuf et
:sol-socket
:int
:unix
)
156 (define-socket-option receive-low-water
:get-and-set et
:so-rcvlowat et
:sol-socket
:int
:unix
)
157 (define-socket-option send-low-water
:get-and-set et
:so-sndlowat et
:sol-socket
:int
:unix
)
158 (define-socket-option receive-timeout
:get-and-set et
:so-rcvtimeo et
:sol-socket
:timeval
:unix
)
159 (define-socket-option send-timeout
:get-and-set et
:so-sndtimeo et
:sol-socket
:timeval
:unix
)
160 (define-socket-option reuse-address
:get-and-set et
:so-reuseaddr et
:sol-socket
:bool
:unix
)
161 (define-socket-option type
:get et
:so-type et
:sol-socket
:int
:unix
)
163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
164 ;; Linux-specific options ;;
165 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
166 (define-socket-option bsd-compatible
:set et
:so-bsdcompat et
:sol-socket
:bool
:linux
)
167 (define-socket-option bind-to-device
:set et
:so-bindtodevice et
:sol-socket
:int
:linux
)
168 (define-socket-option priority
:get-and-set et
:so-priority et
:sol-socket
:int
:linux
)
170 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
171 ;; FreeBSD-specific options ;;
172 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
173 (define-socket-option reuse-port
:get-and-set et
:so-reuseport et
:sol-socket
:bool
:freebsd
)
174 (define-socket-option use-loopback
:get-and-set et
:so-useloopback et
:sol-socket
:bool
:freebsd
)
175 (define-socket-option no-sigpipe
:get-and-set et
:so-nosigpipe et
:sol-socket
:bool
:freebsd
)
178 ;;;;;;;;;;;;;;;;;;;;;;;;
180 ;;; Still to be done ;;;
182 ;;;;;;;;;;;;;;;;;;;;;;;;
184 ;; TODO: implement "struct ucred" helpers
186 ;; (define-socket-option pass-credentials :get-and-set et:so-passcred et:sol-socket :ucred :freebsd)
187 ;; (define-socket-option peer-credentials :get et:so-peercred et:sol-socket :ucred :freebsd)
190 ;; TODO: implement "struct accept_filter_arg" helpers
192 ;; (define-socket-option accept-filter :get-and-set et:so-acceptfilter et:sol-socket :accept-filter :freebsd)
194 ;; TODO: find out the types of these options
196 ;; (define-socket-option bintime :get-and-set et:so-bintime et:sol-socket :bool :freebsd)
197 ;; (define-socket-option label :get-and-set et:so-label et:sol-socket :bool :freebsd)
198 ;; (define-socket-option peerlabel :get-and-set et:so-peerlabel et:sol-socket :bool :freebsd)
199 ;; (define-socket-option listen-queue-limit :get-and-set et:so-listenqlimit et:sol-socket :int :freebsd)
200 ;; (define-socket-option listen-queue-length :get-and-set et:so-listenqlen et:sol-socket :int :freebsd)
201 ;; (define-socket-option listen-incomplete-queue-length :get-and-set et:so-listenincqlen et:sol-socket :int :freebsd)