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