1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; common.lisp --- Various helpers for bsd-sockets.
5 ;;; Copyright (C) 2006-2008, Stelian Ionescu <sionescu@common-lisp.net>
7 ;;; This code is free software; you can redistribute it and/or
8 ;;; modify it under the terms of the version 2.1 of
9 ;;; the GNU Lesser General Public License as published by
10 ;;; the Free Software Foundation, as clarified by the
11 ;;; preamble found here:
12 ;;; http://opensource.franz.com/preamble.html
14 ;;; This program is distributed in the hope that it will be useful,
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;;; GNU General Public License for more details.
19 ;;; You should have received a copy of the GNU Lesser General
20 ;;; Public License along with this library; if not, write to the
21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
22 ;;; Boston, MA 02110-1301, USA
24 (in-package :net.sockets
)
28 (deftype ipv4-array
() '(ub8-sarray 4))
29 (deftype ipv6-array
() '(ub16-sarray 8))
31 ;;;; Byte-swap functions
35 (logior (ash (logand (the ub16 short
) #x00FF
) 8)
36 (ash (logand (the ub16 short
) #xFF00
) -
8))
44 (logior (ash (logand (the ub32 long
) #x000000FF
) 24)
45 (ash (logand (the ub32 long
) #x0000FF00
) 8)
46 (ash (logand (the ub32 long
) #x00FF0000
) -
8)
47 (ash (logand (the ub32 long
) #xFF000000
) -
24))
53 ;;;; Conversion between address formats
55 (defun copy-simple-array-ub16-to-alien-vector (lisp-vec alien-vec
)
56 (declare (type ipv6-array lisp-vec
))
58 (setf (mem-aref alien-vec
:uint16 i
)
59 (htons (aref lisp-vec i
)))))
61 (defun map-ipv4-vector-to-ipv6 (addr)
62 (declare (type ipv4-array addr
))
63 (let ((ipv6addr (make-array 8 :element-type
'ub16
65 ;; setting the IPv4 marker
66 (setf (aref ipv6addr
5) #xFFFF
)
67 ;; setting the first two bytes
68 (setf (aref ipv6addr
6) (+ (ash (aref addr
0) 8)
70 ;; setting the last two bytes
71 (setf (aref ipv6addr
7) (+ (ash (aref addr
2) 8)
75 (defun map-ipv6-vector-to-ipv4 (addr)
76 (declare (type ipv6-array addr
))
77 (let ((ipv4addr (make-array 4 :element-type
'ub8
79 (setf (aref ipv4addr
0) (ldb (byte 8 8) (aref addr
6)))
80 (setf (aref ipv4addr
1) (ldb (byte 8 0) (aref addr
6)))
81 (setf (aref ipv4addr
2) (ldb (byte 8 8) (aref addr
7)))
82 (setf (aref ipv4addr
3) (ldb (byte 8 0) (aref addr
7)))
85 ;;; From CLOCC's PORT library.
86 (defun vector-to-integer (vector)
87 "Convert a vector to a 32-bit unsigned integer."
88 (coercef vector
'ipv4-array
)
89 (+ (ash (aref vector
0) 24)
90 (ash (aref vector
1) 16)
91 (ash (aref vector
2) 8)
94 (defun integer-to-vector (ipaddr)
95 "Convert a 32-bit unsigned integer to a vector."
96 (check-type ipaddr ub32
"an '(unsigned-byte 32)")
97 (let ((vector (make-array 4 :element-type
'ub8
)))
98 (setf (aref vector
0) (ldb (byte 8 24) ipaddr
)
99 (aref vector
1) (ldb (byte 8 16) ipaddr
)
100 (aref vector
2) (ldb (byte 8 8) ipaddr
)
101 (aref vector
3) (ldb (byte 8 0) ipaddr
))
104 (defun in6-addr-to-ipv6-array (in6-addr)
105 (let ((vector (make-array 8 :element-type
'ub16
)))
107 (setf (aref vector i
)
108 (ntohs (mem-aref in6-addr
:uint16 i
))))
111 ;;;; Constructors for SOCKADDR_* structs
113 (defun make-sockaddr-in (sin ub8-vector
&optional
(portno 0))
114 (declare (type ipv4-array ub8-vector
) (type ub16 portno
))
115 (bzero sin size-of-sockaddr-in
)
116 (with-foreign-slots ((family addr port
) sin sockaddr-in
)
117 (setf family af-inet
)
118 (setf addr
(htonl (vector-to-integer ub8-vector
)))
119 (setf port
(htons portno
)))
122 (defmacro with-sockaddr-in
((var address
&optional
(port 0)) &body body
)
123 `(with-foreign-object (,var
'sockaddr-in
)
124 (make-sockaddr-in ,var
,address
,port
)
127 (defun make-sockaddr-in6 (sin6 ub16-vector
&optional
(portno 0))
128 (declare (type ipv6-array ub16-vector
) (type ub16 portno
))
129 (bzero sin6 size-of-sockaddr-in6
)
130 (with-foreign-slots ((family addr port
) sin6 sockaddr-in6
)
131 (setf family af-inet6
)
132 (copy-simple-array-ub16-to-alien-vector ub16-vector addr
)
133 (setf port
(htons portno
)))
136 (defmacro with-sockaddr-in6
((var address
&optional port
) &body body
)
137 `(with-foreign-object (,var
'sockaddr-in6
)
138 (make-sockaddr-in6 ,var
,address
,port
)
141 (defun make-sockaddr-un (sun string
)
142 (declare (type string string
))
143 (bzero sun size-of-sockaddr-un
)
144 (with-foreign-slots ((family path
) sun sockaddr-un
)
145 (setf family af-local
)
146 (with-foreign-string (c-string string
)
147 (loop :for off
:below
(1- unix-path-max
)
148 :do
(setf (mem-aref path
:uint8 off
)
149 (mem-aref c-string
:uint8 off
)))))
152 (defmacro with-sockaddr-un
((var address
) &body body
)
153 `(with-foreign-object (,var
'sockaddr-un
)
154 (make-sockaddr-un ,var
,address
)
157 (defmacro with-sockaddr-storage
((var) &body body
)
158 `(with-foreign-object (,var
'sockaddr-storage
)
159 (bzero ,var size-of-sockaddr-storage
)
164 (defmacro check-bounds
(sequence start end
)
165 (with-gensyms (length)
166 `(let ((,length
(length ,sequence
)))
167 (check-type ,start unsigned-byte
"a non-negative integer")
168 (check-type ,end
(or unsigned-byte null
) "a non-negative integer or NIL")
171 (unless (<= ,start
,end
,length
)
172 (error "Wrong sequence bounds. start: ~S end: ~S" ,start
,end
)))))
174 (defun %to-octets
(buff ef start end
)
175 (babel:string-to-octets buff
:start start
:end end
176 :encoding
(babel:external-format-encoding ef
)))
178 (declaim (inline ensure-number
))
179 (defun ensure-number (value &key
(start 0) end
(radix 10) (type t
) (errorp t
))
180 (check-type value
(or string unsigned-byte
) "a string or an unsigned-byte")
184 (ignore-errors (parse-integer value
:start start
:end end
185 :radix radix
:junk-allowed nil
)))
187 (if (and parsed
(typep parsed type
))
193 (defun ensure-string-or-unsigned-byte (thing &key
(type t
) (radix 10))
194 (or (and (symbolp thing
) (string-downcase thing
))
195 (ensure-number thing
:type type
:radix radix
:errorp nil
)
198 (defun lisp->c-bool
(val)
201 (defmacro with-socklen
((var value
) &body body
)
202 `(with-foreign-object (,var
'socklen
)
203 (setf (mem-ref ,var
'socklen
) ,value
)
206 (defun memq (value list
)
207 (member value list
:test
#'eq
))
209 (defmacro multiple-value-case
((values &key
(test 'eql
)) &body body
)
210 (setf values
(ensure-list values
))
211 (setf test
(alexandria::extract-function-name test
))
212 (assert values
() "Must provide at least one value to test")
213 (labels ((%do-var
(var val
)
215 ((and (symbolp var
) (member var
'("_" "*") :test
#'string
=))
220 `(member ,val
',var
:test
,test
)))
222 `(,test
,val
',var
))))
223 (%do-clause
(c gensyms
)
224 (destructuring-bind (vals &rest code
) c
225 (let* ((tests (remove t
(mapcar #'%do-var
(ensure-list vals
) gensyms
)))
226 (clause-test (if (> 2 (length tests
))
229 `(,clause-test
,@code
))))
230 (%do-last-clause
(c gensyms
)
232 (destructuring-bind (test &rest code
) c
233 (if (member test
'(otherwise t
))
235 `(,(%do-clause c gensyms
)))))))
236 (let ((gensyms (mapcar #'(lambda (v) (gensym (string v
)))
238 `(let ,(mapcar #'list gensyms values
)
239 (declare (ignorable ,@gensyms
))
240 (cond ,@(append (mapcar #'(lambda (c) (%do-clause c gensyms
))
242 (%do-last-clause
(lastcar body
) gensyms
)))))))
246 (defun make-ht-from-list (alist stream test
)
247 (flet ((err () (error 'reader-error
:stream stream
))
248 (alistp (alist) (every #'consp alist
)))
249 (unless (alistp alist
) (err))
250 (alist-hash-table alist
:test test
:size
(length alist
))))
252 (defun read-literal-ht (stream &optional c n
)
253 (declare (ignore c n
))
254 (let ((*readtable
* (copy-readtable))
255 (c (read-char stream
))
257 (flet ((err () (error 'reader-error
:stream stream
)))
260 (#\
: (let ((l (read-delimited-list #\
( stream
)))
261 (unless (= 1 (length l
)) (err))
262 (setf test
(car l
))))
264 (make-ht-from-list (read-delimited-list #\
) stream
)
267 (set-dispatch-macro-character #\
# #\h
'read-literal-ht
)