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