1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Various helpers for bsd-sockets.
6 (in-package :iolib
/sockets
)
10 (deftype ipv4-array
() '(ub8-sarray 4))
11 (deftype ipv6-array
() '(ub16-sarray 8))
13 ;;;; Conversion between address formats
15 (defun copy-simple-array-ub16-to-alien-vector (lisp-vec alien-vec
)
16 (declare (type ipv6-array lisp-vec
))
18 (setf (mem-aref alien-vec
:uint16 i
)
19 (htons (aref lisp-vec i
)))))
21 (defun map-ipv4-vector-to-ipv6 (addr)
22 (declare (type ipv4-array addr
))
23 (let ((ipv6addr (make-array 8 :element-type
'ub16
25 ;; setting the IPv4 marker
26 (setf (aref ipv6addr
5) #xFFFF
)
27 ;; setting the first two bytes
28 (setf (aref ipv6addr
6) (+ (ash (aref addr
0) 8)
30 ;; setting the last two bytes
31 (setf (aref ipv6addr
7) (+ (ash (aref addr
2) 8)
35 (defun map-ipv6-vector-to-ipv4 (addr)
36 (declare (type ipv6-array addr
))
37 (let ((ipv4addr (make-array 4 :element-type
'ub8
39 (setf (aref ipv4addr
0) (ldb (byte 8 8) (aref addr
6)))
40 (setf (aref ipv4addr
1) (ldb (byte 8 0) (aref addr
6)))
41 (setf (aref ipv4addr
2) (ldb (byte 8 8) (aref addr
7)))
42 (setf (aref ipv4addr
3) (ldb (byte 8 0) (aref addr
7)))
45 ;;; From CLOCC's PORT library.
46 (defun vector-to-integer (vector)
47 "Convert a vector to a 32-bit unsigned integer."
48 (coercef vector
'ipv4-array
)
49 (+ (ash (aref vector
0) 24)
50 (ash (aref vector
1) 16)
51 (ash (aref vector
2) 8)
54 (defun integer-to-vector (ipaddr)
55 "Convert a 32-bit unsigned integer to a vector."
56 (check-type ipaddr ub32
"an '(unsigned-byte 32)")
57 (let ((vector (make-array 4 :element-type
'ub8
)))
58 (setf (aref vector
0) (ldb (byte 8 24) ipaddr
)
59 (aref vector
1) (ldb (byte 8 16) ipaddr
)
60 (aref vector
2) (ldb (byte 8 8) ipaddr
)
61 (aref vector
3) (ldb (byte 8 0) ipaddr
))
64 (defun in6-addr-to-ipv6-array (in6-addr)
65 (let ((vector (make-array 8 :element-type
'ub16
)))
68 (ntohs (mem-aref in6-addr
:uint16 i
))))
71 ;;;; Constructors for SOCKADDR_* structs
73 (defun make-sockaddr-in (sin ub8-vector
&optional
(portno 0))
74 (declare (type ipv4-array ub8-vector
) (type ub16 portno
))
75 (isys:bzero sin
(isys:sizeof
'sockaddr-in
))
76 (with-foreign-slots ((family addr port
) sin sockaddr-in
)
78 (setf addr
(htonl (vector-to-integer ub8-vector
)))
79 (setf port
(htons portno
)))
82 (defmacro with-sockaddr-in
((var address
&optional
(port 0)) &body body
)
83 `(with-foreign-object (,var
'sockaddr-in
)
84 (make-sockaddr-in ,var
,address
,port
)
87 (defun make-sockaddr-in6 (sin6 ub16-vector
&optional
(portno 0))
88 (declare (type ipv6-array ub16-vector
) (type ub16 portno
))
89 (isys:bzero sin6
(isys:sizeof
'sockaddr-in6
))
90 (with-foreign-slots ((family addr port
) sin6 sockaddr-in6
)
91 (setf family af-inet6
)
92 (copy-simple-array-ub16-to-alien-vector ub16-vector addr
)
93 (setf port
(htons portno
)))
96 (defmacro with-sockaddr-in6
((var address
&optional port
) &body body
)
97 `(with-foreign-object (,var
'sockaddr-in6
)
98 (make-sockaddr-in6 ,var
,address
,port
)
101 (defun make-sockaddr-un (sun string abstract
)
102 (declare (type string string
))
103 (isys:bzero sun
(isys:sizeof
'sockaddr-un
))
104 (with-foreign-slots ((family path
) sun sockaddr-un
)
105 (setf family af-local
)
106 (let* ((address-string
107 (concatenate 'string
(when abstract
(string #\Null
)) string
))
108 (path-length (length address-string
))
111 (- (isys:sizeof
'sockaddr-un
)
112 (foreign-slot-offset 'sockaddr-un
'path
)))))
113 (assert (< path-length sun-path-len
))
114 (with-foreign-string (c-string address-string
:null-terminated-p nil
)
115 (isys:memcpy
(foreign-slot-pointer sun
'sockaddr-un
'path
)
116 c-string path-length
))))
119 (defun actual-size-of-sockaddr-un (sun)
120 (let ((path-ptr (foreign-slot-pointer sun
'sockaddr-un
'path
))
123 (- (isys:sizeof
'sockaddr-un
)
124 (foreign-slot-offset 'sockaddr-un
'path
)))))
125 (loop :for i
:from
1 :below sun-path-len
126 :if
(zerop (mem-aref path-ptr
:char i
))
127 :do
(return (+ i
(foreign-slot-offset 'sockaddr-un
'path
)))
128 :finally
(bug "Invalid sockaddr_un struct: slot sun_path contains invalid C string"))))
130 (defmacro with-sockaddr-un
((var address abstract
) &body body
)
131 `(with-foreign-object (,var
'sockaddr-un
)
132 (make-sockaddr-un ,var
,address
,abstract
)
136 (defun make-sockaddr-nl (snl multicast-groups
&optional
(portno 0))
137 (declare (type ub32 multicast-groups
)
139 (isys:bzero snl
(isys:sizeof
'sockaddr-nl
))
140 (with-foreign-slots ((family groups port
) snl sockaddr-nl
)
141 (setf family af-netlink
)
142 (setf groups multicast-groups
)
147 (defmacro with-sockaddr-nl
((var multicast-groups
&optional
(port 0)) &body body
)
148 `(with-foreign-object (,var
'sockaddr-nl
)
149 (make-sockaddr-nl ,var
,multicast-groups
,port
)
152 (defmacro with-sockaddr-storage
((var) &body body
)
153 `(with-foreign-object (,var
'sockaddr-storage
)
154 (isys:bzero
,var
(isys:sizeof
'sockaddr-storage
))
157 (defmacro with-socklen
((var value
) &body body
)
158 `(with-foreign-object (,var
'socklen-t
)
159 (setf (mem-aref ,var
'socklen-t
) ,value
)
162 (defmacro with-sockaddr-storage-and-socklen
((ss-var size-var
) &body body
)
163 `(with-sockaddr-storage (,ss-var
)
164 (with-socklen (,size-var
(isys:sizeof
'sockaddr-storage
))
169 (defun ensure-number (value &key
(start 0) end
(radix 10) (type t
) (errorp t
))
173 (ignore-errors (parse-integer value
:start start
:end end
174 :radix radix
:junk-allowed nil
)))
177 ((typep parsed type
) parsed
)
178 (errorp (error 'parse-error
)))))
180 (defun ensure-string-or-unsigned-byte (thing &key
(type t
) (radix 10) (errorp t
))
181 (or (and (symbolp thing
) (string-downcase thing
))
182 (ensure-number thing
:type type
:radix radix
:errorp nil
)
183 (and (stringp thing
) thing
)
184 (if errorp
(error 'parse-error
) nil
)))
186 (defun lisp->c-bool
(val)
189 ;; FIXME: perhaps return some very large value instead of NIL
190 (defun wait->timeout
(wait)
196 (defun compute-flags (flags args
&optional env
)
197 (loop :with flag-combination
:= 0
198 :for cons
:on args
:by
#'cddr
199 :for flag
:= (car cons
)
200 :for val
:= (cadr cons
)
201 :for const
:= (cdr (assoc flag flags
))
203 :do
(when (not (constantp val env
)) (return* nil
))
204 (setf flag-combination
(logior flag-combination const
))
205 :finally
(return flag-combination
)))
207 (defun set-function-docstring (function docstring
)
208 (setf (documentation function
'function
) docstring
))
210 (defun unset-method-docstring (gf qualifiers specializers
)
211 (setf (documentation (find-method gf qualifiers
(mapcar #'find-class specializers
)) t
) nil
))