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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . S O C K E T S . T H I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This version is for NT.
package body GNAT.Sockets.Thin is
use type C.unsigned;
WSAData_Dummy : array (1 .. 512) of C.int;
WS_Version : constant := 16#0101#;
Initialized : Boolean := False;
-----------
-- Clear --
-----------
procedure Clear
(Item : in out Fd_Set;
Socket : C.int)
is
begin
for J in 1 .. Item.fd_count loop
if Item.fd_array (J) = Socket then
Item.fd_array (J .. Item.fd_count - 1) :=
Item.fd_array (J + 1 .. Item.fd_count);
Item.fd_count := Item.fd_count - 1;
exit;
end if;
end loop;
end Clear;
-----------
-- Empty --
-----------
procedure Empty (Item : in out Fd_Set) is
begin
Item := Null_Fd_Set;
end Empty;
--------------
-- Finalize --
--------------
procedure Finalize is
begin
if Initialized then
WSACleanup;
Initialized := False;
end if;
end Finalize;
--------------
-- Is_Empty --
--------------
function Is_Empty (Item : Fd_Set) return Boolean is
begin
return Item.fd_count = 0;
end Is_Empty;
------------
-- Is_Set --
------------
function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is
begin
for J in 1 .. Item.fd_count loop
if Item.fd_array (J) = Socket then
return True;
end if;
end loop;
return False;
end Is_Set;
----------------
-- Initialize --
----------------
procedure Initialize (Process_Blocking_IO : Boolean := False) is
Return_Value : Interfaces.C.int;
begin
if not Initialized then
Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
pragma Assert (Interfaces.C."=" (Return_Value, 0));
Initialized := True;
end if;
end Initialize;
---------
-- Max --
---------
function Max (Item : Fd_Set) return C.int is
L : C.int := 0;
begin
for J in 1 .. Item.fd_count loop
if Item.fd_array (J) > L then
L := Item.fd_array (J);
end if;
end loop;
return L;
end Max;
---------
-- Set --
---------
procedure Set (Item : in out Fd_Set; Socket : in C.int) is
begin
Item.fd_count := Item.fd_count + 1;
Item.fd_array (Item.fd_count) := Socket;
end Set;
--------------------------
-- Socket_Error_Message --
--------------------------
function Socket_Error_Message (Errno : Integer) return String is
use GNAT.Sockets.Constants;
begin
case Errno is
when EINTR =>
return "Interrupted system call";
when EBADF =>
return "Bad file number";
when EACCES =>
return "Permission denied";
when EFAULT =>
return "Bad address";
when EINVAL =>
return "Invalid argument";
when EMFILE =>
return "Too many open files";
when EWOULDBLOCK =>
return "Operation would block";
when EINPROGRESS =>
return "Operation now in progress. This error is "
& "returned if any Windows Sockets API "
& "function is called while a blocking "
& "function is in progress";
when EALREADY =>
return "Operation already in progress";
when ENOTSOCK =>
return "Socket operation on nonsocket";
when EDESTADDRREQ =>
return "Destination address required";
when EMSGSIZE =>
return "Message too long";
when EPROTOTYPE =>
return "Protocol wrong type for socket";
when ENOPROTOOPT =>
return "Protocol not available";
when EPROTONOSUPPORT =>
return "Protocol not supported";
when ESOCKTNOSUPPORT =>
return "Socket type not supported";
when EOPNOTSUPP =>
return "Operation not supported on socket";
when EPFNOSUPPORT =>
return "Protocol family not supported";
when EAFNOSUPPORT =>
return "Address family not supported by protocol family";
when EADDRINUSE =>
return "Address already in use";
when EADDRNOTAVAIL =>
return "Cannot assign requested address";
when ENETDOWN =>
return "Network is down. This error may be "
& "reported at any time if the Windows "
& "Sockets implementation detects an "
& "underlying failure";
when ENETUNREACH =>
return "Network is unreachable";
when ENETRESET =>
return "Network dropped connection on reset";
when ECONNABORTED =>
return "Software caused connection abort";
when ECONNRESET =>
return "Connection reset by peer";
when ENOBUFS =>
return "No buffer space available";
when EISCONN =>
return "Socket is already connected";
when ENOTCONN =>
return "Socket is not connected";
when ESHUTDOWN =>
return "Cannot send after socket shutdown";
when ETOOMANYREFS =>
return "Too many references: cannot splice";
when ETIMEDOUT =>
return "Connection timed out";
when ECONNREFUSED =>
return "Connection refused";
when ELOOP =>
return "Too many levels of symbolic links";
when ENAMETOOLONG =>
return "File name too long";
when EHOSTDOWN =>
return "Host is down";
when EHOSTUNREACH =>
return "No route to host";
when SYSNOTREADY =>
return "Returned by WSAStartup(), indicating that "
& "the network subsystem is unusable";
when VERNOTSUPPORTED =>
return "Returned by WSAStartup(), indicating that "
& "the Windows Sockets DLL cannot support this application";
when NOTINITIALISED =>
return "Winsock not initialized. This message is "
& "returned by any function except WSAStartup(), "
& "indicating that a successful WSAStartup() has "
& "not yet been performed";
when EDISCON =>
return "Disconnect";
when HOST_NOT_FOUND =>
return "Host not found. This message indicates "
& "that the key (name, address, and so on) was not found";
when TRY_AGAIN =>
return "Nonauthoritative host not found. This error may "
& "suggest that the name service itself is not functioning";
when NO_RECOVERY =>
return "Nonrecoverable error. This error may suggest that the "
& "name service itself is not functioning";
when NO_DATA =>
return "Valid name, no data record of requested type. "
& "This error indicates that the key (name, address, "
& "and so on) was not found.";
when others =>
return "Unknown system error";
end case;
end Socket_Error_Message;
end GNAT.Sockets.Thin;
|
