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