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