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