PageRenderTime 2ms CodeModel.GetById 5ms app.highlight 38ms RepoModel.GetById 1ms app.codeStats 0ms

/common-lisp/3rd-party/usocket/backend/clisp.lisp

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