OSDN Git Service

b75c525202f9180bbc0dc26aaee059f54fcd9788
[pf3gnuchains/gcc-fork.git] / gcc / ada / g-socket.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT COMPILER COMPONENTS                         --
4 --                                                                          --
5 --                         G N A T . S O C K E T S                          --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --                     Copyright (C) 2001-2010, AdaCore                     --
10 --                                                                          --
11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
12 -- terms of the  GNU General Public License as published  by the Free Soft- --
13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17 -- for  more details.  You should have  received  a copy of the GNU General --
18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
20 -- Boston, MA 02110-1301, USA.                                              --
21 --                                                                          --
22 -- As a special exception,  if other files  instantiate  generics from this --
23 -- unit, or you link  this unit with other files  to produce an executable, --
24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
25 -- covered  by the  GNU  General  Public  License.  This exception does not --
26 -- however invalidate  any other reasons why  the executable file  might be --
27 -- covered by the  GNU Public License.                                      --
28 --                                                                          --
29 -- GNAT was originally developed  by the GNAT team at  New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
31 --                                                                          --
32 ------------------------------------------------------------------------------
33
34 with Ada.Streams;              use Ada.Streams;
35 with Ada.Exceptions;           use Ada.Exceptions;
36 with Ada.Finalization;
37 with Ada.Unchecked_Conversion;
38
39 with Interfaces.C.Strings;
40
41 with GNAT.Sockets.Thin_Common;          use GNAT.Sockets.Thin_Common;
42 with GNAT.Sockets.Thin;                 use GNAT.Sockets.Thin;
43
44 with GNAT.Sockets.Linker_Options;
45 pragma Warnings (Off, GNAT.Sockets.Linker_Options);
46 --  Need to include pragma Linker_Options which is platform dependent
47
48 with System;               use System;
49 with System.Communication; use System.Communication;
50 with System.CRTL;          use System.CRTL;
51 with System.Task_Lock;
52
53 package body GNAT.Sockets is
54
55    package C renames Interfaces.C;
56
57    use type C.int;
58
59    ENOERROR : constant := 0;
60
61    Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024;
62    Need_Netdb_Lock   : constant Boolean := SOSC.Need_Netdb_Lock /= 0;
63    --  The network database functions gethostbyname, gethostbyaddr,
64    --  getservbyname and getservbyport can either be guaranteed task safe by
65    --  the operating system, or else return data through a user-provided buffer
66    --  to ensure concurrent uses do not interfere.
67
68    --  Correspondence tables
69
70    Levels : constant array (Level_Type) of C.int :=
71               (Socket_Level              => SOSC.SOL_SOCKET,
72                IP_Protocol_For_IP_Level  => SOSC.IPPROTO_IP,
73                IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP,
74                IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP);
75
76    Modes : constant array (Mode_Type) of C.int :=
77              (Socket_Stream   => SOSC.SOCK_STREAM,
78               Socket_Datagram => SOSC.SOCK_DGRAM);
79
80    Shutmodes : constant array (Shutmode_Type) of C.int :=
81                  (Shut_Read       => SOSC.SHUT_RD,
82                   Shut_Write      => SOSC.SHUT_WR,
83                   Shut_Read_Write => SOSC.SHUT_RDWR);
84
85    Requests : constant array (Request_Name) of C.int :=
86                 (Non_Blocking_IO => SOSC.FIONBIO,
87                  N_Bytes_To_Read => SOSC.FIONREAD);
88
89    Options : constant array (Option_Name) of C.int :=
90                (Keep_Alive          => SOSC.SO_KEEPALIVE,
91                 Reuse_Address       => SOSC.SO_REUSEADDR,
92                 Broadcast           => SOSC.SO_BROADCAST,
93                 Send_Buffer         => SOSC.SO_SNDBUF,
94                 Receive_Buffer      => SOSC.SO_RCVBUF,
95                 Linger              => SOSC.SO_LINGER,
96                 Error               => SOSC.SO_ERROR,
97                 No_Delay            => SOSC.TCP_NODELAY,
98                 Add_Membership      => SOSC.IP_ADD_MEMBERSHIP,
99                 Drop_Membership     => SOSC.IP_DROP_MEMBERSHIP,
100                 Multicast_If        => SOSC.IP_MULTICAST_IF,
101                 Multicast_TTL       => SOSC.IP_MULTICAST_TTL,
102                 Multicast_Loop      => SOSC.IP_MULTICAST_LOOP,
103                 Receive_Packet_Info => SOSC.IP_PKTINFO,
104                 Send_Timeout        => SOSC.SO_SNDTIMEO,
105                 Receive_Timeout     => SOSC.SO_RCVTIMEO);
106    --  ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
107    --  but for Linux compatibility this constant is the same as IP_PKTINFO.
108
109    Flags : constant array (0 .. 3) of C.int :=
110              (0 => SOSC.MSG_OOB,     --  Process_Out_Of_Band_Data
111               1 => SOSC.MSG_PEEK,    --  Peek_At_Incoming_Data
112               2 => SOSC.MSG_WAITALL, --  Wait_For_A_Full_Reception
113               3 => SOSC.MSG_EOR);    --  Send_End_Of_Record
114
115    Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
116    Host_Error_Id   : constant Exception_Id := Host_Error'Identity;
117
118    Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF";
119    --  Use to print in hexadecimal format
120
121    -----------------------
122    -- Local subprograms --
123    -----------------------
124
125    function Resolve_Error
126      (Error_Value : Integer;
127       From_Errno  : Boolean := True) return Error_Type;
128    --  Associate an enumeration value (error_type) to en error value (errno).
129    --  From_Errno prevents from mixing h_errno with errno.
130
131    function To_Name   (N  : String) return Name_Type;
132    function To_String (HN : Name_Type) return String;
133    --  Conversion functions
134
135    function To_Int (F : Request_Flag_Type) return C.int;
136    --  Return the int value corresponding to the specified flags combination
137
138    function Set_Forced_Flags (F : C.int) return C.int;
139    --  Return F with the bits from SOSC.MSG_Forced_Flags forced set
140
141    function Short_To_Network
142      (S : C.unsigned_short) return C.unsigned_short;
143    pragma Inline (Short_To_Network);
144    --  Convert a port number into a network port number
145
146    function Network_To_Short
147      (S : C.unsigned_short) return C.unsigned_short
148    renames Short_To_Network;
149    --  Symmetric operation
150
151    function Image
152      (Val :  Inet_Addr_VN_Type;
153       Hex :  Boolean := False) return String;
154    --  Output an array of inet address components in hex or decimal mode
155
156    function Is_IP_Address (Name : String) return Boolean;
157    --  Return true when Name is an IP address in standard dot notation
158
159    procedure Netdb_Lock;
160    pragma Inline (Netdb_Lock);
161    procedure Netdb_Unlock;
162    pragma Inline (Netdb_Unlock);
163    --  Lock/unlock operation used to protect netdb access for platforms that
164    --  require such protection.
165
166    function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr;
167    procedure To_Inet_Addr
168      (Addr   : In_Addr;
169       Result : out Inet_Addr_Type);
170    --  Conversion functions
171
172    function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type;
173    --  Conversion function
174
175    function To_Service_Entry (E : Servent_Access) return Service_Entry_Type;
176    --  Conversion function
177
178    function Value (S : System.Address) return String;
179    --  Same as Interfaces.C.Strings.Value but taking a System.Address (on VMS,
180    --  chars_ptr is a 32-bit pointer, and here we need a 64-bit version).
181
182    function To_Timeval (Val : Timeval_Duration) return Timeval;
183    --  Separate Val in seconds and microseconds
184
185    function To_Duration (Val : Timeval) return Timeval_Duration;
186    --  Reconstruct a Duration value from a Timeval record (seconds and
187    --  microseconds).
188
189    procedure Raise_Socket_Error (Error : Integer);
190    --  Raise Socket_Error with an exception message describing the error code
191    --  from errno.
192
193    procedure Raise_Host_Error (H_Error : Integer);
194    --  Raise Host_Error exception with message describing error code (note
195    --  hstrerror seems to be obsolete) from h_errno.
196
197    procedure Narrow (Item : in out Socket_Set_Type);
198    --  Update Last as it may be greater than the real last socket
199
200    --  Types needed for Datagram_Socket_Stream_Type
201
202    type Datagram_Socket_Stream_Type is new Root_Stream_Type with record
203       Socket : Socket_Type;
204       To     : Sock_Addr_Type;
205       From   : Sock_Addr_Type;
206    end record;
207
208    type Datagram_Socket_Stream_Access is
209      access all Datagram_Socket_Stream_Type;
210
211    procedure Read
212      (Stream : in out Datagram_Socket_Stream_Type;
213       Item   : out Ada.Streams.Stream_Element_Array;
214       Last   : out Ada.Streams.Stream_Element_Offset);
215
216    procedure Write
217      (Stream : in out Datagram_Socket_Stream_Type;
218       Item   : Ada.Streams.Stream_Element_Array);
219
220    --  Types needed for Stream_Socket_Stream_Type
221
222    type Stream_Socket_Stream_Type is new Root_Stream_Type with record
223       Socket : Socket_Type;
224    end record;
225
226    type Stream_Socket_Stream_Access is
227      access all Stream_Socket_Stream_Type;
228
229    procedure Read
230      (Stream : in out Stream_Socket_Stream_Type;
231       Item   : out Ada.Streams.Stream_Element_Array;
232       Last   : out Ada.Streams.Stream_Element_Offset);
233
234    procedure Write
235      (Stream : in out Stream_Socket_Stream_Type;
236       Item   : Ada.Streams.Stream_Element_Array);
237
238    procedure Stream_Write
239      (Socket : Socket_Type;
240       Item   : Ada.Streams.Stream_Element_Array;
241       To     : access Sock_Addr_Type);
242    --  Common implementation for the Write operation of Datagram_Socket_Stream_
243    --  Type and Stream_Socket_Stream_Type.
244
245    procedure Wait_On_Socket
246      (Socket    : Socket_Type;
247       For_Read  : Boolean;
248       Timeout   : Selector_Duration;
249       Selector  : access Selector_Type := null;
250       Status    : out Selector_Status);
251    --  Common code for variants of socket operations supporting a timeout:
252    --  block in Check_Selector on Socket for at most the indicated timeout.
253    --  If For_Read is True, Socket is added to the read set for this call, else
254    --  it is added to the write set. If no selector is provided, a local one is
255    --  created for this call and destroyed prior to returning.
256
257    type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled
258      with null record;
259    --  This type is used to generate automatic calls to Initialize and Finalize
260    --  during the elaboration and finalization of this package. A single object
261    --  of this type must exist at library level.
262
263    function Err_Code_Image (E : Integer) return String;
264    --  Return the value of E surrounded with brackets
265
266    procedure Initialize (X : in out Sockets_Library_Controller);
267    procedure Finalize   (X : in out Sockets_Library_Controller);
268
269    procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type);
270    --  If S is the empty set (detected by Last = No_Socket), make sure its
271    --  fd_set component is actually cleared. Note that the case where it is
272    --  not can occur for an uninitialized Socket_Set_Type object.
273
274    function Is_Open (S : Selector_Type) return Boolean;
275    --  Return True for an "open" Selector_Type object, i.e. one for which
276    --  Create_Selector has been called and Close_Selector has not been called,
277    --  or the null selector.
278
279    ---------
280    -- "+" --
281    ---------
282
283    function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is
284    begin
285       return L or R;
286    end "+";
287
288    --------------------
289    -- Abort_Selector --
290    --------------------
291
292    procedure Abort_Selector (Selector : Selector_Type) is
293       Res : C.int;
294
295    begin
296       if not Is_Open (Selector) then
297          raise Program_Error with "closed selector";
298
299       elsif Selector.Is_Null then
300          raise Program_Error with "null selector";
301
302       end if;
303
304       --  Send one byte to unblock select system call
305
306       Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket));
307
308       if Res = Failure then
309          Raise_Socket_Error (Socket_Errno);
310       end if;
311    end Abort_Selector;
312
313    -------------------
314    -- Accept_Socket --
315    -------------------
316
317    procedure Accept_Socket
318      (Server  : Socket_Type;
319       Socket  : out Socket_Type;
320       Address : out Sock_Addr_Type)
321    is
322       Res : C.int;
323       Sin : aliased Sockaddr_In;
324       Len : aliased C.int := Sin'Size / 8;
325
326    begin
327       Res := C_Accept (C.int (Server), Sin'Address, Len'Access);
328
329       if Res = Failure then
330          Raise_Socket_Error (Socket_Errno);
331       end if;
332
333       Socket := Socket_Type (Res);
334
335       To_Inet_Addr (Sin.Sin_Addr, Address.Addr);
336       Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
337    end Accept_Socket;
338
339    -------------------
340    -- Accept_Socket --
341    -------------------
342
343    procedure Accept_Socket
344      (Server   : Socket_Type;
345       Socket   : out Socket_Type;
346       Address  : out Sock_Addr_Type;
347       Timeout  : Selector_Duration;
348       Selector : access Selector_Type := null;
349       Status   : out Selector_Status)
350    is
351    begin
352       if Selector /= null and then not Is_Open (Selector.all) then
353          raise Program_Error with "closed selector";
354       end if;
355
356       --  Wait for socket to become available for reading
357
358       Wait_On_Socket
359         (Socket    => Server,
360          For_Read  => True,
361          Timeout   => Timeout,
362          Selector  => Selector,
363          Status    => Status);
364
365       --  Accept connection if available
366
367       if Status = Completed then
368          Accept_Socket (Server, Socket, Address);
369       else
370          Socket := No_Socket;
371       end if;
372    end Accept_Socket;
373
374    ---------------
375    -- Addresses --
376    ---------------
377
378    function Addresses
379      (E : Host_Entry_Type;
380       N : Positive := 1) return Inet_Addr_Type
381    is
382    begin
383       return E.Addresses (N);
384    end Addresses;
385
386    ----------------------
387    -- Addresses_Length --
388    ----------------------
389
390    function Addresses_Length (E : Host_Entry_Type) return Natural is
391    begin
392       return E.Addresses_Length;
393    end Addresses_Length;
394
395    -------------
396    -- Aliases --
397    -------------
398
399    function Aliases
400      (E : Host_Entry_Type;
401       N : Positive := 1) return String
402    is
403    begin
404       return To_String (E.Aliases (N));
405    end Aliases;
406
407    -------------
408    -- Aliases --
409    -------------
410
411    function Aliases
412      (S : Service_Entry_Type;
413       N : Positive := 1) return String
414    is
415    begin
416       return To_String (S.Aliases (N));
417    end Aliases;
418
419    --------------------
420    -- Aliases_Length --
421    --------------------
422
423    function Aliases_Length (E : Host_Entry_Type) return Natural is
424    begin
425       return E.Aliases_Length;
426    end Aliases_Length;
427
428    --------------------
429    -- Aliases_Length --
430    --------------------
431
432    function Aliases_Length (S : Service_Entry_Type) return Natural is
433    begin
434       return S.Aliases_Length;
435    end Aliases_Length;
436
437    -----------------
438    -- Bind_Socket --
439    -----------------
440
441    procedure Bind_Socket
442      (Socket  : Socket_Type;
443       Address : Sock_Addr_Type)
444    is
445       Res : C.int;
446       Sin : aliased Sockaddr_In;
447       Len : constant C.int := Sin'Size / 8;
448       --  This assumes that Address.Family = Family_Inet???
449
450    begin
451       if Address.Family = Family_Inet6 then
452          raise Socket_Error with "IPv6 not supported";
453       end if;
454
455       Set_Family  (Sin.Sin_Family, Address.Family);
456       Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr));
457       Set_Port
458         (Sin'Unchecked_Access,
459          Short_To_Network (C.unsigned_short (Address.Port)));
460
461       Res := C_Bind (C.int (Socket), Sin'Address, Len);
462
463       if Res = Failure then
464          Raise_Socket_Error (Socket_Errno);
465       end if;
466    end Bind_Socket;
467
468    --------------------
469    -- Check_Selector --
470    --------------------
471
472    procedure Check_Selector
473      (Selector     : Selector_Type;
474       R_Socket_Set : in out Socket_Set_Type;
475       W_Socket_Set : in out Socket_Set_Type;
476       Status       : out Selector_Status;
477       Timeout      : Selector_Duration := Forever)
478    is
479       E_Socket_Set : Socket_Set_Type;
480    begin
481       Check_Selector
482         (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout);
483    end Check_Selector;
484
485    --------------------
486    -- Check_Selector --
487    --------------------
488
489    procedure Check_Selector
490      (Selector     : Selector_Type;
491       R_Socket_Set : in out Socket_Set_Type;
492       W_Socket_Set : in out Socket_Set_Type;
493       E_Socket_Set : in out Socket_Set_Type;
494       Status       : out Selector_Status;
495       Timeout      : Selector_Duration := Forever)
496    is
497       Res  : C.int;
498       Last : C.int;
499       RSig : Socket_Type := No_Socket;
500       TVal : aliased Timeval;
501       TPtr : Timeval_Access;
502
503    begin
504       if not Is_Open (Selector) then
505          raise Program_Error with "closed selector";
506       end if;
507
508       Status := Completed;
509
510       --  No timeout or Forever is indicated by a null timeval pointer
511
512       if Timeout = Forever then
513          TPtr := null;
514       else
515          TVal := To_Timeval (Timeout);
516          TPtr := TVal'Unchecked_Access;
517       end if;
518
519       --  Add read signalling socket, if present
520
521       if not Selector.Is_Null then
522          RSig := Selector.R_Sig_Socket;
523          Set (R_Socket_Set, RSig);
524       end if;
525
526       Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last),
527                                     C.int (W_Socket_Set.Last)),
528                                     C.int (E_Socket_Set.Last));
529
530       --  Zero out fd_set for empty Socket_Set_Type objects
531
532       Normalize_Empty_Socket_Set (R_Socket_Set);
533       Normalize_Empty_Socket_Set (W_Socket_Set);
534       Normalize_Empty_Socket_Set (E_Socket_Set);
535
536       Res :=
537         C_Select
538          (Last + 1,
539           R_Socket_Set.Set'Access,
540           W_Socket_Set.Set'Access,
541           E_Socket_Set.Set'Access,
542           TPtr);
543
544       if Res = Failure then
545          Raise_Socket_Error (Socket_Errno);
546       end if;
547
548       --  If Select was resumed because of read signalling socket, read this
549       --  data and remove socket from set.
550
551       if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then
552          Clear (R_Socket_Set, RSig);
553
554          Res := Signalling_Fds.Read (C.int (RSig));
555
556          if Res = Failure then
557             Raise_Socket_Error (Socket_Errno);
558          end if;
559
560          Status := Aborted;
561
562       elsif Res = 0 then
563          Status := Expired;
564       end if;
565
566       --  Update socket sets in regard to their new contents
567
568       Narrow (R_Socket_Set);
569       Narrow (W_Socket_Set);
570       Narrow (E_Socket_Set);
571    end Check_Selector;
572
573    -----------
574    -- Clear --
575    -----------
576
577    procedure Clear
578      (Item   : in out Socket_Set_Type;
579       Socket : Socket_Type)
580    is
581       Last : aliased C.int := C.int (Item.Last);
582    begin
583       if Item.Last /= No_Socket then
584          Remove_Socket_From_Set (Item.Set'Access, C.int (Socket));
585          Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
586          Item.Last := Socket_Type (Last);
587       end if;
588    end Clear;
589
590    --------------------
591    -- Close_Selector --
592    --------------------
593
594    procedure Close_Selector (Selector : in out Selector_Type) is
595    begin
596       --  Nothing to do if selector already in closed state
597
598       if Selector.Is_Null or else not Is_Open (Selector) then
599          return;
600       end if;
601
602       --  Close the signalling file descriptors used internally for the
603       --  implementation of Abort_Selector.
604
605       Signalling_Fds.Close (C.int (Selector.R_Sig_Socket));
606       Signalling_Fds.Close (C.int (Selector.W_Sig_Socket));
607
608       --  Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any
609       --  (erroneous) subsequent attempt to use this selector properly fails.
610
611       Selector.R_Sig_Socket := No_Socket;
612       Selector.W_Sig_Socket := No_Socket;
613    end Close_Selector;
614
615    ------------------
616    -- Close_Socket --
617    ------------------
618
619    procedure Close_Socket (Socket : Socket_Type) is
620       Res : C.int;
621
622    begin
623       Res := C_Close (C.int (Socket));
624
625       if Res = Failure then
626          Raise_Socket_Error (Socket_Errno);
627       end if;
628    end Close_Socket;
629
630    --------------------
631    -- Connect_Socket --
632    --------------------
633
634    procedure Connect_Socket
635      (Socket : Socket_Type;
636       Server : Sock_Addr_Type)
637    is
638       Res : C.int;
639       Sin : aliased Sockaddr_In;
640       Len : constant C.int := Sin'Size / 8;
641
642    begin
643       if Server.Family = Family_Inet6 then
644          raise Socket_Error with "IPv6 not supported";
645       end if;
646
647       Set_Family  (Sin.Sin_Family, Server.Family);
648       Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr));
649       Set_Port
650         (Sin'Unchecked_Access,
651          Short_To_Network (C.unsigned_short (Server.Port)));
652
653       Res := C_Connect (C.int (Socket), Sin'Address, Len);
654
655       if Res = Failure then
656          Raise_Socket_Error (Socket_Errno);
657       end if;
658    end Connect_Socket;
659
660    --------------------
661    -- Connect_Socket --
662    --------------------
663
664    procedure Connect_Socket
665      (Socket   : Socket_Type;
666       Server   : Sock_Addr_Type;
667       Timeout  : Selector_Duration;
668       Selector : access Selector_Type := null;
669       Status   : out Selector_Status)
670    is
671       Req : Request_Type;
672       --  Used to set Socket to non-blocking I/O
673
674    begin
675       if Selector /= null and then not Is_Open (Selector.all) then
676          raise Program_Error with "closed selector";
677       end if;
678
679       --  Set the socket to non-blocking I/O
680
681       Req := (Name => Non_Blocking_IO, Enabled => True);
682       Control_Socket (Socket, Request => Req);
683
684       --  Start operation (non-blocking), will raise Socket_Error with
685       --  EINPROGRESS.
686
687       begin
688          Connect_Socket (Socket, Server);
689       exception
690          when E : Socket_Error =>
691             if Resolve_Exception (E) = Operation_Now_In_Progress then
692                null;
693             else
694                raise;
695             end if;
696       end;
697
698       --  Wait for socket to become available for writing
699
700       Wait_On_Socket
701         (Socket    => Socket,
702          For_Read  => False,
703          Timeout   => Timeout,
704          Selector  => Selector,
705          Status    => Status);
706
707       --  Reset the socket to blocking I/O
708
709       Req := (Name => Non_Blocking_IO, Enabled => False);
710       Control_Socket (Socket, Request => Req);
711    end Connect_Socket;
712
713    --------------------
714    -- Control_Socket --
715    --------------------
716
717    procedure Control_Socket
718      (Socket  : Socket_Type;
719       Request : in out Request_Type)
720    is
721       Arg : aliased C.int;
722       Res : C.int;
723
724    begin
725       case Request.Name is
726          when Non_Blocking_IO =>
727             Arg := C.int (Boolean'Pos (Request.Enabled));
728
729          when N_Bytes_To_Read =>
730             null;
731       end case;
732
733       Res := Socket_Ioctl
734                (C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access);
735
736       if Res = Failure then
737          Raise_Socket_Error (Socket_Errno);
738       end if;
739
740       case Request.Name is
741          when Non_Blocking_IO =>
742             null;
743
744          when N_Bytes_To_Read =>
745             Request.Size := Natural (Arg);
746       end case;
747    end Control_Socket;
748
749    ----------
750    -- Copy --
751    ----------
752
753    procedure Copy
754      (Source : Socket_Set_Type;
755       Target : out Socket_Set_Type)
756    is
757    begin
758       Target := Source;
759    end Copy;
760
761    ---------------------
762    -- Create_Selector --
763    ---------------------
764
765    procedure Create_Selector (Selector : out Selector_Type) is
766       Two_Fds : aliased Fd_Pair;
767       Res     : C.int;
768
769    begin
770       if Is_Open (Selector) then
771          --  Raise exception to prevent socket descriptor leak
772
773          raise Program_Error with "selector already open";
774       end if;
775
776       --  We open two signalling file descriptors. One of them is used to send
777       --  data to the other, which is included in a C_Select socket set. The
778       --  communication is used to force a call to C_Select to complete, and
779       --  the waiting task to resume its execution.
780
781       Res := Signalling_Fds.Create (Two_Fds'Access);
782
783       if Res = Failure then
784          Raise_Socket_Error (Socket_Errno);
785       end if;
786
787       Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End));
788       Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End));
789    end Create_Selector;
790
791    -------------------
792    -- Create_Socket --
793    -------------------
794
795    procedure Create_Socket
796      (Socket : out Socket_Type;
797       Family : Family_Type := Family_Inet;
798       Mode   : Mode_Type   := Socket_Stream)
799    is
800       Res : C.int;
801
802    begin
803       Res := C_Socket (Families (Family), Modes (Mode), 0);
804
805       if Res = Failure then
806          Raise_Socket_Error (Socket_Errno);
807       end if;
808
809       Socket := Socket_Type (Res);
810    end Create_Socket;
811
812    -----------
813    -- Empty --
814    -----------
815
816    procedure Empty (Item : out Socket_Set_Type) is
817    begin
818       Reset_Socket_Set (Item.Set'Access);
819       Item.Last := No_Socket;
820    end Empty;
821
822    --------------------
823    -- Err_Code_Image --
824    --------------------
825
826    function Err_Code_Image (E : Integer) return String is
827       Msg : String := E'Img & "] ";
828    begin
829       Msg (Msg'First) := '[';
830       return Msg;
831    end Err_Code_Image;
832
833    --------------
834    -- Finalize --
835    --------------
836
837    procedure Finalize (X : in out Sockets_Library_Controller) is
838       pragma Unreferenced (X);
839
840    begin
841       --  Finalization operation for the GNAT.Sockets package
842
843       Thin.Finalize;
844    end Finalize;
845
846    --------------
847    -- Finalize --
848    --------------
849
850    procedure Finalize is
851    begin
852       --  This is a dummy placeholder for an obsolete API.
853       --  The real finalization actions are in Initialize primitive operation
854       --  of Sockets_Library_Controller.
855
856       null;
857    end Finalize;
858
859    ---------
860    -- Get --
861    ---------
862
863    procedure Get
864      (Item   : in out Socket_Set_Type;
865       Socket : out Socket_Type)
866    is
867       S : aliased C.int;
868       L : aliased C.int := C.int (Item.Last);
869
870    begin
871       if Item.Last /= No_Socket then
872          Get_Socket_From_Set
873            (Item.Set'Access, Last => L'Access, Socket => S'Access);
874          Item.Last := Socket_Type (L);
875          Socket    := Socket_Type (S);
876       else
877          Socket := No_Socket;
878       end if;
879    end Get;
880
881    -----------------
882    -- Get_Address --
883    -----------------
884
885    function Get_Address
886      (Stream : not null Stream_Access) return Sock_Addr_Type
887    is
888    begin
889       if Stream.all in Datagram_Socket_Stream_Type then
890          return Datagram_Socket_Stream_Type (Stream.all).From;
891       else
892          return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
893       end if;
894    end Get_Address;
895
896    -------------------------
897    -- Get_Host_By_Address --
898    -------------------------
899
900    function Get_Host_By_Address
901      (Address : Inet_Addr_Type;
902       Family  : Family_Type := Family_Inet) return Host_Entry_Type
903    is
904       pragma Unreferenced (Family);
905
906       HA     : aliased In_Addr := To_In_Addr (Address);
907       Buflen : constant C.int := Netdb_Buffer_Size;
908       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
909       Res    : aliased Hostent;
910       Err    : aliased C.int;
911
912    begin
913       Netdb_Lock;
914
915       if C_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET,
916                              Res'Access, Buf'Address, Buflen, Err'Access) /= 0
917       then
918          Netdb_Unlock;
919          Raise_Host_Error (Integer (Err));
920       end if;
921
922       return H : constant Host_Entry_Type :=
923                    To_Host_Entry (Res'Unchecked_Access)
924       do
925          Netdb_Unlock;
926       end return;
927    end Get_Host_By_Address;
928
929    ----------------------
930    -- Get_Host_By_Name --
931    ----------------------
932
933    function Get_Host_By_Name (Name : String) return Host_Entry_Type is
934    begin
935       --  Detect IP address name and redirect to Inet_Addr
936
937       if Is_IP_Address (Name) then
938          return Get_Host_By_Address (Inet_Addr (Name));
939       end if;
940
941       declare
942          HN     : constant C.char_array := C.To_C (Name);
943          Buflen : constant C.int := Netdb_Buffer_Size;
944          Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
945          Res    : aliased Hostent;
946          Err    : aliased C.int;
947
948       begin
949          Netdb_Lock;
950
951          if C_Gethostbyname
952            (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
953          then
954             Netdb_Unlock;
955             Raise_Host_Error (Integer (Err));
956          end if;
957
958          return H : constant Host_Entry_Type :=
959                       To_Host_Entry (Res'Unchecked_Access)
960          do
961             Netdb_Unlock;
962          end return;
963       end;
964    end Get_Host_By_Name;
965
966    -------------------
967    -- Get_Peer_Name --
968    -------------------
969
970    function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
971       Sin : aliased Sockaddr_In;
972       Len : aliased C.int := Sin'Size / 8;
973       Res : Sock_Addr_Type (Family_Inet);
974
975    begin
976       if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
977          Raise_Socket_Error (Socket_Errno);
978       end if;
979
980       To_Inet_Addr (Sin.Sin_Addr, Res.Addr);
981       Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
982
983       return Res;
984    end Get_Peer_Name;
985
986    -------------------------
987    -- Get_Service_By_Name --
988    -------------------------
989
990    function Get_Service_By_Name
991      (Name     : String;
992       Protocol : String) return Service_Entry_Type
993    is
994       SN     : constant C.char_array := C.To_C (Name);
995       SP     : constant C.char_array := C.To_C (Protocol);
996       Buflen : constant C.int := Netdb_Buffer_Size;
997       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
998       Res    : aliased Servent;
999
1000    begin
1001       Netdb_Lock;
1002
1003       if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
1004          Netdb_Unlock;
1005          raise Service_Error with "Service not found";
1006       end if;
1007
1008       --  Translate from the C format to the API format
1009
1010       return S : constant Service_Entry_Type :=
1011                    To_Service_Entry (Res'Unchecked_Access)
1012       do
1013          Netdb_Unlock;
1014       end return;
1015    end Get_Service_By_Name;
1016
1017    -------------------------
1018    -- Get_Service_By_Port --
1019    -------------------------
1020
1021    function Get_Service_By_Port
1022      (Port     : Port_Type;
1023       Protocol : String) return Service_Entry_Type
1024    is
1025       SP     : constant C.char_array := C.To_C (Protocol);
1026       Buflen : constant C.int := Netdb_Buffer_Size;
1027       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
1028       Res    : aliased Servent;
1029
1030    begin
1031       Netdb_Lock;
1032
1033       if C_Getservbyport
1034         (C.int (Short_To_Network (C.unsigned_short (Port))), SP,
1035          Res'Access, Buf'Address, Buflen) /= 0
1036       then
1037          Netdb_Unlock;
1038          raise Service_Error with "Service not found";
1039       end if;
1040
1041       --  Translate from the C format to the API format
1042
1043       return S : constant Service_Entry_Type :=
1044                    To_Service_Entry (Res'Unchecked_Access)
1045       do
1046          Netdb_Unlock;
1047       end return;
1048    end Get_Service_By_Port;
1049
1050    ---------------------
1051    -- Get_Socket_Name --
1052    ---------------------
1053
1054    function Get_Socket_Name
1055      (Socket : Socket_Type) return Sock_Addr_Type
1056    is
1057       Sin  : aliased Sockaddr_In;
1058       Len  : aliased C.int := Sin'Size / 8;
1059       Res  : C.int;
1060       Addr : Sock_Addr_Type := No_Sock_Addr;
1061
1062    begin
1063       Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
1064
1065       if Res /= Failure then
1066          To_Inet_Addr (Sin.Sin_Addr, Addr.Addr);
1067          Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1068       end if;
1069
1070       return Addr;
1071    end Get_Socket_Name;
1072
1073    -----------------------
1074    -- Get_Socket_Option --
1075    -----------------------
1076
1077    function Get_Socket_Option
1078      (Socket : Socket_Type;
1079       Level  : Level_Type := Socket_Level;
1080       Name   : Option_Name) return Option_Type
1081    is
1082       use type C.unsigned_char;
1083
1084       V8  : aliased Two_Ints;
1085       V4  : aliased C.int;
1086       V1  : aliased C.unsigned_char;
1087       VT  : aliased Timeval;
1088       Len : aliased C.int;
1089       Add : System.Address;
1090       Res : C.int;
1091       Opt : Option_Type (Name);
1092
1093    begin
1094       case Name is
1095          when Multicast_Loop      |
1096               Multicast_TTL       |
1097               Receive_Packet_Info =>
1098             Len := V1'Size / 8;
1099             Add := V1'Address;
1100
1101          when Keep_Alive      |
1102               Reuse_Address   |
1103               Broadcast       |
1104               No_Delay        |
1105               Send_Buffer     |
1106               Receive_Buffer  |
1107               Multicast_If    |
1108               Error           =>
1109             Len := V4'Size / 8;
1110             Add := V4'Address;
1111
1112          when Send_Timeout    |
1113               Receive_Timeout =>
1114             Len := VT'Size / 8;
1115             Add := VT'Address;
1116
1117          when Linger          |
1118               Add_Membership  |
1119               Drop_Membership =>
1120             Len := V8'Size / 8;
1121             Add := V8'Address;
1122
1123       end case;
1124
1125       Res :=
1126         C_Getsockopt
1127           (C.int (Socket),
1128            Levels (Level),
1129            Options (Name),
1130            Add, Len'Access);
1131
1132       if Res = Failure then
1133          Raise_Socket_Error (Socket_Errno);
1134       end if;
1135
1136       case Name is
1137          when Keep_Alive      |
1138               Reuse_Address   |
1139               Broadcast       |
1140               No_Delay        =>
1141             Opt.Enabled := (V4 /= 0);
1142
1143          when Linger          =>
1144             Opt.Enabled := (V8 (V8'First) /= 0);
1145             Opt.Seconds := Natural (V8 (V8'Last));
1146
1147          when Send_Buffer     |
1148               Receive_Buffer  =>
1149             Opt.Size := Natural (V4);
1150
1151          when Error           =>
1152             Opt.Error := Resolve_Error (Integer (V4));
1153
1154          when Add_Membership  |
1155               Drop_Membership =>
1156             To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address);
1157             To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface);
1158
1159          when Multicast_If    =>
1160             To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
1161
1162          when Multicast_TTL   =>
1163             Opt.Time_To_Live := Integer (V1);
1164
1165          when Multicast_Loop      |
1166               Receive_Packet_Info =>
1167             Opt.Enabled := (V1 /= 0);
1168
1169          when Send_Timeout    |
1170               Receive_Timeout =>
1171             Opt.Timeout := To_Duration (VT);
1172       end case;
1173
1174       return Opt;
1175    end Get_Socket_Option;
1176
1177    ---------------
1178    -- Host_Name --
1179    ---------------
1180
1181    function Host_Name return String is
1182       Name : aliased C.char_array (1 .. 64);
1183       Res  : C.int;
1184
1185    begin
1186       Res := C_Gethostname (Name'Address, Name'Length);
1187
1188       if Res = Failure then
1189          Raise_Socket_Error (Socket_Errno);
1190       end if;
1191
1192       return C.To_Ada (Name);
1193    end Host_Name;
1194
1195    -----------
1196    -- Image --
1197    -----------
1198
1199    function Image
1200      (Val : Inet_Addr_VN_Type;
1201       Hex : Boolean := False) return String
1202    is
1203       --  The largest Inet_Addr_Comp_Type image occurs with IPv4. It
1204       --  has at most a length of 3 plus one '.' character.
1205
1206       Buffer    : String (1 .. 4 * Val'Length);
1207       Length    : Natural := 1;
1208       Separator : Character;
1209
1210       procedure Img10 (V : Inet_Addr_Comp_Type);
1211       --  Append to Buffer image of V in decimal format
1212
1213       procedure Img16 (V : Inet_Addr_Comp_Type);
1214       --  Append to Buffer image of V in hexadecimal format
1215
1216       -----------
1217       -- Img10 --
1218       -----------
1219
1220       procedure Img10 (V : Inet_Addr_Comp_Type) is
1221          Img : constant String := V'Img;
1222          Len : constant Natural := Img'Length - 1;
1223       begin
1224          Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last);
1225          Length := Length + Len;
1226       end Img10;
1227
1228       -----------
1229       -- Img16 --
1230       -----------
1231
1232       procedure Img16 (V : Inet_Addr_Comp_Type) is
1233       begin
1234          Buffer (Length)     := Hex_To_Char (Natural (V / 16) + 1);
1235          Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1);
1236          Length := Length + 2;
1237       end Img16;
1238
1239    --  Start of processing for Image
1240
1241    begin
1242       Separator := (if Hex then ':' else '.');
1243
1244       for J in Val'Range loop
1245          if Hex then
1246             Img16 (Val (J));
1247          else
1248             Img10 (Val (J));
1249          end if;
1250
1251          if J /= Val'Last then
1252             Buffer (Length) := Separator;
1253             Length := Length + 1;
1254          end if;
1255       end loop;
1256
1257       return Buffer (1 .. Length - 1);
1258    end Image;
1259
1260    -----------
1261    -- Image --
1262    -----------
1263
1264    function Image (Value : Inet_Addr_Type) return String is
1265    begin
1266       if Value.Family = Family_Inet then
1267          return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False);
1268       else
1269          return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True);
1270       end if;
1271    end Image;
1272
1273    -----------
1274    -- Image --
1275    -----------
1276
1277    function Image (Value : Sock_Addr_Type) return String is
1278       Port : constant String := Value.Port'Img;
1279    begin
1280       return Image (Value.Addr) & ':' & Port (2 .. Port'Last);
1281    end Image;
1282
1283    -----------
1284    -- Image --
1285    -----------
1286
1287    function Image (Socket : Socket_Type) return String is
1288    begin
1289       return Socket'Img;
1290    end Image;
1291
1292    -----------
1293    -- Image --
1294    -----------
1295
1296    function Image (Item : Socket_Set_Type) return String is
1297       Socket_Set : Socket_Set_Type := Item;
1298
1299    begin
1300       declare
1301          Last_Img : constant String := Socket_Set.Last'Img;
1302          Buffer   : String
1303                       (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length);
1304          Index    : Positive := 1;
1305          Socket   : Socket_Type;
1306
1307       begin
1308          while not Is_Empty (Socket_Set) loop
1309             Get (Socket_Set, Socket);
1310
1311             declare
1312                Socket_Img : constant String := Socket'Img;
1313             begin
1314                Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img;
1315                Index := Index + Socket_Img'Length;
1316             end;
1317          end loop;
1318
1319          return "[" & Last_Img & "]" & Buffer (1 .. Index - 1);
1320       end;
1321    end Image;
1322
1323    ---------------
1324    -- Inet_Addr --
1325    ---------------
1326
1327    function Inet_Addr (Image : String) return Inet_Addr_Type is
1328       use Interfaces.C;
1329       use Interfaces.C.Strings;
1330
1331       Img    : aliased char_array := To_C (Image);
1332       Addr   : aliased C.int;
1333       Res    : C.int;
1334       Result : Inet_Addr_Type;
1335
1336    begin
1337       --  Special case for an empty Image as on some platforms (e.g. Windows)
1338       --  calling Inet_Addr("") will not return an error.
1339
1340       if Image = "" then
1341          Raise_Socket_Error (SOSC.EINVAL);
1342       end if;
1343
1344       Res := Inet_Pton (SOSC.AF_INET, Img'Address, Addr'Address);
1345
1346       if Res < 0 then
1347          Raise_Socket_Error (Socket_Errno);
1348
1349       elsif Res = 0 then
1350          Raise_Socket_Error (SOSC.EINVAL);
1351       end if;
1352
1353       To_Inet_Addr (To_In_Addr (Addr), Result);
1354       return Result;
1355    end Inet_Addr;
1356
1357    ----------------
1358    -- Initialize --
1359    ----------------
1360
1361    procedure Initialize (X : in out Sockets_Library_Controller) is
1362       pragma Unreferenced (X);
1363
1364    begin
1365       Thin.Initialize;
1366    end Initialize;
1367
1368    ----------------
1369    -- Initialize --
1370    ----------------
1371
1372    procedure Initialize (Process_Blocking_IO : Boolean) is
1373       Expected : constant Boolean := not SOSC.Thread_Blocking_IO;
1374
1375    begin
1376       if Process_Blocking_IO /= Expected then
1377          raise Socket_Error with
1378            "incorrect Process_Blocking_IO setting, expected " & Expected'Img;
1379       end if;
1380
1381       --  This is a dummy placeholder for an obsolete API
1382
1383       --  Real initialization actions are in Initialize primitive operation
1384       --  of Sockets_Library_Controller.
1385
1386       null;
1387    end Initialize;
1388
1389    ----------------
1390    -- Initialize --
1391    ----------------
1392
1393    procedure Initialize is
1394    begin
1395       --  This is a dummy placeholder for an obsolete API
1396
1397       --  Real initialization actions are in Initialize primitive operation
1398       --  of Sockets_Library_Controller.
1399
1400       null;
1401    end Initialize;
1402
1403    --------------
1404    -- Is_Empty --
1405    --------------
1406
1407    function Is_Empty (Item : Socket_Set_Type) return Boolean is
1408    begin
1409       return Item.Last = No_Socket;
1410    end Is_Empty;
1411
1412    -------------------
1413    -- Is_IP_Address --
1414    -------------------
1415
1416    function Is_IP_Address (Name : String) return Boolean is
1417    begin
1418       for J in Name'Range loop
1419          if Name (J) /= '.'
1420            and then Name (J) not in '0' .. '9'
1421          then
1422             return False;
1423          end if;
1424       end loop;
1425
1426       return True;
1427    end Is_IP_Address;
1428
1429    -------------
1430    -- Is_Open --
1431    -------------
1432
1433    function Is_Open (S : Selector_Type) return Boolean is
1434    begin
1435       if S.Is_Null then
1436          return True;
1437
1438       else
1439          --  Either both controlling socket descriptors are valid (case of an
1440          --  open selector) or neither (case of a closed selector).
1441
1442          pragma Assert ((S.R_Sig_Socket /= No_Socket)
1443                           =
1444                         (S.W_Sig_Socket /= No_Socket));
1445
1446          return S.R_Sig_Socket /= No_Socket;
1447       end if;
1448    end Is_Open;
1449
1450    ------------
1451    -- Is_Set --
1452    ------------
1453
1454    function Is_Set
1455      (Item   : Socket_Set_Type;
1456       Socket : Socket_Type) return Boolean
1457    is
1458    begin
1459       return Item.Last /= No_Socket
1460         and then Socket <= Item.Last
1461         and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0;
1462    end Is_Set;
1463
1464    -------------------
1465    -- Listen_Socket --
1466    -------------------
1467
1468    procedure Listen_Socket
1469      (Socket : Socket_Type;
1470       Length : Natural := 15)
1471    is
1472       Res : constant C.int := C_Listen (C.int (Socket), C.int (Length));
1473    begin
1474       if Res = Failure then
1475          Raise_Socket_Error (Socket_Errno);
1476       end if;
1477    end Listen_Socket;
1478
1479    ------------
1480    -- Narrow --
1481    ------------
1482
1483    procedure Narrow (Item : in out Socket_Set_Type) is
1484       Last : aliased C.int := C.int (Item.Last);
1485    begin
1486       if Item.Last /= No_Socket then
1487          Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
1488          Item.Last := Socket_Type (Last);
1489       end if;
1490    end Narrow;
1491
1492    ----------------
1493    -- Netdb_Lock --
1494    ----------------
1495
1496    procedure Netdb_Lock is
1497    begin
1498       if Need_Netdb_Lock then
1499          System.Task_Lock.Lock;
1500       end if;
1501    end Netdb_Lock;
1502
1503    ------------------
1504    -- Netdb_Unlock --
1505    ------------------
1506
1507    procedure Netdb_Unlock is
1508    begin
1509       if Need_Netdb_Lock then
1510          System.Task_Lock.Unlock;
1511       end if;
1512    end Netdb_Unlock;
1513
1514    --------------------------------
1515    -- Normalize_Empty_Socket_Set --
1516    --------------------------------
1517
1518    procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is
1519    begin
1520       if S.Last = No_Socket then
1521          Reset_Socket_Set (S.Set'Access);
1522       end if;
1523    end Normalize_Empty_Socket_Set;
1524
1525    -------------------
1526    -- Official_Name --
1527    -------------------
1528
1529    function Official_Name (E : Host_Entry_Type) return String is
1530    begin
1531       return To_String (E.Official);
1532    end Official_Name;
1533
1534    -------------------
1535    -- Official_Name --
1536    -------------------
1537
1538    function Official_Name (S : Service_Entry_Type) return String is
1539    begin
1540       return To_String (S.Official);
1541    end Official_Name;
1542
1543    --------------------
1544    -- Wait_On_Socket --
1545    --------------------
1546
1547    procedure Wait_On_Socket
1548      (Socket    : Socket_Type;
1549       For_Read  : Boolean;
1550       Timeout   : Selector_Duration;
1551       Selector  : access Selector_Type := null;
1552       Status    : out Selector_Status)
1553    is
1554       type Local_Selector_Access is access Selector_Type;
1555       for Local_Selector_Access'Storage_Size use Selector_Type'Size;
1556
1557       S : Selector_Access;
1558       --  Selector to use for waiting
1559
1560       R_Fd_Set : Socket_Set_Type;
1561       W_Fd_Set : Socket_Set_Type;
1562
1563    begin
1564       --  Create selector if not provided by the user
1565
1566       if Selector = null then
1567          declare
1568             Local_S : constant Local_Selector_Access := new Selector_Type;
1569          begin
1570             S := Local_S.all'Unchecked_Access;
1571             Create_Selector (S.all);
1572          end;
1573
1574       else
1575          S := Selector.all'Access;
1576       end if;
1577
1578       if For_Read then
1579          Set (R_Fd_Set, Socket);
1580       else
1581          Set (W_Fd_Set, Socket);
1582       end if;
1583
1584       Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout);
1585
1586       if Selector = null then
1587          Close_Selector (S.all);
1588       end if;
1589    end Wait_On_Socket;
1590
1591    -----------------
1592    -- Port_Number --
1593    -----------------
1594
1595    function Port_Number (S : Service_Entry_Type) return Port_Type is
1596    begin
1597       return S.Port;
1598    end Port_Number;
1599
1600    -------------------
1601    -- Protocol_Name --
1602    -------------------
1603
1604    function Protocol_Name (S : Service_Entry_Type) return String is
1605    begin
1606       return To_String (S.Protocol);
1607    end Protocol_Name;
1608
1609    ----------------------
1610    -- Raise_Host_Error --
1611    ----------------------
1612
1613    procedure Raise_Host_Error (H_Error : Integer) is
1614    begin
1615       raise Host_Error with
1616         Err_Code_Image (H_Error)
1617         & C.Strings.Value (Host_Error_Messages.Host_Error_Message (H_Error));
1618    end Raise_Host_Error;
1619
1620    ------------------------
1621    -- Raise_Socket_Error --
1622    ------------------------
1623
1624    procedure Raise_Socket_Error (Error : Integer) is
1625       use type C.Strings.chars_ptr;
1626    begin
1627       raise Socket_Error with
1628         Err_Code_Image (Error)
1629         & C.Strings.Value (Socket_Error_Message (Error));
1630    end Raise_Socket_Error;
1631
1632    ----------
1633    -- Read --
1634    ----------
1635
1636    procedure Read
1637      (Stream : in out Datagram_Socket_Stream_Type;
1638       Item   : out Ada.Streams.Stream_Element_Array;
1639       Last   : out Ada.Streams.Stream_Element_Offset)
1640    is
1641       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1642       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1643       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1644
1645    begin
1646       loop
1647          Receive_Socket
1648            (Stream.Socket,
1649             Item (First .. Max),
1650             Index,
1651             Stream.From);
1652
1653          Last := Index;
1654
1655          --  Exit when all or zero data received. Zero means that the socket
1656          --  peer is closed.
1657
1658          exit when Index < First or else Index = Max;
1659
1660          First := Index + 1;
1661       end loop;
1662    end Read;
1663
1664    ----------
1665    -- Read --
1666    ----------
1667
1668    procedure Read
1669      (Stream : in out Stream_Socket_Stream_Type;
1670       Item   : out Ada.Streams.Stream_Element_Array;
1671       Last   : out Ada.Streams.Stream_Element_Offset)
1672    is
1673       pragma Warnings (Off, Stream);
1674
1675       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1676       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1677       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1678
1679    begin
1680       loop
1681          Receive_Socket (Stream.Socket, Item (First .. Max), Index);
1682          Last  := Index;
1683
1684          --  Exit when all or zero data received. Zero means that the socket
1685          --  peer is closed.
1686
1687          exit when Index < First or else Index = Max;
1688
1689          First := Index + 1;
1690       end loop;
1691    end Read;
1692
1693    --------------------
1694    -- Receive_Socket --
1695    --------------------
1696
1697    procedure Receive_Socket
1698      (Socket : Socket_Type;
1699       Item   : out Ada.Streams.Stream_Element_Array;
1700       Last   : out Ada.Streams.Stream_Element_Offset;
1701       Flags  : Request_Flag_Type := No_Request_Flag)
1702    is
1703       Res : C.int;
1704
1705    begin
1706       Res :=
1707         C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
1708
1709       if Res = Failure then
1710          Raise_Socket_Error (Socket_Errno);
1711       end if;
1712
1713       Last := Last_Index (First => Item'First, Count => size_t (Res));
1714    end Receive_Socket;
1715
1716    --------------------
1717    -- Receive_Socket --
1718    --------------------
1719
1720    procedure Receive_Socket
1721      (Socket : Socket_Type;
1722       Item   : out Ada.Streams.Stream_Element_Array;
1723       Last   : out Ada.Streams.Stream_Element_Offset;
1724       From   : out Sock_Addr_Type;
1725       Flags  : Request_Flag_Type := No_Request_Flag)
1726    is
1727       Res : C.int;
1728       Sin : aliased Sockaddr_In;
1729       Len : aliased C.int := Sin'Size / 8;
1730
1731    begin
1732       Res :=
1733         C_Recvfrom
1734           (C.int (Socket),
1735            Item'Address,
1736            Item'Length,
1737            To_Int (Flags),
1738            Sin'Address,
1739            Len'Access);
1740
1741       if Res = Failure then
1742          Raise_Socket_Error (Socket_Errno);
1743       end if;
1744
1745       Last := Last_Index (First => Item'First, Count => size_t (Res));
1746
1747       To_Inet_Addr (Sin.Sin_Addr, From.Addr);
1748       From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1749    end Receive_Socket;
1750
1751    --------------------
1752    -- Receive_Vector --
1753    --------------------
1754
1755    procedure Receive_Vector
1756      (Socket : Socket_Type;
1757       Vector : Vector_Type;
1758       Count  : out Ada.Streams.Stream_Element_Count;
1759       Flags  : Request_Flag_Type := No_Request_Flag)
1760    is
1761       Res : ssize_t;
1762
1763       Msg : Msghdr :=
1764               (Msg_Name       => System.Null_Address,
1765                Msg_Namelen    => 0,
1766                Msg_Iov        => Vector'Address,
1767
1768                --  recvmsg(2) returns EMSGSIZE on Linux (and probably on other
1769                --  platforms) when the supplied vector is longer than IOV_MAX,
1770                --  so use minimum of the two lengths.
1771
1772                Msg_Iovlen     => SOSC.Msg_Iovlen_T'Min
1773                                    (Vector'Length, SOSC.IOV_MAX),
1774
1775                Msg_Control    => System.Null_Address,
1776                Msg_Controllen => 0,
1777                Msg_Flags      => 0);
1778
1779    begin
1780       Res :=
1781         C_Recvmsg
1782           (C.int (Socket),
1783            Msg'Address,
1784            To_Int (Flags));
1785
1786       if Res = ssize_t (Failure) then
1787          Raise_Socket_Error (Socket_Errno);
1788       end if;
1789
1790       Count := Ada.Streams.Stream_Element_Count (Res);
1791    end Receive_Vector;
1792
1793    -------------------
1794    -- Resolve_Error --
1795    -------------------
1796
1797    function Resolve_Error
1798      (Error_Value : Integer;
1799       From_Errno  : Boolean := True) return Error_Type
1800    is
1801       use GNAT.Sockets.SOSC;
1802
1803    begin
1804       if not From_Errno then
1805          case Error_Value is
1806             when SOSC.HOST_NOT_FOUND => return Unknown_Host;
1807             when SOSC.TRY_AGAIN      => return Host_Name_Lookup_Failure;
1808             when SOSC.NO_RECOVERY    => return Non_Recoverable_Error;
1809             when SOSC.NO_DATA        => return Unknown_Server_Error;
1810             when others              => return Cannot_Resolve_Error;
1811          end case;
1812       end if;
1813
1814       --  Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
1815       --  can't include it in the case statement below.
1816
1817       pragma Warnings (Off);
1818       --  Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
1819
1820       if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then
1821          return Resource_Temporarily_Unavailable;
1822       end if;
1823
1824       pragma Warnings (On);
1825
1826       --  This is not a case statement because if a particular error
1827       --  number constant is not defined, s-oscons-tmplt.c defines
1828       --  it to -1.  If multiple constants are not defined, they
1829       --  would each be -1 and result in a "duplicate value in case" error.
1830       if Error_Value = ENOERROR then
1831          return Success;
1832       elsif Error_Value = EACCES then
1833          return Permission_Denied;
1834       elsif Error_Value = EADDRINUSE then
1835          return Address_Already_In_Use;
1836       elsif Error_Value = EADDRNOTAVAIL then
1837          return Cannot_Assign_Requested_Address;
1838       elsif Error_Value = EAFNOSUPPORT then
1839          return Address_Family_Not_Supported_By_Protocol;
1840       elsif Error_Value = EALREADY then
1841          return Operation_Already_In_Progress;
1842       elsif Error_Value = EBADF then
1843          return Bad_File_Descriptor;
1844       elsif Error_Value = ECONNABORTED then
1845          return Software_Caused_Connection_Abort;
1846       elsif Error_Value = ECONNREFUSED then
1847          return Connection_Refused;
1848       elsif Error_Value = ECONNRESET then
1849          return Connection_Reset_By_Peer;
1850       elsif Error_Value = EDESTADDRREQ then
1851          return Destination_Address_Required;
1852       elsif Error_Value = EFAULT then
1853          return Bad_Address;
1854       elsif Error_Value = EHOSTDOWN then
1855          return Host_Is_Down;
1856       elsif Error_Value = EHOSTUNREACH then
1857          return No_Route_To_Host;
1858       elsif Error_Value = EINPROGRESS then
1859          return Operation_Now_In_Progress;
1860       elsif Error_Value = EINTR then
1861          return Interrupted_System_Call;
1862       elsif Error_Value = EINVAL then
1863          return Invalid_Argument;
1864       elsif Error_Value = EIO then
1865          return Input_Output_Error;
1866       elsif Error_Value = EISCONN then
1867          return Transport_Endpoint_Already_Connected;
1868       elsif Error_Value = ELOOP then
1869          return Too_Many_Symbolic_Links;
1870       elsif Error_Value = EMFILE then
1871          return Too_Many_Open_Files;
1872       elsif Error_Value = EMSGSIZE then
1873          return Message_Too_Long;
1874       elsif Error_Value = ENAMETOOLONG then
1875          return File_Name_Too_Long;
1876       elsif Error_Value = ENETDOWN then
1877          return Network_Is_Down;
1878       elsif Error_Value = ENETRESET then
1879          return Network_Dropped_Connection_Because_Of_Reset;
1880       elsif Error_Value = ENETUNREACH then
1881          return Network_Is_Unreachable;
1882       elsif Error_Value = ENOBUFS then
1883          return No_Buffer_Space_Available;
1884       elsif Error_Value = ENOPROTOOPT then
1885          return Protocol_Not_Available;
1886       elsif Error_Value = ENOTCONN then
1887          return Transport_Endpoint_Not_Connected;
1888       elsif Error_Value = ENOTSOCK then
1889          return Socket_Operation_On_Non_Socket;
1890       elsif Error_Value = EOPNOTSUPP then
1891          return Operation_Not_Supported;
1892       elsif Error_Value = EPFNOSUPPORT then
1893          return Protocol_Family_Not_Supported;
1894       elsif Error_Value = EPIPE then
1895          return Broken_Pipe;
1896       elsif Error_Value = EPROTONOSUPPORT then
1897          return Protocol_Not_Supported;
1898       elsif Error_Value = EPROTOTYPE then
1899          return Protocol_Wrong_Type_For_Socket;
1900       elsif Error_Value = ESHUTDOWN then
1901          return Cannot_Send_After_Transport_Endpoint_Shutdown;
1902       elsif Error_Value = ESOCKTNOSUPPORT then
1903          return Socket_Type_Not_Supported;
1904       elsif Error_Value = ETIMEDOUT then
1905          return Connection_Timed_Out;
1906       elsif Error_Value = ETOOMANYREFS then
1907          return Too_Many_References;
1908       elsif Error_Value = EWOULDBLOCK then
1909          return Resource_Temporarily_Unavailable;
1910       else
1911          return Cannot_Resolve_Error;
1912       end if;
1913    end Resolve_Error;
1914
1915    -----------------------
1916    -- Resolve_Exception --
1917    -----------------------
1918
1919    function Resolve_Exception
1920      (Occurrence : Exception_Occurrence) return Error_Type
1921    is
1922       Id    : constant Exception_Id := Exception_Identity (Occurrence);
1923       Msg   : constant String       := Exception_Message (Occurrence);
1924       First : Natural;
1925       Last  : Natural;
1926       Val   : Integer;
1927
1928    begin
1929       First := Msg'First;
1930       while First <= Msg'Last
1931         and then Msg (First) not in '0' .. '9'
1932       loop
1933          First := First + 1;
1934       end loop;
1935
1936       if First > Msg'Last then
1937          return Cannot_Resolve_Error;
1938       end if;
1939
1940       Last := First;
1941       while Last < Msg'Last
1942         and then Msg (Last + 1) in '0' .. '9'
1943       loop
1944          Last := Last + 1;
1945       end loop;
1946
1947       Val := Integer'Value (Msg (First .. Last));
1948
1949       if Id = Socket_Error_Id then
1950          return Resolve_Error (Val);
1951
1952       elsif Id = Host_Error_Id then
1953          return Resolve_Error (Val, False);
1954
1955       else
1956          return Cannot_Resolve_Error;
1957       end if;
1958    end Resolve_Exception;
1959
1960    -----------------
1961    -- Send_Socket --
1962    -----------------
1963
1964    procedure Send_Socket
1965      (Socket : Socket_Type;
1966       Item   : Ada.Streams.Stream_Element_Array;
1967       Last   : out Ada.Streams.Stream_Element_Offset;
1968       Flags  : Request_Flag_Type := No_Request_Flag)
1969    is
1970    begin
1971       Send_Socket (Socket, Item, Last, To => null, Flags => Flags);
1972    end Send_Socket;
1973
1974    -----------------
1975    -- Send_Socket --
1976    -----------------
1977
1978    procedure Send_Socket
1979      (Socket : Socket_Type;
1980       Item   : Ada.Streams.Stream_Element_Array;
1981       Last   : out Ada.Streams.Stream_Element_Offset;
1982       To     : Sock_Addr_Type;
1983       Flags  : Request_Flag_Type := No_Request_Flag)
1984    is
1985    begin
1986       Send_Socket
1987         (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags);
1988    end Send_Socket;
1989
1990    -----------------
1991    -- Send_Socket --
1992    -----------------
1993
1994    procedure Send_Socket
1995      (Socket : Socket_Type;
1996       Item   : Ada.Streams.Stream_Element_Array;
1997       Last   : out Ada.Streams.Stream_Element_Offset;
1998       To     : access Sock_Addr_Type;
1999       Flags  : Request_Flag_Type := No_Request_Flag)
2000    is
2001       Res  : C.int;
2002
2003       Sin  : aliased Sockaddr_In;
2004       C_To : System.Address;
2005       Len  : C.int;
2006
2007    begin
2008       if To /= null then
2009          Set_Family  (Sin.Sin_Family, To.Family);
2010          Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
2011          Set_Port
2012            (Sin'Unchecked_Access,
2013             Short_To_Network (C.unsigned_short (To.Port)));
2014          C_To := Sin'Address;
2015          Len := Sin'Size / 8;
2016
2017       else
2018          C_To := System.Null_Address;
2019          Len := 0;
2020       end if;
2021
2022       Res := C_Sendto
2023         (C.int (Socket),
2024          Item'Address,
2025          Item'Length,
2026          Set_Forced_Flags (To_Int (Flags)),
2027          C_To,
2028          Len);
2029
2030       if Res = Failure then
2031          Raise_Socket_Error (Socket_Errno);
2032       end if;
2033
2034       Last := Last_Index (First => Item'First, Count => size_t (Res));
2035    end Send_Socket;
2036
2037    -----------------
2038    -- Send_Vector --
2039    -----------------
2040
2041    procedure Send_Vector
2042      (Socket : Socket_Type;
2043       Vector : Vector_Type;
2044       Count  : out Ada.Streams.Stream_Element_Count;
2045       Flags  : Request_Flag_Type := No_Request_Flag)
2046    is
2047       use SOSC;
2048       use Interfaces.C;
2049
2050       Res            : ssize_t;
2051       Iov_Count      : SOSC.Msg_Iovlen_T;
2052       This_Iov_Count : SOSC.Msg_Iovlen_T;
2053       Msg            : Msghdr;
2054
2055    begin
2056       Count := 0;
2057       Iov_Count := 0;
2058       while Iov_Count < Vector'Length loop
2059
2060          pragma Warnings (Off);
2061          --  Following test may be compile time known on some targets
2062
2063          This_Iov_Count :=
2064            (if Vector'Length - Iov_Count > SOSC.IOV_MAX
2065             then SOSC.IOV_MAX
2066             else Vector'Length - Iov_Count);
2067
2068          pragma Warnings (On);
2069
2070          Msg :=
2071            (Msg_Name       => System.Null_Address,
2072             Msg_Namelen    => 0,
2073             Msg_Iov        => Vector
2074                                 (Vector'First + Integer (Iov_Count))'Address,
2075             Msg_Iovlen     => This_Iov_Count,
2076             Msg_Control    => System.Null_Address,
2077             Msg_Controllen => 0,
2078             Msg_Flags      => 0);
2079
2080          Res :=
2081            C_Sendmsg
2082              (C.int (Socket),
2083               Msg'Address,
2084               Set_Forced_Flags (To_Int (Flags)));
2085
2086          if Res = ssize_t (Failure) then
2087             Raise_Socket_Error (Socket_Errno);
2088          end if;
2089
2090          Count := Count + Ada.Streams.Stream_Element_Count (Res);
2091          Iov_Count := Iov_Count + This_Iov_Count;
2092       end loop;
2093    end Send_Vector;
2094
2095    ---------
2096    -- Set --
2097    ---------
2098
2099    procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
2100    begin
2101       if Item.Last = No_Socket then
2102
2103          --  Uninitialized socket set, make sure it is properly zeroed out
2104
2105          Reset_Socket_Set (Item.Set'Access);
2106          Item.Last := Socket;
2107
2108       elsif Item.Last < Socket then
2109          Item.Last := Socket;
2110       end if;
2111
2112       Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
2113    end Set;
2114
2115    ----------------------
2116    -- Set_Forced_Flags --
2117    ----------------------
2118
2119    function Set_Forced_Flags (F : C.int) return C.int is
2120       use type C.unsigned;
2121       function To_unsigned is
2122         new Ada.Unchecked_Conversion (C.int, C.unsigned);
2123       function To_int is
2124         new Ada.Unchecked_Conversion (C.unsigned, C.int);
2125    begin
2126       return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags);
2127    end Set_Forced_Flags;
2128
2129    -----------------------
2130    -- Set_Socket_Option --
2131    -----------------------
2132
2133    procedure Set_Socket_Option
2134      (Socket : Socket_Type;
2135       Level  : Level_Type := Socket_Level;
2136       Option : Option_Type)
2137    is
2138       V8  : aliased Two_Ints;
2139       V4  : aliased C.int;
2140       V1  : aliased C.unsigned_char;
2141       VT  : aliased Timeval;
2142       Len : C.int;
2143       Add : System.Address := Null_Address;
2144       Res : C.int;
2145
2146    begin
2147       case Option.Name is
2148          when Keep_Alive      |
2149               Reuse_Address   |
2150               Broadcast       |
2151               No_Delay        =>
2152             V4  := C.int (Boolean'Pos (Option.Enabled));
2153             Len := V4'Size / 8;
2154             Add := V4'Address;
2155
2156          when Linger          =>
2157             V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
2158             V8 (V8'Last)  := C.int (Option.Seconds);
2159             Len := V8'Size / 8;
2160             Add := V8'Address;
2161
2162          when Send_Buffer     |
2163               Receive_Buffer  =>
2164             V4  := C.int (Option.Size);
2165             Len := V4'Size / 8;
2166             Add := V4'Address;
2167
2168          when Error           =>
2169             V4  := C.int (Boolean'Pos (True));
2170             Len := V4'Size / 8;
2171             Add := V4'Address;
2172
2173          when Add_Membership  |
2174               Drop_Membership =>
2175             V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
2176             V8 (V8'Last)  := To_Int (To_In_Addr (Option.Local_Interface));
2177             Len := V8'Size / 8;
2178             Add := V8'Address;
2179
2180          when Multicast_If    =>
2181             V4  := To_Int (To_In_Addr (Option.Outgoing_If));
2182             Len := V4'Size / 8;
2183             Add := V4'Address;
2184
2185          when Multicast_TTL   =>
2186             V1  := C.unsigned_char (Option.Time_To_Live);
2187             Len := V1'Size / 8;
2188             Add := V1'Address;
2189
2190          when Multicast_Loop      |
2191               Receive_Packet_Info =>
2192             V1  := C.unsigned_char (Boolean'Pos (Option.Enabled));
2193             Len := V1'Size / 8;
2194             Add := V1'Address;
2195
2196          when Send_Timeout    |
2197               Receive_Timeout =>
2198             VT  := To_Timeval (Option.Timeout);
2199             Len := VT'Size / 8;
2200             Add := VT'Address;
2201
2202       end case;
2203
2204       Res := C_Setsockopt
2205         (C.int (Socket),
2206          Levels (Level),
2207          Options (Option.Name),
2208          Add, Len);
2209
2210       if Res = Failure then
2211          Raise_Socket_Error (Socket_Errno);
2212       end if;
2213    end Set_Socket_Option;
2214
2215    ----------------------
2216    -- Short_To_Network --
2217    ----------------------
2218
2219    function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
2220       use type C.unsigned_short;
2221
2222    begin
2223       --  Big-endian case. No conversion needed. On these platforms,
2224       --  htons() defaults to a null procedure.
2225
2226       pragma Warnings (Off);
2227       --  Since the test can generate "always True/False" warning
2228
2229       if Default_Bit_Order = High_Order_First then
2230          return S;
2231
2232          pragma Warnings (On);
2233
2234       --  Little-endian case. We must swap the high and low bytes of this
2235       --  short to make the port number network compliant.
2236
2237       else
2238          return (S / 256) + (S mod 256) * 256;
2239       end if;
2240    end Short_To_Network;
2241
2242    ---------------------
2243    -- Shutdown_Socket --
2244    ---------------------
2245
2246    procedure Shutdown_Socket
2247      (Socket : Socket_Type;
2248       How    : Shutmode_Type := Shut_Read_Write)
2249    is
2250       Res : C.int;
2251
2252    begin
2253       Res := C_Shutdown (C.int (Socket), Shutmodes (How));
2254
2255       if Res = Failure then
2256          Raise_Socket_Error (Socket_Errno);
2257       end if;
2258    end Shutdown_Socket;
2259
2260    ------------
2261    -- Stream --
2262    ------------
2263
2264    function Stream
2265      (Socket  : Socket_Type;
2266       Send_To : Sock_Addr_Type) return Stream_Access
2267    is
2268       S : Datagram_Socket_Stream_Access;
2269
2270    begin
2271       S        := new Datagram_Socket_Stream_Type;
2272       S.Socket := Socket;
2273       S.To     := Send_To;
2274       S.From   := Get_Socket_Name (Socket);
2275       return Stream_Access (S);
2276    end Stream;
2277
2278    ------------
2279    -- Stream --
2280    ------------
2281
2282    function Stream (Socket : Socket_Type) return Stream_Access is
2283       S : Stream_Socket_Stream_Access;
2284    begin
2285       S := new Stream_Socket_Stream_Type;
2286       S.Socket := Socket;
2287       return Stream_Access (S);
2288    end Stream;
2289
2290    ------------------
2291    -- Stream_Write --
2292    ------------------
2293
2294    procedure Stream_Write
2295      (Socket : Socket_Type;
2296       Item   : Ada.Streams.Stream_Element_Array;
2297       To     : access Sock_Addr_Type)
2298    is
2299       First : Ada.Streams.Stream_Element_Offset;
2300       Index : Ada.Streams.Stream_Element_Offset;
2301       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2302
2303    begin
2304       First := Item'First;
2305       Index := First - 1;
2306       while First <= Max loop
2307          Send_Socket (Socket, Item (First .. Max), Index, To);
2308
2309          --  Exit when all or zero data sent. Zero means that the socket has
2310          --  been closed by peer.
2311
2312          exit when Index < First or else Index = Max;
2313
2314          First := Index + 1;
2315       end loop;
2316
2317       --  For an empty array, we have First > Max, and hence Index >= Max (no
2318       --  error, the loop above is never executed). After a succesful send,
2319       --  Index = Max. The only remaining case, Index < Max, is therefore
2320       --  always an actual send failure.
2321
2322       if Index < Max then
2323          Raise_Socket_Error (Socket_Errno);
2324       end if;
2325    end Stream_Write;
2326
2327    ----------
2328    -- To_C --
2329    ----------
2330
2331    function To_C (Socket : Socket_Type) return Integer is
2332    begin
2333       return Integer (Socket);
2334    end To_C;
2335
2336    -----------------
2337    -- To_Duration --
2338    -----------------
2339
2340    function To_Duration (Val : Timeval) return Timeval_Duration is
2341    begin
2342       return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6;
2343    end To_Duration;
2344
2345    -------------------
2346    -- To_Host_Entry --
2347    -------------------
2348
2349    function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is
2350       use type C.size_t;
2351       use C.Strings;
2352
2353       Aliases_Count, Addresses_Count : Natural;
2354
2355       --  H_Length is not used because it is currently only set to 4
2356       --  H_Addrtype is always AF_INET
2357
2358    begin
2359       Aliases_Count := 0;
2360       while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2361          Aliases_Count := Aliases_Count + 1;
2362       end loop;
2363
2364       Addresses_Count := 0;
2365       while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop
2366          Addresses_Count := Addresses_Count + 1;
2367       end loop;
2368
2369       return Result : Host_Entry_Type
2370                         (Aliases_Length   => Aliases_Count,
2371                          Addresses_Length => Addresses_Count)
2372       do
2373          Result.Official := To_Name (Value (Hostent_H_Name (E)));
2374
2375          for J in Result.Aliases'Range loop
2376             Result.Aliases (J) :=
2377               To_Name (Value (Hostent_H_Alias
2378                                 (E, C.int (J - Result.Aliases'First))));
2379          end loop;
2380
2381          for J in Result.Addresses'Range loop
2382             declare
2383                Addr : In_Addr;
2384                for Addr'Address use
2385                  Hostent_H_Addr (E, C.int (J - Result.Addresses'First));
2386                pragma Import (Ada, Addr);
2387             begin
2388                To_Inet_Addr (Addr, Result.Addresses (J));
2389             end;
2390          end loop;
2391       end return;
2392    end To_Host_Entry;
2393
2394    ----------------
2395    -- To_In_Addr --
2396    ----------------
2397
2398    function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is
2399    begin
2400       if Addr.Family = Family_Inet then
2401          return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
2402                  S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
2403                  S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
2404                  S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
2405       end if;
2406
2407       raise Socket_Error with "IPv6 not supported";
2408    end To_In_Addr;
2409
2410    ------------------
2411    -- To_Inet_Addr --
2412    ------------------
2413
2414    procedure To_Inet_Addr
2415      (Addr   : In_Addr;
2416       Result : out Inet_Addr_Type) is
2417    begin
2418       Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
2419       Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
2420       Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
2421       Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
2422    end To_Inet_Addr;
2423
2424    ------------
2425    -- To_Int --
2426    ------------
2427
2428    function To_Int (F : Request_Flag_Type) return C.int
2429    is
2430       Current : Request_Flag_Type := F;
2431       Result  : C.int := 0;
2432
2433    begin
2434       for J in Flags'Range loop
2435          exit when Current = 0;
2436
2437          if Current mod 2 /= 0 then
2438             if Flags (J) = -1 then
2439                Raise_Socket_Error (SOSC.EOPNOTSUPP);
2440             end if;
2441
2442             Result := Result + Flags (J);
2443          end if;
2444
2445          Current := Current / 2;
2446       end loop;
2447
2448       return Result;
2449    end To_Int;
2450
2451    -------------
2452    -- To_Name --
2453    -------------
2454
2455    function To_Name (N : String) return Name_Type is
2456    begin
2457       return Name_Type'(N'Length, N);
2458    end To_Name;
2459
2460    ----------------------
2461    -- To_Service_Entry --
2462    ----------------------
2463
2464    function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
2465       use C.Strings;
2466       use type C.size_t;
2467
2468       Aliases_Count : Natural;
2469
2470    begin
2471       Aliases_Count := 0;
2472       while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2473          Aliases_Count := Aliases_Count + 1;
2474       end loop;
2475
2476       return Result : Service_Entry_Type (Aliases_Length   => Aliases_Count) do
2477          Result.Official := To_Name (Value (Servent_S_Name (E)));
2478
2479          for J in Result.Aliases'Range loop
2480             Result.Aliases (J) :=
2481               To_Name (Value (Servent_S_Alias
2482                                 (E, C.int (J - Result.Aliases'First))));
2483          end loop;
2484
2485          Result.Protocol := To_Name (Value (Servent_S_Proto (E)));
2486          Result.Port :=
2487            Port_Type (Network_To_Short (Servent_S_Port (E)));
2488       end return;
2489    end To_Service_Entry;
2490
2491    ---------------
2492    -- To_String --
2493    ---------------
2494
2495    function To_String (HN : Name_Type) return String is
2496    begin
2497       return HN.Name (1 .. HN.Length);
2498    end To_String;
2499
2500    ----------------
2501    -- To_Timeval --
2502    ----------------
2503
2504    function To_Timeval (Val : Timeval_Duration) return Timeval is
2505       S  : time_t;
2506       uS : suseconds_t;
2507
2508    begin
2509       --  If zero, set result as zero (otherwise it gets rounded down to -1)
2510
2511       if Val = 0.0 then
2512          S  := 0;
2513          uS := 0;
2514
2515       --  Normal case where we do round down
2516
2517       else
2518          S  := time_t (Val - 0.5);
2519          uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2520       end if;
2521
2522       return (S, uS);
2523    end To_Timeval;
2524
2525    -----------
2526    -- Value --
2527    -----------
2528
2529    function Value (S : System.Address) return String is
2530       Str : String (1 .. Positive'Last);
2531       for Str'Address use S;
2532       pragma Import (Ada, Str);
2533
2534       Terminator : Positive := Str'First;
2535
2536    begin
2537       while Str (Terminator) /= ASCII.NUL loop
2538          Terminator := Terminator + 1;
2539       end loop;
2540
2541       return Str (1 .. Terminator - 1);
2542    end Value;
2543
2544    -----------
2545    -- Write --
2546    -----------
2547
2548    procedure Write
2549      (Stream : in out Datagram_Socket_Stream_Type;
2550       Item   : Ada.Streams.Stream_Element_Array)
2551    is
2552    begin
2553       Stream_Write (Stream.Socket, Item, To => Stream.To'Unrestricted_Access);
2554    end Write;
2555
2556    -----------
2557    -- Write --
2558    -----------
2559
2560    procedure Write
2561      (Stream : in out Stream_Socket_Stream_Type;
2562       Item   : Ada.Streams.Stream_Element_Array)
2563    is
2564    begin
2565       Stream_Write (Stream.Socket, Item, To => null);
2566    end Write;
2567
2568    Sockets_Library_Controller_Object : Sockets_Library_Controller;
2569    pragma Unreferenced (Sockets_Library_Controller_Object);
2570    --  The elaboration and finalization of this object perform the required
2571    --  initialization and cleanup actions for the sockets library.
2572
2573 end GNAT.Sockets;