1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Various helpers for bsd-sockets.
6 (in-package :net.sockets
)
10 (deftype ipv4-array
() '(ub8-sarray 4))
11 (deftype ipv6-array
() '(ub16-sarray 8))
13 ;;;; Byte-swap functions
17 (logior (ash (logand (the ub16 short
) #x00FF
) 8)
18 (ash (logand (the ub16 short
) #xFF00
) -
8))
26 (logior (ash (logand (the ub32 long
) #x000000FF
) 24)
27 (ash (logand (the ub32 long
) #x0000FF00
) 8)
28 (ash (logand (the ub32 long
) #x00FF0000
) -
8)
29 (ash (logand (the ub32 long
) #xFF000000
) -
24))
35 ;;;; Conversion between address formats
37 (defun copy-simple-array-ub16-to-alien-vector (lisp-vec alien-vec
)
38 (declare (type ipv6-array lisp-vec
))
40 (setf (mem-aref alien-vec
:uint16 i
)
41 (htons (aref lisp-vec i
)))))
43 (defun map-ipv4-vector-to-ipv6 (addr)
44 (declare (type ipv4-array addr
))
45 (let ((ipv6addr (make-array 8 :element-type
'ub16
47 ;; setting the IPv4 marker
48 (setf (aref ipv6addr
5) #xFFFF
)
49 ;; setting the first two bytes
50 (setf (aref ipv6addr
6) (+ (ash (aref addr
0) 8)
52 ;; setting the last two bytes
53 (setf (aref ipv6addr
7) (+ (ash (aref addr
2) 8)
57 (defun map-ipv6-vector-to-ipv4 (addr)
58 (declare (type ipv6-array addr
))
59 (let ((ipv4addr (make-array 4 :element-type
'ub8
61 (setf (aref ipv4addr
0) (ldb (byte 8 8) (aref addr
6)))
62 (setf (aref ipv4addr
1) (ldb (byte 8 0) (aref addr
6)))
63 (setf (aref ipv4addr
2) (ldb (byte 8 8) (aref addr
7)))
64 (setf (aref ipv4addr
3) (ldb (byte 8 0) (aref addr
7)))
67 ;;; From CLOCC's PORT library.
68 (defun vector-to-integer (vector)
69 "Convert a vector to a 32-bit unsigned integer."
70 (coercef vector
'ipv4-array
)
71 (+ (ash (aref vector
0) 24)
72 (ash (aref vector
1) 16)
73 (ash (aref vector
2) 8)
76 (defun integer-to-vector (ipaddr)
77 "Convert a 32-bit unsigned integer to a vector."
78 (check-type ipaddr ub32
"an '(unsigned-byte 32)")
79 (let ((vector (make-array 4 :element-type
'ub8
)))
80 (setf (aref vector
0) (ldb (byte 8 24) ipaddr
)
81 (aref vector
1) (ldb (byte 8 16) ipaddr
)
82 (aref vector
2) (ldb (byte 8 8) ipaddr
)
83 (aref vector
3) (ldb (byte 8 0) ipaddr
))
86 (defun in6-addr-to-ipv6-array (in6-addr)
87 (let ((vector (make-array 8 :element-type
'ub16
)))
90 (ntohs (mem-aref in6-addr
:uint16 i
))))
93 ;;;; Constructors for SOCKADDR_* structs
95 (defun make-sockaddr-in (sin ub8-vector
&optional
(portno 0))
96 (declare (type ipv4-array ub8-vector
) (type ub16 portno
))
97 (bzero sin size-of-sockaddr-in
)
98 (with-foreign-slots ((family addr port
) sin sockaddr-in
)
100 (setf addr
(htonl (vector-to-integer ub8-vector
)))
101 (setf port
(htons portno
)))
104 (defmacro with-sockaddr-in
((var address
&optional
(port 0)) &body body
)
105 `(with-foreign-object (,var
'sockaddr-in
)
106 (make-sockaddr-in ,var
,address
,port
)
109 (defun make-sockaddr-in6 (sin6 ub16-vector
&optional
(portno 0))
110 (declare (type ipv6-array ub16-vector
) (type ub16 portno
))
111 (bzero sin6 size-of-sockaddr-in6
)
112 (with-foreign-slots ((family addr port
) sin6 sockaddr-in6
)
113 (setf family af-inet6
)
114 (copy-simple-array-ub16-to-alien-vector ub16-vector addr
)
115 (setf port
(htons portno
)))
118 (defmacro with-sockaddr-in6
((var address
&optional port
) &body body
)
119 `(with-foreign-object (,var
'sockaddr-in6
)
120 (make-sockaddr-in6 ,var
,address
,port
)
123 (defun make-sockaddr-un (sun string
)
124 (declare (type string string
))
125 (bzero sun size-of-sockaddr-un
)
126 (with-foreign-slots ((family path
) sun sockaddr-un
)
127 (setf family af-local
)
128 (with-foreign-string (c-string string
)
129 (loop :for off
:below
(1- unix-path-max
)
130 :do
(setf (mem-aref path
:uint8 off
)
131 (mem-aref c-string
:uint8 off
)))))
134 (defmacro with-sockaddr-un
((var address
) &body body
)
135 `(with-foreign-object (,var
'sockaddr-un
)
136 (make-sockaddr-un ,var
,address
)
139 (defmacro with-sockaddr-storage
((var) &body body
)
140 `(with-foreign-object (,var
'sockaddr-storage
)
141 (bzero ,var size-of-sockaddr-storage
)
144 (defmacro with-socklen
((var value
) &body body
)
145 `(with-foreign-object (,var
'socklen
)
146 (setf (mem-ref ,var
'socklen
) ,value
)
149 (defmacro with-sockaddr-storage-and-socklen
((ss-var size-var
) &body body
)
150 `(with-sockaddr-storage (,ss-var
)
151 (with-socklen (,size-var size-of-sockaddr-storage
)
156 (defmacro check-bounds
(sequence start end
)
157 (with-gensyms (length)
158 `(let ((,length
(length ,sequence
)))
159 (check-type ,start unsigned-byte
"a non-negative integer")
160 (check-type ,end
(or unsigned-byte null
) "a non-negative integer or NIL")
163 (unless (<= ,start
,end
,length
)
164 (error "Wrong sequence bounds. start: ~S end: ~S" ,start
,end
)))))
166 (defun %to-octets
(buff ef start end
)
167 (babel:string-to-octets buff
:start start
:end end
168 :encoding
(babel:external-format-encoding ef
)))
170 (declaim (inline ensure-number
))
171 (defun ensure-number (value &key
(start 0) end
(radix 10) (type t
) (errorp t
))
172 (check-type value
(or string unsigned-byte
) "a string or an unsigned-byte")
176 (ignore-errors (parse-integer value
:start start
:end end
177 :radix radix
:junk-allowed nil
)))
179 (if (and parsed
(typep parsed type
))
185 (defun ensure-string-or-unsigned-byte (thing &key
(type t
) (radix 10))
186 (or (and (symbolp thing
) (string-downcase thing
))
187 (ensure-number thing
:type type
:radix radix
:errorp nil
)
190 (defun lisp->c-bool
(val)
193 (defmacro multiple-value-case
((values &key
(test 'eql
)) &body body
)
194 (setf values
(ensure-list values
))
195 (when (symbolp test
) (setf test
`(quote ,test
)))
196 (assert values
() "Must provide at least one value to test")
197 (let ((test-name (alexandria::extract-function-name test
)))
198 (labels ((%do-var
(var val
)
200 ((and (symbolp var
) (member var
'("_" "*") :test
#'string
=))
203 `(member ,val
',var
:test
,test
))
205 `(,test-name
,val
',var
))))
206 (%do-clause
(c gensyms
)
207 (destructuring-bind (vals &rest code
) c
208 (let* ((tests (remove t
(mapcar #'%do-var
(ensure-list vals
) gensyms
)))
209 (clause-test (if (> 2 (length tests
))
212 `(,clause-test
,@code
))))
213 (%do-last-clause
(c gensyms
)
215 (destructuring-bind (test &rest code
) c
216 (if (member test
'(otherwise t
))
218 `(,(%do-clause c gensyms
)))))))
219 (let ((gensyms (mapcar #'(lambda (v) (gensym (string v
)))
221 `(let ,(mapcar #'list gensyms values
)
222 (declare (ignorable ,@gensyms
))
223 (cond ,@(append (mapcar #'(lambda (c) (%do-clause c gensyms
))
225 (%do-last-clause
(lastcar body
) gensyms
))))))))
227 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
228 (defun compute-flags (flags args
)
229 (loop :with flag-combination
:= 0
230 :for cons
:on args
:by
#'cddr
231 :for flag
:= (car cons
)
232 :for val
:= (cadr cons
)
233 :for const
:= (cdr (assoc flag flags
))
235 (when (not (constantp val
)) (return-from compute-flags
))
236 (setf flag-combination
(logior flag-combination const
))
237 :finally
(return flag-combination
))))
239 (defun set-function-docstring (function docstring
)
240 (setf (documentation function
'function
) docstring
))
242 (defun unset-method-docstring (gf qualifiers specializers
)
243 (setf (documentation (find-method gf qualifiers
(mapcar #'find-class specializers
)) t
) nil
))
247 (defgeneric enable-reader-macro
* (name))
249 (defgeneric disable-reader-macro
* (name))
251 (defmacro enable-reader-macro
(name)
252 `(eval-when (:compile-toplevel
)
253 (enable-reader-macro* ,name
)))
255 (defmacro disable-reader-macro
(name)
256 `(eval-when (:compile-toplevel
)
257 (disable-reader-macro* ,name
)))
259 (defun save-old-readtable (symbol readtable
)
260 (setf (getf (symbol-plist symbol
) 'old-readtable
) readtable
))
262 (defun get-old-readtable (symbol)
263 (getf (symbol-plist symbol
) 'old-readtable
))
265 (defmethod enable-reader-macro* :before
((name symbol
))
266 (save-old-readtable name
*readtable
*)
267 (setf *readtable
* (copy-readtable)))
269 (defmethod disable-reader-macro* ((name symbol
))
270 (assert (readtablep (get-old-readtable name
)))
271 (setf *readtable
* (get-old-readtable name
))
272 (save-old-readtable name nil
))
274 (defmacro define-syntax
(name &body body
)
275 `(defmethod enable-reader-macro* ((name (eql ',name
)))