gcc/ada/g-socthi-mingw.adb

   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-2009, 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 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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
  40 with Interfaces.C.Strings; use Interfaces.C.Strings;
  41 with System;               use System;
  42
  43 package 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 : C.int;
 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 ssize_t
 273    is
 274       Res   : C.int;
 275       Count : C.int := 0;
 276
 277       MH : Msghdr;
 278       for MH'Address use Msg;
 279
 280       Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
 281       for Iovec'Address use MH.Msg_Iov;
 282       pragma Import (Ada, Iovec);
 283
 284    begin
 285       --  Windows does not provide an implementation of recvmsg(). The spec for
 286       --  WSARecvMsg() is incompatible with the data types we define, and is
 287       --  not available in all versions of Windows. So, we use C_Recv instead.
 288
 289       for J in Iovec'Range loop
 290          Res := C_Recv
 291            (S,
 292             Iovec (J).Base.all'Address,
 293             C.int (Iovec (J).Length),
 294             Flags);
 295
 296          if Res < 0 then
 297             return ssize_t (Res);
 298          else
 299             Count := Count + Res;
 300          end if;
 301       end loop;
 302       return ssize_t (Count);
 303    end C_Recvmsg;
 304
 305    --------------
 306    -- C_Select --
 307    --------------
 308
 309    function C_Select
 310      (Nfds      : C.int;
 311       Readfds   : access Fd_Set;
 312       Writefds  : access Fd_Set;
 313       Exceptfds : access Fd_Set;
 314       Timeout   : Timeval_Access) return C.int
 315    is
 316       pragma Warnings (Off, Exceptfds);
 317
 318       Original_WFS : aliased constant Fd_Set := Writefds.all;
 319
 320       Res  : C.int;
 321       S    : aliased C.int;
 322       Last : aliased C.int;
 323
 324    begin
 325       --  Asynchronous connection failures are notified in the exception fd set
 326       --  instead of the write fd set. To ensure POSIX compatibility, copy
 327       --  write fd set into exception fd set. Once select() returns, check any
 328       --  socket present in the exception fd set and peek at incoming
 329       --  out-of-band data. If the test is not successful, and the socket is
 330       --  present in the initial write fd set, then move the socket from the
 331       --  exception fd set to the write fd set.
 332
 333       if Writefds /= No_Fd_Set_Access then
 334
 335          --  Add any socket present in write fd set into exception fd set
 336
 337          declare
 338             WFS : aliased Fd_Set := Writefds.all;
 339          begin
 340             Last := Nfds - 1;
 341             loop
 342                Get_Socket_From_Set
 343                  (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access);
 344                exit when S = -1;
 345                Insert_Socket_In_Set (Exceptfds, S);
 346             end loop;
 347          end;
 348       end if;
 349
 350       Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout);
 351
 352       if Exceptfds /= No_Fd_Set_Access then
 353          declare
 354             EFSC    : aliased Fd_Set := Exceptfds.all;
 355             Flag    : constant C.int := SOSC.MSG_PEEK + SOSC.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'Access, 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                   From    => System.Null_Address,
 375                   Fromlen => Fromlen'Unchecked_Access);
 376                --  Is Fromlen necessary if From is Null_Address???
 377
 378                --  If the signal is not an out-of-band data, then it
 379                --  is a connection failure notification.
 380
 381                if Length = -1 then
 382                   Remove_Socket_From_Set (Exceptfds, S);
 383
 384                   --  If S is present in the initial write fd set, move it from
 385                   --  exception fd set back to write fd set. Otherwise, ignore
 386                   --  this event since the user is not watching for it.
 387
 388                   if Writefds /= No_Fd_Set_Access
 389                     and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0)
 390                   then
 391                      Insert_Socket_In_Set (Writefds, S);
 392                   end if;
 393                end if;
 394             end loop;
 395          end;
 396       end if;
 397       return Res;
 398    end C_Select;
 399
 400    ---------------
 401    -- C_Sendmsg --
 402    ---------------
 403
 404    function C_Sendmsg
 405      (S     : C.int;
 406       Msg   : System.Address;
 407       Flags : C.int) return ssize_t
 408    is
 409       Res   : C.int;
 410       Count : C.int := 0;
 411
 412       MH : Msghdr;
 413       for MH'Address use Msg;
 414
 415       Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
 416       for Iovec'Address use MH.Msg_Iov;
 417       pragma Import (Ada, Iovec);
 418
 419    begin
 420       --  Windows does not provide an implementation of sendmsg(). The spec for
 421       --  WSASendMsg() is incompatible with the data types we define, and is
 422       --  not available in all versions of Windows. So, we'll use C_Sendto
 423       --  instead.
 424
 425       for J in Iovec'Range loop
 426          Res := C_Sendto
 427            (S,
 428             Iovec (J).Base.all'Address,
 429             C.int (Iovec (J).Length),
 430             Flags => Flags,
 431             To    => MH.Msg_Name,
 432             Tolen => C.int (MH.Msg_Namelen));
 433
 434          if Res < 0 then
 435             return ssize_t (Res);
 436          else
 437             Count := Count + Res;
 438          end if;
 439       end loop;
 440       return ssize_t (Count);
 441    end C_Sendmsg;
 442
 443    --------------
 444    -- Finalize --
 445    --------------
 446
 447    procedure Finalize is
 448    begin
 449       if Initialized then
 450          WSACleanup;
 451          Initialized := False;
 452       end if;
 453    end Finalize;
 454
 455    -------------------------
 456    -- Host_Error_Messages --
 457    -------------------------
 458
 459    package body Host_Error_Messages is
 460
 461       --  On Windows, socket and host errors share the same code space, and
 462       --  error messages are provided by Socket_Error_Message. The default
 463       --  separate body for Host_Error_Messages is therefore not used in
 464       --  this case.
 465
 466       function Host_Error_Message
 467         (H_Errno : Integer) return C.Strings.chars_ptr
 468         renames Socket_Error_Message;
 469
 470    end Host_Error_Messages;
 471
 472    ----------------
 473    -- Initialize --
 474    ----------------
 475
 476    procedure Initialize is
 477       Return_Value : Interfaces.C.int;
 478    begin
 479       if not Initialized then
 480          Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
 481          pragma Assert (Return_Value = 0);
 482          Initialized := True;
 483       end if;
 484    end Initialize;
 485
 486    --------------------
 487    -- Signalling_Fds --
 488    --------------------
 489
 490    package body Signalling_Fds is separate;
 491
 492    --------------------------
 493    -- Socket_Error_Message --
 494    --------------------------
 495
 496    function Socket_Error_Message
 497      (Errno : Integer) return C.Strings.chars_ptr
 498    is
 499       use GNAT.Sockets.SOSC;
 500
 501    begin
 502       case Errno is
 503          when EINTR =>           return Error_Messages (N_EINTR);
 504          when EBADF =>           return Error_Messages (N_EBADF);
 505          when EACCES =>          return Error_Messages (N_EACCES);
 506          when EFAULT =>          return Error_Messages (N_EFAULT);
 507          when EINVAL =>          return Error_Messages (N_EINVAL);
 508          when EMFILE =>          return Error_Messages (N_EMFILE);
 509          when EWOULDBLOCK =>     return Error_Messages (N_EWOULDBLOCK);
 510          when EINPROGRESS =>     return Error_Messages (N_EINPROGRESS);
 511          when EALREADY =>        return Error_Messages (N_EALREADY);
 512          when ENOTSOCK =>        return Error_Messages (N_ENOTSOCK);
 513          when EDESTADDRREQ =>    return Error_Messages (N_EDESTADDRREQ);
 514          when EMSGSIZE =>        return Error_Messages (N_EMSGSIZE);
 515          when EPROTOTYPE =>      return Error_Messages (N_EPROTOTYPE);
 516          when ENOPROTOOPT =>     return Error_Messages (N_ENOPROTOOPT);
 517          when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT);
 518          when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT);
 519          when EOPNOTSUPP =>      return Error_Messages (N_EOPNOTSUPP);
 520          when EPFNOSUPPORT =>    return Error_Messages (N_EPFNOSUPPORT);
 521          when EAFNOSUPPORT =>    return Error_Messages (N_EAFNOSUPPORT);
 522          when EADDRINUSE =>      return Error_Messages (N_EADDRINUSE);
 523          when EADDRNOTAVAIL =>   return Error_Messages (N_EADDRNOTAVAIL);
 524          when ENETDOWN =>        return Error_Messages (N_ENETDOWN);
 525          when ENETUNREACH =>     return Error_Messages (N_ENETUNREACH);
 526          when ENETRESET =>       return Error_Messages (N_ENETRESET);
 527          when ECONNABORTED =>    return Error_Messages (N_ECONNABORTED);
 528          when ECONNRESET =>      return Error_Messages (N_ECONNRESET);
 529          when ENOBUFS =>         return Error_Messages (N_ENOBUFS);
 530          when EISCONN =>         return Error_Messages (N_EISCONN);
 531          when ENOTCONN =>        return Error_Messages (N_ENOTCONN);
 532          when ESHUTDOWN =>       return Error_Messages (N_ESHUTDOWN);
 533          when ETOOMANYREFS =>    return Error_Messages (N_ETOOMANYREFS);
 534          when ETIMEDOUT =>       return Error_Messages (N_ETIMEDOUT);
 535          when ECONNREFUSED =>    return Error_Messages (N_ECONNREFUSED);
 536          when ELOOP =>           return Error_Messages (N_ELOOP);
 537          when ENAMETOOLONG =>    return Error_Messages (N_ENAMETOOLONG);
 538          when EHOSTDOWN =>       return Error_Messages (N_EHOSTDOWN);
 539          when EHOSTUNREACH =>    return Error_Messages (N_EHOSTUNREACH);
 540
 541          --  Windows-specific error codes
 542
 543          when WSASYSNOTREADY =>  return Error_Messages (N_WSASYSNOTREADY);
 544          when WSAVERNOTSUPPORTED =>
 545                                  return Error_Messages (N_WSAVERNOTSUPPORTED);
 546          when WSANOTINITIALISED =>
 547                                  return Error_Messages (N_WSANOTINITIALISED);
 548          when WSAEDISCON =>      return Error_Messages (N_WSAEDISCON);
 549
 550          --  h_errno values
 551
 552          when HOST_NOT_FOUND =>  return Error_Messages (N_HOST_NOT_FOUND);
 553          when TRY_AGAIN =>       return Error_Messages (N_TRY_AGAIN);
 554          when NO_RECOVERY =>     return Error_Messages (N_NO_RECOVERY);
 555          when NO_DATA =>         return Error_Messages (N_NO_DATA);
 556
 557          when others =>          return Error_Messages (N_OTHERS);
 558       end case;
 559    end Socket_Error_Message;
 560
 561 end GNAT.Sockets.Thin;