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