with GNAT.OS_Lib; use GNAT.OS_Lib;
with Interfaces.C; use Interfaces.C;
package body GNAT.Sockets.Thin is
type Socket_Info is record
Non_Blocking : Boolean := False;
end record;
Table : array (C.int range 0 .. 31) of Socket_Info;
Quantum : constant Duration := 0.2;
Thread_Blocking_IO : Boolean := True;
function Syscall_Accept
(S : C.int;
Addr : System.Address;
Addrlen : 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_Ioctl
(S : C.int;
Req : C.int;
Arg : Int_Access)
return C.int;
pragma Import (C, Syscall_Ioctl, "ioctl");
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 : Sockaddr_In_Access;
Fromlen : access C.int)
return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
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 : Sockaddr_In_Access;
Tolen : C.int)
return C.int;
pragma Import (C, Syscall_Sendto, "sendto");
function Syscall_Socket
(Domain, Typ, Protocol : C.int)
return C.int;
pragma Import (C, Syscall_Socket, "socket");
procedure Set_Non_Blocking (S : C.int);
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int)
return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Accept (S, Addr, Addrlen);
exit when Thread_Blocking_IO
or else Res /= Failure
or else Table (S).Non_Blocking
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
if not Thread_Blocking_IO
and then Res /= Failure
then
Table (Res).Non_Blocking := Table (S).Non_Blocking;
Set_Non_Blocking (Res);
end if;
return Res;
end C_Accept;
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 Thread_Blocking_IO
or else Res /= Failure
or else Table (S).Non_Blocking
or else Errno /= Constants.EINPROGRESS
then
return Res;
end if;
declare
Set : aliased Fd_Set;
Now : aliased Timeval;
begin
loop
Set := 2 ** Natural (S);
Now := Immediat;
Res := C_Select
(S + 1,
null, Set'Unchecked_Access,
null, 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 = Constants.EISCONN
then
return Thin.Success;
else
return Res;
end if;
end C_Connect;
function C_Ioctl
(S : C.int;
Req : C.int;
Arg : Int_Access)
return C.int
is
begin
if not Thread_Blocking_IO
and then Req = Constants.FIONBIO
then
Table (S).Non_Blocking := (Arg.all /= 0);
end if;
return Syscall_Ioctl (S, Req, Arg);
end C_Ioctl;
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 Thread_Blocking_IO
or else Res /= Failure
or else Table (S).Non_Blocking
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Recv;
function C_Recvfrom
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int)
return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
exit when Thread_Blocking_IO
or else Res /= Failure
or else Table (S).Non_Blocking
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Recvfrom;
function C_Send
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int)
return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Send (S, Msg, Len, Flags);
exit when Thread_Blocking_IO
or else Res /= Failure
or else Table (S).Non_Blocking
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Send;
function C_Sendto
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
To : Sockaddr_In_Access;
Tolen : C.int)
return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
exit when Thread_Blocking_IO
or else Res /= Failure
or else Table (S).Non_Blocking
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Sendto;
function C_Socket
(Domain : C.int;
Typ : C.int;
Protocol : C.int)
return C.int
is
Res : C.int;
begin
Res := Syscall_Socket (Domain, Typ, Protocol);
if not Thread_Blocking_IO
and then Res /= Failure
then
Set_Non_Blocking (Res);
end if;
return Res;
end C_Socket;
procedure Clear
(Item : in out Fd_Set;
Socket : in C.int)
is
Mask : constant Fd_Set := 2 ** Natural (Socket);
begin
if (Item and Mask) /= 0 then
Item := Item xor Mask;
end if;
end Clear;
procedure Empty (Item : in out Fd_Set) is
begin
Item := 0;
end Empty;
procedure Finalize is
begin
null;
end Finalize;
procedure Initialize (Process_Blocking_IO : Boolean) is
begin
Thread_Blocking_IO := not Process_Blocking_IO;
end Initialize;
function Is_Empty (Item : Fd_Set) return Boolean is
begin
return Item = 0;
end Is_Empty;
function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is
begin
return (Item and 2 ** Natural (Socket)) /= 0;
end Is_Set;
function Max (Item : Fd_Set) return C.int
is
L : C.int := -1;
C : Fd_Set := Item;
begin
while C /= 0 loop
L := L + 1;
C := C / 2;
end loop;
return L;
end Max;
procedure Set (Item : in out Fd_Set; Socket : in C.int) is
begin
Item := Item or 2 ** Natural (Socket);
end Set;
procedure Set_Non_Blocking (S : C.int) is
Res : C.int;
Val : aliased C.int := 1;
begin
Res := Syscall_Ioctl (S, Constants.FIONBIO, Val'Unchecked_Access);
end Set_Non_Blocking;
function Socket_Error_Message (Errno : Integer) return String is
use type Interfaces.C.Strings.chars_ptr;
C_Msg : C.Strings.chars_ptr;
begin
C_Msg := C_Strerror (C.int (Errno));
if C_Msg = C.Strings.Null_Ptr then
return "Unknown system error";
else
return C.Strings.Value (C_Msg);
end if;
end Socket_Error_Message;
end GNAT.Sockets.Thin;