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 is the version for OpenVMS 33 34with GNAT.OS_Lib; use GNAT.OS_Lib; 35with GNAT.Task_Lock; 36 37with Interfaces.C; use Interfaces.C; 38 39package body GNAT.Sockets.Thin is 40 41 type VMS_Msghdr is new Msghdr; 42 pragma Pack (VMS_Msghdr); 43 -- On VMS 8.x (unlike other platforms), struct msghdr is packed, so a 44 -- specific derived type is required. This structure was not packed on 45 -- VMS 7.3. 46 47 function Is_VMS_V7 return Integer; 48 pragma Import (C, Is_VMS_V7, "__gnat_is_vms_v7"); 49 -- Helper (defined in init.c) that returns a non-zero value if the VMS 50 -- version is 7.x. 51 52 VMS_V7 : constant Boolean := Is_VMS_V7 /= 0; 53 -- True if VMS version is 7.x. 54 55 Non_Blocking_Sockets : aliased Fd_Set; 56 -- When this package is initialized with Process_Blocking_IO set to True, 57 -- sockets are set in non-blocking mode to avoid blocking the whole process 58 -- when a thread wants to perform a blocking IO operation. But the user can 59 -- also set a socket in non-blocking mode by purpose. In order to make a 60 -- difference between these two situations, we track the origin of 61 -- non-blocking mode in Non_Blocking_Sockets. Note that if S is in 62 -- Non_Blocking_Sockets, it has been set in non-blocking mode by the user. 63 64 Quantum : constant Duration := 0.2; 65 -- When SOSC.Thread_Blocking_IO is False, we set sockets to non-blocking 66 -- mode and we spend a period of time Quantum between two attempts on a 67 -- blocking operation. 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_Sendto 110 (S : C.int; 111 Msg : System.Address; 112 Len : C.int; 113 Flags : C.int; 114 To : System.Address; 115 Tolen : C.int) return C.int; 116 pragma Import (C, Syscall_Sendto, "sendto"); 117 118 function Syscall_Socket 119 (Domain, Typ, Protocol : C.int) return C.int; 120 pragma Import (C, Syscall_Socket, "socket"); 121 122 function Non_Blocking_Socket (S : C.int) return Boolean; 123 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); 124 125 -------------- 126 -- C_Accept -- 127 -------------- 128 129 function C_Accept 130 (S : C.int; 131 Addr : System.Address; 132 Addrlen : not null access C.int) return C.int 133 is 134 R : C.int; 135 Val : aliased C.int := 1; 136 137 Discard : C.int; 138 pragma Warnings (Off, Discard); 139 140 begin 141 loop 142 R := Syscall_Accept (S, Addr, Addrlen); 143 exit when SOSC.Thread_Blocking_IO 144 or else R /= Failure 145 or else Non_Blocking_Socket (S) 146 or else Errno /= SOSC.EWOULDBLOCK; 147 delay Quantum; 148 end loop; 149 150 if not SOSC.Thread_Blocking_IO 151 and then R /= Failure 152 then 153 -- A socket inherits the properties of its server, especially 154 -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram 155 -- tracks sockets set in non-blocking mode by user. 156 157 Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); 158 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); 159 end if; 160 161 return R; 162 end C_Accept; 163 164 --------------- 165 -- C_Connect -- 166 --------------- 167 168 function C_Connect 169 (S : C.int; 170 Name : System.Address; 171 Namelen : C.int) return C.int 172 is 173 Res : C.int; 174 175 begin 176 Res := Syscall_Connect (S, Name, Namelen); 177 178 if SOSC.Thread_Blocking_IO 179 or else Res /= Failure 180 or else Non_Blocking_Socket (S) 181 or else Errno /= SOSC.EINPROGRESS 182 then 183 return Res; 184 end if; 185 186 declare 187 WSet : aliased Fd_Set; 188 Now : aliased Timeval; 189 190 begin 191 Reset_Socket_Set (WSet'Access); 192 loop 193 Insert_Socket_In_Set (WSet'Access, S); 194 Now := Immediat; 195 Res := C_Select 196 (S + 1, 197 No_Fd_Set_Access, 198 WSet'Access, 199 No_Fd_Set_Access, 200 Now'Unchecked_Access); 201 202 exit when Res > 0; 203 204 if Res = Failure then 205 return Res; 206 end if; 207 208 delay Quantum; 209 end loop; 210 end; 211 212 Res := Syscall_Connect (S, Name, Namelen); 213 214 if Res = Failure and then Errno = SOSC.EISCONN then 215 return Thin_Common.Success; 216 else 217 return Res; 218 end if; 219 end C_Connect; 220 221 ------------------ 222 -- Socket_Ioctl -- 223 ------------------ 224 225 function Socket_Ioctl 226 (S : C.int; 227 Req : SOSC.IOCTL_Req_T; 228 Arg : access C.int) return C.int 229 is 230 begin 231 if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then 232 if Arg.all /= 0 then 233 Set_Non_Blocking_Socket (S, True); 234 end if; 235 end if; 236 237 return C_Ioctl (S, Req, Arg); 238 end Socket_Ioctl; 239 240 ------------ 241 -- C_Recv -- 242 ------------ 243 244 function C_Recv 245 (S : C.int; 246 Msg : System.Address; 247 Len : C.int; 248 Flags : C.int) return C.int 249 is 250 Res : C.int; 251 252 begin 253 loop 254 Res := Syscall_Recv (S, Msg, Len, Flags); 255 exit when SOSC.Thread_Blocking_IO 256 or else Res /= Failure 257 or else Non_Blocking_Socket (S) 258 or else Errno /= SOSC.EWOULDBLOCK; 259 delay Quantum; 260 end loop; 261 262 return Res; 263 end C_Recv; 264 265 ---------------- 266 -- C_Recvfrom -- 267 ---------------- 268 269 function C_Recvfrom 270 (S : C.int; 271 Msg : System.Address; 272 Len : C.int; 273 Flags : C.int; 274 From : System.Address; 275 Fromlen : not null access C.int) return C.int 276 is 277 Res : C.int; 278 279 begin 280 loop 281 Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); 282 exit when SOSC.Thread_Blocking_IO 283 or else Res /= Failure 284 or else Non_Blocking_Socket (S) 285 or else Errno /= SOSC.EWOULDBLOCK; 286 delay Quantum; 287 end loop; 288 289 return Res; 290 end C_Recvfrom; 291 292 --------------- 293 -- C_Recvmsg -- 294 --------------- 295 296 function C_Recvmsg 297 (S : C.int; 298 Msg : System.Address; 299 Flags : C.int) return System.CRTL.ssize_t 300 is 301 Res : C.int; 302 303 Msg_Addr : System.Address; 304 305 GNAT_Msg : Msghdr; 306 for GNAT_Msg'Address use Msg; 307 pragma Import (Ada, GNAT_Msg); 308 309 VMS_Msg : aliased VMS_Msghdr; 310 311 begin 312 if VMS_V7 then 313 Msg_Addr := Msg; 314 else 315 VMS_Msg := VMS_Msghdr (GNAT_Msg); 316 Msg_Addr := VMS_Msg'Address; 317 end if; 318 319 loop 320 Res := Syscall_Recvmsg (S, Msg_Addr, Flags); 321 exit when SOSC.Thread_Blocking_IO 322 or else Res /= Failure 323 or else Non_Blocking_Socket (S) 324 or else Errno /= SOSC.EWOULDBLOCK; 325 delay Quantum; 326 end loop; 327 328 if not VMS_V7 then 329 GNAT_Msg := Msghdr (VMS_Msg); 330 end if; 331 332 return System.CRTL.ssize_t (Res); 333 end C_Recvmsg; 334 335 --------------- 336 -- C_Sendmsg -- 337 --------------- 338 339 function C_Sendmsg 340 (S : C.int; 341 Msg : System.Address; 342 Flags : C.int) return System.CRTL.ssize_t 343 is 344 Res : C.int; 345 346 Msg_Addr : System.Address; 347 348 GNAT_Msg : Msghdr; 349 for GNAT_Msg'Address use Msg; 350 pragma Import (Ada, GNAT_Msg); 351 352 VMS_Msg : aliased VMS_Msghdr; 353 354 begin 355 if VMS_V7 then 356 Msg_Addr := Msg; 357 else 358 VMS_Msg := VMS_Msghdr (GNAT_Msg); 359 Msg_Addr := VMS_Msg'Address; 360 end if; 361 362 loop 363 Res := Syscall_Sendmsg (S, Msg_Addr, Flags); 364 exit when SOSC.Thread_Blocking_IO 365 or else Res /= Failure 366 or else Non_Blocking_Socket (S) 367 or else Errno /= SOSC.EWOULDBLOCK; 368 delay Quantum; 369 end loop; 370 371 if not VMS_V7 then 372 GNAT_Msg := Msghdr (VMS_Msg); 373 end if; 374 375 return System.CRTL.ssize_t (Res); 376 end C_Sendmsg; 377 378 -------------- 379 -- C_Sendto -- 380 -------------- 381 382 function C_Sendto 383 (S : C.int; 384 Msg : System.Address; 385 Len : C.int; 386 Flags : C.int; 387 To : System.Address; 388 Tolen : C.int) return C.int 389 is 390 Res : C.int; 391 392 begin 393 loop 394 Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); 395 exit when SOSC.Thread_Blocking_IO 396 or else Res /= Failure 397 or else Non_Blocking_Socket (S) 398 or else Errno /= SOSC.EWOULDBLOCK; 399 delay Quantum; 400 end loop; 401 402 return Res; 403 end C_Sendto; 404 405 -------------- 406 -- C_Socket -- 407 -------------- 408 409 function C_Socket 410 (Domain : C.int; 411 Typ : C.int; 412 Protocol : C.int) return C.int 413 is 414 R : C.int; 415 Val : aliased C.int := 1; 416 417 Discard : C.int; 418 pragma Unreferenced (Discard); 419 420 begin 421 R := Syscall_Socket (Domain, Typ, Protocol); 422 423 if not SOSC.Thread_Blocking_IO 424 and then R /= Failure 425 then 426 -- Do not use Socket_Ioctl as this subprogram tracks sockets set 427 -- in non-blocking mode by user. 428 429 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); 430 Set_Non_Blocking_Socket (R, False); 431 end if; 432 433 return R; 434 end C_Socket; 435 436 -------------- 437 -- Finalize -- 438 -------------- 439 440 procedure Finalize is 441 begin 442 null; 443 end Finalize; 444 445 ------------------------- 446 -- Host_Error_Messages -- 447 ------------------------- 448 449 package body Host_Error_Messages is separate; 450 451 ---------------- 452 -- Initialize -- 453 ---------------- 454 455 procedure Initialize is 456 begin 457 Reset_Socket_Set (Non_Blocking_Sockets'Access); 458 end Initialize; 459 460 ------------------------- 461 -- Non_Blocking_Socket -- 462 ------------------------- 463 464 function Non_Blocking_Socket (S : C.int) return Boolean is 465 R : Boolean; 466 begin 467 Task_Lock.Lock; 468 R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0); 469 Task_Lock.Unlock; 470 return R; 471 end Non_Blocking_Socket; 472 473 ----------------------------- 474 -- Set_Non_Blocking_Socket -- 475 ----------------------------- 476 477 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is 478 begin 479 Task_Lock.Lock; 480 481 if V then 482 Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S); 483 else 484 Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); 485 end if; 486 487 Task_Lock.Unlock; 488 end Set_Non_Blocking_Socket; 489 490 -------------------- 491 -- Signalling_Fds -- 492 -------------------- 493 494 package body Signalling_Fds is separate; 495 496 -------------------------- 497 -- Socket_Error_Message -- 498 -------------------------- 499 500 function Socket_Error_Message (Errno : Integer) return String is separate; 501 502end GNAT.Sockets.Thin; 503