1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S . T H I N --
9 -- Copyright (C) 2001-2013, AdaCore --
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 3, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 -- This is the version for OpenVMS
34 with GNAT.OS_Lib; use GNAT.OS_Lib;
37 with Interfaces.C; use Interfaces.C;
39 package body GNAT.Sockets.Thin is
41 type VMS_Msghdr is new Msghdr;
42 pragma Pack (VMS_Msghdr);
43 -- On VMS 8.x (unlike other platforms), struct msghdr is packed, so a
44 -- specific derived type is required. This structure was not packed on
47 function Is_VMS_V7 return Integer;
48 pragma Import (C, Is_VMS_V7, "__gnat_is_vms_v7");
49 -- Helper (defined in init.c) that returns a non-zero value if the VMS
52 VMS_V7 : constant Boolean := Is_VMS_V7 /= 0;
53 -- True if VMS version is 7.x.
55 Non_Blocking_Sockets : aliased Fd_Set;
56 -- When this package is initialized with Process_Blocking_IO set to True,
57 -- sockets are set in non-blocking mode to avoid blocking the whole process
58 -- when a thread wants to perform a blocking IO operation. But the user can
59 -- also set a socket in non-blocking mode by purpose. In order to make a
60 -- difference between these two situations, we track the origin of
61 -- non-blocking mode in Non_Blocking_Sockets. Note that if S is in
62 -- Non_Blocking_Sockets, it has been set in non-blocking mode by the user.
64 Quantum : constant Duration := 0.2;
65 -- When SOSC.Thread_Blocking_IO is False, we set sockets to non-blocking
66 -- mode and we spend a period of time Quantum between two attempts on a
67 -- blocking operation.
69 function Syscall_Accept
71 Addr : System.Address;
72 Addrlen : not null access C.int) return C.int;
73 pragma Import (C, Syscall_Accept, "accept");
75 function Syscall_Connect
77 Name : System.Address;
78 Namelen : C.int) return C.int;
79 pragma Import (C, Syscall_Connect, "connect");
85 Flags : C.int) return C.int;
86 pragma Import (C, Syscall_Recv, "recv");
88 function Syscall_Recvfrom
93 From : System.Address;
94 Fromlen : not null access C.int) return C.int;
95 pragma Import (C, Syscall_Recvfrom, "recvfrom");
97 function Syscall_Recvmsg
100 Flags : C.int) return C.int;
101 pragma Import (C, Syscall_Recvmsg, "recvmsg");
103 function Syscall_Sendmsg
105 Msg : System.Address;
106 Flags : C.int) return C.int;
107 pragma Import (C, Syscall_Sendmsg, "sendmsg");
109 function Syscall_Sendto
111 Msg : System.Address;
115 Tolen : C.int) return C.int;
116 pragma Import (C, Syscall_Sendto, "sendto");
118 function Syscall_Socket
119 (Domain, Typ, Protocol : C.int) return C.int;
120 pragma Import (C, Syscall_Socket, "socket");
122 function Non_Blocking_Socket (S : C.int) return Boolean;
123 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
131 Addr : System.Address;
132 Addrlen : not null access C.int) return C.int
135 Val : aliased C.int := 1;
138 pragma Warnings (Off, Discard);
142 R := Syscall_Accept (S, Addr, Addrlen);
143 exit when SOSC.Thread_Blocking_IO
145 or else Non_Blocking_Socket (S)
146 or else Errno /= SOSC.EWOULDBLOCK;
150 if not SOSC.Thread_Blocking_IO
151 and then R /= Failure
153 -- A socket inherits the properties of its server, especially
154 -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
155 -- tracks sockets set in non-blocking mode by user.
157 Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
158 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
170 Name : System.Address;
171 Namelen : C.int) return C.int
176 Res := Syscall_Connect (S, Name, Namelen);
178 if SOSC.Thread_Blocking_IO
179 or else Res /= Failure
180 or else Non_Blocking_Socket (S)
181 or else Errno /= SOSC.EINPROGRESS
187 WSet : aliased Fd_Set;
188 Now : aliased Timeval;
191 Reset_Socket_Set (WSet'Access);
193 Insert_Socket_In_Set (WSet'Access, S);
200 Now'Unchecked_Access);
204 if Res = Failure then
212 Res := Syscall_Connect (S, Name, Namelen);
214 if Res = Failure and then Errno = SOSC.EISCONN then
215 return Thin_Common.Success;
225 function Socket_Ioctl
227 Req : SOSC.IOCTL_Req_T;
228 Arg : access C.int) return C.int
231 if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
233 Set_Non_Blocking_Socket (S, True);
237 return C_Ioctl (S, Req, Arg);
246 Msg : System.Address;
248 Flags : C.int) return C.int
254 Res := Syscall_Recv (S, Msg, Len, Flags);
255 exit when SOSC.Thread_Blocking_IO
256 or else Res /= Failure
257 or else Non_Blocking_Socket (S)
258 or else Errno /= SOSC.EWOULDBLOCK;
271 Msg : System.Address;
274 From : System.Address;
275 Fromlen : not null access C.int) return C.int
281 Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
282 exit when SOSC.Thread_Blocking_IO
283 or else Res /= Failure
284 or else Non_Blocking_Socket (S)
285 or else Errno /= SOSC.EWOULDBLOCK;
298 Msg : System.Address;
299 Flags : C.int) return System.CRTL.ssize_t
303 Msg_Addr : System.Address;
306 for GNAT_Msg'Address use Msg;
307 pragma Import (Ada, GNAT_Msg);
309 VMS_Msg : aliased VMS_Msghdr;
315 VMS_Msg := VMS_Msghdr (GNAT_Msg);
316 Msg_Addr := VMS_Msg'Address;
320 Res := Syscall_Recvmsg (S, Msg_Addr, Flags);
321 exit when SOSC.Thread_Blocking_IO
322 or else Res /= Failure
323 or else Non_Blocking_Socket (S)
324 or else Errno /= SOSC.EWOULDBLOCK;
329 GNAT_Msg := Msghdr (VMS_Msg);
332 return System.CRTL.ssize_t (Res);
341 Msg : System.Address;
342 Flags : C.int) return System.CRTL.ssize_t
346 Msg_Addr : System.Address;
349 for GNAT_Msg'Address use Msg;
350 pragma Import (Ada, GNAT_Msg);
352 VMS_Msg : aliased VMS_Msghdr;
358 VMS_Msg := VMS_Msghdr (GNAT_Msg);
359 Msg_Addr := VMS_Msg'Address;
363 Res := Syscall_Sendmsg (S, Msg_Addr, Flags);
364 exit when SOSC.Thread_Blocking_IO
365 or else Res /= Failure
366 or else Non_Blocking_Socket (S)
367 or else Errno /= SOSC.EWOULDBLOCK;
372 GNAT_Msg := Msghdr (VMS_Msg);
375 return System.CRTL.ssize_t (Res);
384 Msg : System.Address;
388 Tolen : C.int) return C.int
394 Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
395 exit when SOSC.Thread_Blocking_IO
396 or else Res /= Failure
397 or else Non_Blocking_Socket (S)
398 or else Errno /= SOSC.EWOULDBLOCK;
412 Protocol : C.int) return C.int
415 Val : aliased C.int := 1;
418 pragma Unreferenced (Discard);
421 R := Syscall_Socket (Domain, Typ, Protocol);
423 if not SOSC.Thread_Blocking_IO
424 and then R /= Failure
426 -- Do not use Socket_Ioctl as this subprogram tracks sockets set
427 -- in non-blocking mode by user.
429 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
430 Set_Non_Blocking_Socket (R, False);
440 procedure Finalize is
445 -------------------------
446 -- Host_Error_Messages --
447 -------------------------
449 package body Host_Error_Messages is separate;
455 procedure Initialize is
457 Reset_Socket_Set (Non_Blocking_Sockets'Access);
460 -------------------------
461 -- Non_Blocking_Socket --
462 -------------------------
464 function Non_Blocking_Socket (S : C.int) return Boolean is
468 R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
471 end Non_Blocking_Socket;
473 -----------------------------
474 -- Set_Non_Blocking_Socket --
475 -----------------------------
477 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
482 Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
484 Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
488 end Set_Non_Blocking_Socket;
494 package body Signalling_Fds is separate;
496 --------------------------
497 -- Socket_Error_Message --
498 --------------------------
500 function Socket_Error_Message (Errno : Integer) return String is separate;
502 end GNAT.Sockets.Thin;