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 38with Ada.Unchecked_Conversion; 39with Interfaces.C.Strings; use Interfaces.C.Strings; 40with System; use System; 41with System.Storage_Elements; use System.Storage_Elements; 42 43package 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 634end GNAT.Sockets.Thin; 635