1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 ; Copyright (C) 2006,2007 by Stelian Ionescu ;
6 ; This program is free software; you can redistribute it and/or modify ;
7 ; it under the terms of the GNU General Public License as published by ;
8 ; the Free Software Foundation; either version 2 of the License, or ;
9 ; (at your option) any later version. ;
11 ; This program is distributed in the hope that it will be useful, ;
12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of ;
13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;
14 ; GNU General Public License for more details. ;
16 ; You should have received a copy of the GNU General Public License ;
17 ; along with this program; if not, write to the ;
18 ; Free Software Foundation, Inc., ;
19 ; 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ;
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
22 (in-package :net.sockets
)
24 (deftype ub8
() `(unsigned-byte 8))
25 (deftype ub16
() `(unsigned-byte 16))
26 (deftype ub32
() `(unsigned-byte 32))
27 (deftype sb8
() `(signed-byte 8))
28 (deftype sb16
() `(signed-byte 16))
29 (deftype sb32
() `(signed-byte 32))
31 (defun parse-number-or-nil (value &optional
(type :any
) (radix 10))
32 (check-type value
(or string unsigned-byte
))
35 (ignore-errors (parse-integer value
:radix radix
39 ;; if it's a number and its type is ok return it
42 (:ub8
(typep parsed
'ub8
))
43 (:ub16
(typep parsed
'ub16
))
44 (:ub32
(typep parsed
'ub32
)))
49 (defun c->lisp-bool
(val)
50 (if (zerop val
) nil t
))
52 (defun lisp->c-bool
(val)
55 (defun addrerr-value (keyword)
56 (foreign-enum-value 'et
:addrinfo-errors keyword
))
58 (defun unixerr-value (keyword)
59 (foreign-enum-value 'et
:errno-values keyword
))
62 (not (eql (not x1
) (not x2
))))
65 ;;; Byte-swap functions
69 (check-type short ub16
"a 16-bit unsigned number")
71 (logior (ash (logand (the ub16 short
) #x00FF
) 8)
72 (ash (logand (the ub16 short
) #xFF00
) -
8))
79 (check-type long ub32
"a 32-bit unsigned number")
81 (logior (ash (logand (the ub32 long
) #x000000FF
) 24)
82 (ash (logand (the ub32 long
) #x0000FF00
) 8)
83 (ash (logand (the ub32 long
) #x00FF0000
) -
8)
84 (ash (logand (the ub32 long
) #xFF000000
) -
24))
90 (defun copy-simple-array-ub16-to-alien-vector (lisp-vec alien-vec
)
91 (declare (type (simple-array ub16
(8)) lisp-vec
))
93 (setf (mem-aref alien-vec
:uint16 i
)
94 (htons (aref lisp-vec i
)))))
96 (defun map-ipv4-vector-to-ipv6 (addr)
97 (declare (type (simple-array ub8
(*)) addr
))
98 (let ((ipv6addr (make-array 8 :element-type
'ub16
100 ;; setting the IPv4 marker
101 (setf (aref ipv6addr
5) #xFFFF
)
102 ;; setting the first two bytes
103 (setf (aref ipv6addr
6) (+ (ash (aref addr
0) 8)
105 ;; setting the last two bytes
106 (setf (aref ipv6addr
7) (+ (ash (aref addr
2) 8)
111 ;; From CLOCC's PORT library
112 (defun vector-to-ipaddr (vector)
113 (coerce vector
'(simple-array ub8
(4)))
114 (+ (ash (aref vector
0) 24)
115 (ash (aref vector
1) 16)
116 (ash (aref vector
2) 8)
119 (defun make-sockaddr-in (sin ub8-vector
&optional
(port 0))
120 (et:bzero sin et
:size-of-sockaddr-in
)
122 (with-foreign-slots ((et:family et
:address et
:port
) sin et
:sockaddr-in
)
123 (setf et
:family et
:af-inet
)
124 (setf et
:address
(htonl (vector-to-ipaddr ub8-vector
)))
125 (setf et
:port
(htons tmp
))))
128 (defun make-sockaddr-in6 (sin6 ub16-vector
&optional
(port 0))
129 (et:bzero sin6 et
:size-of-sockaddr-in6
)
131 (with-foreign-slots ((et:family et
:address et
:port
) sin6 et
:sockaddr-in6
)
132 (setf et
:family et
:af-inet6
)
133 (copy-simple-array-ub16-to-alien-vector ub16-vector et
:address
)
134 (setf et
:port
(htons tmp
))))
137 (defun make-sockaddr-un (sun string
)
138 (check-type string string
)
139 (et:bzero sun et
:size-of-sockaddr-un
)
140 (with-foreign-slots ((et:family et
:path
) sun et
:sockaddr-un
)
141 (setf et
:family et
:af-local
)
142 (with-foreign-string (c-string string
)
144 :for off
:below
(1- et
:unix-path-max
)
145 :do
(setf (mem-aref et
:path
:uint8 off
)
146 (mem-aref c-string
:uint8 off
)))))
149 (defun make-vector-u8-4-from-in-addr (in-addr)
150 (check-type in-addr ub32
)
151 (let ((vector (make-array 4 :element-type
'ub8
)))
152 (setf in-addr
(ntohl in-addr
))
153 (setf (aref vector
0) (ldb (byte 8 24) in-addr
))
154 (setf (aref vector
1) (ldb (byte 8 16) in-addr
))
155 (setf (aref vector
2) (ldb (byte 8 8) in-addr
))
156 (setf (aref vector
3) (ldb (byte 8 0) in-addr
))
159 (defun make-vector-u16-8-from-in6-addr (in6-addr)
160 (let ((newvector (make-array 8 :element-type
'ub16
)))
162 (setf (aref newvector i
)
163 (ntohs (mem-aref in6-addr
:uint16 i
))))
166 (defun sockaddr-in->sockaddr
(sin)
167 (with-foreign-slots ((et:address et
:port
) sin et
:sockaddr-in
)
168 (values (make-instance 'ipv4addr
169 :name
(make-vector-u8-4-from-in-addr et
:address
))
172 (defun sockaddr-in6->sockaddr
(sin6)
173 (with-foreign-slots ((et:address et
:port
) sin6 et
:sockaddr-in6
)
174 (values (make-instance 'ipv6addr
175 :name
(make-vector-u16-8-from-in6-addr et
:address
))
178 (defun sockaddr-un->sockaddr
(sun)
179 (with-foreign-slots ((et:path
) sun et
:sockaddr-un
)
180 (let ((name (make-string (1- et
:unix-path-max
)))
182 (if (zerop (mem-aref et
:path
:uint8
0))
187 :for sindex
:from
0 :below
(1- et
:unix-path-max
)
188 :for pindex
:from
1 :below et
:unix-path-max
189 :do
(setf (schar name sindex
)
190 (code-char (mem-aref et
:path
:uint8 pindex
)))))
191 ;; address is in the filesystem
192 (setf name
(foreign-string-to-lisp et
:path
)))
193 (make-instance 'localaddr
195 :abstract abstract
))))
197 (defun sockaddr-storage->sockaddr
(ss)
198 (with-foreign-slots ((et:family
) ss et
:sockaddr-storage
)
201 (sockaddr-in->sockaddr ss
))
203 (sockaddr-in6->sockaddr ss
))
205 (sockaddr-un->sockaddr ss
)))))
207 (defun sockaddr->sockaddr-storage
(ss sockaddr
&optional
(port 0))
210 (make-sockaddr-in ss
(name sockaddr
) port
))
212 (make-sockaddr-in6 ss
(name sockaddr
) port
))
214 (make-sockaddr-un ss
(name sockaddr
)))))