------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T . S O C K E T S . T H I N -- -- -- -- B o d y -- -- -- -- $Revision: 1.5 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- -- 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 2, 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. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; use GNAT.OS_Lib; with Interfaces.C; use Interfaces.C; package body GNAT.Sockets.Thin is -- 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 set a socket in non-blocking mode -- by purpose. We track the socket in such a mode by redefining -- C_Ioctl. In blocking IO operations, we exit normally when the -- non-blocking flag is set by user, we poll and try later when -- this flag is set automatically by this package. type Socket_Info is record Non_Blocking : Boolean := False; end record; Table : array (C.int range 0 .. 31) of Socket_Info; -- Get info on blocking flag. This array is limited to 32 sockets -- because the select operation allows socket set of less then 32 -- sockets. Quantum : constant Duration := 0.2; -- comment needed ??? 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); -------------- -- C_Accept -- -------------- 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 -- A socket inherits the properties ot its server especially -- the FNDELAY flag. Table (Res).Non_Blocking := Table (S).Non_Blocking; Set_Non_Blocking (Res); end if; return Res; 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 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; ------------- -- C_Ioctl -- ------------- 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; ------------ -- 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 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; ---------------- -- C_Recvfrom -- ---------------- 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; ------------ -- C_Send -- ------------ 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; -------------- -- C_Sendto -- -------------- 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; -------------- -- C_Socket -- -------------- 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; ----------- -- Clear -- ----------- 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; ----------- -- Empty -- ----------- procedure Empty (Item : in out Fd_Set) is begin Item := 0; end Empty; -------------- -- Finalize -- -------------- procedure Finalize is begin null; end Finalize; ---------------- -- Initialize -- ---------------- procedure Initialize (Process_Blocking_IO : Boolean) is begin Thread_Blocking_IO := not Process_Blocking_IO; end Initialize; -------------- -- Is_Empty -- -------------- function Is_Empty (Item : Fd_Set) return Boolean is begin return Item = 0; end Is_Empty; ------------ -- Is_Set -- ------------ function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is begin return (Item and 2 ** Natural (Socket)) /= 0; end Is_Set; --------- -- Max -- --------- 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; --------- -- Set -- --------- procedure Set (Item : in out Fd_Set; Socket : in C.int) is begin Item := Item or 2 ** Natural (Socket); end Set; ---------------------- -- Set_Non_Blocking -- ---------------------- procedure Set_Non_Blocking (S : C.int) is Res : C.int; Val : aliased C.int := 1; begin -- Do not use C_Fcntl because this subprogram tracks the -- sockets set by user in non-blocking mode. Res := Syscall_Ioctl (S, Constants.FIONBIO, Val'Unchecked_Access); end Set_Non_Blocking; -------------------------- -- Socket_Error_Message -- -------------------------- 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;