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