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