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-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 version is for VxWorks
  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    -----------------------
  67    -- Local Subprograms --
  68    -----------------------
  69
  70    --  All these require comments ???
  71
  72    function Syscall_Accept
  73      (S       : C.int;
  74       Addr    : System.Address;
  75       Addrlen : not null access C.int) return C.int;
  76    pragma Import (C, Syscall_Accept, "accept");
  77
  78    function Syscall_Connect
  79      (S       : C.int;
  80       Name    : System.Address;
  81       Namelen : C.int) return C.int;
  82    pragma Import (C, Syscall_Connect, "connect");
  83
  84    function Syscall_Ioctl
  85      (S    : C.int;
  86       Req  : C.int;
  87       Arg  : Int_Access) return C.int;
  88    pragma Import (C, Syscall_Ioctl, "ioctl");
  89
  90    function Syscall_Recv
  91      (S     : C.int;
  92       Msg   : System.Address;
  93       Len   : C.int;
  94       Flags : C.int) return C.int;
  95    pragma Import (C, Syscall_Recv, "recv");
  96
  97    function Syscall_Recvfrom
  98      (S       : C.int;
  99       Msg     : System.Address;
 100       Len     : C.int;
 101       Flags   : C.int;
 102       From    : Sockaddr_In_Access;
 103       Fromlen : not null access C.int) return C.int;
 104    pragma Import (C, Syscall_Recvfrom, "recvfrom");
 105
 106    function Syscall_Send
 107      (S     : C.int;
 108       Msg   : System.Address;
 109       Len   : C.int;
 110       Flags : C.int) return C.int;
 111    pragma Import (C, Syscall_Send, "send");
 112
 113    function Syscall_Sendto
 114      (S     : C.int;
 115       Msg   : System.Address;
 116       Len   : C.int;
 117       Flags : C.int;
 118       To    : Sockaddr_In_Access;
 119       Tolen : C.int) return C.int;
 120    pragma Import (C, Syscall_Sendto, "sendto");
 121
 122    function Syscall_Socket
 123      (Domain   : C.int;
 124       Typ      : C.int;
 125       Protocol : C.int) return C.int;
 126    pragma Import (C, Syscall_Socket, "socket");
 127
 128    function  Non_Blocking_Socket (S : C.int) return Boolean;
 129    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
 130
 131    --------------
 132    -- C_Accept --
 133    --------------
 134
 135    function C_Accept
 136      (S       : C.int;
 137       Addr    : System.Address;
 138       Addrlen : not null access C.int) return C.int
 139    is
 140       R   : C.int;
 141       Val : aliased C.int := 1;
 142
 143       Res : C.int;
 144       pragma Unreferenced (Res);
 145
 146    begin
 147       loop
 148          R := Syscall_Accept (S, Addr, Addrlen);
 149          exit when Constants.Thread_Blocking_IO
 150            or else R /= Failure
 151            or else Non_Blocking_Socket (S)
 152            or else Errno /= Constants.EWOULDBLOCK;
 153          delay Quantum;
 154       end loop;
 155
 156       if not Constants.Thread_Blocking_IO
 157         and then R /= Failure
 158       then
 159          --  A socket inherits the properties ot its server especially
 160          --  the FIONBIO flag. Do not use C_Ioctl as this subprogram
 161          --  tracks sockets set in non-blocking mode by user.
 162
 163          Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
 164          Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
 165          --  Is it OK to ignore result ???
 166       end if;
 167
 168       return R;
 169    end C_Accept;
 170
 171    ---------------
 172    -- C_Connect --
 173    ---------------
 174
 175    function C_Connect
 176      (S       : C.int;
 177       Name    : System.Address;
 178       Namelen : C.int) return C.int
 179    is
 180       Res : C.int;
 181
 182    begin
 183       Res := Syscall_Connect (S, Name, Namelen);
 184
 185       if Constants.Thread_Blocking_IO
 186         or else Res /= Failure
 187         or else Non_Blocking_Socket (S)
 188         or else Errno /= Constants.EINPROGRESS
 189       then
 190          return Res;
 191       end if;
 192
 193       declare
 194          WSet : Fd_Set_Access;
 195          Now  : aliased Timeval;
 196
 197       begin
 198          WSet := New_Socket_Set (No_Socket_Set);
 199
 200          loop
 201             Insert_Socket_In_Set (WSet, S);
 202             Now := Immediat;
 203             Res := C_Select
 204               (S + 1,
 205                No_Fd_Set,
 206                WSet,
 207                No_Fd_Set,
 208                Now'Unchecked_Access);
 209
 210             exit when Res > 0;
 211
 212             if Res = Failure then
 213                Free_Socket_Set (WSet);
 214                return Res;
 215             end if;
 216
 217             delay Quantum;
 218          end loop;
 219
 220          Free_Socket_Set (WSet);
 221       end;
 222
 223       Res := Syscall_Connect (S, Name, Namelen);
 224
 225       if Res = Failure
 226         and then Errno = Constants.EISCONN
 227       then
 228          return Thin.Success;
 229       else
 230          return Res;
 231       end if;
 232    end C_Connect;
 233
 234    -------------
 235    -- C_Ioctl --
 236    -------------
 237
 238    function C_Ioctl
 239      (S    : C.int;
 240       Req  : C.int;
 241       Arg  : Int_Access) return C.int
 242    is
 243    begin
 244       if not Constants.Thread_Blocking_IO
 245         and then Req = Constants.FIONBIO
 246       then
 247          if Arg.all /= 0 then
 248             Set_Non_Blocking_Socket (S, True);
 249          end if;
 250       end if;
 251
 252       return Syscall_Ioctl (S, Req, Arg);
 253    end C_Ioctl;
 254
 255    ------------
 256    -- C_Recv --
 257    ------------
 258
 259    function C_Recv
 260      (S     : C.int;
 261       Msg   : System.Address;
 262       Len   : C.int;
 263       Flags : C.int) return C.int
 264    is
 265       Res : C.int;
 266
 267    begin
 268       loop
 269          Res := Syscall_Recv (S, Msg, Len, Flags);
 270          exit when Constants.Thread_Blocking_IO
 271            or else Res /= Failure
 272            or else Non_Blocking_Socket (S)
 273            or else Errno /= Constants.EWOULDBLOCK;
 274          delay Quantum;
 275       end loop;
 276
 277       return Res;
 278    end C_Recv;
 279
 280    ----------------
 281    -- C_Recvfrom --
 282    ----------------
 283
 284    function C_Recvfrom
 285      (S       : C.int;
 286       Msg     : System.Address;
 287       Len     : C.int;
 288       Flags   : C.int;
 289       From    : Sockaddr_In_Access;
 290       Fromlen : not null access C.int) return C.int
 291    is
 292       Res : C.int;
 293
 294    begin
 295       loop
 296          Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
 297          exit when Constants.Thread_Blocking_IO
 298            or else Res /= Failure
 299            or else Non_Blocking_Socket (S)
 300            or else Errno /= Constants.EWOULDBLOCK;
 301          delay Quantum;
 302       end loop;
 303
 304       return Res;
 305    end C_Recvfrom;
 306
 307    ------------
 308    -- C_Send --
 309    ------------
 310
 311    function C_Send
 312      (S     : C.int;
 313       Msg   : System.Address;
 314       Len   : C.int;
 315       Flags : C.int) return C.int
 316    is
 317       Res : C.int;
 318
 319    begin
 320       loop
 321          Res := Syscall_Send (S, Msg, Len, Flags);
 322          exit when Constants.Thread_Blocking_IO
 323            or else Res /= Failure
 324            or else Non_Blocking_Socket (S)
 325            or else Errno /= Constants.EWOULDBLOCK;
 326          delay Quantum;
 327       end loop;
 328
 329       return Res;
 330    end C_Send;
 331
 332    --------------
 333    -- C_Sendto --
 334    --------------
 335
 336    function C_Sendto
 337      (S     : C.int;
 338       Msg   : System.Address;
 339       Len   : C.int;
 340       Flags : C.int;
 341       To    : Sockaddr_In_Access;
 342       Tolen : C.int) return C.int
 343    is
 344       Res : C.int;
 345
 346    begin
 347       loop
 348          Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 349          exit when Constants.Thread_Blocking_IO
 350            or else Res /= Failure
 351            or else Non_Blocking_Socket (S)
 352            or else Errno /= Constants.EWOULDBLOCK;
 353          delay Quantum;
 354       end loop;
 355
 356       return Res;
 357    end C_Sendto;
 358
 359    --------------
 360    -- C_Socket --
 361    --------------
 362
 363    function C_Socket
 364      (Domain   : C.int;
 365       Typ      : C.int;
 366       Protocol : C.int) return C.int
 367    is
 368       R   : C.int;
 369       Val : aliased C.int := 1;
 370
 371       Res : C.int;
 372       pragma Unreferenced (Res);
 373
 374    begin
 375       R := Syscall_Socket (Domain, Typ, Protocol);
 376
 377       if not Constants.Thread_Blocking_IO
 378         and then R /= Failure
 379       then
 380          --  Do not use C_Ioctl as this subprogram tracks sockets set
 381          --  in non-blocking mode by user.
 382
 383          Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
 384          --  Is it OK to ignore result ???
 385          Set_Non_Blocking_Socket (R, False);
 386       end if;
 387
 388       return R;
 389    end C_Socket;
 390
 391    --------------
 392    -- Finalize --
 393    --------------
 394
 395    procedure Finalize is
 396    begin
 397       null;
 398    end Finalize;
 399
 400    -------------------------
 401    -- Host_Error_Messages --
 402    -------------------------
 403
 404    package body Host_Error_Messages is separate;
 405
 406    ----------------
 407    -- Initialize --
 408    ----------------
 409
 410    procedure Initialize is
 411    begin
 412       null;
 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_char (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    begin
 461       Sin.Sin_Length := C.unsigned_char (Len);
 462    end Set_Length;
 463
 464    -----------------------------
 465    -- Set_Non_Blocking_Socket --
 466    -----------------------------
 467
 468    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
 469    begin
 470       Task_Lock.Lock;
 471       if V then
 472          Insert_Socket_In_Set (Non_Blocking_Sockets, S);
 473       else
 474          Remove_Socket_From_Set (Non_Blocking_Sockets, S);
 475       end if;
 476
 477       Task_Lock.Unlock;
 478    end Set_Non_Blocking_Socket;
 479
 480    --------------
 481    -- Set_Port --
 482    --------------
 483
 484    procedure Set_Port
 485      (Sin  : Sockaddr_In_Access;
 486       Port : C.unsigned_short)
 487    is
 488    begin
 489       Sin.Sin_Port   := Port;
 490    end Set_Port;
 491
 492    --------------------
 493    -- Signalling_Fds --
 494    --------------------
 495
 496    package body Signalling_Fds is separate;
 497
 498    --------------------------
 499    -- Socket_Error_Message --
 500    --------------------------
 501
 502    function Socket_Error_Message
 503      (Errno : Integer) return C.Strings.chars_ptr
 504    is
 505       use type Interfaces.C.Strings.chars_ptr;
 506
 507       C_Msg : C.Strings.chars_ptr;
 508
 509    begin
 510       C_Msg := C_Strerror (C.int (Errno));
 511
 512       if C_Msg = C.Strings.Null_Ptr then
 513          return Unknown_System_Error;
 514
 515       else
 516          return C_Msg;
 517       end if;
 518    end Socket_Error_Message;
 519
 520 end GNAT.Sockets.Thin;