option.lisp 9.76 KB
Newer Older
1
;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET -*-
2
;;;; SOCKET-OPTION, a high-level socket option get/set framework
ctian's avatar
ctian committed
3 4 5 6 7

;;;; See LICENSE for licensing information.

(in-package :usocket)

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

ctian's avatar
ctian committed
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 38
;;; 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))

39
;;; Socket option: RECEIVE-TIMEOUT (SO_RCVTIMEO)
ctian's avatar
ctian committed
40 41 42

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

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

101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
;;; 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))
118
    #+(or ecl clasp)
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 147
    (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))
148
    #+(or ecl clasp)
149 150 151 152 153 154 155 156 157 158 159 160 161 162
    (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))

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

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

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

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

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

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

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

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