| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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-2022, 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.size_t; |
| Flags : C.int) return C.int; |
| pragma Import (C, Syscall_Recv, "recv"); |
| |
| function Syscall_Recvfrom |
| (S : C.int; |
| Msg : System.Address; |
| Len : C.size_t; |
| 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.size_t; |
| Flags : C.int) return System.CRTL.ssize_t; |
| pragma Import (C, Syscall_Send, "send"); |
| |
| function Syscall_Sendto |
| (S : C.int; |
| Msg : System.Address; |
| Len : C.size_t; |
| Flags : C.int; |
| To : System.Address; |
| Tolen : C.int) return System.CRTL.ssize_t; |
| 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.size_t; |
| 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.size_t; |
| 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.size_t; |
| 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 := C.int (Syscall_Send (S, Msg, Len, Flags)); |
| |
| -- Normal case where destination address is non-null |
| |
| else |
| Res := C.int (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; |
| |
| ------------------ |
| -- C_Socketpair -- |
| ------------------ |
| |
| function C_Socketpair |
| (Domain : C.int; |
| Typ : C.int; |
| Protocol : C.int; |
| Fds : not null access Fd_Pair) return C.int is separate; |
| |
| -------------- |
| -- 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; |