source: rtems/c/src/lib/libbsp/i386/ts_386ex/tools/network_ada/adasockets/sockets.adb @ d333638

Last change on this file since d333638 was d333638, checked in by Ralf Corsepius <ralf.corsepius@…>, on 10/15/06 at 05:55:34

Convert to utf-8.
  • Property mode set to 100644
File size: 13.1 KB
Line 
1-----------------------------------------------------------------------------
2--                                                                         --
3--                         ADASOCKETS COMPONENTS                           --
4--                                                                         --
5--                             S O C K E T S                               --
6--                                                                         --
7--                                B o d y                                  --
8--                                                                         --
9--                        $ReleaseVersion: 0.1.3 $                         --
10--                                                                         --
11--  Copyright (C) 1998  École Nationale Supérieure des Télécommunications  --
12--                                                                         --
13--   AdaSockets is free software; you can  redistribute it and/or modify   --
14--   it  under terms of the GNU  General  Public License as published by   --
15--   the Free Software Foundation; either version 2, or (at your option)   --
16--   any later version.   AdaSockets is distributed  in the hope that it   --
17--   will be useful, but WITHOUT ANY  WARRANTY; without even the implied   --
18--   warranty of MERCHANTABILITY   or FITNESS FOR  A PARTICULAR PURPOSE.   --
19--   See the GNU General Public  License  for more details.  You  should   --
20--   have received a copy of the  GNU General Public License distributed   --
21--   with AdaSockets; see   file COPYING.  If  not,  write  to  the Free   --
22--   Software  Foundation, 59   Temple Place -   Suite  330,  Boston, MA   --
23--   02111-1307, USA.                                                      --
24--                                                                         --
25--   As a special exception, if  other  files instantiate generics  from   --
26--   this unit, or  you link this  unit with other  files to produce  an   --
27--   executable,  this  unit does  not  by  itself cause  the  resulting   --
28--   executable to be  covered by the  GNU General Public License.  This   --
29--   exception does  not  however invalidate any  other reasons  why the   --
30--   executable file might be covered by the GNU Public License.           --
31--                                                                         --
32--   The main repository for this software is located at:                  --
33--       http://www-inf.enst.fr/ANC/                                       --
34--                                                                         --
35-----------------------------------------------------------------------------
36
37with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
38with Sockets.Constants;      use Sockets.Constants;
39with Sockets.Link;
40pragma Warnings (Off, Sockets.Link);
41with Sockets.Naming;         use Sockets.Naming;
42with Sockets.Thin;           use Sockets.Thin;
43with Sockets.Utils;          use Sockets.Utils;
44
45package body Sockets is
46
47   use Ada.Streams, Interfaces.C;
48
49   Socket_Domain_Match : constant array (Socket_Domain) of int :=
50     (AF_INET => Constants.Af_Inet);
51
52   Socket_Type_Match : constant array (Socket_Type) of int :=
53     (SOCK_STREAM => Constants.Sock_Stream,
54      SOCK_DGRAM  => Constants.Sock_Dgram);
55
56   Shutdown_Type_Match : constant array (Shutdown_Type) of int :=
57     (Receive => 0,
58      Send    => 1,
59      Both    => 2);
60
61   Socket_Level_Match : constant array (Socket_Level) of int :=
62     (SOL_SOCKET => Constants.Sol_Socket,
63      IPPROTO_IP => Constants.Ipproto_Ip);
64
65   Socket_Option_Match : constant array (Socket_Option) of int :=
66     (SO_REUSEADDR       => Constants.So_Reuseaddr,
67      IP_MULTICAST_TTL   => Constants.Ip_Multicast_Ttl,
68      IP_ADD_MEMBERSHIP  => Constants.Ip_Add_Membership,
69      IP_DROP_MEMBERSHIP => Constants.Ip_Drop_Membership,
70      IP_MULTICAST_LOOP  => Constants.Ip_Multicast_Loop);
71
72   Socket_Option_Size  : constant array (Socket_Option) of Natural :=
73     (SO_REUSEADDR       => 4,
74      IP_MULTICAST_TTL   => 1,
75      IP_ADD_MEMBERSHIP  => 8,
76      IP_DROP_MEMBERSHIP => 8,
77      IP_MULTICAST_LOOP  => 1);
78
79   function "*" (Left : String; Right : Natural) return String;
80   pragma Inline ("*");
81
82   CRLF : constant String := CR & LF;
83
84   ---------
85   -- "*" --
86   ---------
87
88   function "*" (Left : String; Right : Natural) return String is
89      Result : String (1 .. Left'Length * Right);
90      First  : Positive := 1;
91      Last   : Natural  := First + Left'Length - 1;
92   begin
93      for I in 1 .. Right loop
94         Result (First .. Last) := Left;
95         First := First + Left'Length;
96         Last  := Last + Left'Length;
97      end loop;
98      return Result;
99   end "*";
100
101   -------------------
102   -- Accept_Socket --
103   -------------------
104
105   procedure Accept_Socket (Socket     : in Socket_FD;
106                            New_Socket : out Socket_FD)
107   is
108      Sin  : aliased Sockaddr_In;
109      Size : aliased int := Sin'Size / 8;
110      Code : int;
111   begin
112      Code := C_Accept (Socket.FD, Sin'Address, Size'Access);
113      if Code = Failure then
114         Raise_With_Message ("Accept system call failed");
115      else
116         New_Socket := (FD => Code);
117      end if;
118   end Accept_Socket;
119
120   ----------
121   -- Bind --
122   ----------
123
124   procedure Bind
125     (Socket : in Socket_FD;
126      Port   : in Positive)
127   is
128      Sin : aliased Sockaddr_In;
129   begin
130      Sin.Sin_Family := Constants.Af_Inet;
131      Sin.Sin_Port   := Port_To_Network (unsigned_short (Port));
132      if C_Bind (Socket.FD, Sin'Address, Sin'Size / 8) = Failure then
133         Raise_With_Message ("Bind failed");
134      end if;
135   end Bind;
136
137   -------------
138   -- Connect --
139   -------------
140
141   procedure Connect
142     (Socket : in Socket_FD;
143      Host   : in String;
144      Port   : in Positive)
145   is
146      Sin : aliased Sockaddr_In;
147   begin
148      Sin.Sin_Family := Constants.Af_Inet;
149      Sin.Sin_Addr   := To_In_Addr (Address_Of (Host));
150      Sin.Sin_Port   := Port_To_Network (unsigned_short (Port));
151      if C_Connect (Socket.FD, Sin'Address, Sin'Size / 8) = Failure then
152         raise Connection_Refused;
153      end if;
154   end Connect;
155
156   ---------------------------
157   -- Customized_Setsockopt --
158   ---------------------------
159
160   procedure Customized_Setsockopt (Socket : in Socket_FD'Class;
161                                    Optval : in Opt_Type)
162   is
163   begin
164      pragma Assert (Optval'Size / 8 = Socket_Option_Size (Optname));
165      if C_Setsockopt (Socket.FD, Socket_Level_Match (Level),
166                       Socket_Option_Match (Optname),
167                       Optval'Address, Optval'Size / 8) = Failure
168      then
169         Raise_With_Message ("Setsockopt failed");
170      end if;
171   end Customized_Setsockopt;
172
173   ---------
174   -- Get --
175   ---------
176
177   function Get (Socket : Socket_FD'Class) return String
178   is
179      Stream : constant Stream_Element_Array := Receive (Socket);
180      Result : String (Positive (Stream'First) .. Positive (Stream'Last));
181   begin
182      for I in Stream'Range loop
183         Result (Positive (I)) :=
184           Character'Val (Stream_Element'Pos (Stream (I)));
185      end loop;
186      return Result;
187   end Get;
188
189   --------------
190   -- Get_Line --
191   --------------
192
193   function Get_Line (Socket : Socket_FD'Class) return String is
194      Result : String (1 .. 1024);
195      Index  : Positive := Result'First;
196      Byte   : Stream_Element_Array (1 .. 1);
197      Char   : Character;
198   begin
199      loop
200         Receive (Socket, Byte);
201         Char := Character'Val (Stream_Element'Pos (Byte (Byte'First)));
202         if Char = LF then
203            return Result (1 .. Index - 1);
204         elsif Char /= CR then
205            Result (Index) := Char;
206            Index := Index + 1;
207            if Index > Result'Last then
208               return Result & Get_Line (Socket);
209            end if;
210         end if;
211      end loop;
212   end Get_Line;
213
214   ------------
215   -- Listen --
216   ------------
217
218   procedure Listen
219     (Socket     : in Socket_FD;
220      Queue_Size : in Positive := 5)
221   is
222   begin
223      if C_Listen (Socket.FD, int (Queue_Size)) = Failure then
224         Raise_With_Message ("Listen failed");
225      end if;
226   end Listen;
227
228   --------------
229   -- New_Line --
230   --------------
231
232   procedure New_Line (Socket : in Socket_FD'Class;
233                       Count  : in Natural := 1)
234   is
235   begin
236      Put (Socket, CRLF * Count);
237   end New_Line;
238
239   ---------
240   -- Put --
241   ---------
242
243   procedure Put (Socket : in Socket_FD'Class;
244                  Str    : in String)
245   is
246      Stream : Stream_Element_Array (Stream_Element_Offset (Str'First) ..
247                                     Stream_Element_Offset (Str'Last));
248   begin
249      for I in Str'Range loop
250         Stream (Stream_Element_Offset (I)) :=
251           Stream_Element'Val (Character'Pos (Str (I)));
252      end loop;
253      Send (Socket, Stream);
254   end Put;
255
256   --------------
257   -- Put_Line --
258   --------------
259
260   procedure Put_Line (Socket : in Socket_FD'Class; Str : in String)
261   is
262   begin
263      Put (Socket, Str & CRLF);
264   end Put_Line;
265
266   -------------
267   -- Receive --
268   -------------
269
270   function Receive (Socket : Socket_FD; Max : Stream_Element_Count := 4096)
271     return Ada.Streams.Stream_Element_Array
272   is
273      Buffer  : Stream_Element_Array (1 .. Max);
274      Addr    : aliased In_Addr;
275      Addrlen : aliased int := Addr'Size / 8;
276      Count   : constant int :=
277        C_Recvfrom (Socket.FD, Buffer'Address, Buffer'Length, 0,
278                    Addr'Address, Addrlen'Access);
279   begin
280      if Count < 0 then
281         Raise_With_Message ("Receive error");
282      elsif Count = 0 then
283         raise Connection_Closed;
284      end if;
285      return Buffer (1 .. Stream_Element_Offset (Count));
286   end Receive;
287
288   -------------
289   -- Receive --
290   -------------
291
292   procedure Receive (Socket : in Socket_FD'Class;
293                      Data   : out Ada.Streams.Stream_Element_Array)
294   is
295      Index : Stream_Element_Offset := Data'First;
296      Rest  : Stream_Element_Count  := Data'Length;
297   begin
298      while Rest > 0 loop
299         declare
300            Sub_Buffer : constant Stream_Element_Array :=
301              Receive (Socket, Rest);
302            Length     : constant Stream_Element_Count := Sub_Buffer'Length;
303         begin
304            Data (Index .. Index + Length - 1) := Sub_Buffer;
305            Index := Index + Length;
306            Rest  := Rest - Length;
307         end;
308      end loop;
309   end Receive;
310
311   ----------
312   -- Send --
313   ----------
314
315   procedure Send (Socket : in Socket_FD;
316                   Data   : in Stream_Element_Array)
317   is
318      Index : Stream_Element_Offset  := Data'First;
319      Rest  : Stream_Element_Count   := Data'Length;
320      Count : int;
321   begin
322      while Rest > 0 loop
323         Count := C_Send (Socket.FD, Data (Index) 'Address, int (Rest), 0);
324         if Count < 0 then
325            Raise_With_Message ("Send failed");
326         elsif Count = 0 then
327            raise Connection_Closed;
328         end if;
329         Index := Index + Stream_Element_Count (Count);
330         Rest  := Rest - Stream_Element_Count (Count);
331      end loop;
332   end Send;
333
334   ----------------
335   -- Setsockopt --
336   ----------------
337
338   procedure Setsockopt
339     (Socket  : in Socket_FD'Class;
340      Level   : in Socket_Level := Sol_Socket;
341      Optname : in Socket_Option;
342      Optval  : in Integer)
343   is
344   begin
345      case Socket_Option_Size (Optname) is
346
347         when 1 =>
348            declare
349               C_Char_Optval : aliased char := char'Val (Optval);
350            begin
351               pragma Assert (C_Char_Optval'Size = 8);
352               if C_Setsockopt (Socket.FD, Socket_Level_Match (Level),
353                                Socket_Option_Match (Optname),
354                                C_Char_Optval'Address, 1) = Failure
355               then
356                  Raise_With_Message ("Setsockopt failed");
357               end if;
358            end;
359
360         when 4 =>
361            declare
362               C_Int_Optval : aliased int := int (Optval);
363            begin
364               pragma Assert (C_Int_Optval'Size = 32);
365               if C_Setsockopt (Socket.FD, Socket_Level_Match (Level),
366                                Socket_Option_Match (Optname),
367                                C_Int_Optval'Address, 4) = Failure
368               then
369                  Raise_With_Message ("Setsockopt failed");
370               end if;
371            end;
372
373         when others =>
374            Raise_With_Message ("Setsockopt called with wrong arguments",
375                                False);
376
377      end case;
378   end Setsockopt;
379
380   --------------
381   -- Shutdown --
382   --------------
383
384   procedure Shutdown (Socket : in Socket_FD;
385                       How    : in Shutdown_Type := Both)
386   is
387   begin
388      C_Shutdown (Socket.FD, Shutdown_Type_Match (How));
389   end Shutdown;
390
391   ------------
392   -- Socket --
393   ------------
394
395   procedure Socket
396     (Sock   : out Socket_FD;
397      Domain : in Socket_Domain := AF_INET;
398      Typ    : in Socket_Type   := SOCK_STREAM)
399   is
400      Result : constant int :=
401        C_Socket (Socket_Domain_Match (Domain), Socket_Type_Match (Typ), 0);
402   begin
403      if Result = Failure then
404         Raise_With_Message ("Unable to create socket");
405      end if;
406      Sock := (FD => Result);
407   end Socket;
408
409end Sockets;
Note: See TracBrowser for help on using the repository browser.