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