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