option.lisp 9.68 KB
Newer Older
1
;;;; SOCKET-OPTION, a high-level socket option get/set framework
2 3 4 5 6

;;;; See LICENSE for licensing information.

(in-package :usocket)

7 8 9
;; put here because option.lisp is for native backend only
(defparameter *backend* :native)

10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37
;;; 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))

38
;;; Socket option: RECEIVE-TIMEOUT (SO_RCVTIMEO)
39 40 41

(defmethod socket-option ((usocket stream-usocket)
                          (option (eql :receive-timeout)) &key)
42
  (declare (ignorable option))
43
  (let ((socket (socket usocket)))
44
    (declare (ignorable socket))
45 46 47 48 49 50 51 52 53 54
    #+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))
55
    #+(or ecl clasp)
56 57 58 59 60
    (sb-bsd-sockets:sockopt-receive-timeout socket)
    #+lispworks
    (get-socket-receive-timeout socket)
    #+mcl
    () ; TODO
61 62
    #+mocl
    () ; unknown
63 64 65
    #+sbcl
    (sb-impl::fd-stream-timeout (socket-stream usocket))
    #+scl
66
    ())) ; TODO
67 68 69

(defmethod (setf socket-option) (new-value (usocket stream-usocket)
                                           (option (eql :receive-timeout)) &key)
70
  (declare (type number new-value) (ignorable new-value option))
71 72
  (let ((socket (socket usocket))
        (timeout new-value))
73
    (declare (ignorable socket timeout))
74 75 76 77 78 79 80 81 82 83 84
    #+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))
85
    #+(or ecl clasp)
86 87 88 89 90
    (setf (sb-bsd-sockets:sockopt-receive-timeout socket) timeout)
    #+lispworks
    (set-socket-receive-timeout socket timeout)
    #+mcl
    () ; TODO
91 92
    #+mocl
    () ; unknown
93 94 95 96
    #+sbcl
    (setf (sb-impl::fd-stream-timeout (socket-stream usocket))
          (coerce timeout 'single-float))
    #+scl
97
    () ; TODO
98
    new-value))
99

100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
;;; 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))
117
    #+(or ecl clasp)
118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
    (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))
147
    #+(or ecl clasp)
148 149 150 151 152 153 154 155 156 157 158 159 160 161
    (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))

162 163 164 165 166 167 168 169
;;; 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
170
    () ; TODO
171
    #+allegro
172
    () ; TODO
173
    #+clisp
174
    (int->bool (socket:socket-options socket :so-reuseaddr))
175
    #+clozure
176
    (int->bool (get-socket-option-reuseaddr socket))
177
    #+cmu
178
    () ; TODO
179
    #+lispworks
180
    (get-socket-reuse-address socket)
181
    #+mcl
182
    () ; TODO
183 184
    #+mocl
    () ; unknown
185
    #+(or ecl sbcl clasp)
186 187
    (sb-bsd-sockets:sockopt-reuse-address socket)
    #+scl
188
    ())) ; TODO
189 190 191 192 193 194 195

(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
196 197 198
    () ; TODO
    #+allegro
    (socket:set-socket-options socket option new-value)
199
    #+clisp
200
    (socket:socket-options socket :so-reuseaddr (bool->int new-value))
201
    #+clozure
202
    (set-socket-option-reuseaddr socket (bool->int new-value))
203
    #+cmu
204
    () ; TODO
205
    #+lispworks
206
    (set-socket-reuse-address socket new-value)
207
    #+mcl
208
    () ; TODO
209 210
    #+mocl
    () ; unknown
211
    #+(or ecl sbcl clasp)
212 213
    (setf (sb-bsd-sockets:sockopt-reuse-address socket) new-value)
    #+scl
214
    () ; TODO
215 216 217 218 219 220 221 222 223 224
    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
225 226 227
    () ; TODO
    #+allegro
    () ; TODO
228
    #+clisp
229
    (int->bool (socket:socket-options socket :so-broadcast))
230
    #+clozure
231
    (int->bool (get-socket-option-broadcast socket))
232
    #+cmu
233
    () ; TODO
234
    #+(or ecl clasp)
235
    () ; TODO
236
    #+lispworks
237
    () ; TODO
238
    #+mcl
239
    () ; TODO
240 241
    #+mocl
    () ; unknown
242
    #+sbcl
243 244
    (sb-bsd-sockets:sockopt-broadcast socket)
    #+scl
245
    ())) ; TODO
246 247 248

(defmethod (setf socket-option) (new-value (usocket datagram-usocket)
                                           (option (eql :broadcast)) &key)
249 250
  (declare (type boolean new-value)
           (ignorable new-value option))
251 252 253
  (let ((socket (socket usocket)))
    (declare (ignorable socket))
    #+abcl
254 255 256
    () ; TODO
    #+allegro
    (socket:set-socket-options socket option new-value)
257
    #+clisp
258
    (socket:socket-options socket :so-broadcast (bool->int new-value))
259
    #+clozure
260
    (set-socket-option-broadcast socket (bool->int new-value))
261
    #+cmu
262
    () ; TODO
263
    #+(or ecl clasp)
264
    () ; TODO
265
    #+lispworks
266
    () ; TODO
267
    #+mcl
268
    () ; TODO
269 270
    #+mocl
    () ; unknown
271
    #+sbcl
272 273
    (setf (sb-bsd-sockets:sockopt-broadcast socket) new-value)
    #+scl
274
    () ; TODO
275
    new-value))
276

277
;;; Socket option: TCP-NODELAY (TCP_NODELAY), for TCP client
278 279 280

(defmethod socket-option ((usocket stream-usocket)
                          (option (eql :tcp-no-delay)) &key)
281
  (declare (ignorable option))
282 283 284 285
  (socket-option usocket :tcp-nodelay))

(defmethod socket-option ((usocket stream-usocket)
                          (option (eql :tcp-nodelay)) &key)
286 287 288 289 290 291 292 293 294 295 296 297 298
  (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
    ()
299
    #+(or ecl clasp)
300 301
    (sb-bsd-sockets::sockopt-tcp-nodelay socket)
    #+lispworks
302
    (int->bool (get-socket-tcp-nodelay socket))
303 304
    #+mcl
    () ; TODO
305 306
    #+mocl
    () ; unknown
307 308 309 310 311 312 313
    #+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)
314
  (declare (ignorable option))
315 316 317 318
  (setf (socket-option usocket :tcp-nodelay) new-value))

(defmethod (setf socket-option) (new-value (usocket stream-usocket)
                                           (option (eql :tcp-nodelay)) &key)
319 320
  (declare (type boolean new-value)
           (ignorable new-value option))
321 322 323 324 325 326 327 328 329 330 331 332
  (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
    ()
333
    #+(or ecl clasp)
334 335
    (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value)
    #+lispworks
336
    (progn
337
      #-(or lispworks4 lispworks5.0)
338
      (comm::set-socket-tcp-nodelay socket new-value)
339
      #+(or lispworks4 lispworks5.0)
340
      (set-socket-tcp-nodelay socket (bool->int new-value)))
341 342
    #+mcl
    () ; TODO
343 344
    #+mocl
    () ; unknown
345 346 347 348 349
    #+sbcl
    (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value)
    #+scl
    () ; TODO
    new-value))
350 351 352

(eval-when (:load-toplevel :execute)
  (export 'socket-option))