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