[adasockets] Memory leak in examples
Dmitriy Anisimkov
anisimkov at omsknet.ru
Fri Aug 6 14:33:43 CEST 2004
wojtek at power.com.pl wrote:
>Hello,
>
>It turns out that dynamically allocated tasks need to be freed. The leak is
>not relevant for the examples themselves, but the danger is that somebody
>might use the example code as a skeleton for real code.
>
>The affected files are listener.adb, stream_listener.adb, tcprelay.adb.
>Should I provide a patch or new versions of those files? Or would you
>prefer to just insert the relevant lines:
>
>
>with Ada.Unchecked_Deallocation;
>
>procedure Free is new Ada.Unchecked_Deallocation (Echo, Echo_Access);
>
>Dummy := new Echo;
>Dummy.Start (Incoming_Socket);
>Free (Dummy); -- Missing free
>
>
>
Task could be freed only after termination.
You should do something like that.
loop
delay Some_Time;
if Dumme'Terminated then
Free (Dummy);
exit;
end if;
end loop;
I made a program relay.adb, similar to tcprelay.adb but with dynamic
task deallocation and based on the
AWS sockets interface. Task deallocation is performed in the special
task Destructor, which is waiting for termination
and deallocate the task. See attachment.
-------------- next part --------------
-----------------------------------------------------------------------------
-- --
-- R E L A Y --
-- --
-- Copyright (C) 2002-2004 --
-- Dmitriy Anisimkov --
-- --
-- Relay is free software; you can redistribute it and/or modify --
-- it under terms of the GNU General Public License as published by --
-- the Free Software Foundation; either version 2, or (at your option) --
-- any later version. AdaSockets is distributed in the hope that it --
-- will be useful, but WITHOUT ANY WARRANTY; without even the implied --
-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- See the GNU General Public License for more details. You should --
-- have received a copy of the GNU General Public License distributed --
-- with AdaSockets; see file COPYING. If not, write to the Free --
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --
-- 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from --
-- this unit, or you link this unit with other files to produce an --
-- executable, this unit does not by itself cause the resulting --
-- executable to be covered by the GNU General Public License. This --
-- exception does not however invalidate any other reasons why the --
-- executable file might be covered by the GNU Public License. --
-----------------------------------------------------------------------------
with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Text_IO;
with Ada.Streams;
with Ada.Characters.Handling;
with Ada.Unchecked_Deallocation;
with AWS.Net;
with GNAT.OS_Lib;
procedure Relay is
use Ada.Command_Line;
use Ada.Text_IO;
-- Usage: relay localport remotehost remoteport [options]
-- Example: relay 5000 localhost 25,
-- then telnet localhost 5000
use AWS;
use type Net.Socket_Access;
type Show_Enum is
(Client_IP, Error, Error_Info, First_Data, Text_Data, Binary_Data);
Output_Set : array (Show_Enum) of Boolean := (others => False);
Local_Port : Integer;
Remote_Port : Integer;
subtype Socket_Access is Net.Socket_Access;
protected Direct is
procedure Check (Where : Character);
private
Current : Character := ASCII.Nul;
end Direct;
type Relay;
type Relay_Access is access Relay;
task type Relay is
entry Start
(Socket : in Socket_Access;
Self : in Relay_Access);
end Relay;
task Destructor is
entry Free_Task (R : Relay_Access);
end Destructor;
procedure Unexpected
(E : Ada.Exceptions.Exception_Occurrence;
Text : String);
pragma Inline (Unexpected);
------------
-- Direct --
------------
protected body Direct is
-----------
-- Check --
-----------
procedure Check (Where : Character) is
begin
if Where /= Current then
Put_Line (ASCII.Lf & Current & Where);
Current := Where;
end if;
end Check;
end Direct;
----------------
-- Destructor --
----------------
task body Destructor is
Rf : Relay_Access;
procedure Free is new Ada.Unchecked_Deallocation (Relay, Relay_Access);
begin
loop
select
accept Free_Task (R : Relay_Access) do
Rf := R;
end Free_Task;
end select;
loop
exit when Rf'Terminated;
delay 0.001;
end loop;
Free (Rf);
end loop;
exception when E : others =>
Unexpected (E, "Destructor");
end Destructor;
-----------
-- Relay --
-----------
task body Relay is
Server : Net.Socket_Type'CLass := Net.Socket (Remote_Port < 0);
Client : Socket_Access;
-- symbol < on console detect server side
-- and symbol > detect client side.
Connected : Boolean := False;
Self : Relay_Access;
First_Output : Boolean := True;
procedure Move
(From_FD, To_FD : in Net.Socket_Type'Class;
Dir : in Character);
procedure Transfer;
----------
-- Move --
----------
procedure Move
(From_FD, To_FD : in Net.Socket_Type'Class;
Dir : in Character) is
begin
loop
declare
use Ada.Streams;
Tmp : Stream_Element_Array := Net.Receive (From_FD);
Last_Lf : Stream_Element_Offset := Tmp'First;
All_Text : Boolean := True;
procedure Binary_Output;
procedure Text_Output;
-------------------
-- Binary_Output --
-------------------
procedure Binary_Output is
function Hex (V : in Stream_Element) return String;
---------
-- Hex --
---------
function Hex (V : in Stream_Element) return String is
Hex_V : String (1 .. 6);
-- 16#00#
-- 123456
package IO is new Ada.Text_IO.Modular_IO (Stream_Element);
begin
IO.Put (Hex_V, V, 16);
if Hex_V (Hex_V'First) = ' ' then
return '0' & Hex_V (5);
else
return Hex_V (4 .. 5);
end if;
end Hex;
Idx : Natural := 1;
First_Binary : Stream_Element_Offset;
begin
if All_Text then
return;
end if;
if Last_Lf = Tmp'First then
First_Binary := Tmp'First;
else
First_Binary := Last_Lf + 1;
end if;
declare
Hex_Text : String
(1 .. Integer
(Tmp'Last - First_Binary + 1) * 3);
begin
for I in First_Binary .. Tmp'Last loop
Hex_Text (Idx .. Idx + 1) := Hex (Tmp (I));
if I rem 26 = 0 or I = Tmp'Last then
Hex_Text (Idx + 2) := ASCII.LF;
else
Hex_Text (Idx + 2) := ' ';
end if;
Idx := Idx + 3;
end loop;
Put (Hex_Text);
Flush;
end;
end Binary_Output;
-----------------
-- Text_Output --
-----------------
procedure Text_Output is
Text : String (1 .. Tmp'Length);
Chr : Character;
Text_Shift : constant Integer
:= Text'First - Integer (Tmp'First);
begin
for I in Tmp'Range loop
Chr := Character'Val (Stream_Element'Pos (Tmp (I)));
if Ada.Characters.Handling.Is_Graphic (Chr)
or else Chr = ASCII.Lf
or else Chr = ASCII.Ht
or else Chr = ASCII.Cr
then
Text (Integer (I) + Text_Shift) := Chr;
if Chr = ASCII.Lf then
Last_Lf := I;
end if;
else
All_Text := False;
exit;
end if;
end loop;
if All_Text then
Put (Text);
Flush;
elsif Last_Lf > Tmp'First then
Put (Text (Text'First .. Integer (Last_Lf) + Text_Shift));
Flush;
end if;
end Text_Output;
begin
if Output_Set (First_Data .. Binary_Data)
/= (First_Data .. Binary_Data => False)
then
Direct.Check (Dir);
if (Output_Set (First_Data) and First_Output)
or Output_Set (Text_Data)
then
Text_Output;
end if;
if (Output_Set (First_Data) and First_Output)
or Output_Set (Binary_Data)
then
Binary_Output;
end if;
First_Output := False;
end if;
Net.Send (To_FD, Tmp);
end;
end loop;
end Move;
--------------
-- Transfer --
--------------
procedure Transfer is
task Back_Task;
protected Flag is
entry Once (Result : out Boolean);
procedure Complete;
private
Value : Boolean := True;
Busy : Boolean := False;
end Flag;
procedure Free (Dir : Character);
---------------
-- Back_Task --
---------------
task body Back_Task is
begin
Move (Client.all, Server, '>');
exception
when Net.Socket_Error =>
Free ('>');
when E : others =>
Unexpected (E, "relay");
end Back_Task;
----------
-- Free --
----------
procedure Free (Dir : Character) is
First : Boolean;
begin
Flag.Once (First);
if First then
Net.Shutdown (Server);
Net.Shutdown (Client.all);
Put (Dir & "closed");
Flag.Complete;
else
AWS.Net.Free (Client);
AWS.Net.Free (Server);
return;
end if;
exception when E : others =>
Flag.Complete;
Unexpected (E, "in free");
end Free;
----------
-- Flag --
----------
protected body Flag is
----------
-- Once --
----------
entry Once (Result : out Boolean) when not Busy is
begin
Result := Value;
Value := False;
Busy := True;
end Once;
--------------
-- Complete --
--------------
procedure Complete is
begin
Busy := False;
end Complete;
end Flag;
begin
Move (Server, Client.all, '<');
exception
when Net.Socket_Error =>
Free ('<');
end Transfer;
begin
accept Start
(Socket : in Socket_Access;
Self : in Relay_Access)
do
Client := Socket;
Relay.Self := Start.Self;
end Start;
begin
AWS.Net.Connect (Server, Argument (2), abs (Remote_Port));
Connected := True;
exception when AWS.Net.Socket_Error =>
Put_Line (">Could not connect.");
Net.Shutdown (Client.all);
AWS.Net.Free (Client);
end;
if Connected then
Transfer;
end if;
Destructor.Free_Task (Self);
exception
when E : others =>
Put_Line ("task error");
Unexpected (E, "relay");
end Relay;
----------------
-- Unexpected --
----------------
procedure Unexpected
(E : Ada.Exceptions.Exception_Occurrence;
Text : String) is
begin
Put_Line
(Current_Error,
Text & ASCII.Lf & Ada.Exceptions.Exception_Information (E));
Flush (Current_Error);
GNAT.OS_Lib.OS_Abort;
end Unexpected;
Accepting_Socket : Net.Socket_Type'Class := Net.Socket (False);
begin
Local_Port := Integer'Value (Argument (1));
Remote_Port := Integer'Value (Argument (3));
for i in 4 .. Argument_Count loop
Output_Set (Show_Enum'Value (Argument (i))) := True;
end loop;
Net.Bind (Accepting_Socket, abs (Local_Port));
Net.Listen (Accepting_Socket);
loop
declare
Incoming_Socket : Socket_Access;
Income : Relay_Access;
begin
Incoming_Socket := Net.Socket (Local_Port < 0);
AWS.Net.Accept_Socket (Accepting_Socket,
New_Socket => Incoming_Socket.all);
if Output_Set (Client_IP) then
Put_Line (Net.Peer_Addr (Incoming_Socket.all));
end if;
Income := new Relay;
Income.Start (Incoming_Socket, Income);
exception
when E : others =>
Put_Line
(Current_Error,
"Accept " & ASCII.Lf
& Ada.Exceptions.Exception_Information (E));
if Incoming_Socket /= null then
Net.Shutdown (Incoming_Socket.all);
Net.Free (Incoming_Socket);
end if;
end;
end loop;
exception
when Constraint_Error =>
Put ("Usage: " & Command_Name & " localport remotehost remoteport");
for i in Show_Enum'Range loop
Put (" [" & Show_Enum'Image (i) & ']');
end loop;
New_Line;
when E : others =>
Put_Line ("main error");
Unexpected (E, "Unexpected error in main task");
end Relay;
More information about the AdaSockets
mailing list