?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2010-07-27 Paolo Carlini <paolo.carlini@oracle.com>
[official-gcc/alias-decl.git] / gcc / ada / g-socthi-mingw.adb
blob727a69ddba9ea1e85ff44f022bb2794deada228d
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T . S O C K E T S . T H I N --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2010, AdaCore --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
33
34 -- This package provides a target dependent thin interface to the sockets
35 -- layer for use by the GNAT.Sockets package (g-socket.ads). This package
36 -- should not be directly with'ed by an applications program.
37
38 -- This version is for NT
39
40 with Ada.Streams; use Ada.Streams;
41 with Ada.Unchecked_Conversion;
42 with Interfaces.C.Strings; use Interfaces.C.Strings;
43 with System; use System;
44 with System.Storage_Elements; use System.Storage_Elements;
45
46 package body GNAT.Sockets.Thin is
47
48 use type C.unsigned;
49 use type C.int;
50
51 WSAData_Dummy : array (1 .. 512) of C.int;
52
53 WS_Version : constant := 16#0202#;
54 -- Winsock 2.2
55
56 Initialized : Boolean := False;
57
58 function Standard_Connect
59 (S : C.int;
60 Name : System.Address;
61 Namelen : C.int) return C.int;
62 pragma Import (Stdcall, Standard_Connect, "connect");
63
64 function Standard_Select
65 (Nfds : C.int;
66 Readfds : access Fd_Set;
67 Writefds : access Fd_Set;
68 Exceptfds : access Fd_Set;
69 Timeout : Timeval_Access) return C.int;
70 pragma Import (Stdcall, Standard_Select, "select");
71
72 type Error_Type is
73 (N_EINTR,
74 N_EBADF,
75 N_EACCES,
76 N_EFAULT,
77 N_EINVAL,
78 N_EMFILE,
79 N_EWOULDBLOCK,
80 N_EINPROGRESS,
81 N_EALREADY,
82 N_ENOTSOCK,
83 N_EDESTADDRREQ,
84 N_EMSGSIZE,
85 N_EPROTOTYPE,
86 N_ENOPROTOOPT,
87 N_EPROTONOSUPPORT,
88 N_ESOCKTNOSUPPORT,
89 N_EOPNOTSUPP,
90 N_EPFNOSUPPORT,
91 N_EAFNOSUPPORT,
92 N_EADDRINUSE,
93 N_EADDRNOTAVAIL,
94 N_ENETDOWN,
95 N_ENETUNREACH,
96 N_ENETRESET,
97 N_ECONNABORTED,
98 N_ECONNRESET,
99 N_ENOBUFS,
100 N_EISCONN,
101 N_ENOTCONN,
102 N_ESHUTDOWN,
103 N_ETOOMANYREFS,
104 N_ETIMEDOUT,
105 N_ECONNREFUSED,
106 N_ELOOP,
107 N_ENAMETOOLONG,
108 N_EHOSTDOWN,
109 N_EHOSTUNREACH,
110 N_WSASYSNOTREADY,
111 N_WSAVERNOTSUPPORTED,
112 N_WSANOTINITIALISED,
113 N_WSAEDISCON,
114 N_HOST_NOT_FOUND,
115 N_TRY_AGAIN,
116 N_NO_RECOVERY,
117 N_NO_DATA,
118 N_OTHERS);
119
120 Error_Messages : constant array (Error_Type) of chars_ptr :=
121 (N_EINTR =>
122 New_String ("Interrupted system call"),
123 N_EBADF =>
124 New_String ("Bad file number"),
125 N_EACCES =>
126 New_String ("Permission denied"),
127 N_EFAULT =>
128 New_String ("Bad address"),
129 N_EINVAL =>
130 New_String ("Invalid argument"),
131 N_EMFILE =>
132 New_String ("Too many open files"),
133 N_EWOULDBLOCK =>
134 New_String ("Operation would block"),
135 N_EINPROGRESS =>
136 New_String ("Operation now in progress. This error is "
137 & "returned if any Windows Sockets API "
138 & "function is called while a blocking "
139 & "function is in progress"),
140 N_EALREADY =>
141 New_String ("Operation already in progress"),
142 N_ENOTSOCK =>
143 New_String ("Socket operation on nonsocket"),
144 N_EDESTADDRREQ =>
145 New_String ("Destination address required"),
146 N_EMSGSIZE =>
147 New_String ("Message too long"),
148 N_EPROTOTYPE =>
149 New_String ("Protocol wrong type for socket"),
150 N_ENOPROTOOPT =>
151 New_String ("Protocol not available"),
152 N_EPROTONOSUPPORT =>
153 New_String ("Protocol not supported"),
154 N_ESOCKTNOSUPPORT =>
155 New_String ("Socket type not supported"),
156 N_EOPNOTSUPP =>
157 New_String ("Operation not supported on socket"),
158 N_EPFNOSUPPORT =>
159 New_String ("Protocol family not supported"),
160 N_EAFNOSUPPORT =>
161 New_String ("Address family not supported by protocol family"),
162 N_EADDRINUSE =>
163 New_String ("Address already in use"),
164 N_EADDRNOTAVAIL =>
165 New_String ("Cannot assign requested address"),
166 N_ENETDOWN =>
167 New_String ("Network is down. This error may be "
168 & "reported at any time if the Windows "
169 & "Sockets implementation detects an "
170 & "underlying failure"),
171 N_ENETUNREACH =>
172 New_String ("Network is unreachable"),
173 N_ENETRESET =>
174 New_String ("Network dropped connection on reset"),
175 N_ECONNABORTED =>
176 New_String ("Software caused connection abort"),
177 N_ECONNRESET =>
178 New_String ("Connection reset by peer"),
179 N_ENOBUFS =>
180 New_String ("No buffer space available"),
181 N_EISCONN =>
182 New_String ("Socket is already connected"),
183 N_ENOTCONN =>
184 New_String ("Socket is not connected"),
185 N_ESHUTDOWN =>
186 New_String ("Cannot send after socket shutdown"),
187 N_ETOOMANYREFS =>
188 New_String ("Too many references: cannot splice"),
189 N_ETIMEDOUT =>
190 New_String ("Connection timed out"),
191 N_ECONNREFUSED =>
192 New_String ("Connection refused"),
193 N_ELOOP =>
194 New_String ("Too many levels of symbolic links"),
195 N_ENAMETOOLONG =>
196 New_String ("File name too long"),
197 N_EHOSTDOWN =>
198 New_String ("Host is down"),
199 N_EHOSTUNREACH =>
200 New_String ("No route to host"),
201 N_WSASYSNOTREADY =>
202 New_String ("Returned by WSAStartup(), indicating that "
203 & "the network subsystem is unusable"),
204 N_WSAVERNOTSUPPORTED =>
205 New_String ("Returned by WSAStartup(), indicating that "
206 & "the Windows Sockets DLL cannot support "
207 & "this application"),
208 N_WSANOTINITIALISED =>
209 New_String ("Winsock not initialized. This message is "
210 & "returned by any function except WSAStartup(), "
211 & "indicating that a successful WSAStartup() has "
212 & "not yet been performed"),
213 N_WSAEDISCON =>
214 New_String ("Disconnected"),
215 N_HOST_NOT_FOUND =>
216 New_String ("Host not found. This message indicates "
217 & "that the key (name, address, and so on) was not found"),
218 N_TRY_AGAIN =>
219 New_String ("Nonauthoritative host not found. This error may "
220 & "suggest that the name service itself is not "
221 & "functioning"),
222 N_NO_RECOVERY =>
223 New_String ("Nonrecoverable error. This error may suggest that the "
224 & "name service itself is not functioning"),
225 N_NO_DATA =>
226 New_String ("Valid name, no data record of requested type. "
227 & "This error indicates that the key (name, address, "
228 & "and so on) was not found."),
229 N_OTHERS =>
230 New_String ("Unknown system error"));
231
232 ---------------
233 -- C_Connect --
234 ---------------
235
236 function C_Connect
237 (S : C.int;
238 Name : System.Address;
239 Namelen : C.int) return C.int
240 is
241 Res : C.int;
242
243 begin
244 Res := Standard_Connect (S, Name, Namelen);
245
246 if Res = -1 then
247 if Socket_Errno = SOSC.EWOULDBLOCK then
248 Set_Socket_Errno (SOSC.EINPROGRESS);
249 end if;
250 end if;
251
252 return Res;
253 end C_Connect;
254
255 ------------------
256 -- Socket_Ioctl --
257 ------------------
258
259 function Socket_Ioctl
260 (S : C.int;
261 Req : C.int;
262 Arg : access C.int) return C.int
263 is
264 begin
265 return C_Ioctl (S, Req, Arg);
266 end Socket_Ioctl;
267
268 ---------------
269 -- C_Recvmsg --
270 ---------------
271
272 function C_Recvmsg
273 (S : C.int;
274 Msg : System.Address;
275 Flags : C.int) return System.CRTL.ssize_t
276 is
277 use type C.size_t;
278
279 Fill : constant Boolean :=
280 (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0;
281 -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors
282
283 Res : C.int;
284 Count : C.int := 0;
285
286 MH : Msghdr;
287 for MH'Address use Msg;
288
289 Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
290 for Iovec'Address use MH.Msg_Iov;
291 pragma Import (Ada, Iovec);
292
293 Iov_Index : Integer;
294 Current_Iovec : Vector_Element;
295
296 function To_Access is new Ada.Unchecked_Conversion
297 (System.Address, Stream_Element_Reference);
298 pragma Warnings (Off, Stream_Element_Reference);
299
300 Req : Request_Type (Name => N_Bytes_To_Read);
301
302 begin
303 -- Windows does not provide an implementation of recvmsg(). The spec for
304 -- WSARecvMsg() is incompatible with the data types we define, and is
305 -- available starting with Windows Vista and Server 2008 only. So,
306 -- we use C_Recv instead.
307
308 -- Check how much data are available
309
310 Control_Socket (Socket_Type (S), Req);
311
312 -- Fill the vectors
313
314 Iov_Index := -1;
315 Current_Iovec := (Base => null, Length => 0);
316
317 loop
318 if Current_Iovec.Length = 0 then
319 Iov_Index := Iov_Index + 1;
320 exit when Iov_Index > Integer (Iovec'Last);
321 Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index));
322 end if;
323
324 Res :=
325 C_Recv
326 (S,
327 Current_Iovec.Base.all'Address,
328 C.int (Current_Iovec.Length),
329 Flags);
330
331 if Res < 0 then
332 return System.CRTL.ssize_t (Res);
333
334 elsif Res = 0 and then not Fill then
335 exit;
336
337 else
338 pragma Assert (Stream_Element_Count (Res) <= Current_Iovec.Length);
339
340 Count := Count + Res;
341 Current_Iovec.Length :=
342 Current_Iovec.Length - Stream_Element_Count (Res);
343 Current_Iovec.Base :=
344 To_Access (Current_Iovec.Base.all'Address
345 + Storage_Offset (Res));
346
347 -- If all the data that was initially available read, do not
348 -- attempt to receive more, since this might block, or merge data
349 -- from successive datagrams for a datagram-oriented socket. We
350 -- still try to receive more if we need to fill all vectors
351 -- (MSG_WAITALL flag is set).
352
353 exit when Natural (Count) >= Req.Size
354 and then
355
356 -- Either we are not in fill mode
357
358 (not Fill
359
360 -- Or else last vector filled
361
362 or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last
363 and then Current_Iovec.Length = 0));
364 end if;
365 end loop;
366
367 return System.CRTL.ssize_t (Count);
368 end C_Recvmsg;
369
370 --------------
371 -- C_Select --
372 --------------
373
374 function C_Select
375 (Nfds : C.int;
376 Readfds : access Fd_Set;
377 Writefds : access Fd_Set;
378 Exceptfds : access Fd_Set;
379 Timeout : Timeval_Access) return C.int
380 is
381 pragma Warnings (Off, Exceptfds);
382
383 Original_WFS : aliased constant Fd_Set := Writefds.all;
384
385 Res : C.int;
386 S : aliased C.int;
387 Last : aliased C.int;
388
389 begin
390 -- Asynchronous connection failures are notified in the exception fd
391 -- set instead of the write fd set. To ensure POSIX compatibility, copy
392 -- write fd set into exception fd set. Once select() returns, check any
393 -- socket present in the exception fd set and peek at incoming
394 -- out-of-band data. If the test is not successful, and the socket is
395 -- present in the initial write fd set, then move the socket from the
396 -- exception fd set to the write fd set.
397
398 if Writefds /= No_Fd_Set_Access then
399
400 -- Add any socket present in write fd set into exception fd set
401
402 declare
403 WFS : aliased Fd_Set := Writefds.all;
404 begin
405 Last := Nfds - 1;
406 loop
407 Get_Socket_From_Set
408 (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access);
409 exit when S = -1;
410 Insert_Socket_In_Set (Exceptfds, S);
411 end loop;
412 end;
413 end if;
414
415 Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout);
416
417 if Exceptfds /= No_Fd_Set_Access then
418 declare
419 EFSC : aliased Fd_Set := Exceptfds.all;
420 Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB;
421 Buffer : Character;
422 Length : C.int;
423 Fromlen : aliased C.int;
424
425 begin
426 Last := Nfds - 1;
427 loop
428 Get_Socket_From_Set
429 (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access);
430
431 -- No more sockets in EFSC
432
433 exit when S = -1;
434
435 -- Check out-of-band data
436
437 Length :=
438 C_Recvfrom
439 (S, Buffer'Address, 1, Flag,
440 From => System.Null_Address,
441 Fromlen => Fromlen'Unchecked_Access);
442 -- Is Fromlen necessary if From is Null_Address???
443
444 -- If the signal is not an out-of-band data, then it
445 -- is a connection failure notification.
446
447 if Length = -1 then
448 Remove_Socket_From_Set (Exceptfds, S);
449
450 -- If S is present in the initial write fd set, move it from
451 -- exception fd set back to write fd set. Otherwise, ignore
452 -- this event since the user is not watching for it.
453
454 if Writefds /= No_Fd_Set_Access
455 and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0)
456 then
457 Insert_Socket_In_Set (Writefds, S);
458 end if;
459 end if;
460 end loop;
461 end;
462 end if;
463 return Res;
464 end C_Select;
465
466 ---------------
467 -- C_Sendmsg --
468 ---------------
469
470 function C_Sendmsg
471 (S : C.int;
472 Msg : System.Address;
473 Flags : C.int) return System.CRTL.ssize_t
474 is
475 use type C.size_t;
476
477 Res : C.int;
478 Count : C.int := 0;
479
480 MH : Msghdr;
481 for MH'Address use Msg;
482
483 Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
484 for Iovec'Address use MH.Msg_Iov;
485 pragma Import (Ada, Iovec);
486
487 begin
488 -- Windows does not provide an implementation of sendmsg(). The spec for
489 -- WSASendMsg() is incompatible with the data types we define, and is
490 -- available starting with Windows Vista and Server 2008 only. So
491 -- use C_Sendto instead.
492
493 for J in Iovec'Range loop
494 Res :=
495 C_Sendto
496 (S,
497 Iovec (J).Base.all'Address,
498 C.int (Iovec (J).Length),
499 Flags => Flags,
500 To => MH.Msg_Name,
501 Tolen => C.int (MH.Msg_Namelen));
502
503 if Res < 0 then
504 return System.CRTL.ssize_t (Res);
505 else
506 Count := Count + Res;
507 end if;
508
509 -- Exit now if the buffer is not fully transmitted
510
511 exit when Stream_Element_Count (Res) < Iovec (J).Length;
512 end loop;
513
514 return System.CRTL.ssize_t (Count);
515 end C_Sendmsg;
516
517 --------------
518 -- Finalize --
519 --------------
520
521 procedure Finalize is
522 begin
523 if Initialized then
524 WSACleanup;
525 Initialized := False;
526 end if;
527 end Finalize;
528
529 -------------------------
530 -- Host_Error_Messages --
531 -------------------------
532
533 package body Host_Error_Messages is
534
535 -- On Windows, socket and host errors share the same code space, and
536 -- error messages are provided by Socket_Error_Message, so the default
537 -- separate body for Host_Error_Messages is not used in this case.
538
539 function Host_Error_Message
540 (H_Errno : Integer) return C.Strings.chars_ptr
541 renames Socket_Error_Message;
542
543 end Host_Error_Messages;
544
545 ----------------
546 -- Initialize --
547 ----------------
548
549 procedure Initialize is
550 Return_Value : Interfaces.C.int;
551 begin
552 if not Initialized then
553 Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
554 pragma Assert (Return_Value = 0);
555 Initialized := True;
556 end if;
557 end Initialize;
558
559 --------------------
560 -- Signalling_Fds --
561 --------------------
562
563 package body Signalling_Fds is separate;
564
565 --------------------------
566 -- Socket_Error_Message --
567 --------------------------
568
569 function Socket_Error_Message
570 (Errno : Integer) return C.Strings.chars_ptr
571 is
572 use GNAT.Sockets.SOSC;
573
574 begin
575 case Errno is
576 when EINTR => return Error_Messages (N_EINTR);
577 when EBADF => return Error_Messages (N_EBADF);
578 when EACCES => return Error_Messages (N_EACCES);
579 when EFAULT => return Error_Messages (N_EFAULT);
580 when EINVAL => return Error_Messages (N_EINVAL);
581 when EMFILE => return Error_Messages (N_EMFILE);
582 when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK);
583 when EINPROGRESS => return Error_Messages (N_EINPROGRESS);
584 when EALREADY => return Error_Messages (N_EALREADY);
585 when ENOTSOCK => return Error_Messages (N_ENOTSOCK);
586 when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ);
587 when EMSGSIZE => return Error_Messages (N_EMSGSIZE);
588 when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE);
589 when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT);
590 when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT);
591 when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT);
592 when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP);
593 when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT);
594 when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT);
595 when EADDRINUSE => return Error_Messages (N_EADDRINUSE);
596 when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL);
597 when ENETDOWN => return Error_Messages (N_ENETDOWN);
598 when ENETUNREACH => return Error_Messages (N_ENETUNREACH);
599 when ENETRESET => return Error_Messages (N_ENETRESET);
600 when ECONNABORTED => return Error_Messages (N_ECONNABORTED);
601 when ECONNRESET => return Error_Messages (N_ECONNRESET);
602 when ENOBUFS => return Error_Messages (N_ENOBUFS);
603 when EISCONN => return Error_Messages (N_EISCONN);
604 when ENOTCONN => return Error_Messages (N_ENOTCONN);
605 when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN);
606 when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS);
607 when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT);
608 when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED);
609 when ELOOP => return Error_Messages (N_ELOOP);
610 when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG);
611 when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN);
612 when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH);
613
614 -- Windows-specific error codes
615
616 when WSASYSNOTREADY => return Error_Messages (N_WSASYSNOTREADY);
617 when WSAVERNOTSUPPORTED =>
618 return Error_Messages (N_WSAVERNOTSUPPORTED);
619 when WSANOTINITIALISED =>
620 return Error_Messages (N_WSANOTINITIALISED);
621 when WSAEDISCON => return Error_Messages (N_WSAEDISCON);
622
623 -- h_errno values
624
625 when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND);
626 when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN);
627 when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY);
628 when NO_DATA => return Error_Messages (N_NO_DATA);
629
630 when others => return Error_Messages (N_OTHERS);
631 end case;
632 end Socket_Error_Message;
633
634 end GNAT.Sockets.Thin;