1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T . S O C K E T S -- 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 32with Ada.Streams; use Ada.Streams; 33with Ada.Exceptions; use Ada.Exceptions; 34with Ada.Finalization; 35with Ada.Unchecked_Conversion; 36 37with Interfaces.C.Strings; 38 39with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common; 40with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; 41 42with GNAT.Sockets.Linker_Options; 43pragma Warnings (Off, GNAT.Sockets.Linker_Options); 44-- Need to include pragma Linker_Options which is platform dependent 45 46with System; use System; 47with System.Communication; use System.Communication; 48with System.CRTL; use System.CRTL; 49with System.Task_Lock; 50 51package body GNAT.Sockets is 52 53 package C renames Interfaces.C; 54 55 use type C.int; 56 57 ENOERROR : constant := 0; 58 59 Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024; 60 Need_Netdb_Lock : constant Boolean := SOSC.Need_Netdb_Lock /= 0; 61 -- The network database functions gethostbyname, gethostbyaddr, 62 -- getservbyname and getservbyport can either be guaranteed task safe by 63 -- the operating system, or else return data through a user-provided buffer 64 -- to ensure concurrent uses do not interfere. 65 66 -- Correspondence tables 67 68 Levels : constant array (Level_Type) of C.int := 69 (Socket_Level => SOSC.SOL_SOCKET, 70 IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP, 71 IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP, 72 IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP); 73 74 Modes : constant array (Mode_Type) of C.int := 75 (Socket_Stream => SOSC.SOCK_STREAM, 76 Socket_Datagram => SOSC.SOCK_DGRAM); 77 78 Shutmodes : constant array (Shutmode_Type) of C.int := 79 (Shut_Read => SOSC.SHUT_RD, 80 Shut_Write => SOSC.SHUT_WR, 81 Shut_Read_Write => SOSC.SHUT_RDWR); 82 83 Requests : constant array (Request_Name) of SOSC.IOCTL_Req_T := 84 (Non_Blocking_IO => SOSC.FIONBIO, 85 N_Bytes_To_Read => SOSC.FIONREAD); 86 87 Options : constant array (Option_Name) of C.int := 88 (Keep_Alive => SOSC.SO_KEEPALIVE, 89 Reuse_Address => SOSC.SO_REUSEADDR, 90 Broadcast => SOSC.SO_BROADCAST, 91 Send_Buffer => SOSC.SO_SNDBUF, 92 Receive_Buffer => SOSC.SO_RCVBUF, 93 Linger => SOSC.SO_LINGER, 94 Error => SOSC.SO_ERROR, 95 No_Delay => SOSC.TCP_NODELAY, 96 Add_Membership => SOSC.IP_ADD_MEMBERSHIP, 97 Drop_Membership => SOSC.IP_DROP_MEMBERSHIP, 98 Multicast_If => SOSC.IP_MULTICAST_IF, 99 Multicast_TTL => SOSC.IP_MULTICAST_TTL, 100 Multicast_Loop => SOSC.IP_MULTICAST_LOOP, 101 Receive_Packet_Info => SOSC.IP_PKTINFO, 102 Send_Timeout => SOSC.SO_SNDTIMEO, 103 Receive_Timeout => SOSC.SO_RCVTIMEO); 104 -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO, 105 -- but for Linux compatibility this constant is the same as IP_PKTINFO. 106 107 Flags : constant array (0 .. 3) of C.int := 108 (0 => SOSC.MSG_OOB, -- Process_Out_Of_Band_Data 109 1 => SOSC.MSG_PEEK, -- Peek_At_Incoming_Data 110 2 => SOSC.MSG_WAITALL, -- Wait_For_A_Full_Reception 111 3 => SOSC.MSG_EOR); -- Send_End_Of_Record 112 113 Socket_Error_Id : constant Exception_Id := Socket_Error'Identity; 114 Host_Error_Id : constant Exception_Id := Host_Error'Identity; 115 116 Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF"; 117 -- Use to print in hexadecimal format 118 119 ----------------------- 120 -- Local subprograms -- 121 ----------------------- 122 123 function Resolve_Error 124 (Error_Value : Integer; 125 From_Errno : Boolean := True) return Error_Type; 126 -- Associate an enumeration value (error_type) to an error value (errno). 127 -- From_Errno prevents from mixing h_errno with errno. 128 129 function To_Name (N : String) return Name_Type; 130 function To_String (HN : Name_Type) return String; 131 -- Conversion functions 132 133 function To_Int (F : Request_Flag_Type) return C.int; 134 -- Return the int value corresponding to the specified flags combination 135 136 function Set_Forced_Flags (F : C.int) return C.int; 137 -- Return F with the bits from SOSC.MSG_Forced_Flags forced set 138 139 function Short_To_Network 140 (S : C.unsigned_short) return C.unsigned_short; 141 pragma Inline (Short_To_Network); 142 -- Convert a port number into a network port number 143 144 function Network_To_Short 145 (S : C.unsigned_short) return C.unsigned_short 146 renames Short_To_Network; 147 -- Symmetric operation 148 149 function Image 150 (Val : Inet_Addr_VN_Type; 151 Hex : Boolean := False) return String; 152 -- Output an array of inet address components in hex or decimal mode 153 154 function Is_IP_Address (Name : String) return Boolean; 155 -- Return true when Name is an IP address in standard dot notation 156 157 procedure Netdb_Lock; 158 pragma Inline (Netdb_Lock); 159 procedure Netdb_Unlock; 160 pragma Inline (Netdb_Unlock); 161 -- Lock/unlock operation used to protect netdb access for platforms that 162 -- require such protection. 163 164 function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr; 165 procedure To_Inet_Addr 166 (Addr : In_Addr; 167 Result : out Inet_Addr_Type); 168 -- Conversion functions 169 170 function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type; 171 -- Conversion function 172 173 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type; 174 -- Conversion function 175 176 function Value (S : System.Address) return String; 177 -- Same as Interfaces.C.Strings.Value but taking a System.Address (on VMS, 178 -- chars_ptr is a 32-bit pointer, and here we need a 64-bit version). 179 180 function To_Timeval (Val : Timeval_Duration) return Timeval; 181 -- Separate Val in seconds and microseconds 182 183 function To_Duration (Val : Timeval) return Timeval_Duration; 184 -- Reconstruct a Duration value from a Timeval record (seconds and 185 -- microseconds). 186 187 procedure Raise_Socket_Error (Error : Integer); 188 -- Raise Socket_Error with an exception message describing the error code 189 -- from errno. 190 191 procedure Raise_Host_Error (H_Error : Integer); 192 -- Raise Host_Error exception with message describing error code (note 193 -- hstrerror seems to be obsolete) from h_errno. 194 195 procedure Narrow (Item : in out Socket_Set_Type); 196 -- Update Last as it may be greater than the real last socket 197 198 procedure Check_For_Fd_Set (Fd : Socket_Type); 199 pragma Inline (Check_For_Fd_Set); 200 -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to 201 -- FD_SETSIZE, on platforms where fd_set is a bitmap. 202 203 function Connect_Socket 204 (Socket : Socket_Type; 205 Server : Sock_Addr_Type) return C.int; 206 pragma Inline (Connect_Socket); 207 -- Underlying implementation for the Connect_Socket procedures 208 209 -- Types needed for Datagram_Socket_Stream_Type 210 211 type Datagram_Socket_Stream_Type is new Root_Stream_Type with record 212 Socket : Socket_Type; 213 To : Sock_Addr_Type; 214 From : Sock_Addr_Type; 215 end record; 216 217 type Datagram_Socket_Stream_Access is 218 access all Datagram_Socket_Stream_Type; 219 220 procedure Read 221 (Stream : in out Datagram_Socket_Stream_Type; 222 Item : out Ada.Streams.Stream_Element_Array; 223 Last : out Ada.Streams.Stream_Element_Offset); 224 225 procedure Write 226 (Stream : in out Datagram_Socket_Stream_Type; 227 Item : Ada.Streams.Stream_Element_Array); 228 229 -- Types needed for Stream_Socket_Stream_Type 230 231 type Stream_Socket_Stream_Type is new Root_Stream_Type with record 232 Socket : Socket_Type; 233 end record; 234 235 type Stream_Socket_Stream_Access is 236 access all Stream_Socket_Stream_Type; 237 238 procedure Read 239 (Stream : in out Stream_Socket_Stream_Type; 240 Item : out Ada.Streams.Stream_Element_Array; 241 Last : out Ada.Streams.Stream_Element_Offset); 242 243 procedure Write 244 (Stream : in out Stream_Socket_Stream_Type; 245 Item : Ada.Streams.Stream_Element_Array); 246 247 procedure Stream_Write 248 (Socket : Socket_Type; 249 Item : Ada.Streams.Stream_Element_Array; 250 To : access Sock_Addr_Type); 251 -- Common implementation for the Write operation of Datagram_Socket_Stream_ 252 -- Type and Stream_Socket_Stream_Type. 253 254 procedure Wait_On_Socket 255 (Socket : Socket_Type; 256 For_Read : Boolean; 257 Timeout : Selector_Duration; 258 Selector : access Selector_Type := null; 259 Status : out Selector_Status); 260 -- Common code for variants of socket operations supporting a timeout: 261 -- block in Check_Selector on Socket for at most the indicated timeout. 262 -- If For_Read is True, Socket is added to the read set for this call, else 263 -- it is added to the write set. If no selector is provided, a local one is 264 -- created for this call and destroyed prior to returning. 265 266 type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled 267 with null record; 268 -- This type is used to generate automatic calls to Initialize and Finalize 269 -- during the elaboration and finalization of this package. A single object 270 -- of this type must exist at library level. 271 272 function Err_Code_Image (E : Integer) return String; 273 -- Return the value of E surrounded with brackets 274 275 procedure Initialize (X : in out Sockets_Library_Controller); 276 procedure Finalize (X : in out Sockets_Library_Controller); 277 278 procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type); 279 -- If S is the empty set (detected by Last = No_Socket), make sure its 280 -- fd_set component is actually cleared. Note that the case where it is 281 -- not can occur for an uninitialized Socket_Set_Type object. 282 283 function Is_Open (S : Selector_Type) return Boolean; 284 -- Return True for an "open" Selector_Type object, i.e. one for which 285 -- Create_Selector has been called and Close_Selector has not been called, 286 -- or the null selector. 287 288 --------- 289 -- "+" -- 290 --------- 291 292 function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is 293 begin 294 return L or R; 295 end "+"; 296 297 -------------------- 298 -- Abort_Selector -- 299 -------------------- 300 301 procedure Abort_Selector (Selector : Selector_Type) is 302 Res : C.int; 303 304 begin 305 if not Is_Open (Selector) then 306 raise Program_Error with "closed selector"; 307 308 elsif Selector.Is_Null then 309 raise Program_Error with "null selector"; 310 311 end if; 312 313 -- Send one byte to unblock select system call 314 315 Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket)); 316 317 if Res = Failure then 318 Raise_Socket_Error (Socket_Errno); 319 end if; 320 end Abort_Selector; 321 322 ------------------- 323 -- Accept_Socket -- 324 ------------------- 325 326 procedure Accept_Socket 327 (Server : Socket_Type; 328 Socket : out Socket_Type; 329 Address : out Sock_Addr_Type) 330 is 331 Res : C.int; 332 Sin : aliased Sockaddr_In; 333 Len : aliased C.int := Sin'Size / 8; 334 335 begin 336 Res := C_Accept (C.int (Server), Sin'Address, Len'Access); 337 338 if Res = Failure then 339 Raise_Socket_Error (Socket_Errno); 340 end if; 341 342 Socket := Socket_Type (Res); 343 344 To_Inet_Addr (Sin.Sin_Addr, Address.Addr); 345 Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); 346 end Accept_Socket; 347 348 ------------------- 349 -- Accept_Socket -- 350 ------------------- 351 352 procedure Accept_Socket 353 (Server : Socket_Type; 354 Socket : out Socket_Type; 355 Address : out Sock_Addr_Type; 356 Timeout : Selector_Duration; 357 Selector : access Selector_Type := null; 358 Status : out Selector_Status) 359 is 360 begin 361 if Selector /= null and then not Is_Open (Selector.all) then 362 raise Program_Error with "closed selector"; 363 end if; 364 365 -- Wait for socket to become available for reading 366 367 Wait_On_Socket 368 (Socket => Server, 369 For_Read => True, 370 Timeout => Timeout, 371 Selector => Selector, 372 Status => Status); 373 374 -- Accept connection if available 375 376 if Status = Completed then 377 Accept_Socket (Server, Socket, Address); 378 else 379 Socket := No_Socket; 380 end if; 381 end Accept_Socket; 382 383 --------------- 384 -- Addresses -- 385 --------------- 386 387 function Addresses 388 (E : Host_Entry_Type; 389 N : Positive := 1) return Inet_Addr_Type 390 is 391 begin 392 return E.Addresses (N); 393 end Addresses; 394 395 ---------------------- 396 -- Addresses_Length -- 397 ---------------------- 398 399 function Addresses_Length (E : Host_Entry_Type) return Natural is 400 begin 401 return E.Addresses_Length; 402 end Addresses_Length; 403 404 ------------- 405 -- Aliases -- 406 ------------- 407 408 function Aliases 409 (E : Host_Entry_Type; 410 N : Positive := 1) return String 411 is 412 begin 413 return To_String (E.Aliases (N)); 414 end Aliases; 415 416 ------------- 417 -- Aliases -- 418 ------------- 419 420 function Aliases 421 (S : Service_Entry_Type; 422 N : Positive := 1) return String 423 is 424 begin 425 return To_String (S.Aliases (N)); 426 end Aliases; 427 428 -------------------- 429 -- Aliases_Length -- 430 -------------------- 431 432 function Aliases_Length (E : Host_Entry_Type) return Natural is 433 begin 434 return E.Aliases_Length; 435 end Aliases_Length; 436 437 -------------------- 438 -- Aliases_Length -- 439 -------------------- 440 441 function Aliases_Length (S : Service_Entry_Type) return Natural is 442 begin 443 return S.Aliases_Length; 444 end Aliases_Length; 445 446 ----------------- 447 -- Bind_Socket -- 448 ----------------- 449 450 procedure Bind_Socket 451 (Socket : Socket_Type; 452 Address : Sock_Addr_Type) 453 is 454 Res : C.int; 455 Sin : aliased Sockaddr_In; 456 Len : constant C.int := Sin'Size / 8; 457 -- This assumes that Address.Family = Family_Inet??? 458 459 begin 460 if Address.Family = Family_Inet6 then 461 raise Socket_Error with "IPv6 not supported"; 462 end if; 463 464 Set_Family (Sin.Sin_Family, Address.Family); 465 Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr)); 466 Set_Port 467 (Sin'Unchecked_Access, 468 Short_To_Network (C.unsigned_short (Address.Port))); 469 470 Res := C_Bind (C.int (Socket), Sin'Address, Len); 471 472 if Res = Failure then 473 Raise_Socket_Error (Socket_Errno); 474 end if; 475 end Bind_Socket; 476 477 ---------------------- 478 -- Check_For_Fd_Set -- 479 ---------------------- 480 481 procedure Check_For_Fd_Set (Fd : Socket_Type) is 482 use SOSC; 483 484 begin 485 -- On Windows, fd_set is a FD_SETSIZE array of socket ids: 486 -- no check required. Warnings suppressed because condition 487 -- is known at compile time. 488 489 if Target_OS = Windows then 490 491 return; 492 493 -- On other platforms, fd_set is an FD_SETSIZE bitmap: check 494 -- that Fd is within range (otherwise behaviour is undefined). 495 496 elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then 497 raise Constraint_Error 498 with "invalid value for socket set: " & Image (Fd); 499 end if; 500 end Check_For_Fd_Set; 501 502 -------------------- 503 -- Check_Selector -- 504 -------------------- 505 506 procedure Check_Selector 507 (Selector : Selector_Type; 508 R_Socket_Set : in out Socket_Set_Type; 509 W_Socket_Set : in out Socket_Set_Type; 510 Status : out Selector_Status; 511 Timeout : Selector_Duration := Forever) 512 is 513 E_Socket_Set : Socket_Set_Type; 514 begin 515 Check_Selector 516 (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout); 517 end Check_Selector; 518 519 procedure Check_Selector 520 (Selector : Selector_Type; 521 R_Socket_Set : in out Socket_Set_Type; 522 W_Socket_Set : in out Socket_Set_Type; 523 E_Socket_Set : in out Socket_Set_Type; 524 Status : out Selector_Status; 525 Timeout : Selector_Duration := Forever) 526 is 527 Res : C.int; 528 Last : C.int; 529 RSig : Socket_Type := No_Socket; 530 TVal : aliased Timeval; 531 TPtr : Timeval_Access; 532 533 begin 534 if not Is_Open (Selector) then 535 raise Program_Error with "closed selector"; 536 end if; 537 538 Status := Completed; 539 540 -- No timeout or Forever is indicated by a null timeval pointer 541 542 if Timeout = Forever then 543 TPtr := null; 544 else 545 TVal := To_Timeval (Timeout); 546 TPtr := TVal'Unchecked_Access; 547 end if; 548 549 -- Add read signalling socket, if present 550 551 if not Selector.Is_Null then 552 RSig := Selector.R_Sig_Socket; 553 Set (R_Socket_Set, RSig); 554 end if; 555 556 Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last), 557 C.int (W_Socket_Set.Last)), 558 C.int (E_Socket_Set.Last)); 559 560 -- Zero out fd_set for empty Socket_Set_Type objects 561 562 Normalize_Empty_Socket_Set (R_Socket_Set); 563 Normalize_Empty_Socket_Set (W_Socket_Set); 564 Normalize_Empty_Socket_Set (E_Socket_Set); 565 566 Res := 567 C_Select 568 (Last + 1, 569 R_Socket_Set.Set'Access, 570 W_Socket_Set.Set'Access, 571 E_Socket_Set.Set'Access, 572 TPtr); 573 574 if Res = Failure then 575 Raise_Socket_Error (Socket_Errno); 576 end if; 577 578 -- If Select was resumed because of read signalling socket, read this 579 -- data and remove socket from set. 580 581 if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then 582 Clear (R_Socket_Set, RSig); 583 584 Res := Signalling_Fds.Read (C.int (RSig)); 585 586 if Res = Failure then 587 Raise_Socket_Error (Socket_Errno); 588 end if; 589 590 Status := Aborted; 591 592 elsif Res = 0 then 593 Status := Expired; 594 end if; 595 596 -- Update socket sets in regard to their new contents 597 598 Narrow (R_Socket_Set); 599 Narrow (W_Socket_Set); 600 Narrow (E_Socket_Set); 601 end Check_Selector; 602 603 ----------- 604 -- Clear -- 605 ----------- 606 607 procedure Clear 608 (Item : in out Socket_Set_Type; 609 Socket : Socket_Type) 610 is 611 Last : aliased C.int := C.int (Item.Last); 612 613 begin 614 Check_For_Fd_Set (Socket); 615 616 if Item.Last /= No_Socket then 617 Remove_Socket_From_Set (Item.Set'Access, C.int (Socket)); 618 Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access); 619 Item.Last := Socket_Type (Last); 620 end if; 621 end Clear; 622 623 -------------------- 624 -- Close_Selector -- 625 -------------------- 626 627 procedure Close_Selector (Selector : in out Selector_Type) is 628 begin 629 -- Nothing to do if selector already in closed state 630 631 if Selector.Is_Null or else not Is_Open (Selector) then 632 return; 633 end if; 634 635 -- Close the signalling file descriptors used internally for the 636 -- implementation of Abort_Selector. 637 638 Signalling_Fds.Close (C.int (Selector.R_Sig_Socket)); 639 Signalling_Fds.Close (C.int (Selector.W_Sig_Socket)); 640 641 -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any 642 -- (erroneous) subsequent attempt to use this selector properly fails. 643 644 Selector.R_Sig_Socket := No_Socket; 645 Selector.W_Sig_Socket := No_Socket; 646 end Close_Selector; 647 648 ------------------ 649 -- Close_Socket -- 650 ------------------ 651 652 procedure Close_Socket (Socket : Socket_Type) is 653 Res : C.int; 654 655 begin 656 Res := C_Close (C.int (Socket)); 657 658 if Res = Failure then 659 Raise_Socket_Error (Socket_Errno); 660 end if; 661 end Close_Socket; 662 663 -------------------- 664 -- Connect_Socket -- 665 -------------------- 666 667 function Connect_Socket 668 (Socket : Socket_Type; 669 Server : Sock_Addr_Type) return C.int 670 is 671 Sin : aliased Sockaddr_In; 672 Len : constant C.int := Sin'Size / 8; 673 674 begin 675 if Server.Family = Family_Inet6 then 676 raise Socket_Error with "IPv6 not supported"; 677 end if; 678 679 Set_Family (Sin.Sin_Family, Server.Family); 680 Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr)); 681 Set_Port 682 (Sin'Unchecked_Access, 683 Short_To_Network (C.unsigned_short (Server.Port))); 684 685 return C_Connect (C.int (Socket), Sin'Address, Len); 686 end Connect_Socket; 687 688 procedure Connect_Socket 689 (Socket : Socket_Type; 690 Server : Sock_Addr_Type) 691 is 692 begin 693 if Connect_Socket (Socket, Server) = Failure then 694 Raise_Socket_Error (Socket_Errno); 695 end if; 696 end Connect_Socket; 697 698 procedure Connect_Socket 699 (Socket : Socket_Type; 700 Server : Sock_Addr_Type; 701 Timeout : Selector_Duration; 702 Selector : access Selector_Type := null; 703 Status : out Selector_Status) 704 is 705 Req : Request_Type; 706 -- Used to set Socket to non-blocking I/O 707 708 Conn_Err : aliased Integer; 709 -- Error status of the socket after completion of select(2) 710 711 Res : C.int; 712 Conn_Err_Size : aliased C.int := Conn_Err'Size / 8; 713 -- For getsockopt(2) call 714 715 begin 716 if Selector /= null and then not Is_Open (Selector.all) then 717 raise Program_Error with "closed selector"; 718 end if; 719 720 -- Set the socket to non-blocking I/O 721 722 Req := (Name => Non_Blocking_IO, Enabled => True); 723 Control_Socket (Socket, Request => Req); 724 725 -- Start operation (non-blocking), will return Failure with errno set 726 -- to EINPROGRESS. 727 728 Res := Connect_Socket (Socket, Server); 729 if Res = Failure then 730 Conn_Err := Socket_Errno; 731 if Conn_Err /= SOSC.EINPROGRESS then 732 Raise_Socket_Error (Conn_Err); 733 end if; 734 end if; 735 736 -- Wait for socket to become available for writing (unless the Timeout 737 -- is zero, in which case we consider that it has already expired, and 738 -- we do not need to wait at all). 739 740 if Timeout = 0.0 then 741 Status := Expired; 742 743 else 744 Wait_On_Socket 745 (Socket => Socket, 746 For_Read => False, 747 Timeout => Timeout, 748 Selector => Selector, 749 Status => Status); 750 end if; 751 752 -- Check error condition (the asynchronous connect may have terminated 753 -- with an error, e.g. ECONNREFUSED) if select(2) completed. 754 755 if Status = Completed then 756 Res := C_Getsockopt 757 (C.int (Socket), SOSC.SOL_SOCKET, SOSC.SO_ERROR, 758 Conn_Err'Address, Conn_Err_Size'Access); 759 760 if Res /= 0 then 761 Conn_Err := Socket_Errno; 762 end if; 763 764 else 765 Conn_Err := 0; 766 end if; 767 768 -- Reset the socket to blocking I/O 769 770 Req := (Name => Non_Blocking_IO, Enabled => False); 771 Control_Socket (Socket, Request => Req); 772 773 -- Report error condition if any 774 775 if Conn_Err /= 0 then 776 Raise_Socket_Error (Conn_Err); 777 end if; 778 end Connect_Socket; 779 780 -------------------- 781 -- Control_Socket -- 782 -------------------- 783 784 procedure Control_Socket 785 (Socket : Socket_Type; 786 Request : in out Request_Type) 787 is 788 Arg : aliased C.int; 789 Res : C.int; 790 791 begin 792 case Request.Name is 793 when Non_Blocking_IO => 794 Arg := C.int (Boolean'Pos (Request.Enabled)); 795 796 when N_Bytes_To_Read => 797 null; 798 end case; 799 800 Res := Socket_Ioctl 801 (C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access); 802 803 if Res = Failure then 804 Raise_Socket_Error (Socket_Errno); 805 end if; 806 807 case Request.Name is 808 when Non_Blocking_IO => 809 null; 810 811 when N_Bytes_To_Read => 812 Request.Size := Natural (Arg); 813 end case; 814 end Control_Socket; 815 816 ---------- 817 -- Copy -- 818 ---------- 819 820 procedure Copy 821 (Source : Socket_Set_Type; 822 Target : out Socket_Set_Type) 823 is 824 begin 825 Target := Source; 826 end Copy; 827 828 --------------------- 829 -- Create_Selector -- 830 --------------------- 831 832 procedure Create_Selector (Selector : out Selector_Type) is 833 Two_Fds : aliased Fd_Pair; 834 Res : C.int; 835 836 begin 837 if Is_Open (Selector) then 838 -- Raise exception to prevent socket descriptor leak 839 840 raise Program_Error with "selector already open"; 841 end if; 842 843 -- We open two signalling file descriptors. One of them is used to send 844 -- data to the other, which is included in a C_Select socket set. The 845 -- communication is used to force a call to C_Select to complete, and 846 -- the waiting task to resume its execution. 847 848 Res := Signalling_Fds.Create (Two_Fds'Access); 849 850 if Res = Failure then 851 Raise_Socket_Error (Socket_Errno); 852 end if; 853 854 Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End)); 855 Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End)); 856 end Create_Selector; 857 858 ------------------- 859 -- Create_Socket -- 860 ------------------- 861 862 procedure Create_Socket 863 (Socket : out Socket_Type; 864 Family : Family_Type := Family_Inet; 865 Mode : Mode_Type := Socket_Stream) 866 is 867 Res : C.int; 868 869 begin 870 Res := C_Socket (Families (Family), Modes (Mode), 0); 871 872 if Res = Failure then 873 Raise_Socket_Error (Socket_Errno); 874 end if; 875 876 Socket := Socket_Type (Res); 877 end Create_Socket; 878 879 ----------- 880 -- Empty -- 881 ----------- 882 883 procedure Empty (Item : out Socket_Set_Type) is 884 begin 885 Reset_Socket_Set (Item.Set'Access); 886 Item.Last := No_Socket; 887 end Empty; 888 889 -------------------- 890 -- Err_Code_Image -- 891 -------------------- 892 893 function Err_Code_Image (E : Integer) return String is 894 Msg : String := E'Img & "] "; 895 begin 896 Msg (Msg'First) := '['; 897 return Msg; 898 end Err_Code_Image; 899 900 -------------- 901 -- Finalize -- 902 -------------- 903 904 procedure Finalize (X : in out Sockets_Library_Controller) is 905 pragma Unreferenced (X); 906 907 begin 908 -- Finalization operation for the GNAT.Sockets package 909 910 Thin.Finalize; 911 end Finalize; 912 913 -------------- 914 -- Finalize -- 915 -------------- 916 917 procedure Finalize is 918 begin 919 -- This is a dummy placeholder for an obsolete API. 920 -- The real finalization actions are in Initialize primitive operation 921 -- of Sockets_Library_Controller. 922 923 null; 924 end Finalize; 925 926 --------- 927 -- Get -- 928 --------- 929 930 procedure Get 931 (Item : in out Socket_Set_Type; 932 Socket : out Socket_Type) 933 is 934 S : aliased C.int; 935 L : aliased C.int := C.int (Item.Last); 936 937 begin 938 if Item.Last /= No_Socket then 939 Get_Socket_From_Set 940 (Item.Set'Access, Last => L'Access, Socket => S'Access); 941 Item.Last := Socket_Type (L); 942 Socket := Socket_Type (S); 943 else 944 Socket := No_Socket; 945 end if; 946 end Get; 947 948 ----------------- 949 -- Get_Address -- 950 ----------------- 951 952 function Get_Address 953 (Stream : not null Stream_Access) return Sock_Addr_Type 954 is 955 begin 956 if Stream.all in Datagram_Socket_Stream_Type then 957 return Datagram_Socket_Stream_Type (Stream.all).From; 958 else 959 return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket); 960 end if; 961 end Get_Address; 962 963 ------------------------- 964 -- Get_Host_By_Address -- 965 ------------------------- 966 967 function Get_Host_By_Address 968 (Address : Inet_Addr_Type; 969 Family : Family_Type := Family_Inet) return Host_Entry_Type 970 is 971 pragma Unreferenced (Family); 972 973 HA : aliased In_Addr := To_In_Addr (Address); 974 Buflen : constant C.int := Netdb_Buffer_Size; 975 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); 976 Res : aliased Hostent; 977 Err : aliased C.int; 978 979 begin 980 Netdb_Lock; 981 982 if C_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET, 983 Res'Access, Buf'Address, Buflen, Err'Access) /= 0 984 then 985 Netdb_Unlock; 986 Raise_Host_Error (Integer (Err)); 987 end if; 988 989 return H : constant Host_Entry_Type := 990 To_Host_Entry (Res'Unchecked_Access) 991 do 992 Netdb_Unlock; 993 end return; 994 end Get_Host_By_Address; 995 996 ---------------------- 997 -- Get_Host_By_Name -- 998 ---------------------- 999 1000 function Get_Host_By_Name (Name : String) return Host_Entry_Type is 1001 begin 1002 -- Detect IP address name and redirect to Inet_Addr 1003 1004 if Is_IP_Address (Name) then 1005 return Get_Host_By_Address (Inet_Addr (Name)); 1006 end if; 1007 1008 declare 1009 HN : constant C.char_array := C.To_C (Name); 1010 Buflen : constant C.int := Netdb_Buffer_Size; 1011 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); 1012 Res : aliased Hostent; 1013 Err : aliased C.int; 1014 1015 begin 1016 Netdb_Lock; 1017 1018 if C_Gethostbyname 1019 (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 1020 then 1021 Netdb_Unlock; 1022 Raise_Host_Error (Integer (Err)); 1023 end if; 1024 1025 return H : constant Host_Entry_Type := 1026 To_Host_Entry (Res'Unchecked_Access) 1027 do 1028 Netdb_Unlock; 1029 end return; 1030 end; 1031 end Get_Host_By_Name; 1032 1033 ------------------- 1034 -- Get_Peer_Name -- 1035 ------------------- 1036 1037 function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is 1038 Sin : aliased Sockaddr_In; 1039 Len : aliased C.int := Sin'Size / 8; 1040 Res : Sock_Addr_Type (Family_Inet); 1041 1042 begin 1043 if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then 1044 Raise_Socket_Error (Socket_Errno); 1045 end if; 1046 1047 To_Inet_Addr (Sin.Sin_Addr, Res.Addr); 1048 Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); 1049 1050 return Res; 1051 end Get_Peer_Name; 1052 1053 ------------------------- 1054 -- Get_Service_By_Name -- 1055 ------------------------- 1056 1057 function Get_Service_By_Name 1058 (Name : String; 1059 Protocol : String) return Service_Entry_Type 1060 is 1061 SN : constant C.char_array := C.To_C (Name); 1062 SP : constant C.char_array := C.To_C (Protocol); 1063 Buflen : constant C.int := Netdb_Buffer_Size; 1064 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); 1065 Res : aliased Servent; 1066 1067 begin 1068 Netdb_Lock; 1069 1070 if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then 1071 Netdb_Unlock; 1072 raise Service_Error with "Service not found"; 1073 end if; 1074 1075 -- Translate from the C format to the API format 1076 1077 return S : constant Service_Entry_Type := 1078 To_Service_Entry (Res'Unchecked_Access) 1079 do 1080 Netdb_Unlock; 1081 end return; 1082 end Get_Service_By_Name; 1083 1084 ------------------------- 1085 -- Get_Service_By_Port -- 1086 ------------------------- 1087 1088 function Get_Service_By_Port 1089 (Port : Port_Type; 1090 Protocol : String) return Service_Entry_Type 1091 is 1092 SP : constant C.char_array := C.To_C (Protocol); 1093 Buflen : constant C.int := Netdb_Buffer_Size; 1094 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); 1095 Res : aliased Servent; 1096 1097 begin 1098 Netdb_Lock; 1099 1100 if C_Getservbyport 1101 (C.int (Short_To_Network (C.unsigned_short (Port))), SP, 1102 Res'Access, Buf'Address, Buflen) /= 0 1103 then 1104 Netdb_Unlock; 1105 raise Service_Error with "Service not found"; 1106 end if; 1107 1108 -- Translate from the C format to the API format 1109 1110 return S : constant Service_Entry_Type := 1111 To_Service_Entry (Res'Unchecked_Access) 1112 do 1113 Netdb_Unlock; 1114 end return; 1115 end Get_Service_By_Port; 1116 1117 --------------------- 1118 -- Get_Socket_Name -- 1119 --------------------- 1120 1121 function Get_Socket_Name 1122 (Socket : Socket_Type) return Sock_Addr_Type 1123 is 1124 Sin : aliased Sockaddr_In; 1125 Len : aliased C.int := Sin'Size / 8; 1126 Res : C.int; 1127 Addr : Sock_Addr_Type := No_Sock_Addr; 1128 1129 begin 1130 Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access); 1131 1132 if Res /= Failure then 1133 To_Inet_Addr (Sin.Sin_Addr, Addr.Addr); 1134 Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); 1135 end if; 1136 1137 return Addr; 1138 end Get_Socket_Name; 1139 1140 ----------------------- 1141 -- Get_Socket_Option -- 1142 ----------------------- 1143 1144 function Get_Socket_Option 1145 (Socket : Socket_Type; 1146 Level : Level_Type := Socket_Level; 1147 Name : Option_Name) return Option_Type 1148 is 1149 use SOSC; 1150 use type C.unsigned_char; 1151 1152 V8 : aliased Two_Ints; 1153 V4 : aliased C.int; 1154 V1 : aliased C.unsigned_char; 1155 VT : aliased Timeval; 1156 Len : aliased C.int; 1157 Add : System.Address; 1158 Res : C.int; 1159 Opt : Option_Type (Name); 1160 1161 begin 1162 case Name is 1163 when Multicast_Loop | 1164 Multicast_TTL | 1165 Receive_Packet_Info => 1166 Len := V1'Size / 8; 1167 Add := V1'Address; 1168 1169 when Keep_Alive | 1170 Reuse_Address | 1171 Broadcast | 1172 No_Delay | 1173 Send_Buffer | 1174 Receive_Buffer | 1175 Multicast_If | 1176 Error => 1177 Len := V4'Size / 8; 1178 Add := V4'Address; 1179 1180 when Send_Timeout | 1181 Receive_Timeout => 1182 1183 -- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a 1184 -- struct timeval, but on Windows it is a milliseconds count in 1185 -- a DWORD. 1186 1187 if Target_OS = Windows then 1188 Len := V4'Size / 8; 1189 Add := V4'Address; 1190 1191 else 1192 Len := VT'Size / 8; 1193 Add := VT'Address; 1194 end if; 1195 1196 when Linger | 1197 Add_Membership | 1198 Drop_Membership => 1199 Len := V8'Size / 8; 1200 Add := V8'Address; 1201 1202 end case; 1203 1204 Res := 1205 C_Getsockopt 1206 (C.int (Socket), 1207 Levels (Level), 1208 Options (Name), 1209 Add, Len'Access); 1210 1211 if Res = Failure then 1212 Raise_Socket_Error (Socket_Errno); 1213 end if; 1214 1215 case Name is 1216 when Keep_Alive | 1217 Reuse_Address | 1218 Broadcast | 1219 No_Delay => 1220 Opt.Enabled := (V4 /= 0); 1221 1222 when Linger => 1223 Opt.Enabled := (V8 (V8'First) /= 0); 1224 Opt.Seconds := Natural (V8 (V8'Last)); 1225 1226 when Send_Buffer | 1227 Receive_Buffer => 1228 Opt.Size := Natural (V4); 1229 1230 when Error => 1231 Opt.Error := Resolve_Error (Integer (V4)); 1232 1233 when Add_Membership | 1234 Drop_Membership => 1235 To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address); 1236 To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface); 1237 1238 when Multicast_If => 1239 To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If); 1240 1241 when Multicast_TTL => 1242 Opt.Time_To_Live := Integer (V1); 1243 1244 when Multicast_Loop | 1245 Receive_Packet_Info => 1246 Opt.Enabled := (V1 /= 0); 1247 1248 when Send_Timeout | 1249 Receive_Timeout => 1250 1251 if Target_OS = Windows then 1252 1253 -- Timeout is in milliseconds, actual value is 500 ms + 1254 -- returned value (unless it is 0). 1255 1256 if V4 = 0 then 1257 Opt.Timeout := 0.0; 1258 else 1259 Opt.Timeout := Natural (V4) * 0.001 + 0.500; 1260 end if; 1261 1262 else 1263 Opt.Timeout := To_Duration (VT); 1264 end if; 1265 end case; 1266 1267 return Opt; 1268 end Get_Socket_Option; 1269 1270 --------------- 1271 -- Host_Name -- 1272 --------------- 1273 1274 function Host_Name return String is 1275 Name : aliased C.char_array (1 .. 64); 1276 Res : C.int; 1277 1278 begin 1279 Res := C_Gethostname (Name'Address, Name'Length); 1280 1281 if Res = Failure then 1282 Raise_Socket_Error (Socket_Errno); 1283 end if; 1284 1285 return C.To_Ada (Name); 1286 end Host_Name; 1287 1288 ----------- 1289 -- Image -- 1290 ----------- 1291 1292 function Image 1293 (Val : Inet_Addr_VN_Type; 1294 Hex : Boolean := False) return String 1295 is 1296 -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It 1297 -- has at most a length of 3 plus one '.' character. 1298 1299 Buffer : String (1 .. 4 * Val'Length); 1300 Length : Natural := 1; 1301 Separator : Character; 1302 1303 procedure Img10 (V : Inet_Addr_Comp_Type); 1304 -- Append to Buffer image of V in decimal format 1305 1306 procedure Img16 (V : Inet_Addr_Comp_Type); 1307 -- Append to Buffer image of V in hexadecimal format 1308 1309 ----------- 1310 -- Img10 -- 1311 ----------- 1312 1313 procedure Img10 (V : Inet_Addr_Comp_Type) is 1314 Img : constant String := V'Img; 1315 Len : constant Natural := Img'Length - 1; 1316 begin 1317 Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last); 1318 Length := Length + Len; 1319 end Img10; 1320 1321 ----------- 1322 -- Img16 -- 1323 ----------- 1324 1325 procedure Img16 (V : Inet_Addr_Comp_Type) is 1326 begin 1327 Buffer (Length) := Hex_To_Char (Natural (V / 16) + 1); 1328 Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1); 1329 Length := Length + 2; 1330 end Img16; 1331 1332 -- Start of processing for Image 1333 1334 begin 1335 Separator := (if Hex then ':' else '.'); 1336 1337 for J in Val'Range loop 1338 if Hex then 1339 Img16 (Val (J)); 1340 else 1341 Img10 (Val (J)); 1342 end if; 1343 1344 if J /= Val'Last then 1345 Buffer (Length) := Separator; 1346 Length := Length + 1; 1347 end if; 1348 end loop; 1349 1350 return Buffer (1 .. Length - 1); 1351 end Image; 1352 1353 ----------- 1354 -- Image -- 1355 ----------- 1356 1357 function Image (Value : Inet_Addr_Type) return String is 1358 begin 1359 if Value.Family = Family_Inet then 1360 return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False); 1361 else 1362 return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True); 1363 end if; 1364 end Image; 1365 1366 ----------- 1367 -- Image -- 1368 ----------- 1369 1370 function Image (Value : Sock_Addr_Type) return String is 1371 Port : constant String := Value.Port'Img; 1372 begin 1373 return Image (Value.Addr) & ':' & Port (2 .. Port'Last); 1374 end Image; 1375 1376 ----------- 1377 -- Image -- 1378 ----------- 1379 1380 function Image (Socket : Socket_Type) return String is 1381 begin 1382 return Socket'Img; 1383 end Image; 1384 1385 ----------- 1386 -- Image -- 1387 ----------- 1388 1389 function Image (Item : Socket_Set_Type) return String is 1390 Socket_Set : Socket_Set_Type := Item; 1391 1392 begin 1393 declare 1394 Last_Img : constant String := Socket_Set.Last'Img; 1395 Buffer : String 1396 (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length); 1397 Index : Positive := 1; 1398 Socket : Socket_Type; 1399 1400 begin 1401 while not Is_Empty (Socket_Set) loop 1402 Get (Socket_Set, Socket); 1403 1404 declare 1405 Socket_Img : constant String := Socket'Img; 1406 begin 1407 Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img; 1408 Index := Index + Socket_Img'Length; 1409 end; 1410 end loop; 1411 1412 return "[" & Last_Img & "]" & Buffer (1 .. Index - 1); 1413 end; 1414 end Image; 1415 1416 --------------- 1417 -- Inet_Addr -- 1418 --------------- 1419 1420 function Inet_Addr (Image : String) return Inet_Addr_Type is 1421 use Interfaces.C; 1422 use Interfaces.C.Strings; 1423 1424 Img : aliased char_array := To_C (Image); 1425 Addr : aliased C.int; 1426 Res : C.int; 1427 Result : Inet_Addr_Type; 1428 1429 begin 1430 -- Special case for an empty Image as on some platforms (e.g. Windows) 1431 -- calling Inet_Addr("") will not return an error. 1432 1433 if Image = "" then 1434 Raise_Socket_Error (SOSC.EINVAL); 1435 end if; 1436 1437 Res := Inet_Pton (SOSC.AF_INET, Img'Address, Addr'Address); 1438 1439 if Res < 0 then 1440 Raise_Socket_Error (Socket_Errno); 1441 1442 elsif Res = 0 then 1443 Raise_Socket_Error (SOSC.EINVAL); 1444 end if; 1445 1446 To_Inet_Addr (To_In_Addr (Addr), Result); 1447 return Result; 1448 end Inet_Addr; 1449 1450 ---------------- 1451 -- Initialize -- 1452 ---------------- 1453 1454 procedure Initialize (X : in out Sockets_Library_Controller) is 1455 pragma Unreferenced (X); 1456 1457 begin 1458 Thin.Initialize; 1459 end Initialize; 1460 1461 ---------------- 1462 -- Initialize -- 1463 ---------------- 1464 1465 procedure Initialize (Process_Blocking_IO : Boolean) is 1466 Expected : constant Boolean := not SOSC.Thread_Blocking_IO; 1467 1468 begin 1469 if Process_Blocking_IO /= Expected then 1470 raise Socket_Error with 1471 "incorrect Process_Blocking_IO setting, expected " & Expected'Img; 1472 end if; 1473 1474 -- This is a dummy placeholder for an obsolete API 1475 1476 -- Real initialization actions are in Initialize primitive operation 1477 -- of Sockets_Library_Controller. 1478 1479 null; 1480 end Initialize; 1481 1482 ---------------- 1483 -- Initialize -- 1484 ---------------- 1485 1486 procedure Initialize is 1487 begin 1488 -- This is a dummy placeholder for an obsolete API 1489 1490 -- Real initialization actions are in Initialize primitive operation 1491 -- of Sockets_Library_Controller. 1492 1493 null; 1494 end Initialize; 1495 1496 -------------- 1497 -- Is_Empty -- 1498 -------------- 1499 1500 function Is_Empty (Item : Socket_Set_Type) return Boolean is 1501 begin 1502 return Item.Last = No_Socket; 1503 end Is_Empty; 1504 1505 ------------------- 1506 -- Is_IP_Address -- 1507 ------------------- 1508 1509 function Is_IP_Address (Name : String) return Boolean is 1510 begin 1511 for J in Name'Range loop 1512 if Name (J) /= '.' 1513 and then Name (J) not in '0' .. '9' 1514 then 1515 return False; 1516 end if; 1517 end loop; 1518 1519 return True; 1520 end Is_IP_Address; 1521 1522 ------------- 1523 -- Is_Open -- 1524 ------------- 1525 1526 function Is_Open (S : Selector_Type) return Boolean is 1527 begin 1528 if S.Is_Null then 1529 return True; 1530 1531 else 1532 -- Either both controlling socket descriptors are valid (case of an 1533 -- open selector) or neither (case of a closed selector). 1534 1535 pragma Assert ((S.R_Sig_Socket /= No_Socket) 1536 = 1537 (S.W_Sig_Socket /= No_Socket)); 1538 1539 return S.R_Sig_Socket /= No_Socket; 1540 end if; 1541 end Is_Open; 1542 1543 ------------ 1544 -- Is_Set -- 1545 ------------ 1546 1547 function Is_Set 1548 (Item : Socket_Set_Type; 1549 Socket : Socket_Type) return Boolean 1550 is 1551 begin 1552 Check_For_Fd_Set (Socket); 1553 1554 return Item.Last /= No_Socket 1555 and then Socket <= Item.Last 1556 and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0; 1557 end Is_Set; 1558 1559 ------------------- 1560 -- Listen_Socket -- 1561 ------------------- 1562 1563 procedure Listen_Socket 1564 (Socket : Socket_Type; 1565 Length : Natural := 15) 1566 is 1567 Res : constant C.int := C_Listen (C.int (Socket), C.int (Length)); 1568 begin 1569 if Res = Failure then 1570 Raise_Socket_Error (Socket_Errno); 1571 end if; 1572 end Listen_Socket; 1573 1574 ------------ 1575 -- Narrow -- 1576 ------------ 1577 1578 procedure Narrow (Item : in out Socket_Set_Type) is 1579 Last : aliased C.int := C.int (Item.Last); 1580 begin 1581 if Item.Last /= No_Socket then 1582 Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access); 1583 Item.Last := Socket_Type (Last); 1584 end if; 1585 end Narrow; 1586 1587 ---------------- 1588 -- Netdb_Lock -- 1589 ---------------- 1590 1591 procedure Netdb_Lock is 1592 begin 1593 if Need_Netdb_Lock then 1594 System.Task_Lock.Lock; 1595 end if; 1596 end Netdb_Lock; 1597 1598 ------------------ 1599 -- Netdb_Unlock -- 1600 ------------------ 1601 1602 procedure Netdb_Unlock is 1603 begin 1604 if Need_Netdb_Lock then 1605 System.Task_Lock.Unlock; 1606 end if; 1607 end Netdb_Unlock; 1608 1609 -------------------------------- 1610 -- Normalize_Empty_Socket_Set -- 1611 -------------------------------- 1612 1613 procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is 1614 begin 1615 if S.Last = No_Socket then 1616 Reset_Socket_Set (S.Set'Access); 1617 end if; 1618 end Normalize_Empty_Socket_Set; 1619 1620 ------------------- 1621 -- Official_Name -- 1622 ------------------- 1623 1624 function Official_Name (E : Host_Entry_Type) return String is 1625 begin 1626 return To_String (E.Official); 1627 end Official_Name; 1628 1629 ------------------- 1630 -- Official_Name -- 1631 ------------------- 1632 1633 function Official_Name (S : Service_Entry_Type) return String is 1634 begin 1635 return To_String (S.Official); 1636 end Official_Name; 1637 1638 -------------------- 1639 -- Wait_On_Socket -- 1640 -------------------- 1641 1642 procedure Wait_On_Socket 1643 (Socket : Socket_Type; 1644 For_Read : Boolean; 1645 Timeout : Selector_Duration; 1646 Selector : access Selector_Type := null; 1647 Status : out Selector_Status) 1648 is 1649 type Local_Selector_Access is access Selector_Type; 1650 for Local_Selector_Access'Storage_Size use Selector_Type'Size; 1651 1652 S : Selector_Access; 1653 -- Selector to use for waiting 1654 1655 R_Fd_Set : Socket_Set_Type; 1656 W_Fd_Set : Socket_Set_Type; 1657 1658 begin 1659 -- Create selector if not provided by the user 1660 1661 if Selector = null then 1662 declare 1663 Local_S : constant Local_Selector_Access := new Selector_Type; 1664 begin 1665 S := Local_S.all'Unchecked_Access; 1666 Create_Selector (S.all); 1667 end; 1668 1669 else 1670 S := Selector.all'Access; 1671 end if; 1672 1673 if For_Read then 1674 Set (R_Fd_Set, Socket); 1675 else 1676 Set (W_Fd_Set, Socket); 1677 end if; 1678 1679 Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout); 1680 1681 if Selector = null then 1682 Close_Selector (S.all); 1683 end if; 1684 end Wait_On_Socket; 1685 1686 ----------------- 1687 -- Port_Number -- 1688 ----------------- 1689 1690 function Port_Number (S : Service_Entry_Type) return Port_Type is 1691 begin 1692 return S.Port; 1693 end Port_Number; 1694 1695 ------------------- 1696 -- Protocol_Name -- 1697 ------------------- 1698 1699 function Protocol_Name (S : Service_Entry_Type) return String is 1700 begin 1701 return To_String (S.Protocol); 1702 end Protocol_Name; 1703 1704 ---------------------- 1705 -- Raise_Host_Error -- 1706 ---------------------- 1707 1708 procedure Raise_Host_Error (H_Error : Integer) is 1709 begin 1710 raise Host_Error with 1711 Err_Code_Image (H_Error) 1712 & Host_Error_Messages.Host_Error_Message (H_Error); 1713 end Raise_Host_Error; 1714 1715 ------------------------ 1716 -- Raise_Socket_Error -- 1717 ------------------------ 1718 1719 procedure Raise_Socket_Error (Error : Integer) is 1720 use type C.Strings.chars_ptr; 1721 begin 1722 raise Socket_Error with 1723 Err_Code_Image (Error) & Socket_Error_Message (Error); 1724 end Raise_Socket_Error; 1725 1726 ---------- 1727 -- Read -- 1728 ---------- 1729 1730 procedure Read 1731 (Stream : in out Datagram_Socket_Stream_Type; 1732 Item : out Ada.Streams.Stream_Element_Array; 1733 Last : out Ada.Streams.Stream_Element_Offset) 1734 is 1735 First : Ada.Streams.Stream_Element_Offset := Item'First; 1736 Index : Ada.Streams.Stream_Element_Offset := First - 1; 1737 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; 1738 1739 begin 1740 loop 1741 Receive_Socket 1742 (Stream.Socket, 1743 Item (First .. Max), 1744 Index, 1745 Stream.From); 1746 1747 Last := Index; 1748 1749 -- Exit when all or zero data received. Zero means that the socket 1750 -- peer is closed. 1751 1752 exit when Index < First or else Index = Max; 1753 1754 First := Index + 1; 1755 end loop; 1756 end Read; 1757 1758 ---------- 1759 -- Read -- 1760 ---------- 1761 1762 procedure Read 1763 (Stream : in out Stream_Socket_Stream_Type; 1764 Item : out Ada.Streams.Stream_Element_Array; 1765 Last : out Ada.Streams.Stream_Element_Offset) 1766 is 1767 First : Ada.Streams.Stream_Element_Offset := Item'First; 1768 Index : Ada.Streams.Stream_Element_Offset := First - 1; 1769 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; 1770 1771 begin 1772 loop 1773 Receive_Socket (Stream.Socket, Item (First .. Max), Index); 1774 Last := Index; 1775 1776 -- Exit when all or zero data received. Zero means that the socket 1777 -- peer is closed. 1778 1779 exit when Index < First or else Index = Max; 1780 1781 First := Index + 1; 1782 end loop; 1783 end Read; 1784 1785 -------------------- 1786 -- Receive_Socket -- 1787 -------------------- 1788 1789 procedure Receive_Socket 1790 (Socket : Socket_Type; 1791 Item : out Ada.Streams.Stream_Element_Array; 1792 Last : out Ada.Streams.Stream_Element_Offset; 1793 Flags : Request_Flag_Type := No_Request_Flag) 1794 is 1795 Res : C.int; 1796 1797 begin 1798 Res := 1799 C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags)); 1800 1801 if Res = Failure then 1802 Raise_Socket_Error (Socket_Errno); 1803 end if; 1804 1805 Last := Last_Index (First => Item'First, Count => size_t (Res)); 1806 end Receive_Socket; 1807 1808 -------------------- 1809 -- Receive_Socket -- 1810 -------------------- 1811 1812 procedure Receive_Socket 1813 (Socket : Socket_Type; 1814 Item : out Ada.Streams.Stream_Element_Array; 1815 Last : out Ada.Streams.Stream_Element_Offset; 1816 From : out Sock_Addr_Type; 1817 Flags : Request_Flag_Type := No_Request_Flag) 1818 is 1819 Res : C.int; 1820 Sin : aliased Sockaddr_In; 1821 Len : aliased C.int := Sin'Size / 8; 1822 1823 begin 1824 Res := 1825 C_Recvfrom 1826 (C.int (Socket), 1827 Item'Address, 1828 Item'Length, 1829 To_Int (Flags), 1830 Sin'Address, 1831 Len'Access); 1832 1833 if Res = Failure then 1834 Raise_Socket_Error (Socket_Errno); 1835 end if; 1836 1837 Last := Last_Index (First => Item'First, Count => size_t (Res)); 1838 1839 To_Inet_Addr (Sin.Sin_Addr, From.Addr); 1840 From.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); 1841 end Receive_Socket; 1842 1843 -------------------- 1844 -- Receive_Vector -- 1845 -------------------- 1846 1847 procedure Receive_Vector 1848 (Socket : Socket_Type; 1849 Vector : Vector_Type; 1850 Count : out Ada.Streams.Stream_Element_Count; 1851 Flags : Request_Flag_Type := No_Request_Flag) 1852 is 1853 Res : ssize_t; 1854 1855 Msg : Msghdr := 1856 (Msg_Name => System.Null_Address, 1857 Msg_Namelen => 0, 1858 Msg_Iov => Vector'Address, 1859 1860 -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other 1861 -- platforms) when the supplied vector is longer than IOV_MAX, 1862 -- so use minimum of the two lengths. 1863 1864 Msg_Iovlen => SOSC.Msg_Iovlen_T'Min 1865 (Vector'Length, SOSC.IOV_MAX), 1866 1867 Msg_Control => System.Null_Address, 1868 Msg_Controllen => 0, 1869 Msg_Flags => 0); 1870 1871 begin 1872 Res := 1873 C_Recvmsg 1874 (C.int (Socket), 1875 Msg'Address, 1876 To_Int (Flags)); 1877 1878 if Res = ssize_t (Failure) then 1879 Raise_Socket_Error (Socket_Errno); 1880 end if; 1881 1882 Count := Ada.Streams.Stream_Element_Count (Res); 1883 end Receive_Vector; 1884 1885 ------------------- 1886 -- Resolve_Error -- 1887 ------------------- 1888 1889 function Resolve_Error 1890 (Error_Value : Integer; 1891 From_Errno : Boolean := True) return Error_Type 1892 is 1893 use GNAT.Sockets.SOSC; 1894 1895 begin 1896 if not From_Errno then 1897 case Error_Value is 1898 when SOSC.HOST_NOT_FOUND => return Unknown_Host; 1899 when SOSC.TRY_AGAIN => return Host_Name_Lookup_Failure; 1900 when SOSC.NO_RECOVERY => return Non_Recoverable_Error; 1901 when SOSC.NO_DATA => return Unknown_Server_Error; 1902 when others => return Cannot_Resolve_Error; 1903 end case; 1904 end if; 1905 1906 -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we 1907 -- can't include it in the case statement below. 1908 1909 pragma Warnings (Off); 1910 -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time 1911 1912 if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then 1913 return Resource_Temporarily_Unavailable; 1914 end if; 1915 1916 -- This is not a case statement because if a particular error 1917 -- number constant is not defined, s-oscons-tmplt.c defines 1918 -- it to -1. If multiple constants are not defined, they 1919 -- would each be -1 and result in a "duplicate value in case" error. 1920 -- 1921 -- But we have to leave warnings off because the compiler is also 1922 -- smart enough to note that when two errnos have the same value, 1923 -- the second if condition is useless. 1924 if Error_Value = ENOERROR then 1925 return Success; 1926 elsif Error_Value = EACCES then 1927 return Permission_Denied; 1928 elsif Error_Value = EADDRINUSE then 1929 return Address_Already_In_Use; 1930 elsif Error_Value = EADDRNOTAVAIL then 1931 return Cannot_Assign_Requested_Address; 1932 elsif Error_Value = EAFNOSUPPORT then 1933 return Address_Family_Not_Supported_By_Protocol; 1934 elsif Error_Value = EALREADY then 1935 return Operation_Already_In_Progress; 1936 elsif Error_Value = EBADF then 1937 return Bad_File_Descriptor; 1938 elsif Error_Value = ECONNABORTED then 1939 return Software_Caused_Connection_Abort; 1940 elsif Error_Value = ECONNREFUSED then 1941 return Connection_Refused; 1942 elsif Error_Value = ECONNRESET then 1943 return Connection_Reset_By_Peer; 1944 elsif Error_Value = EDESTADDRREQ then 1945 return Destination_Address_Required; 1946 elsif Error_Value = EFAULT then 1947 return Bad_Address; 1948 elsif Error_Value = EHOSTDOWN then 1949 return Host_Is_Down; 1950 elsif Error_Value = EHOSTUNREACH then 1951 return No_Route_To_Host; 1952 elsif Error_Value = EINPROGRESS then 1953 return Operation_Now_In_Progress; 1954 elsif Error_Value = EINTR then 1955 return Interrupted_System_Call; 1956 elsif Error_Value = EINVAL then 1957 return Invalid_Argument; 1958 elsif Error_Value = EIO then 1959 return Input_Output_Error; 1960 elsif Error_Value = EISCONN then 1961 return Transport_Endpoint_Already_Connected; 1962 elsif Error_Value = ELOOP then 1963 return Too_Many_Symbolic_Links; 1964 elsif Error_Value = EMFILE then 1965 return Too_Many_Open_Files; 1966 elsif Error_Value = EMSGSIZE then 1967 return Message_Too_Long; 1968 elsif Error_Value = ENAMETOOLONG then 1969 return File_Name_Too_Long; 1970 elsif Error_Value = ENETDOWN then 1971 return Network_Is_Down; 1972 elsif Error_Value = ENETRESET then 1973 return Network_Dropped_Connection_Because_Of_Reset; 1974 elsif Error_Value = ENETUNREACH then 1975 return Network_Is_Unreachable; 1976 elsif Error_Value = ENOBUFS then 1977 return No_Buffer_Space_Available; 1978 elsif Error_Value = ENOPROTOOPT then 1979 return Protocol_Not_Available; 1980 elsif Error_Value = ENOTCONN then 1981 return Transport_Endpoint_Not_Connected; 1982 elsif Error_Value = ENOTSOCK then 1983 return Socket_Operation_On_Non_Socket; 1984 elsif Error_Value = EOPNOTSUPP then 1985 return Operation_Not_Supported; 1986 elsif Error_Value = EPFNOSUPPORT then 1987 return Protocol_Family_Not_Supported; 1988 elsif Error_Value = EPIPE then 1989 return Broken_Pipe; 1990 elsif Error_Value = EPROTONOSUPPORT then 1991 return Protocol_Not_Supported; 1992 elsif Error_Value = EPROTOTYPE then 1993 return Protocol_Wrong_Type_For_Socket; 1994 elsif Error_Value = ESHUTDOWN then 1995 return Cannot_Send_After_Transport_Endpoint_Shutdown; 1996 elsif Error_Value = ESOCKTNOSUPPORT then 1997 return Socket_Type_Not_Supported; 1998 elsif Error_Value = ETIMEDOUT then 1999 return Connection_Timed_Out; 2000 elsif Error_Value = ETOOMANYREFS then 2001 return Too_Many_References; 2002 elsif Error_Value = EWOULDBLOCK then 2003 return Resource_Temporarily_Unavailable; 2004 else 2005 return Cannot_Resolve_Error; 2006 end if; 2007 pragma Warnings (On); 2008 2009 end Resolve_Error; 2010 2011 ----------------------- 2012 -- Resolve_Exception -- 2013 ----------------------- 2014 2015 function Resolve_Exception 2016 (Occurrence : Exception_Occurrence) return Error_Type 2017 is 2018 Id : constant Exception_Id := Exception_Identity (Occurrence); 2019 Msg : constant String := Exception_Message (Occurrence); 2020 First : Natural; 2021 Last : Natural; 2022 Val : Integer; 2023 2024 begin 2025 First := Msg'First; 2026 while First <= Msg'Last 2027 and then Msg (First) not in '0' .. '9' 2028 loop 2029 First := First + 1; 2030 end loop; 2031 2032 if First > Msg'Last then 2033 return Cannot_Resolve_Error; 2034 end if; 2035 2036 Last := First; 2037 while Last < Msg'Last 2038 and then Msg (Last + 1) in '0' .. '9' 2039 loop 2040 Last := Last + 1; 2041 end loop; 2042 2043 Val := Integer'Value (Msg (First .. Last)); 2044 2045 if Id = Socket_Error_Id then 2046 return Resolve_Error (Val); 2047 2048 elsif Id = Host_Error_Id then 2049 return Resolve_Error (Val, False); 2050 2051 else 2052 return Cannot_Resolve_Error; 2053 end if; 2054 end Resolve_Exception; 2055 2056 ----------------- 2057 -- Send_Socket -- 2058 ----------------- 2059 2060 procedure Send_Socket 2061 (Socket : Socket_Type; 2062 Item : Ada.Streams.Stream_Element_Array; 2063 Last : out Ada.Streams.Stream_Element_Offset; 2064 Flags : Request_Flag_Type := No_Request_Flag) 2065 is 2066 begin 2067 Send_Socket (Socket, Item, Last, To => null, Flags => Flags); 2068 end Send_Socket; 2069 2070 ----------------- 2071 -- Send_Socket -- 2072 ----------------- 2073 2074 procedure Send_Socket 2075 (Socket : Socket_Type; 2076 Item : Ada.Streams.Stream_Element_Array; 2077 Last : out Ada.Streams.Stream_Element_Offset; 2078 To : Sock_Addr_Type; 2079 Flags : Request_Flag_Type := No_Request_Flag) 2080 is 2081 begin 2082 Send_Socket 2083 (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags); 2084 end Send_Socket; 2085 2086 ----------------- 2087 -- Send_Socket -- 2088 ----------------- 2089 2090 procedure Send_Socket 2091 (Socket : Socket_Type; 2092 Item : Ada.Streams.Stream_Element_Array; 2093 Last : out Ada.Streams.Stream_Element_Offset; 2094 To : access Sock_Addr_Type; 2095 Flags : Request_Flag_Type := No_Request_Flag) 2096 is 2097 Res : C.int; 2098 2099 Sin : aliased Sockaddr_In; 2100 C_To : System.Address; 2101 Len : C.int; 2102 2103 begin 2104 if To /= null then 2105 Set_Family (Sin.Sin_Family, To.Family); 2106 Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr)); 2107 Set_Port 2108 (Sin'Unchecked_Access, 2109 Short_To_Network (C.unsigned_short (To.Port))); 2110 C_To := Sin'Address; 2111 Len := Sin'Size / 8; 2112 2113 else 2114 C_To := System.Null_Address; 2115 Len := 0; 2116 end if; 2117 2118 Res := C_Sendto 2119 (C.int (Socket), 2120 Item'Address, 2121 Item'Length, 2122 Set_Forced_Flags (To_Int (Flags)), 2123 C_To, 2124 Len); 2125 2126 if Res = Failure then 2127 Raise_Socket_Error (Socket_Errno); 2128 end if; 2129 2130 Last := Last_Index (First => Item'First, Count => size_t (Res)); 2131 end Send_Socket; 2132 2133 ----------------- 2134 -- Send_Vector -- 2135 ----------------- 2136 2137 procedure Send_Vector 2138 (Socket : Socket_Type; 2139 Vector : Vector_Type; 2140 Count : out Ada.Streams.Stream_Element_Count; 2141 Flags : Request_Flag_Type := No_Request_Flag) 2142 is 2143 use SOSC; 2144 use Interfaces.C; 2145 2146 Res : ssize_t; 2147 Iov_Count : SOSC.Msg_Iovlen_T; 2148 This_Iov_Count : SOSC.Msg_Iovlen_T; 2149 Msg : Msghdr; 2150 2151 begin 2152 Count := 0; 2153 Iov_Count := 0; 2154 while Iov_Count < Vector'Length loop 2155 2156 pragma Warnings (Off); 2157 -- Following test may be compile time known on some targets 2158 2159 This_Iov_Count := 2160 (if Vector'Length - Iov_Count > SOSC.IOV_MAX 2161 then SOSC.IOV_MAX 2162 else Vector'Length - Iov_Count); 2163 2164 pragma Warnings (On); 2165 2166 Msg := 2167 (Msg_Name => System.Null_Address, 2168 Msg_Namelen => 0, 2169 Msg_Iov => Vector 2170 (Vector'First + Integer (Iov_Count))'Address, 2171 Msg_Iovlen => This_Iov_Count, 2172 Msg_Control => System.Null_Address, 2173 Msg_Controllen => 0, 2174 Msg_Flags => 0); 2175 2176 Res := 2177 C_Sendmsg 2178 (C.int (Socket), 2179 Msg'Address, 2180 Set_Forced_Flags (To_Int (Flags))); 2181 2182 if Res = ssize_t (Failure) then 2183 Raise_Socket_Error (Socket_Errno); 2184 end if; 2185 2186 Count := Count + Ada.Streams.Stream_Element_Count (Res); 2187 Iov_Count := Iov_Count + This_Iov_Count; 2188 end loop; 2189 end Send_Vector; 2190 2191 --------- 2192 -- Set -- 2193 --------- 2194 2195 procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is 2196 begin 2197 Check_For_Fd_Set (Socket); 2198 2199 if Item.Last = No_Socket then 2200 2201 -- Uninitialized socket set, make sure it is properly zeroed out 2202 2203 Reset_Socket_Set (Item.Set'Access); 2204 Item.Last := Socket; 2205 2206 elsif Item.Last < Socket then 2207 Item.Last := Socket; 2208 end if; 2209 2210 Insert_Socket_In_Set (Item.Set'Access, C.int (Socket)); 2211 end Set; 2212 2213 ----------------------- 2214 -- Set_Close_On_Exec -- 2215 ----------------------- 2216 2217 procedure Set_Close_On_Exec 2218 (Socket : Socket_Type; 2219 Close_On_Exec : Boolean; 2220 Status : out Boolean) 2221 is 2222 function C_Set_Close_On_Exec 2223 (Socket : Socket_Type; Close_On_Exec : C.int) return C.int; 2224 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); 2225 begin 2226 Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0; 2227 end Set_Close_On_Exec; 2228 2229 ---------------------- 2230 -- Set_Forced_Flags -- 2231 ---------------------- 2232 2233 function Set_Forced_Flags (F : C.int) return C.int is 2234 use type C.unsigned; 2235 function To_unsigned is 2236 new Ada.Unchecked_Conversion (C.int, C.unsigned); 2237 function To_int is 2238 new Ada.Unchecked_Conversion (C.unsigned, C.int); 2239 begin 2240 return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags); 2241 end Set_Forced_Flags; 2242 2243 ----------------------- 2244 -- Set_Socket_Option -- 2245 ----------------------- 2246 2247 procedure Set_Socket_Option 2248 (Socket : Socket_Type; 2249 Level : Level_Type := Socket_Level; 2250 Option : Option_Type) 2251 is 2252 use SOSC; 2253 2254 V8 : aliased Two_Ints; 2255 V4 : aliased C.int; 2256 V1 : aliased C.unsigned_char; 2257 VT : aliased Timeval; 2258 Len : C.int; 2259 Add : System.Address := Null_Address; 2260 Res : C.int; 2261 2262 begin 2263 case Option.Name is 2264 when Keep_Alive | 2265 Reuse_Address | 2266 Broadcast | 2267 No_Delay => 2268 V4 := C.int (Boolean'Pos (Option.Enabled)); 2269 Len := V4'Size / 8; 2270 Add := V4'Address; 2271 2272 when Linger => 2273 V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled)); 2274 V8 (V8'Last) := C.int (Option.Seconds); 2275 Len := V8'Size / 8; 2276 Add := V8'Address; 2277 2278 when Send_Buffer | 2279 Receive_Buffer => 2280 V4 := C.int (Option.Size); 2281 Len := V4'Size / 8; 2282 Add := V4'Address; 2283 2284 when Error => 2285 V4 := C.int (Boolean'Pos (True)); 2286 Len := V4'Size / 8; 2287 Add := V4'Address; 2288 2289 when Add_Membership | 2290 Drop_Membership => 2291 V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address)); 2292 V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface)); 2293 Len := V8'Size / 8; 2294 Add := V8'Address; 2295 2296 when Multicast_If => 2297 V4 := To_Int (To_In_Addr (Option.Outgoing_If)); 2298 Len := V4'Size / 8; 2299 Add := V4'Address; 2300 2301 when Multicast_TTL => 2302 V1 := C.unsigned_char (Option.Time_To_Live); 2303 Len := V1'Size / 8; 2304 Add := V1'Address; 2305 2306 when Multicast_Loop | 2307 Receive_Packet_Info => 2308 V1 := C.unsigned_char (Boolean'Pos (Option.Enabled)); 2309 Len := V1'Size / 8; 2310 Add := V1'Address; 2311 2312 when Send_Timeout | 2313 Receive_Timeout => 2314 2315 if Target_OS = Windows then 2316 2317 -- On Windows, the timeout is a DWORD in milliseconds, and 2318 -- the actual timeout is 500 ms + the given value (unless it 2319 -- is 0). 2320 2321 V4 := C.int (Option.Timeout / 0.001); 2322 2323 if V4 > 500 then 2324 V4 := V4 - 500; 2325 2326 elsif V4 > 0 then 2327 V4 := 1; 2328 end if; 2329 2330 Len := V4'Size / 8; 2331 Add := V4'Address; 2332 2333 else 2334 VT := To_Timeval (Option.Timeout); 2335 Len := VT'Size / 8; 2336 Add := VT'Address; 2337 end if; 2338 2339 end case; 2340 2341 Res := C_Setsockopt 2342 (C.int (Socket), 2343 Levels (Level), 2344 Options (Option.Name), 2345 Add, Len); 2346 2347 if Res = Failure then 2348 Raise_Socket_Error (Socket_Errno); 2349 end if; 2350 end Set_Socket_Option; 2351 2352 ---------------------- 2353 -- Short_To_Network -- 2354 ---------------------- 2355 2356 function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is 2357 use type C.unsigned_short; 2358 2359 begin 2360 -- Big-endian case. No conversion needed. On these platforms, htons() 2361 -- defaults to a null procedure. 2362 2363 if Default_Bit_Order = High_Order_First then 2364 return S; 2365 2366 -- Little-endian case. We must swap the high and low bytes of this 2367 -- short to make the port number network compliant. 2368 2369 else 2370 return (S / 256) + (S mod 256) * 256; 2371 end if; 2372 end Short_To_Network; 2373 2374 --------------------- 2375 -- Shutdown_Socket -- 2376 --------------------- 2377 2378 procedure Shutdown_Socket 2379 (Socket : Socket_Type; 2380 How : Shutmode_Type := Shut_Read_Write) 2381 is 2382 Res : C.int; 2383 2384 begin 2385 Res := C_Shutdown (C.int (Socket), Shutmodes (How)); 2386 2387 if Res = Failure then 2388 Raise_Socket_Error (Socket_Errno); 2389 end if; 2390 end Shutdown_Socket; 2391 2392 ------------ 2393 -- Stream -- 2394 ------------ 2395 2396 function Stream 2397 (Socket : Socket_Type; 2398 Send_To : Sock_Addr_Type) return Stream_Access 2399 is 2400 S : Datagram_Socket_Stream_Access; 2401 2402 begin 2403 S := new Datagram_Socket_Stream_Type; 2404 S.Socket := Socket; 2405 S.To := Send_To; 2406 S.From := Get_Socket_Name (Socket); 2407 return Stream_Access (S); 2408 end Stream; 2409 2410 ------------ 2411 -- Stream -- 2412 ------------ 2413 2414 function Stream (Socket : Socket_Type) return Stream_Access is 2415 S : Stream_Socket_Stream_Access; 2416 begin 2417 S := new Stream_Socket_Stream_Type; 2418 S.Socket := Socket; 2419 return Stream_Access (S); 2420 end Stream; 2421 2422 ------------------ 2423 -- Stream_Write -- 2424 ------------------ 2425 2426 procedure Stream_Write 2427 (Socket : Socket_Type; 2428 Item : Ada.Streams.Stream_Element_Array; 2429 To : access Sock_Addr_Type) 2430 is 2431 First : Ada.Streams.Stream_Element_Offset; 2432 Index : Ada.Streams.Stream_Element_Offset; 2433 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; 2434 2435 begin 2436 First := Item'First; 2437 Index := First - 1; 2438 while First <= Max loop 2439 Send_Socket (Socket, Item (First .. Max), Index, To); 2440 2441 -- Exit when all or zero data sent. Zero means that the socket has 2442 -- been closed by peer. 2443 2444 exit when Index < First or else Index = Max; 2445 2446 First := Index + 1; 2447 end loop; 2448 2449 -- For an empty array, we have First > Max, and hence Index >= Max (no 2450 -- error, the loop above is never executed). After a successful send, 2451 -- Index = Max. The only remaining case, Index < Max, is therefore 2452 -- always an actual send failure. 2453 2454 if Index < Max then 2455 Raise_Socket_Error (Socket_Errno); 2456 end if; 2457 end Stream_Write; 2458 2459 ---------- 2460 -- To_C -- 2461 ---------- 2462 2463 function To_C (Socket : Socket_Type) return Integer is 2464 begin 2465 return Integer (Socket); 2466 end To_C; 2467 2468 ----------------- 2469 -- To_Duration -- 2470 ----------------- 2471 2472 function To_Duration (Val : Timeval) return Timeval_Duration is 2473 begin 2474 return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6; 2475 end To_Duration; 2476 2477 ------------------- 2478 -- To_Host_Entry -- 2479 ------------------- 2480 2481 function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is 2482 use type C.size_t; 2483 use C.Strings; 2484 2485 Aliases_Count, Addresses_Count : Natural; 2486 2487 -- H_Length is not used because it is currently only ever set to 4, as 2488 -- H_Addrtype is always AF_INET. 2489 2490 begin 2491 Aliases_Count := 0; 2492 while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop 2493 Aliases_Count := Aliases_Count + 1; 2494 end loop; 2495 2496 Addresses_Count := 0; 2497 while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop 2498 Addresses_Count := Addresses_Count + 1; 2499 end loop; 2500 2501 return Result : Host_Entry_Type 2502 (Aliases_Length => Aliases_Count, 2503 Addresses_Length => Addresses_Count) 2504 do 2505 Result.Official := To_Name (Value (Hostent_H_Name (E))); 2506 2507 for J in Result.Aliases'Range loop 2508 Result.Aliases (J) := 2509 To_Name (Value (Hostent_H_Alias 2510 (E, C.int (J - Result.Aliases'First)))); 2511 end loop; 2512 2513 for J in Result.Addresses'Range loop 2514 declare 2515 Addr : In_Addr; 2516 2517 -- Hostent_H_Addr (E, <index>) may return an address that is 2518 -- not correctly aligned for In_Addr, so we need to use 2519 -- an intermediate copy operation on a type with an alignemnt 2520 -- of 1 to recover the value. 2521 2522 subtype Addr_Buf_T is C.char_array (1 .. Addr'Size / 8); 2523 Unaligned_Addr : Addr_Buf_T; 2524 for Unaligned_Addr'Address 2525 use Hostent_H_Addr (E, C.int (J - Result.Addresses'First)); 2526 pragma Import (Ada, Unaligned_Addr); 2527 2528 Aligned_Addr : Addr_Buf_T; 2529 for Aligned_Addr'Address use Addr'Address; 2530 pragma Import (Ada, Aligned_Addr); 2531 2532 begin 2533 Aligned_Addr := Unaligned_Addr; 2534 To_Inet_Addr (Addr, Result.Addresses (J)); 2535 end; 2536 end loop; 2537 end return; 2538 end To_Host_Entry; 2539 2540 ---------------- 2541 -- To_In_Addr -- 2542 ---------------- 2543 2544 function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is 2545 begin 2546 if Addr.Family = Family_Inet then 2547 return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)), 2548 S_B2 => C.unsigned_char (Addr.Sin_V4 (2)), 2549 S_B3 => C.unsigned_char (Addr.Sin_V4 (3)), 2550 S_B4 => C.unsigned_char (Addr.Sin_V4 (4))); 2551 end if; 2552 2553 raise Socket_Error with "IPv6 not supported"; 2554 end To_In_Addr; 2555 2556 ------------------ 2557 -- To_Inet_Addr -- 2558 ------------------ 2559 2560 procedure To_Inet_Addr 2561 (Addr : In_Addr; 2562 Result : out Inet_Addr_Type) is 2563 begin 2564 Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1); 2565 Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2); 2566 Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3); 2567 Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4); 2568 end To_Inet_Addr; 2569 2570 ------------ 2571 -- To_Int -- 2572 ------------ 2573 2574 function To_Int (F : Request_Flag_Type) return C.int 2575 is 2576 Current : Request_Flag_Type := F; 2577 Result : C.int := 0; 2578 2579 begin 2580 for J in Flags'Range loop 2581 exit when Current = 0; 2582 2583 if Current mod 2 /= 0 then 2584 if Flags (J) = -1 then 2585 Raise_Socket_Error (SOSC.EOPNOTSUPP); 2586 end if; 2587 2588 Result := Result + Flags (J); 2589 end if; 2590 2591 Current := Current / 2; 2592 end loop; 2593 2594 return Result; 2595 end To_Int; 2596 2597 ------------- 2598 -- To_Name -- 2599 ------------- 2600 2601 function To_Name (N : String) return Name_Type is 2602 begin 2603 return Name_Type'(N'Length, N); 2604 end To_Name; 2605 2606 ---------------------- 2607 -- To_Service_Entry -- 2608 ---------------------- 2609 2610 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is 2611 use C.Strings; 2612 use type C.size_t; 2613 2614 Aliases_Count : Natural; 2615 2616 begin 2617 Aliases_Count := 0; 2618 while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop 2619 Aliases_Count := Aliases_Count + 1; 2620 end loop; 2621 2622 return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do 2623 Result.Official := To_Name (Value (Servent_S_Name (E))); 2624 2625 for J in Result.Aliases'Range loop 2626 Result.Aliases (J) := 2627 To_Name (Value (Servent_S_Alias 2628 (E, C.int (J - Result.Aliases'First)))); 2629 end loop; 2630 2631 Result.Protocol := To_Name (Value (Servent_S_Proto (E))); 2632 Result.Port := 2633 Port_Type (Network_To_Short (Servent_S_Port (E))); 2634 end return; 2635 end To_Service_Entry; 2636 2637 --------------- 2638 -- To_String -- 2639 --------------- 2640 2641 function To_String (HN : Name_Type) return String is 2642 begin 2643 return HN.Name (1 .. HN.Length); 2644 end To_String; 2645 2646 ---------------- 2647 -- To_Timeval -- 2648 ---------------- 2649 2650 function To_Timeval (Val : Timeval_Duration) return Timeval is 2651 S : time_t; 2652 uS : suseconds_t; 2653 2654 begin 2655 -- If zero, set result as zero (otherwise it gets rounded down to -1) 2656 2657 if Val = 0.0 then 2658 S := 0; 2659 uS := 0; 2660 2661 -- Normal case where we do round down 2662 2663 else 2664 S := time_t (Val - 0.5); 2665 uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S))); 2666 end if; 2667 2668 return (S, uS); 2669 end To_Timeval; 2670 2671 ----------- 2672 -- Value -- 2673 ----------- 2674 2675 function Value (S : System.Address) return String is 2676 Str : String (1 .. Positive'Last); 2677 for Str'Address use S; 2678 pragma Import (Ada, Str); 2679 2680 Terminator : Positive := Str'First; 2681 2682 begin 2683 while Str (Terminator) /= ASCII.NUL loop 2684 Terminator := Terminator + 1; 2685 end loop; 2686 2687 return Str (1 .. Terminator - 1); 2688 end Value; 2689 2690 ----------- 2691 -- Write -- 2692 ----------- 2693 2694 procedure Write 2695 (Stream : in out Datagram_Socket_Stream_Type; 2696 Item : Ada.Streams.Stream_Element_Array) 2697 is 2698 begin 2699 Stream_Write (Stream.Socket, Item, To => Stream.To'Unrestricted_Access); 2700 end Write; 2701 2702 ----------- 2703 -- Write -- 2704 ----------- 2705 2706 procedure Write 2707 (Stream : in out Stream_Socket_Stream_Type; 2708 Item : Ada.Streams.Stream_Element_Array) 2709 is 2710 begin 2711 Stream_Write (Stream.Socket, Item, To => null); 2712 end Write; 2713 2714 Sockets_Library_Controller_Object : Sockets_Library_Controller; 2715 pragma Unreferenced (Sockets_Library_Controller_Object); 2716 -- The elaboration and finalization of this object perform the required 2717 -- initialization and cleanup actions for the sockets library. 2718 2719end GNAT.Sockets; 2720