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

4.104.114.84.9
Last change on this file since 1d4048b2 was 1d4048b2, checked in by Joel Sherrill <joel.sherrill@…>, on Aug 11, 1999 at 11:45:57 PM

Patch from Tony R. Ambardar <tonya@…>:

I'm attaching a big patch for the ts_386ex BSP which adds and includes
the following:

1) Conversion to ELF format + minor code cleanups + documentation.

2) An Ada95 binding to FreeBSD sockets, based on Samuel Tardieu's

adasockets-0.1.3 package. This includes some sample applications.

3) Some Ada and C interfaces to add serial-port debugging to

programs. Comes with examples, too; the Ada one shows how
transparent adding the support can be. Note that Rosimildo sent me
the original C code.

The network stuff is not BSP specific, and could be added to your Ada
code collection. The debugging stuff is specific to the i386. Right
now, everything sits in my "tools" directory.

  • 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.