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-2014, 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 387 begin 388 R := Syscall_Socket (Domain, Typ, Protocol); 389 390 if not SOSC.Thread_Blocking_IO 391 and then R /= Failure 392 then 393 -- Do not use Socket_Ioctl as this subprogram tracks sockets set 394 -- in non-blocking mode by user. 395 396 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); 397 Set_Non_Blocking_Socket (R, False); 398 end if; 399 Disable_SIGPIPE (R); 400 return R; 401 end C_Socket; 402 403 -------------- 404 -- Finalize -- 405 -------------- 406 407 procedure Finalize is 408 begin 409 null; 410 end Finalize; 411 412 ------------------------- 413 -- Host_Error_Messages -- 414 ------------------------- 415 416 package body Host_Error_Messages is separate; 417 418 ---------------- 419 -- Initialize -- 420 ---------------- 421 422 procedure Initialize is 423 begin 424 Disable_All_SIGPIPEs; 425 Reset_Socket_Set (Non_Blocking_Sockets'Access); 426 end Initialize; 427 428 ------------------------- 429 -- Non_Blocking_Socket -- 430 ------------------------- 431 432 function Non_Blocking_Socket (S : C.int) return Boolean is 433 R : Boolean; 434 begin 435 Task_Lock.Lock; 436 R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0); 437 Task_Lock.Unlock; 438 return R; 439 end Non_Blocking_Socket; 440 441 ----------------------------- 442 -- Set_Non_Blocking_Socket -- 443 ----------------------------- 444 445 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is 446 begin 447 Task_Lock.Lock; 448 449 if V then 450 Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S); 451 else 452 Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); 453 end if; 454 455 Task_Lock.Unlock; 456 end Set_Non_Blocking_Socket; 457 458 -------------------- 459 -- Signalling_Fds -- 460 -------------------- 461 462 package body Signalling_Fds is 463 464 -- In this default implementation, we use a C version of these 465 -- subprograms provided by socket.c. 466 467 function C_Create (Fds : not null access Fd_Pair) return C.int; 468 function C_Read (Rsig : C.int) return C.int; 469 function C_Write (Wsig : C.int) return C.int; 470 procedure C_Close (Sig : C.int); 471 472 pragma Import (C, C_Create, "__gnat_create_signalling_fds"); 473 pragma Import (C, C_Read, "__gnat_read_signalling_fd"); 474 pragma Import (C, C_Write, "__gnat_write_signalling_fd"); 475 pragma Import (C, C_Close, "__gnat_close_signalling_fd"); 476 477 function Create 478 (Fds : not null access Fd_Pair) return C.int renames C_Create; 479 function Read (Rsig : C.int) return C.int renames C_Read; 480 function Write (Wsig : C.int) return C.int renames C_Write; 481 procedure Close (Sig : C.int) renames C_Close; 482 483 end Signalling_Fds; 484 485 -------------------------- 486 -- Socket_Error_Message -- 487 -------------------------- 488 489 function Socket_Error_Message (Errno : Integer) return String is separate; 490 491end GNAT.Sockets.Thin; 492