1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T . S O C K E T S . T H I N -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2013, 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 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. -- 17-- -- 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. -- 21-- -- 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/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This package provides a target dependent thin interface to the sockets 33-- layer for use by the GNAT.Sockets package (g-socket.ads). This package 34-- should not be directly with'ed by an applications program. 35 36-- This is the default version 37 38with GNAT.OS_Lib; use GNAT.OS_Lib; 39with GNAT.Task_Lock; 40 41with Interfaces.C; use Interfaces.C; 42 43package body GNAT.Sockets.Thin is 44 45 Non_Blocking_Sockets : aliased Fd_Set; 46 -- When this package is initialized with Process_Blocking_IO set 47 -- to True, sockets are set in non-blocking mode to avoid blocking 48 -- the whole process when a thread wants to perform a blocking IO 49 -- operation. But the user can also set a socket in non-blocking 50 -- mode by purpose. In order to make a difference between these 51 -- two situations, we track the origin of non-blocking mode in 52 -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has 53 -- been set in non-blocking mode by the user. 54 55 Quantum : constant Duration := 0.2; 56 -- When SOSC.Thread_Blocking_IO is False, we set sockets in 57 -- non-blocking mode and we spend a period of time Quantum between 58 -- two attempts on a blocking operation. 59 60 -- Comments required for following functions ??? 61 62 function Syscall_Accept 63 (S : C.int; 64 Addr : System.Address; 65 Addrlen : not null access C.int) return C.int; 66 pragma Import (C, Syscall_Accept, "accept"); 67 68 function Syscall_Connect 69 (S : C.int; 70 Name : System.Address; 71 Namelen : C.int) return C.int; 72 pragma Import (C, Syscall_Connect, "connect"); 73 74 function Syscall_Recv 75 (S : C.int; 76 Msg : System.Address; 77 Len : C.int; 78 Flags : C.int) return C.int; 79 pragma Import (C, Syscall_Recv, "recv"); 80 81 function Syscall_Recvfrom 82 (S : C.int; 83 Msg : System.Address; 84 Len : C.int; 85 Flags : C.int; 86 From : System.Address; 87 Fromlen : not null access C.int) return C.int; 88 pragma Import (C, Syscall_Recvfrom, "recvfrom"); 89 90 function Syscall_Recvmsg 91 (S : C.int; 92 Msg : System.Address; 93 Flags : C.int) return System.CRTL.ssize_t; 94 pragma Import (C, Syscall_Recvmsg, "recvmsg"); 95 96 function Syscall_Sendmsg 97 (S : C.int; 98 Msg : System.Address; 99 Flags : C.int) return System.CRTL.ssize_t; 100 pragma Import (C, Syscall_Sendmsg, "sendmsg"); 101 102 function Syscall_Sendto 103 (S : C.int; 104 Msg : System.Address; 105 Len : C.int; 106 Flags : C.int; 107 To : System.Address; 108 Tolen : C.int) return C.int; 109 pragma Import (C, Syscall_Sendto, "sendto"); 110 111 function Syscall_Socket 112 (Domain : C.int; 113 Typ : C.int; 114 Protocol : C.int) return C.int; 115 pragma Import (C, Syscall_Socket, "socket"); 116 117 procedure Disable_SIGPIPE (S : C.int); 118 pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe"); 119 120 procedure Disable_All_SIGPIPEs; 121 pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes"); 122 -- Sets the process to ignore all SIGPIPE signals on platforms that 123 -- don't support Disable_SIGPIPE for particular streams. 124 125 function Non_Blocking_Socket (S : C.int) return Boolean; 126 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); 127 128 -------------- 129 -- C_Accept -- 130 -------------- 131 132 function C_Accept 133 (S : C.int; 134 Addr : System.Address; 135 Addrlen : not null access C.int) return C.int 136 is 137 R : C.int; 138 Val : aliased C.int := 1; 139 140 Discard : C.int; 141 pragma Warnings (Off, Discard); 142 143 begin 144 loop 145 R := Syscall_Accept (S, Addr, Addrlen); 146 exit when SOSC.Thread_Blocking_IO 147 or else R /= Failure 148 or else Non_Blocking_Socket (S) 149 or else Errno /= SOSC.EWOULDBLOCK; 150 delay Quantum; 151 end loop; 152 153 if not SOSC.Thread_Blocking_IO 154 and then R /= Failure 155 then 156 -- A socket inherits the properties ot its server especially 157 -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram 158 -- tracks sockets set in non-blocking mode by user. 159 160 Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); 161 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); 162 end if; 163 164 Disable_SIGPIPE (R); 165 return R; 166 end C_Accept; 167 168 --------------- 169 -- C_Connect -- 170 --------------- 171 172 function C_Connect 173 (S : C.int; 174 Name : System.Address; 175 Namelen : C.int) return C.int 176 is 177 Res : C.int; 178 179 begin 180 Res := Syscall_Connect (S, Name, Namelen); 181 182 if SOSC.Thread_Blocking_IO 183 or else Res /= Failure 184 or else Non_Blocking_Socket (S) 185 or else Errno /= SOSC.EINPROGRESS 186 then 187 return Res; 188 end if; 189 190 declare 191 WSet : aliased Fd_Set; 192 Now : aliased Timeval; 193 194 begin 195 Reset_Socket_Set (WSet'Access); 196 loop 197 Insert_Socket_In_Set (WSet'Access, S); 198 Now := Immediat; 199 Res := C_Select 200 (S + 1, 201 No_Fd_Set_Access, 202 WSet'Access, 203 No_Fd_Set_Access, 204 Now'Unchecked_Access); 205 206 exit when Res > 0; 207 208 if Res = Failure then 209 return Res; 210 end if; 211 212 delay Quantum; 213 end loop; 214 end; 215 216 Res := Syscall_Connect (S, Name, Namelen); 217 218 if Res = Failure 219 and then Errno = SOSC.EISCONN 220 then 221 return Thin_Common.Success; 222 else 223 return Res; 224 end if; 225 end C_Connect; 226 227 ------------------ 228 -- Socket_Ioctl -- 229 ------------------ 230 231 function Socket_Ioctl 232 (S : C.int; 233 Req : SOSC.IOCTL_Req_T; 234 Arg : access C.int) return C.int 235 is 236 begin 237 if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then 238 if Arg.all /= 0 then 239 Set_Non_Blocking_Socket (S, True); 240 end if; 241 end if; 242 243 return C_Ioctl (S, Req, Arg); 244 end Socket_Ioctl; 245 246 ------------ 247 -- C_Recv -- 248 ------------ 249 250 function C_Recv 251 (S : C.int; 252 Msg : System.Address; 253 Len : C.int; 254 Flags : C.int) return C.int 255 is 256 Res : C.int; 257 258 begin 259 loop 260 Res := Syscall_Recv (S, Msg, Len, Flags); 261 exit when SOSC.Thread_Blocking_IO 262 or else Res /= Failure 263 or else Non_Blocking_Socket (S) 264 or else Errno /= SOSC.EWOULDBLOCK; 265 delay Quantum; 266 end loop; 267 268 return Res; 269 end C_Recv; 270 271 ---------------- 272 -- C_Recvfrom -- 273 ---------------- 274 275 function C_Recvfrom 276 (S : C.int; 277 Msg : System.Address; 278 Len : C.int; 279 Flags : C.int; 280 From : System.Address; 281 Fromlen : not null access C.int) return C.int 282 is 283 Res : C.int; 284 285 begin 286 loop 287 Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); 288 exit when SOSC.Thread_Blocking_IO 289 or else Res /= Failure 290 or else Non_Blocking_Socket (S) 291 or else Errno /= SOSC.EWOULDBLOCK; 292 delay Quantum; 293 end loop; 294 295 return Res; 296 end C_Recvfrom; 297 298 --------------- 299 -- C_Recvmsg -- 300 --------------- 301 302 function C_Recvmsg 303 (S : C.int; 304 Msg : System.Address; 305 Flags : C.int) return System.CRTL.ssize_t 306 is 307 Res : System.CRTL.ssize_t; 308 309 begin 310 loop 311 Res := Syscall_Recvmsg (S, Msg, Flags); 312 exit when SOSC.Thread_Blocking_IO 313 or else Res /= System.CRTL.ssize_t (Failure) 314 or else Non_Blocking_Socket (S) 315 or else Errno /= SOSC.EWOULDBLOCK; 316 delay Quantum; 317 end loop; 318 319 return Res; 320 end C_Recvmsg; 321 322 --------------- 323 -- C_Sendmsg -- 324 --------------- 325 326 function C_Sendmsg 327 (S : C.int; 328 Msg : System.Address; 329 Flags : C.int) return System.CRTL.ssize_t 330 is 331 Res : System.CRTL.ssize_t; 332 333 begin 334 loop 335 Res := Syscall_Sendmsg (S, Msg, Flags); 336 exit when SOSC.Thread_Blocking_IO 337 or else Res /= System.CRTL.ssize_t (Failure) 338 or else Non_Blocking_Socket (S) 339 or else Errno /= SOSC.EWOULDBLOCK; 340 delay Quantum; 341 end loop; 342 343 return Res; 344 end C_Sendmsg; 345 346 -------------- 347 -- C_Sendto -- 348 -------------- 349 350 function C_Sendto 351 (S : C.int; 352 Msg : System.Address; 353 Len : C.int; 354 Flags : C.int; 355 To : System.Address; 356 Tolen : C.int) return C.int 357 is 358 Res : C.int; 359 360 begin 361 loop 362 Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); 363 exit when SOSC.Thread_Blocking_IO 364 or else Res /= Failure 365 or else Non_Blocking_Socket (S) 366 or else Errno /= SOSC.EWOULDBLOCK; 367 delay Quantum; 368 end loop; 369 370 return Res; 371 end C_Sendto; 372 373 -------------- 374 -- C_Socket -- 375 -------------- 376 377 function C_Socket 378 (Domain : C.int; 379 Typ : C.int; 380 Protocol : C.int) return C.int 381 is 382 R : C.int; 383 Val : aliased C.int := 1; 384 385 Discard : C.int; 386 pragma Unreferenced (Discard); 387 388 begin 389 R := Syscall_Socket (Domain, Typ, Protocol); 390 391 if not SOSC.Thread_Blocking_IO 392 and then R /= Failure 393 then 394 -- Do not use Socket_Ioctl as this subprogram tracks sockets set 395 -- in non-blocking mode by user. 396 397 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); 398 Set_Non_Blocking_Socket (R, False); 399 end if; 400 Disable_SIGPIPE (R); 401 return R; 402 end C_Socket; 403 404 -------------- 405 -- Finalize -- 406 -------------- 407 408 procedure Finalize is 409 begin 410 null; 411 end Finalize; 412 413 ------------------------- 414 -- Host_Error_Messages -- 415 ------------------------- 416 417 package body Host_Error_Messages is separate; 418 419 ---------------- 420 -- Initialize -- 421 ---------------- 422 423 procedure Initialize is 424 begin 425 Disable_All_SIGPIPEs; 426 Reset_Socket_Set (Non_Blocking_Sockets'Access); 427 end Initialize; 428 429 ------------------------- 430 -- Non_Blocking_Socket -- 431 ------------------------- 432 433 function Non_Blocking_Socket (S : C.int) return Boolean is 434 R : Boolean; 435 begin 436 Task_Lock.Lock; 437 R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0); 438 Task_Lock.Unlock; 439 return R; 440 end Non_Blocking_Socket; 441 442 ----------------------------- 443 -- Set_Non_Blocking_Socket -- 444 ----------------------------- 445 446 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is 447 begin 448 Task_Lock.Lock; 449 450 if V then 451 Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S); 452 else 453 Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); 454 end if; 455 456 Task_Lock.Unlock; 457 end Set_Non_Blocking_Socket; 458 459 -------------------- 460 -- Signalling_Fds -- 461 -------------------- 462 463 package body Signalling_Fds is 464 465 -- In this default implementation, we use a C version of these 466 -- subprograms provided by socket.c. 467 468 function C_Create (Fds : not null access Fd_Pair) return C.int; 469 function C_Read (Rsig : C.int) return C.int; 470 function C_Write (Wsig : C.int) return C.int; 471 procedure C_Close (Sig : C.int); 472 473 pragma Import (C, C_Create, "__gnat_create_signalling_fds"); 474 pragma Import (C, C_Read, "__gnat_read_signalling_fd"); 475 pragma Import (C, C_Write, "__gnat_write_signalling_fd"); 476 pragma Import (C, C_Close, "__gnat_close_signalling_fd"); 477 478 function Create 479 (Fds : not null access Fd_Pair) return C.int renames C_Create; 480 function Read (Rsig : C.int) return C.int renames C_Read; 481 function Write (Wsig : C.int) return C.int renames C_Write; 482 procedure Close (Sig : C.int) renames C_Close; 483 484 end Signalling_Fds; 485 486 -------------------------- 487 -- Socket_Error_Message -- 488 -------------------------- 489 490 function Socket_Error_Message (Errno : Integer) return String is separate; 491 492end GNAT.Sockets.Thin; 493