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