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