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-2004 Ada Core Technologies, Inc. -- 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 2, 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. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- As a special exception, if other files instantiate generics from this -- 23-- unit, or you link this unit with other files to produce an executable, -- 24-- this unit does not by itself cause the resulting executable to be -- 25-- covered by the GNU General Public License. This exception does not -- 26-- however invalidate any other reasons why the executable file might be -- 27-- covered by the GNU Public License. -- 28-- -- 29-- GNAT was originally developed by the GNAT team at New York University. -- 30-- Extensive contributions were provided by Ada Core Technologies Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34-- This package provides a target dependent thin interface to the sockets 35-- layer for use by the GNAT.Sockets package (g-socket.ads). This package 36-- should not be directly with'ed by an applications program. 37 38-- This version is for NT. 39 40with GNAT.Sockets.Constants; use GNAT.Sockets.Constants; 41with Interfaces.C.Strings; use Interfaces.C.Strings; 42 43with System; use System; 44 45package body GNAT.Sockets.Thin is 46 47 use type C.unsigned; 48 49 WSAData_Dummy : array (1 .. 512) of C.int; 50 51 WS_Version : constant := 16#0101#; 52 Initialized : Boolean := False; 53 54 SYSNOTREADY : constant := 10091; 55 VERNOTSUPPORTED : constant := 10092; 56 NOTINITIALISED : constant := 10093; 57 EDISCON : constant := 10101; 58 59 function Standard_Connect 60 (S : C.int; 61 Name : System.Address; 62 Namelen : C.int) 63 return C.int; 64 pragma Import (Stdcall, Standard_Connect, "connect"); 65 66 function Standard_Select 67 (Nfds : C.int; 68 Readfds : Fd_Set_Access; 69 Writefds : Fd_Set_Access; 70 Exceptfds : Fd_Set_Access; 71 Timeout : Timeval_Access) 72 return C.int; 73 pragma Import (Stdcall, Standard_Select, "select"); 74 75 type Error_Type is 76 (N_EINTR, 77 N_EBADF, 78 N_EACCES, 79 N_EFAULT, 80 N_EINVAL, 81 N_EMFILE, 82 N_EWOULDBLOCK, 83 N_EINPROGRESS, 84 N_EALREADY, 85 N_ENOTSOCK, 86 N_EDESTADDRREQ, 87 N_EMSGSIZE, 88 N_EPROTOTYPE, 89 N_ENOPROTOOPT, 90 N_EPROTONOSUPPORT, 91 N_ESOCKTNOSUPPORT, 92 N_EOPNOTSUPP, 93 N_EPFNOSUPPORT, 94 N_EAFNOSUPPORT, 95 N_EADDRINUSE, 96 N_EADDRNOTAVAIL, 97 N_ENETDOWN, 98 N_ENETUNREACH, 99 N_ENETRESET, 100 N_ECONNABORTED, 101 N_ECONNRESET, 102 N_ENOBUFS, 103 N_EISCONN, 104 N_ENOTCONN, 105 N_ESHUTDOWN, 106 N_ETOOMANYREFS, 107 N_ETIMEDOUT, 108 N_ECONNREFUSED, 109 N_ELOOP, 110 N_ENAMETOOLONG, 111 N_EHOSTDOWN, 112 N_EHOSTUNREACH, 113 N_SYSNOTREADY, 114 N_VERNOTSUPPORTED, 115 N_NOTINITIALISED, 116 N_EDISCON, 117 N_HOST_NOT_FOUND, 118 N_TRY_AGAIN, 119 N_NO_RECOVERY, 120 N_NO_DATA, 121 N_OTHERS); 122 123 Error_Messages : constant array (Error_Type) of chars_ptr := 124 (N_EINTR => 125 New_String ("Interrupted system call"), 126 N_EBADF => 127 New_String ("Bad file number"), 128 N_EACCES => 129 New_String ("Permission denied"), 130 N_EFAULT => 131 New_String ("Bad address"), 132 N_EINVAL => 133 New_String ("Invalid argument"), 134 N_EMFILE => 135 New_String ("Too many open files"), 136 N_EWOULDBLOCK => 137 New_String ("Operation would block"), 138 N_EINPROGRESS => 139 New_String ("Operation now in progress. This error is " 140 & "returned if any Windows Sockets API " 141 & "function is called while a blocking " 142 & "function is in progress"), 143 N_EALREADY => 144 New_String ("Operation already in progress"), 145 N_ENOTSOCK => 146 New_String ("Socket operation on nonsocket"), 147 N_EDESTADDRREQ => 148 New_String ("Destination address required"), 149 N_EMSGSIZE => 150 New_String ("Message too long"), 151 N_EPROTOTYPE => 152 New_String ("Protocol wrong type for socket"), 153 N_ENOPROTOOPT => 154 New_String ("Protocol not available"), 155 N_EPROTONOSUPPORT => 156 New_String ("Protocol not supported"), 157 N_ESOCKTNOSUPPORT => 158 New_String ("Socket type not supported"), 159 N_EOPNOTSUPP => 160 New_String ("Operation not supported on socket"), 161 N_EPFNOSUPPORT => 162 New_String ("Protocol family not supported"), 163 N_EAFNOSUPPORT => 164 New_String ("Address family not supported by protocol family"), 165 N_EADDRINUSE => 166 New_String ("Address already in use"), 167 N_EADDRNOTAVAIL => 168 New_String ("Cannot assign requested address"), 169 N_ENETDOWN => 170 New_String ("Network is down. This error may be " 171 & "reported at any time if the Windows " 172 & "Sockets implementation detects an " 173 & "underlying failure"), 174 N_ENETUNREACH => 175 New_String ("Network is unreachable"), 176 N_ENETRESET => 177 New_String ("Network dropped connection on reset"), 178 N_ECONNABORTED => 179 New_String ("Software caused connection abort"), 180 N_ECONNRESET => 181 New_String ("Connection reset by peer"), 182 N_ENOBUFS => 183 New_String ("No buffer space available"), 184 N_EISCONN => 185 New_String ("Socket is already connected"), 186 N_ENOTCONN => 187 New_String ("Socket is not connected"), 188 N_ESHUTDOWN => 189 New_String ("Cannot send after socket shutdown"), 190 N_ETOOMANYREFS => 191 New_String ("Too many references: cannot splice"), 192 N_ETIMEDOUT => 193 New_String ("Connection timed out"), 194 N_ECONNREFUSED => 195 New_String ("Connection refused"), 196 N_ELOOP => 197 New_String ("Too many levels of symbolic links"), 198 N_ENAMETOOLONG => 199 New_String ("File name too long"), 200 N_EHOSTDOWN => 201 New_String ("Host is down"), 202 N_EHOSTUNREACH => 203 New_String ("No route to host"), 204 N_SYSNOTREADY => 205 New_String ("Returned by WSAStartup(), indicating that " 206 & "the network subsystem is unusable"), 207 N_VERNOTSUPPORTED => 208 New_String ("Returned by WSAStartup(), indicating that " 209 & "the Windows Sockets DLL cannot support " 210 & "this application"), 211 N_NOTINITIALISED => 212 New_String ("Winsock not initialized. This message is " 213 & "returned by any function except WSAStartup(), " 214 & "indicating that a successful WSAStartup() has " 215 & "not yet been performed"), 216 N_EDISCON => 217 New_String ("Disconnect"), 218 N_HOST_NOT_FOUND => 219 New_String ("Host not found. This message indicates " 220 & "that the key (name, address, and so on) was not found"), 221 N_TRY_AGAIN => 222 New_String ("Nonauthoritative host not found. This error may " 223 & "suggest that the name service itself is not " 224 & "functioning"), 225 N_NO_RECOVERY => 226 New_String ("Nonrecoverable error. This error may suggest that the " 227 & "name service itself is not functioning"), 228 N_NO_DATA => 229 New_String ("Valid name, no data record of requested type. " 230 & "This error indicates that the key (name, address, " 231 & "and so on) was not found."), 232 N_OTHERS => 233 New_String ("Unknown system error")); 234 235 --------------- 236 -- C_Connect -- 237 --------------- 238 239 function C_Connect 240 (S : C.int; 241 Name : System.Address; 242 Namelen : C.int) 243 return C.int 244 is 245 Res : C.int; 246 247 begin 248 Res := Standard_Connect (S, Name, Namelen); 249 250 if Res = -1 then 251 if Socket_Errno = EWOULDBLOCK then 252 Set_Socket_Errno (EINPROGRESS); 253 end if; 254 end if; 255 256 return Res; 257 end C_Connect; 258 259 ------------- 260 -- C_Readv -- 261 ------------- 262 263 function C_Readv 264 (Socket : C.int; 265 Iov : System.Address; 266 Iovcnt : C.int) 267 return C.int 268 is 269 Res : C.int; 270 Count : C.int := 0; 271 272 Iovec : array (0 .. Iovcnt - 1) of Vector_Element; 273 for Iovec'Address use Iov; 274 pragma Import (Ada, Iovec); 275 276 begin 277 for J in Iovec'Range loop 278 Res := C_Recv 279 (Socket, 280 Iovec (J).Base.all'Address, 281 C.int (Iovec (J).Length), 282 0); 283 284 if Res < 0 then 285 return Res; 286 else 287 Count := Count + Res; 288 end if; 289 end loop; 290 return Count; 291 end C_Readv; 292 293 -------------- 294 -- C_Select -- 295 -------------- 296 297 function C_Select 298 (Nfds : C.int; 299 Readfds : Fd_Set_Access; 300 Writefds : Fd_Set_Access; 301 Exceptfds : Fd_Set_Access; 302 Timeout : Timeval_Access) 303 return C.int 304 is 305 pragma Warnings (Off, Exceptfds); 306 307 RFS : constant Fd_Set_Access := Readfds; 308 WFS : constant Fd_Set_Access := Writefds; 309 WFSC : Fd_Set_Access := No_Fd_Set; 310 EFS : Fd_Set_Access := Exceptfds; 311 Res : C.int; 312 S : aliased C.int; 313 Last : aliased C.int; 314 315 begin 316 -- Asynchronous connection failures are notified in the 317 -- exception fd set instead of the write fd set. To ensure 318 -- POSIX compatitibility, copy write fd set into exception fd 319 -- set. Once select() returns, check any socket present in the 320 -- exception fd set and peek at incoming out-of-band data. If 321 -- the test is not successfull and if the socket is present in 322 -- the initial write fd set, then move the socket from the 323 -- exception fd set to the write fd set. 324 325 if WFS /= No_Fd_Set then 326 -- Add any socket present in write fd set into exception fd set 327 328 if EFS = No_Fd_Set then 329 EFS := New_Socket_Set (WFS); 330 331 else 332 WFSC := New_Socket_Set (WFS); 333 334 Last := Nfds - 1; 335 loop 336 Get_Socket_From_Set 337 (WFSC, S'Unchecked_Access, Last'Unchecked_Access); 338 exit when S = -1; 339 Insert_Socket_In_Set (EFS, S); 340 end loop; 341 342 Free_Socket_Set (WFSC); 343 end if; 344 345 -- Keep a copy of write fd set 346 347 WFSC := New_Socket_Set (WFS); 348 end if; 349 350 Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout); 351 352 if EFS /= No_Fd_Set then 353 declare 354 EFSC : constant Fd_Set_Access := New_Socket_Set (EFS); 355 Flag : constant C.int := MSG_PEEK + MSG_OOB; 356 Buffer : Character; 357 Length : C.int; 358 Fromlen : aliased C.int; 359 360 begin 361 Last := Nfds - 1; 362 loop 363 Get_Socket_From_Set 364 (EFSC, S'Unchecked_Access, Last'Unchecked_Access); 365 366 -- No more sockets in EFSC 367 368 exit when S = -1; 369 370 -- Check out-of-band data 371 372 Length := C_Recvfrom 373 (S, Buffer'Address, 1, Flag, 374 null, Fromlen'Unchecked_Access); 375 376 -- If the signal is not an out-of-band data, then it 377 -- is a connection failure notification. 378 379 if Length = -1 then 380 Remove_Socket_From_Set (EFS, S); 381 382 -- If S is present in the initial write fd set, 383 -- move it from exception fd set back to write fd 384 -- set. Otherwise, ignore this event since the user 385 -- is not watching for it. 386 387 if WFSC /= No_Fd_Set 388 and then Is_Socket_In_Set (WFSC, S) 389 then 390 Insert_Socket_In_Set (WFS, S); 391 end if; 392 end if; 393 end loop; 394 395 Free_Socket_Set (EFSC); 396 end; 397 398 if Exceptfds = No_Fd_Set then 399 Free_Socket_Set (EFS); 400 end if; 401 end if; 402 403 -- Free any copy of write fd set 404 405 if WFSC /= No_Fd_Set then 406 Free_Socket_Set (WFSC); 407 end if; 408 409 return Res; 410 end C_Select; 411 412 -------------- 413 -- C_Writev -- 414 -------------- 415 416 function C_Writev 417 (Socket : C.int; 418 Iov : System.Address; 419 Iovcnt : C.int) 420 return C.int 421 is 422 Res : C.int; 423 Count : C.int := 0; 424 425 Iovec : array (0 .. Iovcnt - 1) of Vector_Element; 426 for Iovec'Address use Iov; 427 pragma Import (Ada, Iovec); 428 429 begin 430 for J in Iovec'Range loop 431 Res := C_Send 432 (Socket, 433 Iovec (J).Base.all'Address, 434 C.int (Iovec (J).Length), 435 0); 436 437 if Res < 0 then 438 return Res; 439 else 440 Count := Count + Res; 441 end if; 442 end loop; 443 return Count; 444 end C_Writev; 445 446 -------------- 447 -- Finalize -- 448 -------------- 449 450 procedure Finalize is 451 begin 452 if Initialized then 453 WSACleanup; 454 Initialized := False; 455 end if; 456 end Finalize; 457 458 ---------------- 459 -- Initialize -- 460 ---------------- 461 462 procedure Initialize (Process_Blocking_IO : Boolean := False) is 463 pragma Unreferenced (Process_Blocking_IO); 464 465 Return_Value : Interfaces.C.int; 466 467 begin 468 if not Initialized then 469 Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address); 470 pragma Assert (Interfaces.C."=" (Return_Value, 0)); 471 Initialized := True; 472 end if; 473 end Initialize; 474 475 ----------------- 476 -- Set_Address -- 477 ----------------- 478 479 procedure Set_Address 480 (Sin : Sockaddr_In_Access; 481 Address : In_Addr) 482 is 483 begin 484 Sin.Sin_Addr := Address; 485 end Set_Address; 486 487 ---------------- 488 -- Set_Family -- 489 ---------------- 490 491 procedure Set_Family 492 (Sin : Sockaddr_In_Access; 493 Family : C.int) 494 is 495 begin 496 Sin.Sin_Family := C.unsigned_short (Family); 497 end Set_Family; 498 499 ---------------- 500 -- Set_Length -- 501 ---------------- 502 503 procedure Set_Length 504 (Sin : Sockaddr_In_Access; 505 Len : C.int) 506 is 507 pragma Unreferenced (Sin); 508 pragma Unreferenced (Len); 509 510 begin 511 null; 512 end Set_Length; 513 514 -------------- 515 -- Set_Port -- 516 -------------- 517 518 procedure Set_Port 519 (Sin : Sockaddr_In_Access; 520 Port : C.unsigned_short) 521 is 522 begin 523 Sin.Sin_Port := Port; 524 end Set_Port; 525 526 -------------------------- 527 -- Socket_Error_Message -- 528 -------------------------- 529 530 function Socket_Error_Message 531 (Errno : Integer) 532 return C.Strings.chars_ptr 533 is 534 use GNAT.Sockets.Constants; 535 536 begin 537 case Errno is 538 when EINTR => return Error_Messages (N_EINTR); 539 when EBADF => return Error_Messages (N_EBADF); 540 when EACCES => return Error_Messages (N_EACCES); 541 when EFAULT => return Error_Messages (N_EFAULT); 542 when EINVAL => return Error_Messages (N_EINVAL); 543 when EMFILE => return Error_Messages (N_EMFILE); 544 when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK); 545 when EINPROGRESS => return Error_Messages (N_EINPROGRESS); 546 when EALREADY => return Error_Messages (N_EALREADY); 547 when ENOTSOCK => return Error_Messages (N_ENOTSOCK); 548 when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ); 549 when EMSGSIZE => return Error_Messages (N_EMSGSIZE); 550 when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE); 551 when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT); 552 when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT); 553 when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT); 554 when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP); 555 when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT); 556 when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT); 557 when EADDRINUSE => return Error_Messages (N_EADDRINUSE); 558 when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL); 559 when ENETDOWN => return Error_Messages (N_ENETDOWN); 560 when ENETUNREACH => return Error_Messages (N_ENETUNREACH); 561 when ENETRESET => return Error_Messages (N_ENETRESET); 562 when ECONNABORTED => return Error_Messages (N_ECONNABORTED); 563 when ECONNRESET => return Error_Messages (N_ECONNRESET); 564 when ENOBUFS => return Error_Messages (N_ENOBUFS); 565 when EISCONN => return Error_Messages (N_EISCONN); 566 when ENOTCONN => return Error_Messages (N_ENOTCONN); 567 when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN); 568 when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS); 569 when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT); 570 when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED); 571 when ELOOP => return Error_Messages (N_ELOOP); 572 when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG); 573 when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN); 574 when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH); 575 when SYSNOTREADY => return Error_Messages (N_SYSNOTREADY); 576 when VERNOTSUPPORTED => return Error_Messages (N_VERNOTSUPPORTED); 577 when NOTINITIALISED => return Error_Messages (N_NOTINITIALISED); 578 when EDISCON => return Error_Messages (N_EDISCON); 579 when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND); 580 when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN); 581 when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY); 582 when NO_DATA => return Error_Messages (N_NO_DATA); 583 when others => return Error_Messages (N_OTHERS); 584 end case; 585 end Socket_Error_Message; 586 587end GNAT.Sockets.Thin; 588