| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- G N A T . S O C K E T S . T H I N -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2025, 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 is the default version |
| |
| with GNAT.OS_Lib; use GNAT.OS_Lib; |
| with GNAT.Task_Lock; |
| |
| with Interfaces.C; use Interfaces.C; |
| |
| with System.C_Time; |
| |
| 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. |
| |
| -- Comments required for following functions ??? |
| |
| function Syscall_Accept |
| (S : C.int; |
| Addr : System.Address; |
| Addrlen : not null access C.unsigned) return C.int; |
| pragma Import (C, Syscall_Accept, "accept"); |
| |
| function Syscall_Connect |
| (S : C.int; |
| Name : System.Address; |
| Namelen : C.unsigned) 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 System.CRTL.ssize_t; |
| 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.unsigned) return System.CRTL.ssize_t; |
| pragma Import (C, Syscall_Recvfrom, "recvfrom"); |
| |
| function Syscall_Recvmsg |
| (S : C.int; |
| Msg : System.Address; |
| Flags : C.int) return System.CRTL.ssize_t; |
| pragma Import (C, Syscall_Recvmsg, "recvmsg"); |
| |
| function Syscall_Sendmsg |
| (S : C.int; |
| Msg : System.Address; |
| Flags : C.int) return System.CRTL.ssize_t; |
| pragma Import (C, Syscall_Sendmsg, "sendmsg"); |
| |
| function Syscall_Sendto |
| (S : C.int; |
| Msg : System.Address; |
| Len : C.size_t; |
| Flags : C.int; |
| To : System.Address; |
| Tolen : C.unsigned) 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"); |
| |
| procedure Disable_SIGPIPE (S : C.int); |
| pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe"); |
| |
| procedure Disable_All_SIGPIPEs; |
| pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes"); |
| -- Sets the process to ignore all SIGPIPE signals on platforms that |
| -- don't support Disable_SIGPIPE for particular streams. |
| |
| function Non_Blocking_Socket (S : C.int) return Boolean; |
| procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); |
| |
| ------------ |
| -- C_Bind -- |
| ------------ |
| |
| function C_Bind |
| (S : C.int; |
| Name : System.Address; |
| Namelen : C.int) return C.int |
| is |
| function Bind |
| (S : C.int; |
| Name : System.Address; |
| Namelen : C.unsigned) return C.int |
| with Import, Convention => C, External_Name => "bind"; |
| |
| begin |
| return Bind (S, Name, C.unsigned (Namelen)); |
| end C_Bind; |
| |
| -------------- |
| -- C_Accept -- |
| -------------- |
| |
| function C_Accept |
| (S : C.int; |
| Addr : System.Address; |
| Addrlen : not null access C.int) return C.int |
| is |
| R : C.int; |
| U_Addrlen : aliased C.unsigned; |
| Val : aliased C.int := 1; |
| |
| Discard : C.int; |
| pragma Warnings (Off, Discard); |
| |
| begin |
| U_Addrlen := C.unsigned (Addrlen.all); |
| |
| loop |
| R := Syscall_Accept (S, Addr, U_Addrlen'Unchecked_Access); |
| 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; |
| |
| Addrlen.all := C.int (U_Addrlen); |
| |
| if not SOSC.Thread_Blocking_IO |
| and then R /= Failure |
| then |
| -- A socket inherits the properties ot 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)); |
| Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); |
| end if; |
| |
| Disable_SIGPIPE (R); |
| 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, C.unsigned (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; |
| |
| pragma Warnings (Off, "unreachable code"); |
| declare -- unreachable if Thread_Blocking_IO is statically True |
| pragma Warnings (On, "unreachable code"); |
| WSet : aliased Fd_Set; |
| Now : aliased System.C_Time.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, C.unsigned (Namelen)); |
| |
| if Res = Failure |
| and then Errno = SOSC.EISCONN |
| then |
| return Thin_Common.Success; |
| else |
| return Res; |
| end if; |
| end C_Connect; |
| |
| ------------------- |
| -- C_Getpeername -- |
| ------------------- |
| |
| function C_Getpeername |
| (S : C.int; |
| Name : System.Address; |
| Namelen : not null access C.int) return C.int |
| is |
| function Getpeername |
| (S : C.int; |
| Name : System.Address; |
| Namelen : not null access C.unsigned) return C.int |
| with Import, Convention => C, External_Name => "getpeername"; |
| |
| U_Namelen : aliased C.unsigned; |
| Val : C.int; |
| |
| begin |
| U_Namelen := C.unsigned (Namelen.all); |
| Val := Getpeername (S, Name, U_Namelen'Unchecked_Access); |
| Namelen.all := C.int (U_Namelen); |
| return Val; |
| end C_Getpeername; |
| |
| ------------------- |
| -- C_Getsockname -- |
| ------------------- |
| |
| function C_Getsockname |
| (S : C.int; |
| Name : System.Address; |
| Namelen : not null access C.int) return C.int |
| is |
| function Getsockname |
| (S : C.int; |
| Name : System.Address; |
| Namelen : not null access C.unsigned) return C.int |
| with Import, Convention => C, External_Name => "getsockname"; |
| |
| U_Namelen : aliased C.unsigned; |
| Val : C.int; |
| |
| begin |
| U_Namelen := C.unsigned (Namelen.all); |
| Val := Getsockname (S, Name, U_Namelen'Unchecked_Access); |
| Namelen.all := C.int (U_Namelen); |
| return Val; |
| end C_Getsockname; |
| |
| ------------------- |
| -- C_Getsockopt -- |
| ------------------- |
| |
| function C_Getsockopt |
| (S : C.int; |
| Level : C.int; |
| Optname : C.int; |
| Optval : System.Address; |
| Optlen : not null access C.int) return C.int |
| is |
| function Getsockopt |
| (S : C.int; |
| Level : C.int; |
| Optname : C.int; |
| Optval : System.Address; |
| Optlen : not null access C.unsigned) return C.int |
| with Import, Convention => C, External_Name => "getsockopt"; |
| |
| U_Optlen : aliased C.unsigned; |
| Val : C.int; |
| |
| begin |
| U_Optlen := C.unsigned (Optlen.all); |
| Val := Getsockopt (S, Level, Optname, Optval, U_Optlen'Unchecked_Access); |
| Optlen.all := C.int (U_Optlen); |
| return Val; |
| end C_Getsockopt; |
| |
| ------------------ |
| -- 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 := C.int (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; |
| U_Fromlen : aliased C.unsigned; |
| |
| begin |
| U_Fromlen := C.unsigned (Fromlen.all); |
| |
| loop |
| Res := C.int (Syscall_Recvfrom (S, Msg, Len, Flags, From, |
| U_Fromlen'Unchecked_Access)); |
| 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; |
| |
| Fromlen.all := C.int (U_Fromlen); |
| |
| 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 : System.CRTL.ssize_t; |
| |
| begin |
| loop |
| Res := Syscall_Recvmsg (S, Msg, Flags); |
| exit when SOSC.Thread_Blocking_IO |
| or else Res /= System.CRTL.ssize_t (Failure) |
| or else Non_Blocking_Socket (S) |
| or else Errno /= SOSC.EWOULDBLOCK; |
| delay Quantum; |
| end loop; |
| |
| return 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 : System.CRTL.ssize_t; |
| |
| begin |
| loop |
| Res := Syscall_Sendmsg (S, Msg, Flags); |
| exit when SOSC.Thread_Blocking_IO |
| or else Res /= System.CRTL.ssize_t (Failure) |
| or else Non_Blocking_Socket (S) |
| or else Errno /= SOSC.EWOULDBLOCK; |
| delay Quantum; |
| end loop; |
| |
| return 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 |
| Res : C.int; |
| |
| begin |
| loop |
| Res := C.int (Syscall_Sendto (S, Msg, Len, Flags, To, |
| C.unsigned (Tolen))); |
| 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_Setsockopt -- |
| ------------------ |
| |
| function C_Setsockopt |
| (S : C.int; |
| Level : C.int; |
| Optname : C.int; |
| Optval : System.Address; |
| Optlen : C.int) return C.int |
| is |
| function Setsockopt |
| (S : C.int; |
| Level : C.int; |
| Optname : C.int; |
| Optval : System.Address; |
| Optlen : C.unsigned) return C.int |
| with Import, Convention => C, External_Name => "setsockopt"; |
| |
| begin |
| return Setsockopt (S, Level, Optname, Optval, C.unsigned (Optlen)); |
| end C_Setsockopt; |
| |
| -------------- |
| -- 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; |
| |
| Discard : C.int; |
| |
| 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. |
| |
| Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); |
| Set_Non_Blocking_Socket (R, False); |
| end if; |
| Disable_SIGPIPE (R); |
| 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 |
| Disable_All_SIGPIPEs; |
| 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; |
| |
| -------------------------------- |
| -- Nonreentrant_Gethostbyaddr -- |
| -------------------------------- |
| |
| function Nonreentrant_Gethostbyaddr |
| (Addr : System.Address; |
| Addr_Len : C.int; |
| Addr_Type : C.int) return Hostent_Access |
| is |
| function Gethostbyaddr |
| (Addr : System.Address; |
| Addr_Len : C.unsigned; |
| Addr_Type : C.int) return Hostent_Access |
| with Import, Convention => C, External_Name => "gethostbyaddr"; |
| |
| begin |
| return Gethostbyaddr (Addr, C.unsigned (Addr_Len), Addr_Type); |
| end Nonreentrant_Gethostbyaddr; |
| |
| -------------------- |
| -- Signalling_Fds -- |
| -------------------- |
| |
| package body Signalling_Fds is |
| |
| -- In this default implementation, we use a C version of these |
| -- subprograms provided by socket.c. |
| |
| function C_Create (Fds : not null access Fd_Pair) return C.int; |
| function C_Read (Rsig : C.int) return C.int; |
| function C_Write (Wsig : C.int) return C.int; |
| procedure C_Close (Sig : C.int); |
| |
| pragma Import (C, C_Create, "__gnat_create_signalling_fds"); |
| pragma Import (C, C_Read, "__gnat_read_signalling_fd"); |
| pragma Import (C, C_Write, "__gnat_write_signalling_fd"); |
| pragma Import (C, C_Close, "__gnat_close_signalling_fd"); |
| |
| function Create |
| (Fds : not null access Fd_Pair) return C.int renames C_Create; |
| function Read (Rsig : C.int) return C.int renames C_Read; |
| function Write (Wsig : C.int) return C.int renames C_Write; |
| procedure Close (Sig : C.int) renames C_Close; |
| |
| end Signalling_Fds; |
| |
| -------------------------- |
| -- Socket_Error_Message -- |
| -------------------------- |
| |
| function Socket_Error_Message (Errno : Integer) return String is separate; |
| |
| end GNAT.Sockets.Thin; |
