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