mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-17 18:00:55 +08:00
Code Issues Packages Projects Releases Wiki Activity

g-soccon.ads: Add new constant Thread_Blocking_IO...

Browse Source 
2007-04-20  Thomas Quinot  <quinot@adacore.com>

	* g-soccon.ads: Add new constant Thread_Blocking_IO, always True by
	default, set False on a per-runtime basis.
	(Need_Netdb_Buffer): New constant.

	* g-socket.ads, g-socket.adb: Import new package
	GNAT.Sockets.Thin.Task_Safe_NetDB.
	(Raise_Host_Error): Use Host_Error_Message from platform-specific thin
	binding to obtain proper message.
	(Close_Selector): Use GNAT.Sockets.Thin.Signalling_Fds.Close.
	Replace various occurrences of Arry (Arry'First)'Address with the
	equivalent Arry'Address (GNAT always follows implementation advice from
	13.3(14)).
	(Get_Host_By_Address, Get_Host_By_Name,
	Get_Service_By_Name, Get_Service_By_Port): Do not use GNAT.Task_Lock;
	instead, rely on platform-specific task safe netdb operations provided
	by g-socthi.

	* g-socthi.ads, g-socthi.adb (Initialize): Remove obsolete formal
	parameter Process_Blocking_IO.
	(Host_Error_Messages): Add stub body.
	(GNAT.Sockets.Thin.Signalling_Fds): New procedure Close.
	(Safe_Gethostbyname, Safe_Gethostbyaddr, Safe_Getservbyname,
	Safe_Getservbyport): Move functions into new child package
	Task_Safe_NetDB.
	(Nonreentrant_Gethostbyname, Nonreentrant_Gethostbyaddr,
	Nonreentrant_Getservbyname, Nonreentrant_Getservbyport): New routines.
	(In_Addr): Add alignment clause.

From-SVN: r125424
This commit is contained in:
Thomas Quinot 2007-06-06 12:31:06 +02:00 committed by Arnaud Charlet
parent 96338f1975
commit 9aeef76b6f
5 changed files with 257 additions and 271 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/ada/g-soccon.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2005, Free Software Foundation, Inc. --
-- Copyright (C) 2000-2007, Free Software Foundation, 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- --
@ -43,6 +43,9 @@
-- but are for illustration purposes only. As noted above, part of a port
-- to a new target is to replace this file appropriately.
-- This file is generated automatically, do not modify it by hand! Instead,
-- make changes to gen-soccon.c and re-run it on each target.
package GNAT.Sockets.Constants is
--------------
@ -182,4 +185,17 @@ package GNAT.Sockets.Constants is
SIZEOF_tv_sec : constant := 4; -- tv_sec
SIZEOF_tv_usec : constant := 4; -- tv_usec
----------------------------------------
-- Properties of supported interfaces --
----------------------------------------
Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops
----------------------
-- Additional flags --
----------------------
Thread_Blocking_IO : constant Boolean := True;
-- Set False for contexts where socket i/o are process blocking
end GNAT.Sockets.Constants;

322
gcc/ada/g-socket.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2006, AdaCore --
-- Copyright (C) 2001-2007, 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- --
@ -31,15 +31,14 @@
-- --
------------------------------------------------------------------------------
with Ada.Streams; use Ada.Streams;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Streams; use Ada.Streams;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
with Interfaces.C.Strings;
with GNAT.Sockets.Constants;
with GNAT.Sockets.Thin; use GNAT.Sockets.Thin;
with GNAT.Task_Lock;
with GNAT.Sockets.Thin; use GNAT.Sockets.Thin;
with GNAT.Sockets.Thin.Task_Safe_NetDB; use GNAT.Sockets.Thin.Task_Safe_NetDB;
with GNAT.Sockets.Linker_Options;
pragma Warnings (Off, GNAT.Sockets.Linker_Options);
@ -56,53 +55,59 @@ package body GNAT.Sockets is
ENOERROR : constant := 0;
Netdb_Buffer_Size : constant := Constants.Need_Netdb_Buffer * 1024;
-- The network database functions gethostbyname, gethostbyaddr,
-- getservbyname and getservbyport can either be guaranteed task safe by
-- the operating system, or else return data through a user-provided buffer
-- to ensure concurrent uses do not interfere.
-- Correspondance tables
Families : constant array (Family_Type) of C.int :=
(Family_Inet => Constants.AF_INET,
Family_Inet6 => Constants.AF_INET6);
(Family_Inet => Constants.AF_INET,
Family_Inet6 => Constants.AF_INET6);
Levels : constant array (Level_Type) of C.int :=
(Socket_Level => Constants.SOL_SOCKET,
IP_Protocol_For_IP_Level => Constants.IPPROTO_IP,
IP_Protocol_For_UDP_Level => Constants.IPPROTO_UDP,
IP_Protocol_For_TCP_Level => Constants.IPPROTO_TCP);
(Socket_Level => Constants.SOL_SOCKET,
IP_Protocol_For_IP_Level => Constants.IPPROTO_IP,
IP_Protocol_For_UDP_Level => Constants.IPPROTO_UDP,
IP_Protocol_For_TCP_Level => Constants.IPPROTO_TCP);
Modes : constant array (Mode_Type) of C.int :=
(Socket_Stream => Constants.SOCK_STREAM,
Socket_Datagram => Constants.SOCK_DGRAM);
(Socket_Stream => Constants.SOCK_STREAM,
Socket_Datagram => Constants.SOCK_DGRAM);
Shutmodes : constant array (Shutmode_Type) of C.int :=
(Shut_Read => Constants.SHUT_RD,
Shut_Write => Constants.SHUT_WR,
Shut_Read_Write => Constants.SHUT_RDWR);
(Shut_Read => Constants.SHUT_RD,
Shut_Write => Constants.SHUT_WR,
Shut_Read_Write => Constants.SHUT_RDWR);
Requests : constant array (Request_Name) of C.int :=
(Non_Blocking_IO => Constants.FIONBIO,
N_Bytes_To_Read => Constants.FIONREAD);
(Non_Blocking_IO => Constants.FIONBIO,
N_Bytes_To_Read => Constants.FIONREAD);
Options : constant array (Option_Name) of C.int :=
(Keep_Alive => Constants.SO_KEEPALIVE,
Reuse_Address => Constants.SO_REUSEADDR,
Broadcast => Constants.SO_BROADCAST,
Send_Buffer => Constants.SO_SNDBUF,
Receive_Buffer => Constants.SO_RCVBUF,
Linger => Constants.SO_LINGER,
Error => Constants.SO_ERROR,
No_Delay => Constants.TCP_NODELAY,
Add_Membership => Constants.IP_ADD_MEMBERSHIP,
Drop_Membership => Constants.IP_DROP_MEMBERSHIP,
Multicast_If => Constants.IP_MULTICAST_IF,
Multicast_TTL => Constants.IP_MULTICAST_TTL,
Multicast_Loop => Constants.IP_MULTICAST_LOOP,
Send_Timeout => Constants.SO_SNDTIMEO,
Receive_Timeout => Constants.SO_RCVTIMEO);
(Keep_Alive => Constants.SO_KEEPALIVE,
Reuse_Address => Constants.SO_REUSEADDR,
Broadcast => Constants.SO_BROADCAST,
Send_Buffer => Constants.SO_SNDBUF,
Receive_Buffer => Constants.SO_RCVBUF,
Linger => Constants.SO_LINGER,
Error => Constants.SO_ERROR,
No_Delay => Constants.TCP_NODELAY,
Add_Membership => Constants.IP_ADD_MEMBERSHIP,
Drop_Membership => Constants.IP_DROP_MEMBERSHIP,
Multicast_If => Constants.IP_MULTICAST_IF,
Multicast_TTL => Constants.IP_MULTICAST_TTL,
Multicast_Loop => Constants.IP_MULTICAST_LOOP,
Send_Timeout => Constants.SO_SNDTIMEO,
Receive_Timeout => Constants.SO_RCVTIMEO);
Flags : constant array (0 .. 3) of C.int :=
(0 => Constants.MSG_OOB, -- Process_Out_Of_Band_Data
1 => Constants.MSG_PEEK, -- Peek_At_Incoming_Data
2 => Constants.MSG_WAITALL, -- Wait_For_A_Full_Reception
3 => Constants.MSG_EOR); -- Send_End_Of_Record
(0 => Constants.MSG_OOB, -- Process_Out_Of_Band_Data
1 => Constants.MSG_PEEK, -- Peek_At_Incoming_Data
2 => Constants.MSG_WAITALL, -- Wait_For_A_Full_Reception
3 => Constants.MSG_EOR); -- Send_End_Of_Record
Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
Host_Error_Id : constant Exception_Id := Host_Error'Identity;
@ -354,8 +359,8 @@ package body GNAT.Sockets is
raise Socket_Error;
end if;
Set_Length (Sin'Unchecked_Access, Len);
Set_Family (Sin'Unchecked_Access, Families (Address.Family));
Set_Length (Sin'Unchecked_Access, Len);
Set_Family (Sin'Unchecked_Access, Families (Address.Family));
Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr));
Set_Port
(Sin'Unchecked_Access,
@ -497,7 +502,6 @@ package body GNAT.Sockets is
E_Socket_Set := ESet;
exception
when Socket_Error =>
-- The local socket sets must be emptied before propagating
@ -533,27 +537,11 @@ package body GNAT.Sockets is
procedure Close_Selector (Selector : in out Selector_Type) is
begin
-- Close the signalling file descriptors used internally for the
-- implementation of Abort_Selector.
-- Close the signalling sockets used internally for the implementation
-- of Abort_Selector. Exceptions are ignored because these sockets
-- are implementation artefacts of no interest to the user, and
-- there is little that can be done if either Close_Socket call fails
-- (which theoretically should not happen anyway). We also want to try
-- to perform the second Close_Socket even if the first one failed.
begin
Close_Socket (Selector.R_Sig_Socket);
exception
when Socket_Error =>
null;
end;
begin
Close_Socket (Selector.W_Sig_Socket);
exception
when Socket_Error =>
null;
end;
Signalling_Fds.Close (C.int (Selector.R_Sig_Socket));
Signalling_Fds.Close (C.int (Selector.W_Sig_Socket));
-- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any
-- (errneous) subsequent attempt to use this selector properly fails.
@ -626,7 +614,6 @@ package body GNAT.Sockets is
when N_Bytes_To_Read =>
null;
end case;
Res := C_Ioctl
@ -794,32 +781,20 @@ package body GNAT.Sockets is
is
pragma Unreferenced (Family);
HA : aliased In_Addr := To_In_Addr (Address);
Res : Hostent_Access;
Err : Integer;
HA : aliased In_Addr := To_In_Addr (Address);
Buflen : constant C.int := Netdb_Buffer_Size;
Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
Res : aliased Hostent;
Err : aliased C.int;
begin
-- This C function is not always thread-safe. Protect against
-- concurrent access.
Task_Lock.Lock;
Res := C_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET);
if Res = null then
Err := Host_Errno;
Task_Lock.Unlock;
Raise_Host_Error (Err);
if Safe_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET,
Res'Access, Buf'Address, Buflen, Err'Access) /= 0
then
Raise_Host_Error (Integer (Err));
end if;
-- Translate from the C format to the API format
declare
HE : constant Host_Entry_Type := To_Host_Entry (Res.all);
begin
Task_Lock.Unlock;
return HE;
end;
return To_Host_Entry (Res);
end Get_Host_By_Address;
----------------------
@ -827,10 +802,6 @@ package body GNAT.Sockets is
----------------------
function Get_Host_By_Name (Name : String) return Host_Entry_Type is
HN : constant C.char_array := C.To_C (Name);
Res : Hostent_Access;
Err : Integer;
begin
-- Detect IP address name and redirect to Inet_Addr
@ -838,25 +809,21 @@ package body GNAT.Sockets is
return Get_Host_By_Address (Inet_Addr (Name));
end if;
-- This C function is not always thread-safe. Protect against
-- concurrent access.
Task_Lock.Lock;
Res := C_Gethostbyname (HN);
if Res = null then
Err := Host_Errno;
Task_Lock.Unlock;
Raise_Host_Error (Err);
end if;
-- Translate from the C format to the API format
declare
HE : constant Host_Entry_Type := To_Host_Entry (Res.all);
HN : constant C.char_array := C.To_C (Name);
Buflen : constant C.int := Netdb_Buffer_Size;
Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
Res : aliased Hostent;
Err : aliased C.int;
begin
Task_Lock.Unlock;
return HE;
if Safe_Gethostbyname
(HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
then
Raise_Host_Error (Integer (Err));
end if;
return To_Host_Entry (Res);
end;
end Get_Host_By_Name;
@ -888,32 +855,21 @@ package body GNAT.Sockets is
(Name : String;
Protocol : String) return Service_Entry_Type
is
SN : constant C.char_array := C.To_C (Name);
SP : constant C.char_array := C.To_C (Protocol);
Res : Servent_Access;
SN : constant C.char_array := C.To_C (Name);
SP : constant C.char_array := C.To_C (Protocol);
Buflen : constant C.int := Netdb_Buffer_Size;
Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
Res : aliased Servent;
begin
-- This C function is not always thread-safe. Protect against
-- concurrent access.
Task_Lock.Lock;
Res := C_Getservbyname (SN, SP);
if Res = null then
Task_Lock.Unlock;
if Safe_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
Ada.Exceptions.Raise_Exception
(Service_Error'Identity, "Service not found");
end if;
-- Translate from the C format to the API format
declare
SE : constant Service_Entry_Type := To_Service_Entry (Res.all);
begin
Task_Lock.Unlock;
return SE;
end;
return To_Service_Entry (Res);
end Get_Service_By_Name;
-------------------------
@ -924,32 +880,23 @@ package body GNAT.Sockets is
(Port : Port_Type;
Protocol : String) return Service_Entry_Type
is
SP : constant C.char_array := C.To_C (Protocol);
Res : Servent_Access;
SP : constant C.char_array := C.To_C (Protocol);
Buflen : constant C.int := Netdb_Buffer_Size;
Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
Res : aliased Servent;
begin
-- This C function is not always thread-safe. Protect against
-- concurrent access.
Task_Lock.Lock;
Res := C_Getservbyport
(C.int (Short_To_Network (C.unsigned_short (Port))), SP);
if Res = null then
Task_Lock.Unlock;
if Safe_Getservbyport
(C.int (Short_To_Network (C.unsigned_short (Port))), SP,
Res'Access, Buf'Address, Buflen) /= 0
then
Ada.Exceptions.Raise_Exception
(Service_Error'Identity, "Service not found");
end if;
-- Translate from the C format to the API format
declare
SE : constant Service_Entry_Type := To_Service_Entry (Res.all);
begin
Task_Lock.Unlock;
return SE;
end;
return To_Service_Entry (Res);
end Get_Service_By_Port;
---------------------
@ -966,6 +913,7 @@ package body GNAT.Sockets is
begin
Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
if Res /= Failure then
To_Inet_Addr (Sin.Sin_Addr, Addr.Addr);
Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
@ -1071,7 +1019,6 @@ package body GNAT.Sockets is
when Send_Timeout |
Receive_Timeout =>
Opt.Timeout := To_Duration (VT);
end case;
return Opt;
@ -1208,9 +1155,9 @@ package body GNAT.Sockets is
Result : Inet_Addr_Type;
begin
-- Special case for the all-ones broadcast address: this address
-- has the same in_addr_t value as Failure, and thus cannot be
-- properly returned by inet_addr(3).
-- Special case for the all-ones broadcast address: this address has the
-- same in_addr_t value as Failure, and thus cannot be properly returned
-- by inet_addr(3).
if Image = "255.255.255.255" then
return Broadcast_Inet_Addr;
@ -1238,11 +1185,26 @@ package body GNAT.Sockets is
-- Initialize --
----------------
procedure Initialize (Process_Blocking_IO : Boolean := False) is
procedure Initialize (Process_Blocking_IO : Boolean) is
Expected : constant Boolean := not Constants.Thread_Blocking_IO;
begin
if Process_Blocking_IO /= Expected then
raise Socket_Error with
"incorrect Process_Blocking_IO setting, expected " & Expected'Img;
end if;
Initialize;
end Initialize;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
if not Initialized then
Initialized := True;
Thin.Initialize (Process_Blocking_IO);
Thin.Initialize;
end if;
end Initialize;
@ -1355,32 +1317,10 @@ package body GNAT.Sockets is
----------------------
procedure Raise_Host_Error (H_Error : Integer) is
function Host_Error_Message return String;
-- We do not use a C function like strerror because hstrerror that would
-- correspond is obsolete. Return appropriate string for error value.
------------------------
-- Host_Error_Message --
------------------------
function Host_Error_Message return String is
begin
case H_Error is
when Constants.HOST_NOT_FOUND => return "Host not found";
when Constants.TRY_AGAIN => return "Try again";
when Constants.NO_RECOVERY => return "No recovery";
when Constants.NO_DATA => return "No address";
when others => return "Unknown error";
end case;
end Host_Error_Message;
-- Start of processing for Raise_Host_Error
begin
Ada.Exceptions.Raise_Exception (Host_Error'Identity,
Err_Code_Image (H_Error)
& Host_Error_Message);
& C.Strings.Value (Host_Error_Messages.Host_Error_Message (H_Error)));
end Raise_Host_Error;
------------------------
@ -1416,7 +1356,7 @@ package body GNAT.Sockets is
Index,
Stream.From);
Last := Index;
Last := Index;
-- Exit when all or zero data received. Zero means that the socket
-- peer is closed.
@ -1469,11 +1409,8 @@ package body GNAT.Sockets is
Res : C.int;
begin
Res := C_Recv
(C.int (Socket),
Item (Item'First)'Address,
Item'Length,
To_Int (Flags));
Res :=
C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
@ -1503,7 +1440,7 @@ package body GNAT.Sockets is
Res :=
C_Recvfrom
(C.int (Socket),
Item (Item'First)'Address,
Item'Address,
Item'Length,
To_Int (Flags),
Sin'Unchecked_Access,
@ -1534,8 +1471,7 @@ package body GNAT.Sockets is
case Error_Value is
when Constants.HOST_NOT_FOUND => return Unknown_Host;
when Constants.TRY_AGAIN => return Host_Name_Lookup_Failure;
when Constants.NO_RECOVERY =>
return Non_Recoverable_Error;
when Constants.NO_RECOVERY => return Non_Recoverable_Error;
when Constants.NO_DATA => return Unknown_Server_Error;
when others => return Cannot_Resolve_Error;
end case;
@ -1546,8 +1482,8 @@ package body GNAT.Sockets is
when EACCES => return Permission_Denied;
when EADDRINUSE => return Address_Already_In_Use;
when EADDRNOTAVAIL => return Cannot_Assign_Requested_Address;
when EAFNOSUPPORT =>
return Address_Family_Not_Supported_By_Protocol;
when EAFNOSUPPORT => return
Address_Family_Not_Supported_By_Protocol;
when EALREADY => return Operation_Already_In_Progress;
when EBADF => return Bad_File_Descriptor;
when ECONNABORTED => return Software_Caused_Connection_Abort;
@ -1567,8 +1503,8 @@ package body GNAT.Sockets is
when EMSGSIZE => return Message_Too_Long;
when ENAMETOOLONG => return File_Name_Too_Long;
when ENETDOWN => return Network_Is_Down;
when ENETRESET =>
return Network_Dropped_Connection_Because_Of_Reset;
when ENETRESET => return
Network_Dropped_Connection_Because_Of_Reset;
when ENETUNREACH => return Network_Is_Unreachable;
when ENOBUFS => return No_Buffer_Space_Available;
when ENOPROTOOPT => return Protocol_Not_Available;
@ -1578,8 +1514,8 @@ package body GNAT.Sockets is
when EPFNOSUPPORT => return Protocol_Family_Not_Supported;
when EPROTONOSUPPORT => return Protocol_Not_Supported;
when EPROTOTYPE => return Protocol_Wrong_Type_For_Socket;
when ESHUTDOWN =>
return Cannot_Send_After_Transport_Endpoint_Shutdown;
when ESHUTDOWN => return
Cannot_Send_After_Transport_Endpoint_Shutdown;
when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported;
when ETIMEDOUT => return Connection_Timed_Out;
when ETOOMANYREFS => return Too_Many_References;
@ -1648,7 +1584,7 @@ package body GNAT.Sockets is
Res :=
C_Readv
(C.int (Socket),
Vector (Vector'First)'Address,
Vector'Address,
Vector'Length);
if Res = Failure then
@ -1676,7 +1612,7 @@ package body GNAT.Sockets is
Res :=
C_Send
(C.int (Socket),
Item (Item'First)'Address,
Item'Address,
Item'Length,
Set_Forced_Flags (To_Int (Flags)));
@ -1714,7 +1650,7 @@ package body GNAT.Sockets is
Res := C_Sendto
(C.int (Socket),
Item (Item'First)'Address,
Item'Address,
Item'Length,
Set_Forced_Flags (To_Int (Flags)),
Sin'Unchecked_Access,
@ -2107,19 +2043,16 @@ package body GNAT.Sockets is
function To_Service_Entry (E : Servent) return Service_Entry_Type is
use type C.size_t;
Official : constant String :=
C.Strings.Value (E.S_Name);
Official : constant String := C.Strings.Value (E.S_Name);
Aliases : constant Chars_Ptr_Array :=
Chars_Ptr_Pointers.Value (E.S_Aliases);
-- S_Aliases points to a list of name aliases. The list is
-- terminated by a NULL pointer.
Protocol : constant String :=
C.Strings.Value (E.S_Proto);
Protocol : constant String := C.Strings.Value (E.S_Proto);
Result : Service_Entry_Type
(Aliases_Length => Aliases'Length - 1);
Result : Service_Entry_Type (Aliases_Length => Aliases'Length - 1);
-- The last element is a null pointer
Source : C.size_t;
@ -2141,7 +2074,6 @@ package body GNAT.Sockets is
Port_Type (Network_To_Short (C.unsigned_short (E.S_Port)));
Result.Protocol := To_Name (Protocol);
return Result;
end To_Service_Entry;

48
gcc/ada/g-socket.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2006, AdaCore --
-- Copyright (C) 2001-2007, 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- --
@ -42,7 +42,7 @@
-- installed. In particular Multicast is not available with the Windows
-- version.
-- The VMS implementation has implemented using the DECC RTL Socket API,
-- The VMS implementation was implemented using the DECC RTL Socket API,
-- and is thus subject to limitations in the implementation of this API.
-- VxWorks cross ports fully implement this package
@ -354,11 +354,7 @@ package GNAT.Sockets is
-- end Ping;
-- begin
-- -- Indicate whether the thread library provides process
-- -- blocking IO. Basically, if you are not using FSU threads
-- -- the default is ok.
-- Initialize (Process_Blocking_IO => False);
-- Initialize;
-- Ping.Start;
-- Pong.Start;
-- Ping.Stop;
@ -366,18 +362,22 @@ package GNAT.Sockets is
-- Finalize;
-- end PingPong;
procedure Initialize (Process_Blocking_IO : Boolean := False);
-- Initialize must be called before using any other socket routines. The
-- Process_Blocking_IO parameter indicates whether the thread library
-- provides process-blocking or thread-blocking input/output operations.
-- In the former case (typically with FSU threads) GNAT.Sockets should be
-- initialized with a value of True to provide task-blocking IO through an
-- emulation mechanism. Only the first call to Initialize is taken into
-- account (further calls will be ignored). Note that with the default
-- value of Process_Blocking_IO, this operation is a no-op on UNIX
-- platforms, but applications should make sure to call it if portability
-- is expected: some platforms (such as Windows) require initialization
-- before any other socket operations.
procedure Initialize;
-- Initialize must be called before using any other socket routines.
-- Note that this operation is a no-op on UNIX platforms, but applications
-- should make sure to call it if portability is expected: some platforms
-- (such as Windows) require initialization before any socket operation.
procedure Initialize (Process_Blocking_IO : Boolean);
pragma Obsolescent
(Entity => Initialize,
"passing a parameter to Initialize is not supported anymore");
-- Previous versions of GNAT.Sockets used to require the user to indicate
-- whether socket I/O was process- or thread-blocking on the platform.
-- This property is now determined automatically when the run-time library
-- is built. The old version of Initialize, taking a parameter, is kept
-- for compatibility reasons, but this interface is obsolete (and if the
-- value given is wrong, an exception will be raised at run time).
procedure Finalize;
-- After Finalize is called it is not possible to use any routines
@ -976,12 +976,10 @@ package GNAT.Sockets is
-- cases Status is set to Completed and sockets that are ready are set in
-- R_Socket_Set or W_Socket_Set. Status is set to Expired if no socket was
-- ready after a Timeout expiration. Status is set to Aborted if an abort
-- signal has been received while checking socket status. As this
-- procedure returns when Timeout occurs, it is a design choice to keep
-- this procedure process blocking. Note that a Timeout of 0.0 returns
-- immediately. Also note that two different Socket_Set_Type objects must
-- be passed as R_Socket_Set and W_Socket_Set (even if they denote the
-- same set of Sockets), or some event may be lost.
-- signal has been received while checking socket status.
-- Note that two different Socket_Set_Type objects must be passed as
-- R_Socket_Set and W_Socket_Set (even if they denote the same set of
-- Sockets), or some event may be lost.
-- Socket_Error is raised when the select(2) system call returns an
-- error condition, or when a read error occurs on the signalling socket
-- used for the implementation of Abort_Selector.

43
gcc/ada/g-socthi.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2006, AdaCore --
-- Copyright (C) 2001-2007, 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- --
@ -56,13 +56,10 @@ package body GNAT.Sockets.Thin is
-- been set in non-blocking mode by the user.
Quantum : constant Duration := 0.2;
-- When Thread_Blocking_IO is False, we set sockets in
-- When Constants.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;
-- Comment required for this ???
Unknown_System_Error : constant C.Strings.chars_ptr :=
C.Strings.New_String ("Unknown system error");
@ -153,14 +150,14 @@ package body GNAT.Sockets.Thin is
begin
loop
R := Syscall_Accept (S, Addr, Addrlen);
exit when Thread_Blocking_IO
exit when Constants.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
if not Constants.Thread_Blocking_IO
and then R /= Failure
then
-- A socket inherits the properties ot its server especially
@ -189,7 +186,7 @@ package body GNAT.Sockets.Thin is
begin
Res := Syscall_Connect (S, Name, Namelen);
if Thread_Blocking_IO
if Constants.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= Constants.EINPROGRESS
@ -247,7 +244,7 @@ package body GNAT.Sockets.Thin is
Arg : Int_Access) return C.int
is
begin
if not Thread_Blocking_IO
if not Constants.Thread_Blocking_IO
and then Req = Constants.FIONBIO
then
if Arg.all /= 0 then
@ -273,7 +270,7 @@ package body GNAT.Sockets.Thin is
begin
loop
Res := Syscall_Recv (S, Msg, Len, Flags);
exit when Thread_Blocking_IO
exit when Constants.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= Constants.EWOULDBLOCK;
@ -300,7 +297,7 @@ package body GNAT.Sockets.Thin is
begin
loop
Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
exit when Thread_Blocking_IO
exit when Constants.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= Constants.EWOULDBLOCK;
@ -325,7 +322,7 @@ package body GNAT.Sockets.Thin is
begin
loop
Res := Syscall_Send (S, Msg, Len, Flags);
exit when Thread_Blocking_IO
exit when Constants.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= Constants.EWOULDBLOCK;
@ -352,7 +349,7 @@ package body GNAT.Sockets.Thin is
begin
loop
Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
exit when Thread_Blocking_IO
exit when Constants.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= Constants.EWOULDBLOCK;
@ -380,7 +377,7 @@ package body GNAT.Sockets.Thin is
begin
R := Syscall_Socket (Domain, Typ, Protocol);
if not Thread_Blocking_IO
if not Constants.Thread_Blocking_IO
and then R /= Failure
then
-- Do not use C_Ioctl as this subprogram tracks sockets set
@ -402,13 +399,18 @@ package body GNAT.Sockets.Thin is
null;
end Finalize;
-------------------------
-- Host_Error_Messages --
-------------------------
package body Host_Error_Messages is separate;
----------------
-- Initialize --
----------------
procedure Initialize (Process_Blocking_IO : Boolean) is
procedure Initialize is
begin
Thread_Blocking_IO := not Process_Blocking_IO;
Disable_All_SIGPIPEs;
end Initialize;
@ -505,17 +507,18 @@ package body GNAT.Sockets.Thin is
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 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;

97
gcc/ada/g-socthi.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2006, AdaCore --
-- Copyright (C) 2001-2007, 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- --
@ -40,8 +40,8 @@
with Interfaces.C.Pointers;
with Interfaces.C.Strings;
with GNAT.Sockets.Constants;
with GNAT.OS_Lib;
with GNAT.Sockets.Constants;
with System;
@ -64,12 +64,21 @@ package GNAT.Sockets.Thin is
function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
-- Returns the error message string for the error number Errno. If Errno is
-- not known it returns "Unknown system error".
-- not known, returns "Unknown system error".
function Host_Errno return Integer;
pragma Import (C, Host_Errno, "__gnat_get_h_errno");
-- Returns last host error number
package Host_Error_Messages is
function Host_Error_Message
(H_Errno : Integer) return C.Strings.chars_ptr;
-- Returns the error message string for the host error number H_Errno.
-- If H_Errno is not known, returns "Unknown system error".
end Host_Error_Messages;
subtype Fd_Set_Access is System.Address;
No_Fd_Set : constant Fd_Set_Access := System.Null_Address;
@ -111,8 +120,11 @@ package GNAT.Sockets.Thin is
type In_Addr is record
S_B1, S_B2, S_B3, S_B4 : C.unsigned_char;
end record;
for In_Addr'Alignment use C.int'Alignment;
pragma Convention (C, In_Addr);
-- Internet address
-- IPv4 address, represented as a network-order C.int. Note that the
-- underlying operating system may assume that values of this type have
-- C.int alignment, so we need to provide a suitable alignment clause here.
type In_Addr_Access is access all In_Addr;
pragma Convention (C, In_Addr_Access);
@ -219,6 +231,10 @@ package GNAT.Sockets.Thin is
-- Indices into an Fd_Pair value providing access to each of the connected
-- file descriptors.
--------------------------------
-- Standard library functions --
--------------------------------
function C_Accept
(S : C.int;
Addr : System.Address;
@ -237,14 +253,6 @@ package GNAT.Sockets.Thin is
Name : System.Address;
Namelen : C.int) return C.int;
function C_Gethostbyaddr
(Addr : System.Address;
Len : C.int;
Typ : C.int) return Hostent_Access;
function C_Gethostbyname
(Name : C.char_array) return Hostent_Access;
function C_Gethostname
(Name : System.Address;
Namelen : C.int) return C.int;
@ -254,14 +262,6 @@ package GNAT.Sockets.Thin is
Name : System.Address;
Namelen : not null access C.int) return C.int;
function C_Getservbyname
(Name : C.char_array;
Proto : C.char_array) return Servent_Access;
function C_Getservbyport
(Port : C.int;
Proto : C.char_array) return Servent_Access;
function C_Getsockname
(S : C.int;
Name : System.Address;
@ -353,6 +353,10 @@ package GNAT.Sockets.Thin is
Iov : System.Address;
Iovcnt : C.int) return C.int;
-------------------------------------------------------
-- Signalling file descriptors for selector abortion --
-------------------------------------------------------
package Signalling_Fds is
function Create (Fds : not null access Fd_Pair) return C.int;
@ -370,8 +374,16 @@ package GNAT.Sockets.Thin is
-- Write one byte of data to wsig, the write end of a pair of signalling
-- fds created by Create_Signalling_Fds.
procedure Close (Sig : C.int);
pragma Convention (C, Close);
-- Close one end of a pair of signalling fds (ignoring any error)
end Signalling_Fds;
----------------------------
-- Socket sets management --
----------------------------
procedure Free_Socket_Set
(Set : Fd_Set_Access);
-- Free system-dependent socket set
@ -380,11 +392,11 @@ package GNAT.Sockets.Thin is
(Set : Fd_Set_Access;
Socket : Int_Access;
Last : Int_Access);
-- Get last socket in Socket and remove it from the socket
-- set. The parameter Last is a maximum value of the largest
-- socket. This hint is used to avoid scanning very large socket
-- sets. After a call to Get_Socket_From_Set, Last is set back to
-- the real largest socket in the socket set.
-- Get last socket in Socket and remove it from the socket set. The
-- parameter Last is a maximum value of the largest socket. This hint is
-- used to avoid scanning very large socket sets. After a call to
-- Get_Socket_From_Set, Last is set back to the real largest socket in the
-- socket set.
procedure Insert_Socket_In_Set
(Set : Fd_Set_Access;
@ -417,18 +429,38 @@ package GNAT.Sockets.Thin is
Socket : C.int);
-- Remove socket from the socket set
-------------------------------------------
-- Nonreentrant network databases access --
-------------------------------------------
-- The following are used only on systems that have nonreentrant
-- getXXXbyYYY functions, and do NOT have corresponding getXXXbyYYY_
-- functions. Currently, LynxOS is the only such system.
function Nonreentrant_Gethostbyname
(Name : C.char_array) return Hostent_Access;
function Nonreentrant_Gethostbyaddr
(Addr : System.Address;
Addr_Len : C.int;
Addr_Type : C.int) return Hostent_Access;
function Nonreentrant_Getservbyname
(Name : C.char_array;
Proto : C.char_array) return Servent_Access;
function Nonreentrant_Getservbyport
(Port : C.int;
Proto : C.char_array) return Servent_Access;
procedure Initialize;
procedure Finalize;
procedure Initialize (Process_Blocking_IO : Boolean);
private
pragma Import (C, C_Bind, "bind");
pragma Import (C, C_Close, "close");
pragma Import (C, C_Gethostbyaddr, "gethostbyaddr");
pragma Import (C, C_Gethostbyname, "gethostbyname");
pragma Import (C, C_Gethostname, "gethostname");
pragma Import (C, C_Getpeername, "getpeername");
pragma Import (C, C_Getservbyname, "getservbyname");
pragma Import (C, C_Getservbyport, "getservbyport");
pragma Import (C, C_Getsockname, "getsockname");
pragma Import (C, C_Getsockopt, "getsockopt");
pragma Import (C, C_Inet_Addr, "inet_addr");
@ -449,4 +481,9 @@ private
pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set");
pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set");
pragma Import (C, Nonreentrant_Gethostbyname, "gethostbyname");
pragma Import (C, Nonreentrant_Gethostbyaddr, "gethostbyaddr");
pragma Import (C, Nonreentrant_Getservbyname, "getservbyname");
pragma Import (C, Nonreentrant_Getservbyport, "getservbyport");
end GNAT.Sockets.Thin;