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-2019, 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.Containers.Generic_Array_Sort; 35with Ada.Finalization; 36with Ada.Unchecked_Conversion; 37 38with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common; 39with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; 40 41with GNAT.Sockets.Linker_Options; 42pragma Warnings (Off, GNAT.Sockets.Linker_Options); 43-- Need to include pragma Linker_Options which is platform dependent 44 45with System; use System; 46with System.Communication; use System.Communication; 47with System.CRTL; use System.CRTL; 48with System.Task_Lock; 49 50package body GNAT.Sockets is 51 52 package C renames Interfaces.C; 53 54 type IPV6_Mreq is record 55 ipv6mr_multiaddr : In6_Addr; 56 ipv6mr_interface : C.unsigned; 57 end record with Convention => C; 58 -- Record to Add/Drop_Membership for multicast in IPv6 59 60 ENOERROR : constant := 0; 61 62 Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024; 63 Need_Netdb_Lock : constant Boolean := SOSC.Need_Netdb_Lock /= 0; 64 -- The network database functions gethostbyname, gethostbyaddr, 65 -- getservbyname and getservbyport can either be guaranteed task safe by 66 -- the operating system, or else return data through a user-provided buffer 67 -- to ensure concurrent uses do not interfere. 68 69 -- Correspondence tables 70 71 Levels : constant array (Level_Type) of C.int := 72 (Socket_Level => SOSC.SOL_SOCKET, 73 IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP, 74 IP_Protocol_For_IPv6_Level => SOSC.IPPROTO_IPV6, 75 IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP, 76 IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP, 77 IP_Protocol_For_ICMP_Level => SOSC.IPPROTO_ICMP, 78 IP_Protocol_For_IGMP_Level => SOSC.IPPROTO_IGMP, 79 IP_Protocol_For_RAW_Level => SOSC.IPPROTO_RAW); 80 81 Modes : constant array (Mode_Type) of C.int := 82 (Socket_Stream => SOSC.SOCK_STREAM, 83 Socket_Datagram => SOSC.SOCK_DGRAM, 84 Socket_Raw => SOSC.SOCK_RAW); 85 86 Shutmodes : constant array (Shutmode_Type) of C.int := 87 (Shut_Read => SOSC.SHUT_RD, 88 Shut_Write => SOSC.SHUT_WR, 89 Shut_Read_Write => SOSC.SHUT_RDWR); 90 91 Requests : constant array (Request_Name) of SOSC.IOCTL_Req_T := 92 (Non_Blocking_IO => SOSC.FIONBIO, 93 N_Bytes_To_Read => SOSC.FIONREAD); 94 95 Options : constant array (Specific_Option_Name) of C.int := 96 (Keep_Alive => SOSC.SO_KEEPALIVE, 97 Reuse_Address => SOSC.SO_REUSEADDR, 98 Broadcast => SOSC.SO_BROADCAST, 99 Send_Buffer => SOSC.SO_SNDBUF, 100 Receive_Buffer => SOSC.SO_RCVBUF, 101 Linger => SOSC.SO_LINGER, 102 Error => SOSC.SO_ERROR, 103 No_Delay => SOSC.TCP_NODELAY, 104 Add_Membership_V4 => SOSC.IP_ADD_MEMBERSHIP, 105 Drop_Membership_V4 => SOSC.IP_DROP_MEMBERSHIP, 106 Multicast_If_V4 => SOSC.IP_MULTICAST_IF, 107 Multicast_Loop_V4 => SOSC.IP_MULTICAST_LOOP, 108 Receive_Packet_Info => SOSC.IP_PKTINFO, 109 Multicast_TTL => SOSC.IP_MULTICAST_TTL, 110 Add_Membership_V6 => SOSC.IPV6_ADD_MEMBERSHIP, 111 Drop_Membership_V6 => SOSC.IPV6_DROP_MEMBERSHIP, 112 Multicast_If_V6 => SOSC.IPV6_MULTICAST_IF, 113 Multicast_Loop_V6 => SOSC.IPV6_MULTICAST_LOOP, 114 Multicast_Hops => SOSC.IPV6_MULTICAST_HOPS, 115 IPv6_Only => SOSC.IPV6_V6ONLY, 116 Send_Timeout => SOSC.SO_SNDTIMEO, 117 Receive_Timeout => SOSC.SO_RCVTIMEO, 118 Busy_Polling => SOSC.SO_BUSY_POLL); 119 -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO, 120 -- but for Linux compatibility this constant is the same as IP_PKTINFO. 121 122 Flags : constant array (0 .. 3) of C.int := 123 (0 => SOSC.MSG_OOB, -- Process_Out_Of_Band_Data 124 1 => SOSC.MSG_PEEK, -- Peek_At_Incoming_Data 125 2 => SOSC.MSG_WAITALL, -- Wait_For_A_Full_Reception 126 3 => SOSC.MSG_EOR); -- Send_End_Of_Record 127 128 Socket_Error_Id : constant Exception_Id := Socket_Error'Identity; 129 Host_Error_Id : constant Exception_Id := Host_Error'Identity; 130 131 type In_Addr_Union (Family : Family_Inet_4_6) is record 132 case Family is 133 when Family_Inet => 134 In4 : In_Addr; 135 when Family_Inet6 => 136 In6 : In6_Addr; 137 end case; 138 end record with Unchecked_Union; 139 140 ----------------------- 141 -- Local subprograms -- 142 ----------------------- 143 144 function Resolve_Error 145 (Error_Value : Integer; 146 From_Errno : Boolean := True) return Error_Type; 147 -- Associate an enumeration value (error_type) to an error value (errno). 148 -- From_Errno prevents from mixing h_errno with errno. 149 150 function To_Name (N : String) return Name_Type; 151 function To_String (HN : Name_Type) return String; 152 -- Conversion functions 153 154 function To_Int (F : Request_Flag_Type) return C.int; 155 -- Return the int value corresponding to the specified flags combination 156 157 function Set_Forced_Flags (F : C.int) return C.int; 158 -- Return F with the bits from SOSC.MSG_Forced_Flags forced set 159 160 procedure Netdb_Lock; 161 pragma Inline (Netdb_Lock); 162 procedure Netdb_Unlock; 163 pragma Inline (Netdb_Unlock); 164 -- Lock/unlock operation used to protect netdb access for platforms that 165 -- require such protection. 166 167 function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type; 168 -- Conversion function 169 170 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type; 171 -- Conversion function 172 173 function Value (S : System.Address) return String; 174 -- Same as Interfaces.C.Strings.Value but taking a System.Address 175 176 function To_Timeval (Val : Timeval_Duration) return Timeval; 177 -- Separate Val in seconds and microseconds 178 179 function To_Duration (Val : Timeval) return Timeval_Duration; 180 -- Reconstruct a Duration value from a Timeval record (seconds and 181 -- microseconds). 182 183 function Dedot (Value : String) return String 184 is (if Value /= "" and then Value (Value'Last) = '.' 185 then Value (Value'First .. Value'Last - 1) 186 else Value); 187 -- Removes dot at the end of error message 188 189 procedure Raise_Socket_Error (Error : Integer); 190 -- Raise Socket_Error with an exception message describing the error code 191 -- from errno. 192 193 procedure Raise_Host_Error (H_Error : Integer; Name : String); 194 -- Raise Host_Error exception with message describing error code (note 195 -- hstrerror seems to be obsolete) from h_errno. Name is the name 196 -- or address that was being looked up. 197 198 procedure Raise_GAI_Error (RC : C.int; Name : String); 199 -- Raise Host_Error with exception message in case of errors in 200 -- getaddrinfo and getnameinfo. 201 202 function Is_Windows return Boolean with Inline; 203 -- Returns True on Windows platform 204 205 procedure Narrow (Item : in out Socket_Set_Type); 206 -- Update Last as it may be greater than the real last socket 207 208 procedure Check_For_Fd_Set (Fd : Socket_Type); 209 pragma Inline (Check_For_Fd_Set); 210 -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to 211 -- FD_SETSIZE, on platforms where fd_set is a bitmap. 212 213 function Connect_Socket 214 (Socket : Socket_Type; 215 Server : Sock_Addr_Type) return C.int; 216 pragma Inline (Connect_Socket); 217 -- Underlying implementation for the Connect_Socket procedures 218 219 -- Types needed for Datagram_Socket_Stream_Type 220 221 type Datagram_Socket_Stream_Type is new Root_Stream_Type with record 222 Socket : Socket_Type; 223 To : Sock_Addr_Type; 224 From : Sock_Addr_Type; 225 end record; 226 227 type Datagram_Socket_Stream_Access is 228 access all Datagram_Socket_Stream_Type; 229 230 procedure Read 231 (Stream : in out Datagram_Socket_Stream_Type; 232 Item : out Ada.Streams.Stream_Element_Array; 233 Last : out Ada.Streams.Stream_Element_Offset); 234 235 procedure Write 236 (Stream : in out Datagram_Socket_Stream_Type; 237 Item : Ada.Streams.Stream_Element_Array); 238 239 -- Types needed for Stream_Socket_Stream_Type 240 241 type Stream_Socket_Stream_Type is new Root_Stream_Type with record 242 Socket : Socket_Type; 243 end record; 244 245 type Stream_Socket_Stream_Access is 246 access all Stream_Socket_Stream_Type; 247 248 procedure Read 249 (Stream : in out Stream_Socket_Stream_Type; 250 Item : out Ada.Streams.Stream_Element_Array; 251 Last : out Ada.Streams.Stream_Element_Offset); 252 253 procedure Write 254 (Stream : in out Stream_Socket_Stream_Type; 255 Item : Ada.Streams.Stream_Element_Array); 256 257 procedure Wait_On_Socket 258 (Socket : Socket_Type; 259 For_Read : Boolean; 260 Timeout : Selector_Duration; 261 Selector : access Selector_Type := null; 262 Status : out Selector_Status); 263 -- Common code for variants of socket operations supporting a timeout: 264 -- block in Check_Selector on Socket for at most the indicated timeout. 265 -- If For_Read is True, Socket is added to the read set for this call, else 266 -- it is added to the write set. If no selector is provided, a local one is 267 -- created for this call and destroyed prior to returning. 268 269 type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled 270 with null record; 271 -- This type is used to generate automatic calls to Initialize and Finalize 272 -- during the elaboration and finalization of this package. A single object 273 -- of this type must exist at library level. 274 275 function Err_Code_Image (E : Integer) return String; 276 -- Return the value of E surrounded with brackets 277 278 procedure Initialize (X : in out Sockets_Library_Controller); 279 procedure Finalize (X : in out Sockets_Library_Controller); 280 281 procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type); 282 -- If S is the empty set (detected by Last = No_Socket), make sure its 283 -- fd_set component is actually cleared. Note that the case where it is 284 -- not can occur for an uninitialized Socket_Set_Type object. 285 286 function Is_Open (S : Selector_Type) return Boolean; 287 -- Return True for an "open" Selector_Type object, i.e. one for which 288 -- Create_Selector has been called and Close_Selector has not been called, 289 -- or the null selector. 290 291 function Create_Address 292 (Family : Family_Inet_4_6; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type 293 with Inline; 294 -- Creates address from family and Inet_Addr_Bytes array. 295 296 function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes 297 with Inline; 298 -- Extract bytes from address 299 300 --------- 301 -- "+" -- 302 --------- 303 304 function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is 305 begin 306 return L or R; 307 end "+"; 308 309 -------------------- 310 -- Abort_Selector -- 311 -------------------- 312 313 procedure Abort_Selector (Selector : Selector_Type) is 314 Res : C.int; 315 316 begin 317 if not Is_Open (Selector) then 318 raise Program_Error with "closed selector"; 319 320 elsif Selector.Is_Null then 321 raise Program_Error with "null selector"; 322 323 end if; 324 325 -- Send one byte to unblock select system call 326 327 Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket)); 328 329 if Res = Failure then 330 Raise_Socket_Error (Socket_Errno); 331 end if; 332 end Abort_Selector; 333 334 ------------------- 335 -- Accept_Socket -- 336 ------------------- 337 338 procedure Accept_Socket 339 (Server : Socket_Type; 340 Socket : out Socket_Type; 341 Address : out Sock_Addr_Type) 342 is 343 Res : C.int; 344 Sin : aliased Sockaddr; 345 Len : aliased C.int := Sin'Size / 8; 346 347 begin 348 Res := C_Accept (C.int (Server), Sin'Address, Len'Access); 349 350 if Res = Failure then 351 Raise_Socket_Error (Socket_Errno); 352 end if; 353 354 Socket := Socket_Type (Res); 355 Address := Get_Address (Sin, Len); 356 end Accept_Socket; 357 358 ------------------- 359 -- Accept_Socket -- 360 ------------------- 361 362 procedure Accept_Socket 363 (Server : Socket_Type; 364 Socket : out Socket_Type; 365 Address : out Sock_Addr_Type; 366 Timeout : Selector_Duration; 367 Selector : access Selector_Type := null; 368 Status : out Selector_Status) 369 is 370 begin 371 if Selector /= null and then not Is_Open (Selector.all) then 372 raise Program_Error with "closed selector"; 373 end if; 374 375 -- Wait for socket to become available for reading 376 377 Wait_On_Socket 378 (Socket => Server, 379 For_Read => True, 380 Timeout => Timeout, 381 Selector => Selector, 382 Status => Status); 383 384 -- Accept connection if available 385 386 if Status = Completed then 387 Accept_Socket (Server, Socket, Address); 388 else 389 Socket := No_Socket; 390 end if; 391 end Accept_Socket; 392 393 --------------- 394 -- Addresses -- 395 --------------- 396 397 function Addresses 398 (E : Host_Entry_Type; 399 N : Positive := 1) return Inet_Addr_Type 400 is 401 begin 402 return E.Addresses (N); 403 end Addresses; 404 405 ---------------------- 406 -- Addresses_Length -- 407 ---------------------- 408 409 function Addresses_Length (E : Host_Entry_Type) return Natural is 410 begin 411 return E.Addresses_Length; 412 end Addresses_Length; 413 414 ------------- 415 -- Aliases -- 416 ------------- 417 418 function Aliases 419 (E : Host_Entry_Type; 420 N : Positive := 1) return String 421 is 422 begin 423 return To_String (E.Aliases (N)); 424 end Aliases; 425 426 ------------- 427 -- Aliases -- 428 ------------- 429 430 function Aliases 431 (S : Service_Entry_Type; 432 N : Positive := 1) return String 433 is 434 begin 435 return To_String (S.Aliases (N)); 436 end Aliases; 437 438 -------------------- 439 -- Aliases_Length -- 440 -------------------- 441 442 function Aliases_Length (E : Host_Entry_Type) return Natural is 443 begin 444 return E.Aliases_Length; 445 end Aliases_Length; 446 447 -------------------- 448 -- Aliases_Length -- 449 -------------------- 450 451 function Aliases_Length (S : Service_Entry_Type) return Natural is 452 begin 453 return S.Aliases_Length; 454 end Aliases_Length; 455 456 ----------------- 457 -- Bind_Socket -- 458 ----------------- 459 460 procedure Bind_Socket 461 (Socket : Socket_Type; 462 Address : Sock_Addr_Type) 463 is 464 Res : C.int; 465 Sin : aliased Sockaddr; 466 Len : C.int; 467 468 begin 469 Set_Address (Sin'Unchecked_Access, Address, Len); 470 471 Res := C_Bind (C.int (Socket), Sin'Address, Len); 472 473 if Res = Failure then 474 Raise_Socket_Error (Socket_Errno); 475 end if; 476 end Bind_Socket; 477 478 ---------------------- 479 -- Check_For_Fd_Set -- 480 ---------------------- 481 482 procedure Check_For_Fd_Set (Fd : Socket_Type) is 483 begin 484 -- On Windows, fd_set is a FD_SETSIZE array of socket ids: 485 -- no check required. Warnings suppressed because condition 486 -- is known at compile time. 487 488 if Is_Windows then 489 490 return; 491 492 -- On other platforms, fd_set is an FD_SETSIZE bitmap: check 493 -- that Fd is within range (otherwise behavior is undefined). 494 495 elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then 496 raise Constraint_Error 497 with "invalid value for socket set: " & Image (Fd); 498 end if; 499 end Check_For_Fd_Set; 500 501 -------------------- 502 -- Check_Selector -- 503 -------------------- 504 505 procedure Check_Selector 506 (Selector : Selector_Type; 507 R_Socket_Set : in out Socket_Set_Type; 508 W_Socket_Set : in out Socket_Set_Type; 509 Status : out Selector_Status; 510 Timeout : Selector_Duration := Forever) 511 is 512 E_Socket_Set : Socket_Set_Type; 513 begin 514 Check_Selector 515 (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout); 516 end Check_Selector; 517 518 procedure Check_Selector 519 (Selector : Selector_Type; 520 R_Socket_Set : in out Socket_Set_Type; 521 W_Socket_Set : in out Socket_Set_Type; 522 E_Socket_Set : in out Socket_Set_Type; 523 Status : out Selector_Status; 524 Timeout : Selector_Duration := Forever) 525 is 526 Res : C.int; 527 Last : C.int; 528 RSig : Socket_Type := No_Socket; 529 TVal : aliased Timeval; 530 TPtr : Timeval_Access; 531 532 begin 533 if not Is_Open (Selector) then 534 raise Program_Error with "closed selector"; 535 end if; 536 537 Status := Completed; 538 539 -- No timeout or Forever is indicated by a null timeval pointer 540 541 if Timeout = Forever then 542 TPtr := null; 543 else 544 TVal := To_Timeval (Timeout); 545 TPtr := TVal'Unchecked_Access; 546 end if; 547 548 -- Add read signalling socket, if present 549 550 if not Selector.Is_Null then 551 RSig := Selector.R_Sig_Socket; 552 Set (R_Socket_Set, RSig); 553 end if; 554 555 Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last), 556 C.int (W_Socket_Set.Last)), 557 C.int (E_Socket_Set.Last)); 558 559 -- Zero out fd_set for empty Socket_Set_Type objects 560 561 Normalize_Empty_Socket_Set (R_Socket_Set); 562 Normalize_Empty_Socket_Set (W_Socket_Set); 563 Normalize_Empty_Socket_Set (E_Socket_Set); 564 565 Res := 566 C_Select 567 (Last + 1, 568 R_Socket_Set.Set'Access, 569 W_Socket_Set.Set'Access, 570 E_Socket_Set.Set'Access, 571 TPtr); 572 573 if Res = Failure then 574 Raise_Socket_Error (Socket_Errno); 575 end if; 576 577 -- If Select was resumed because of read signalling socket, read this 578 -- data and remove socket from set. 579 580 if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then 581 Clear (R_Socket_Set, RSig); 582 583 Res := Signalling_Fds.Read (C.int (RSig)); 584 585 if Res = Failure then 586 Raise_Socket_Error (Socket_Errno); 587 end if; 588 589 Status := Aborted; 590 591 elsif Res = 0 then 592 Status := Expired; 593 end if; 594 595 -- Update socket sets in regard to their new contents 596 597 Narrow (R_Socket_Set); 598 Narrow (W_Socket_Set); 599 Narrow (E_Socket_Set); 600 end Check_Selector; 601 602 ----------- 603 -- Clear -- 604 ----------- 605 606 procedure Clear 607 (Item : in out Socket_Set_Type; 608 Socket : Socket_Type) 609 is 610 Last : aliased C.int := C.int (Item.Last); 611 612 begin 613 Check_For_Fd_Set (Socket); 614 615 if Item.Last /= No_Socket then 616 Remove_Socket_From_Set (Item.Set'Access, C.int (Socket)); 617 Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access); 618 Item.Last := Socket_Type (Last); 619 end if; 620 end Clear; 621 622 -------------------- 623 -- Close_Selector -- 624 -------------------- 625 626 procedure Close_Selector (Selector : in out Selector_Type) is 627 begin 628 -- Nothing to do if selector already in closed state 629 630 if Selector.Is_Null or else not Is_Open (Selector) then 631 return; 632 end if; 633 634 -- Close the signalling file descriptors used internally for the 635 -- implementation of Abort_Selector. 636 637 Signalling_Fds.Close (C.int (Selector.R_Sig_Socket)); 638 Signalling_Fds.Close (C.int (Selector.W_Sig_Socket)); 639 640 -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any 641 -- (erroneous) subsequent attempt to use this selector properly fails. 642 643 Selector.R_Sig_Socket := No_Socket; 644 Selector.W_Sig_Socket := No_Socket; 645 end Close_Selector; 646 647 ------------------ 648 -- Close_Socket -- 649 ------------------ 650 651 procedure Close_Socket (Socket : Socket_Type) is 652 Res : C.int; 653 654 begin 655 Res := C_Close (C.int (Socket)); 656 657 if Res = Failure then 658 Raise_Socket_Error (Socket_Errno); 659 end if; 660 end Close_Socket; 661 662 -------------------- 663 -- Connect_Socket -- 664 -------------------- 665 666 function Connect_Socket 667 (Socket : Socket_Type; 668 Server : Sock_Addr_Type) return C.int 669 is 670 Sin : aliased Sockaddr; 671 Len : C.int; 672 begin 673 Set_Address (Sin'Unchecked_Access, Server, Len); 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 Level : Level_Type := IP_Protocol_For_IP_Level) 857 is 858 Res : C.int; 859 860 begin 861 Res := C_Socket (Families (Family), Modes (Mode), Levels (Level)); 862 863 if Res = Failure then 864 Raise_Socket_Error (Socket_Errno); 865 end if; 866 867 Socket := Socket_Type (Res); 868 end Create_Socket; 869 870 ------------------------ 871 -- Create_Socket_Pair -- 872 ------------------------ 873 874 procedure Create_Socket_Pair 875 (Left : out Socket_Type; 876 Right : out Socket_Type; 877 Family : Family_Type := Family_Unspec; 878 Mode : Mode_Type := Socket_Stream; 879 Level : Level_Type := IP_Protocol_For_IP_Level) 880 is 881 Res : C.int; 882 Pair : aliased Thin_Common.Fd_Pair; 883 884 begin 885 Res := C_Socketpair 886 ((if Family = Family_Unspec then Default_Socket_Pair_Family 887 else Families (Family)), 888 Modes (Mode), Levels (Level), Pair'Access); 889 890 if Res = Failure then 891 Raise_Socket_Error (Socket_Errno); 892 end if; 893 894 Left := Socket_Type (Pair (Pair'First)); 895 Right := Socket_Type (Pair (Pair'Last)); 896 end Create_Socket_Pair; 897 898 ----------- 899 -- Empty -- 900 ----------- 901 902 procedure Empty (Item : out Socket_Set_Type) is 903 begin 904 Reset_Socket_Set (Item.Set'Access); 905 Item.Last := No_Socket; 906 end Empty; 907 908 -------------------- 909 -- Err_Code_Image -- 910 -------------------- 911 912 function Err_Code_Image (E : Integer) return String is 913 Msg : String := E'Img & "] "; 914 begin 915 Msg (Msg'First) := '['; 916 return Msg; 917 end Err_Code_Image; 918 919 -------------- 920 -- Finalize -- 921 -------------- 922 923 procedure Finalize (X : in out Sockets_Library_Controller) is 924 pragma Unreferenced (X); 925 926 begin 927 -- Finalization operation for the GNAT.Sockets package 928 929 Thin.Finalize; 930 end Finalize; 931 932 -------------- 933 -- Finalize -- 934 -------------- 935 936 procedure Finalize is 937 begin 938 -- This is a dummy placeholder for an obsolete API. 939 -- The real finalization actions are in Initialize primitive operation 940 -- of Sockets_Library_Controller. 941 942 null; 943 end Finalize; 944 945 --------- 946 -- Get -- 947 --------- 948 949 procedure Get 950 (Item : in out Socket_Set_Type; 951 Socket : out Socket_Type) 952 is 953 S : aliased C.int; 954 L : aliased C.int := C.int (Item.Last); 955 956 begin 957 if Item.Last /= No_Socket then 958 Get_Socket_From_Set 959 (Item.Set'Access, Last => L'Access, Socket => S'Access); 960 Item.Last := Socket_Type (L); 961 Socket := Socket_Type (S); 962 else 963 Socket := No_Socket; 964 end if; 965 end Get; 966 967 ----------------- 968 -- Get_Address -- 969 ----------------- 970 971 function Get_Address 972 (Stream : not null Stream_Access) return Sock_Addr_Type 973 is 974 begin 975 if Stream.all in Datagram_Socket_Stream_Type then 976 return Datagram_Socket_Stream_Type (Stream.all).From; 977 else 978 return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket); 979 end if; 980 end Get_Address; 981 982 --------------------- 983 -- Raise_GAI_Error -- 984 --------------------- 985 986 procedure Raise_GAI_Error (RC : C.int; Name : String) is 987 begin 988 if RC = SOSC.EAI_SYSTEM then 989 declare 990 Errcode : constant Integer := Socket_Errno; 991 begin 992 raise Host_Error with Err_Code_Image (Errcode) 993 & Dedot (Socket_Error_Message (Errcode)) & ": " & Name; 994 end; 995 else 996 raise Host_Error with Err_Code_Image (Integer (RC)) 997 & Dedot (CS.Value (C_GAI_Strerror (RC))) & ": " & Name; 998 end if; 999 end Raise_GAI_Error; 1000 1001 ---------------------- 1002 -- Get_Address_Info -- 1003 ---------------------- 1004 1005 function Get_Address_Info 1006 (Host : String; 1007 Service : String; 1008 Family : Family_Type := Family_Unspec; 1009 Mode : Mode_Type := Socket_Stream; 1010 Level : Level_Type := IP_Protocol_For_IP_Level; 1011 Numeric_Host : Boolean := False; 1012 Passive : Boolean := False; 1013 Unknown : access procedure 1014 (Family, Mode, Level, Length : Integer) := null) 1015 return Address_Info_Array 1016 is 1017 A : aliased Addrinfo_Access; 1018 N : aliased C.char_array := C.To_C (Host); 1019 S : aliased C.char_array := C.To_C (if Service = "" then "0" 1020 else Service); 1021 Hints : aliased constant Addrinfo := 1022 (ai_family => Families (Family), 1023 ai_socktype => Modes (Mode), 1024 ai_protocol => Levels (Level), 1025 ai_flags => (if Numeric_Host then SOSC.AI_NUMERICHOST else 0) + 1026 (if Passive then SOSC.AI_PASSIVE else 0), 1027 ai_addrlen => 0, 1028 others => <>); 1029 1030 R : C.int; 1031 Iter : Addrinfo_Access; 1032 Found : Boolean; 1033 1034 function To_Array return Address_Info_Array; 1035 -- Convert taken from OS addrinfo list A into Address_Info_Array 1036 1037 -------------- 1038 -- To_Array -- 1039 -------------- 1040 1041 function To_Array return Address_Info_Array is 1042 Result : Address_Info_Array (1 .. 8); 1043 1044 procedure Unsupported; 1045 -- Calls Unknown callback if defiend 1046 1047 ----------------- 1048 -- Unsupported -- 1049 ----------------- 1050 1051 procedure Unsupported is 1052 begin 1053 if Unknown /= null then 1054 Unknown 1055 (Integer (Iter.ai_family), 1056 Integer (Iter.ai_socktype), 1057 Integer (Iter.ai_protocol), 1058 Integer (Iter.ai_addrlen)); 1059 end if; 1060 end Unsupported; 1061 1062 -- Start of processing for To_Array 1063 1064 begin 1065 for J in Result'Range loop 1066 Look_For_Supported : loop 1067 if Iter = null then 1068 pragma Warnings 1069 (Off, "may be referenced before it has a value"); 1070 1071 return Result (1 .. J - 1); 1072 1073 pragma Warnings 1074 (On, "may be referenced before it has a value"); 1075 end if; 1076 1077 Result (J).Addr := 1078 Get_Address (Iter.ai_addr.all, C.int (Iter.ai_addrlen)); 1079 1080 if Result (J).Addr.Family = Family_Unspec then 1081 Unsupported; 1082 else 1083 for M in Modes'Range loop 1084 Found := False; 1085 if Modes (M) = Iter.ai_socktype then 1086 Result (J).Mode := M; 1087 Found := True; 1088 exit; 1089 end if; 1090 end loop; 1091 1092 if Found then 1093 for L in Levels'Range loop 1094 if Levels (L) = Iter.ai_protocol then 1095 Result (J).Level := L; 1096 exit; 1097 end if; 1098 end loop; 1099 1100 exit Look_For_Supported; 1101 else 1102 Unsupported; 1103 end if; 1104 end if; 1105 1106 Iter := Iter.ai_next; 1107 end loop Look_For_Supported; 1108 1109 Iter := Iter.ai_next; 1110 end loop; 1111 1112 return Result & To_Array; 1113 end To_Array; 1114 1115 -- Start of processing for Get_Address_Info 1116 1117 begin 1118 R := C_Getaddrinfo 1119 (Node => (if Host = "" then null else N'Unchecked_Access), 1120 Service => S'Unchecked_Access, 1121 Hints => Hints'Unchecked_Access, 1122 Res => A'Access); 1123 1124 if R /= 0 then 1125 Raise_GAI_Error 1126 (R, Host & (if Service = "" then "" else ':' & Service)); 1127 end if; 1128 1129 Iter := A; 1130 1131 return Result : constant Address_Info_Array := To_Array do 1132 C_Freeaddrinfo (A); 1133 end return; 1134 end Get_Address_Info; 1135 1136 ---------- 1137 -- Sort -- 1138 ---------- 1139 1140 procedure Sort 1141 (Addr_Info : in out Address_Info_Array; 1142 Compare : access function (Left, Right : Address_Info) return Boolean) 1143 is 1144 function Comp (Left, Right : Address_Info) return Boolean is 1145 (Compare (Left, Right)); 1146 procedure Sorter is new Ada.Containers.Generic_Array_Sort 1147 (Positive, Address_Info, Address_Info_Array, Comp); 1148 begin 1149 Sorter (Addr_Info); 1150 end Sort; 1151 1152 ------------------------ 1153 -- IPv6_TCP_Preferred -- 1154 ------------------------ 1155 1156 function IPv6_TCP_Preferred (Left, Right : Address_Info) return Boolean is 1157 begin 1158 pragma Assert (Family_Inet < Family_Inet6); 1159 -- To be sure that Family_Type enumeration has appropriate elements 1160 -- order 1161 1162 if Left.Addr.Family /= Right.Addr.Family then 1163 return Left.Addr.Family > Right.Addr.Family; 1164 end if; 1165 1166 pragma Assert (Socket_Stream < Socket_Datagram); 1167 -- To be sure that Mode_Type enumeration has appropriate elements order 1168 1169 return Left.Mode < Right.Mode; 1170 end IPv6_TCP_Preferred; 1171 1172 ------------------- 1173 -- Get_Name_Info -- 1174 ------------------- 1175 1176 function Get_Name_Info 1177 (Addr : Sock_Addr_Type; 1178 Numeric_Host : Boolean := False; 1179 Numeric_Serv : Boolean := False) return Host_Service 1180 is 1181 SA : aliased Sockaddr; 1182 H : aliased C.char_array := (1 .. SOSC.NI_MAXHOST => C.nul); 1183 S : aliased C.char_array := (1 .. SOSC.NI_MAXSERV => C.nul); 1184 RC : C.int; 1185 Len : C.int; 1186 begin 1187 Set_Address (SA'Unchecked_Access, Addr, Len); 1188 1189 RC := C_Getnameinfo 1190 (SA'Unchecked_Access, socklen_t (Len), 1191 H'Unchecked_Access, H'Length, 1192 S'Unchecked_Access, S'Length, 1193 (if Numeric_Host then SOSC.NI_NUMERICHOST else 0) + 1194 (if Numeric_Serv then SOSC.NI_NUMERICSERV else 0)); 1195 1196 if RC /= 0 then 1197 Raise_GAI_Error (RC, Image (Addr)); 1198 end if; 1199 1200 declare 1201 HR : constant String := C.To_Ada (H); 1202 SR : constant String := C.To_Ada (S); 1203 begin 1204 return (HR'Length, SR'Length, HR, SR); 1205 end; 1206 end Get_Name_Info; 1207 1208 ------------------------- 1209 -- Get_Host_By_Address -- 1210 ------------------------- 1211 1212 function Get_Host_By_Address 1213 (Address : Inet_Addr_Type; 1214 Family : Family_Type := Family_Inet) return Host_Entry_Type 1215 is 1216 pragma Unreferenced (Family); 1217 1218 HA : aliased In_Addr_Union (Address.Family); 1219 Buflen : constant C.int := Netdb_Buffer_Size; 1220 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); 1221 Res : aliased Hostent; 1222 Err : aliased C.int; 1223 1224 begin 1225 case Address.Family is 1226 when Family_Inet => 1227 HA.In4 := To_In_Addr (Address); 1228 when Family_Inet6 => 1229 HA.In6 := To_In6_Addr (Address); 1230 end case; 1231 1232 Netdb_Lock; 1233 1234 if C_Gethostbyaddr 1235 (HA'Address, 1236 (case Address.Family is 1237 when Family_Inet => HA.In4'Size, 1238 when Family_Inet6 => HA.In6'Size) / 8, 1239 Families (Address.Family), 1240 Res'Access, Buf'Address, Buflen, Err'Access) /= 0 1241 then 1242 Netdb_Unlock; 1243 Raise_Host_Error (Integer (Err), Image (Address)); 1244 end if; 1245 1246 begin 1247 return H : constant Host_Entry_Type := 1248 To_Host_Entry (Res'Unchecked_Access) 1249 do 1250 Netdb_Unlock; 1251 end return; 1252 exception 1253 when others => 1254 Netdb_Unlock; 1255 raise; 1256 end; 1257 end Get_Host_By_Address; 1258 1259 ---------------------- 1260 -- Get_Host_By_Name -- 1261 ---------------------- 1262 1263 function Get_Host_By_Name (Name : String) return Host_Entry_Type is 1264 begin 1265 -- If the given name actually is the string representation of 1266 -- an IP address, use Get_Host_By_Address instead. 1267 1268 if Is_IPv4_Address (Name) or else Is_IPv6_Address (Name) then 1269 return Get_Host_By_Address (Inet_Addr (Name)); 1270 end if; 1271 1272 declare 1273 HN : constant C.char_array := C.To_C (Name); 1274 Buflen : constant C.int := Netdb_Buffer_Size; 1275 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); 1276 Res : aliased Hostent; 1277 Err : aliased C.int; 1278 1279 begin 1280 Netdb_Lock; 1281 1282 if C_Gethostbyname 1283 (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 1284 then 1285 Netdb_Unlock; 1286 Raise_Host_Error (Integer (Err), Name); 1287 end if; 1288 1289 return H : constant Host_Entry_Type := 1290 To_Host_Entry (Res'Unchecked_Access) 1291 do 1292 Netdb_Unlock; 1293 end return; 1294 end; 1295 end Get_Host_By_Name; 1296 1297 ------------------- 1298 -- Get_Peer_Name -- 1299 ------------------- 1300 1301 function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is 1302 Sin : aliased Sockaddr; 1303 Len : aliased C.int := Sin'Size / 8; 1304 begin 1305 if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then 1306 Raise_Socket_Error (Socket_Errno); 1307 end if; 1308 1309 return Get_Address (Sin, Len); 1310 end Get_Peer_Name; 1311 1312 ------------------------- 1313 -- Get_Service_By_Name -- 1314 ------------------------- 1315 1316 function Get_Service_By_Name 1317 (Name : String; 1318 Protocol : String) return Service_Entry_Type 1319 is 1320 SN : constant C.char_array := C.To_C (Name); 1321 SP : constant C.char_array := C.To_C (Protocol); 1322 Buflen : constant C.int := Netdb_Buffer_Size; 1323 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); 1324 Res : aliased Servent; 1325 1326 begin 1327 Netdb_Lock; 1328 1329 if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then 1330 Netdb_Unlock; 1331 raise Service_Error with "Service not found"; 1332 end if; 1333 1334 -- Translate from the C format to the API format 1335 1336 return S : constant Service_Entry_Type := 1337 To_Service_Entry (Res'Unchecked_Access) 1338 do 1339 Netdb_Unlock; 1340 end return; 1341 end Get_Service_By_Name; 1342 1343 ------------------------- 1344 -- Get_Service_By_Port -- 1345 ------------------------- 1346 1347 function Get_Service_By_Port 1348 (Port : Port_Type; 1349 Protocol : String) return Service_Entry_Type 1350 is 1351 SP : constant C.char_array := C.To_C (Protocol); 1352 Buflen : constant C.int := Netdb_Buffer_Size; 1353 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); 1354 Res : aliased Servent; 1355 1356 begin 1357 Netdb_Lock; 1358 1359 if C_Getservbyport 1360 (C.int (Short_To_Network (C.unsigned_short (Port))), SP, 1361 Res'Access, Buf'Address, Buflen) /= 0 1362 then 1363 Netdb_Unlock; 1364 raise Service_Error with "Service not found"; 1365 end if; 1366 1367 -- Translate from the C format to the API format 1368 1369 return S : constant Service_Entry_Type := 1370 To_Service_Entry (Res'Unchecked_Access) 1371 do 1372 Netdb_Unlock; 1373 end return; 1374 end Get_Service_By_Port; 1375 1376 --------------------- 1377 -- Get_Socket_Name -- 1378 --------------------- 1379 1380 function Get_Socket_Name 1381 (Socket : Socket_Type) return Sock_Addr_Type 1382 is 1383 Sin : aliased Sockaddr; 1384 Len : aliased C.int := Sin'Size / 8; 1385 Res : C.int; 1386 begin 1387 Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access); 1388 1389 if Res = Failure then 1390 return No_Sock_Addr; 1391 end if; 1392 1393 return Get_Address (Sin, Len); 1394 end Get_Socket_Name; 1395 1396 ----------------------- 1397 -- Get_Socket_Option -- 1398 ----------------------- 1399 1400 function Get_Socket_Option 1401 (Socket : Socket_Type; 1402 Level : Level_Type; 1403 Name : Option_Name; 1404 Optname : Interfaces.C.int := -1) return Option_Type 1405 is 1406 use type C.unsigned; 1407 use type C.unsigned_char; 1408 1409 V8 : aliased Two_Ints; 1410 V4 : aliased C.int; 1411 U4 : aliased C.unsigned; 1412 V1 : aliased C.unsigned_char; 1413 VT : aliased Timeval; 1414 Len : aliased C.int; 1415 Add : System.Address; 1416 Res : C.int; 1417 Opt : Option_Type (Name); 1418 Onm : Interfaces.C.int; 1419 1420 begin 1421 if Name in Specific_Option_Name then 1422 Onm := Options (Name); 1423 1424 elsif Optname = -1 then 1425 raise Socket_Error with "optname must be specified"; 1426 1427 else 1428 Onm := Optname; 1429 end if; 1430 1431 case Name is 1432 when Multicast_TTL 1433 | Receive_Packet_Info 1434 => 1435 Len := V1'Size / 8; 1436 Add := V1'Address; 1437 1438 when Broadcast 1439 | Busy_Polling 1440 | Error 1441 | Generic_Option 1442 | Keep_Alive 1443 | Multicast_If_V4 1444 | Multicast_If_V6 1445 | Multicast_Loop_V4 1446 | Multicast_Loop_V6 1447 | Multicast_Hops 1448 | No_Delay 1449 | Receive_Buffer 1450 | Reuse_Address 1451 | Send_Buffer 1452 | IPv6_Only 1453 => 1454 Len := V4'Size / 8; 1455 Add := V4'Address; 1456 1457 when Receive_Timeout 1458 | Send_Timeout 1459 => 1460 -- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a 1461 -- struct timeval, but on Windows it is a milliseconds count in 1462 -- a DWORD. 1463 1464 if Is_Windows then 1465 Len := U4'Size / 8; 1466 Add := U4'Address; 1467 else 1468 Len := VT'Size / 8; 1469 Add := VT'Address; 1470 end if; 1471 1472 when Add_Membership_V4 1473 | Add_Membership_V6 1474 | Drop_Membership_V4 1475 | Drop_Membership_V6 1476 => 1477 raise Socket_Error with 1478 "Add/Drop membership valid only for Set_Socket_Option"; 1479 1480 when Linger 1481 => 1482 Len := V8'Size / 8; 1483 Add := V8'Address; 1484 end case; 1485 1486 Res := 1487 C_Getsockopt 1488 (C.int (Socket), 1489 Levels (Level), 1490 Onm, 1491 Add, Len'Access); 1492 1493 if Res = Failure then 1494 Raise_Socket_Error (Socket_Errno); 1495 end if; 1496 1497 case Name is 1498 when Generic_Option => 1499 Opt.Optname := Onm; 1500 Opt.Optval := V4; 1501 1502 when Broadcast 1503 | Keep_Alive 1504 | No_Delay 1505 | Reuse_Address 1506 | Multicast_Loop_V4 1507 | Multicast_Loop_V6 1508 | IPv6_Only 1509 => 1510 Opt.Enabled := (V4 /= 0); 1511 1512 when Busy_Polling => 1513 Opt.Microseconds := Natural (V4); 1514 1515 when Linger => 1516 Opt.Enabled := (V8 (V8'First) /= 0); 1517 Opt.Seconds := Natural (V8 (V8'Last)); 1518 1519 when Receive_Buffer 1520 | Send_Buffer 1521 => 1522 Opt.Size := Natural (V4); 1523 1524 when Error => 1525 Opt.Error := Resolve_Error (Integer (V4)); 1526 1527 when Add_Membership_V4 1528 | Add_Membership_V6 1529 | Drop_Membership_V4 1530 | Drop_Membership_V6 1531 => 1532 -- No way to be here. Exception raised in the first case Name 1533 -- expression. 1534 null; 1535 1536 when Multicast_If_V4 => 1537 To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If); 1538 1539 when Multicast_If_V6 => 1540 Opt.Outgoing_If_Index := Natural (V4); 1541 1542 when Multicast_TTL => 1543 Opt.Time_To_Live := Integer (V1); 1544 1545 when Multicast_Hops => 1546 Opt.Hop_Limit := Integer (V4); 1547 1548 when Receive_Packet_Info 1549 => 1550 Opt.Enabled := (V1 /= 0); 1551 1552 when Receive_Timeout 1553 | Send_Timeout 1554 => 1555 if Is_Windows then 1556 1557 -- Timeout is in milliseconds, actual value is 500 ms + 1558 -- returned value (unless it is 0). 1559 1560 if U4 = 0 then 1561 Opt.Timeout := 0.0; 1562 else 1563 Opt.Timeout := Duration (U4) / 1000 + 0.500; 1564 end if; 1565 1566 else 1567 Opt.Timeout := To_Duration (VT); 1568 end if; 1569 end case; 1570 1571 return Opt; 1572 end Get_Socket_Option; 1573 1574 --------------- 1575 -- Host_Name -- 1576 --------------- 1577 1578 function Host_Name return String is 1579 Name : aliased C.char_array (1 .. 64); 1580 Res : C.int; 1581 1582 begin 1583 Res := C_Gethostname (Name'Address, Name'Length); 1584 1585 if Res = Failure then 1586 Raise_Socket_Error (Socket_Errno); 1587 end if; 1588 1589 return C.To_Ada (Name); 1590 end Host_Name; 1591 1592 ----------- 1593 -- Image -- 1594 ----------- 1595 1596 function Image (Value : Inet_Addr_Type) return String is 1597 use type CS.char_array_access; 1598 Size : constant socklen_t := 1599 (case Value.Family is 1600 when Family_Inet => 4 * Value.Sin_V4'Length, 1601 when Family_Inet6 => 6 * 5 + 4 * 4); 1602 -- 1234:1234:1234:1234:1234:1234:123.123.123.123 1603 Dst : aliased C.char_array := (1 .. C.size_t (Size) => C.nul); 1604 Ia : aliased In_Addr_Union (Value.Family); 1605 begin 1606 case Value.Family is 1607 when Family_Inet6 => 1608 Ia.In6 := To_In6_Addr (Value); 1609 when Family_Inet => 1610 Ia.In4 := To_In_Addr (Value); 1611 end case; 1612 1613 if Inet_Ntop 1614 (Families (Value.Family), Ia'Address, 1615 Dst'Unchecked_Access, Size) = null 1616 then 1617 Raise_Socket_Error (Socket_Errno); 1618 end if; 1619 1620 return C.To_Ada (Dst); 1621 end Image; 1622 1623 ----------- 1624 -- Image -- 1625 ----------- 1626 1627 function Image (Value : Sock_Addr_Type) return String is 1628 function Ipv6_Brackets (S : String) return String is 1629 (if Value.Family = Family_Inet6 then "[" & S & "]" else S); 1630 begin 1631 case Value.Family is 1632 when Family_Unix => 1633 if ASU.Length (Value.Name) > 0 1634 and then ASU.Element (Value.Name, 1) = ASCII.NUL 1635 then 1636 return '@' & ASU.Slice (Value.Name, 2, ASU.Length (Value.Name)); 1637 else 1638 return ASU.To_String (Value.Name); 1639 end if; 1640 1641 when Family_Inet_4_6 => 1642 declare 1643 Port : constant String := Value.Port'Img; 1644 begin 1645 return Ipv6_Brackets (Image (Value.Addr)) & ':' 1646 & Port (2 .. Port'Last); 1647 end; 1648 1649 when Family_Unspec => 1650 return ""; 1651 end case; 1652 end Image; 1653 1654 ----------- 1655 -- Image -- 1656 ----------- 1657 1658 function Image (Socket : Socket_Type) return String is 1659 begin 1660 return Socket'Img; 1661 end Image; 1662 1663 ----------- 1664 -- Image -- 1665 ----------- 1666 1667 function Image (Item : Socket_Set_Type) return String is 1668 Socket_Set : Socket_Set_Type := Item; 1669 1670 begin 1671 declare 1672 Last_Img : constant String := Socket_Set.Last'Img; 1673 Buffer : String 1674 (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length); 1675 Index : Positive := 1; 1676 Socket : Socket_Type; 1677 1678 begin 1679 while not Is_Empty (Socket_Set) loop 1680 Get (Socket_Set, Socket); 1681 1682 declare 1683 Socket_Img : constant String := Socket'Img; 1684 begin 1685 Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img; 1686 Index := Index + Socket_Img'Length; 1687 end; 1688 end loop; 1689 1690 return "[" & Last_Img & "]" & Buffer (1 .. Index - 1); 1691 end; 1692 end Image; 1693 1694 --------------- 1695 -- Inet_Addr -- 1696 --------------- 1697 1698 function Inet_Addr (Image : String) return Inet_Addr_Type is 1699 use Interfaces.C; 1700 1701 Img : aliased char_array := To_C (Image); 1702 Res : C.int; 1703 Result : Inet_Addr_Type; 1704 IPv6 : constant Boolean := Is_IPv6_Address (Image); 1705 Ia : aliased In_Addr_Union 1706 (if IPv6 then Family_Inet6 else Family_Inet); 1707 begin 1708 -- Special case for an empty Image as on some platforms (e.g. Windows) 1709 -- calling Inet_Addr("") will not return an error. 1710 1711 if Image = "" then 1712 Raise_Socket_Error (SOSC.EINVAL); 1713 end if; 1714 1715 Res := Inet_Pton 1716 ((if IPv6 then SOSC.AF_INET6 else SOSC.AF_INET), Img'Address, 1717 Ia'Address); 1718 1719 if Res < 0 then 1720 Raise_Socket_Error (Socket_Errno); 1721 1722 elsif Res = 0 then 1723 Raise_Socket_Error (SOSC.EINVAL); 1724 end if; 1725 1726 if IPv6 then 1727 To_Inet_Addr (Ia.In6, Result); 1728 else 1729 To_Inet_Addr (Ia.In4, Result); 1730 end if; 1731 1732 return Result; 1733 end Inet_Addr; 1734 1735 ---------------- 1736 -- Initialize -- 1737 ---------------- 1738 1739 procedure Initialize (X : in out Sockets_Library_Controller) is 1740 pragma Unreferenced (X); 1741 1742 begin 1743 Thin.Initialize; 1744 end Initialize; 1745 1746 ---------------- 1747 -- Initialize -- 1748 ---------------- 1749 1750 procedure Initialize (Process_Blocking_IO : Boolean) is 1751 Expected : constant Boolean := not SOSC.Thread_Blocking_IO; 1752 1753 begin 1754 if Process_Blocking_IO /= Expected then 1755 raise Socket_Error with 1756 "incorrect Process_Blocking_IO setting, expected " & Expected'Img; 1757 end if; 1758 1759 -- This is a dummy placeholder for an obsolete API 1760 1761 -- Real initialization actions are in Initialize primitive operation 1762 -- of Sockets_Library_Controller. 1763 1764 null; 1765 end Initialize; 1766 1767 ---------------- 1768 -- Initialize -- 1769 ---------------- 1770 1771 procedure Initialize is 1772 begin 1773 -- This is a dummy placeholder for an obsolete API 1774 1775 -- Real initialization actions are in Initialize primitive operation 1776 -- of Sockets_Library_Controller. 1777 1778 null; 1779 end Initialize; 1780 1781 ---------------- 1782 -- Is_Windows -- 1783 ---------------- 1784 1785 function Is_Windows return Boolean is 1786 use SOSC; 1787 begin 1788 return Target_OS = Windows; 1789 end Is_Windows; 1790 1791 -------------- 1792 -- Is_Empty -- 1793 -------------- 1794 1795 function Is_Empty (Item : Socket_Set_Type) return Boolean is 1796 begin 1797 return Item.Last = No_Socket; 1798 end Is_Empty; 1799 1800 --------------------- 1801 -- Is_IPv6_Address -- 1802 --------------------- 1803 1804 function Is_IPv6_Address (Name : String) return Boolean is 1805 Prev_Colon : Natural := 0; 1806 Double_Colon : Boolean := False; 1807 Colons : Natural := 0; 1808 begin 1809 for J in Name'Range loop 1810 if Name (J) = ':' then 1811 Colons := Colons + 1; 1812 1813 if Prev_Colon > 0 and then J = Prev_Colon + 1 then 1814 if Double_Colon then 1815 -- Only one double colon allowed 1816 return False; 1817 end if; 1818 1819 Double_Colon := True; 1820 1821 elsif J = Name'Last then 1822 -- Single colon at the end is not allowed 1823 return False; 1824 end if; 1825 1826 Prev_Colon := J; 1827 1828 elsif Prev_Colon = Name'First then 1829 -- Single colon at start is not allowed 1830 return False; 1831 1832 elsif Name (J) = '.' then 1833 return Prev_Colon > 0 1834 and then Is_IPv4_Address (Name (Prev_Colon + 1 .. Name'Last)); 1835 1836 elsif Name (J) not in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' then 1837 return False; 1838 1839 end if; 1840 end loop; 1841 1842 return Colons in 2 .. 8; 1843 end Is_IPv6_Address; 1844 1845 --------------------- 1846 -- Is_IPv4_Address -- 1847 --------------------- 1848 1849 function Is_IPv4_Address (Name : String) return Boolean is 1850 Dots : Natural := 0; 1851 1852 begin 1853 -- Perform a cursory check for a dotted quad: we must have 1 to 3 dots, 1854 -- and there must be at least one digit around each. 1855 1856 for J in Name'Range loop 1857 if Name (J) = '.' then 1858 1859 -- Check that the dot is not in first or last position, and that 1860 -- it is followed by a digit. Note that we already know that it is 1861 -- preceded by a digit, or we would have returned earlier on. 1862 1863 if J in Name'First + 1 .. Name'Last - 1 1864 and then Name (J + 1) in '0' .. '9' 1865 then 1866 Dots := Dots + 1; 1867 1868 -- Definitely not a proper dotted quad 1869 1870 else 1871 return False; 1872 end if; 1873 1874 elsif Name (J) not in '0' .. '9' then 1875 return False; 1876 end if; 1877 end loop; 1878 1879 return Dots in 1 .. 3; 1880 end Is_IPv4_Address; 1881 1882 ------------- 1883 -- Is_Open -- 1884 ------------- 1885 1886 function Is_Open (S : Selector_Type) return Boolean is 1887 begin 1888 if S.Is_Null then 1889 return True; 1890 1891 else 1892 -- Either both controlling socket descriptors are valid (case of an 1893 -- open selector) or neither (case of a closed selector). 1894 1895 pragma Assert ((S.R_Sig_Socket /= No_Socket) 1896 = 1897 (S.W_Sig_Socket /= No_Socket)); 1898 1899 return S.R_Sig_Socket /= No_Socket; 1900 end if; 1901 end Is_Open; 1902 1903 ------------ 1904 -- Is_Set -- 1905 ------------ 1906 1907 function Is_Set 1908 (Item : Socket_Set_Type; 1909 Socket : Socket_Type) return Boolean 1910 is 1911 begin 1912 Check_For_Fd_Set (Socket); 1913 1914 return Item.Last /= No_Socket 1915 and then Socket <= Item.Last 1916 and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0; 1917 end Is_Set; 1918 1919 ------------------- 1920 -- Listen_Socket -- 1921 ------------------- 1922 1923 procedure Listen_Socket 1924 (Socket : Socket_Type; 1925 Length : Natural := 15) 1926 is 1927 Res : constant C.int := C_Listen (C.int (Socket), C.int (Length)); 1928 begin 1929 if Res = Failure then 1930 Raise_Socket_Error (Socket_Errno); 1931 end if; 1932 end Listen_Socket; 1933 1934 ------------ 1935 -- Narrow -- 1936 ------------ 1937 1938 procedure Narrow (Item : in out Socket_Set_Type) is 1939 Last : aliased C.int := C.int (Item.Last); 1940 begin 1941 if Item.Last /= No_Socket then 1942 Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access); 1943 Item.Last := Socket_Type (Last); 1944 end if; 1945 end Narrow; 1946 1947 ---------------- 1948 -- Netdb_Lock -- 1949 ---------------- 1950 1951 procedure Netdb_Lock is 1952 begin 1953 if Need_Netdb_Lock then 1954 System.Task_Lock.Lock; 1955 end if; 1956 end Netdb_Lock; 1957 1958 ------------------ 1959 -- Netdb_Unlock -- 1960 ------------------ 1961 1962 procedure Netdb_Unlock is 1963 begin 1964 if Need_Netdb_Lock then 1965 System.Task_Lock.Unlock; 1966 end if; 1967 end Netdb_Unlock; 1968 1969 ---------------------------- 1970 -- Network_Socket_Address -- 1971 ---------------------------- 1972 1973 function Network_Socket_Address 1974 (Addr : Inet_Addr_Type; Port : Port_Type) return Sock_Addr_Type is 1975 begin 1976 return Result : Sock_Addr_Type (Addr.Family) do 1977 Result.Addr := Addr; 1978 Result.Port := Port; 1979 end return; 1980 end Network_Socket_Address; 1981 1982 -------------------------------- 1983 -- Normalize_Empty_Socket_Set -- 1984 -------------------------------- 1985 1986 procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is 1987 begin 1988 if S.Last = No_Socket then 1989 Reset_Socket_Set (S.Set'Access); 1990 end if; 1991 end Normalize_Empty_Socket_Set; 1992 1993 ------------------- 1994 -- Official_Name -- 1995 ------------------- 1996 1997 function Official_Name (E : Host_Entry_Type) return String is 1998 begin 1999 return To_String (E.Official); 2000 end Official_Name; 2001 2002 ------------------- 2003 -- Official_Name -- 2004 ------------------- 2005 2006 function Official_Name (S : Service_Entry_Type) return String is 2007 begin 2008 return To_String (S.Official); 2009 end Official_Name; 2010 2011 -------------------- 2012 -- Wait_On_Socket -- 2013 -------------------- 2014 2015 procedure Wait_On_Socket 2016 (Socket : Socket_Type; 2017 For_Read : Boolean; 2018 Timeout : Selector_Duration; 2019 Selector : access Selector_Type := null; 2020 Status : out Selector_Status) 2021 is 2022 type Local_Selector_Access is access Selector_Type; 2023 for Local_Selector_Access'Storage_Size use Selector_Type'Size; 2024 2025 S : Selector_Access; 2026 -- Selector to use for waiting 2027 2028 R_Fd_Set : Socket_Set_Type; 2029 W_Fd_Set : Socket_Set_Type; 2030 2031 begin 2032 -- Create selector if not provided by the user 2033 2034 if Selector = null then 2035 declare 2036 Local_S : constant Local_Selector_Access := new Selector_Type; 2037 begin 2038 S := Local_S.all'Unchecked_Access; 2039 Create_Selector (S.all); 2040 end; 2041 2042 else 2043 S := Selector.all'Access; 2044 end if; 2045 2046 if For_Read then 2047 Set (R_Fd_Set, Socket); 2048 else 2049 Set (W_Fd_Set, Socket); 2050 end if; 2051 2052 Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout); 2053 2054 if Selector = null then 2055 Close_Selector (S.all); 2056 end if; 2057 end Wait_On_Socket; 2058 2059 ----------------- 2060 -- Port_Number -- 2061 ----------------- 2062 2063 function Port_Number (S : Service_Entry_Type) return Port_Type is 2064 begin 2065 return S.Port; 2066 end Port_Number; 2067 2068 ------------------- 2069 -- Protocol_Name -- 2070 ------------------- 2071 2072 function Protocol_Name (S : Service_Entry_Type) return String is 2073 begin 2074 return To_String (S.Protocol); 2075 end Protocol_Name; 2076 2077 ---------------------- 2078 -- Raise_Host_Error -- 2079 ---------------------- 2080 2081 procedure Raise_Host_Error (H_Error : Integer; Name : String) is 2082 begin 2083 raise Host_Error with 2084 Err_Code_Image (H_Error) 2085 & Dedot (Host_Error_Messages.Host_Error_Message (H_Error)) 2086 & ": " & Name; 2087 end Raise_Host_Error; 2088 2089 ------------------------ 2090 -- Raise_Socket_Error -- 2091 ------------------------ 2092 2093 procedure Raise_Socket_Error (Error : Integer) is 2094 begin 2095 raise Socket_Error with 2096 Err_Code_Image (Error) & Socket_Error_Message (Error); 2097 end Raise_Socket_Error; 2098 2099 ---------- 2100 -- Read -- 2101 ---------- 2102 2103 procedure Read 2104 (Stream : in out Datagram_Socket_Stream_Type; 2105 Item : out Ada.Streams.Stream_Element_Array; 2106 Last : out Ada.Streams.Stream_Element_Offset) 2107 is 2108 begin 2109 Receive_Socket 2110 (Stream.Socket, 2111 Item, 2112 Last, 2113 Stream.From); 2114 end Read; 2115 2116 ---------- 2117 -- Read -- 2118 ---------- 2119 2120 procedure Read 2121 (Stream : in out Stream_Socket_Stream_Type; 2122 Item : out Ada.Streams.Stream_Element_Array; 2123 Last : out Ada.Streams.Stream_Element_Offset) 2124 is 2125 First : Ada.Streams.Stream_Element_Offset := Item'First; 2126 Index : Ada.Streams.Stream_Element_Offset := First - 1; 2127 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; 2128 2129 begin 2130 loop 2131 Receive_Socket (Stream.Socket, Item (First .. Max), Index); 2132 Last := Index; 2133 2134 -- Exit when all or zero data received. Zero means that the socket 2135 -- peer is closed. 2136 2137 exit when Index < First or else Index = Max; 2138 2139 First := Index + 1; 2140 end loop; 2141 end Read; 2142 2143 -------------------- 2144 -- Receive_Socket -- 2145 -------------------- 2146 2147 procedure Receive_Socket 2148 (Socket : Socket_Type; 2149 Item : out Ada.Streams.Stream_Element_Array; 2150 Last : out Ada.Streams.Stream_Element_Offset; 2151 Flags : Request_Flag_Type := No_Request_Flag) 2152 is 2153 Res : C.int; 2154 2155 begin 2156 Res := 2157 C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags)); 2158 2159 if Res = Failure then 2160 Raise_Socket_Error (Socket_Errno); 2161 end if; 2162 2163 Last := Last_Index (First => Item'First, Count => size_t (Res)); 2164 end Receive_Socket; 2165 2166 -------------------- 2167 -- Receive_Socket -- 2168 -------------------- 2169 2170 procedure Receive_Socket 2171 (Socket : Socket_Type; 2172 Item : out Ada.Streams.Stream_Element_Array; 2173 Last : out Ada.Streams.Stream_Element_Offset; 2174 From : out Sock_Addr_Type; 2175 Flags : Request_Flag_Type := No_Request_Flag) 2176 is 2177 Res : C.int; 2178 Sin : aliased Sockaddr; 2179 Len : aliased C.int := Sin'Size / 8; 2180 2181 begin 2182 Res := 2183 C_Recvfrom 2184 (C.int (Socket), 2185 Item'Address, 2186 Item'Length, 2187 To_Int (Flags), 2188 Sin'Address, 2189 Len'Access); 2190 2191 if Res = Failure then 2192 Raise_Socket_Error (Socket_Errno); 2193 end if; 2194 2195 Last := Last_Index (First => Item'First, Count => size_t (Res)); 2196 2197 From := Get_Address (Sin, Len); 2198 end Receive_Socket; 2199 2200 -------------------- 2201 -- Receive_Vector -- 2202 -------------------- 2203 2204 procedure Receive_Vector 2205 (Socket : Socket_Type; 2206 Vector : Vector_Type; 2207 Count : out Ada.Streams.Stream_Element_Count; 2208 Flags : Request_Flag_Type := No_Request_Flag) 2209 is 2210 Res : ssize_t; 2211 2212 Msg : Msghdr := 2213 (Msg_Name => System.Null_Address, 2214 Msg_Namelen => 0, 2215 Msg_Iov => Vector'Address, 2216 2217 -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other 2218 -- platforms) when the supplied vector is longer than IOV_MAX, 2219 -- so use minimum of the two lengths. 2220 2221 Msg_Iovlen => SOSC.Msg_Iovlen_T'Min 2222 (Vector'Length, SOSC.IOV_MAX), 2223 2224 Msg_Control => System.Null_Address, 2225 Msg_Controllen => 0, 2226 Msg_Flags => 0); 2227 2228 begin 2229 Res := 2230 C_Recvmsg 2231 (C.int (Socket), 2232 Msg'Address, 2233 To_Int (Flags)); 2234 2235 if Res = ssize_t (Failure) then 2236 Raise_Socket_Error (Socket_Errno); 2237 end if; 2238 2239 Count := Ada.Streams.Stream_Element_Count (Res); 2240 end Receive_Vector; 2241 2242 ------------------- 2243 -- Resolve_Error -- 2244 ------------------- 2245 2246 function Resolve_Error 2247 (Error_Value : Integer; 2248 From_Errno : Boolean := True) return Error_Type 2249 is 2250 use GNAT.Sockets.SOSC; 2251 2252 begin 2253 if not From_Errno then 2254 case Error_Value is 2255 when SOSC.HOST_NOT_FOUND => return Unknown_Host; 2256 when SOSC.TRY_AGAIN => return Host_Name_Lookup_Failure; 2257 when SOSC.NO_RECOVERY => return Non_Recoverable_Error; 2258 when SOSC.NO_DATA => return Unknown_Server_Error; 2259 when others => return Cannot_Resolve_Error; 2260 end case; 2261 end if; 2262 2263 -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we 2264 -- can't include it in the case statement below. 2265 2266 pragma Warnings (Off); 2267 -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time 2268 2269 if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then 2270 return Resource_Temporarily_Unavailable; 2271 end if; 2272 2273 -- This is not a case statement because if a particular error 2274 -- number constant is not defined, s-oscons-tmplt.c defines 2275 -- it to -1. If multiple constants are not defined, they 2276 -- would each be -1 and result in a "duplicate value in case" error. 2277 -- 2278 -- But we have to leave warnings off because the compiler is also 2279 -- smart enough to note that when two errnos have the same value, 2280 -- the second if condition is useless. 2281 if Error_Value = ENOERROR then 2282 return Success; 2283 elsif Error_Value = EACCES then 2284 return Permission_Denied; 2285 elsif Error_Value = EADDRINUSE then 2286 return Address_Already_In_Use; 2287 elsif Error_Value = EADDRNOTAVAIL then 2288 return Cannot_Assign_Requested_Address; 2289 elsif Error_Value = EAFNOSUPPORT then 2290 return Address_Family_Not_Supported_By_Protocol; 2291 elsif Error_Value = EALREADY then 2292 return Operation_Already_In_Progress; 2293 elsif Error_Value = EBADF then 2294 return Bad_File_Descriptor; 2295 elsif Error_Value = ECONNABORTED then 2296 return Software_Caused_Connection_Abort; 2297 elsif Error_Value = ECONNREFUSED then 2298 return Connection_Refused; 2299 elsif Error_Value = ECONNRESET then 2300 return Connection_Reset_By_Peer; 2301 elsif Error_Value = EDESTADDRREQ then 2302 return Destination_Address_Required; 2303 elsif Error_Value = EFAULT then 2304 return Bad_Address; 2305 elsif Error_Value = EHOSTDOWN then 2306 return Host_Is_Down; 2307 elsif Error_Value = EHOSTUNREACH then 2308 return No_Route_To_Host; 2309 elsif Error_Value = EINPROGRESS then 2310 return Operation_Now_In_Progress; 2311 elsif Error_Value = EINTR then 2312 return Interrupted_System_Call; 2313 elsif Error_Value = EINVAL then 2314 return Invalid_Argument; 2315 elsif Error_Value = EIO then 2316 return Input_Output_Error; 2317 elsif Error_Value = EISCONN then 2318 return Transport_Endpoint_Already_Connected; 2319 elsif Error_Value = ELOOP then 2320 return Too_Many_Symbolic_Links; 2321 elsif Error_Value = EMFILE then 2322 return Too_Many_Open_Files; 2323 elsif Error_Value = EMSGSIZE then 2324 return Message_Too_Long; 2325 elsif Error_Value = ENAMETOOLONG then 2326 return File_Name_Too_Long; 2327 elsif Error_Value = ENETDOWN then 2328 return Network_Is_Down; 2329 elsif Error_Value = ENETRESET then 2330 return Network_Dropped_Connection_Because_Of_Reset; 2331 elsif Error_Value = ENETUNREACH then 2332 return Network_Is_Unreachable; 2333 elsif Error_Value = ENOBUFS then 2334 return No_Buffer_Space_Available; 2335 elsif Error_Value = ENOPROTOOPT then 2336 return Protocol_Not_Available; 2337 elsif Error_Value = ENOTCONN then 2338 return Transport_Endpoint_Not_Connected; 2339 elsif Error_Value = ENOTSOCK then 2340 return Socket_Operation_On_Non_Socket; 2341 elsif Error_Value = EOPNOTSUPP then 2342 return Operation_Not_Supported; 2343 elsif Error_Value = EPFNOSUPPORT then 2344 return Protocol_Family_Not_Supported; 2345 elsif Error_Value = EPIPE then 2346 return Broken_Pipe; 2347 elsif Error_Value = EPROTONOSUPPORT then 2348 return Protocol_Not_Supported; 2349 elsif Error_Value = EPROTOTYPE then 2350 return Protocol_Wrong_Type_For_Socket; 2351 elsif Error_Value = ESHUTDOWN then 2352 return Cannot_Send_After_Transport_Endpoint_Shutdown; 2353 elsif Error_Value = ESOCKTNOSUPPORT then 2354 return Socket_Type_Not_Supported; 2355 elsif Error_Value = ETIMEDOUT then 2356 return Connection_Timed_Out; 2357 elsif Error_Value = ETOOMANYREFS then 2358 return Too_Many_References; 2359 elsif Error_Value = EWOULDBLOCK then 2360 return Resource_Temporarily_Unavailable; 2361 else 2362 return Cannot_Resolve_Error; 2363 end if; 2364 pragma Warnings (On); 2365 2366 end Resolve_Error; 2367 2368 ----------------------- 2369 -- Resolve_Exception -- 2370 ----------------------- 2371 2372 function Resolve_Exception 2373 (Occurrence : Exception_Occurrence) return Error_Type 2374 is 2375 Id : constant Exception_Id := Exception_Identity (Occurrence); 2376 Msg : constant String := Exception_Message (Occurrence); 2377 First : Natural; 2378 Last : Natural; 2379 Val : Integer; 2380 2381 begin 2382 First := Msg'First; 2383 while First <= Msg'Last 2384 and then Msg (First) not in '0' .. '9' 2385 loop 2386 First := First + 1; 2387 end loop; 2388 2389 if First > Msg'Last then 2390 return Cannot_Resolve_Error; 2391 end if; 2392 2393 Last := First; 2394 while Last < Msg'Last 2395 and then Msg (Last + 1) in '0' .. '9' 2396 loop 2397 Last := Last + 1; 2398 end loop; 2399 2400 Val := Integer'Value (Msg (First .. Last)); 2401 2402 if Id = Socket_Error_Id then 2403 return Resolve_Error (Val); 2404 2405 elsif Id = Host_Error_Id then 2406 return Resolve_Error (Val, False); 2407 2408 else 2409 return Cannot_Resolve_Error; 2410 end if; 2411 end Resolve_Exception; 2412 2413 ----------------- 2414 -- Send_Socket -- 2415 ----------------- 2416 2417 procedure Send_Socket 2418 (Socket : Socket_Type; 2419 Item : Ada.Streams.Stream_Element_Array; 2420 Last : out Ada.Streams.Stream_Element_Offset; 2421 Flags : Request_Flag_Type := No_Request_Flag) 2422 is 2423 begin 2424 Send_Socket (Socket, Item, Last, To => null, Flags => Flags); 2425 end Send_Socket; 2426 2427 ----------------- 2428 -- Send_Socket -- 2429 ----------------- 2430 2431 procedure Send_Socket 2432 (Socket : Socket_Type; 2433 Item : Ada.Streams.Stream_Element_Array; 2434 Last : out Ada.Streams.Stream_Element_Offset; 2435 To : Sock_Addr_Type; 2436 Flags : Request_Flag_Type := No_Request_Flag) 2437 is 2438 begin 2439 Send_Socket 2440 (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags); 2441 end Send_Socket; 2442 2443 ----------------- 2444 -- Send_Socket -- 2445 ----------------- 2446 2447 procedure Send_Socket 2448 (Socket : Socket_Type; 2449 Item : Ada.Streams.Stream_Element_Array; 2450 Last : out Ada.Streams.Stream_Element_Offset; 2451 To : access Sock_Addr_Type; 2452 Flags : Request_Flag_Type := No_Request_Flag) 2453 is 2454 Res : C.int; 2455 2456 Sin : aliased Sockaddr; 2457 C_To : System.Address; 2458 Len : C.int; 2459 2460 begin 2461 if To /= null then 2462 Set_Address (Sin'Unchecked_Access, To.all, Len); 2463 C_To := Sin'Address; 2464 2465 else 2466 C_To := System.Null_Address; 2467 Len := 0; 2468 end if; 2469 2470 Res := C_Sendto 2471 (C.int (Socket), 2472 Item'Address, 2473 Item'Length, 2474 Set_Forced_Flags (To_Int (Flags)), 2475 C_To, 2476 Len); 2477 2478 if Res = Failure then 2479 Raise_Socket_Error (Socket_Errno); 2480 end if; 2481 2482 Last := Last_Index (First => Item'First, Count => size_t (Res)); 2483 end Send_Socket; 2484 2485 ----------------- 2486 -- Send_Vector -- 2487 ----------------- 2488 2489 procedure Send_Vector 2490 (Socket : Socket_Type; 2491 Vector : Vector_Type; 2492 Count : out Ada.Streams.Stream_Element_Count; 2493 Flags : Request_Flag_Type := No_Request_Flag) 2494 is 2495 use Interfaces.C; 2496 2497 Res : ssize_t; 2498 Iov_Count : SOSC.Msg_Iovlen_T; 2499 This_Iov_Count : SOSC.Msg_Iovlen_T; 2500 Msg : Msghdr; 2501 2502 begin 2503 Count := 0; 2504 Iov_Count := 0; 2505 while Iov_Count < Vector'Length loop 2506 2507 pragma Warnings (Off); 2508 -- Following test may be compile time known on some targets 2509 2510 This_Iov_Count := 2511 (if Vector'Length - Iov_Count > SOSC.IOV_MAX 2512 then SOSC.IOV_MAX 2513 else Vector'Length - Iov_Count); 2514 2515 pragma Warnings (On); 2516 2517 Msg := 2518 (Msg_Name => System.Null_Address, 2519 Msg_Namelen => 0, 2520 Msg_Iov => Vector 2521 (Vector'First + Integer (Iov_Count))'Address, 2522 Msg_Iovlen => This_Iov_Count, 2523 Msg_Control => System.Null_Address, 2524 Msg_Controllen => 0, 2525 Msg_Flags => 0); 2526 2527 Res := 2528 C_Sendmsg 2529 (C.int (Socket), 2530 Msg'Address, 2531 Set_Forced_Flags (To_Int (Flags))); 2532 2533 if Res = ssize_t (Failure) then 2534 Raise_Socket_Error (Socket_Errno); 2535 end if; 2536 2537 Count := Count + Ada.Streams.Stream_Element_Count (Res); 2538 Iov_Count := Iov_Count + This_Iov_Count; 2539 end loop; 2540 end Send_Vector; 2541 2542 --------- 2543 -- Set -- 2544 --------- 2545 2546 procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is 2547 begin 2548 Check_For_Fd_Set (Socket); 2549 2550 if Item.Last = No_Socket then 2551 2552 -- Uninitialized socket set, make sure it is properly zeroed out 2553 2554 Reset_Socket_Set (Item.Set'Access); 2555 Item.Last := Socket; 2556 2557 elsif Item.Last < Socket then 2558 Item.Last := Socket; 2559 end if; 2560 2561 Insert_Socket_In_Set (Item.Set'Access, C.int (Socket)); 2562 end Set; 2563 2564 ----------------------- 2565 -- Set_Close_On_Exec -- 2566 ----------------------- 2567 2568 procedure Set_Close_On_Exec 2569 (Socket : Socket_Type; 2570 Close_On_Exec : Boolean; 2571 Status : out Boolean) 2572 is 2573 function C_Set_Close_On_Exec 2574 (Socket : Socket_Type; Close_On_Exec : C.int) return C.int; 2575 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); 2576 begin 2577 Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0; 2578 end Set_Close_On_Exec; 2579 2580 ---------------------- 2581 -- Set_Forced_Flags -- 2582 ---------------------- 2583 2584 function Set_Forced_Flags (F : C.int) return C.int is 2585 use type C.unsigned; 2586 function To_unsigned is 2587 new Ada.Unchecked_Conversion (C.int, C.unsigned); 2588 function To_int is 2589 new Ada.Unchecked_Conversion (C.unsigned, C.int); 2590 begin 2591 return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags); 2592 end Set_Forced_Flags; 2593 2594 ----------------------- 2595 -- Set_Socket_Option -- 2596 ----------------------- 2597 2598 procedure Set_Socket_Option 2599 (Socket : Socket_Type; 2600 Level : Level_Type; 2601 Option : Option_Type) 2602 is 2603 use type C.unsigned; 2604 2605 MR : aliased IPV6_Mreq; 2606 V8 : aliased Two_Ints; 2607 V4 : aliased C.int; 2608 U4 : aliased C.unsigned; 2609 V1 : aliased C.unsigned_char; 2610 VT : aliased Timeval; 2611 Len : C.int; 2612 Add : System.Address := Null_Address; 2613 Res : C.int; 2614 Onm : C.int; 2615 2616 begin 2617 case Option.Name is 2618 when Generic_Option => 2619 V4 := Option.Optval; 2620 Len := V4'Size / 8; 2621 Add := V4'Address; 2622 2623 when Broadcast 2624 | Keep_Alive 2625 | No_Delay 2626 | Reuse_Address 2627 | Multicast_Loop_V4 2628 | Multicast_Loop_V6 2629 | IPv6_Only 2630 => 2631 V4 := C.int (Boolean'Pos (Option.Enabled)); 2632 Len := V4'Size / 8; 2633 Add := V4'Address; 2634 2635 when Busy_Polling => 2636 V4 := C.int (Option.Microseconds); 2637 Len := V4'Size / 8; 2638 Add := V4'Address; 2639 2640 when Linger => 2641 V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled)); 2642 V8 (V8'Last) := C.int (Option.Seconds); 2643 Len := V8'Size / 8; 2644 Add := V8'Address; 2645 2646 when Receive_Buffer 2647 | Send_Buffer 2648 => 2649 V4 := C.int (Option.Size); 2650 Len := V4'Size / 8; 2651 Add := V4'Address; 2652 2653 when Error => 2654 V4 := C.int (Boolean'Pos (True)); 2655 Len := V4'Size / 8; 2656 Add := V4'Address; 2657 2658 when Add_Membership_V4 2659 | Drop_Membership_V4 2660 => 2661 V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address)); 2662 V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface)); 2663 Len := V8'Size / 8; 2664 Add := V8'Address; 2665 2666 when Add_Membership_V6 2667 | Drop_Membership_V6 => 2668 MR.ipv6mr_multiaddr := To_In6_Addr (Option.Multicast_Address); 2669 MR.ipv6mr_interface := C.unsigned (Option.Interface_Index); 2670 Len := MR'Size / 8; 2671 Add := MR'Address; 2672 2673 when Multicast_If_V4 => 2674 V4 := To_Int (To_In_Addr (Option.Outgoing_If)); 2675 Len := V4'Size / 8; 2676 Add := V4'Address; 2677 2678 when Multicast_If_V6 => 2679 V4 := C.int (Option.Outgoing_If_Index); 2680 Len := V4'Size / 8; 2681 Add := V4'Address; 2682 2683 when Multicast_TTL => 2684 V1 := C.unsigned_char (Option.Time_To_Live); 2685 Len := V1'Size / 8; 2686 Add := V1'Address; 2687 2688 when Multicast_Hops => 2689 V4 := C.int (Option.Hop_Limit); 2690 Len := V4'Size / 8; 2691 Add := V4'Address; 2692 2693 when Receive_Packet_Info 2694 => 2695 V1 := C.unsigned_char (Boolean'Pos (Option.Enabled)); 2696 Len := V1'Size / 8; 2697 Add := V1'Address; 2698 2699 when Receive_Timeout 2700 | Send_Timeout 2701 => 2702 if Is_Windows then 2703 2704 -- On Windows, the timeout is a DWORD in milliseconds 2705 2706 Len := U4'Size / 8; 2707 Add := U4'Address; 2708 2709 U4 := C.unsigned (Option.Timeout / 0.001); 2710 2711 if Option.Timeout > 0.0 and then U4 = 0 then 2712 -- Avoid round to zero. Zero timeout mean unlimited. 2713 U4 := 1; 2714 end if; 2715 2716 -- Old windows versions actual timeout is 500 ms + the given 2717 -- value (unless it is 0). 2718 2719 if Minus_500ms_Windows_Timeout /= 0 then 2720 if U4 > 500 then 2721 U4 := U4 - 500; 2722 2723 elsif U4 > 0 then 2724 U4 := 1; 2725 end if; 2726 end if; 2727 2728 else 2729 VT := To_Timeval (Option.Timeout); 2730 Len := VT'Size / 8; 2731 Add := VT'Address; 2732 end if; 2733 end case; 2734 2735 if Option.Name in Specific_Option_Name then 2736 Onm := Options (Option.Name); 2737 2738 elsif Option.Optname = -1 then 2739 raise Socket_Error with "optname must be specified"; 2740 2741 else 2742 Onm := Option.Optname; 2743 end if; 2744 2745 Res := C_Setsockopt 2746 (C.int (Socket), 2747 Levels (Level), 2748 Onm, 2749 Add, Len); 2750 2751 if Res = Failure then 2752 Raise_Socket_Error (Socket_Errno); 2753 end if; 2754 end Set_Socket_Option; 2755 2756 --------------------- 2757 -- Shutdown_Socket -- 2758 --------------------- 2759 2760 procedure Shutdown_Socket 2761 (Socket : Socket_Type; 2762 How : Shutmode_Type := Shut_Read_Write) 2763 is 2764 Res : C.int; 2765 2766 begin 2767 Res := C_Shutdown (C.int (Socket), Shutmodes (How)); 2768 2769 if Res = Failure then 2770 Raise_Socket_Error (Socket_Errno); 2771 end if; 2772 end Shutdown_Socket; 2773 2774 ------------ 2775 -- Stream -- 2776 ------------ 2777 2778 function Stream 2779 (Socket : Socket_Type; 2780 Send_To : Sock_Addr_Type) return Stream_Access 2781 is 2782 S : Datagram_Socket_Stream_Access; 2783 2784 begin 2785 S := new Datagram_Socket_Stream_Type; 2786 S.Socket := Socket; 2787 S.To := Send_To; 2788 S.From := Get_Socket_Name (Socket); 2789 return Stream_Access (S); 2790 end Stream; 2791 2792 ------------ 2793 -- Stream -- 2794 ------------ 2795 2796 function Stream (Socket : Socket_Type) return Stream_Access is 2797 S : Stream_Socket_Stream_Access; 2798 begin 2799 S := new Stream_Socket_Stream_Type; 2800 S.Socket := Socket; 2801 return Stream_Access (S); 2802 end Stream; 2803 2804 ------------ 2805 -- To_Ada -- 2806 ------------ 2807 2808 function To_Ada (Fd : Integer) return Socket_Type is 2809 begin 2810 return Socket_Type (Fd); 2811 end To_Ada; 2812 2813 ---------- 2814 -- To_C -- 2815 ---------- 2816 2817 function To_C (Socket : Socket_Type) return Integer is 2818 begin 2819 return Integer (Socket); 2820 end To_C; 2821 2822 ----------------- 2823 -- To_Duration -- 2824 ----------------- 2825 2826 function To_Duration (Val : Timeval) return Timeval_Duration is 2827 Max_D : constant Long_Long_Integer := Long_Long_Integer (Forever - 0.5); 2828 Tv_sec_64 : constant Boolean := SOSC.SIZEOF_tv_sec = 8; 2829 -- Need to separate this condition into the constant declaration to 2830 -- avoid GNAT warning about "always true" or "always false". 2831 begin 2832 if Tv_sec_64 then 2833 -- Check for possible Duration overflow when Tv_Sec field is 64 bit 2834 -- integer. 2835 2836 if Val.Tv_Sec > time_t (Max_D) or else 2837 (Val.Tv_Sec = time_t (Max_D) and then 2838 Val.Tv_Usec > suseconds_t ((Forever - Duration (Max_D)) * 1E6)) 2839 then 2840 return Forever; 2841 end if; 2842 end if; 2843 2844 return Duration (Val.Tv_Sec) + Duration (Val.Tv_Usec) * 1.0E-6; 2845 end To_Duration; 2846 2847 ------------------- 2848 -- To_Host_Entry -- 2849 ------------------- 2850 2851 function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is 2852 Aliases_Count, Addresses_Count : Natural; 2853 2854 Family : constant Family_Type := 2855 (case Hostent_H_Addrtype (E) is 2856 when SOSC.AF_INET => Family_Inet, 2857 when SOSC.AF_INET6 => Family_Inet6, 2858 when others => Family_Unspec); 2859 2860 Addr_Len : constant C.size_t := C.size_t (Hostent_H_Length (E)); 2861 2862 begin 2863 if Family = Family_Unspec then 2864 Raise_Socket_Error (SOSC.EPFNOSUPPORT); 2865 end if; 2866 2867 Aliases_Count := 0; 2868 while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop 2869 Aliases_Count := Aliases_Count + 1; 2870 end loop; 2871 2872 Addresses_Count := 0; 2873 while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop 2874 Addresses_Count := Addresses_Count + 1; 2875 end loop; 2876 2877 return Result : Host_Entry_Type 2878 (Aliases_Length => Aliases_Count, 2879 Addresses_Length => Addresses_Count) 2880 do 2881 Result.Official := To_Name (Value (Hostent_H_Name (E))); 2882 2883 for J in Result.Aliases'Range loop 2884 Result.Aliases (J) := 2885 To_Name (Value (Hostent_H_Alias 2886 (E, C.int (J - Result.Aliases'First)))); 2887 end loop; 2888 2889 for J in Result.Addresses'Range loop 2890 declare 2891 Ia : In_Addr_Union (Family); 2892 2893 -- Hostent_H_Addr (E, <index>) may return an address that is 2894 -- not correctly aligned for In_Addr, so we need to use 2895 -- an intermediate copy operation on a type with an alignment 2896 -- of 1 to recover the value. 2897 2898 subtype Addr_Buf_T is C.char_array (1 .. Addr_Len); 2899 Unaligned_Addr : Addr_Buf_T; 2900 for Unaligned_Addr'Address 2901 use Hostent_H_Addr (E, C.int (J - Result.Addresses'First)); 2902 pragma Import (Ada, Unaligned_Addr); 2903 2904 Aligned_Addr : Addr_Buf_T; 2905 for Aligned_Addr'Address use Ia'Address; 2906 pragma Import (Ada, Aligned_Addr); 2907 2908 begin 2909 Aligned_Addr := Unaligned_Addr; 2910 if Family = Family_Inet6 then 2911 To_Inet_Addr (Ia.In6, Result.Addresses (J)); 2912 else 2913 To_Inet_Addr (Ia.In4, Result.Addresses (J)); 2914 end if; 2915 end; 2916 end loop; 2917 end return; 2918 end To_Host_Entry; 2919 2920 ------------ 2921 -- To_Int -- 2922 ------------ 2923 2924 function To_Int (F : Request_Flag_Type) return C.int 2925 is 2926 Current : Request_Flag_Type := F; 2927 Result : C.int := 0; 2928 2929 begin 2930 for J in Flags'Range loop 2931 exit when Current = 0; 2932 2933 if Current mod 2 /= 0 then 2934 if Flags (J) = -1 then 2935 Raise_Socket_Error (SOSC.EOPNOTSUPP); 2936 end if; 2937 2938 Result := Result + Flags (J); 2939 end if; 2940 2941 Current := Current / 2; 2942 end loop; 2943 2944 return Result; 2945 end To_Int; 2946 2947 ------------- 2948 -- To_Name -- 2949 ------------- 2950 2951 function To_Name (N : String) return Name_Type is 2952 begin 2953 return Name_Type'(N'Length, N); 2954 end To_Name; 2955 2956 ---------------------- 2957 -- To_Service_Entry -- 2958 ---------------------- 2959 2960 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is 2961 Aliases_Count : Natural; 2962 2963 begin 2964 Aliases_Count := 0; 2965 while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop 2966 Aliases_Count := Aliases_Count + 1; 2967 end loop; 2968 2969 return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do 2970 Result.Official := To_Name (Value (Servent_S_Name (E))); 2971 2972 for J in Result.Aliases'Range loop 2973 Result.Aliases (J) := 2974 To_Name (Value (Servent_S_Alias 2975 (E, C.int (J - Result.Aliases'First)))); 2976 end loop; 2977 2978 Result.Protocol := To_Name (Value (Servent_S_Proto (E))); 2979 Result.Port := 2980 Port_Type (Network_To_Short (Servent_S_Port (E))); 2981 end return; 2982 end To_Service_Entry; 2983 2984 --------------- 2985 -- To_String -- 2986 --------------- 2987 2988 function To_String (HN : Name_Type) return String is 2989 begin 2990 return HN.Name (1 .. HN.Length); 2991 end To_String; 2992 2993 ---------------- 2994 -- To_Timeval -- 2995 ---------------- 2996 2997 function To_Timeval (Val : Timeval_Duration) return Timeval is 2998 S : time_t; 2999 uS : suseconds_t; 3000 3001 begin 3002 -- If zero, set result as zero (otherwise it gets rounded down to -1) 3003 3004 if Val = 0.0 then 3005 S := 0; 3006 uS := 0; 3007 3008 -- Normal case where we do round down 3009 3010 else 3011 S := time_t (Val - 0.5); 3012 uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)) - 0.5); 3013 3014 if uS = -1 then 3015 -- It happen on integer duration 3016 uS := 0; 3017 end if; 3018 end if; 3019 3020 return (S, uS); 3021 end To_Timeval; 3022 3023 ----------- 3024 -- Value -- 3025 ----------- 3026 3027 function Value (S : System.Address) return String is 3028 Str : String (1 .. Positive'Last); 3029 for Str'Address use S; 3030 pragma Import (Ada, Str); 3031 3032 Terminator : Positive := Str'First; 3033 3034 begin 3035 while Str (Terminator) /= ASCII.NUL loop 3036 Terminator := Terminator + 1; 3037 end loop; 3038 3039 return Str (1 .. Terminator - 1); 3040 end Value; 3041 3042 ----------- 3043 -- Write -- 3044 ----------- 3045 3046 procedure Write 3047 (Stream : in out Datagram_Socket_Stream_Type; 3048 Item : Ada.Streams.Stream_Element_Array) 3049 is 3050 Last : Stream_Element_Offset; 3051 3052 begin 3053 Send_Socket 3054 (Stream.Socket, 3055 Item, 3056 Last, 3057 Stream.To); 3058 3059 -- It is an error if not all of the data has been sent 3060 3061 if Last /= Item'Last then 3062 Raise_Socket_Error (Socket_Errno); 3063 end if; 3064 end Write; 3065 3066 ----------- 3067 -- Write -- 3068 ----------- 3069 3070 procedure Write 3071 (Stream : in out Stream_Socket_Stream_Type; 3072 Item : Ada.Streams.Stream_Element_Array) 3073 is 3074 First : Ada.Streams.Stream_Element_Offset; 3075 Index : Ada.Streams.Stream_Element_Offset; 3076 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; 3077 3078 begin 3079 First := Item'First; 3080 Index := First - 1; 3081 while First <= Max loop 3082 Send_Socket (Stream.Socket, Item (First .. Max), Index, null); 3083 3084 -- Exit when all or zero data sent. Zero means that the socket has 3085 -- been closed by peer. 3086 3087 exit when Index < First or else Index = Max; 3088 3089 First := Index + 1; 3090 end loop; 3091 3092 -- For an empty array, we have First > Max, and hence Index >= Max (no 3093 -- error, the loop above is never executed). After a successful send, 3094 -- Index = Max. The only remaining case, Index < Max, is therefore 3095 -- always an actual send failure. 3096 3097 if Index < Max then 3098 Raise_Socket_Error (Socket_Errno); 3099 end if; 3100 end Write; 3101 3102 Sockets_Library_Controller_Object : Sockets_Library_Controller; 3103 pragma Unreferenced (Sockets_Library_Controller_Object); 3104 -- The elaboration and finalization of this object perform the required 3105 -- initialization and cleanup actions for the sockets library. 3106 3107 -------------------- 3108 -- Create_Address -- 3109 -------------------- 3110 3111 function Create_Address 3112 (Family : Family_Inet_4_6; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type 3113 is 3114 (case Family is 3115 when Family_Inet => (Family_Inet, Bytes), 3116 when Family_Inet6 => (Family_Inet6, Bytes)); 3117 3118 --------------- 3119 -- Get_Bytes -- 3120 --------------- 3121 3122 function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes is 3123 (case Addr.Family is 3124 when Family_Inet => Addr.Sin_V4, 3125 when Family_Inet6 => Addr.Sin_V6); 3126 3127 ---------- 3128 -- Mask -- 3129 ---------- 3130 3131 function Mask 3132 (Family : Family_Inet_4_6; 3133 Length : Natural; 3134 Host : Boolean := False) return Inet_Addr_Type 3135 is 3136 Addr_Len : constant Natural := Inet_Addr_Bytes_Length (Family); 3137 begin 3138 if Length > 8 * Addr_Len then 3139 raise Constraint_Error with 3140 "invalid mask length for address family " & Family'Img; 3141 end if; 3142 3143 declare 3144 B : Inet_Addr_Bytes (1 .. Addr_Len); 3145 Part : Inet_Addr_Comp_Type; 3146 begin 3147 for J in 1 .. Length / 8 loop 3148 B (J) := (if Host then 0 else 255); 3149 end loop; 3150 3151 if Length < 8 * Addr_Len then 3152 Part := 2 ** (8 - Length mod 8) - 1; 3153 B (Length / 8 + 1) := (if Host then Part else not Part); 3154 3155 for J in Length / 8 + 2 .. B'Last loop 3156 B (J) := (if Host then 255 else 0); 3157 end loop; 3158 end if; 3159 3160 return Create_Address (Family, B); 3161 end; 3162 end Mask; 3163 3164 ------------------------- 3165 -- Unix_Socket_Address -- 3166 ------------------------- 3167 3168 function Unix_Socket_Address (Addr : String) return Sock_Addr_Type is 3169 begin 3170 return Sock_Addr_Type'(Family_Unix, ASU.To_Unbounded_String (Addr)); 3171 end Unix_Socket_Address; 3172 3173 ----------- 3174 -- "and" -- 3175 ----------- 3176 3177 function "and" (Addr, Mask : Inet_Addr_Type) return Inet_Addr_Type is 3178 begin 3179 if Addr.Family /= Mask.Family then 3180 raise Constraint_Error with "incompatible address families"; 3181 end if; 3182 3183 declare 3184 A : constant Inet_Addr_Bytes := Get_Bytes (Addr); 3185 M : constant Inet_Addr_Bytes := Get_Bytes (Mask); 3186 R : Inet_Addr_Bytes (A'Range); 3187 3188 begin 3189 for J in A'Range loop 3190 R (J) := A (J) and M (J); 3191 end loop; 3192 return Create_Address (Addr.Family, R); 3193 end; 3194 end "and"; 3195 3196 ---------- 3197 -- "or" -- 3198 ---------- 3199 3200 function "or" (Net, Host : Inet_Addr_Type) return Inet_Addr_Type is 3201 begin 3202 if Net.Family /= Host.Family then 3203 raise Constraint_Error with "incompatible address families"; 3204 end if; 3205 3206 declare 3207 N : constant Inet_Addr_Bytes := Get_Bytes (Net); 3208 H : constant Inet_Addr_Bytes := Get_Bytes (Host); 3209 R : Inet_Addr_Bytes (N'Range); 3210 3211 begin 3212 for J in N'Range loop 3213 R (J) := N (J) or H (J); 3214 end loop; 3215 return Create_Address (Net.Family, R); 3216 end; 3217 end "or"; 3218 3219 ----------- 3220 -- "not" -- 3221 ----------- 3222 3223 function "not" (Mask : Inet_Addr_Type) return Inet_Addr_Type is 3224 M : constant Inet_Addr_Bytes := Get_Bytes (Mask); 3225 R : Inet_Addr_Bytes (M'Range); 3226 begin 3227 for J in R'Range loop 3228 R (J) := not M (J); 3229 end loop; 3230 return Create_Address (Mask.Family, R); 3231 end "not"; 3232 3233end GNAT.Sockets; 3234