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