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) 2002-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 version is for VxWorks 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 ----------------------- 61 -- Local Subprograms -- 62 ----------------------- 63 64 -- All these require comments ??? 65 66 function Syscall_Accept 67 (S : C.int; 68 Addr : System.Address; 69 Addrlen : not null access C.int) return C.int; 70 pragma Import (C, Syscall_Accept, "accept"); 71 72 function Syscall_Connect 73 (S : C.int; 74 Name : System.Address; 75 Namelen : C.int) return C.int; 76 pragma Import (C, Syscall_Connect, "connect"); 77 78 function Syscall_Recv 79 (S : C.int; 80 Msg : System.Address; 81 Len : C.int; 82 Flags : C.int) return C.int; 83 pragma Import (C, Syscall_Recv, "recv"); 84 85 function Syscall_Recvfrom 86 (S : C.int; 87 Msg : System.Address; 88 Len : C.int; 89 Flags : C.int; 90 From : System.Address; 91 Fromlen : not null access C.int) return C.int; 92 pragma Import (C, Syscall_Recvfrom, "recvfrom"); 93 94 function Syscall_Recvmsg 95 (S : C.int; 96 Msg : System.Address; 97 Flags : C.int) return C.int; 98 pragma Import (C, Syscall_Recvmsg, "recvmsg"); 99 100 function Syscall_Sendmsg 101 (S : C.int; 102 Msg : System.Address; 103 Flags : C.int) return C.int; 104 pragma Import (C, Syscall_Sendmsg, "sendmsg"); 105 106 function Syscall_Send 107 (S : C.int; 108 Msg : System.Address; 109 Len : C.int; 110 Flags : C.int) return C.int; 111 pragma Import (C, Syscall_Send, "send"); 112 113 function Syscall_Sendto 114 (S : C.int; 115 Msg : System.Address; 116 Len : C.int; 117 Flags : C.int; 118 To : System.Address; 119 Tolen : C.int) return C.int; 120 pragma Import (C, Syscall_Sendto, "sendto"); 121 122 function Syscall_Socket 123 (Domain : C.int; 124 Typ : C.int; 125 Protocol : C.int) return C.int; 126 pragma Import (C, Syscall_Socket, "socket"); 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 Res : C.int; 144 pragma Unreferenced (Res); 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 of 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 Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access); 165 -- Is it OK to ignore result ??? 166 end if; 167 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 begin 197 Reset_Socket_Set (WSet'Access); 198 loop 199 Insert_Socket_In_Set (WSet'Access, S); 200 Now := Immediat; 201 Res := C_Select 202 (S + 1, 203 No_Fd_Set_Access, 204 WSet'Access, 205 No_Fd_Set_Access, 206 Now'Unchecked_Access); 207 208 exit when Res > 0; 209 210 if Res = Failure then 211 return Res; 212 end if; 213 214 delay Quantum; 215 end loop; 216 end; 217 218 Res := Syscall_Connect (S, Name, Namelen); 219 220 if Res = Failure 221 and then Errno = SOSC.EISCONN 222 then 223 return Thin_Common.Success; 224 else 225 return Res; 226 end if; 227 end C_Connect; 228 229 ------------------ 230 -- Socket_Ioctl -- 231 ------------------ 232 233 function Socket_Ioctl 234 (S : C.int; 235 Req : SOSC.IOCTL_Req_T; 236 Arg : access C.int) return C.int 237 is 238 begin 239 if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then 240 if Arg.all /= 0 then 241 Set_Non_Blocking_Socket (S, True); 242 end if; 243 end if; 244 245 return C_Ioctl (S, Req, Arg); 246 end Socket_Ioctl; 247 248 ------------ 249 -- C_Recv -- 250 ------------ 251 252 function C_Recv 253 (S : C.int; 254 Msg : System.Address; 255 Len : C.int; 256 Flags : C.int) return C.int 257 is 258 Res : C.int; 259 260 begin 261 loop 262 Res := Syscall_Recv (S, Msg, Len, Flags); 263 exit when SOSC.Thread_Blocking_IO 264 or else Res /= Failure 265 or else Non_Blocking_Socket (S) 266 or else Errno /= SOSC.EWOULDBLOCK; 267 delay Quantum; 268 end loop; 269 270 return Res; 271 end C_Recv; 272 273 ---------------- 274 -- C_Recvfrom -- 275 ---------------- 276 277 function C_Recvfrom 278 (S : C.int; 279 Msg : System.Address; 280 Len : C.int; 281 Flags : C.int; 282 From : System.Address; 283 Fromlen : not null access C.int) return C.int 284 is 285 Res : C.int; 286 287 begin 288 loop 289 Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); 290 exit when SOSC.Thread_Blocking_IO 291 or else Res /= Failure 292 or else Non_Blocking_Socket (S) 293 or else Errno /= SOSC.EWOULDBLOCK; 294 delay Quantum; 295 end loop; 296 297 return Res; 298 end C_Recvfrom; 299 300 --------------- 301 -- C_Recvmsg -- 302 --------------- 303 304 function C_Recvmsg 305 (S : C.int; 306 Msg : System.Address; 307 Flags : C.int) return System.CRTL.ssize_t 308 is 309 Res : C.int; 310 311 begin 312 loop 313 Res := Syscall_Recvmsg (S, Msg, Flags); 314 exit when SOSC.Thread_Blocking_IO 315 or else Res /= Failure 316 or else Non_Blocking_Socket (S) 317 or else Errno /= SOSC.EWOULDBLOCK; 318 delay Quantum; 319 end loop; 320 321 return System.CRTL.ssize_t (Res); 322 end C_Recvmsg; 323 324 --------------- 325 -- C_Sendmsg -- 326 --------------- 327 328 function C_Sendmsg 329 (S : C.int; 330 Msg : System.Address; 331 Flags : C.int) return System.CRTL.ssize_t 332 is 333 Res : C.int; 334 335 begin 336 loop 337 Res := Syscall_Sendmsg (S, Msg, Flags); 338 exit when SOSC.Thread_Blocking_IO 339 or else Res /= Failure 340 or else Non_Blocking_Socket (S) 341 or else Errno /= SOSC.EWOULDBLOCK; 342 delay Quantum; 343 end loop; 344 345 return System.CRTL.ssize_t (Res); 346 end C_Sendmsg; 347 348 -------------- 349 -- C_Sendto -- 350 -------------- 351 352 function C_Sendto 353 (S : C.int; 354 Msg : System.Address; 355 Len : C.int; 356 Flags : C.int; 357 To : System.Address; 358 Tolen : C.int) return C.int 359 is 360 use System; 361 362 Res : C.int; 363 364 begin 365 loop 366 if To = Null_Address then 367 368 -- In violation of the standard sockets API, VxWorks does not 369 -- support sendto(2) calls on connected sockets with a null 370 -- destination address, so use send(2) instead in that case. 371 372 Res := Syscall_Send (S, Msg, Len, Flags); 373 374 -- Normal case where destination address is non-null 375 376 else 377 Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); 378 end if; 379 380 exit when SOSC.Thread_Blocking_IO 381 or else Res /= Failure 382 or else Non_Blocking_Socket (S) 383 or else Errno /= SOSC.EWOULDBLOCK; 384 delay Quantum; 385 end loop; 386 387 return Res; 388 end C_Sendto; 389 390 -------------- 391 -- C_Socket -- 392 -------------- 393 394 function C_Socket 395 (Domain : C.int; 396 Typ : C.int; 397 Protocol : C.int) return C.int 398 is 399 R : C.int; 400 Val : aliased C.int := 1; 401 402 Res : C.int; 403 pragma Unreferenced (Res); 404 405 begin 406 R := Syscall_Socket (Domain, Typ, Protocol); 407 408 if not SOSC.Thread_Blocking_IO 409 and then R /= Failure 410 then 411 -- Do not use Socket_Ioctl as this subprogram tracks sockets set 412 -- in non-blocking mode by user. 413 414 Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access); 415 -- Is it OK to ignore result ??? 416 Set_Non_Blocking_Socket (R, False); 417 end if; 418 419 return R; 420 end C_Socket; 421 422 -------------- 423 -- Finalize -- 424 -------------- 425 426 procedure Finalize is 427 begin 428 null; 429 end Finalize; 430 431 ------------------------- 432 -- Host_Error_Messages -- 433 ------------------------- 434 435 package body Host_Error_Messages is separate; 436 437 ---------------- 438 -- Initialize -- 439 ---------------- 440 441 procedure Initialize is 442 begin 443 Reset_Socket_Set (Non_Blocking_Sockets'Access); 444 end Initialize; 445 446 ------------------------- 447 -- Non_Blocking_Socket -- 448 ------------------------- 449 450 function Non_Blocking_Socket (S : C.int) return Boolean is 451 R : Boolean; 452 begin 453 Task_Lock.Lock; 454 R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0); 455 Task_Lock.Unlock; 456 return R; 457 end Non_Blocking_Socket; 458 459 ----------------------------- 460 -- Set_Non_Blocking_Socket -- 461 ----------------------------- 462 463 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is 464 begin 465 Task_Lock.Lock; 466 if V then 467 Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S); 468 else 469 Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); 470 end if; 471 472 Task_Lock.Unlock; 473 end Set_Non_Blocking_Socket; 474 475 -------------------- 476 -- Signalling_Fds -- 477 -------------------- 478 479 package body Signalling_Fds is separate; 480 481 -------------------------- 482 -- Socket_Error_Message -- 483 -------------------------- 484 485 function Socket_Error_Message (Errno : Integer) return String is separate; 486 487end GNAT.Sockets.Thin; 488