gcc/ada/g-socthi.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 is the default version
  39
  40 with GNAT.OS_Lib; use GNAT.OS_Lib;
  41 with GNAT.Task_Lock;
  42
  43 with Interfaces.C; use Interfaces.C;
  44
  45 package body GNAT.Sockets.Thin is
  46
  47    Non_Blocking_Sockets : constant Fd_Set_Access :=
  48                             New_Socket_Set (No_Socket_Set);
  49    --  When this package is initialized with Process_Blocking_IO set
  50    --  to True, sockets are set in non-blocking mode to avoid blocking
  51    --  the whole process when a thread wants to perform a blocking IO
  52    --  operation. But the user can also set a socket in non-blocking
  53    --  mode by purpose. In order to make a difference between these
  54    --  two situations, we track the origin of non-blocking mode in
  55    --  Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
  56    --  been set in non-blocking mode by the user.
  57
  58    Quantum : constant Duration := 0.2;
  59    --  When Constants.Thread_Blocking_IO is False, we set sockets in
  60    --  non-blocking mode and we spend a period of time Quantum between
  61    --  two attempts on a blocking operation.
  62
  63    Unknown_System_Error : constant C.Strings.chars_ptr :=
  64                             C.Strings.New_String ("Unknown system error");
  65
  66    --  Comments required for following functions ???
  67
  68    function Syscall_Accept
  69      (S       : C.int;
  70       Addr    : System.Address;
  71       Addrlen : not null access C.int) return C.int;
  72    pragma Import (C, Syscall_Accept, "accept");
  73
  74    function Syscall_Connect
  75      (S       : C.int;
  76       Name    : System.Address;
  77       Namelen : C.int) return C.int;
  78    pragma Import (C, Syscall_Connect, "connect");
  79
  80    function Syscall_Ioctl
  81      (S    : C.int;
  82       Req  : C.int;
  83       Arg  : Int_Access) return C.int;
  84    pragma Import (C, Syscall_Ioctl, "ioctl");
  85
  86    function Syscall_Recv
  87      (S     : C.int;
  88       Msg   : System.Address;
  89       Len   : C.int;
  90       Flags : C.int) return C.int;
  91    pragma Import (C, Syscall_Recv, "recv");
  92
  93    function Syscall_Recvfrom
  94      (S       : C.int;
  95       Msg     : System.Address;
  96       Len     : C.int;
  97       Flags   : C.int;
  98       From    : Sockaddr_In_Access;
  99       Fromlen : not null access C.int) return C.int;
 100    pragma Import (C, Syscall_Recvfrom, "recvfrom");
 101
 102    function Syscall_Send
 103      (S     : C.int;
 104       Msg   : System.Address;
 105       Len   : C.int;
 106       Flags : C.int) return C.int;
 107    pragma Import (C, Syscall_Send, "send");
 108
 109    function Syscall_Sendto
 110      (S     : C.int;
 111       Msg   : System.Address;
 112       Len   : C.int;
 113       Flags : C.int;
 114       To    : Sockaddr_In_Access;
 115       Tolen : C.int) return C.int;
 116    pragma Import (C, Syscall_Sendto, "sendto");
 117
 118    function Syscall_Socket
 119      (Domain   : C.int;
 120       Typ      : C.int;
 121       Protocol : C.int) return C.int;
 122    pragma Import (C, Syscall_Socket, "socket");
 123
 124    procedure Disable_SIGPIPE (S : C.int);
 125    pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe");
 126
 127    procedure Disable_All_SIGPIPEs;
 128    pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes");
 129    --  Sets the process to ignore all SIGPIPE signals on platforms that
 130    --  don't support Disable_SIGPIPE for particular streams.
 131
 132    function Non_Blocking_Socket (S : C.int) return Boolean;
 133    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
 134
 135    --------------
 136    -- C_Accept --
 137    --------------
 138
 139    function C_Accept
 140      (S       : C.int;
 141       Addr    : System.Address;
 142       Addrlen : not null access C.int) return C.int
 143    is
 144       R   : C.int;
 145       Val : aliased C.int := 1;
 146
 147       Discard : C.int;
 148       pragma Warnings (Off, Discard);
 149
 150    begin
 151       loop
 152          R := Syscall_Accept (S, Addr, Addrlen);
 153          exit when Constants.Thread_Blocking_IO
 154            or else R /= Failure
 155            or else Non_Blocking_Socket (S)
 156            or else Errno /= Constants.EWOULDBLOCK;
 157          delay Quantum;
 158       end loop;
 159
 160       if not Constants.Thread_Blocking_IO
 161         and then R /= Failure
 162       then
 163          --  A socket inherits the properties ot its server especially
 164          --  the FIONBIO flag. Do not use C_Ioctl as this subprogram
 165          --  tracks sockets set in non-blocking mode by user.
 166
 167          Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
 168          Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
 169       end if;
 170
 171       Disable_SIGPIPE (R);
 172       return R;
 173    end C_Accept;
 174
 175    ---------------
 176    -- C_Connect --
 177    ---------------
 178
 179    function C_Connect
 180      (S       : C.int;
 181       Name    : System.Address;
 182       Namelen : C.int) return C.int
 183    is
 184       Res : C.int;
 185
 186    begin
 187       Res := Syscall_Connect (S, Name, Namelen);
 188
 189       if Constants.Thread_Blocking_IO
 190         or else Res /= Failure
 191         or else Non_Blocking_Socket (S)
 192         or else Errno /= Constants.EINPROGRESS
 193       then
 194          return Res;
 195       end if;
 196
 197       declare
 198          WSet : Fd_Set_Access;
 199          Now  : aliased Timeval;
 200
 201       begin
 202          WSet := New_Socket_Set (No_Socket_Set);
 203          loop
 204             Insert_Socket_In_Set (WSet, S);
 205             Now := Immediat;
 206             Res := C_Select
 207               (S + 1,
 208                No_Fd_Set,
 209                WSet,
 210                No_Fd_Set,
 211                Now'Unchecked_Access);
 212
 213             exit when Res > 0;
 214
 215             if Res = Failure then
 216                Free_Socket_Set (WSet);
 217                return Res;
 218             end if;
 219
 220             delay Quantum;
 221          end loop;
 222
 223          Free_Socket_Set (WSet);
 224       end;
 225
 226       Res := Syscall_Connect (S, Name, Namelen);
 227
 228       if Res = Failure
 229         and then Errno = Constants.EISCONN
 230       then
 231          return Thin.Success;
 232       else
 233          return Res;
 234       end if;
 235    end C_Connect;
 236
 237    -------------
 238    -- C_Ioctl --
 239    -------------
 240
 241    function C_Ioctl
 242      (S   : C.int;
 243       Req : C.int;
 244       Arg : Int_Access) return C.int
 245    is
 246    begin
 247       if not Constants.Thread_Blocking_IO
 248         and then Req = Constants.FIONBIO
 249       then
 250          if Arg.all /= 0 then
 251             Set_Non_Blocking_Socket (S, True);
 252          end if;
 253       end if;
 254
 255       return Syscall_Ioctl (S, Req, Arg);
 256    end C_Ioctl;
 257
 258    ------------
 259    -- C_Recv --
 260    ------------
 261
 262    function C_Recv
 263      (S     : C.int;
 264       Msg   : System.Address;
 265       Len   : C.int;
 266       Flags : C.int) return C.int
 267    is
 268       Res : C.int;
 269
 270    begin
 271       loop
 272          Res := Syscall_Recv (S, Msg, Len, Flags);
 273          exit when Constants.Thread_Blocking_IO
 274            or else Res /= Failure
 275            or else Non_Blocking_Socket (S)
 276            or else Errno /= Constants.EWOULDBLOCK;
 277          delay Quantum;
 278       end loop;
 279
 280       return Res;
 281    end C_Recv;
 282
 283    ----------------
 284    -- C_Recvfrom --
 285    ----------------
 286
 287    function C_Recvfrom
 288      (S       : C.int;
 289       Msg     : System.Address;
 290       Len     : C.int;
 291       Flags   : C.int;
 292       From    : Sockaddr_In_Access;
 293       Fromlen : not null access C.int) return C.int
 294    is
 295       Res : C.int;
 296
 297    begin
 298       loop
 299          Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
 300          exit when Constants.Thread_Blocking_IO
 301            or else Res /= Failure
 302            or else Non_Blocking_Socket (S)
 303            or else Errno /= Constants.EWOULDBLOCK;
 304          delay Quantum;
 305       end loop;
 306
 307       return Res;
 308    end C_Recvfrom;
 309
 310    ------------
 311    -- C_Send --
 312    ------------
 313
 314    function C_Send
 315      (S     : C.int;
 316       Msg   : System.Address;
 317       Len   : C.int;
 318       Flags : C.int) return C.int
 319    is
 320       Res : C.int;
 321
 322    begin
 323       loop
 324          Res := Syscall_Send (S, Msg, Len, Flags);
 325          exit when Constants.Thread_Blocking_IO
 326            or else Res /= Failure
 327            or else Non_Blocking_Socket (S)
 328            or else Errno /= Constants.EWOULDBLOCK;
 329          delay Quantum;
 330       end loop;
 331
 332       return Res;
 333    end C_Send;
 334
 335    --------------
 336    -- C_Sendto --
 337    --------------
 338
 339    function C_Sendto
 340      (S     : C.int;
 341       Msg   : System.Address;
 342       Len   : C.int;
 343       Flags : C.int;
 344       To    : Sockaddr_In_Access;
 345       Tolen : C.int) return C.int
 346    is
 347       Res : C.int;
 348
 349    begin
 350       loop
 351          Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 352          exit when Constants.Thread_Blocking_IO
 353            or else Res /= Failure
 354            or else Non_Blocking_Socket (S)
 355            or else Errno /= Constants.EWOULDBLOCK;
 356          delay Quantum;
 357       end loop;
 358
 359       return Res;
 360    end C_Sendto;
 361
 362    --------------
 363    -- C_Socket --
 364    --------------
 365
 366    function C_Socket
 367      (Domain   : C.int;
 368       Typ      : C.int;
 369       Protocol : C.int) return C.int
 370    is
 371       R   : C.int;
 372       Val : aliased C.int := 1;
 373
 374       Discard : C.int;
 375       pragma Unreferenced (Discard);
 376
 377    begin
 378       R := Syscall_Socket (Domain, Typ, Protocol);
 379
 380       if not Constants.Thread_Blocking_IO
 381         and then R /= Failure
 382       then
 383          --  Do not use C_Ioctl as this subprogram tracks sockets set
 384          --  in non-blocking mode by user.
 385
 386          Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
 387          Set_Non_Blocking_Socket (R, False);
 388       end if;
 389       Disable_SIGPIPE (R);
 390       return R;
 391    end C_Socket;
 392
 393    --------------
 394    -- Finalize --
 395    --------------
 396
 397    procedure Finalize is
 398    begin
 399       null;
 400    end Finalize;
 401
 402    -------------------------
 403    -- Host_Error_Messages --
 404    -------------------------
 405
 406    package body Host_Error_Messages is separate;
 407
 408    ----------------
 409    -- Initialize --
 410    ----------------
 411
 412    procedure Initialize is
 413    begin
 414       Disable_All_SIGPIPEs;
 415    end Initialize;
 416
 417    -------------------------
 418    -- Non_Blocking_Socket --
 419    -------------------------
 420
 421    function Non_Blocking_Socket (S : C.int) return Boolean is
 422       R : Boolean;
 423    begin
 424       Task_Lock.Lock;
 425       R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
 426       Task_Lock.Unlock;
 427       return R;
 428    end Non_Blocking_Socket;
 429
 430    -----------------
 431    -- Set_Address --
 432    -----------------
 433
 434    procedure Set_Address
 435      (Sin     : Sockaddr_In_Access;
 436       Address : In_Addr)
 437    is
 438    begin
 439       Sin.Sin_Addr := Address;
 440    end Set_Address;
 441
 442    ----------------
 443    -- Set_Family --
 444    ----------------
 445
 446    procedure Set_Family
 447      (Sin    : Sockaddr_In_Access;
 448       Family : C.int)
 449    is
 450    begin
 451       Sin.Sin_Family := C.unsigned_short (Family);
 452    end Set_Family;
 453
 454    ----------------
 455    -- Set_Length --
 456    ----------------
 457
 458    procedure Set_Length
 459      (Sin : Sockaddr_In_Access;
 460       Len : C.int)
 461    is
 462       pragma Unreferenced (Sin);
 463       pragma Unreferenced (Len);
 464
 465    begin
 466       null;
 467    end Set_Length;
 468
 469    -----------------------------
 470    -- Set_Non_Blocking_Socket --
 471    -----------------------------
 472
 473    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
 474    begin
 475       Task_Lock.Lock;
 476
 477       if V then
 478          Insert_Socket_In_Set (Non_Blocking_Sockets, S);
 479       else
 480          Remove_Socket_From_Set (Non_Blocking_Sockets, S);
 481       end if;
 482
 483       Task_Lock.Unlock;
 484    end Set_Non_Blocking_Socket;
 485
 486    --------------
 487    -- Set_Port --
 488    --------------
 489
 490    procedure Set_Port
 491      (Sin  : Sockaddr_In_Access;
 492       Port : C.unsigned_short)
 493    is
 494    begin
 495       Sin.Sin_Port   := Port;
 496    end Set_Port;
 497
 498    --------------------
 499    -- Signalling_Fds --
 500    --------------------
 501
 502    package body Signalling_Fds is
 503
 504       --  In this default implementation, we use a C version of these
 505       --  subprograms provided by socket.c.
 506
 507       function C_Create (Fds : not null access Fd_Pair) return C.int;
 508       function C_Read (Rsig : C.int) return C.int;
 509       function C_Write (Wsig : C.int) return C.int;
 510       procedure C_Close (Sig : C.int);
 511
 512       pragma Import (C, C_Create, "__gnat_create_signalling_fds");
 513       pragma Import (C, C_Read,   "__gnat_read_signalling_fd");
 514       pragma Import (C, C_Write,  "__gnat_write_signalling_fd");
 515       pragma Import (C, C_Close,  "__gnat_close_signalling_fd");
 516
 517       function Create
 518         (Fds : not null access Fd_Pair) return C.int renames C_Create;
 519       function Read (Rsig : C.int) return C.int renames C_Read;
 520       function Write (Wsig : C.int) return C.int renames C_Write;
 521       procedure Close (Sig : C.int) renames C_Close;
 522
 523    end Signalling_Fds;
 524
 525    --------------------------
 526    -- Socket_Error_Message --
 527    --------------------------
 528
 529    function Socket_Error_Message
 530      (Errno : Integer) return C.Strings.chars_ptr
 531    is
 532       use type Interfaces.C.Strings.chars_ptr;
 533
 534       C_Msg : C.Strings.chars_ptr;
 535
 536    begin
 537       C_Msg := C_Strerror (C.int (Errno));
 538
 539       if C_Msg = C.Strings.Null_Ptr then
 540          return Unknown_System_Error;
 541       else
 542          return C_Msg;
 543       end if;
 544    end Socket_Error_Message;
 545
 546 end GNAT.Sockets.Thin;