0.8.0.65:
[sbcl.git] / contrib / sb-bsd-sockets / sockopt.lisp
1 (in-package :sb-bsd-sockets)
2
3 #||
4 <H2> Socket Options </h2>
5 <a name="sockopt"> </a>
6 <p> A subset of socket options are supported, using a fairly
7 general framework which should make it simple to add more as required 
8 - see sockopt.lisp for details.  The name mapping from C is fairly
9 straightforward: <tt>SO_RCVLOWAT</tt> becomes
10 <tt>sockopt-receive-low-water</tt> and <tt>(setf
11 sockopt-receive-low-water)</tt>.
12 ||#
13
14 #|
15 getsockopt(socket, level, int optname, void *optval, socklen_t *optlen)
16 setsockopt(socket, level, int optname, void *optval, socklen_t optlen)
17              ^ SOL_SOCKET or a protocol number
18
19 In terms of providing a useful interface, we have to face up to the
20 fact that most of these take different data types - some are integers,
21 some are booleans, some are foreign struct instances, etc etc
22
23 (define-socket-option lisp-name level number mangle-arg size mangle-return)
24
25 macro-expands to two functions that define lisp-name and (setf ,lisp-name)
26 and calls the functions mangle-arg and mangle-return on outgoing and incoming
27 data resp.
28
29 Parameters passed to the function thus defined (lisp-name)
30 are all passed directly into mangle-arg.  mangle-arg should return an
31 alien pointer  - this is passed unscathed to the foreign routine, so
32 wants to have type (* t).  Note that even for options that have
33 integer arguments, this is still a pointer to said integer.
34
35 size is the size of the buffer that the return of mangle-arg points
36 to, and also of the buffer that we should allocate for getsockopt 
37 to write into.
38
39 mangle-return is called with an alien buffer and should turn it into
40 something that the caller will want.
41
42 Code for options that not every system has should be conditionalised:
43
44 (if (boundp 'sockint::IP_RECVIF)
45     (define-socket-option so-receive-interface (getprotobyname "ip")
46       sockint::IP_RECVIF  ...  ))
47
48
49 |#
50
51 (defmacro define-socket-option
52   (lisp-name level number mangle-arg size mangle-return)
53   (let ((find-level
54          (if (numberp (eval level))
55              level
56              `(get-protocol-by-name ,(string-downcase (symbol-name level))))))
57     `(progn
58       (export ',lisp-name)
59       (defun ,lisp-name (socket &aux (fd (socket-file-descriptor socket)))
60         (sb-sys:without-gcing
61          (let ((buf (make-array sockint::size-of-int
62                                 :element-type '(unsigned-byte 8)
63                                 :initial-element 0)))
64            (if (= -1 (sockint::getsockopt
65                       fd ,find-level ,number (sockint::array-data-address buf) ,size))
66                (socket-error "getsockopt")
67                (,mangle-return buf ,size)))))
68       (defun (setf ,lisp-name) (new-val socket
69                                 &aux (fd (socket-file-descriptor socket)))
70         (if (= -1
71                (sb-sys:without-gcing
72                 (sockint::setsockopt
73                  fd ,find-level ,number (funcall (function ,mangle-arg) new-val ,size)
74                  ,size)))
75             (socket-error "setsockopt"))))))
76
77 ;;; sockopts that have integer arguments
78
79 (defun int-to-foreign (x size)
80   ;; can't use with-alien, as the variables it creates only have
81   ;; dynamic scope.  can't use the passed-in size because sap-alien
82   ;; is a macro and evaluates its second arg at read time
83   (let* ((v (make-array size :element-type '(unsigned-byte 8)
84                         :initial-element 0))
85          (d (sockint::array-data-address v))
86          (alien (sb-alien:sap-alien
87                  d; (sb-sys:int-sap d)
88                  (* (sb-alien:signed #.(* 8 sockint::size-of-int))))))
89     (setf (sb-alien:deref alien 0) x)
90     alien))
91
92 (defun buffer-to-int (x size)
93   (declare (ignore size))
94   (let ((alien (sb-alien:sap-alien
95                 (sockint::array-data-address x)
96                 (* (sb-alien:signed #.(* 8 sockint::size-of-int))))))
97     (sb-alien:deref alien)))
98
99 (defmacro define-socket-option-int (name level number)
100   `(define-socket-option ,name ,level ,number
101      int-to-foreign sockint::size-of-int buffer-to-int))
102
103 (define-socket-option-int
104   sockopt-receive-low-water sockint::sol-socket sockint::so-rcvlowat)
105 (define-socket-option-int
106   sockopt-send-low-water sockint::sol-socket sockint::so-sndlowat)
107 (define-socket-option-int
108   sockopt-type sockint::sol-socket sockint::so-type)
109 (define-socket-option-int
110   sockopt-send-buffer sockint::sol-socket sockint::so-sndbuf)
111 (define-socket-option-int
112   sockopt-receive-buffer sockint::sol-socket sockint::so-rcvbuf)
113 (define-socket-option-int
114   sockopt-priority sockint::sol-socket sockint::so-priority)
115
116 ;;; boolean options are integers really
117
118 (defun bool-to-foreign (x size)
119   (int-to-foreign (if x 1 0) size))
120
121 (defun buffer-to-bool (x size)
122   (not (= (buffer-to-int x size) 0)))
123
124 (defmacro define-socket-option-bool (name level number)
125   `(define-socket-option ,name ,level ,number
126      bool-to-foreign sockint::size-of-int buffer-to-bool))
127
128 (define-socket-option-bool
129   sockopt-reuse-address sockint::sol-socket sockint::so-reuseaddr)
130 (define-socket-option-bool
131   sockopt-keep-alive sockint::sol-socket sockint::so-keepalive)
132 (define-socket-option-bool
133   sockopt-oob-inline sockint::sol-socket sockint::so-oobinline)
134 (define-socket-option-bool
135   sockopt-bsd-compatible sockint::sol-socket sockint::so-bsdcompat)
136 (define-socket-option-bool
137   sockopt-pass-credentials sockint::sol-socket sockint::so-passcred)
138 (define-socket-option-bool
139   sockopt-debug sockint::sol-socket sockint::so-debug)
140 (define-socket-option-bool
141   sockopt-dont-route sockint::sol-socket sockint::so-dontroute)
142 (define-socket-option-bool
143   sockopt-broadcast sockint::sol-socket sockint::so-broadcast)
144
145 (define-socket-option-bool sockopt-tcp-nodelay :tcp sockint::tcp-nodelay)
146
147 (defun string-to-foreign (string size)
148   (declare (ignore size))
149   (let ((data (sockint::array-data-address string)))
150     (sb-alien:sap-alien data (* t))))
151                                                          
152 (defun buffer-to-string (x size)
153   (declare (ignore size))
154   (sb-c-call::%naturalize-c-string
155    (sockint::array-data-address x)))
156
157 (define-socket-option sockopt-bind-to-device sockint::sol-socket
158   sockint::so-bindtodevice string-to-foreign sockint::ifnamsiz
159   buffer-to-string)
160
161 ;;; other kinds of socket option
162
163 ;;; so_peercred takes a ucre structure
164 ;;; so_linger struct linger {
165 ;                  int   l_onoff;    /* linger active */
166 ;                  int   l_linger;   /* how many seconds to linger for */
167 ;              };
168
169 #|
170
171 (sockopt-reuse-address 2)
172
173 (defun echo-server ()
174   (let ((s (make-inet-socket :stream (get-protocol-by-name "tcp"))))
175     (setf (sockopt-reuse-address s) t)
176     (setf (sockopt-bind-to-device s) "lo")
177     (socket-bind s (make-inet-address "127.0.0.1") 3459)
178     (socket-listen s 5)
179     (dotimes (i 10)
180       (let* ((s1 (socket-accept s))
181              (stream (socket-make-stream s1 :input t :output t :buffering :none)))
182         (let ((line (read-line stream)))
183           (format t "got one ~A ~%" line)
184           (format stream "~A~%" line))
185         (close stream)))))
186
187 NIL
188 |#
189