?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Daily bump.
[official-gcc.git] / gcc / ada / libgnat / g-socthi__mingw.adb
blob9aae6f6cb912add9e575677d06e7d338e9683e2b
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-2024, 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 Original_WFS : aliased Fd_Set;
379 Res : C.int;
380 S : aliased C.int;
381 Last : aliased C.int;
382
383 begin
384 -- Asynchronous connection failures are notified in the exception fd
385 -- set instead of the write fd set. To ensure POSIX compatibility, copy
386 -- write fd set into exception fd set. Once select() returns, check any
387 -- socket present in the exception fd set and peek at incoming
388 -- out-of-band data. If the test is not successful, and the socket is
389 -- present in the initial write fd set, then move the socket from the
390 -- exception fd set to the write fd set.
391
392 if Writefds /= null then
393 Original_WFS := Writefds.all;
394
395 -- Add any socket present in write fd set into exception fd set
396
397 declare
398 WFS : aliased Fd_Set := Writefds.all;
399 begin
400 Last := Nfds - 1;
401 loop
402 Get_Socket_From_Set
403 (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access);
404 exit when S = -1;
405 Insert_Socket_In_Set (Exceptfds, S);
406 end loop;
407 end;
408 end if;
409
410 Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout);
411
412 if Exceptfds /= null then
413 declare
414 EFSC : aliased Fd_Set := Exceptfds.all;
415 Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB;
416 Buffer : Character;
417 Length : C.int;
418 Fromlen : aliased C.int;
419
420 begin
421 Last := Nfds - 1;
422 loop
423 Get_Socket_From_Set
424 (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access);
425
426 -- No more sockets in EFSC
427
428 exit when S = -1;
429
430 -- Check out-of-band data
431
432 Length :=
433 C_Recvfrom
434 (S, Buffer'Address, 1, Flag,
435 From => System.Null_Address,
436 Fromlen => Fromlen'Unchecked_Access);
437 -- Is Fromlen necessary if From is Null_Address???
438
439 -- If the signal is not an out-of-band data, then it
440 -- is a connection failure notification.
441
442 if Length = -1 then
443 Remove_Socket_From_Set (Exceptfds, S);
444
445 -- If S is present in the initial write fd set, move it from
446 -- exception fd set back to write fd set. Otherwise, ignore
447 -- this event since the user is not watching for it.
448
449 if Writefds /= null
450 and then Is_Socket_In_Set (Original_WFS'Access, S) /= 0
451 then
452 Insert_Socket_In_Set (Writefds, S);
453 end if;
454 end if;
455 end loop;
456 end;
457 end if;
458
459 return Res;
460 end C_Select;
461
462 ---------------
463 -- C_Sendmsg --
464 ---------------
465
466 function C_Sendmsg
467 (S : C.int;
468 Msg : System.Address;
469 Flags : C.int) return System.CRTL.ssize_t
470 is
471 use type C.size_t;
472
473 Res : C.int;
474 Count : C.int := 0;
475
476 MH : Msghdr;
477 for MH'Address use Msg;
478
479 Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
480 for Iovec'Address use MH.Msg_Iov;
481 pragma Import (Ada, Iovec);
482
483 begin
484 -- Windows does not provide an implementation of sendmsg(). The spec for
485 -- WSASendMsg() is incompatible with the data types we define, and is
486 -- available starting with Windows Vista and Server 2008 only. So
487 -- use C_Sendto instead.
488
489 for J in Iovec'Range loop
490 Res :=
491 C_Sendto
492 (S,
493 Iovec (J).Base.all'Address,
494 C.int (Iovec (J).Length),
495 Flags => Flags,
496 To => MH.Msg_Name,
497 Tolen => C.int (MH.Msg_Namelen));
498
499 if Res < 0 then
500 return System.CRTL.ssize_t (Res);
501 else
502 Count := Count + Res;
503 end if;
504
505 -- Exit now if the buffer is not fully transmitted
506
507 exit when Interfaces.C.size_t (Res) < Iovec (J).Length;
508 end loop;
509
510 return System.CRTL.ssize_t (Count);
511 end C_Sendmsg;
512
513 ------------------
514 -- C_Socketpair --
515 ------------------
516
517 function C_Socketpair
518 (Domain : C.int;
519 Typ : C.int;
520 Protocol : C.int;
521 Fds : not null access Fd_Pair) return C.int is separate;
522
523 --------------
524 -- Finalize --
525 --------------
526
527 procedure Finalize is
528 begin
529 if Initialized then
530 WSACleanup;
531 Initialized := False;
532 end if;
533 end Finalize;
534
535 -------------------------
536 -- Host_Error_Messages --
537 -------------------------
538
539 package body Host_Error_Messages is
540
541 -- On Windows, socket and host errors share the same code space, and
542 -- error messages are provided by Socket_Error_Message, so the default
543 -- separate body for Host_Error_Messages is not used in this case.
544
545 function Host_Error_Message (H_Errno : Integer) return String
546 renames Socket_Error_Message;
547
548 end Host_Error_Messages;
549
550 ----------------
551 -- Initialize --
552 ----------------
553
554 procedure Initialize is
555 Return_Value : Interfaces.C.int;
556 begin
557 if not Initialized then
558 Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
559 pragma Assert (Return_Value = 0);
560 Initialized := True;
561 end if;
562 end Initialize;
563
564 --------------------
565 -- Signalling_Fds --
566 --------------------
567
568 package body Signalling_Fds is separate;
569
570 --------------------------
571 -- Socket_Error_Message --
572 --------------------------
573
574 function Socket_Error_Message (Errno : Integer) return String is
575 use GNAT.Sockets.SOSC;
576
577 Errm : C.Strings.chars_ptr;
578
579 begin
580 case Errno is
581 when EINTR => Errm := Error_Messages (N_EINTR);
582 when EBADF => Errm := Error_Messages (N_EBADF);
583 when EACCES => Errm := Error_Messages (N_EACCES);
584 when EFAULT => Errm := Error_Messages (N_EFAULT);
585 when EINVAL => Errm := Error_Messages (N_EINVAL);
586 when EMFILE => Errm := Error_Messages (N_EMFILE);
587 when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK);
588 when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS);
589 when EALREADY => Errm := Error_Messages (N_EALREADY);
590 when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK);
591 when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ);
592 when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE);
593 when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE);
594 when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT);
595 when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT);
596 when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT);
597 when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP);
598 when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT);
599 when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT);
600 when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE);
601 when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL);
602 when ENETDOWN => Errm := Error_Messages (N_ENETDOWN);
603 when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH);
604 when ENETRESET => Errm := Error_Messages (N_ENETRESET);
605 when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED);
606 when ECONNRESET => Errm := Error_Messages (N_ECONNRESET);
607 when ENOBUFS => Errm := Error_Messages (N_ENOBUFS);
608 when EISCONN => Errm := Error_Messages (N_EISCONN);
609 when ENOTCONN => Errm := Error_Messages (N_ENOTCONN);
610 when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN);
611 when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS);
612 when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT);
613 when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED);
614 when ELOOP => Errm := Error_Messages (N_ELOOP);
615 when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG);
616 when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN);
617 when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH);
618
619 -- Windows-specific error codes
620
621 when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY);
622 when WSAVERNOTSUPPORTED =>
623 Errm := Error_Messages (N_WSAVERNOTSUPPORTED);
624 when WSANOTINITIALISED =>
625 Errm := Error_Messages (N_WSANOTINITIALISED);
626 when WSAEDISCON => Errm := Error_Messages (N_WSAEDISCON);
627
628 -- h_errno values
629
630 when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND);
631 when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN);
632 when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY);
633 when NO_DATA => Errm := Error_Messages (N_NO_DATA);
634 when others => Errm := Error_Messages (N_OTHERS);
635 end case;
636
637 return Value (Errm);
638 end Socket_Error_Message;
639
640 end GNAT.Sockets.Thin;
Mirror of the offical gcc git repository hosted at gcc.gnu.org