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