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