| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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-2005, 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 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, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, 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 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; |
| with Unchecked_Conversion; |
| |
| package body GNAT.Sockets.Thin is |
| |
| Non_Blocking_Sockets : constant Fd_Set_Access := |
| New_Socket_Set (No_Socket_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 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. |
| |
| Thread_Blocking_IO : Boolean := True; |
| |
| Unknown_System_Error : constant C.Strings.chars_ptr := |
| C.Strings.New_String ("Unknown system error"); |
| |
| -- The following types and variables are required to create a Hostent |
| -- record "by hand". |
| |
| type In_Addr_Access_Array_Access is access In_Addr_Access_Array; |
| |
| Alias_Access : constant Chars_Ptr_Pointers.Pointer := |
| new C.Strings.chars_ptr'(C.Strings.Null_Ptr); |
| |
| In_Addr_Access_Array_A : constant In_Addr_Access_Array_Access := |
| new In_Addr_Access_Array'(new In_Addr, null); |
| |
| In_Addr_Access_Ptr : constant In_Addr_Access_Pointers.Pointer := |
| In_Addr_Access_Array_A |
| (In_Addr_Access_Array_A'First)'Access; |
| |
| Local_Hostent : constant Hostent_Access := new Hostent; |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| -- All these require comments ??? |
| |
| 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 : 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 : 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 Thread_Blocking_IO |
| or else R /= Failure |
| or else Non_Blocking_Socket (S) |
| or else Errno /= Constants.EWOULDBLOCK; |
| delay Quantum; |
| end loop; |
| |
| if not Thread_Blocking_IO |
| and then R /= Failure |
| then |
| -- A socket inherits the properties ot its server especially |
| -- the FIONBIO flag. Do not use C_Ioctl as this subprogram |
| -- tracks sockets set in non-blocking mode by user. |
| |
| Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); |
| Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_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 Thread_Blocking_IO |
| or else Res /= Failure |
| or else Non_Blocking_Socket (S) |
| or else Errno /= Constants.EINPROGRESS |
| then |
| return Res; |
| end if; |
| |
| declare |
| WSet : Fd_Set_Access; |
| Now : aliased Timeval; |
| |
| begin |
| WSet := New_Socket_Set (No_Socket_Set); |
| |
| loop |
| Insert_Socket_In_Set (WSet, S); |
| Now := Immediat; |
| Res := C_Select |
| (S + 1, |
| No_Fd_Set, |
| WSet, |
| No_Fd_Set, |
| Now'Unchecked_Access); |
| |
| exit when Res > 0; |
| |
| if Res = Failure then |
| Free_Socket_Set (WSet); |
| return Res; |
| end if; |
| |
| delay Quantum; |
| end loop; |
| |
| Free_Socket_Set (WSet); |
| 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_Gethostbyaddr -- |
| --------------------- |
| |
| function C_Gethostbyaddr |
| (Addr : System.Address; |
| Len : C.int; |
| Typ : C.int) return Hostent_Access |
| is |
| pragma Warnings (Off, Len); |
| pragma Warnings (Off, Typ); |
| |
| type int_Access is access int; |
| function To_Pointer is |
| new Unchecked_Conversion (System.Address, int_Access); |
| |
| function VxWorks_hostGetByAddr |
| (Addr : C.int; Buf : System.Address) return C.int; |
| pragma Import (C, VxWorks_hostGetByAddr, "hostGetByAddr"); |
| |
| Host_Name : aliased C.char_array (1 .. Max_Name_Length); |
| |
| begin |
| if VxWorks_hostGetByAddr (To_Pointer (Addr).all, |
| Host_Name (Host_Name'First)'Address) |
| /= Constants.OK |
| then |
| return null; |
| end if; |
| |
| In_Addr_Access_Ptr.all.all := To_In_Addr (To_Pointer (Addr).all); |
| Local_Hostent.all.H_Name := C.Strings.New_Char_Array (Host_Name); |
| |
| return Local_Hostent; |
| end C_Gethostbyaddr; |
| |
| --------------------- |
| -- C_Gethostbyname -- |
| --------------------- |
| |
| function C_Gethostbyname |
| (Name : C.char_array) return Hostent_Access |
| is |
| function VxWorks_hostGetByName |
| (Name : C.char_array) return C.int; |
| pragma Import (C, VxWorks_hostGetByName, "hostGetByName"); |
| |
| Addr : C.int; |
| |
| begin |
| Addr := VxWorks_hostGetByName (Name); |
| if Addr /= Constants.OK then |
| return null; |
| end if; |
| |
| In_Addr_Access_Ptr.all.all := To_In_Addr (Addr); |
| Local_Hostent.all.H_Name := C.Strings.New_Char_Array (To_C (Host_Name)); |
| |
| return Local_Hostent; |
| end C_Gethostbyname; |
| |
| --------------------- |
| -- C_Getservbyname -- |
| --------------------- |
| |
| function C_Getservbyname |
| (Name : C.char_array; |
| Proto : C.char_array) return Servent_Access |
| is |
| pragma Warnings (Off, Name); |
| pragma Warnings (Off, Proto); |
| |
| begin |
| return null; |
| end C_Getservbyname; |
| |
| --------------------- |
| -- C_Getservbyport -- |
| --------------------- |
| |
| function C_Getservbyport |
| (Port : C.int; |
| Proto : C.char_array) return Servent_Access |
| is |
| pragma Warnings (Off, Port); |
| pragma Warnings (Off, Proto); |
| |
| begin |
| return null; |
| end C_Getservbyport; |
| |
| ------------- |
| -- 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 |
| if Arg.all /= 0 then |
| Set_Non_Blocking_Socket (S, True); |
| end if; |
| 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 Non_Blocking_Socket (S) |
| 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 Non_Blocking_Socket (S) |
| 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 Non_Blocking_Socket (S) |
| 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 Non_Blocking_Socket (S) |
| 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 |
| R : C.int; |
| Val : aliased C.int := 1; |
| |
| Res : C.int; |
| pragma Unreferenced (Res); |
| |
| begin |
| R := Syscall_Socket (Domain, Typ, Protocol); |
| |
| if not Thread_Blocking_IO |
| and then R /= Failure |
| then |
| -- Do not use C_Ioctl as this subprogram tracks sockets set |
| -- in non-blocking mode by user. |
| |
| Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_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; |
| |
| ---------------- |
| -- Initialize -- |
| ---------------- |
| |
| procedure Initialize (Process_Blocking_IO : Boolean) is |
| begin |
| Thread_Blocking_IO := not Process_Blocking_IO; |
| 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, S) /= 0); |
| Task_Lock.Unlock; |
| return R; |
| end Non_Blocking_Socket; |
| |
| ----------------- |
| -- Set_Address -- |
| ----------------- |
| |
| procedure Set_Address |
| (Sin : Sockaddr_In_Access; |
| Address : In_Addr) |
| is |
| begin |
| Sin.Sin_Addr := Address; |
| end Set_Address; |
| |
| ---------------- |
| -- Set_Family -- |
| ---------------- |
| |
| procedure Set_Family |
| (Sin : Sockaddr_In_Access; |
| Family : C.int) |
| is |
| begin |
| Sin.Sin_Family := C.unsigned_char (Family); |
| end Set_Family; |
| |
| ---------------- |
| -- Set_Length -- |
| ---------------- |
| |
| procedure Set_Length |
| (Sin : Sockaddr_In_Access; |
| Len : C.int) |
| is |
| begin |
| Sin.Sin_Length := C.unsigned_char (Len); |
| end Set_Length; |
| |
| ----------------------------- |
| -- 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, S); |
| else |
| Remove_Socket_From_Set (Non_Blocking_Sockets, S); |
| end if; |
| |
| Task_Lock.Unlock; |
| end Set_Non_Blocking_Socket; |
| |
| -------------- |
| -- Set_Port -- |
| -------------- |
| |
| procedure Set_Port |
| (Sin : Sockaddr_In_Access; |
| Port : C.unsigned_short) |
| is |
| begin |
| Sin.Sin_Port := Port; |
| end Set_Port; |
| |
| -------------------------- |
| -- Socket_Error_Message -- |
| -------------------------- |
| |
| function Socket_Error_Message |
| (Errno : Integer) return C.Strings.chars_ptr |
| 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_Msg; |
| end if; |
| end Socket_Error_Message; |
| |
| -- Package elaboration |
| |
| begin |
| Local_Hostent.all.H_Aliases := Alias_Access; |
| |
| -- VxWorks currently only supports AF_INET |
| |
| Local_Hostent.all.H_Addrtype := Constants.AF_INET; |
| |
| Local_Hostent.all.H_Length := 1; |
| Local_Hostent.all.H_Addr_List := In_Addr_Access_Ptr; |
| |
| end GNAT.Sockets.Thin; |
