gcc/ada/libgnat/g-sothco.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --              G N A T . S O C K E T S . T H I N _ C O M M O N             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                       Copyright (C) 2008-2024, 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
  32 package body GNAT.Sockets.Thin_Common is
  33
  34    -----------------
  35    -- Set_Address --
  36    -----------------
  37
  38    procedure Set_Address
  39      (Sin     : Sockaddr_Access;
  40       Address : Sock_Addr_Type;
  41       Length  : out C.int)
  42    is
  43       use type C.char;
  44
  45       function Network_Port return C.unsigned_short is
  46         (Short_To_Network (C.unsigned_short (Address.Port))) with Inline;
  47
  48    begin
  49       Set_Family (Sin.Sin_Family, Address.Family);
  50
  51       Length := C.int (Lengths (Address.Family));
  52
  53       case Address.Family is
  54          when Family_Inet =>
  55             Sin.Sin_Port := Network_Port;
  56             Sin.Sin_Addr := To_In_Addr (Address.Addr);
  57
  58          when Family_Inet6 =>
  59             Sin.Sin6_Port := Network_Port;
  60             Sin.Sin6_Addr := To_In6_Addr (Address.Addr);
  61             Sin.Sin6_Scope_Id := 0;
  62
  63          when Family_Unix =>
  64             declare
  65                use type C.size_t;
  66                Name_Len : constant C.size_t :=
  67                             C.size_t (ASU.Length (Address.Name));
  68             begin
  69                Length := Sockaddr_Length_And_Family'Size / System.Storage_Unit
  70                          + C.int (Name_Len);
  71
  72                if Name_Len > Sin.Sun_Path'Length then
  73                   raise Constraint_Error with
  74                     "Too big address length for UNIX local communication";
  75                end if;
  76
  77                if Name_Len = 0 then
  78                   Sin.Sun_Path (1) := C.nul;
  79
  80                else
  81                   Sin.Sun_Path (1 .. Name_Len) :=
  82                     C.To_C (ASU.To_String (Address.Name), Append_Nul => False);
  83
  84                   if Sin.Sun_Path (1) /= C.nul
  85                     and then Name_Len < Sin.Sun_Path'Length
  86                   then
  87                      Sin.Sun_Path (Name_Len + 1) := C.nul;
  88                      Length := Length + 1;
  89                   end if;
  90                end if;
  91             end;
  92
  93          when Family_Unspec =>
  94             null;
  95       end case;
  96    end Set_Address;
  97
  98    -----------------
  99    -- Get_Address --
 100    -----------------
 101
 102    function Get_Address
 103      (Sin : Sockaddr; Length : C.int) return Sock_Addr_Type
 104    is
 105       use type C.unsigned_short, C.size_t, C.char, SOSC.OS_Type;
 106       Family : constant C.unsigned_short :=
 107         (if SOSC.Has_Sockaddr_Len = 0 then Sin.Sin_Family.Short_Family
 108          else C.unsigned_short (Sin.Sin_Family.Char_Family));
 109       Result : Sock_Addr_Type
 110         (if SOSC.AF_INET6 > 0 and then SOSC.AF_INET6 = Family then Family_Inet6
 111          elsif SOSC.AF_UNIX > 0 and then SOSC.AF_UNIX = Family then Family_Unix
 112          elsif SOSC.AF_INET = Family then Family_Inet
 113          else Family_Unspec);
 114    begin
 115       case Result.Family is
 116          when Family_Inet =>
 117             Result.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
 118             To_Inet_Addr (Sin.Sin_Addr, Result.Addr);
 119          when Family_Inet6 =>
 120             Result.Port := Port_Type (Network_To_Short (Sin.Sin6_Port));
 121             To_Inet_Addr (Sin.Sin6_Addr, Result.Addr);
 122          when Family_Unix =>
 123             if Length > Sin.Sin_Family'Size / System.Storage_Unit then
 124                Result.Name := ASU.To_Unbounded_String
 125                  (C.To_Ada
 126                     (Sin.Sun_Path
 127                          (1 .. C.size_t (Length)
 128                           - Sin.Sin_Family'Size / System.Storage_Unit),
 129                      Trim_Nul => Sin.Sun_Path (1) /= C.nul
 130                                  or else SOSC.Target_OS = SOSC.Windows));
 131             end if;
 132
 133          when Family_Unspec =>
 134             null;
 135       end case;
 136
 137       return Result;
 138    end Get_Address;
 139
 140    ----------------
 141    -- Set_Family --
 142    ----------------
 143
 144    procedure Set_Family
 145      (Length_And_Family : out Sockaddr_Length_And_Family;
 146       Family            : Family_Type)
 147    is
 148       C_Family : C.int renames Families (Family);
 149       Has_Sockaddr_Len : constant Boolean := SOSC.Has_Sockaddr_Len /= 0;
 150    begin
 151       if Has_Sockaddr_Len then
 152          Length_And_Family.Length       := Lengths (Family);
 153          Length_And_Family.Char_Family  := C.unsigned_char  (C_Family);
 154       else
 155          Length_And_Family.Short_Family := C.unsigned_short (C_Family);
 156       end if;
 157    end Set_Family;
 158
 159    ----------------
 160    -- To_In_Addr --
 161    ----------------
 162
 163    function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is
 164    begin
 165       if Addr.Family = Family_Inet then
 166          return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
 167                  S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
 168                  S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
 169                  S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
 170       end if;
 171
 172       raise Socket_Error with "IPv6 not supported";
 173    end To_In_Addr;
 174
 175    ------------------
 176    -- To_Inet_Addr --
 177    ------------------
 178
 179    procedure To_Inet_Addr
 180      (Addr   : In_Addr;
 181       Result : out Inet_Addr_Type) is
 182    begin
 183       Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
 184       Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
 185       Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
 186       Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
 187    end To_Inet_Addr;
 188
 189    ------------------
 190    -- To_Inet_Addr --
 191    ------------------
 192
 193    procedure To_Inet_Addr
 194      (Addr   : In6_Addr;
 195       Result : out Inet_Addr_Type)
 196    is
 197       Sin_V6 : Inet_Addr_V6_Type;
 198    begin
 199       for J in Addr'Range loop
 200          Sin_V6 (J) := Inet_Addr_Comp_Type (Addr (J));
 201       end loop;
 202
 203       Result := (Family => Family_Inet6, Sin_V6 => Sin_V6);
 204    end To_Inet_Addr;
 205
 206    ----------------
 207    -- To_In_Addr --
 208    ----------------
 209
 210    function To_In6_Addr (Addr : Inet_Addr_Type) return In6_Addr is
 211       Result : In6_Addr;
 212    begin
 213       for J in Addr.Sin_V6'Range loop
 214          Result (J) := C.unsigned_char (Addr.Sin_V6 (J));
 215       end loop;
 216
 217       return Result;
 218    end To_In6_Addr;
 219
 220    ----------------------
 221    -- Short_To_Network --
 222    ----------------------
 223
 224    function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
 225       use Interfaces;
 226       use System;
 227
 228    begin
 229       --  Big-endian case. No conversion needed. On these platforms, htons()
 230       --  defaults to a null procedure.
 231
 232       if Default_Bit_Order = High_Order_First then
 233          return S;
 234
 235       --  Little-endian case. We must swap the high and low bytes of this
 236       --  short to make the port number network compliant.
 237
 238       else
 239          return C.unsigned_short (Rotate_Left (Unsigned_16 (S), 8));
 240       end if;
 241    end Short_To_Network;
 242
 243 end GNAT.Sockets.Thin_Common;