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