1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S . T H I N --
9 -- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This package provides a target dependent thin interface to the sockets
35 -- layer for use by the GNAT.Sockets package (g-socket.ads). This package
36 -- should not be directly with'ed by an applications program.
38 -- This version is for VxWorks
40 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
43 with Interfaces
.C
; use Interfaces
.C
;
44 with Unchecked_Conversion
;
46 package body GNAT
.Sockets
.Thin
is
48 Non_Blocking_Sockets
: Fd_Set_Access
:= New_Socket_Set
(No_Socket_Set
);
49 -- When this package is initialized with Process_Blocking_IO set
50 -- to True, sockets are set in non-blocking mode to avoid blocking
51 -- the whole process when a thread wants to perform a blocking IO
52 -- operation. But the user can also set a socket in non-blocking
53 -- mode by purpose. In order to make a difference between these
54 -- two situations, we track the origin of non-blocking mode in
55 -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
56 -- been set in non-blocking mode by the user.
58 Quantum
: constant Duration := 0.2;
59 -- When Thread_Blocking_IO is False, we set sockets in
60 -- non-blocking mode and we spend a period of time Quantum between
61 -- two attempts on a blocking operation.
62 Thread_Blocking_IO
: Boolean := True;
64 -- The following types and variables are required to create a Hostent
67 type In_Addr_Access_Array_Access
is access In_Addr_Access_Array
;
69 Alias_Access
: Chars_Ptr_Pointers
.Pointer
:=
70 new C
.Strings
.chars_ptr
'(C.Strings.Null_Ptr);
72 In_Addr_Access_Array_A : In_Addr_Access_Array_Access :=
73 new In_Addr_Access_Array'(new In_Addr
, null);
75 In_Addr_Access_Ptr
: In_Addr_Access_Pointers
.Pointer
:=
76 In_Addr_Access_Array_A
77 (In_Addr_Access_Array_A
'First)'Access;
79 Local_Hostent
: Hostent_Access
:= new Hostent
;
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
85 -- All these require comments ???
87 function Syscall_Accept
89 Addr
: System
.Address
;
90 Addrlen
: access C
.int
)
92 pragma Import
(C
, Syscall_Accept
, "accept");
94 function Syscall_Connect
96 Name
: System
.Address
;
99 pragma Import
(C
, Syscall_Connect
, "connect");
101 function Syscall_Ioctl
106 pragma Import
(C
, Syscall_Ioctl
, "ioctl");
108 function Syscall_Recv
110 Msg
: System
.Address
;
114 pragma Import
(C
, Syscall_Recv
, "recv");
116 function Syscall_Recvfrom
118 Msg
: System
.Address
;
121 From
: Sockaddr_In_Access
;
122 Fromlen
: access C
.int
)
124 pragma Import
(C
, Syscall_Recvfrom
, "recvfrom");
126 function Syscall_Send
128 Msg
: System
.Address
;
132 pragma Import
(C
, Syscall_Send
, "send");
134 function Syscall_Sendto
136 Msg
: System
.Address
;
139 To
: Sockaddr_In_Access
;
142 pragma Import
(C
, Syscall_Sendto
, "sendto");
144 function Syscall_Socket
149 pragma Import
(C
, Syscall_Socket
, "socket");
151 function Non_Blocking_Socket
(S
: C
.int
) return Boolean;
152 procedure Set_Non_Blocking_Socket
(S
: C
.int
; V
: Boolean);
160 Addr
: System
.Address
;
161 Addrlen
: access C
.int
)
165 Val
: aliased C
.int
:= 1;
170 R
:= Syscall_Accept
(S
, Addr
, Addrlen
);
171 exit when Thread_Blocking_IO
173 or else Non_Blocking_Socket
(S
)
174 or else Errno
/= Constants
.EWOULDBLOCK
;
178 if not Thread_Blocking_IO
179 and then R
/= Failure
181 -- A socket inherits the properties ot its server especially
182 -- the FIONBIO flag. Do not use C_Ioctl as this subprogram
183 -- tracks sockets set in non-blocking mode by user.
185 Set_Non_Blocking_Socket
(R
, Non_Blocking_Socket
(S
));
186 Res
:= Syscall_Ioctl
(R
, Constants
.FIONBIO
, Val
'Unchecked_Access);
198 Name
: System
.Address
;
205 Res
:= Syscall_Connect
(S
, Name
, Namelen
);
207 if Thread_Blocking_IO
208 or else Res
/= Failure
209 or else Non_Blocking_Socket
(S
)
210 or else Errno
/= Constants
.EINPROGRESS
216 WSet
: Fd_Set_Access
;
217 Now
: aliased Timeval
;
220 WSet
:= New_Socket_Set
(No_Socket_Set
);
223 Insert_Socket_In_Set
(WSet
, S
);
230 Now
'Unchecked_Access);
234 if Res
= Failure
then
235 Free_Socket_Set
(WSet
);
242 Free_Socket_Set
(WSet
);
245 Res
:= Syscall_Connect
(S
, Name
, Namelen
);
248 and then Errno
= Constants
.EISCONN
256 ---------------------
257 -- C_Gethostbyaddr --
258 ---------------------
260 function C_Gethostbyaddr
261 (Addr
: System
.Address
;
264 return Hostent_Access
266 pragma Warnings
(Off
, Len
);
267 pragma Warnings
(Off
, Typ
);
269 type int_Access
is access int
;
270 function To_Pointer
is
271 new Unchecked_Conversion
(System
.Address
, int_Access
);
273 procedure VxWorks_Gethostbyaddr
274 (Addr
: C
.int
; Buf
: out C
.char_array
);
275 pragma Import
(C
, VxWorks_Gethostbyaddr
, "hostGetByAddr");
277 Host_Name
: C
.char_array
(1 .. Max_Name_Length
);
280 VxWorks_Gethostbyaddr
(To_Pointer
(Addr
).all, Host_Name
);
282 In_Addr_Access_Ptr
.all.all := To_In_Addr
(To_Pointer
(Addr
).all);
283 Local_Hostent
.all.H_Name
:= C
.Strings
.New_Char_Array
(Host_Name
);
285 return Local_Hostent
;
288 ---------------------
289 -- C_Gethostbyname --
290 ---------------------
292 function C_Gethostbyname
293 (Name
: C
.char_array
)
294 return Hostent_Access
296 function VxWorks_Gethostbyname
297 (Name
: C
.char_array
)
299 pragma Import
(C
, VxWorks_Gethostbyname
, "hostGetByName");
304 Addr
:= VxWorks_Gethostbyname
(Name
);
306 In_Addr_Access_Ptr
.all.all := To_In_Addr
(Addr
);
307 Local_Hostent
.all.H_Name
:= C
.Strings
.New_Char_Array
(To_C
(Host_Name
));
309 return Local_Hostent
;
312 ---------------------
313 -- C_Getservbyname --
314 ---------------------
316 function C_Getservbyname
317 (Name
: C
.char_array
;
318 Proto
: C
.char_array
)
319 return Servent_Access
321 pragma Warnings
(Off
, Name
);
322 pragma Warnings
(Off
, Proto
);
328 ---------------------
329 -- C_Getservbyport --
330 ---------------------
332 function C_Getservbyport
334 Proto
: C
.char_array
)
335 return Servent_Access
337 pragma Warnings
(Off
, Port
);
338 pragma Warnings
(Off
, Proto
);
355 if not Thread_Blocking_IO
356 and then Req
= Constants
.FIONBIO
359 Set_Non_Blocking_Socket
(S
, True);
363 return Syscall_Ioctl
(S
, Req
, Arg
);
372 Msg
: System
.Address
;
381 Res
:= Syscall_Recv
(S
, Msg
, Len
, Flags
);
382 exit when Thread_Blocking_IO
383 or else Res
/= Failure
384 or else Non_Blocking_Socket
(S
)
385 or else Errno
/= Constants
.EWOULDBLOCK
;
398 Msg
: System
.Address
;
401 From
: Sockaddr_In_Access
;
402 Fromlen
: access C
.int
)
409 Res
:= Syscall_Recvfrom
(S
, Msg
, Len
, Flags
, From
, Fromlen
);
410 exit when Thread_Blocking_IO
411 or else Res
/= Failure
412 or else Non_Blocking_Socket
(S
)
413 or else Errno
/= Constants
.EWOULDBLOCK
;
426 Msg
: System
.Address
;
435 Res
:= Syscall_Send
(S
, Msg
, Len
, Flags
);
436 exit when Thread_Blocking_IO
437 or else Res
/= Failure
438 or else Non_Blocking_Socket
(S
)
439 or else Errno
/= Constants
.EWOULDBLOCK
;
452 Msg
: System
.Address
;
455 To
: Sockaddr_In_Access
;
463 Res
:= Syscall_Sendto
(S
, Msg
, Len
, Flags
, To
, Tolen
);
464 exit when Thread_Blocking_IO
465 or else Res
/= Failure
466 or else Non_Blocking_Socket
(S
)
467 or else Errno
/= Constants
.EWOULDBLOCK
;
485 Val
: aliased C
.int
:= 1;
489 R
:= Syscall_Socket
(Domain
, Typ
, Protocol
);
491 if not Thread_Blocking_IO
492 and then R
/= Failure
494 -- Do not use C_Ioctl as this subprogram tracks sockets set
495 -- in non-blocking mode by user.
497 Res
:= Syscall_Ioctl
(R
, Constants
.FIONBIO
, Val
'Unchecked_Access);
498 Set_Non_Blocking_Socket
(R
, False);
508 procedure Finalize
is
517 procedure Initialize
(Process_Blocking_IO
: Boolean) is
519 Thread_Blocking_IO
:= not Process_Blocking_IO
;
522 -------------------------
523 -- Non_Blocking_Socket --
524 -------------------------
526 function Non_Blocking_Socket
(S
: C
.int
) return Boolean is
531 R
:= Is_Socket_In_Set
(Non_Blocking_Sockets
, S
);
534 end Non_Blocking_Socket
;
540 procedure Set_Address
541 (Sin
: Sockaddr_In_Access
;
545 Sin
.Sin_Addr
:= Address
;
553 (Sin
: Sockaddr_In_Access
;
557 Sin
.Sin_Family
:= C
.unsigned_char
(Family
);
565 (Sin
: Sockaddr_In_Access
;
569 Sin
.Sin_Length
:= C
.unsigned_char
(Len
);
572 -----------------------------
573 -- Set_Non_Blocking_Socket --
574 -----------------------------
576 procedure Set_Non_Blocking_Socket
(S
: C
.int
; V
: Boolean) is
580 Insert_Socket_In_Set
(Non_Blocking_Sockets
, S
);
582 Remove_Socket_From_Set
(Non_Blocking_Sockets
, S
);
586 end Set_Non_Blocking_Socket
;
593 (Sin
: Sockaddr_In_Access
;
594 Port
: C
.unsigned_short
)
597 Sin
.Sin_Port
:= Port
;
600 --------------------------
601 -- Socket_Error_Message --
602 --------------------------
604 function Socket_Error_Message
(Errno
: Integer) return String is
605 use type Interfaces
.C
.Strings
.chars_ptr
;
607 C_Msg
: C
.Strings
.chars_ptr
;
610 C_Msg
:= C_Strerror
(C
.int
(Errno
));
612 if C_Msg
= C
.Strings
.Null_Ptr
then
613 return "Unknown system error";
616 return C
.Strings
.Value
(C_Msg
);
618 end Socket_Error_Message
;
620 -- Package elaboration
623 Local_Hostent
.all.H_Aliases
:= Alias_Access
;
625 -- VxWorks currently only supports AF_INET
627 Local_Hostent
.all.H_Addrtype
:= Constants
.AF_INET
;
629 Local_Hostent
.all.H_Length
:= 1;
630 Local_Hostent
.all.H_Addr_List
:= In_Addr_Access_Ptr
;
632 end GNAT
.Sockets
.Thin
;