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