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-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
32package 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
243end GNAT.Sockets.Thin_Common;
244