clisp.lisp - clic - Clic is an command line interactive client for gopher writt… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
clisp.lisp (26836B) | |
--- | |
1 ;;;; See LICENSE for licensing information. | |
2 | |
3 (in-package :usocket) | |
4 | |
5 (eval-when (:compile-toplevel :load-toplevel :execute) | |
6 #-ffi | |
7 (warn "This image doesn't contain FFI package, GET-HOST-NAME won't wor… | |
8 #-(or ffi rawsock) | |
9 (warn "This image doesn't contain either FFI or RAWSOCK package, no UD… | |
10 | |
11 ;; utility routine for looking up the current host name | |
12 #+ffi | |
13 (ffi:def-call-out get-host-name-internal | |
14 (:name "gethostname") | |
15 (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256… | |
16 :OUT :ALLOCA) | |
17 (len ffi:int)) | |
18 #+win32 (:library "WS2_32") | |
19 #-win32 (:library :default) | |
20 (:language #-win32 :stdc | |
21 #+win32 :stdc-stdcall) | |
22 (:return-type ffi:int)) | |
23 | |
24 (defun get-host-name () | |
25 #+ffi | |
26 (multiple-value-bind (retcode name) | |
27 (get-host-name-internal 256) | |
28 (when (= retcode 0) | |
29 name)) | |
30 #-ffi | |
31 "localhost") | |
32 | |
33 (defun get-host-by-address (address) | |
34 (with-mapped-conditions (nil address) | |
35 (let ((hostent (posix:resolve-host-ipaddr (host-to-hostname address)… | |
36 (posix:hostent-name hostent)))) | |
37 | |
38 (defun get-hosts-by-name (name) | |
39 (with-mapped-conditions (nil name) | |
40 (let ((hostent (posix:resolve-host-ipaddr name))) | |
41 (mapcar #'host-to-vector-quad | |
42 (posix:hostent-addr-list hostent))))) | |
43 | |
44 ;; Format: ((UNIX Windows) . CONDITION) | |
45 (defparameter +clisp-error-map+ | |
46 #-win32 | |
47 `((:EADDRINUSE . address-in-use-error) | |
48 (:EADDRNOTAVAIL . address-not-available-error) | |
49 (:EBADF . bad-file-descriptor-error) | |
50 (:ECONNREFUSED . connection-refused-error) | |
51 (:ECONNRESET . connection-reset-error) | |
52 (:ECONNABORTED . connection-aborted-error) | |
53 (:EINVAL . invalid-argument-error) | |
54 (:ENOBUFS . no-buffers-error) | |
55 (:ENOMEM . out-of-memory-error) | |
56 (:ENOTSUP . operation-not-supported-error) | |
57 (:EPERM . operation-not-permitted-error) | |
58 (:EPROTONOSUPPORT . protocol-not-supported-error) | |
59 (:ESOCKTNOSUPPORT . socket-type-not-supported-error) | |
60 (:ENETUNREACH . network-unreachable-error) | |
61 (:ENETDOWN . network-down-error) | |
62 (:ENETRESET . network-reset-error) | |
63 (:ESHUTDOWN . already-shutdown-error) | |
64 (:ETIMEDOUT . timeout-error) | |
65 (:EHOSTDOWN . host-down-error) | |
66 (:EHOSTUNREACH . host-unreachable-error) | |
67 ;; when blocked reading, and we close our socket due to a timeout. | |
68 ;; POSIX.1 says that EAGAIN and EWOULDBLOCK may have the same values. | |
69 (:EAGAIN . timeout-error) | |
70 (:EWOULDBLOCK . timeout-error)) ;linux | |
71 #+win32 | |
72 `((:WSAEADDRINUSE . address-in-use-error) | |
73 (:WSAEADDRNOTAVAIL . address-not-available-error) | |
74 (:WSAEBADF . bad-file-descriptor-error) | |
75 (:WSAECONNREFUSED . connection-refused-error) | |
76 (:WSAECONNRESET . connection-reset-error) | |
77 (:WSAECONNABORTED . connection-aborted-error) | |
78 (:WSAEINVAL . invalid-argument-error) | |
79 (:WSAENOBUFS . no-buffers-error) | |
80 (:WSAENOMEM . out-of-memory-error) | |
81 (:WSAENOTSUP . operation-not-supported-error) | |
82 (:WSAEPERM . operation-not-permitted-error) | |
83 (:WSAEPROTONOSUPPORT . protocol-not-supported-error) | |
84 (:WSAESOCKTNOSUPPORT . socket-type-not-supported-error) | |
85 (:WSAENETUNREACH . network-unreachable-error) | |
86 (:WSAENETDOWN . network-down-error) | |
87 (:WSAENETRESET . network-reset-error) | |
88 (:WSAESHUTDOWN . already-shutdown-error) | |
89 (:WSAETIMEDOUT . timeout-error) | |
90 (:WSAEHOSTDOWN . host-down-error) | |
91 (:WSAEHOSTUNREACH . host-unreachable-error))) | |
92 | |
93 (defun parse-errno (condition) | |
94 "Returns a number or keyword if it can parse what is within parens, el… | |
95 (let ((s (princ-to-string condition))) | |
96 (let ((pos1 (position #\( s)) | |
97 (pos2 (position #\) s))) | |
98 ;mac: number, linux: keyword | |
99 (ignore-errors | |
100 (if (digit-char-p (char s (1+ pos1))) | |
101 (parse-integer s :start (1+ pos1) :end pos2) | |
102 (let ((*package* (find-package "KEYWORD"))) | |
103 (car (read-from-string s t nil :start pos1 :end (1+ pos2))))… | |
104 | |
105 (defun handle-condition (condition &optional (socket nil) (host-or-ip ni… | |
106 "Dispatch a usocket condition instead of a CLISP specific one, if we c… | |
107 (let ((errno | |
108 (cond | |
109 ;clisp 2.49+ | |
110 ((typep condition (find-symbol "OS-STREAM-ERROR" "EXT")) | |
111 (parse-errno condition)) | |
112 ;clisp 2.49 | |
113 ((typep condition (find-symbol "SIMPLE-STREAM-ERROR" "SYSTEM… | |
114 (car (simple-condition-format-arguments condition)))))) | |
115 (when errno | |
116 (let ((error-keyword (if (keywordp errno) errno #+ffi(os:errno err… | |
117 (let ((usock-error (cdr (assoc error-keyword +clisp-error-map+))… | |
118 (when usock-error | |
119 (if (subtypep usock-error 'error) | |
120 (cond ((subtypep usock-error 'ns-error) | |
121 (error usock-error :socket socket :host-or-ip hos… | |
122 (t | |
123 (error usock-error :socket socket))) | |
124 (cond ((subtypep usock-error 'ns-condition) | |
125 (signal usock-error :socket socket :host-or-ip ho… | |
126 (t | |
127 (signal usock-error :socket socket)))))))))) | |
128 | |
129 (defun socket-connect (host port &key (protocol :stream) (element-type '… | |
130 timeout deadline (nodelay t nodelay-specified) | |
131 local-host local-port) | |
132 (declare (ignorable timeout local-host local-port)) | |
133 (when deadline (unsupported 'deadline 'socket-connect)) | |
134 (when (and nodelay-specified | |
135 (not (eq nodelay :if-supported))) | |
136 (unsupported 'nodelay 'socket-connect)) | |
137 (case protocol | |
138 (:stream | |
139 (let ((socket) | |
140 (hostname (host-to-hostname host))) | |
141 (with-mapped-conditions (socket host) | |
142 (setf socket | |
143 (if timeout | |
144 (socket:socket-connect port hostname | |
145 :element-type element-type | |
146 :buffered t | |
147 :timeout timeout) | |
148 (socket:socket-connect port hostname | |
149 :element-type element-type | |
150 :buffered t)))) | |
151 (make-stream-socket :socket socket | |
152 :stream socket))) ;; the socket is a stream t… | |
153 (:datagram | |
154 #+(or rawsock ffi) | |
155 (with-mapped-conditions (nil (or host local-host)) | |
156 (socket-create-datagram (or local-port *auto-port*) | |
157 :local-host (or local-host *wildcard-host… | |
158 :remote-host (and host (host-to-vector-qu… | |
159 :remote-port port)) | |
160 #-(or rawsock ffi) | |
161 (unsupported '(protocol :datagram) 'socket-connect)))) | |
162 | |
163 (defun socket-listen (host port | |
164 &key reuseaddress | |
165 (reuse-address nil reuse-address-supplied-p) | |
166 (backlog 5) | |
167 (element-type 'character)) | |
168 ;; clisp 2.39 sets SO_REUSEADDRESS to 1 by default; no need to | |
169 ;; to explicitly turn it on; unfortunately, there's no way to turn it … | |
170 (declare (ignore reuseaddress reuse-address reuse-address-supplied-p)) | |
171 (let ((sock (apply #'socket:socket-server | |
172 (append (list port | |
173 :backlog backlog) | |
174 (when (ip/= host *wildcard-host*) | |
175 (list :interface host)))))) | |
176 (with-mapped-conditions (nil host) | |
177 (make-stream-server-socket sock :element-type element-type)))) | |
178 | |
179 (defmethod socket-accept ((socket stream-server-usocket) &key element-ty… | |
180 (let ((stream | |
181 (with-mapped-conditions (socket) | |
182 (socket:socket-accept (socket socket) | |
183 :element-type (or element-type | |
184 (element-type socket)… | |
185 (make-stream-socket :socket stream | |
186 :stream stream))) | |
187 | |
188 ;; Only one close method required: | |
189 ;; sockets and their associated streams | |
190 ;; are the same object | |
191 (defmethod socket-close ((usocket usocket)) | |
192 "Close socket." | |
193 (with-mapped-conditions (usocket) | |
194 (close (socket usocket)))) | |
195 | |
196 (defmethod socket-close ((usocket stream-server-usocket)) | |
197 (socket:socket-server-close (socket usocket))) | |
198 | |
199 (defmethod socket-shutdown ((usocket stream-usocket) direction) | |
200 (with-mapped-conditions (usocket) | |
201 (socket:socket-stream-shutdown (socket usocket) direction))) | |
202 | |
203 (defmethod get-local-name ((usocket stream-usocket)) | |
204 (multiple-value-bind | |
205 (address port) | |
206 (socket:socket-stream-local (socket usocket) t) | |
207 (values (dotted-quad-to-vector-quad address) port))) | |
208 | |
209 (defmethod get-local-name ((usocket stream-server-usocket)) | |
210 (values (get-local-address usocket) | |
211 (get-local-port usocket))) | |
212 | |
213 (defmethod get-peer-name ((usocket stream-usocket)) | |
214 (multiple-value-bind | |
215 (address port) | |
216 (socket:socket-stream-peer (socket usocket) t) | |
217 (values (dotted-quad-to-vector-quad address) port))) | |
218 | |
219 (defmethod get-local-address ((usocket usocket)) | |
220 (nth-value 0 (get-local-name usocket))) | |
221 | |
222 (defmethod get-local-address ((usocket stream-server-usocket)) | |
223 (dotted-quad-to-vector-quad | |
224 (socket:socket-server-host (socket usocket)))) | |
225 | |
226 (defmethod get-peer-address ((usocket usocket)) | |
227 (nth-value 0 (get-peer-name usocket))) | |
228 | |
229 (defmethod get-local-port ((usocket usocket)) | |
230 (nth-value 1 (get-local-name usocket))) | |
231 | |
232 (defmethod get-local-port ((usocket stream-server-usocket)) | |
233 (socket:socket-server-port (socket usocket))) | |
234 | |
235 (defmethod get-peer-port ((usocket usocket)) | |
236 (nth-value 1 (get-peer-name usocket))) | |
237 | |
238 (defun %setup-wait-list (wait-list) | |
239 (declare (ignore wait-list))) | |
240 | |
241 (defun %add-waiter (wait-list waiter) | |
242 ;; clisp's #'socket-status takes a list whose elts look either like, | |
243 ;; (socket-stream direction . x) or like, | |
244 ;; (socket-server . x) | |
245 ;; and it replaces the x's. | |
246 (push (cons (socket waiter) | |
247 (cond ((stream-usocket-p waiter) (cons NIL NIL)) | |
248 (t NIL))) | |
249 (wait-list-%wait wait-list))) | |
250 | |
251 (defun %remove-waiter (wait-list waiter) | |
252 (setf (wait-list-%wait wait-list) | |
253 (remove (socket waiter) (wait-list-%wait wait-list) :key #'car))) | |
254 | |
255 (defmethod wait-for-input-internal (wait-list &key timeout) | |
256 (with-mapped-conditions () | |
257 (multiple-value-bind | |
258 (secs musecs) | |
259 (split-timeout (or timeout 1)) | |
260 (dolist (x (wait-list-%wait wait-list)) | |
261 (when (consp (cdr x)) ;it's a socket-stream not socket-server | |
262 (setf (cadr x) :INPUT))) | |
263 (let* ((request-list (wait-list-%wait wait-list)) | |
264 (status-list (if timeout | |
265 (socket:socket-status request-list secs mu… | |
266 (socket:socket-status request-list))) | |
267 (sockets (wait-list-waiters wait-list))) | |
268 (do* ((x (pop sockets) (pop sockets)) | |
269 (y (cdr (last (pop status-list))) (cdr (last (pop status-l… | |
270 ((null x)) | |
271 (when (member y '(T :INPUT :EOF)) | |
272 (setf (state x) :READ))) | |
273 wait-list)))) | |
274 | |
275 ;;; | |
276 ;;; UDP/Datagram sockets (RAWSOCK version) | |
277 ;;; | |
278 | |
279 #+rawsock | |
280 (progn | |
281 (defun make-sockaddr_in () | |
282 (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0)) | |
283 | |
284 (declaim (inline fill-sockaddr_in)) | |
285 (defun fill-sockaddr_in (sockaddr_in ip port) | |
286 (port-to-octet-buffer port sockaddr_in) | |
287 (ip-to-octet-buffer ip sockaddr_in :start 2) | |
288 sockaddr_in) | |
289 | |
290 (defun socket-create-datagram (local-port | |
291 &key (local-host *wildcard-host*) | |
292 remote-host | |
293 remote-port) | |
294 (let ((sock (rawsock:socket :inet :dgram 0)) | |
295 (lsock_addr (fill-sockaddr_in (make-sockaddr_in) | |
296 local-host local-port)) | |
297 (rsock_addr (when remote-host | |
298 (fill-sockaddr_in (make-sockaddr_in) | |
299 remote-host (or remote-port | |
300 local-port))))) | |
301 (rawsock:bind sock (rawsock:make-sockaddr :inet lsock_addr)) | |
302 (when rsock_addr | |
303 (rawsock:connect sock (rawsock:make-sockaddr :inet rsock_addr))) | |
304 (make-datagram-socket sock :connected-p (if rsock_addr t nil)))) | |
305 | |
306 (defmethod socket-receive ((socket datagram-usocket) buffer length &ke… | |
307 "Returns the buffer, the number of octets copied into the buffer (re… | |
308 and the address of the sender as values." | |
309 (let* ((sock (socket socket)) | |
310 (sockaddr (rawsock:make-sockaddr :inet)) | |
311 (real-length (or length +max-datagram-packet-size+)) | |
312 (real-buffer (or buffer | |
313 (make-array real-length | |
314 :element-type '(unsigned-byte 8)… | |
315 (let ((rv (rawsock:recvfrom sock real-buffer sockaddr | |
316 :start 0 :end real-length)) | |
317 (host 0) (port 0)) | |
318 (unless (connected-p socket) | |
319 (let ((data (rawsock:sockaddr-data sockaddr))) | |
320 (setq host (ip-from-octet-buffer data :start 4) | |
321 port (port-from-octet-buffer data :start 2)))) | |
322 (values (if buffer real-buffer (subseq real-buffer 0 rv)) | |
323 rv | |
324 host | |
325 port)))) | |
326 | |
327 (defmethod socket-send ((socket datagram-usocket) buffer size &key hos… | |
328 "Returns the number of octets sent." | |
329 (let* ((sock (socket socket)) | |
330 (sockaddr (when (and host port) | |
331 (rawsock:make-sockaddr :inet | |
332 (fill-sockaddr_in | |
333 (make-sockaddr_in) | |
334 (host-byte-order host) | |
335 port)))) | |
336 (real-size (min size +max-datagram-packet-size+)) | |
337 (real-buffer (if (typep buffer '(simple-array (unsigned-byte … | |
338 buffer | |
339 (make-array real-size | |
340 :element-type '(unsigned-byte 8) | |
341 :initial-contents (subseq buffer 0… | |
342 (rv (if (and host port) | |
343 (rawsock:sendto sock real-buffer sockaddr | |
344 :start offset | |
345 :end (+ offset real-size)) | |
346 (rawsock:send sock real-buffer | |
347 :start offset | |
348 :end (+ offset real-size))))) | |
349 rv)) | |
350 | |
351 (defmethod socket-close ((usocket datagram-usocket)) | |
352 (rawsock:sock-close (socket usocket))) | |
353 | |
354 (declaim (inline get-socket-name)) | |
355 (defun get-socket-name (socket function) | |
356 (let ((sockaddr (rawsock:make-sockaddr :inet (make-sockaddr_in)))) | |
357 (funcall function socket sockaddr) | |
358 (let ((data (rawsock:sockaddr-data sockaddr))) | |
359 (values (hbo-to-vector-quad (ip-from-octet-buffer data :start 2)) | |
360 (port-from-octet-buffer data :start 0))))) | |
361 | |
362 (defmethod get-local-name ((usocket datagram-usocket)) | |
363 (get-socket-name (socket usocket) 'rawsock:getsockname)) | |
364 | |
365 (defmethod get-peer-name ((usocket datagram-usocket)) | |
366 (get-socket-name (socket usocket) 'rawsock:getpeername)) | |
367 | |
368 ) ; progn | |
369 | |
370 ;;; | |
371 ;;; UDP/Datagram sockets (FFI version) | |
372 ;;; | |
373 | |
374 #+(and ffi (not rawsock)) | |
375 (progn | |
376 ;; C primitive types | |
377 (ffi:def-c-type socklen_t ffi:uint32) | |
378 | |
379 ;; C structures | |
380 (ffi:def-c-struct sockaddr | |
381 #+macos (sa_len ffi:uint8) | |
382 (sa_family #-macos ffi:ushort | |
383 #+macos ffi:uint8) | |
384 (sa_data (ffi:c-array ffi:char 14))) | |
385 | |
386 (ffi:def-c-struct sockaddr_in | |
387 #+macos (sin_len ffi:uint8) | |
388 (sin_family #-macos ffi:short | |
389 #+macos ffi:uint8) | |
390 (sin_port #-macos ffi:ushort | |
391 #+macos ffi:uint16) | |
392 (sin_addr ffi:uint32) | |
393 (sin_zero (ffi:c-array ffi:char 8))) | |
394 | |
395 (ffi:def-c-struct timeval | |
396 (tv_sec ffi:long) | |
397 (tv_usec ffi:long)) | |
398 | |
399 ;; foreign functions | |
400 (ffi:def-call-out %sendto (:name "sendto") | |
401 (:arguments (socket ffi:int) | |
402 (buffer ffi:c-pointer) | |
403 (length ffi:int) | |
404 (flags ffi:int) | |
405 (address (ffi:c-ptr sockaddr)) | |
406 (address-len ffi:int)) | |
407 #+win32 (:library "WS2_32") | |
408 #-win32 (:library :default) | |
409 (:language #-win32 :stdc | |
410 #+win32 :stdc-stdcall) | |
411 (:return-type ffi:int)) | |
412 | |
413 (ffi:def-call-out %send (:name "send") | |
414 (:arguments (socket ffi:int) | |
415 (buffer ffi:c-pointer) | |
416 (length ffi:int) | |
417 (flags ffi:int)) | |
418 #+win32 (:library "WS2_32") | |
419 #-win32 (:library :default) | |
420 (:language #-win32 :stdc | |
421 #+win32 :stdc-stdcall) | |
422 (:return-type ffi:int)) | |
423 | |
424 (ffi:def-call-out %recvfrom (:name "recvfrom") | |
425 (:arguments (socket ffi:int) | |
426 (buffer ffi:c-pointer) | |
427 (length ffi:int) | |
428 (flags ffi:int) | |
429 (address (ffi:c-ptr sockaddr) :in-out) | |
430 (address-len (ffi:c-ptr ffi:int) :in-out)) | |
431 #+win32 (:library "WS2_32") | |
432 #-win32 (:library :default) | |
433 (:language #-win32 :stdc | |
434 #+win32 :stdc-stdcall) | |
435 (:return-type ffi:int)) | |
436 | |
437 (ffi:def-call-out %socket (:name "socket") | |
438 (:arguments (family ffi:int) | |
439 (type ffi:int) | |
440 (protocol ffi:int)) | |
441 #+win32 (:library "WS2_32") | |
442 #-win32 (:library :default) | |
443 (:language #-win32 :stdc | |
444 #+win32 :stdc-stdcall) | |
445 (:return-type ffi:int)) | |
446 | |
447 (ffi:def-call-out %connect (:name "connect") | |
448 (:arguments (socket ffi:int) | |
449 (address (ffi:c-ptr sockaddr) :in) | |
450 (address_len socklen_t)) | |
451 #+win32 (:library "WS2_32") | |
452 #-win32 (:library :default) | |
453 (:language #-win32 :stdc | |
454 #+win32 :stdc-stdcall) | |
455 (:return-type ffi:int)) | |
456 | |
457 (ffi:def-call-out %bind (:name "bind") | |
458 (:arguments (socket ffi:int) | |
459 (address (ffi:c-ptr sockaddr) :in) | |
460 (address_len socklen_t)) | |
461 #+win32 (:library "WS2_32") | |
462 #-win32 (:library :default) | |
463 (:language #-win32 :stdc | |
464 #+win32 :stdc-stdcall) | |
465 (:return-type ffi:int)) | |
466 | |
467 (ffi:def-call-out %close (:name #-win32 "close" #+win32 "closesocket") | |
468 (:arguments (socket ffi:int)) | |
469 #+win32 (:library "WS2_32") | |
470 #-win32 (:library :default) | |
471 (:language #-win32 :stdc | |
472 #+win32 :stdc-stdcall) | |
473 (:return-type ffi:int)) | |
474 | |
475 (ffi:def-call-out %getsockopt (:name "getsockopt") | |
476 (:arguments (sockfd ffi:int) | |
477 (level ffi:int) | |
478 (optname ffi:int) | |
479 (optval ffi:c-pointer) | |
480 (optlen (ffi:c-ptr socklen_t) :out)) | |
481 #+win32 (:library "WS2_32") | |
482 #-win32 (:library :default) | |
483 (:language #-win32 :stdc | |
484 #+win32 :stdc-stdcall) | |
485 (:return-type ffi:int)) | |
486 | |
487 (ffi:def-call-out %setsockopt (:name "setsockopt") | |
488 (:arguments (sockfd ffi:int) | |
489 (level ffi:int) | |
490 (optname ffi:int) | |
491 (optval ffi:c-pointer) | |
492 (optlen socklen_t)) | |
493 #+win32 (:library "WS2_32") | |
494 #-win32 (:library :default) | |
495 (:language #-win32 :stdc | |
496 #+win32 :stdc-stdcall) | |
497 (:return-type ffi:int)) | |
498 | |
499 (ffi:def-call-out %htonl (:name "htonl") | |
500 (:arguments (hostlong ffi:uint32)) | |
501 #+win32 (:library "WS2_32") | |
502 #-win32 (:library :default) | |
503 (:language #-win32 :stdc | |
504 #+win32 :stdc-stdcall) | |
505 (:return-type ffi:uint32)) | |
506 | |
507 (ffi:def-call-out %htons (:name "htons") | |
508 (:arguments (hostshort ffi:uint16)) | |
509 #+win32 (:library "WS2_32") | |
510 #-win32 (:library :default) | |
511 (:language #-win32 :stdc | |
512 #+win32 :stdc-stdcall) | |
513 (:return-type ffi:uint16)) | |
514 | |
515 (ffi:def-call-out %ntohl (:name "ntohl") | |
516 (:arguments (netlong ffi:uint32)) | |
517 #+win32 (:library "WS2_32") | |
518 #-win32 (:library :default) | |
519 (:language #-win32 :stdc | |
520 #+win32 :stdc-stdcall) | |
521 (:return-type ffi:uint32)) | |
522 | |
523 (ffi:def-call-out %ntohs (:name "ntohs") | |
524 (:arguments (netshort ffi:uint16)) | |
525 #+win32 (:library "WS2_32") | |
526 #-win32 (:library :default) | |
527 (:language #-win32 :stdc | |
528 #+win32 :stdc-stdcall) | |
529 (:return-type ffi:uint16)) | |
530 | |
531 (ffi:def-call-out %getsockname (:name "getsockname") | |
532 (:arguments (sockfd ffi:int) | |
533 (localaddr (ffi:c-ptr sockaddr) :in-out) | |
534 (addrlen (ffi:c-ptr socklen_t) :in-out)) | |
535 #+win32 (:library "WS2_32") | |
536 #-win32 (:library :default) | |
537 (:language #-win32 :stdc | |
538 #+win32 :stdc-stdcall) | |
539 (:return-type ffi:int)) | |
540 | |
541 (ffi:def-call-out %getpeername (:name "getpeername") | |
542 (:arguments (sockfd ffi:int) | |
543 (peeraddr (ffi:c-ptr sockaddr) :in-out) | |
544 (addrlen (ffi:c-ptr socklen_t) :in-out)) | |
545 #+win32 (:library "WS2_32") | |
546 #-win32 (:library :default) | |
547 (:language #-win32 :stdc | |
548 #+win32 :stdc-stdcall) | |
549 (:return-type ffi:int)) | |
550 | |
551 ;; socket constants | |
552 (defconstant +socket-af-inet+ 2) | |
553 (defconstant +socket-sock-dgram+ 2) | |
554 (defconstant +socket-ip-proto-udp+ 17) | |
555 | |
556 (defconstant +sockopt-so-rcvtimeo+ #-linux #x1006 #+linux 20 "Socket r… | |
557 | |
558 (defparameter *length-of-sockaddr_in* (ffi:sizeof 'sockaddr_in)) | |
559 | |
560 (declaim (inline fill-sockaddr_in)) | |
561 (defun fill-sockaddr_in (sockaddr host port) | |
562 (let ((hbo (host-to-hbo host))) | |
563 (ffi:with-c-place (place sockaddr) | |
564 #+macos | |
565 (setf (ffi:slot place 'sin_len) *length-of-sockaddr_in*) | |
566 (setf (ffi:slot place 'sin_family) +socket-af-inet+ | |
567 (ffi:slot place 'sin_port) (%htons port) | |
568 (ffi:slot place 'sin_addr) (%htonl hbo))) | |
569 sockaddr)) | |
570 | |
571 (defun socket-create-datagram (local-port | |
572 &key (local-host *wildcard-host*) | |
573 remote-host | |
574 remote-port) | |
575 (let ((sock (%socket +socket-af-inet+ +socket-sock-dgram+ +socket-ip… | |
576 (lsock_addr (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_… | |
577 local-host local-port)) | |
578 (rsock_addr (when remote-host | |
579 (fill-sockaddr_in (ffi:allocate-shallow 'sockadd… | |
580 remote-host (or remote-port lo… | |
581 (unless (plusp sock) | |
582 (error "SOCKET-CREATE-DATAGRAM ERROR (socket): ~A" (os:errno))) | |
583 (unwind-protect | |
584 (let ((rv (%bind sock (ffi:cast (ffi:foreign-value lsock_addr… | |
585 *length-of-sockaddr_in*))) | |
586 (unless (zerop rv) | |
587 (error "SOCKET-CREATE-DATAGRAM ERROR (bind): ~A" (os:errn… | |
588 (when rsock_addr | |
589 (let ((rv (%connect sock | |
590 (ffi:cast (ffi:foreign-value rsock_ad… | |
591 *length-of-sockaddr_in*))) | |
592 (unless (zerop rv) | |
593 (error "SOCKET-CREATE-DATAGRAM ERROR (connect): ~A" (… | |
594 (ffi:foreign-free lsock_addr) | |
595 (when remote-host | |
596 (ffi:foreign-free rsock_addr))) | |
597 (make-datagram-socket sock :connected-p (if rsock_addr t nil)))) | |
598 | |
599 (defun finalize-datagram-usocket (object) | |
600 (when (datagram-usocket-p object) | |
601 (socket-close object))) | |
602 | |
603 (defmethod initialize-instance :after ((usocket datagram-usocket) &key) | |
604 (setf (slot-value usocket 'recv-buffer) | |
605 (ffi:allocate-shallow 'ffi:uint8 :count +max-datagram-packet-s… | |
606 ;; finalize the object | |
607 (ext:finalize usocket 'finalize-datagram-usocket)) | |
608 | |
609 (defmethod socket-close ((usocket datagram-usocket)) | |
610 (with-slots (recv-buffer socket) usocket | |
611 (ffi:foreign-free recv-buffer) | |
612 (zerop (%close socket)))) | |
613 | |
614 (defmethod socket-receive ((usocket datagram-usocket) buffer length &k… | |
615 (let ((remote-address (ffi:allocate-shallow 'sockaddr_in)) | |
616 (remote-address-length (ffi:allocate-shallow 'ffi:int)) | |
617 nbytes (host 0) (port 0)) | |
618 (setf (ffi:foreign-value remote-address-length) | |
619 *length-of-sockaddr_in*) | |
620 (unwind-protect | |
621 (multiple-value-bind (n address address-length) | |
622 (%recvfrom (socket usocket) | |
623 (ffi:foreign-address (slot-value usocket 'recv… | |
624 +max-datagram-packet-size+ | |
625 0 ; flags | |
626 (ffi:cast (ffi:foreign-value remote-address) '… | |
627 (ffi:foreign-value remote-address-length)) | |
628 (when (minusp n) | |
629 (error "SOCKET-RECEIVE ERROR: ~A" (os:errno))) | |
630 (setq nbytes n) | |
631 (when (= address-length *length-of-sockaddr_in*) | |
632 (let ((data (sockaddr-sa_data address))) | |
633 (setq host (ip-from-octet-buffer data :start 2) | |
634 port (port-from-octet-buffer data)))) | |
635 (cond ((plusp n) | |
636 (let ((return-buffer (ffi:foreign-value (slot-value … | |
637 (if buffer ; replace exist buffer of create new re… | |
638 (let ((end-1 (min (or length (length buffer)) … | |
639 (end-2 (min n +max-datagram-packet-size+… | |
640 (replace buffer return-buffer :end1 end-1 :e… | |
641 (setq buffer (subseq return-buffer 0 (min n +m… | |
642 ((zerop n)))) | |
643 (ffi:foreign-free remote-address) | |
644 (ffi:foreign-free remote-address-length)) | |
645 (values buffer nbytes host port))) | |
646 | |
647 ;; implementation note: different from socket-receive, we know how man… | |
648 ;; so, a send buffer will not needed, and if there is a buffer, it's h… | |
649 ;; in LispWorks. So, we allocate new foreign buffer for holding data (… | |
650 ;; | |
651 ;; I don't know if anyone is watching my coding work, but I think this… | |
652 (defmethod socket-send ((usocket datagram-usocket) buffer size &key ho… | |
653 (declare (type sequence buffer) | |
654 (type (integer 0 *) size offset)) | |
655 (let ((remote-address | |
656 (when (and host port) | |
657 (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) host … | |
658 (send-buffer | |
659 (ffi:allocate-deep 'ffi:uint8 | |
660 (if (zerop offset) | |
661 buffer | |
662 (subseq buffer offset (+ offset size))) | |
663 :count size :read-only t)) | |
664 (real-size (min size +max-datagram-packet-size+)) | |
665 (nbytes 0)) | |
666 (unwind-protect | |
667 (let ((n (if remote-address | |
668 (%sendto (socket usocket) | |
669 (ffi:foreign-address send-buffer) | |
670 real-size | |
671 0 ; flags | |
672 (ffi:cast (ffi:foreign-value remote-add… | |
673 *length-of-sockaddr_in*) | |
674 (%send (socket usocket) | |
675 (ffi:foreign-address send-buffer) | |
676 real-size | |
677 0)))) | |
678 (cond ((plusp n) | |
679 (setq nbytes n)) | |
680 ((zerop n) | |
681 (setq nbytes n)) | |
682 (t (error "SOCKET-SEND ERROR: ~A" (os:errno))))) | |
683 (ffi:foreign-free send-buffer) | |
684 (when remote-address | |
685 (ffi:foreign-free remote-address)) | |
686 nbytes))) | |
687 | |
688 (declaim (inline get-socket-name)) | |
689 (defun get-socket-name (socket function) | |
690 (let ((address (ffi:allocate-shallow 'sockaddr_in)) | |
691 (address-length (ffi:allocate-shallow 'ffi:int)) | |
692 (host 0) (port 0)) | |
693 (setf (ffi:foreign-value address-length) *length-of-sockaddr_in*) | |
694 (unwind-protect | |
695 (multiple-value-bind (rv return-address return-address-length) | |
696 (funcall function socket | |
697 (ffi:cast (ffi:foreign-value address) 'sockaddr) | |
698 (ffi:foreign-value address-length)) | |
699 (declare (ignore return-address-length)) | |
700 (if (zerop rv) | |
701 (let ((data (sockaddr-sa_data return-address))) | |
702 (setq host (ip-from-octet-buffer data :start 2) | |
703 port (port-from-octet-buffer data))) | |
704 (error "GET-SOCKET-NAME ERROR: ~A" (os:errno)))) | |
705 (ffi:foreign-free address) | |
706 (ffi:foreign-free address-length)) | |
707 (values (hbo-to-vector-quad host) port))) | |
708 | |
709 (defmethod get-local-name ((usocket datagram-usocket)) | |
710 (get-socket-name (socket usocket) '%getsockname)) | |
711 | |
712 (defmethod get-peer-name ((usocket datagram-usocket)) | |
713 (get-socket-name (socket usocket) '%getpeername)) | |
714 | |
715 ) ; progn |