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-2008, 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    Initialized : Boolean := False;
  52
  53    function Standard_Connect
  54      (S       : C.int;
  55       Name    : System.Address;
  56       Namelen : C.int) return C.int;
  57    pragma Import (Stdcall, Standard_Connect, "connect");
  58
  59    function Standard_Select
  60      (Nfds      : C.int;
  61       Readfds   : access Fd_Set;
  62       Writefds  : access Fd_Set;
  63       Exceptfds : access Fd_Set;
  64       Timeout   : Timeval_Access) return C.int;
  65    pragma Import (Stdcall, Standard_Select, "select");
  66
  67    type Error_Type is
  68      (N_EINTR,
  69       N_EBADF,
  70       N_EACCES,
  71       N_EFAULT,
  72       N_EINVAL,
  73       N_EMFILE,
  74       N_EWOULDBLOCK,
  75       N_EINPROGRESS,
  76       N_EALREADY,
  77       N_ENOTSOCK,
  78       N_EDESTADDRREQ,
  79       N_EMSGSIZE,
  80       N_EPROTOTYPE,
  81       N_ENOPROTOOPT,
  82       N_EPROTONOSUPPORT,
  83       N_ESOCKTNOSUPPORT,
  84       N_EOPNOTSUPP,
  85       N_EPFNOSUPPORT,
  86       N_EAFNOSUPPORT,
  87       N_EADDRINUSE,
  88       N_EADDRNOTAVAIL,
  89       N_ENETDOWN,
  90       N_ENETUNREACH,
  91       N_ENETRESET,
  92       N_ECONNABORTED,
  93       N_ECONNRESET,
  94       N_ENOBUFS,
  95       N_EISCONN,
  96       N_ENOTCONN,
  97       N_ESHUTDOWN,
  98       N_ETOOMANYREFS,
  99       N_ETIMEDOUT,
 100       N_ECONNREFUSED,
 101       N_ELOOP,
 102       N_ENAMETOOLONG,
 103       N_EHOSTDOWN,
 104       N_EHOSTUNREACH,
 105       N_WSASYSNOTREADY,
 106       N_WSAVERNOTSUPPORTED,
 107       N_WSANOTINITIALISED,
 108       N_WSAEDISCON,
 109       N_HOST_NOT_FOUND,
 110       N_TRY_AGAIN,
 111       N_NO_RECOVERY,
 112       N_NO_DATA,
 113       N_OTHERS);
 114
 115    Error_Messages : constant array (Error_Type) of chars_ptr :=
 116      (N_EINTR =>
 117         New_String ("Interrupted system call"),
 118       N_EBADF =>
 119         New_String ("Bad file number"),
 120       N_EACCES =>
 121         New_String ("Permission denied"),
 122       N_EFAULT =>
 123         New_String ("Bad address"),
 124       N_EINVAL =>
 125         New_String ("Invalid argument"),
 126       N_EMFILE =>
 127         New_String ("Too many open files"),
 128       N_EWOULDBLOCK =>
 129         New_String ("Operation would block"),
 130       N_EINPROGRESS =>
 131         New_String ("Operation now in progress. This error is "
 132                     & "returned if any Windows Sockets API "
 133                     & "function is called while a blocking "
 134                     & "function is in progress"),
 135       N_EALREADY =>
 136         New_String ("Operation already in progress"),
 137       N_ENOTSOCK =>
 138         New_String ("Socket operation on nonsocket"),
 139       N_EDESTADDRREQ =>
 140         New_String ("Destination address required"),
 141       N_EMSGSIZE =>
 142         New_String ("Message too long"),
 143       N_EPROTOTYPE =>
 144         New_String ("Protocol wrong type for socket"),
 145       N_ENOPROTOOPT =>
 146         New_String ("Protocol not available"),
 147       N_EPROTONOSUPPORT =>
 148         New_String ("Protocol not supported"),
 149       N_ESOCKTNOSUPPORT =>
 150         New_String ("Socket type not supported"),
 151       N_EOPNOTSUPP =>
 152         New_String ("Operation not supported on socket"),
 153       N_EPFNOSUPPORT =>
 154         New_String ("Protocol family not supported"),
 155       N_EAFNOSUPPORT =>
 156         New_String ("Address family not supported by protocol family"),
 157       N_EADDRINUSE =>
 158         New_String ("Address already in use"),
 159       N_EADDRNOTAVAIL =>
 160         New_String ("Cannot assign requested address"),
 161       N_ENETDOWN =>
 162         New_String ("Network is down. This error may be "
 163                     & "reported at any time if the Windows "
 164                     & "Sockets implementation detects an "
 165                     & "underlying failure"),
 166       N_ENETUNREACH =>
 167         New_String ("Network is unreachable"),
 168       N_ENETRESET =>
 169         New_String ("Network dropped connection on reset"),
 170       N_ECONNABORTED =>
 171         New_String ("Software caused connection abort"),
 172       N_ECONNRESET =>
 173         New_String ("Connection reset by peer"),
 174       N_ENOBUFS =>
 175         New_String ("No buffer space available"),
 176       N_EISCONN  =>
 177         New_String ("Socket is already connected"),
 178       N_ENOTCONN =>
 179         New_String ("Socket is not connected"),
 180       N_ESHUTDOWN =>
 181         New_String ("Cannot send after socket shutdown"),
 182       N_ETOOMANYREFS =>
 183         New_String ("Too many references: cannot splice"),
 184       N_ETIMEDOUT =>
 185         New_String ("Connection timed out"),
 186       N_ECONNREFUSED =>
 187         New_String ("Connection refused"),
 188       N_ELOOP =>
 189         New_String ("Too many levels of symbolic links"),
 190       N_ENAMETOOLONG =>
 191         New_String ("File name too long"),
 192       N_EHOSTDOWN =>
 193         New_String ("Host is down"),
 194       N_EHOSTUNREACH =>
 195         New_String ("No route to host"),
 196       N_WSASYSNOTREADY =>
 197         New_String ("Returned by WSAStartup(), indicating that "
 198                     & "the network subsystem is unusable"),
 199       N_WSAVERNOTSUPPORTED =>
 200         New_String ("Returned by WSAStartup(), indicating that "
 201                     & "the Windows Sockets DLL cannot support "
 202                     & "this application"),
 203       N_WSANOTINITIALISED =>
 204         New_String ("Winsock not initialized. This message is "
 205                     & "returned by any function except WSAStartup(), "
 206                     & "indicating that a successful WSAStartup() has "
 207                     & "not yet been performed"),
 208       N_WSAEDISCON =>
 209         New_String ("Disconnected"),
 210       N_HOST_NOT_FOUND =>
 211         New_String ("Host not found. This message indicates "
 212                     & "that the key (name, address, and so on) was not found"),
 213       N_TRY_AGAIN =>
 214         New_String ("Nonauthoritative host not found. This error may "
 215                     & "suggest that the name service itself is not "
 216                     & "functioning"),
 217       N_NO_RECOVERY =>
 218         New_String ("Nonrecoverable error. This error may suggest that the "
 219                     & "name service itself is not functioning"),
 220       N_NO_DATA =>
 221         New_String ("Valid name, no data record of requested type. "
 222                     & "This error indicates that the key (name, address, "
 223                     & "and so on) was not found."),
 224       N_OTHERS =>
 225         New_String ("Unknown system error"));
 226
 227    ---------------
 228    -- C_Connect --
 229    ---------------
 230
 231    function C_Connect
 232      (S       : C.int;
 233       Name    : System.Address;
 234       Namelen : C.int) return C.int
 235    is
 236       Res : C.int;
 237
 238    begin
 239       Res := Standard_Connect (S, Name, Namelen);
 240
 241       if Res = -1 then
 242          if Socket_Errno = SOSC.EWOULDBLOCK then
 243             Set_Socket_Errno (SOSC.EINPROGRESS);
 244          end if;
 245       end if;
 246
 247       return Res;
 248    end C_Connect;
 249
 250    -------------
 251    -- C_Readv --
 252    -------------
 253
 254    function C_Readv
 255      (Fd     : C.int;
 256       Iov    : System.Address;
 257       Iovcnt : C.int) return C.int
 258    is
 259       Res   : C.int;
 260       Count : C.int := 0;
 261
 262       Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
 263       for Iovec'Address use Iov;
 264       pragma Import (Ada, Iovec);
 265
 266    begin
 267       for J in Iovec'Range loop
 268          Res := C_Recv
 269            (Fd,
 270             Iovec (J).Base.all'Address,
 271             C.int (Iovec (J).Length),
 272             0);
 273
 274          if Res < 0 then
 275             return Res;
 276          else
 277             Count := Count + Res;
 278          end if;
 279       end loop;
 280       return Count;
 281    end C_Readv;
 282
 283    --------------
 284    -- C_Select --
 285    --------------
 286
 287    function C_Select
 288      (Nfds      : C.int;
 289       Readfds   : access Fd_Set;
 290       Writefds  : access Fd_Set;
 291       Exceptfds : access Fd_Set;
 292       Timeout   : Timeval_Access) return C.int
 293    is
 294       pragma Warnings (Off, Exceptfds);
 295
 296       Original_WFS : aliased constant Fd_Set := Writefds.all;
 297
 298       Res  : C.int;
 299       S    : aliased C.int;
 300       Last : aliased C.int;
 301
 302    begin
 303       --  Asynchronous connection failures are notified in the exception fd set
 304       --  instead of the write fd set. To ensure POSIX compatibility, copy
 305       --  write fd set into exception fd set. Once select() returns, check any
 306       --  socket present in the exception fd set and peek at incoming
 307       --  out-of-band data. If the test is not successful, and the socket is
 308       --  present in the initial write fd set, then move the socket from the
 309       --  exception fd set to the write fd set.
 310
 311       if Writefds /= No_Fd_Set_Access then
 312
 313          --  Add any socket present in write fd set into exception fd set
 314
 315          declare
 316             WFS : aliased Fd_Set := Writefds.all;
 317          begin
 318             Last := Nfds - 1;
 319             loop
 320                Get_Socket_From_Set
 321                  (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access);
 322                exit when S = -1;
 323                Insert_Socket_In_Set (Exceptfds, S);
 324             end loop;
 325          end;
 326       end if;
 327
 328       Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout);
 329
 330       if Exceptfds /= No_Fd_Set_Access then
 331          declare
 332             EFSC    : aliased Fd_Set := Exceptfds.all;
 333             Flag    : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB;
 334             Buffer  : Character;
 335             Length  : C.int;
 336             Fromlen : aliased C.int;
 337
 338          begin
 339             Last := Nfds - 1;
 340             loop
 341                Get_Socket_From_Set
 342                  (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access);
 343
 344                --  No more sockets in EFSC
 345
 346                exit when S = -1;
 347
 348                --  Check out-of-band data
 349
 350                Length := C_Recvfrom
 351                  (S, Buffer'Address, 1, Flag, null, Fromlen'Unchecked_Access);
 352
 353                --  If the signal is not an out-of-band data, then it
 354                --  is a connection failure notification.
 355
 356                if Length = -1 then
 357                   Remove_Socket_From_Set (Exceptfds, S);
 358
 359                   --  If S is present in the initial write fd set, move it from
 360                   --  exception fd set back to write fd set. Otherwise, ignore
 361                   --  this event since the user is not watching for it.
 362
 363                   if Writefds /= No_Fd_Set_Access
 364                     and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0)
 365                   then
 366                      Insert_Socket_In_Set (Writefds, S);
 367                   end if;
 368                end if;
 369             end loop;
 370          end;
 371       end if;
 372       return Res;
 373    end C_Select;
 374
 375    --------------
 376    -- C_Writev --
 377    --------------
 378
 379    function C_Writev
 380      (Fd     : C.int;
 381       Iov    : System.Address;
 382       Iovcnt : C.int) return C.int
 383    is
 384       Res   : C.int;
 385       Count : C.int := 0;
 386
 387       Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
 388       for Iovec'Address use Iov;
 389       pragma Import (Ada, Iovec);
 390
 391    begin
 392       for J in Iovec'Range loop
 393          Res := C_Sendto
 394            (Fd,
 395             Iovec (J).Base.all'Address,
 396             C.int (Iovec (J).Length),
 397             Flags => 0,
 398             To    => null,
 399             Tolen => 0);
 400
 401          if Res < 0 then
 402             return Res;
 403          else
 404             Count := Count + Res;
 405          end if;
 406       end loop;
 407       return Count;
 408    end C_Writev;
 409
 410    --------------
 411    -- Finalize --
 412    --------------
 413
 414    procedure Finalize is
 415    begin
 416       if Initialized then
 417          WSACleanup;
 418          Initialized := False;
 419       end if;
 420    end Finalize;
 421
 422    -------------------------
 423    -- Host_Error_Messages --
 424    -------------------------
 425
 426    package body Host_Error_Messages is
 427
 428       --  On Windows, socket and host errors share the same code space, and
 429       --  error messages are provided by Socket_Error_Message. The default
 430       --  separate body for Host_Error_Messages is therefore not used in
 431       --  this case.
 432
 433       function Host_Error_Message
 434         (H_Errno : Integer) return C.Strings.chars_ptr
 435         renames Socket_Error_Message;
 436
 437    end Host_Error_Messages;
 438
 439    ----------------
 440    -- Initialize --
 441    ----------------
 442
 443    procedure Initialize is
 444       Return_Value : Interfaces.C.int;
 445    begin
 446       if not Initialized then
 447          Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
 448          pragma Assert (Return_Value = 0);
 449          Initialized := True;
 450       end if;
 451    end Initialize;
 452
 453    --------------------
 454    -- Signalling_Fds --
 455    --------------------
 456
 457    package body Signalling_Fds is separate;
 458
 459    --------------------------
 460    -- Socket_Error_Message --
 461    --------------------------
 462
 463    function Socket_Error_Message
 464      (Errno : Integer) return C.Strings.chars_ptr
 465    is
 466       use GNAT.Sockets.SOSC;
 467
 468    begin
 469       case Errno is
 470          when EINTR =>           return Error_Messages (N_EINTR);
 471          when EBADF =>           return Error_Messages (N_EBADF);
 472          when EACCES =>          return Error_Messages (N_EACCES);
 473          when EFAULT =>          return Error_Messages (N_EFAULT);
 474          when EINVAL =>          return Error_Messages (N_EINVAL);
 475          when EMFILE =>          return Error_Messages (N_EMFILE);
 476          when EWOULDBLOCK =>     return Error_Messages (N_EWOULDBLOCK);
 477          when EINPROGRESS =>     return Error_Messages (N_EINPROGRESS);
 478          when EALREADY =>        return Error_Messages (N_EALREADY);
 479          when ENOTSOCK =>        return Error_Messages (N_ENOTSOCK);
 480          when EDESTADDRREQ =>    return Error_Messages (N_EDESTADDRREQ);
 481          when EMSGSIZE =>        return Error_Messages (N_EMSGSIZE);
 482          when EPROTOTYPE =>      return Error_Messages (N_EPROTOTYPE);
 483          when ENOPROTOOPT =>     return Error_Messages (N_ENOPROTOOPT);
 484          when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT);
 485          when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT);
 486          when EOPNOTSUPP =>      return Error_Messages (N_EOPNOTSUPP);
 487          when EPFNOSUPPORT =>    return Error_Messages (N_EPFNOSUPPORT);
 488          when EAFNOSUPPORT =>    return Error_Messages (N_EAFNOSUPPORT);
 489          when EADDRINUSE =>      return Error_Messages (N_EADDRINUSE);
 490          when EADDRNOTAVAIL =>   return Error_Messages (N_EADDRNOTAVAIL);
 491          when ENETDOWN =>        return Error_Messages (N_ENETDOWN);
 492          when ENETUNREACH =>     return Error_Messages (N_ENETUNREACH);
 493          when ENETRESET =>       return Error_Messages (N_ENETRESET);
 494          when ECONNABORTED =>    return Error_Messages (N_ECONNABORTED);
 495          when ECONNRESET =>      return Error_Messages (N_ECONNRESET);
 496          when ENOBUFS =>         return Error_Messages (N_ENOBUFS);
 497          when EISCONN =>         return Error_Messages (N_EISCONN);
 498          when ENOTCONN =>        return Error_Messages (N_ENOTCONN);
 499          when ESHUTDOWN =>       return Error_Messages (N_ESHUTDOWN);
 500          when ETOOMANYREFS =>    return Error_Messages (N_ETOOMANYREFS);
 501          when ETIMEDOUT =>       return Error_Messages (N_ETIMEDOUT);
 502          when ECONNREFUSED =>    return Error_Messages (N_ECONNREFUSED);
 503          when ELOOP =>           return Error_Messages (N_ELOOP);
 504          when ENAMETOOLONG =>    return Error_Messages (N_ENAMETOOLONG);
 505          when EHOSTDOWN =>       return Error_Messages (N_EHOSTDOWN);
 506          when EHOSTUNREACH =>    return Error_Messages (N_EHOSTUNREACH);
 507
 508          --  Windows-specific error codes
 509
 510          when WSASYSNOTREADY =>  return Error_Messages (N_WSASYSNOTREADY);
 511          when WSAVERNOTSUPPORTED =>
 512                                  return Error_Messages (N_WSAVERNOTSUPPORTED);
 513          when WSANOTINITIALISED =>
 514                                  return Error_Messages (N_WSANOTINITIALISED);
 515          when WSAEDISCON =>      return Error_Messages (N_WSAEDISCON);
 516
 517          --  h_errno values
 518
 519          when HOST_NOT_FOUND =>  return Error_Messages (N_HOST_NOT_FOUND);
 520          when TRY_AGAIN =>       return Error_Messages (N_TRY_AGAIN);
 521          when NO_RECOVERY =>     return Error_Messages (N_NO_RECOVERY);
 522          when NO_DATA =>         return Error_Messages (N_NO_DATA);
 523
 524          when others =>          return Error_Messages (N_OTHERS);
 525       end case;
 526    end Socket_Error_Message;
 527
 528 end GNAT.Sockets.Thin;