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