1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
;;;; -*- Mode: Lisp -*-
;;;; $Id$
;;;; $URL$
;;;; Foreign functions defined by ECL's DFFI, used for #+ecl-bytecmp only.
;;;; See LICENSE for licensing information.
(in-package :usocket)
#+(and ecl-bytecmp windows)
(eval-when (:load-toplevel :execute)
(ffi:load-foreign-library "ws2_32.dll" :module "ws2_32"))
#+(and ecl-bytecmp windows)
(progn
(ffi:def-function ("gethostname" c-gethostname)
((name (* :unsigned-char))
(len :int))
:returning :int
:module "ws2_32")
(defun get-host-name ()
"Returns the hostname"
(ffi:with-foreign-object (name '(:array :unsigned-char 256))
(when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256))
(ffi:convert-from-foreign-string name))))
(ffi:def-foreign-type ws-socket :unsigned-int)
(ffi:def-foreign-type ws-dword :unsigned-long)
(ffi:def-foreign-type ws-event :unsigned-int)
(ffi:def-struct wsa-network-events
(network-events :long)
(error-code (:array :int 10)))
(ffi:def-function ("WSACreateEvent" wsa-event-create)
()
:returning ws-event
:module "ws2_32")
(ffi:def-function ("WSACloseEvent" c-wsa-event-close)
((event-object ws-event))
:returning :int
:module "ws2_32")
(defun wsa-event-close (ws-event)
(not (zerop (c-wsa-event-close ws-event))))
(ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events)
((socket ws-socket)
(event-object ws-event)
(network-events (* wsa-network-events)))
:returning :int
:module "ws2_32")
(ffi:def-function ("WSAEventSelect" wsa-event-select)
((socket ws-socket)
(event-object ws-event)
(network-events :long))
:returning :int
:module "ws2_32")
(ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events)
((number-of-events ws-dword)
(events (* ws-event))
(wait-all-p :int)
(timeout ws-dword)
(alertable-p :int))
:returning ws-dword
:module "ws2_32")
(defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p)
(c-wsa-wait-for-multiple-events number-of-events
events
(if wait-all-p -1 0)
timeout
(if alertable-p -1 0)))
(ffi:def-function ("ioctlsocket" wsa-ioctlsocket)
((socket ws-socket)
(cmd :long)
(argp (* :unsigned-long)))
:returning :int
:module "ws2_32")
(ffi:def-function ("WSAGetLastError" wsa-get-last-error)
()
:returning :int
:module "ws2_32")
(defun maybe-wsa-error (rv &optional socket)
(unless (zerop rv)
(raise-usock-err (wsa-get-last-error) socket)))
(defun bytes-available-for-read (socket)
(ffi:with-foreign-object (int-ptr :unsigned-long)
(maybe-wsa-error (wsa-ioctlsocket (socket-handle socket) fionread int-ptr)
socket)
(let ((int (ffi:deref-pointer int-ptr :unsigned-long)))
(prog1 int
(when (plusp int)
(setf (state socket) :read))))))
(defun map-network-events (func network-events)
(let ((event-map (ffi:get-slot-value network-events 'wsa-network-events 'network-events))
(error-array (ffi:get-slot-pointer network-events 'wsa-network-events 'error-code)))
(unless (zerop event-map)
(dotimes (i fd-max-events)
(unless (zerop (ldb (byte 1 i) event-map))
(funcall func (ffi:deref-array error-array '(:array :int 10) i)))))))
(defun update-ready-and-state-slots (sockets)
(dolist (socket sockets)
(if (%ready-p socket)
(progn
(setf (state socket) :READ))
(ffi:with-foreign-object (network-events 'wsa-network-events)
(let ((rv (wsa-enum-network-events (socket-handle socket) 0 network-events)))
(if (zerop rv)
(map-network-events
#'(lambda (err-code)
(if (zerop err-code)
(progn
(setf (state socket) :READ)
(when (stream-server-usocket-p socket)
(setf (%ready-p socket) t)))
(raise-usock-err err-code socket)))
network-events)
(maybe-wsa-error rv socket)))))))
(defun os-wait-list-%wait (wait-list)
(ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event))
(defun (setf os-wait-list-%wait) (value wait-list)
(setf (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event) value))
(defun free-wait-list (wl)
(when (wait-list-p wl)
(unless (null (wait-list-%wait wl))
(wsa-event-close (os-wait-list-%wait wl))
(ffi:free-foreign-object (wait-list-%wait wl))
(setf (wait-list-%wait wl) nil))))
(defun %setup-wait-list (wait-list)
(setf (wait-list-%wait wait-list)
(ffi:allocate-foreign-object 'ws-event))
(setf (os-wait-list-%wait wait-list)
(wsa-event-create))
(ext:set-finalizer wait-list #'free-wait-list))
(defun os-socket-handle (usocket)
(socket-handle usocket))
) ; #+(and ecl-bytecmp windows)
|
