gcc/ada/g-socthi-vxworks.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                    G N A T . S O C K E T S . T H I N                     --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2002-2013, AdaCore                     --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This package provides a target dependent thin interface to the sockets
--  layer for use by the GNAT.Sockets package (g-socket.ads). This package
--  should not be directly with'ed by an applications program.

--  This version is for VxWorks

with GNAT.OS_Lib;  use GNAT.OS_Lib;
with GNAT.Task_Lock;

with Interfaces.C; use Interfaces.C;

package body GNAT.Sockets.Thin is

   Non_Blocking_Sockets : aliased Fd_Set;
   --  When this package is initialized with Process_Blocking_IO set
   --  to True, sockets are set in non-blocking mode to avoid blocking
   --  the whole process when a thread wants to perform a blocking IO
   --  operation. But the user can also set a socket in non-blocking
   --  mode by purpose. In order to make a difference between these
   --  two situations, we track the origin of non-blocking mode in
   --  Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
   --  been set in non-blocking mode by the user.

   Quantum : constant Duration := 0.2;
   --  When SOSC.Thread_Blocking_IO is False, we set sockets in
   --  non-blocking mode and we spend a period of time Quantum between
   --  two attempts on a blocking operation.

   -----------------------
   -- Local Subprograms --
   -----------------------

   --  All these require comments ???

   function Syscall_Accept
     (S       : C.int;
      Addr    : System.Address;
      Addrlen : not null access C.int) return C.int;
   pragma Import (C, Syscall_Accept, "accept");

   function Syscall_Connect
     (S       : C.int;
      Name    : System.Address;
      Namelen : C.int) return C.int;
   pragma Import (C, Syscall_Connect, "connect");

   function Syscall_Recv
     (S     : C.int;
      Msg   : System.Address;
      Len   : C.int;
      Flags : C.int) return C.int;
   pragma Import (C, Syscall_Recv, "recv");

   function Syscall_Recvfrom
     (S       : C.int;
      Msg     : System.Address;
      Len     : C.int;
      Flags   : C.int;
      From    : System.Address;
      Fromlen : not null access C.int) return C.int;
   pragma Import (C, Syscall_Recvfrom, "recvfrom");

   function Syscall_Recvmsg
     (S     : C.int;
      Msg   : System.Address;
      Flags : C.int) return C.int;
   pragma Import (C, Syscall_Recvmsg, "recvmsg");

   function Syscall_Sendmsg
     (S     : C.int;
      Msg   : System.Address;
      Flags : C.int) return C.int;
   pragma Import (C, Syscall_Sendmsg, "sendmsg");

   function Syscall_Send
     (S     : C.int;
      Msg   : System.Address;
      Len   : C.int;
      Flags : C.int) return C.int;
   pragma Import (C, Syscall_Send, "send");

   function Syscall_Sendto
     (S     : C.int;
      Msg   : System.Address;
      Len   : C.int;
      Flags : C.int;
      To    : System.Address;
      Tolen : C.int) return C.int;
   pragma Import (C, Syscall_Sendto, "sendto");

   function Syscall_Socket
     (Domain   : C.int;
      Typ      : C.int;
      Protocol : C.int) return C.int;
   pragma Import (C, Syscall_Socket, "socket");

   function Non_Blocking_Socket (S : C.int) return Boolean;
   procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);

   --------------
   -- C_Accept --
   --------------

   function C_Accept
     (S       : C.int;
      Addr    : System.Address;
      Addrlen : not null access C.int) return C.int
   is
      R   : C.int;
      Val : aliased C.int := 1;

      Res : C.int;
      pragma Unreferenced (Res);

   begin
      loop
         R := Syscall_Accept (S, Addr, Addrlen);
         exit when SOSC.Thread_Blocking_IO
           or else R /= Failure
           or else Non_Blocking_Socket (S)
           or else Errno /= SOSC.EWOULDBLOCK;
         delay Quantum;
      end loop;

      if not SOSC.Thread_Blocking_IO
        and then R /= Failure
      then
         --  A socket inherits the properties of its server especially
         --  the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
         --  tracks sockets set in non-blocking mode by user.

         Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
         Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
         --  Is it OK to ignore result ???
      end if;

      return R;
   end C_Accept;

   ---------------
   -- C_Connect --
   ---------------

   function C_Connect
     (S       : C.int;
      Name    : System.Address;
      Namelen : C.int) return C.int
   is
      Res : C.int;

   begin
      Res := Syscall_Connect (S, Name, Namelen);

      if SOSC.Thread_Blocking_IO
        or else Res /= Failure
        or else Non_Blocking_Socket (S)
        or else Errno /= SOSC.EINPROGRESS
      then
         return Res;
      end if;

      declare
         WSet : aliased Fd_Set;
         Now  : aliased Timeval;
      begin
         Reset_Socket_Set (WSet'Access);
         loop
            Insert_Socket_In_Set (WSet'Access, S);
            Now := Immediat;
            Res := C_Select
              (S + 1,
               No_Fd_Set_Access,
               WSet'Access,
               No_Fd_Set_Access,
               Now'Unchecked_Access);

            exit when Res > 0;

            if Res = Failure then
               return Res;
            end if;

            delay Quantum;
         end loop;
      end;

      Res := Syscall_Connect (S, Name, Namelen);

      if Res = Failure
        and then Errno = SOSC.EISCONN
      then
         return Thin_Common.Success;
      else
         return Res;
      end if;
   end C_Connect;

   ------------------
   -- Socket_Ioctl --
   ------------------

   function Socket_Ioctl
     (S   : C.int;
      Req : SOSC.IOCTL_Req_T;
      Arg : access C.int) return C.int
   is
   begin
      if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
         if Arg.all /= 0 then
            Set_Non_Blocking_Socket (S, True);
         end if;
      end if;

      return C_Ioctl (S, Req, Arg);
   end Socket_Ioctl;

   ------------
   -- C_Recv --
   ------------

   function C_Recv
     (S     : C.int;
      Msg   : System.Address;
      Len   : C.int;
      Flags : C.int) return C.int
   is
      Res : C.int;

   begin
      loop
         Res := Syscall_Recv (S, Msg, Len, Flags);
         exit when SOSC.Thread_Blocking_IO
           or else Res /= Failure
           or else Non_Blocking_Socket (S)
           or else Errno /= SOSC.EWOULDBLOCK;
         delay Quantum;
      end loop;

      return Res;
   end C_Recv;

   ----------------
   -- C_Recvfrom --
   ----------------

   function C_Recvfrom
     (S       : C.int;
      Msg     : System.Address;
      Len     : C.int;
      Flags   : C.int;
      From    : System.Address;
      Fromlen : not null access C.int) return C.int
   is
      Res : C.int;

   begin
      loop
         Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
         exit when SOSC.Thread_Blocking_IO
           or else Res /= Failure
           or else Non_Blocking_Socket (S)
           or else Errno /= SOSC.EWOULDBLOCK;
         delay Quantum;
      end loop;

      return Res;
   end C_Recvfrom;

   ---------------
   -- C_Recvmsg --
   ---------------

   function C_Recvmsg
     (S     : C.int;
      Msg   : System.Address;
      Flags : C.int) return System.CRTL.ssize_t
   is
      Res : C.int;

   begin
      loop
         Res := Syscall_Recvmsg (S, Msg, Flags);
         exit when SOSC.Thread_Blocking_IO
           or else Res /= Failure
           or else Non_Blocking_Socket (S)
           or else Errno /= SOSC.EWOULDBLOCK;
         delay Quantum;
      end loop;

      return System.CRTL.ssize_t (Res);
   end C_Recvmsg;

   ---------------
   -- C_Sendmsg --
   ---------------

   function C_Sendmsg
     (S     : C.int;
      Msg   : System.Address;
      Flags : C.int) return System.CRTL.ssize_t
   is
      Res : C.int;

   begin
      loop
         Res := Syscall_Sendmsg (S, Msg, Flags);
         exit when SOSC.Thread_Blocking_IO
           or else Res /= Failure
           or else Non_Blocking_Socket (S)
           or else Errno /= SOSC.EWOULDBLOCK;
         delay Quantum;
      end loop;

      return System.CRTL.ssize_t (Res);
   end C_Sendmsg;

   --------------
   -- C_Sendto --
   --------------

   function C_Sendto
     (S     : C.int;
      Msg   : System.Address;
      Len   : C.int;
      Flags : C.int;
      To    : System.Address;
      Tolen : C.int) return C.int
   is
      use System;

      Res : C.int;

   begin
      loop
         if To = Null_Address then

            --  In violation of the standard sockets API, VxWorks does not
            --  support sendto(2) calls on connected sockets with a null
            --  destination address, so use send(2) instead in that case.

            Res := Syscall_Send (S, Msg, Len, Flags);

         --  Normal case where destination address is non-null

         else
            Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
         end if;

         exit when SOSC.Thread_Blocking_IO
           or else Res /= Failure
           or else Non_Blocking_Socket (S)
           or else Errno /= SOSC.EWOULDBLOCK;
         delay Quantum;
      end loop;

      return Res;
   end C_Sendto;

   --------------
   -- C_Socket --
   --------------

   function C_Socket
     (Domain   : C.int;
      Typ      : C.int;
      Protocol : C.int) return C.int
   is
      R   : C.int;
      Val : aliased C.int := 1;

      Res : C.int;
      pragma Unreferenced (Res);

   begin
      R := Syscall_Socket (Domain, Typ, Protocol);

      if not SOSC.Thread_Blocking_IO
        and then R /= Failure
      then
         --  Do not use Socket_Ioctl as this subprogram tracks sockets set
         --  in non-blocking mode by user.

         Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
         --  Is it OK to ignore result ???
         Set_Non_Blocking_Socket (R, False);
      end if;

      return R;
   end C_Socket;

   --------------
   -- Finalize --
   --------------

   procedure Finalize is
   begin
      null;
   end Finalize;

   -------------------------
   -- Host_Error_Messages --
   -------------------------

   package body Host_Error_Messages is separate;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      Reset_Socket_Set (Non_Blocking_Sockets'Access);
   end Initialize;

   -------------------------
   -- Non_Blocking_Socket --
   -------------------------

   function Non_Blocking_Socket (S : C.int) return Boolean is
      R : Boolean;
   begin
      Task_Lock.Lock;
      R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
      Task_Lock.Unlock;
      return R;
   end Non_Blocking_Socket;

   -----------------------------
   -- Set_Non_Blocking_Socket --
   -----------------------------

   procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
   begin
      Task_Lock.Lock;
      if V then
         Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
      else
         Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
      end if;

      Task_Lock.Unlock;
   end Set_Non_Blocking_Socket;

   --------------------
   -- Signalling_Fds --
   --------------------

   package body Signalling_Fds is separate;

   --------------------------
   -- Socket_Error_Message --
   --------------------------

   function Socket_Error_Message (Errno : Integer) return String is separate;

end GNAT.Sockets.Thin;