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