Import initial

52 files changed, 15496 insertions, 0 deletions

diff --git a/src/MTools.pm b/src/MTools.pm
new file mode 100644
index 0000000..a5bf965
--- /dev/null
+++ b/src/MTools.pm
@@ -0,0 +1,711 @@
+package MTools;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# MTools exporte des fonctions destinees principalement a :
+#	- activer des fonctions propres a la librairie mtools
+#	- assurer la compatibilite entre la manipulation des objets mtools et des objets zincs
+#
+# Ainsi, d'une maniere generale, toutes fonctions exportees s'appliquent aussi bien a des objets 
+# zinc qu'a des objets mtools. L'unique restriction est dans la methode d'appel :
+#	- obligatoirement : fct ($obj, @parametres) pour un objet zinc
+#	- indefiremment $obj -> fct (@parametres).
+# L'avantage de la premiere methode est qu'elle s'applique aussi bien a un objet zinc qu'a un objet MTools. 
+# L'inconvenient est que l'on perd la possibilite de profiter de l'heritage et de la redefinition eventuelle de la fonction.
+#
+# La fonction particuliere "new" :
+#	La fonction "new" permet de generer une nouvelle frame encapsulant un canvas zinc. 
+#	Une frame MTools est unique pour une application
+#	Elle initialise par ailleurs les donnees generiques pour le fonctionnement de MTools
+#
+# Les callbacks dans MTools :
+#	\&fct : execution de fct ()
+#	[\&fct, @params] : execution de fct (@params)
+#	['fct_name', $obj, @params] : execution de $obj -> fct_name (@params)
+#	[$obj, 'fct_name', @params] : execution de $obj -> fct_name (@params)
+#	[$obj, \&fct_name, @params] : execution de fct_name ($obj, @params)
+#
+# Fonctions :
+#	- propertyExists : test si une propriete MTools a ete enregistree (par recordProperty) 
+#	pour l'objet en question. S'il s'agit d'un objet zinc la valeur retournee est forcement 0.
+#	- mconfigure : permet de configurer indifferement des proprietes zinc ou MTools d'un objet. 
+#	Les parametres sont passes sous forme d'une table de hash.
+#	Par habitude, les proprietes zinc ou definie pour assurer une compatibilite avec zinc (comme '-visible') 
+#	on ete precedees d'un '-'.
+#	- mget : $obj -> mget ('propriete') permet de recuperer la valeur d'une propriete
+#	- plisten : $obj -> plisten ('property_name', callback) plisten permet d'ecouter les modifications 
+#	des propriete mtools d'un objet => associe l'appel d'une fonction a la modification d'un objet MTools
+#	- unplisten : $obj -> unplisten ('property_name', callback) supprime l'ecoute
+#	- plink : plink ([$obj1, 'property_1'], [$obj2, 'property_2'], ...); Synchronise n proprietes. 
+#	Si property_1 est modifiee, property_2 prendra la valeur de property_1 et reciproquement. A l'initialisation,
+#	toutes les propriete prennent la valeur de property_1.
+#	- executer : executer (callback); permet d'executer une callback du type predefini ci-dessus dans la section 
+#	"Les callbacks dans MTools"
+#	- binding : $obj -> binding ('evenement', callback) permet d'ecouter un evenement MTOOLS ou Tk survenant sur un objet. binding peut aussi etre redefini pour ecouter
+#	de nouvelle source d'evenement (par exemple MIvy ou WacomAdapter)
+#	- unbinding : $obj -> unbinding ('evenement', callback) arrete l'ecoute d'un evenement
+#	- minstanciate : minstanciate ('definition', $parent) permet de retourner un objet MTools ? partir de la spec 'definition'
+#	si 'definition' est un path svg, minstanciate instancie le svg et retourne un objet MTools encapsulant le contenu
+#	si 'definition' est un objet zinc, minstanciate retourne un objet MTools encapsulant l'objet zinc
+#	si 'definition' est deja un objet MTools, minstanciate retourne l'objet lui-meme.
+#	minstanciate change egalement le groupe parent qui deviendra obligatoirement $parent
+#	- minstance : minstance ($objet, $parent) est le cousin de minstanciate mais lui retourne obligatoirement un objet zinc
+#	- mrun : lance l'execution de la main loop.
+#	- mfind : $objet -> mfind ('tag') permet de chercher un fils de l'objet ayant le tag correspondant
+#	- mplaying : permet de lire un fichier son
+# Les fonctions suivantes encapsulent l'execution des fonction zinc associees voir la doc zinc.
+# http://www.tkzinc.org/Documentation/refman-3.3.4/index.html
+#	- raise
+#	- scale
+#	- translate
+#	- rotate
+#	- coords
+#	- bbox
+#	- type
+#	- tset
+#	- treset
+#	- tget
+#	- clone
+#	- chggroup
+#	
+
+
+
+
+require Exporter;
+
+BEGIN 
+{
+	@ISA = qw / Exporter/;
+	@EXPORT = qw / %fonts $zinc translate rotate executer mconfigure binding unbinding raise mget 
+		scale getGradient chggroup plink plisten mplaying minstance mrun minstanciate 
+		propertyExists bbox mdelete mfind coords type tset treset tget clone unplisten/;
+}
+
+use strict;
+use Tk::Zinc;
+use Ivy;
+
+use MTools::MObjet;
+use MTools::SVG::SVGLoader;
+
+our $zinc;
+our %fonts;
+
+my %gradients;
+
+sub new {
+	my ($class, $width, $height, $title) = @_;
+	my $self = {};
+	bless $self, $class;
+
+	$self -> {window} = my $mw = MainWindow -> new ();
+	$mw -> title($title);
+	
+	$self -> {zinc} = $zinc = $mw -> Zinc (
+		-width => $width,
+		-height => $height,
+		-borderwidth => 0,
+		-backcolor => 'white',
+		-render => 1,
+	) -> pack (qw/-expand yes -fill both/);
+
+	return $self;
+}
+
+my $link_token = 0;
+
+sub __configure {
+	my ($obj, $sender, $key, $value) = @_;
+	my $obj_instance = ref ($obj) eq '' ? $obj : $obj -> {instance};
+	if ($obj_instance ne $obj)
+	{
+		my $oldvalue = $obj -> {__properties} -> {$key} -> {val};
+		$obj -> {__properties} -> {$key} -> {val} = $value;
+		if (defined $obj -> {__properties} -> {$key} -> {listeners})
+		{
+			my @listeners = @{$obj -> {__properties} -> {$key} -> {listeners}};
+			for (my $i = 0; $i < @listeners; $i++)
+			{
+				executer ($listeners [$i], $sender, $key, $value, $oldvalue);
+			}
+		}
+	}
+	else
+	{
+		eval 
+		{
+			$zinc -> itemconfigure ($obj_instance, $key => $value);
+		};
+		if ($@) 
+		{
+			die "##### Error MTools::__confproplink : property $key not defined for $obj\n";
+		}	
+	}
+}
+
+sub __confproplink {
+	my ($sender, $obj, $key, $val) = @_;
+	
+	my $obj_instance = ref ($obj) eq '' ? $obj : $obj -> {instance};
+	if ($obj_instance ne $obj)
+	{
+		if ($obj -> {__properties} -> {$key} -> {link_token} != $link_token)
+		{
+			$obj -> {__properties} -> {$key} -> {link_token} = $link_token;
+			if (defined $obj -> {__properties} -> {$key} -> {links})
+			{
+				my @links = @{$obj -> {__properties} -> {$key} -> {links}};
+				for (my $i = 0; $i < @links; $i ++)
+				{
+					__confproplink ($obj, $links [$i] -> [0], $links [$i] -> [1], $val);
+				}
+			}
+			__configure ($obj, $sender, $key, $val);
+		}
+	}
+	else
+	{
+		eval 
+		{
+			$zinc -> itemconfigure($obj_instance, $key => $val);
+		};
+		if ($@) 
+		{
+			die "##### Error MTools::__confproplink : property $key not defined for $obj\n";
+		}			
+	}
+}
+
+sub propertyExists {
+	my ($obj, $key) = @_;
+	my $obj_instance = ref ($obj) eq '' ? $obj : $obj -> {instance};
+	if ("$obj_instance" ne "$obj")
+	{
+		if (exists $obj -> {__properties} -> {$key})
+		{
+			return 1;
+		}
+	}
+	return 0;
+}
+
+sub mconfigure {
+	my ($obj, %options) = @_;
+	my $obj_instance = ref ($obj) eq '' ? $obj : $obj -> {instance};
+	my %zinc_props = ();
+ 	if ("$obj_instance" ne "$obj")
+	{
+ 		while ( my ($key, $val) = each (%options) )
+		{
+			my $oldval;
+			if (exists $obj -> {__properties} -> {$key})
+			{
+				if (defined $obj -> {__properties} -> {$key} -> {links})
+				{
+					$link_token ++;
+					$obj -> {__properties} -> {$key} -> {link_token} = $link_token;
+					my @links = @{$obj -> {__properties} -> {$key} -> {links}};
+					for (my $i = 0; $i < @links; $i ++)
+					{
+						 __confproplink ($obj, $links [$i] -> [0], $links [$i] -> [1], $val);
+					}
+				}
+				__configure ($obj, $obj, $key, $val);
+			}
+			else
+			{
+				$zinc_props {$key} = $val;
+			}
+		}
+ 	}
+ 	else
+ 	{
+	 	%zinc_props = %options;
+ 	}
+ 	if (defined %zinc_props)
+ 	{
+ 		eval 
+		{
+			$zinc -> itemconfigure ($obj_instance, %zinc_props);
+		};
+		if ($@) 
+		{
+			my $prop = "";
+			while (my ($k, $val) = each (%zinc_props))
+			{
+				$prop .= " '$k'";
+			}
+			die "##### Error MTools::mconfigure : one of the following properties :$prop, is not defined for $obj\n";
+		}
+	}
+}
+
+# WARNING 
+# Les modification effectuees directement sur les objets zinc ne sont pas propagees
+# En revanche, une modification effectuee sur un autre objet peut entrainer la modification 
+# d'un objets zinc.
+sub plink {
+	my (@objets) = @_;
+	if (!defined @objets) {return;}
+	
+	for (my $i = 0; $i < @objets; $i ++)
+	{
+		my $obj = $objets [$i] -> [0];
+		my $key = $objets [$i] -> [1];
+		# La propriete est une propriete zinc, 
+		if(ref ($obj) ne '')
+		{
+			# On la transforme en propriete MTools si ce n'est pas deja fait
+			if ( !defined $obj -> {__properties} -> {$key} )
+			{
+				$obj -> {__properties} -> {$key} -> {val} = $obj -> mget ($key);
+				push (@{$obj -> {__properties} -> {$key} -> {links}}, [$obj -> {instance}, $key]);
+				$obj -> {__properties} -> {$key} -> {link_token} = 0;
+				# et on associe la modification de la propriete zinc avec la modification propriete MTools
+			}
+		}
+	}
+	my $val = ($objets [0] -> [0]) -> mget ($objets [0] -> [1]);
+	# Normalement, tous les objets non zinc doivent donc avoir une propriete MTools
+	$link_token ++;
+	for (my $i = 0; $i < @objets; $i ++)
+	{
+		my $obj = $objets [$i] -> [0];
+		my $key = $objets [$i] -> [1];
+		# Si l'objet n'est pas un objet zinc, on associe a sa propriete tous ses liens
+		if(ref ($obj) ne '')
+		{
+			for (my $j = 0; $j < @objets; $j ++)
+			{
+				if ($i != $j)
+				{
+					# Enregistre
+					push (@{$obj -> {__properties} -> {$key} -> {links}}, $objets [$j]);
+					__confproplink ($objets [0], $obj, $key, $val);
+				}			
+			}
+		}
+		else
+		{
+			eval 
+			{
+				$zinc -> itemconfigure ($obj, $key => $val);
+			};
+			if ($@) 
+			{
+				die "##### Error MTools::plink : property $key not defined for $obj\n";
+			}
+		}
+	}
+}
+
+sub plisten {
+	my ($obj, $key, $methode) = @_;
+	
+	# Si la propriete est une propriete zinc, on la transforme en propriete MTools 
+	# et on lie la modification de la propriete MTools a la propriete zinc
+	if ( !defined $obj -> {__properties} -> {$key} )
+	{
+		$obj -> {__properties} -> {$key} -> {val} = $obj -> mget ($key);
+		plink ([$obj, $key], [$obj -> {instance}, $key]);
+	}
+	push (@{$obj -> {__properties} -> {$key} -> {listeners}}, $methode);
+	mconfigure ($obj, $key => mget ($obj, $key));
+	return $methode;
+}
+
+sub unplisten {
+	my ($obj, $key, $methode) = @_;
+	if (defined $obj -> {__properties} -> {$key} -> {listeners})
+	{
+		for (my $i = @{$obj -> {__properties} -> {$key} -> {listeners}} - 1; $i >=  0; $i --) 
+		{
+			if (@{$obj -> {__properties} -> {$key} -> {listeners}} [$i] eq $methode) 
+			{
+				splice (@{$obj -> {__properties} -> {$key} -> {listeners}}, $i, 1);
+			}
+		}
+	 }
+}
+
+sub mget {
+	my ($obj, $key) = @_;
+	if (ref ($obj) ne '')
+	{
+		if (defined $obj -> {__properties} -> {$key})
+		{
+			return $obj -> {__properties} -> {$key} -> {val};
+		}
+		else
+		{
+			my $retour;
+			eval 
+			{
+				$retour = $zinc -> itemcget (minstance ($obj), $key);
+			};
+			if ($@) 
+			{
+				die "##### Error MTools::mget : property $key not defined for $obj\n";
+			}
+			return $retour;
+		}
+	}
+	else
+	{
+		my $retour;
+		eval 
+		{
+			$retour = $zinc -> itemcget ($obj, $key);
+		};
+		if ($@) 
+		{
+			die "##### Error MTools::mget : property $key not defined for $obj\n";
+		}
+		return $retour;
+	}
+}
+
+sub mdelete {
+	my ($obj) = @_;
+	if (ref ($obj) ne '')
+	{
+		$zinc -> remove ($obj -> {instance});
+		$obj -> {__events} = {};
+		$obj -> {__properties} = {};
+		undef $obj;
+	}
+	else
+	{
+		$zinc -> remove ($obj);
+	}
+}
+
+sub binding {
+	my ($obj, $spec, $sub) = @_;
+	if ($spec =~ /\<(.*)\>/)
+	{
+		$obj = ref ($obj) eq ''?$obj:$obj -> {instance};
+		if (type ($obj) eq 'group')
+		{
+			mconfigure ($obj, '-atomic' => 1);
+		}
+		if (ref ($sub) eq 'ARRAY')
+		{
+			$zinc -> bind ($obj, $spec, [\&__callback_binding, @{$sub}]);
+		}
+		else
+		{
+			$zinc -> bind ($obj, $spec, [\&__callback_binding, $sub]);
+		}
+		return $sub;
+	}
+	else
+	{
+		$obj -> __addListener ($spec, $sub);
+		return $sub;
+	}
+}
+
+sub __callback_binding {
+	my ($tk, @cbk) = @_;
+	executer (\@cbk);
+}
+
+sub unbinding {
+	my ($obj, $spec, $sub) = @_;
+	if ($spec =~ /\<(.*)\>/)
+	{
+		$zinc -> bind ( ref ($obj) eq '' ? $obj : $obj -> {instance}, $spec, undef);
+	}
+	else
+	{
+		$obj -> __removeListener ($spec, $sub);
+	}
+}
+
+sub tset {
+	my ($obj, @args) = @_;
+	return $zinc -> tset (ref ($obj) eq '' ? $obj : $obj -> {instance}, @args);
+}
+
+sub tget {
+	my ($obj, $ref) = @_;
+	return $zinc -> tget (ref ($obj) eq '' ? $obj : $obj -> {instance}, $ref);
+}
+
+sub treset {
+	my ($obj) = @_;
+	return $zinc -> treset (ref ($obj) eq '' ? $obj : $obj -> {instance});
+}
+
+sub bbox {
+	my ($obj) = @_;
+	return $zinc -> bbox (ref ($obj) eq '' ? $obj : $obj -> {instance});
+}
+
+sub coords {
+	my ($obj, @args) = @_;
+	return $zinc -> coords (ref ($obj) eq '' ? $obj : $obj -> {instance}, @args);
+}
+
+sub type {
+	my ($obj) = @_;
+	$zinc -> type (ref ($obj) eq '' ? $obj : $obj -> {instance});
+}
+
+
+sub raise {
+	my ($obj) = @_;
+	$zinc -> raise (ref ($obj) eq '' ? $obj : $obj -> {instance});
+}
+
+sub chggroup {
+	my ($obj, $parent) = @_;
+	$zinc -> chggroup (ref ($obj) eq '' ? $obj : $obj -> {instance}, ref ($parent) eq '' ? $parent : $parent -> {instance});
+}
+
+sub clone {
+	my ($obj, $parent) = @_;
+	return $zinc -> clone (ref ($obj) eq '' ? $obj : $obj -> {instance});
+}
+
+sub scale {
+	my ($obj, @params) = @_;
+	$zinc -> scale (ref ($obj) eq '' ? $obj : $obj -> {instance}, @params);
+}
+
+sub translate {
+	my ($obj, @params) = @_;
+	$zinc -> translate (ref ($obj) eq '' ? $obj : $obj -> {instance}, @params);
+}
+
+sub rotate {
+	my ($obj, @params) = @_;
+	$zinc -> rotate (ref ($obj) eq '' ? $obj : $obj -> {instance}, @params);
+}
+
+sub mfind {
+	my ($obj, @params) = @_;
+	my @tagged = $zinc -> find ('withtag', @params);
+	my $ref = ref ($obj) eq '' ? $obj : $obj -> {instance};
+	if (@tagged)
+	{
+		for (my $i = 0; $i < @tagged; $i++)
+		{
+			my @ancestors = $zinc -> find ('ancestors', $tagged [$i]);
+			for (my $j = 0; $j < @ancestors; $j ++)
+			{
+				if ($ancestors [$j] == $ref)
+				{
+					return $tagged [$i];
+				}
+			}
+		}
+		print "#### Warning : can't find any object matching with @params \n";
+	}
+	else
+	{
+		print "#### Warning : can't find any object matching with @params \n";
+	}
+	return undef;
+}
+
+sub executer {
+	my ($tb, @params) = @_;
+	if (ref ($tb) eq 'ARRAY')
+	{
+		my @fct = @{$tb};
+		my $methode = shift @fct;
+		if(ref ($methode) eq 'CODE')
+		{
+			&$methode (@fct, @params);
+		}
+		elsif (ref ($methode) eq '')
+		{
+			my $objet = shift @fct;
+			$objet -> $methode (@fct, @params);
+		}
+		else
+		{
+			my $objet = shift @fct;
+			$methode -> $objet (@fct, @params);
+		}
+	}
+	else
+	{
+		&$tb(@params);
+	}
+}
+
+sub getGradient {
+	
+	my $pack = shift (@_);
+	my $id = shift (@_);
+	my $type = shift (@_);
+	my $unit = shift (@_);
+
+	if (defined $gradients {"$pack#$id"})
+	{
+		return "$pack#$id";
+	}
+	if ($type eq 'axial')
+	{
+		my ($x1, $y1, $x2, $y2, $stops, $a00, $a01, $a10, $a11, $a20, $a21, $bb_x1, $bb_y1, $bb_x2, $bb_y2) = @_;
+
+		if ($unit ne 'userSpaceOnUse')
+		{
+			$x1 = $x1 * 100 - 50;
+			$x2 = $x2 * 100 - 50;
+			$y1 = $y1 * 100 - 50;
+			$y2 = $y2 * 100 - 50;
+		}
+
+	    $x1 = $a00 * $x1 + $a10 * $y1 + $a20;
+	    $y1 = $a01 * $x1 + $a11 * $y1 + $a21;
+    	$x2 = $a00 * $x2 + $a10 * $y2 + $a20;
+	    $y2 = $a01 * $x2 + $a11 * $y2 + $a21;
+	  
+		my ($zx1, $zx2, $zy1, $zy2);
+		if ($unit eq 'userSpaceOnUse')
+		{
+			my $cx = ($bb_x1 + $bb_x2) / 2;
+			my $cy = ($bb_y1 + $bb_y2) / 2;
+			my $w = ($bb_x2 - $bb_x1);
+			my $h = ($bb_y2 - $bb_y1);
+			
+			$zx1 = $w ? 100 * ($x1 - $cx) / $w : 0;
+			$zx2 = $w ? 100 * ($x2 - $cx) / $w : 0;
+			$zy1 = $h ? 100 * ($y1 - $cy) / $h : 0;
+			$zy2 = $h ? 100 * ($y2 - $cy) / $h : 0;
+			
+			$zx1 = $zx1 > 0 ? int ($zx1 + 0.5) : int ($zx1 - 0.5);
+			$zx2 = $zx2 > 0 ? int ($zx2 + 0.5) : int ($zx2 - 0.5);
+			$zy1 = $zy1 > 0 ? int ($zy1 + 0.5) : int ($zy1 - 0.5);
+			$zy2 = $zy2 > 0 ? int ($zy2 + 0.5) : int ($zy2 - 0.5);
+		}
+		else
+		{
+			$zx1 = $x1;
+			$zx2 = $x2;
+			$zy1 = $y1;
+			$zy2 = $y2;
+		}
+	    
+		my $path = "=axial $zx1 $zy1 $zx2 $zy2 | $stops";
+		$zinc -> gname ($path, "$pack#$id");
+		$gradients {"$pack#$id"} = 1;
+		return "$pack#$id";
+	}
+	
+	if ($type eq 'radial')
+	{
+		my ($x1, $y1, $stops, $bb_x1, $bb_y1, $bb_x2, $bb_y2) = @_;
+		if ($unit eq 'userSpaceOnUse')
+		{
+			$x1 = 0;
+			$y1 = 0;
+		}
+		my $path = "=radial $x1 $y1 | $stops";
+		$zinc -> gname ($path, "$pack#$id");
+		$gradients {"$pack#$id"} = 1;
+		return "$pack#$id";
+	}
+	
+	return $type;
+}
+
+use IPC::Open2;
+
+sub mplaying {
+	my ($file) = @_;
+	$file = Tk::findINC ($file);
+#	my $player = Tk::findINC ("essai.pl");
+#	my ($out,$in);
+#	open2 ($out, $in, "perl $player $file");
+	my $h1;
+	my $h2;
+	open2 ($h1, $h2, "play $file \&");
+}
+
+sub minstance {
+	my ($obj, $parent) = @_;
+	if ( ref ($obj) eq '')
+	{
+		if( $obj =~ /SVG\((.*)\)/)
+		{
+			my $tmp = MTools::SVG::SVGLoader::load ($1, $parent);
+			return $tmp -> {instance};
+		}
+		else
+		{
+			if( $obj =~ /(.*)\.svg\#(.*)/)
+			{
+				my $tmp = MTools::SVG::SVGLoader::load ($obj, $parent);
+				return $tmp -> {instance};
+			}
+			else
+			{
+				return $obj;
+			}
+		}
+	}
+	else
+	{
+		return $obj -> {instance};
+	}
+}
+
+sub mrun {
+	&Tk::MainLoop;
+}
+
+sub minstanciate {
+	my ($path, $parent) = @_;
+	if ( ref ($path) eq '')
+	{
+		if( $path =~ /SVG\((.*)\)/)
+		{
+			return MTools::SVG::SVGLoader::load ($1, $parent);
+		}
+		else
+		{
+			if( $path =~ /(.*)\.svg\#(.*)/)
+			{
+				return MTools::SVG::SVGLoader::load ($path, $parent);
+			}
+			elsif( $path =~ /(.*)\.svg/)
+			{
+				return MTools::SVG::SVGLoader::load ($path, $parent);
+			}
+			else
+			{
+				my $obj = new MTools::MObjet ();
+				$obj -> {instance} = $path;
+				$obj -> chggroup ($parent);
+				return $obj;
+			}
+		}
+	}
+	else
+	{
+		$path -> chggroup ($parent);
+		return $path;
+	}
+}
+
+1;
diff --git a/src/MTools/Adapters/WacomAdapter.pm b/src/MTools/Adapters/WacomAdapter.pm
new file mode 100644
index 0000000..5d6c77a
--- /dev/null
+++ b/src/MTools/Adapters/WacomAdapter.pm
@@ -0,0 +1,159 @@
+package MTools::Adapters::WacomAdapter;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+use strict;
+use MTools;
+use MTools::MObjet;
+use MTools::MIvy;
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, $adresse, $ivy_name, $wacom_adresse) = @_;
+	my $self = new MTools::MObjet ();
+	if (!defined $wacom_adresse)
+	{
+		$wacom_adresse = 'default';
+	}
+	bless $self, $class;
+	$self -> {__pointer_status} = 0;
+	$self -> {__ivy} = new MTools::MIvy ($adresse, $ivy_name);
+	$self -> {__ivy} -> binding ('pad_event wacom_id='.$wacom_adresse.' button=(.*) status=(.*) time=(.*)', [\&wacom_event, $self, 'buttons']);	
+	$self -> {__ivy} -> binding ('slider_event wacom_id='.$wacom_adresse.' value=(.*) side=(.*) time=(.*)', [\&wacom_event, $self, 'sliders']);
+	$self -> {__ivy} -> binding ('pointer_event wacom_id='.$wacom_adresse.' x=(.*) y=(.*) presure=(.*) tilt_x=(.*) tilt_y=(.*) wheel=(.*) predicted_x=(.*) predicted_y=(.*) type=(.*) serial_number=(.*) time=(.*)', [\&wacom_event, $self, 'pointers']);
+	return $self;
+	
+}
+
+sub binding {
+	my ($self, $reg, $cb) = @_;
+	if ($reg eq '<WSlider>')
+	{
+		push (@{$self -> {sliders} -> {all}}, $cb);
+	}
+	elsif ($reg =~ /\<WSlider(.*)-(.*)\>/)
+	{
+		push (@{$self -> {sliders} -> {$1} -> {$2}}, $cb);
+	}
+	elsif ($reg =~ /\<WSlider(.*)\>/)
+	{
+		push (@{$self -> {sliders} -> {$1} -> {all}}, $cb);
+	}
+	elsif ($reg eq '<WButton>')
+	{
+		push (@{$self -> {buttons} -> {all}}, $cb);
+	}
+	elsif ($reg =~ /\<WButton(.*)-(.*)\>/)
+	{
+		push (@{$self -> {buttons} -> {$1} -> {$2}}, $cb);
+	}
+	elsif ($reg =~ /\<WButton(.*)\>/)
+	{
+		push (@{$self -> {buttons} -> {$1} -> {all}}, $cb);
+	}
+	elsif ($reg eq '<WPointer>')
+	{
+		push (@{$self -> {pointers} -> {all}}, $cb);
+	}
+	elsif ($reg =~ /\<WPointer(.*)-(.*)\>/)
+	{
+		push (@{$self -> {pointers} -> {$1} -> {$2}}, $cb);
+	}
+	elsif ($reg =~ /\<WPointer(.*)\>/)
+	{
+		push (@{$self -> {pointers} -> {$1} -> {all}}, $cb);
+	}
+	else
+	{
+		die "Can't recognize a wacom event in $reg\n";
+	}
+}
+
+sub wacom_event {
+	my ($agent, $self, $type, $value, $status, $time, @others) = @_;
+	my @callbacks = ();
+	my @args = ();
+	if ($type eq 'sliders')
+	{
+		my $nb = 0;
+		if ($value != 0)
+		{
+			while ($value != 1)
+			{
+				$value = $value / 2;
+				$nb ++;
+			}			
+			$nb++;	
+		}
+		$value = $nb;
+	}
+	if ($type eq 'pointers')
+	{
+		$status = $others [5];
+		if ($status =~ /(.*)_(.*)_(.*)_(.*)/)
+		{
+			$status = $3;
+		}
+		elsif ($status =~ /(.*)_(.*)_(.*)/)
+		{
+			$status = $2;
+		}
+		if ($time == 0)
+		{
+			$value = 'Release';
+			$self -> {__pointer_status} = 0;
+		}
+		else
+		{
+			if ($self -> {__pointer_status})
+			{
+				$value = 'Motion';
+			}
+			else
+			{
+				$value = 'Press';
+				$self -> {__pointer_status} = 1;
+			}
+		}
+	}
+	if (defined $self -> {$type} -> {all})
+	{
+		push (@callbacks, @{$self -> {$type} -> {all}});
+	}
+	if (defined $self -> {$type} -> {$status} -> {all})
+	{
+		push (@callbacks, @{$self -> {$type} -> {$status} -> {all}});
+	}
+	if (defined $self -> {$type} -> {$status} -> {$value})
+	{
+		push (@callbacks, @{$self -> {$type} -> {$status} -> {$value}});
+	}
+	for (my $i = 0; $i < @callbacks; $i ++)
+	{
+		executer ($callbacks[$i], $value, $status, $type);
+	}	
+}
+
+
+1;
diff --git a/src/MTools/Anim/MOpacity.pm b/src/MTools/Anim/MOpacity.pm
new file mode 100644
index 0000000..e1882ba
--- /dev/null
+++ b/src/MTools/Anim/MOpacity.pm
@@ -0,0 +1,143 @@
+package MTools::Anim::MOpacity;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# MOpacity permet de realiser une animation sur la transparence d'un objet
+# 
+# proprietes :
+#	* -visible : permet d'activer ou non l'animation
+#	* from_opacity : valeur initiale de l'opacite au depart de l'animation
+#	* to_opacity : valeur de l'opacite a la fin de l'animation
+# 	* duration : duree de l'animation
+#	* loop : marque le caractere repetitif ou non de l'animation
+#	* targets : objets cible de cette animation
+# Evenements :
+#	* ANIMATION_END : Notifie lorque l'annimation se termine
+#	* OPACITY_CHANGED : Notifie lorsque la valeur de l'opacite est changee au cours de l'animation
+#	* ANIMATION_ABORD : Notifie lorsque l'animation est stoppee avant la fin
+# Fonctions : 
+#	* start : demarre l'animation
+#	* stop: arrete l'animation
+#	* isRunning : test si l'animation est en cours
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use Anim;
+use Anim::Pacing::Linear;
+use Anim::Path::Rectilinear;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, %options) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+
+	$self -> recordProperty ('-visible', 0);
+	$self -> recordProperty ('from_opacity', 0);
+	$self -> recordProperty ('to_opacity', 0);
+	$self -> recordProperty ('duration', 1);
+	$self -> recordProperty ('loop', 0);
+	$self -> recordProperty ('targets', undef);
+	$self -> recordEvent ('ANIMATION_END');
+	$self -> recordEvent ('OPACITY_CHANGED');
+	$self -> recordEvent ('ANIMATION_ABORD');
+	$self -> plisten ('-visible', sub { 
+		my ($src, $key, $val) = @_;
+		if ($val == 0)
+		{
+			$self -> stop ();
+		}
+		else
+		{
+			$self -> start ();
+		}
+	});
+	$self -> {__animation} = undef;
+	$self -> mconfigure (%options);
+	return $self;
+}
+
+sub start {
+	my ($self) = @_;
+	my $pacing = new Anim::Pacing::Linear (-duration => $self -> mget ('duration'));
+	$self -> {__opacitydep} = my $opacitydep = $self -> mget ('from_opacity');
+
+	my $animationpath = new Anim::Path::Rectilinear (
+		-xdep => 0,
+		-ydep => 0,
+		-xdest => $self -> mget ('to_opacity') - $opacitydep,
+		-ydest => 0,
+	);
+	$self -> {__opacity} = $opacitydep;
+	$self -> {__animation} = my $animation = new Anim (
+		-pacing => $pacing,
+		-resources => [
+			$animationpath,
+			-command => sub { $self -> __event (@_)},
+			-endcommand => sub {$self -> notify ('ANIMATION_END');$self -> {__animation} = undef;},
+		],
+		-stopcommand => sub {$self -> notify ('ANIMATION_ABORD', $self -> {__opacity});$self -> {__animation} = undef;},
+		-loop => $self -> mget ('loop'),
+	);
+	$animation -> start ();
+}
+
+sub stop {
+	my ($self) = @_;
+	if (defined $self -> {__animation})
+	{
+		$self -> {__animation} -> stop ();
+	}
+}
+
+sub __event {
+	my ($self, $opacity) = @_;
+	$opacity += $self -> {__opacitydep};
+	my @targets = ();
+	my $target = $self -> mget ('targets');
+	if (ref ($target) eq 'ARRAY')
+	{
+		@targets = @{$target};
+	}
+	else
+	{
+		push (@targets, $target);
+	}
+	for (my $i = 0; $i < @targets; $i++)
+	{
+		$targets [$i] -> mconfigure ('-alpha' => $opacity);
+	}
+	$self -> {__opacity} = $opacity;
+	$self -> notify ('OPACITY_CHANGED', $opacity);
+}
+
+sub isRunning {
+	my ($self) = @_;
+	return defined $self -> {__animation};
+}
+
+1;
diff --git a/src/MTools/Anim/MPath.pm b/src/MTools/Anim/MPath.pm
new file mode 100644
index 0000000..6fcbb2f
--- /dev/null
+++ b/src/MTools/Anim/MPath.pm
@@ -0,0 +1,193 @@
+package MTools::Anim::MPath;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# MPath permet de realiser une animation de deplacement suivant un chemin
+# 
+# proprietes :
+#	* -visible : permet d'activer ou non l'animation
+#	* path : chemin
+# 	* duration : duree de l'animation
+#	* loop : marque le caractere repetitif ou non de l'animation
+#	* targets : objets cible de cette animation
+# Evenements :
+#	* ANIMATION_END : Notifie lorque l'annimation se termine
+#	* VALUE_CHANGED : Notifie lorsque la valeur de l'opacite est changee au cours de l'animation
+#	* ANIMATION_ABORD : Notifie lorsque l'animation est stoppee avant la fin
+# Fonctions : 
+#	* start : demarre l'animation
+#	* stop: arrete l'animation
+#	* isRunning : test si l'animation est en cours
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use Anim;
+use Anim::Pacing::Linear;
+use Anim::Path::Rectilinear;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, %options) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+
+	$self -> recordProperty ('-visible', 0);
+	$self -> recordProperty ('path', []);
+	$self -> recordProperty ('duration', 1);
+	$self -> recordProperty ('loop', 0);
+	$self -> recordProperty ('targets', undef);
+	$self -> recordEvent ('ANIMATION_END');
+	$self -> recordEvent ('VALUE_CHANGED');
+	$self -> recordEvent ('ANIMATION_ABORD');
+	$self -> plisten ('path', [$self, 'pathchanged']);
+	$self -> plisten ('-visible', sub { 
+		my ($src, $key, $val) = @_;
+		if ($val == 0)
+		{
+			$self -> stop ();
+		}
+		else
+		{
+			$self -> start ();
+		}
+	});
+	$self -> {__animation} = undef;
+	$self -> {__length} = 0;
+	$self -> {__x} = 0;
+	$self -> {__y} = 0;
+	$self -> {__vx} = 0;
+	$self -> {__vy} = 0;
+	$self -> mconfigure (%options);
+	return $self;
+}
+
+sub pathchanged {
+	my ($self, $src, $key, $value) = @_;
+	my @points = @{$value};
+	my $length = 0;
+	for (my $i = 0; $i < @points - 1; $i ++)
+	{
+		my $x = $points [$i + 1] -> [0] - $points [$i] -> [0];
+		my $y = $points [$i + 1] -> [1] - $points [$i] -> [1];
+		$length +=  sqrt ($x * $x + $y * $y);
+	}
+	$self -> {__length} = $length;
+}
+
+sub start {
+	my ($self) = @_;
+	
+	my @points = @{$self -> mget ('path')};
+	if (!defined @points || @points <= 0) {return;}
+	$self -> {__x} = $points [0] -> [0];
+	$self -> {__y} = $points [0] -> [1];
+	my $pacing = new Anim::Pacing::Linear (-duration => $self -> mget ('duration'));
+	$self -> {__percentage} = 0;
+	my $animationpath = new Anim::Path::Rectilinear (
+		-xdep => 0,
+		-ydep => 0,
+		-xdest => 100,
+		-ydest => 0,
+	);
+	$self -> {__animation} = my $animation = new Anim (
+		-pacing => $pacing,
+		-resources => [
+			$animationpath,
+			-command => sub { $self -> __event (@_)},
+			-endcommand => sub {$self -> notify ('ANIMATION_END'); $self -> {__animation} = undef;},
+		],
+		-stopcommand => sub {
+			$self -> notify ('ANIMATION_ABORD', $self -> __getPoint ($self -> {__percentage}));
+			$self -> {__animation} = undef;
+		},
+		-loop => $self -> mget ('loop'),
+	);
+	$animation -> start ();
+}
+
+sub stop {
+	my ($self) = @_;
+	if (defined $self -> {__animation})
+	{
+		$self -> {__animation} -> stop ();
+	}
+}
+
+sub __getPoint {
+	my ($self, $percentage) = @_;
+	my @points = @{$self -> mget ('path')};
+	my $length = $self -> {__length} * $percentage / 100;
+	my $x = 0;
+	my $y = 0;
+	my $vx = 0;
+	my $vy = 0;
+	for (my $i = 0; $i < @points - 1; $i ++)
+	{
+		$vx = $x = $points [$i + 1] -> [0] - $points [$i] -> [0];
+		$vy = $y = $points [$i + 1] -> [1] - $points [$i] -> [1];
+		my $d = sqrt ($x * $x + $y * $y);
+		$length -= $d;
+		if ($length <= 0)
+		{
+			$d = ($d + $length) / $d;
+			$x = $d * $x + $points [$i] -> [0];
+			$y = $d * $y + $points [$i] -> [1];
+			$i = @points;
+		}
+	}
+	return ($x, $y, $vx, $vy);
+}
+
+sub __event {
+	my ($self, $percentage) = @_;
+	my ($x, $y, $vx, $vy) = $self -> __getPoint ($percentage);
+	my @targets = ();
+	my $target = $self -> mget ('targets');
+	if (ref ($target) eq 'ARRAY')
+	{
+		@targets = @{$target};
+	}
+	else
+	{
+		push (@targets, $target);
+	}
+	for (my $i = 0; $i < @targets; $i++)
+	{
+		$targets [$i] -> translate ($x - $self -> {__x}, $y - $self -> {__y});
+	}
+	$self -> {__x} = $x;
+	$self -> {__y} = $y;
+	$self -> {__percentage} = $percentage;
+	$self -> notify ('VALUE_CHANGED', $x, $y, $vx, $vy);
+}
+
+sub isRunning {
+	my ($self) = @_;
+	return defined $self -> {__animation};
+}
+
+1;
diff --git a/src/MTools/Anim/MScalor.pm b/src/MTools/Anim/MScalor.pm
new file mode 100644
index 0000000..cbdc49d
--- /dev/null
+++ b/src/MTools/Anim/MScalor.pm
@@ -0,0 +1,154 @@
+package MTools::Anim::MScalor;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# MScalor permet de realiser une animation de scale sur l'objet
+# 
+# proprietes :
+#	* -visible : permet d'activer ou non l'animation
+#	* center_x, center_y : coordonnees du centre de la transformation
+#	* from_x, from_y : valeur initiale de la transformation
+#	* to_x, to_y : valeur finale de la transformation
+# 	* duration : duree de l'animation
+#	* loop : marque le caractere repetitif ou non de l'animation
+#	* targets : objets cible de cette animation
+# Evenements :
+#	* ANIMATION_END : Notifie lorque l'annimation se termine
+#	* SCALED : Notifie lorsque la valeur de l'opacite est changee au cours de l'animation
+#	* ANIMATION_ABORD : Notifie lorsque l'animation est stoppee avant la fin
+# Fonctions : 
+#	* start : demarre l'animation
+#	* stop: arrete l'animation
+#	* isRunning : test si l'animation est en cours
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use Anim;
+use Anim::Pacing::Linear;
+use Anim::Path::Rectilinear;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, %options) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+
+	$self -> recordProperty ('-visible', 0);
+	$self -> recordProperty ('center_x', 0);
+	$self -> recordProperty ('center_y', 0);
+	$self -> recordProperty ('from_x', 0);
+	$self -> recordProperty ('from_y', 0);
+	$self -> recordProperty ('to_x', 0);
+	$self -> recordProperty ('to_y', 0);
+	$self -> recordProperty ('duration', 1);
+	$self -> recordProperty ('loop', 0);
+	$self -> recordProperty ('targets', undef);
+	$self -> recordEvent ('ANIMATION_END');
+	$self -> recordEvent ('SCALED');
+	$self -> recordEvent ('ANIMATION_ABORD');
+	$self -> plisten ('-visible', sub { 
+		my ($src, $key, $val) = @_;
+		if ($val == 0)
+		{
+			$self -> stop ();
+		}
+		else
+		{
+			$self -> start ();
+		}
+	});
+	$self -> {__animation} = undef;
+	$self -> mconfigure (%options);
+	return $self;
+}
+
+sub start {
+	my ($self) = @_;
+	my $pacing = new Anim::Pacing::Linear (-duration => $self -> mget ('duration'));
+	$self -> {__xdep} = my $xdep = $self -> mget ('from_x');
+	$self -> {__ydep} = my $ydep = $self -> mget ('from_y');
+
+	my $animationpath = new Anim::Path::Rectilinear (
+		-xdep => 0,
+		-ydep => 0,
+		-xdest => $self -> mget ('to_x') - $xdep,
+		-ydest => $self -> mget ('to_y') - $ydep,
+	);
+	$self -> {__x} = $xdep;
+	$self -> {__y} = $ydep;
+	$self -> {__animation} = my $animation = new Anim (
+		-pacing => $pacing,
+		-resources => [
+			$animationpath,
+			-command => sub { $self -> __event (@_)},
+			-endcommand => sub {$self -> notify ('ANIMATION_END');$self -> {__animation} = undef;},
+		],
+		-stopcommand => sub {$self -> notify ('ANIMATION_ABORD', $self -> {__x}, $self -> {__y});$self -> {__animation} = undef;},
+		-loop => $self -> mget ('loop'),
+	);
+	$animation -> start ();
+}
+
+sub stop {
+	my ($self) = @_;
+	if (defined $self -> {__animation})
+	{
+		$self -> {__animation} -> stop ();
+	}
+}
+
+sub __event {
+	my ($self, $x, $y) = @_;
+	my $cx = $self -> mget ('center_x');
+	my $cy = $self -> mget ('center_y');
+	$x += $self -> {__xdep};
+	$y += $self -> {__ydep};
+	my @targets = ();
+	my $target = $self -> mget ('targets');
+	if (ref ($target) eq 'ARRAY')
+	{
+		@targets = @{$target};
+	}
+	else
+	{
+		push (@targets, $target);
+	}
+	for (my $i = 0; $i < @targets; $i++)
+	{
+		scale ($targets [$i], $x / $self -> {__x}, $y / $self -> {__y}, $cx, $cy);
+	}
+	$self -> {__x} = $x;
+	$self -> {__y} = $y;
+	$self -> notify ('SCALED', $x, $y, $cx, $cy);
+}
+
+sub isRunning {
+	my ($self) = @_;
+	return defined $self -> {__animation};
+}
+
+1;
diff --git a/src/MTools/Anim/MTranslator.pm b/src/MTools/Anim/MTranslator.pm
new file mode 100644
index 0000000..3ac0544
--- /dev/null
+++ b/src/MTools/Anim/MTranslator.pm
@@ -0,0 +1,166 @@
+package MTools::Anim::MTranslator;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# MTranslator permet de realiser une animation de translation sur l'objet
+# 
+# proprietes :
+#	* -visible : permet d'activer ou non l'animation
+#	* from_x, from_y : valeur initiale de la transformation
+#	* to_x, to_y : valeur finale de la transformation
+# 	* duration : duree de l'animation
+#	* loop : marque le caractere repetitif ou non de l'animation
+#	* targets : objets cible de cette animation
+# Evenements :
+#	* ANIMATION_END : Notifie lorque l'annimation se termine
+#	* MOTION : Notifie lorsque la valeur de l'opacite est changee au cours de l'animation
+#	* ANIMATION_ABORD : Notifie lorsque l'animation est stoppee avant la fin
+# Fonctions : 
+#	* start : demarre l'animation
+#	* stop: arrete l'animation
+#	* isRunning : test si l'animation est en cours
+
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use Anim;
+use Anim::Pacing::Linear;
+use Anim::Path::Rectilinear;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, %options) = @_;
+	my $self = {};
+	bless $self, $class;
+
+	$self -> recordProperty ('-visible', 0);
+	$self -> recordProperty ('from_x', $options {from_x} ? $options {from_x} : 0);
+	$self -> recordProperty ('from_y', $options {from_y} ? $options {from_y} : 0);
+	$self -> recordProperty ('to_x', $options {to_x} ? $options {to_x} : 0);
+	$self -> recordProperty ('to_y', $options {to_y} ? $options {to_y} : 0);
+	$self -> recordProperty ('duration', $options {duration} ? $options {duration} : 1);
+	$self -> recordProperty ('loop', $options {loop} ? $options {loop} : 0);
+	$self -> recordProperty ('targets', $options {targets});
+
+	$self -> recordEvent ('ANIMATION_END');
+	$self -> recordEvent ('MOTION');
+	$self -> recordEvent ('ANIMATION_ABORDED');
+
+	$self -> plisten ('-visible', sub { 
+		my ($src, $key, $val) = @_;
+		if ($val == 0)
+		{
+			$self -> stop ();
+		}
+		else
+		{
+			$self -> start ();
+		}
+	});
+	$self -> {__animation} = undef;
+	$self -> mconfigure (%options);
+	return $self;
+}
+
+sub stop {
+	my ($self) = @_;
+	if (defined $self -> {__animation})
+	{
+		$self -> {__animation} -> stop ();
+	}
+}
+
+sub start {
+	my ($self) = @_;
+	my $pacing = new Anim::Pacing::Linear (-duration => $self -> mget ('duration'));
+	$self -> {__xdep} = my $xdep = $self -> mget ('from_x');
+	$self -> {__ydep} = my $ydep = $self -> mget ('from_y');
+
+	my $animationpath = new Anim::Path::Rectilinear (
+		-xdep => 0,
+		-ydep => 0,
+		-xdest => $self -> mget ('to_x') - $xdep,
+		-ydest => $self -> mget ('to_y') - $ydep,
+	);
+	$self -> {__x} = $xdep;
+	$self -> {__y} = $ydep;
+	$self -> {__animation} = my $animation = new Anim (
+		-pacing => $pacing,
+		-resources => [
+			$animationpath,
+			-command => sub { $self -> event (@_)},
+			-endcommand => sub {
+				$self -> {__animation} = undef;
+				$self -> notify ('ANIMATION_END');
+			},
+		],
+		-stopcommand => sub {
+			$self -> {__animation} = undef;
+			$self -> notify ('ANIMATION_ABORDED', $self -> {__x}, $self -> {__y});
+		},
+		-loop => $self -> mget ('loop'),
+	);
+	$animation -> start ();
+}
+
+sub isRunning {
+	my ($self) = @_;
+	return defined $self -> {__animation};
+}
+
+
+sub event {
+	my ($self, $x, $y) = @_;
+	$x += $self -> {__xdep};
+	$y += $self -> {__ydep};
+	my @targets = ();
+	my $target = $self -> mget ('targets');
+	if (ref ($target) eq 'ARRAY')
+	{
+		@targets = @{$target};
+	}
+	else
+	{
+		push (@targets, $target);
+	}
+	for (my $i = 0; $i < @targets; $i++)
+	{
+		if (ref ($targets [$i]) eq 'MTools::Comp::MMover')
+		{
+			$target -> setPos ($x, $y);
+			$target -> notify ('MOVED', $x, $y, "mvd");
+		}
+		else
+		{
+			$targets [$i] -> translate ($x - $self -> {__x}, $y - $self -> {__y});
+		}
+	}
+	$self -> {__x} = $x;
+	$self -> {__y} = $y;
+	$self -> notify ('MOTION', $x, $y);
+}
+1;
diff --git a/src/MTools/Comp/MAntiRecouvrement.pm b/src/MTools/Comp/MAntiRecouvrement.pm
new file mode 100644
index 0000000..1e10edd
--- /dev/null
+++ b/src/MTools/Comp/MAntiRecouvrement.pm
@@ -0,0 +1,240 @@
+package MTools::Comp::MAntiRecouvrement;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Encapsule l'algorithme d'anti-recouvrement des objets et gere les objets anti-recouvres
+# IMPORTANT : Les objets anti-recouvre doivent heriter de MTools::GUI::MAntiRecouvrementGroup
+#
+# BUG : La propriete '-visible' devrait permettre d'activer ou non l'anti-recouvrement global des objets.
+# Ce n'est pas le cas aujourd'hui, cette popriete est inactive
+#
+# Fonctions :
+#	* addObject : permet d'inclure un objet heritant de MTools::GUI::MAntiRecouvrementGroup dans l'algorithme d'anti-recouvrement
+#	* removeObjet : permet de sortir un objet de l'algorithme d'anti-recouvrement
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+
+	$self -> recordProperty	('-visible', 1);
+	$self -> recordEvent ('ITEM_MOVED');
+	$self -> {__objects} = ();
+	$self -> {__known_objects} = ();
+	$self -> {__ask_move} = ();
+	$self -> {__ask_reaction} = ();
+	
+	return $self;
+}
+
+sub addObject {
+	my ($self, $ob) = @_;
+	my $ever_known = 0;
+	if (defined $self -> {__known_objects})
+	{
+		my @known = @{$self -> {__known_objects}};
+		for (my $i = 0; $i < @known; $i ++)
+		{
+			if ($known [$i] eq $ob)
+			{
+				$ever_known = 1;
+				last;
+			}
+		}
+	}
+	if (!$ever_known)
+	{
+		binding ($ob, '__HANDLE_MOVING', [$self, \&__on_handle_moving_on_track]);
+		binding ($ob, '__PUSH_BACK', [$self, \&__on_push_back_on_track]);
+		binding ($ob, '__ENQUEUE_MOVING', [$self, \&__on_enqueue_moving_on_track]);
+		push (@{$self -> {__known_objects}}, $ob);
+	}
+	if (!defined $ob -> {__added} || $ob -> {__added} == 0)
+	{
+		push (@{$self -> {__objects}}, $ob);
+	}
+	$ob -> update_bbox ();
+	$ob -> {__added} = 1;
+	$ob -> translate (0, 0);
+}
+
+sub removeObject {
+	my ($self, $target) = @_;
+	for (my $i = @{$self -> {__objects}} - 1; $i >=  0; $i --) 
+	{
+		if (@{$self -> {__objects}} [$i] eq $target) 
+		{
+			@{$self -> {__objects}} [$i] -> {__added} = 0;
+			splice (@{$self -> {__objects}}, $i, 1);
+		}
+	}
+}
+
+sub __on_handle_moving_on_track {
+	my ($self) = @_;
+	my ($first_work, $first_track, $current_track, $intersection);
+	while (scalar @{$self -> {__ask_move}} > 0) 
+	{
+    	$first_work = $self -> {__ask_move} -> [0];
+		$first_track = $first_work -> [0];
+		my ($firstx, $firsty) = ($first_track -> mget ('x'), $first_track -> mget ('y'));
+		for (my $i = 0; $i < @{$self -> {__objects}}; $i++) 
+		{
+			$current_track = @{$self -> {__objects}} [$i];
+			next if ($current_track eq $first_track);
+			my ($x, $y) = ($current_track -> mget ('x'), $current_track -> mget ('y'));
+			$intersection = __intersection (
+				$firstx, $firsty,
+                $first_track -> mget ('width'), $first_track -> mget ('height'),
+				$x, $y,
+				$current_track -> mget ('width'), $current_track-> mget ('height')
+			);
+			next if (($intersection -> [2] == 0) and ($intersection -> [3] == 0));
+			if ($intersection -> [2] < $intersection -> [3]) 
+			{
+				if ($firstx < $x) 
+				{
+					$current_track	->	__try_move ($intersection -> [2], 0, $first_work -> [3]);
+				}
+				else 
+				{
+					$current_track -> __try_move(-$intersection -> [2], 0, $first_work -> [3]);
+				}
+			}
+			else 
+			{
+				if ($firsty < $y) 
+				{
+					$current_track -> __try_move (0, $intersection -> [3], $first_work -> [3]);
+				}
+				else 
+				{
+					$current_track -> __try_move (0, -$intersection -> [3], $first_work -> [3]);
+				}
+			}
+		}
+		shift @{$self -> {__ask_move}};
+	}
+	$self -> notify ('ITEM_MOVED');
+}
+
+sub __on_push_back_on_track {
+	my ($self, $track, $delta_x, $delta_y, $path) = @_;
+	push @{$path}, $track;
+	my @other_path = @{$path};
+	$self -> __on_enqueue_moving_on_track ($track, $delta_x, $delta_y, [@other_path]);
+	$track -> __update_xy ($delta_x, $delta_y);
+	my ($current_track, $push_x, $push_y, $intersection);
+	my ($firstx, $firsty) = ($track -> mget ('x'), $track -> mget ('y'));
+	
+	for (my $i = 0; $i < @{$self -> {__objects}}; $i++) 
+	{
+		$current_track = @{$self -> {__objects}} [$i];
+		next if $current_track eq $track;
+		my ($x, $y) = ($current_track -> mget ('x'), $current_track -> mget ('y'));
+		$intersection = __intersection (
+			$firstx, $firsty,
+			$track -> mget ('width'), $track -> mget ('height'),
+			$x, $y,
+			$current_track -> mget ('width'), $current_track -> mget ('height')
+		);
+		$push_x = 0;
+		$push_y = 0;
+		$push_x = $intersection -> [2] if ($intersection -> [2] <= $delta_x);
+		$push_x = -$intersection -> [2] if ($intersection -> [2] <= -$delta_x);
+		$push_y = $intersection -> [3] if ($intersection -> [3] <= $delta_y);
+		$push_y = -$intersection -> [3] if ($intersection -> [3] <= -$delta_y);
+		$self -> __on_push_back_on_track ($current_track, $push_x, $push_y, $path)
+		if ((($push_x != 0) or ($push_y != 0)) and (__occurences ($current_track, @{$path}) < 3));
+	}
+	pop @{$path};
+}
+
+sub __intersection {
+	my ($x1, $y1, $w1, $h1, $x2, $y2, $w2, $h2) = @_;
+	my ($x, $y, $w, $h);
+	$x = &__max_of ($x1, $x2);
+	$w = &__min_of ($x1 + $w1, $x2 + $w2) - $x;
+	if ($w > 0) 
+	{
+		$y = &__max_of ($y1, $y2);
+		$h = &__min_of ($y1 + $h1, $y2 + $h2) - $y;
+		if ($h > 0) 
+		{
+			return [$x, $y, $w, $h];
+		}
+	}
+	return [0, 0, 0, 0];
+}
+
+sub __min_of {
+	my (@values) = @_;
+	my $res = $values [0];
+	foreach (@values) 
+	{
+    	$res = $_ if ($_ <= $res);
+	}
+	return $res;
+}
+
+sub __max_of {
+	my (@values) = @_;
+	my $res = $values [0];
+	foreach (@values) 
+	{
+		$res = $_ if ($_ >= $res);
+	}
+	return $res;
+}
+
+sub __occurences {
+	my ($val,@tab) = @_;
+	my $result = 0;
+	if (($#tab != -1) and (defined $val)) 
+	{
+		foreach (@tab) 
+		{
+			if (($_ eq $val) or ($_ =~ m/$val/)) 
+			{
+				$result++;
+			}
+		}
+	}
+	return $result;
+}
+
+sub __on_enqueue_moving_on_track {
+	my ($self, $track, $delta_x, $delta_y, $path) = @_;
+	push @{$self -> {__ask_move}}, [$track, $delta_x, $delta_y, $path];
+}
+
+
+
+1;
diff --git a/src/MTools/Comp/MFlicker.pm b/src/MTools/Comp/MFlicker.pm
new file mode 100644
index 0000000..fd622c8
--- /dev/null
+++ b/src/MTools/Comp/MFlicker.pm
@@ -0,0 +1,79 @@
+package MTools::Comp::MFlicker;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Le composant permet d'ajouter un comportement de clignotement ? un objet cible
+#
+# Parametres : 
+#
+#	* target : objet cible du tremblement
+#	* periode : periode du clignottement
+# Propriete :
+#	* flick : demarre le clignottement
+#	* show : rend l'objet cible toujours visible
+#	* hide : rend l'objet cible toujours masque
+
+use strict;
+use MTools;
+use MTools::MObjet;
+use MTools::MTimer;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MSwitch/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, $target, $periode) = @_;
+	my $self = new MTools::MObjet ();
+	$self -> {__target} = $target;
+	$self -> {__target} -> mconfigure (-visible => 0);
+	bless $self, $class;
+	
+	$self -> recordProperty ('periode', $periode);
+	
+	$self -> {__timer} = new MTools::MTimer ($periode, 1, sub {
+		$self -> {__target} -> mconfigure (-visible => !$self -> {__target} -> mget (-visible));
+	});
+	
+	plink ([$self, 'periode'], [$self -> {__timer}, 'timeout']);
+
+	return $self;
+}
+
+sub flick {
+	my ($self) = @_;
+	$self -> {__timer} -> start ();
+}
+
+sub show {
+	my ($self) = @_;
+	$self -> {__timer} -> stop ();
+	$self -> {__target} -> mconfigure (-visible => 1);
+}
+
+sub hide {
+	my ($self) = @_;
+	$self -> {__timer} -> stop ();
+	$self -> mconfigure ('state' => 'unvisible');
+}
+
+1;
diff --git a/src/MTools/Comp/MFocuser.pm b/src/MTools/Comp/MFocuser.pm
new file mode 100644
index 0000000..cb821ae
--- /dev/null
+++ b/src/MTools/Comp/MFocuser.pm
@@ -0,0 +1,89 @@
+package MTools::Comp::MFocuser;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# L'objet MFocuser permet de gerer le focus entre plusieurs objets
+#
+# Parametres : 
+#	* @targets : objets entre lesquels est gere le focus
+# Fonctions : 
+#	* add : permet de prendre en compte un nouvel objet 
+#	* setFocused : force le focus sur un objet
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, @targets) = @_;
+	my $self = {};
+	bless $self, $class;
+	
+	$self -> recordEvent ('GET_FOCUS');
+	$self -> recordEvent ('SET_FOCUS');
+	
+	$self -> {__targets} = \@targets;
+	for (my $i; $i < @targets; $i++)
+	{
+		$targets [$i] -> binding ('GET_FOCUS', ['setFocused', $self]);
+	}
+	
+	$self -> binding ('SET_FOCUS', ['setFocused', $self]);
+	
+	return $self;
+}
+
+sub add {
+	my ($self, $tg) = @_;
+	push (@{$self -> {__targets}}, $tg);
+	$tg -> binding ('GET_FOCUS', ['setFocused', $self]);
+}
+
+sub setFocused {
+	my ($self, $tg) = @_;
+	if (!defined $self -> {__targets}) {return;}
+	my @tgs = @{$self -> {__targets}};
+	my $from_children = 0;
+	for (my $i; $i < @tgs; $i++)
+	{
+		if ($tgs [$i] ne $tg)
+		{
+			$tgs [$i] -> notify ('SET_FOCUS');
+		}
+		else
+		{
+			$from_children = 1;
+		}
+	}
+	if ($from_children)
+	{
+		$self -> notify ('GET_FOCUS', $self);
+	}
+}
+
+1;
+
+
diff --git a/src/MTools/Comp/MInertie.pm b/src/MTools/Comp/MInertie.pm
new file mode 100644
index 0000000..9b820a0
--- /dev/null
+++ b/src/MTools/Comp/MInertie.pm
@@ -0,0 +1,153 @@
+package MTools::Comp::MInertie;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+use strict;
+use MTools;
+use MTools::MObjet;
+use Time::HiRes;
+
+use MTools::MTimer;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, $target, %options) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+
+	my $msg_pressed = defined $options {msg_pressed} ? $options {msg_pressed} : 'PRESSED';
+	my $msg_moved = defined $options {msg_moved} ? $options {msg_moved} : 'MOVED';
+	my $msg_released = defined $options {msg_released} ? $options {msg_released} : 'RELEASED';
+	my $msg_stopped = defined $options {msg_stopped} ? $options {msg_stopped} : 'INERTIE_STOPPED';
+	
+	delete $options {msg_pressed};
+	delete $options {msg_moved};
+	delete $options {msg_released};
+	delete $options {msg_stopped};
+
+	$self -> recordProperty	('target', $target);
+	$self -> recordProperty	('-visible', 1);
+	$self -> recordProperty	('rate', 0.85);
+	$self -> recordProperty	('inertie_callback', 'translate');
+
+	$self -> recordEvent ($msg_stopped);
+	$self -> mconfigure (%options);
+
+	$self -> {__old_t} = 0;
+	$self -> {__old_x} = 0;
+	$self -> {__old_y} = 0;
+	$self -> {__x} = 0;
+	$self -> {__y} = 0;
+	$self -> {__t} = 0;
+	$self -> {__vx} = 0;
+	$self -> {__vy} = 0;
+	
+	$self -> {__msg_stopped} = $msg_stopped;
+	
+	$target -> binding ($msg_pressed, [$self, 'target_pressed']);
+	$target -> binding ($msg_moved, [$self, 'target_moved']);
+	$target -> binding ($msg_released, [$self, 'target_released']);
+	
+	$self -> {timer_inertie} = new MTools::MTimer (1000/60, 1, [$self, 'inertie']);
+	
+	return $self;
+}
+
+sub interrupt {
+	my ($self) = @_;
+	$self -> {timer_inertie} -> stop ();
+}
+
+sub target_pressed {
+	my ($self, $x, $y, $t) = @_;
+	$self -> interrupt ();
+	$self -> {__old_x} = 0;
+	$self -> {__old_y} = 0;
+	$self -> {__old_t} = 0;
+	$self -> {__x} = 0;
+	$self -> {__y} = 0;
+	$self -> {__t} = 0;
+}
+
+sub target_moved {
+	my ($self, $x, $y, $t) = @_;
+	if (!defined $t)
+	{
+		$t = Time::HiRes::gettimeofday();
+	}
+	$self -> {__old_x} = $self -> {__x};
+	$self -> {__old_y} = $self -> {__y};
+	$self -> {__old_t} = $self -> {__t};
+	$self -> {__x} = $x;
+	$self -> {__y} = $y;
+	$self -> {__t} = $t;
+}
+
+sub target_released {
+	my ($self, $x, $y, $t) = @_;
+	if (!defined $t)
+	{
+		$t = Time::HiRes::gettimeofday();
+	}
+	my $dt = $self -> {__t} - $self -> {__old_t};
+	my $dx = $self -> {__x} - $self -> {__old_x};
+	my $dy = $self -> {__y} - $self -> {__old_y};
+	if ($dt && $self -> mget ('-visible'))
+	{
+		$self -> {__vx} = ($dx * 1000) / ($dt * 60);
+		$self -> {__vy} = ($dy * 1000) / ($dt * 60);
+		$self -> {timer_inertie} -> start();
+	}
+	else
+	{
+		$self -> notify ($self -> {__msg_stopped});
+	}
+	$self -> {__old_x} = 0;
+	$self -> {__old_y} = 0;
+	$self -> {__old_t} = 0;
+	$self -> {__x} = 0;
+	$self -> {__y} = 0;
+	$self -> {__t} = 0;
+}
+
+sub inertie {
+	my ($self) = @_;
+	my $rate = $self -> mget ('rate');
+	$self -> {__vx} *= $rate;
+ 	$self -> {__vy} *= $rate;
+	if ((abs $self -> {__vx} <= 2) and (abs $self -> {__vy} <= 2)) 
+	{
+		$self -> notify ($self -> {__msg_stopped});
+		$self -> {timer_inertie} -> stop();
+		return;
+  	}
+	my $dx = $self -> {__vx};
+	my $dy = $self -> {__vy};
+	my $target = $self -> mget ('target');
+	my $callback = $self -> mget ('inertie_callback');
+	$target -> $callback ($dx, $dy);
+}
+
+1;
diff --git a/src/MTools/Comp/MMover.pm b/src/MTools/Comp/MMover.pm
new file mode 100644
index 0000000..8282943
--- /dev/null
+++ b/src/MTools/Comp/MMover.pm
@@ -0,0 +1,221 @@
+package MTools::Comp::MMover;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Le composant MMover permet de donner un comportement prehensible a un objet zinc. Les deplacements peuvent etre contraints a un espace defin
+#
+# Parametres :
+#	* src : objet source des evenements de deplacement
+#	* targets : objets deplaces
+#	* button : bouton de la souris utilise pour genere le deplacement
+# Proprietes :
+#	* x_min, y_min, x_max, y_max : contraintes de l'espace dans lequel peut se deplacer le strip
+#	* allower : fonction permettre d'appliquer une contrainte plus complexe sur l'objet
+#	* x, y : position de l'objet modifiee par le MMover
+#	* targets : objets deplaces
+#	* -visible : active ou desactive le comportement prehensible
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, $src, $targets, $button, %options) = @_;
+	my $self = {};
+	bless $self, $class;
+
+	$self -> recordProperty ('x_min', -10000);
+	$self -> recordProperty ('y_min', -10000);
+	$self -> recordProperty ('x_max', 10000);
+	$self -> recordProperty ('y_max', 10000);
+	$self -> recordProperty ('-visible', 1);
+	$self -> recordProperty ('x', 0);
+	$self -> recordProperty ('y', 0);
+	$self -> recordProperty ('targets', $targets);
+	$self -> recordProperty ('allower', undef);
+	
+	$self -> mconfigure (%options);
+	
+	$self -> recordEvent ('PRESSED');
+	$self -> recordEvent ('MOVED');
+	$self -> recordEvent ('RELEASED');
+		
+	$button = 1 if ! defined $button;
+	binding ($src, "<Button-$button>", [\&__pressed, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($src, "<Button$button-Motion>", [\&__moved, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($src, "<ButtonRelease-$button>", [\&__released, $self, Ev('x'), Ev('y'), Ev('t')]);
+		
+	$self -> {__last_mouse_x} = 0;
+	$self -> {__last_mouse_y} = 0;
+
+	return $self;
+}
+
+sub setPos {
+	my ($self, $x, $y) = @_;
+	my $dx = $x - $self -> mget ('x');
+	my $dy = $y - $self -> mget ('y');
+	my $tgs = $self -> mget ('targets');
+	my @targets;
+	if (ref ($tgs) eq 'ARRAY')
+	{
+		@targets = @{$tgs};
+		for (my $i = 0; $i < @targets; $i++)
+		{
+			$targets [$i] -> translate ($dx, $dy);
+		}
+	}
+	else
+	{
+		$tgs -> translate ($dx, $dy);
+	}
+	$self -> mconfigure ('x', $x);
+	$self -> mconfigure ('y', $y);
+}
+
+sub __pressed {
+	my ($self, $x, $y, $t) = @_;
+	if(!$self -> mget('-visible')) {return;}
+	$self -> {__started} = 1;
+	$self -> {__last_mouse_x} = $x;
+	$self -> {__last_mouse_y} = $y;
+	$self -> notify ('PRESSED', $self -> {__last_mouse_x}, $self -> {__last_mouse_y}, $t);
+}
+
+sub __moved {
+	my ($self, $x, $y, $t) = @_;
+	if (!$self -> {__started}) {return;}
+	if(!$self -> mget('-visible')) {return;}
+	
+	my $dx = $x - $self -> {__last_mouse_x};
+	my $dy = $y - $self -> {__last_mouse_y};
+
+	my $x_min = $self -> mget('x_min');
+	my $y_min = $self -> mget('y_min');
+	my $x_max = $self -> mget('x_max');
+	my $y_max = $self -> mget('y_max');
+	my $current_x = $self -> mget ('x');
+	my $current_y = $self -> mget ('y');
+	if($current_x + $dx > $x_max)
+	{
+		$x -= $current_x + $dx - $x_max;	
+		$dx -= $current_x + $dx - $x_max;
+	}
+	if($current_y + $dy > $y_max)
+	{
+		$y -= $current_y + $dy - $y_max;	
+		$dy -= $current_y + $dy - $y_max;
+	}
+	if($current_x + $dx < $x_min)
+	{
+	
+		$x -= $current_x + $dx - $x_min;	
+		$dx -= $current_x + $dx - $x_min;
+	}
+	if($current_y + $dy < $y_min)
+	{
+		$y -= $current_y + $dy - $y_min;	
+		$dy -= $current_y + $dy - $y_min;
+	}
+	if( $dx == 0 && $dy == 0 )
+	{
+		return;
+	}
+	my $allower = $self -> mget ('allower');
+	if ($allower)
+	{
+		my ($ddx, $ddy) = executer ($allower, $current_x, $current_y, $dx, $dy);
+		$x -= $ddx;
+		$dx -= $ddx;
+		$y -= $ddy;
+		$dy -= $ddy;
+		if( $dx == 0 && $dy == 0 )
+		{
+			return;
+		}
+	}
+	$self -> {__last_mouse_x} = $x;
+	$self -> {__last_mouse_y} = $y;
+	$current_x += $dx;
+	$current_y += $dy;
+	$self -> notify ('MOVED', $current_x, $current_y, $t);	
+	$self -> setPos ($current_x, $current_y);
+}
+
+sub __released {
+	my ($self, $x, $y, $t) = @_;
+	$self -> {__started} = 0;
+	if(!$self -> mget('-visible')) {return;}
+	$self -> notify ('RELEASED', $self -> {__last_mouse_x}, $self -> {__last_mouse_y}, $t);
+}
+
+sub translate {
+	my ($self, $dx, $dy, $t) = @_;
+	my $x_min = $self -> mget('x_min');
+	my $y_min = $self -> mget('y_min');
+	my $x_max = $self -> mget('x_max');
+	my $y_max = $self -> mget('y_max');
+	my $current_x = $self -> mget ('x');
+	my $current_y = $self -> mget ('y');
+	if($current_x + $dx > $x_max)
+	{
+		$dx -= $current_x + $dx - $x_max;
+	}
+	if($current_y + $dy > $y_max)
+	{
+		$dy -= $current_y + $dy - $y_max;
+	}
+	if($current_x + $dx < $x_min)
+	{
+	
+		$dx -= $current_x + $dx - $x_min;
+	}
+	if($current_y + $dy < $y_min)
+	{
+		$dy -= $current_y + $dy - $y_min;
+	}
+	if( $dx == 0 && $dy == 0 )
+	{
+		return;
+	}
+	my $allower = $self -> mget ('allower');
+	if ($allower)
+	{
+		my ($ddx, $ddy) = executer ($allower, $current_x, $current_y, $dx, $dy);
+		$dx -= $ddx;
+		$dy -= $ddy;
+		if( $dx == 0 && $dy == 0 )
+		{
+			return;
+		}
+	}
+	$current_x += $dx;
+	$current_y += $dy;
+	$self -> setPos ($current_x, $current_y);
+	$self -> notify ('MOVED', $current_x, $current_y, $t);
+}
+
+1;
diff --git a/src/MTools/Comp/MMultiSelection.pm b/src/MTools/Comp/MMultiSelection.pm
new file mode 100644
index 0000000..f124720
--- /dev/null
+++ b/src/MTools/Comp/MMultiSelection.pm
@@ -0,0 +1,754 @@
+package MTools::Comp::MMultiSelection;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+
+# Le composant MMultiSelection associe deux comportements :
+# 	1. Selection multiple d'objets repartis eventuellement dans plusieurs plans. 
+# 	La selection des objets est geree en les entourant et des-entourant.
+# 	Si un objet est selectionne dans le plan 1, les objets situes dans les plans 2, 3, etc. sont negliges. 
+# 	De meme, si un objet est selectionne dans le plan, les objets situes dans les plans 3, 4, etc. sont negliges.
+#	2. Deux interactions peuvent-etre initiees depuis la zone de selection. Si l'interaction est demarree 
+#	au-dessus d'un objet, on deplace les objets selectionnes. Si on demarre un interaction au-dessus du fond,
+#	on demarre une operation de designation de cibles.
+#
+#	Les cibles et les objets selectionnables doivent declarer des proprietes particulieres. Il n'y a ce jour de 
+# 	composant definissant ces interfaces, c'est un tord... Qui est volontaire :)
+#
+#	Les source doivent definir les prorpiete 
+#		barycentre_x
+#		barycentre_y
+# 	La position d'un objet est definie par 
+#		la valeur de barycentre_x plus optionnelement la valeur de la propriete x si celle-ci est definie
+#		la valeur de barycentre_y plus optionnelement la valeur de la propriete y si celle-ci est definie
+#	Les cibles doivent emettre les evenements 
+#		DRAGENTER
+#		DRAGLEAVE
+#		RELEASEDOVER
+#
+#	NOTA : le deuxieme comportement devrait etre dissocie de l'objet multi-selection... 
+#	Cela reste a faire egalement
+#
+# Parametres : 
+#	* src : Objet sur lequel est effectue l'interaction de selection
+#	* dessin : Group parent du dessin de la selection
+#	* reference a la frame principale
+# Proprietes : 
+#	* delay : duree pendant laquelle le dessin de la selection s'estompe et pendant laquelle le demarrage de la
+#	seconde interaction est possible
+#	* inertie : coefficient d'inertie dqns le deplacement de la fleche
+# Evenements :
+#	* PRESSED : Notifie lorsque l'on demarre la selection
+#	* MOVED : Notifie lorsque la selection evolue
+#	* RELEASED : Notifie lorsque la selection est terminee
+#	* FLECHEPRESSED : Notifie lorsque une seconde interaction est demarree depuis la zone de selection
+#	* FLECHEMOVED : Notifie lorsque la seconde interaction evolue
+#	* FLECHERELEASED : Notifie lorsque la seconde interaction se termine
+#	* SELECTION_CHANGED : Notifie lorsque le statut d'un objet a change
+# Fonctions : 
+#	* addObject : $multi -> addObject ($objet, $plan)
+#	Ajoute l'objet $objet dans le plan de selection $plan
+#	* removeObject : $multi -> removeObject ($objet, $plan)
+#	Supprime l'objet $objet du plan de selection $plan
+#	* addDropTarget : $multi -> addDropTarget ($target)
+#	Ajoute la cible $target
+#	* removeDropTarget : $multi -> removeDropTarget ($target)
+#	Supprime la cible $target
+#	* applySelection : $multi -> applySelection ($plan, $fonction, @parametres)
+#	Applique la fonction $fonction (@parametres) ? tous les objets selectionnes dans le plan $plan
+#	* applyAll : $multi -> applyAll ($plan, $fonction, @parametres)
+#	Applique la fonction $fonction (@parametres) ? tous les objets du plan $plan
+#	* getSelectedPlan : $multi -> getSelectedPlan ()
+#	Retourne l'index du plan selectionne
+#	* getSelection : $multi -> getSelection ($plan)
+#	Retourne la liste des objets selectionnes dans le plan $plan si $plan est d?fini 
+#	sinon retourne $multi -> getSelection ($multi -> getSelectedPlan ())
+#	
+
+
+
+use strict;
+use MTools;
+use MTools::MObjet;
+use Math::Trig;
+use MTools::Anim::MOpacity;
+use MTools::Comp::MInertie;
+use MTools::MGroup;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, $src, $dessin, $frame, %options) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+	
+	$self -> recordProperty ('delay', 0);
+	$self -> recordProperty ('inertie', 0.6);
+	$self -> recordEvent ('PRESSED');
+	$self -> recordEvent ('MOVED');
+	$self -> recordEvent ('RELEASED');
+	$self -> recordEvent ('FLECHEPRESSED');
+	$self -> recordEvent ('FLECHEMOVED');
+	$self -> recordEvent ('FLECHERELEASED');
+	$self -> recordEvent ('SELECTION_CHANGED');
+	$self -> recordEvent ('DESELECT_ALL');
+	$self -> mconfigure (%options);
+	
+	binding ($src, '<Button-1>', [\&__pressed, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($src, '<Button1-Motion>', [\&__moved, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($src, '<ButtonRelease-1>', [\&__released, $self, Ev('x'), Ev('y'), Ev('t')]);
+	
+	$self -> {__inertie} = my $inertie = new MTools::Comp::MInertie(
+		$self,
+		'rate' => $self -> mget ('inertie'),
+	);
+	binding ($inertie, 'INERTIE_STOPPED', [$self, \&__fin_moved]);
+	
+	my $inertie = new MTools::Comp::MInertie(
+		$self,
+		'rate' => 0.75,
+		'msg_pressed' => 'FLECHEPRESSED',
+		'msg_moved' => 'FLECHEMOVED',
+		'msg_released' => 'FLECHERELEASED',
+		'msg_stopped' => 'FLECHEINERTIE_STOPPED',
+		'inertie_callback' => '__translate_fleche',
+	);
+	binding ($inertie, 'FLECHEINERTIE_STOPPED', [$self, \&__fin_fleche_moved]);
+	
+	$self -> {__frame} = $frame;
+	$self -> {__drop_targets} = ();
+	$self -> {__objects} = ();
+	$self -> {__points} = ();
+	$self -> {__owns_data} = ();
+	$self -> {__source} = minstance ($src);
+	
+	$self -> {__gp_anime} = my $group = new MTools::MGroup ($dessin);
+	
+	push (@{$self -> {__owns_data}}, minstance ($src));
+	push (@{$self -> {__owns_data}}, minstance ($group));
+	
+	$self -> {__anim__disparition} = new MTools::Anim::MOpacity (
+		duration => 0.8,
+		targets => $group,
+		from_opacity => 100,
+		to_opacity => 0,
+	);
+	
+	binding ($self -> {__anim__disparition}, 'ANIMATION_END', [$self, \&__clear]);
+
+	$self -> {__curve_bck} = $zinc -> add ('curve', minstance($group), [[0,0],[0,0]],
+		-linecolor => "#888888;50",
+		-linewidth => 2,
+		-smoothrelief => 1,
+		-priority => 10,
+		-visible  => 1,
+		-sensitive => 1,
+		-filled => 0,
+	);
+	$self -> {__curve} = $zinc -> add ('curve', minstance($group), [[0,0],[0,0]],
+		-linecolor => "#FFFFFF;90",
+		-linewidth => 1,
+		-smoothrelief => 1,
+		-priority => 10,
+		-visible  => 1,
+		-sensitive => 1,
+		-fillcolor => "#FFFFFF;10",
+		-filled => 1,
+	);
+	push (@{$self -> {__owns_data}}, minstance ($self -> {__curve}));
+	
+	$self -> {__fleche} = $zinc -> add ('curve', minstance($dessin), [[0,0],[0,0]],
+		-linecolor => "black",
+		-linewidth => 2,
+		-priority => 10,
+		-visible  => 1,
+		-sensitive => 0,
+	);
+	push (@{$self -> {__owns_data}}, minstance ($self -> {__fleche}));
+	
+	$self -> {__ph_fleche} = $zinc -> add ('curve', minstance($dessin), [[0,0],[0,0]],
+		-linecolor => "black",
+		-linewidth => 2,
+		-priority => 10,
+		-visible  => 1,
+		-sensitive => 0,
+	);
+	push (@{$self -> {__owns_data}}, minstance ($self -> {__ph_fleche}));
+	
+	$self -> {__pb_fleche} = $zinc -> add ('curve', minstance($dessin), [[0,0],[0,0]],
+		-linecolor => "black",
+		-linewidth => 2,
+		-priority => 10,
+		-visible  => 1,
+		-sensitive => 0,
+	);
+	push (@{$self -> {__owns_data}}, minstance ($self -> {__pb_fleche}));
+
+	binding ($self -> {__curve}, '<Button-1>', [\&__fleche_pressed, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($self -> {__curve}, '<Button1-Motion>', [\&__fleche_moved, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($self -> {__curve}, '<ButtonRelease-1>', [\&__fleche_released, $self, Ev('x'), Ev('y'), Ev('t')]);
+	$self -> {__fleche_points} = ();
+	$self -> {__fleche_started} = 0;
+	$self -> {__drag_started} = 0;
+	return $self;
+}
+
+sub __hide_cursor {
+	my ($self) = @_;
+	my $frame = $self -> {__frame};
+	$frame -> {window} -> Tk::configure (
+		-cursor => [ '@'.Tk::findINC('emptycursor.xbm'),
+			Tk::findINC('emptycursor.mask'),
+			'black', 'black'
+		]
+	);
+}
+
+sub __show_cursor {
+	my ($self) = @_;
+	my $frame = $self -> {__frame};
+	$frame -> {window} -> Tk::configure (
+		-cursor => "",
+	);
+}
+
+sub addObject {
+	my ($self, $object, $plan) = @_;
+	if (!defined $plan) {$plan = 0;}
+	if (!$object -> propertyExists ('barycentre_x'))
+	{
+		print "MMultiSelection Error property barycentre_x isn't defined in $object\n";
+		return;
+	}
+	if (!$object -> propertyExists ('barycentre_y'))
+	{
+		print "MMultiSelection Error property barycentre_y isn't defined in $object\n";
+		return;
+	}
+	$object -> {__surround_angle} = 0;
+	push (@{$self -> {__objects} [$plan]}, $object);
+}
+
+sub removeObject {
+	my ($self, $target, $plan) = @_;
+	if (!defined $plan) {$plan = 0;}
+	for (my $i = @{$self -> {__objects} [$plan]} - 1; $i >= 0; $i --) 
+	{
+		if (@{$self -> {__objects} [$plan]} [$i] eq $target) 
+		{
+			splice (@{$self -> {__objects} [$plan]}, $i, 1);
+			last;
+		}
+	}
+}
+
+sub addDropTarget {
+	my ($self, $target) = @_;
+	push (@{$self -> {__drop_targets}}, $target);
+}
+
+sub removeDropTarget {
+	my ($self, $target) = @_;
+	if ($self -> {__last_notified} == $target)
+	{
+		$self -> {__last_notified} = undef;
+	}
+	for (my $i = @{$self -> {__drop_targets}} - 1; $i >= 0; $i--) 
+	{
+		if (@{$self -> {__drop_targets}} [$i] eq $target) 
+		{
+			splice (@{$self -> {__drop_targets}}, $i, 1);
+			last;
+		}
+	}
+}
+
+sub __clear {
+	my ($self) = @_;
+	$self -> {__anim__disparition} -> stop ();
+	$self -> {__inertie} -> interrupt ();
+	$self -> {__fleche_started} = 0;
+	$self -> {__drag_started} = 0;
+	$self -> {__points} = ();
+	$self -> {__fleche_points} = ();
+	$self -> __reset_surrounding ();
+	$zinc -> coords ($self -> {__ph_fleche}, 0, [[0,0],[0,0]]);
+	$zinc -> coords ($self -> {__pb_fleche}, 0, [[0,0],[0,0]]);
+	$zinc -> coords ($self -> {__fleche}, 0, [[0,0],[0,0]]);
+	$zinc -> coords ($self -> {__curve}, 0, [[0,0],[0,0]]);
+	$zinc -> coords ($self -> {__curve_bck}, 0, [[0,0],[0,0]]);
+	$self -> {__gp_anime} -> mconfigure (
+		-alpha => 100,
+	);
+}
+
+sub __pressed {
+	my ($self, $x, $y, $t) = @_;
+	$self -> __clear ();
+	push (@{$self -> {__points}}, [$x, $y]);
+	$self -> notify ('PRESSED', $x, $y, $t);
+	$self -> notify ('DESELECT_ALL');
+}
+
+sub __released {
+	my ($self, $x, $y, $t) = @_;
+	my $pt = $self -> {__points}[@{$self -> {__points}} - 2];
+	$self -> notify ('RELEASED',  $x - $pt -> [0], $y - $pt -> [1], $t);
+}
+
+sub __fin_moved {
+	my ($self) = @_;
+	if (!$self -> {__fleche_started} && !$self -> {__drag_started})
+	{
+		$self -> {__anim__disparition} -> start ();
+	}
+}
+
+sub __moved {
+	my ($self, $x, $y, $t) = @_;
+	push (@{$self -> {__points}}, [$x, $y]);
+	my @pts = @{$self -> {__points}};
+	$zinc -> coords ($self -> {__curve}, 0, \@pts);
+	$zinc -> coords ($self -> {__curve_bck}, 0, \@pts);
+	my $pt = $self -> {__points}[@{$self -> {__points}} - 2];
+	$self -> notify ('MOVED', $x - $pt -> [0], $y - $pt -> [1], $t);
+	$self -> __update_all ();
+}
+
+sub translate {
+	my ($self, $dx, $dy) = @_;
+	my $pt = $self -> {__points}[@{$self -> {__points}} - 1];
+	push (@{$self -> {__points}}, [$pt -> [0] - $dx, $pt -> [1] - $dy]);
+	my @pts = @{$self -> {__points}};
+	$zinc -> coords ($self -> {__curve}, 0, \@pts);
+	$zinc -> coords ($self -> {__curve_bck}, 0, \@pts);
+	$self -> __update_all ();
+}
+
+sub __fleche_pressed {
+	my ($self, $x, $y, $t) = @_;
+	my @all = $zinc -> find ('overlapping', $x, $y, $x + 1, $y +1);
+	if ($all [1] == $self -> {__source})
+	{
+		$self -> {__fleche_points} = ();
+		push (@{$self -> {__fleche_points}}, [$x, $y]);
+		$self -> {__fleche_started} = 1;
+		$self -> __hide_cursor ();
+		$self -> notify ('FLECHEPRESSED', $x, $y, $t);
+		$self -> __stop_animation ();
+	}
+	else
+	{
+		$self -> {__drag_started} = 1;
+		$self -> {__lx} = $x;
+		$self -> {__ly} = $y;
+		$self -> notify ('FLECHEPRESSED', $x, $y, $t);
+	}
+}
+
+sub __stop_animation {
+	my ($self) = @_;
+	$self -> {__anim__disparition} -> stop ();
+	$self -> {__gp_anime} -> mconfigure (
+		-alpha => 100,
+	);
+}
+
+sub __fleche_released {
+	my ($self, $x, $y, $t) = @_;
+	if ($self -> {__fleche_started}) 
+	{
+		my $pt = $self -> {__fleche_points}[@{$self -> {__fleche_points}} - 1];
+		$self -> notify ('FLECHERELEASED', $x - $pt -> [0], $y - $pt -> [1], $t);
+	}
+	else
+	{
+		$self -> notify ('FLECHERELEASED', $x - $self -> {__lx}, $y - $self -> {__ly}, $t);
+		$self -> {__lx} = $x;
+		$self -> {__ly} = $y;
+	}
+
+}
+
+sub __fin_fleche_moved {
+	my ($self) = @_;
+	if ($self -> {__fleche_started}) 
+	{
+		$self -> __clear ();
+		if (defined $self -> {__last_notified})
+		{
+			$self -> {__last_notified} -> notify ('RELEASEDOVER', $self);
+			$self -> {__last_notified} = undef;
+		}
+		elsif (defined $self -> {__secondary_last_notified})
+		{
+			$self -> {__secondary_last_notified} -> notify ('RELEASEDOVER', $self);
+			$self -> {__secondary_last_notified} = undef;
+		}
+		$self -> __show_cursor ();
+	}
+	else
+	{
+	}
+}
+
+sub __fleche_moved {
+	my ($self, $x, $y, $t) = @_;
+	if ($self -> {__fleche_started}) 
+	{
+		push (@{$self -> {__fleche_points}}, [$x, $y]);
+		my @pts = @{$self -> {__fleche_points}};
+		$zinc -> coords ($self -> {__fleche}, 0, \@pts);
+		my $pt = $self -> {__fleche_points}[@{$self -> {__fleche_points}} - 2];
+		$self -> notify ('FLECHEMOVED', $x - $pt -> [0], $y - $pt -> [1], $t);
+		$self -> __update_fleche_moved ($x, $y);
+	}
+	else
+	{
+		$self -> notify ('FLECHEMOVED', $x - $self -> {__lx}, $y - $self -> {__ly}, $t);
+		$self -> __translate_selection ($x - $self -> {__lx}, $y - $self -> {__ly});
+		$self -> {__lx} = $x;
+		$self -> {__ly} = $y;
+	}
+}
+
+sub __translate_fleche {
+	my ($self, $dx, $dy) = @_;
+	if ($self -> {__fleche_started}) 
+	{
+		my $pt = $self -> {__fleche_points}[@{$self -> {__fleche_points}} - 1];
+		push (@{$self -> {__fleche_points}}, [$pt -> [0] - $dx, $pt -> [1] - $dy]);
+		my @pts = @{$self -> {__fleche_points}};
+		$zinc -> coords ($self -> {__fleche}, 0, \@pts);
+		$self -> __update_fleche_moved ($pt -> [0] - $dx, $pt -> [1] - $dy);
+	}
+	else
+	{
+		$self -> __translate_selection (-$dx, -$dy);
+	}
+}
+
+sub __translate_selection {
+	my ($self, $dx, $dy) = @_;
+	my @oldy = $self -> applySelection (0, 'mget', 'y');
+	my @oldx = $self -> applySelection (0, 'mget', 'x');
+	my @selection = $self -> getSelection ();
+	for (my $i = 0; $i < @selection; $i ++)
+	{
+		my $x = $selection [$i] -> mget ('x');
+		my $pdx = $dx - ($x - $oldx [$i]);
+		my $y = $selection [$i] -> mget ('y');
+		my $pdy = $dy - ($y - $oldy [$i]);
+		$selection [$i] -> translate ($pdx, $pdy);
+	}
+}
+	
+sub __update_fleche_moved {
+	my ($self, $x, $y) = @_;
+	my $pt;
+	if (@{$self -> {__fleche_points}} > 2)
+	{
+		$pt = $self -> {__fleche_points}[@{$self -> {__fleche_points}} - 3];
+	}
+	else
+	{
+		$pt = $self -> {__fleche_points}[@{$self -> {__fleche_points}} - 2];
+	}
+	my $xa = $x - $pt -> [0];
+	my $ya = $y - $pt -> [1];
+	if ($xa + $ya == 0) {return;}
+
+	my $norme = sqrt ($xa * $xa + $ya * $ya);
+	$xa = $xa * 8 / $norme;
+	$ya = $ya * 8 / $norme;
+
+	if ( $xa != 0)
+	{
+		my $yb = sqrt ((10 * 10 - $xa * $xa - $ya * $ya) / (1 + $ya * $ya / ($xa * $xa)));
+		my $xb = -$yb * $ya / $xa;
+		$zinc -> coords ($self -> {__ph_fleche}, 0, [[$x, $y], [$x + $xb - $xa, $y + $yb - $ya]]);
+		$zinc -> coords ($self -> {__pb_fleche}, 0, [[$x, $y], [$x - $xb - $xa, $y - $yb - $ya]]);
+	}
+	else
+	{
+		my $xb = sqrt (10 * 10 - $ya * $ya);
+		my $yb = 0;
+		$zinc -> coords ($self -> {__ph_fleche}, 0, [[$x, $y], [$x + $xb - $xa, $y + $yb - $ya]]);
+		$zinc -> coords ($self -> {__pb_fleche}, 0, [[$x, $y], [$x - $xb - $xa, $y - $yb - $ya]]);
+	}
+	my @all = $zinc -> find ('overlapping', $x, $y, $x + 1, $y +1);
+	
+	if (defined $self -> {__drop_targets})
+	{
+		my @selected;
+		my @owns = @{$self -> {__owns_data}};
+		for (my $i = 0; $i < @all; $i++)
+		{
+			my $find = 0;
+			for (my $j = 0; $j < @owns; $j ++)
+			{
+				if ($all [$i] == $owns [$j])
+				{
+					$find = 1;
+				}
+			}
+			if (!$find)
+			{
+				push (@selected, $all [$i]);
+			}
+		}
+		if (defined @selected)
+		{
+			my @targets = @{$self -> {__drop_targets}};
+			my $last_notified = $self -> {__last_notified};
+			$self -> {__last_notified} = undef;
+			for (my $i = 0; $i < @targets; $i ++)
+			{
+				if (minstance ($targets [$i]) == $selected [0] || minstance ($targets [$i]) == $selected [1])
+				{
+					if ($last_notified != $targets [$i])
+					{
+						$targets [$i] -> notify ('DRAGENTER');
+					}
+					$self -> {__last_notified} = $targets [$i];
+				}
+				else
+				{
+					if ($last_notified == $targets [$i])
+					{
+						$targets [$i] -> notify ('DRAGLEAVE');
+					}
+				}
+			}
+		}
+	}
+}
+
+sub getObjectBellow {
+	my ($self, $x, $y, @objects) = @_;
+	my @all = $zinc -> find ('overlapping', $x, $y, $x + 1, $y +1);
+	my @owns = @{$self -> {__owns_data}};
+	my @below;
+	for (my $i = 0; $i < @all; $i++)
+	{
+		my $find = 0;
+		for (my $j = 0; $j < @owns; $j ++)
+		{
+			if ($all [$i] == $owns [$j])
+			{
+				$find = 1;
+			}
+		}
+		if (!$find)
+		{
+			push (@below, $all [$i]);
+		}
+	}
+	my $nb = @below;
+	my @elements;
+	for (my $i = 0; $i < $nb; $i ++)
+	{
+		my @fils = $zinc -> find ('ancestors', $below [$i]);
+		push (@elements, '-'.$below [$i], @fils);
+	}
+	my $main;
+	for (my $j = 0; $j < @elements; $j ++)
+	{
+		if (index($elements [$j], '-') == 0)
+		{
+			$elements [$j] = substr ($elements [$j], 1, length ($elements [$j]));
+			$main = $elements [$j];
+		}
+		for (my $i = 0; $i < @objects; $i++)
+		{
+			if (minstance ($objects [$i]) == $elements [$j])
+			{
+				return ($objects [$i], $main);
+			}
+		}
+	}
+	return undef;
+}
+
+sub __update_all {
+	my ($self) = @_;
+	my $selection_changed = 0;
+  	$self -> {_selected} = 0;
+	$self -> {__selected_plan} = -1;
+	if (defined $self -> {__objects})
+	{
+		my @object_plan = @{$self -> {__objects}};
+		for (my $j = 0; $j < @object_plan; $j ++)
+		{
+			if (defined $self -> {__objects} [$j])
+			{
+				my @items = @{$self -> {__objects} [$j]};
+				for (my $i = 0; $i < @items; $i++)
+				{
+					$selection_changed = $selection_changed || $self -> __update_surrouding ($items [$i], ($self -> {__selected_plan} != -1), $self -> {__points});
+				}
+				if ($self -> {_selected} && $self -> {__selected_plan} == -1)
+				{
+					$self -> {__selected_plan} = $j;
+				}
+			}
+		}
+	}
+	if ($selection_changed)
+	{
+		$self -> notify ('SELECTION_CHANGED', $self)
+	}
+}
+
+sub getSelectedPlan {
+	my ($self) = @_;
+	return $self -> {__selected_plan};
+}
+
+sub __update_surrouding {
+	my ($self, $item, $force_non_sel, $coords) = @_;
+	my $center_x = $item -> mget ('barycentre_x');
+	if ($item -> propertyExists ('x'))
+	{
+		$center_x += $item -> mget ('x');
+	}
+	my $center_y = $item -> mget ('barycentre_y');
+	if ($item -> propertyExists ('y'))
+	{
+		$center_y += $item -> mget ('y');
+	}
+	my ($tmp,$ref);
+	$ref = -$self -> __angle($coords, @{$coords} - 1, $center_x, $center_y, 0);
+	$tmp = -$self -> __angle($coords, @{$coords} - 2, $center_x, $center_y, $ref);
+	$item -> {__surround_angle} += $tmp;
+	$tmp = $self -> __angle($coords, 0, $center_x, $center_y, $ref);
+	if ($force_non_sel)
+	{
+		if ($item -> isSelected ())
+		{
+	    	$item -> setSelected (0);
+		}
+	}
+	else
+	{
+		if (abs ($item -> {__surround_angle} + $tmp) > 2) 
+		{
+			$self -> {_selected} ++;
+			if (!$item -> isSelected ())
+			{
+	  			$item -> setSelected (1);
+	  			return 1;
+			}
+		} 
+		else 
+		{
+			if ($item -> isSelected ())
+			{
+		    	$item -> setSelected (0);
+		    	return 1;
+			}
+		}
+	}
+	return 0;
+}
+
+sub __angle {
+	my ($self, $coords, $index, $center_x, $center_y, $ref) = @_;
+	my $angle;
+	my $tab = $coords -> [$index];
+	$angle = atan2 ($tab -> [1] - $center_y, $tab -> [0] - $center_x) + $ref;
+	$angle -= 2*pi if ($angle > pi);
+	$angle += 2*pi if ($angle < - pi);
+	return $angle;
+}
+
+sub __reset_surrounding {
+	my ($self) = @_;
+	if (defined $self -> {__objects})
+	{
+		my @object_plan = @{$self -> {__objects}};
+		for (my $j = 0; $j < @object_plan; $j ++)
+		{
+			if (defined $self -> {__objects} [$j])
+			{
+				my @items = @{$self -> {__objects} [$j]};
+				for (my $i = 0; $i < @items; $i++)
+				{
+					$items [$i] -> {__surround_angle} = 0;
+				}
+			}
+		}
+	}
+}
+
+sub applySelection {
+	my ($self, $plan, $fct, @args) = @_;
+	my @retour;
+	if (defined $self -> {__objects} [$plan])
+	{
+		my @items = @{$self -> {__objects} [$plan]};
+		for (my $i = 0; $i < @items; $i++)
+		{
+			if ($items [$i] -> isSelected ())
+			{
+				push (@retour, $items [$i] -> $fct (@args));
+			}
+		}
+	}
+	return @retour;
+}
+
+sub applyAll {
+	my ($self, $plan, $fct, @args) = @_;
+	my @retour;
+	if (defined $self -> {__objects} [$plan])
+	{
+		my @items = @{$self -> {__objects} [$plan]};
+		for (my $i = 0; $i < @items; $i++)
+		{
+			push (@retour, $items [$i] -> $fct (@args));
+		}
+	}
+	return @retour;
+}
+
+sub getSelection {
+	my ($self, $plan) = @_;
+	if (!defined $plan) {$plan = $self -> getSelectedPlan ();}
+	my @selection;
+	if (defined $self -> {__objects} [$plan])
+	{
+		my @items = @{$self -> {__objects} [$plan]};
+		for (my $i = 0; $i < @items; $i++)
+		{
+			if ($items [$i] -> isSelected ())
+			{
+				push (@selection, $items [$i]);
+			}
+		}
+	}
+	return @selection;
+}
+
+1;
diff --git a/src/MTools/Comp/MReconizer.pm b/src/MTools/Comp/MReconizer.pm
new file mode 100644
index 0000000..9605eb9
--- /dev/null
+++ b/src/MTools/Comp/MReconizer.pm
@@ -0,0 +1,145 @@
+package MTools::Comp::MReconizer;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Le composant permet de rendre un objet zinc sensible a la reco de geste
+#
+# Parametres :
+#	* src : objet rendu sensible et donc source des evenements
+#	* button : bouton de la souris utilise pour genere la reco de geste
+#	* %options :  table de hash permettant la configuration initiale des proprietes
+# Proprietes : 
+#	* animation_duration : duree de l'animation de disparition du feedback
+#	* color : couleur du feedback
+#	* callback : callback appelee sur reconnaissance
+# Evenements :
+#	* START_GESTURE_RECO : evenement survenant lors du demarrage d'un geste
+#	* RECONIZED : evenement survenant lorsque un geste est reconnu
+
+use strict;
+use MTools;
+use MTools::MObjet;
+use Recogestures;
+
+use MTools::Anim::MOpacity;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, $src, $button, %options) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+
+	$button = 1 if ! defined $button;
+	
+	$self -> recordEvent ('RECONIZED');
+	$self -> recordEvent ('START_GESTURE_RECO');
+	$self -> recordProperty ('animation_duration', 0.5);
+	$self -> recordProperty ('color', 'blue');
+	$self -> recordProperty ('callback', undef);
+	
+	$self -> mconfigure (%options);
+		
+	binding ($src, "<Button-$button>", [\&__pressed, $self, Ev('x'), Ev('y')]);
+	binding ($src, "<Button$button-Motion>", [\&__moved, $self, Ev('x'), Ev('y')]);
+	binding ($src, "<ButtonRelease-$button>", [\&__released, $self, Ev('x'), Ev('y')]);
+
+	$self -> binding ('RECONIZED', sub {
+		my $methode = $self -> mget ('callback');
+		if (defined $methode)
+		{
+			executer ($methode, @_);
+		}
+	});
+	$self -> {__dessin} = undef;
+	
+	$self -> {__dessin} = my $dessin = new MTools::MGroup (1);
+	$self -> {__fleche} = $zinc -> add ('curve', minstance($dessin), [[0,0],[0,0]],
+		-linecolor => 'blue',
+		-linewidth => 2,
+        -priority => 10,
+        -visible  => 1,
+        -sensitive => 0,
+	);
+	
+	$self -> {__anim__disparition} = new MTools::Anim::MOpacity (
+		duration => 0.8,
+		targets => $dessin,
+		from_opacity => 100,
+		to_opacity => 0,
+	);
+	binding ($self -> {__anim__disparition}, 'ANIMATION_END', [$self, \&__clear]);
+	plink ([$self, 'color'], [$self -> {__fleche}, '-linecolor']);
+	plink ([$self, 'animation_duration'], [$self -> {__anim__disparition}, 'duration']);
+
+	return $self;
+}
+
+sub __clear () {
+	my ($self, $x, $y) = @_;
+	$self -> {__points} = ();
+	$zinc -> coords ($self -> {__fleche}, 0, [[0,0],[0,0]]);
+	$self -> {__dessin} -> mconfigure (
+		-alpha => 100,
+	);
+}
+
+sub __pressed {
+	my ($self, $x, $y) = @_;
+	($x, $y) = $zinc -> transform('device', minstance ($self -> {__dessin}), [$x, $y]);
+	if (defined $self -> {__dessin})
+	{
+		push (@{$self -> {__points}}, [$x, $y]);
+	}
+	$self -> notify ('START_GESTURE_RECO', $x, $y);
+}
+
+sub __moved {
+	my ($self, $x, $y) = @_;
+	($x, $y) = $zinc -> transform('device', minstance ($self -> {__dessin}), [$x, $y]);
+	push (@{$self -> {trace}},$x,$y);
+	
+	if (defined $self -> {__dessin})
+	{
+		push (@{$self -> {__points}}, [$x, $y]);
+		my @pts = @{$self -> {__points}};
+		$zinc -> coords ($self -> {__fleche}, 0, \@pts);
+	}
+}
+
+sub __released {
+	my ($self, $x, $y) = @_;
+	
+	my ($gesture,$explanation) = AnalyzeGesture(@{$self -> {trace}});
+	$self -> {trace} = ();
+	$self -> notify ('RECONIZED', $gesture, $explanation);
+	
+	if (defined $self -> {__dessin})
+	{
+		$self -> {__anim__disparition} -> start ();
+	}
+}
+
+1;
+
diff --git a/src/MTools/Comp/MTremor.pm b/src/MTools/Comp/MTremor.pm
new file mode 100644
index 0000000..25b5023
--- /dev/null
+++ b/src/MTools/Comp/MTremor.pm
@@ -0,0 +1,121 @@
+package MTools::Comp::MTremor;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Le composant permet d'ajouter un comportement de tremblement ? un objet cible
+#
+# Parametres : 
+#	* target : objet cible du tremblement
+#	* %options : table de hash permettant la configuration initiale des proprietes
+# Propriete :
+#	* timeout : periode / 2 du tremblement
+#	* target : cible
+# 	* amplitude_x, amplitude_y : amplitude du deplacement
+#	* -visible : visibilite versus activation du comportement
+
+use strict;
+use MTools;
+#use MTools::MSwitch;
+use MTools::MTimer;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, $target, %options) = @_;
+	
+	$self -> {__timer} = my $timer = new MTools::MTimer (200, 1, \&tremble);
+	my $self = new MTools::MObjet ();
+#	$self -> {__sw} = new MTools::MSwitch (
+#		$parent,
+#		tremble => [$timer],
+#		fixe => [],
+#	);
+#	$self -> {__sw} -> mconfigure (state => 'fixe');
+	$timer -> mconfigure ( callback => [$self, '__tremble']);
+	bless $self, $class;
+
+	$self -> recordProperty ('timeout', 200);
+	$self -> recordProperty ('target', $target);
+	$self -> recordProperty ('amplitude_x', 2);
+	$self -> recordProperty ('amplitude_y', 2);
+	$self -> recordProperty ('-visible', 0);
+	$self -> plisten ('-visible', sub { 
+		my ($src, $key, $val) = @_;
+		if ($val == 0)
+		{
+			$self -> __stop ();
+		}
+		else
+		{
+			$self -> __start ();
+		}
+	});
+	
+	$self -> mconfigure (%options);
+	
+	plink ([$self, 'timeout'], [$timer, 'timeout']);
+	$self -> {__timer} = $timer;
+	$self -> {__x} = 0;
+	$self -> {__y} = 0;
+	$self -> {__started} = 0;
+	return $self;
+}
+
+sub __tremble {
+	my ($self) = @_;
+	my $target = $self -> mget ('target');
+	my $dx = -2 * $self -> {__x};
+	my $dy = -2 * $self -> {__y};
+	$self -> {__x} = -$self -> {__x};
+	$self -> {__y} = -$self -> {__y};
+	$target -> translate ($dx, $dy);
+}
+
+sub __start {
+	my ($self) = @_;
+	if ($self -> {__started}) {return;}
+	$self -> {__started} = 1;
+	my $target = $self -> mget ('target');
+	my $amplitudex = $self -> mget ('amplitude_x');
+	my $amplitudey = $self -> mget ('amplitude_y');
+	$self -> {__x} = $amplitudex;
+	$self -> {__y} = $amplitudey;
+	$target -> translate ($amplitudex, $amplitudey);
+#	$self -> {__sw} -> mconfigure ('state' => 'tremble');	
+	$self -> {__timer} -> start ();
+}
+
+sub __stop {
+	my ($self) = @_;
+	if (!$self -> {__started}) {return;}
+	$self -> {__started} = 0;
+	my $target = $self -> mget ('target');
+	$target -> translate (-$self -> {__x}, -$self -> {__y});
+	$self -> {__x} = 0;
+	$self -> {__y} = 0;
+	$self -> {__sw} -> mconfigure ('state' => 'fixe');
+	$self -> {__timer} -> stop ();
+}
+
+1;
diff --git a/src/MTools/Comp/MWritable.pm b/src/MTools/Comp/MWritable.pm
new file mode 100644
index 0000000..8a2a2d5
--- /dev/null
+++ b/src/MTools/Comp/MWritable.pm
@@ -0,0 +1,276 @@
+package MTools::Comp::MWritable;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Le composant MWritable permet d'associer un comportement scritptible a un objet zinc
+# Le composant peut alors etre ecrit et l'ecriture effacee
+#
+# Parametres : 
+# 	* parent : objet parent des curves qui vont etre dessinee au cours de l'ecriture
+#	* src : objet source des evenements qui vont generer le dessin
+#	* button : bouton de la souris utilise pour genere la reco de geste
+#	* %options : table de hash permettant la configuration initiale des proprietes et de definir un objet clip ($options {clip}) 
+#	l'objet clip permet de contenir l'ecriture libre dans une zone.
+# Proprietes : 
+#	* color : couleur d'ecriture
+# 	* writing_mode : ('write' ou 'erase') permet de specifier le resultat de l'interaction sur l'objet source (ecriture ou effacement)
+# Evenements :
+#	* BEGIN_WRITE : Message emis lors d'un debut d'ecriture
+#	* WRITE : Message emis lors de l'ecriture
+#	* END_WRITE :Message emis lors d'une fin d'ecriture
+#	* ERASE : Message emis lors de l'effacement
+# Fonctions : 
+#	* begin_write : force un debut d'ecriture
+#	* write : force l'ecriture
+#	* end_write : force une fin d'ecriture
+#	* erase : force un effacement
+
+
+use strict;
+use MTools;
+use MTools::MObjet;
+use MTools::GUI::MClip;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MGroup/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, $parent, $src, $button, %options) = @_;
+	my $self = new MTools::MGroup ($parent);
+	bless $self, $class;
+	if (defined $options {clip})
+	{
+		$self -> {__clip} = new MTools::GUI::MClip (
+			$self,
+			$options {clip},
+		);
+	}
+	delete $options {clip};
+	$self -> mconfigure (-atomic => 1);
+	$self -> recordProperty ('color', '#000000');
+	$self -> recordProperty ('writing_mode', 'write');
+	$self -> recordEvent ('BEGIN_WRITE');
+	$self -> recordEvent ('END_WRITE');
+	$self -> recordEvent ('WRITE');
+	$self -> recordEvent ('ERASE');
+	$button = 1 if ! defined $button;
+	binding ($src, "<Button-$button>", [\&__beginWrite, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($src, "<Button$button-Motion>", [\&__writing, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($src, "<ButtonRelease-$button>", [\&__endWrite, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($self, "<Button-$button>", [\&__beginWrite, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($self, "<Button$button-Motion>", [\&__writing, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($self, "<ButtonRelease-$button>", [\&__endWrite, $self, Ev('x'), Ev('y'), Ev('t')]);
+	$self -> {__curves} = ();
+	$self -> {__points} = ();
+	$self -> {__current_curves} = ();
+	$self -> {__tmp_curves} = new MTools::MGroup ($self);
+	return $self;
+}
+
+sub __beginWrite {
+	my ($self, $x, $y) = @_;
+	($x, $y) = $zinc -> transform ('device', minstance ($self), [$x, $y]);
+	$self -> beginWrite ($x, $y);
+	$self -> notify ('BEGIN_WRITE', $x, $y)
+}
+
+sub beginWrite {	
+	my ($self, $x, $y) = @_;
+	push (@{$self -> {__old_coords}}, ($x, $y));
+}
+
+sub __endWrite {
+	my ($self, $x, $y) = @_;
+	if ($self -> mget ('writing_mode') eq 'write')
+	{
+		($x, $y) = $zinc -> transform ('device', minstance ($self), [$x, $y]);
+		$self -> writing ($x, $y);
+		$self -> notify ('WRITE', $x, $y);
+		$self -> notify ('END_WRITE');
+		$self -> endWrite ();
+	}
+	else
+	{
+		$self -> {__old_coords} = ();
+	}
+}
+
+sub endWrite {
+	my ($self) = @_;
+	if (defined $self -> {__points} && @{$self -> {__points}})
+	{
+		my @points = @{$self -> {__points}};
+		push (@{$self -> {__curves}}, $zinc -> add (
+				'curve', 
+				minstance ($self), 
+				[@points],
+				-linecolor => $self -> mget ('color'),
+				-linewidth => 1,
+				-priority  => 2,
+				-visible   => 1,
+				-sensitive => 0
+			)
+		);
+		$self -> {__points} = ();
+		$self -> {__tmp_curves} -> mdelete ();
+		$self -> {__tmp_curves} = new MTools::MGroup ($self);
+	}
+	$self -> {__old_coords} = ();
+}
+
+sub __writing {
+	my ($self, $x, $y) = @_;
+	if ($self -> mget ('writing_mode') eq 'write')
+	{
+		($x, $y) = $zinc -> transform ('device', minstance ($self), [$x, $y]);
+		$self -> writing ($x, $y);
+		$self -> notify ('WRITE', $x, $y)
+	}
+	else
+	{
+		erase ($self, $x, $y);
+	}
+}
+
+
+sub writing {
+	my ($self, $x, $y) = @_;
+  	$self -> write ($x, $y);
+}
+
+sub write {
+	my ($self, $x, $y) = @_;
+	my @coords;
+  	push (@{$self -> {__old_coords}}, ($x, $y));
+	my $list_size = @{$self -> {__old_coords}};
+	if ($list_size >= 6) 
+	{
+    	my $x1 = $self -> {__old_coords} -> [$list_size - 6];
+		my $y1 = $self -> {__old_coords} -> [$list_size - 5];
+		my $x2 = $self -> {__old_coords} -> [$list_size - 4];
+		my $y2 = $self -> {__old_coords} -> [$list_size - 3];
+		my $x3 = $self -> {__old_coords} -> [$list_size - 2];
+		my $y3 = $self -> {__old_coords} -> [$list_size - 1];
+		my $cx2 = ($x1 - $x3) * 0.2  + $x2;
+		my $cy2 = ($y1 - $y3) * 0.2  + $y2;
+		if ($list_size == 6) 
+		{
+			@coords = ([$x1,$y1],[$cx2,$cy2,'c'],[$x2,$y2]);
+		}
+    	else 
+    	{
+			my $cx1 = ($x2 - $self -> {__old_coords} -> [$list_size - 8]) * 0.2 + $x1;
+			my $cy1 = ($y2 - $self -> {__old_coords} -> [$list_size - 7]) * 0.2 + $y1;
+			@coords = ([$x1, $y1], [$cx1, $cy1, 'c'], [$cx2, $cy2, 'c'], [$x2, $y2]);
+		}
+		push (@{$self -> {__points}}, @coords);
+		push (@{$self -> {__current_curves}}, $zinc -> add (
+				'curve', 
+				minstance ($self -> {__tmp_curves}), 
+				[@coords],
+				-linecolor => $self -> mget ('color'),
+				-linewidth => 1,
+				-priority  => 2,
+				-visible   => 1,
+				-sensitive => 0
+			)
+		);
+	}
+}
+
+my $k = 5;
+sub erase {
+	my ($self, $x, $y) = @_;
+	($x, $y) = $zinc -> transform ('device', minstance ($self), [$x, $y]);
+	if (defined $self -> {__curves})
+	{
+		my @curves = @{$self -> {__curves}};
+		for (my $i = @curves - 1; $i >= 0 ; $i --)
+		{
+			my @points = $zinc -> coords ($curves [$i], 0);
+			for (my $j = 0; $j < @points - 1; $j ++)
+			{
+				my $pt1 = $points [$j];
+				my $pt2 = $points [$j + 1];
+				
+				if ($pt1 -> [0] == $pt2 -> [0])
+				{
+					if (in ($y, $pt1 -> [1], $pt2 -> [1]) && ( abs ($pt1 -> [0] - $x) <= $k))
+					{
+						$self -> __deleteCurve ($i);
+						last;
+					}
+				}
+				else
+				{
+					my $a = ($pt1 -> [1] - $pt2 -> [1]) / ($pt1 -> [0] - $pt2 -> [0]);
+					my $b = $pt2 -> [1] - $a * $pt2 -> [0];
+					my $ar = ($a ** 2 + 1);
+					my $br = (2 * $a * ($b - $y) - 2 * $x);
+					my $cr = ($x ** 2 + ($b - $y) ** 2 - $k ** 2);
+					my $d = $br ** 2 - 4 * $ar * $cr;
+					if ($d >= 0)
+					{
+						if (mdist ($pt1 -> [0], $pt1 -> [1], $x ,$y) || mdist ($pt2 -> [0], $pt2 -> [1], $x ,$y))
+						{
+							$self -> __deleteCurve ($i);
+							last;
+						}
+						my $x1 = (-$br + sqrt ($d)) / (2 * $ar);
+						my $x2 = (-$br - sqrt ($d)) / (2 * $ar);
+						if (in ($x1, $pt1 -> [0], $pt2 -> [0]) || in ($x2, $pt1 -> [0], $pt2 -> [0]))
+						{
+							$self -> __deleteCurve ($i);
+							last;
+						}
+					}
+				}
+			}
+		}
+	}
+}
+
+sub __deleteCurve {
+	my ($self, $index) = @_;
+	$self -> notify ('ERASE', $index);
+	$self -> deleteCurve ($index);
+}
+
+sub deleteCurve {
+	my ($self, $index) = @_;
+	$self -> {__old_coords} = ();
+	mdelete ($self -> {__curves} [$index]);
+	splice (@{$self -> {__curves}}, $index, 1);
+}
+
+sub in {
+	my ($x, $x0, $x1) = @_;
+	return (($x0 <= $x) && ($x <= $x1) || ($x1 <= $x) && ($x <= $x0));
+}
+
+sub mdist {
+	my ($x1, $y1, $x2, $y2) = @_;
+	return (($x1 - $x2) ** 2 + ($y1 - $y2) ** 2 <= ($k) ** 2);
+}
+
+1;
diff --git a/src/MTools/GUI/MAntiRecouvrementGroup.pm b/src/MTools/GUI/MAntiRecouvrementGroup.pm
new file mode 100644
index 0000000..4e8dbc7
--- /dev/null
+++ b/src/MTools/GUI/MAntiRecouvrementGroup.pm
@@ -0,0 +1,191 @@
+package MTools::GUI::MAntiRecouvrementGroup;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+
+# Les objets heritant de MAntiRecouvrementGroup peuvent etre geres par un objet MAntiRecouvrement et ainsi pris en charge
+# par un algorithme d'anti-recouvrement.
+#
+# parametres :
+#	* $parent : parent de l'objet...
+#	* %options : table de hash permettant d'initialiser les proprietes
+# Les ?v?nements :
+#	* TRANSLATED : notifie lorsque l'objet est translate...
+# attibuts : 
+#	followed_by : MAntiRecouvrementGroup permet aux objets contenus dans ce tableau de suivre ses deplacements 
+#	(permet un chainage des objets)
+# Les propietes :
+#	* xmin, ymin, xmax, ymax : definissent les caract?risiques de l'espace dans lequel l'objet est contraint.
+#	* height, width : definissent la base rectangulaire de l'objet
+#	* auto_sizing : si width ou height ne sont pas pass?s en param?tre, les caracteristiques 
+#	sont auto-determinees en fonction de la bbox de l'objet. On peut bien evidemment choisir cette definition automatique, cependant
+#	attention, la bbox de l'objet ne correspond par toujours a la bbox visible de l'objet.
+#	* x, y : determinent la position de l'objet et sont mis a jour automatiquement au cours des deplacement de l'objet.
+# 	* anchors : permet d'active ou ne le suivi des objets contenus dans 'followed_by'
+# Les fonctions :
+#	* update_bbox : permet de demander une remise ? jour du calcul automatique des dimensions de l'objet (util uniquement si auto_sizing == 1)
+
+use MTools;
+
+use vars qw /@ISA/;
+
+
+use MTools::MGroup;
+require Exporter;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MGroup Exporter/;
+	@EXPORT = qw / translate scale rotate /;
+}
+
+use strict;
+use Tk;
+
+sub new {
+	my ($class, $parent, %options) = @_;
+	my $self = new MTools::MGroup ($parent);
+	bless $self, $class;
+
+	$self -> recordEvent ('TRANSLATED');	
+	$self -> recordProperty ('auto_sizing', (!defined $options{width}) || (!defined $options{height}));
+	$self -> recordProperty ('height', 0);
+	$self -> recordProperty ('width', 0);
+	$self -> recordProperty ('x', 0);
+	$self -> recordProperty ('y', 0);
+	$self -> recordProperty ('xmin', 0);
+	$self -> recordProperty ('ymin', 0);
+	$self -> recordProperty ('xmax', 1500);
+	$self -> recordProperty ('ymax', 1500);
+	$self -> recordProperty ('anchors', 1);
+	
+	$self -> recordEvent ('__HANDLE_MOVING');
+	$self -> recordEvent ('__PUSH_BACK');
+	$self -> recordEvent ('__ENQUEUE_MOVING');
+
+	$self -> mconfigure (%options);
+	return $self;
+}
+
+sub translate {
+	my ($self, $delta_x, $delta_y) = @_;
+	if ($self -> {__added})
+	{
+		if ((abs ($delta_x) >= $self -> mget ('width') / 2) or (abs ($delta_y) >= $self -> mget ('height') / 2)) 
+		{
+	    	my ($mini_dx, $mini_dy) = (int ($delta_x / 2), int ($delta_y / 2));
+			$self -> translate ($mini_dx, $mini_dy);
+			$self -> translate ($delta_x - $mini_dx, $delta_y - $mini_dy);
+		}
+		else 
+		{
+			$self -> __try_move ($delta_x, $delta_y, []);
+			$self -> notify ('__HANDLE_MOVING');
+		}
+	}
+	else
+	{
+		$self -> __update_xy ($delta_x, $delta_y);
+	}
+}
+
+sub __search {
+	my ($val, @tab) = @_;
+	my $result = 0;
+	if (($#tab != -1) and (defined $val)) 
+	{
+		foreach (@tab) 
+		{
+			if (($_ eq $val) or ($_ =~ m/$val/)) 
+			{
+				$result = 1;
+				last;
+			}
+		}
+	}
+	return $result;
+}
+
+sub __try_move {
+	my ($self, $delta_x, $delta_y, $path) = @_;
+	return if __search ($self, @{$path});
+	push (@{$path},	$self);
+	$self -> __update_xy ($delta_x, $delta_y);
+
+	my $label_coords_x = $self -> mget ('x');
+	my $label_coords_y = $self -> mget ('y');
+	my $x_min = $self -> mget ('xmin');
+	my $x_max = $self -> mget ('xmax');
+	my $y_min = $self -> mget ('ymin');
+	my $y_max = $self -> mget ('ymax');
+	
+	my ($push_x, $push_y) = (0, 0);
+	$push_x = $x_min - $label_coords_x if $label_coords_x < $x_min;
+	$push_x = $x_max - $label_coords_x if $label_coords_x > $x_max;
+	$push_y = $y_min - $label_coords_y if $label_coords_y < $y_min;
+	$push_y = $y_max - $label_coords_y if $label_coords_y > $y_max;
+	$self -> notify ('__PUSH_BACK', $self, $push_x, $push_y, $path) if (($push_x != 0) or ($push_y != 0));
+	
+	if ($self -> mget ('anchors')) 
+	{
+		if (defined $self -> {followed_by})
+		{
+	    	foreach (@{$self -> {followed_by}}) 
+	    	{
+				$_ -> __try_move($delta_x + $push_x, $delta_y + $push_y, $path);
+	    	}
+		}
+	}
+	
+	my @other_path = @{$path};
+	$self -> notify ('__ENQUEUE_MOVING', $self, $delta_x + $push_x, $delta_y + $push_y, [@other_path]);
+	pop @{$path};
+}
+
+sub __update_xy {
+	my ($self, $delta_x, $delta_y) = @_;
+	MTools::translate ($self, $delta_x, $delta_y);
+	$self -> mconfigure ('x' => $self -> mget ('x') + $delta_x);
+	$self -> mconfigure ('y' => $self -> mget ('y') + $delta_y);
+	$self -> notify ('TRANSLATED', $delta_x, $delta_y);
+}
+
+sub scale {
+	my ($self, @params) = @_;
+	MTools::scale ($self, @params);
+	$self -> update_bbox ();
+	$self -> translate (0, 0);
+}
+
+sub rotate {
+	my ($self, @params) = @_;
+	MTools::rotate ($self, @params);
+	$self -> update_bbox ();
+	$self -> translate (0, 0);
+}
+
+sub update_bbox {
+	my ($self) = @_;
+	if ($self -> mget ('auto_sizing'))
+	{
+		my @rect = $self -> bbox ();
+		$self -> mconfigure (width => $rect [2] - $rect [0]);
+		$self -> mconfigure (height => $rect [3] - $rect [1]);
+	}
+}
+
+1;
diff --git a/src/MTools/GUI/MCircle.pm b/src/MTools/GUI/MCircle.pm
new file mode 100644
index 0000000..35463ef
--- /dev/null
+++ b/src/MTools/GUI/MCircle.pm
@@ -0,0 +1,51 @@
+package MTools::GUI::MCircle;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Encapsule la creation d'un cercle
+# Parametres : 
+# 	* parent : pere de l'objet.
+# 	* x, y : coordonnees du centre du cercle
+#	* r : rayon du cercle
+#	* %options : table de hash pass?e en parametre de la cr?ation de l'objet zinc arc
+
+use strict;
+
+use MTools;
+use MTools::MObjet;
+use vars qw / @ISA /;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+sub new {
+	my ($class, $parent, $x, $y, $r, %options) = @_;
+	my $self = {};
+	bless $self, $class;
+	$self -> {instance} = $zinc -> add('arc', 
+		ref ($parent) eq '' ? $parent : $parent -> {instance}, 
+		[$x - $r, $y - $r, $x + $r, $y + $r],
+		-pieslice => 0,
+		-priority => 10,
+		%options,
+	);
+	return $self;
+}
+
+1;
diff --git a/src/MTools/GUI/MClip.pm b/src/MTools/GUI/MClip.pm
new file mode 100644
index 0000000..248e395
--- /dev/null
+++ b/src/MTools/GUI/MClip.pm
@@ -0,0 +1,90 @@
+package MTools::GUI::MClip;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Encapsule le clipping d'un objet
+# Parametres : 
+# 	* clipped : group zinc clippe
+#	* path : description de l'objet clippant
+#		- soit une descrition sous forme [_type, _coords] creant un objet zinc de type _type et de coordonnees _coords
+#		- soit un objet existant qui prendra pour p?re le group $clipped.
+
+use strict;
+
+use MTools;
+use MTools::MObjet;
+use vars qw / @ISA /;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+sub new {
+	my ($class, $clipped, $path, $debug) = @_;
+	my $self = {};
+	bless $self, $class;
+
+	if (!defined $debug) {$debug = 0}
+	
+	my $clip = $path;
+	if(ref ($path) eq 'ARRAY')
+	{
+		my $type = shift @{$path};
+		$clip = $zinc -> add ($type, $clipped -> {instance}, $path, 
+			-filled => 1, 
+			-priority => 10,
+			-linewidth => 0,
+			-fillcolor => "#000000",
+			-visible => $debug,
+			-sensitive => 0,
+		);
+	}
+	elsif(ref ($path) eq '')
+	{
+		$clip = minstance ($clip, $clipped);
+		MTools::chggroup ($clip, $clipped);
+		MTools::mconfigure  ($clip, -visible => $debug, -sensitive => 0);
+	}
+	else
+	{
+		MTools::chggroup ($clip, $clipped);
+		MTools::mconfigure (-visible => $debug, -sensitive => 0);
+		$clip = minstance ($clip);
+	}
+	$self -> {__clipped} = $clipped;
+	$self -> {__clip} = $clip;
+	mconfigure ($clipped, -clip => $clip);
+	return $self;
+}
+
+sub translate {
+	my ($self, @args) = @_;
+	MTools::translate ($self -> {__clip}, @args);
+}
+
+sub scale {
+	my ($self, @args) = @_;
+	MTools::scale ($self -> {__clip}, @args);
+}
+
+sub rotate {
+	my ($self, @args) = @_;
+	MTools::rotate ($self -> {__clip}, @args);
+}
+
+1;
diff --git a/src/MTools/GUI/MCurve.pm b/src/MTools/GUI/MCurve.pm
new file mode 100644
index 0000000..3458e49
--- /dev/null
+++ b/src/MTools/GUI/MCurve.pm
@@ -0,0 +1,54 @@
+package MTools::GUI::MCurve;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Encapsule la creation d'une curve
+# Parametres : 
+# 	* parent : pere de l'objet.
+# 	* coords : coordonnees de la curve (cf. format zinc)
+#	* %options : table de hash pass?e en param?tre de la creation de l'objet zinc curve
+
+
+use strict;
+
+use MTools;
+use MTools::MObjet;
+use vars qw / @ISA /;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+sub new {
+	my ($class, $parent, $coords, %options) = @_;
+	my $self = {};
+	bless $self, $class;
+	$self -> {instance} = $zinc -> add('curve', 
+		ref ($parent) eq '' ? $parent : $parent -> {instance}, 
+		$coords,
+		-priority => 10,
+		-visible => 1,
+		-filled => 0,
+		-linecolor => 'black',
+		-linewidth => 1,
+		%options,
+	);
+	return $self;
+}
+
+1;
diff --git a/src/MTools/GUI/MImage.pm b/src/MTools/GUI/MImage.pm
new file mode 100644
index 0000000..94a20b6
--- /dev/null
+++ b/src/MTools/GUI/MImage.pm
@@ -0,0 +1,69 @@
+package MTools::GUI::MImage;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Encapsule la creation d'une image
+# Parametres : 
+# 	* parent : pere de l'objet.
+# 	* image : nom de l'image
+#	* %options : table de hash passee en parametre de la creation de l'objet zinc icon
+
+
+use strict;
+
+use MTools;
+use MTools::MObjet;
+use vars qw / @ISA /;
+
+use Tk::PNG;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+sub new {
+	my ($class, $parent, $image, %options) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+	
+	my $image = __getImage ($zinc, $image);
+	$self -> {instance}  = $zinc -> add('icon', minstance ($parent),
+		-priority => 10,
+		-image => $image,
+		-composealpha => 1,
+		%options
+	);
+	return $self;
+}
+
+
+sub __getImage {
+	my ($widget, $imagefile) = @_;
+	my $image;
+	if (index ($imagefile, '.png') != -1)
+	{
+		$image = $widget -> Photo(-file => Tk::findINC($imagefile), -format => 'png');
+	}
+	else
+	{
+		$image = $widget -> Photo(-file => Tk::findINC($imagefile));
+	}
+    return $image;
+}
+
+1;
diff --git a/src/MTools/GUI/MRect.pm b/src/MTools/GUI/MRect.pm
new file mode 100644
index 0000000..e28b044
--- /dev/null
+++ b/src/MTools/GUI/MRect.pm
@@ -0,0 +1,54 @@
+package MTools::GUI::MRect;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Encapsule la creation d'un rectangle
+# Parametres : 
+# 	* parent : pere de l'objet.
+# 	* x, y : de l'angle en haut a gauche du rectangle
+#	* w, h : largeur et hauteur du rectangle
+#	* %options : table de hash passee en parametre de la creation de l'objet zinc rectangle
+
+
+use strict;
+
+use MTools;
+use MTools::MObjet;
+use vars qw / @ISA /;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+sub new {
+	my ($class, $parent, $x, $y, $w, $h, %options) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+	if ((defined $options {-fillcolor}) && (!defined $options {-filled})) 
+	{
+		$options{-filled} = 1;
+	}
+	$self -> {instance} = $zinc -> add ('rectangle', 
+		minstance ($parent), 
+		[$x, $y, $x + $w, $y + $h],
+		%options,
+	);
+	return $self;
+}
+
+1;
diff --git a/src/MTools/GUI/MText.pm b/src/MTools/GUI/MText.pm
new file mode 100644
index 0000000..71d99ec
--- /dev/null
+++ b/src/MTools/GUI/MText.pm
@@ -0,0 +1,54 @@
+package MTools::GUI::MText;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Encapsule la creation d'un text
+# Parametres : 
+# 	* parent : pere de l'objet.
+#	* text : text !
+# 	* x, y : coordonnees de l'emplacement de l'objet
+#	* %options : table de hash passee en parametre de la creation de l'objet zinc text
+
+
+use strict;
+
+use MTools;
+use MTools::MObjet;
+use vars qw / @ISA /;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+sub new {
+	my ($class, $parent, $text, $x, $y, %options) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+	if (!defined $x) {$x = 0;}
+	if (!defined $y) {$y = 0;}
+	if (!defined $text) {$text = "";}
+	$self -> {instance} = $zinc -> add ('text', 
+		minstance ($parent), 
+		-text => $text,
+		%options,
+	);
+	$self -> translate ($x, $y);
+	return $self;
+}
+
+1;
diff --git a/src/MTools/GUI/MTexture.pm b/src/MTools/GUI/MTexture.pm
new file mode 100644
index 0000000..f3dff9e
--- /dev/null
+++ b/src/MTools/GUI/MTexture.pm
@@ -0,0 +1,75 @@
+package MTools::GUI::MTexture;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Permet d'appliquer un texture a un objet
+# Parametres : 
+# 	* parent : pere de l'objet.
+#	* target : group zinc destine a contenir les images de texture
+# 	* image_name : nom de l'image texture
+
+use strict;
+
+use MTools;
+use MTools::MGroup;
+use MTools::GUI::MImage;
+
+use vars qw / @ISA /;
+
+
+BEGIN 
+{
+	@ISA = qw /MTools::MGroup/;
+}
+
+sub new {
+	my ($class, $parent, $target, $image_name) = @_;
+	my $self = new MTools::MGroup ($parent);
+	bless $self, $class;
+	
+	chggroup ($target, $self);
+	
+	my $image = new MTools::GUI::MImage ($self, $image_name);
+	
+	my @bb = bbox ($image);
+	my $img_w = $bb [2] - $bb [0];
+	my $img_h = $bb [3] - $bb [1];
+	
+	my @bb = bbox ($target);
+	my $w = $bb [2] - $bb [0];
+	my $h = $bb [3] - $bb [1];
+	
+	mdelete ($image);
+	
+	for (my $x = 0; $x < $w; $x += $img_w)
+	{
+		for (my $y = 0; $y < $h; $y += $img_h)
+		{
+				$image = new MTools::GUI::MImage ($self, $image_name);
+				$image -> translate ($x + $bb [0], $y + $bb [1]);
+		}
+	}
+	
+	my $clip = $zinc -> clone ($target);
+	mconfigure ($clip, -visible => 0);
+	new MTools::GUI::MClip ($self, $clip);
+	return $self;
+}
+
+
+
+1;
diff --git a/src/MTools/MGroup.pm b/src/MTools/MGroup.pm
new file mode 100644
index 0000000..fb00925
--- /dev/null
+++ b/src/MTools/MGroup.pm
@@ -0,0 +1,41 @@
+package MTools::MGroup;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# L'objet MTools::MGroup encapsule la cr?ation d'un objet group zinc en toute rigueur il aurait d? ?tre plac? dans MTools::GUI
+
+use strict;
+
+use MTools;
+use MTools::MObjet;
+use vars qw / @ISA /;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+sub new {
+	my ($class, $parent, %options) = @_;
+	my $self = {};
+	bless $self, $class;
+	$parent = ref($parent) eq ''?$parent:$parent -> {instance};
+	$self -> {instance} = $zinc -> add ('group', $parent, -priority => 10, %options);
+	return $self;
+}
+
+1;
diff --git a/src/MTools/MIvy.pm b/src/MTools/MIvy.pm
new file mode 100644
index 0000000..9ade88f
--- /dev/null
+++ b/src/MTools/MIvy.pm
@@ -0,0 +1,75 @@
+package MTools::MIvy;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+
+# Le composant MIvy encapsule la declaration et l'utilisation d'un bus ivy.
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use vars qw /@ISA/;
+
+our $ivy_instance = undef;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, $adresse, $ivy_name) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+	if (!defined $ivy_instance)
+	{
+		Ivy -> init(
+			-ivyBus => $adresse,
+			-appName => $ivy_name,
+			-loopMode => 'TK',
+			-messWhenReady => 'READY',
+		);
+		$self -> {__ivy} = Ivy -> new ();
+		$self -> {__ivy} -> start ();
+		$ivy_instance = $self -> {__ivy};
+	}
+	else
+	{
+		$self -> {__ivy} = $ivy_instance;
+	}
+	return $self;
+}
+
+
+sub binding {
+	my ($self, $reg, $cb) = @_;
+	if (ref ($cb) ne 'ARRAY')
+	{
+		$cb = [$cb];
+	}
+	$self -> {__ivy} -> bindRegexp ($reg, $cb);
+}
+
+sub sendMsgs {
+	my ($self, $msgs) = @_;
+	$self -> {__ivy} -> sendMsgs ($msgs);
+}
+
+1;
diff --git a/src/MTools/MObjet.pm b/src/MTools/MObjet.pm
new file mode 100644
index 0000000..b35c07f
--- /dev/null
+++ b/src/MTools/MObjet.pm
@@ -0,0 +1,128 @@
+package MTools::MObjet;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Le composant MObject est l'objet racine des composants MTools. 
+# Il defini les fonctions applicables uniquement aux objets MTools. 
+#
+# IMPORTANT : Une autre partie des fonctions applicables aux objets MTools est definie dans la classe MTools. 
+# La difference entre ces deux classes de fonctions est que les fonctions definies dans MTools sont egalement
+# applicables ? des objets zinc tandis que les fonctions definies ici ne peuvent etre appliquees que a des objets heritant de MTools::MObjet.
+#
+# Concepts :
+#	* Objet MTools : objet heritant de MObjet
+#	* Les PROPERTY :  Les proprietes sont des attributs particuliers et modifiables
+#	par un appel a "mconfigure". Elles peuvent etre ecoutees et synchronisees avec d'autres proprietes 
+#	MTools ou meme zinc ! (cf MTools::plink et MTools::plisten). En consequence elles sont la pour engendrer un comportement 
+#	consecutif ? leur modification et doivent etre distinguees des attibuts qui peuvent se contenter d'etre ds clef de hash de l'objet.
+#	* Les EVENT : les evenements peuvent etre emis par n'importe quel objet MTools et capter par un binding.
+#
+# Les fonctions public :
+# 	* recordEvent : permet de permettre a un objet MObjet d'emettre un evenement.
+# 	* recordProperty : permet de declarer et initialiser une propriete.
+# 	NOTA : Il pourrait manquer une declaration collective des proprietes. Initialement, 
+#	celle-ci n'a pas ete effectuee pour essayer de limiter l'usage des proprietes 
+#	et ne pas les utiliser comme des attributs. 
+#	* notify : permet a un objet MTools de notifier un evenement prealablement enregistre par recordEvent
+#	* propagate : permet a un objet de propager un evenement emis par un autre objet 
+#	(correspond a un recordEvent puis un binding sur un evenement d'un objet effectuant le notify du meme evt 
+#	depuis l'objet declarant la propagation)
+
+use strict;
+use MTools;
+use vars qw /@ISA @EXPORT @EXPORT_OK/;
+
+BEGIN 
+{
+	@ISA = qw //;
+}
+
+sub new {
+	my ($class) = @_;
+	my $self = {};
+	$self -> {instance} = -1;
+	bless $self, $class;
+	return $self;
+}
+
+sub recordEvent {
+	my ($self, $event) = @_;
+	if (!(defined $self -> {__events} -> {$event}))
+	{
+		$self -> {__events} -> {$event} = [];
+	}
+}
+
+sub recordProperty {
+	my ($self, $prop, $val) = @_;
+	$self -> {__properties} -> {$prop} -> {val} = $val;
+}
+
+sub notify {
+	my ($self, $event, @params) = @_;
+	if (!defined $self -> {__events} -> {$event})
+	{
+		print "ERREUR $self : Vous essayer de notifier l'evenement $event qui n'est pas declare\n";
+		return;
+	}
+	my @tb = @{$self -> {__events} -> {$event}};
+	for (my $i = 0; $i < @tb; $i++)
+	{
+		executer ($tb[$i], @params);
+	}
+}
+
+sub propagate {
+	my ($self, $from, $event, @nargs) = @_;
+	$self -> recordEvent ($event);
+	$from -> __addListener ($event, 
+		sub { 
+			my (@args) = @_; 
+			$self -> notify  ($event, @args, @nargs);
+		}
+	);
+}
+
+sub __addListener {
+	my ($self, $event, $methode) = @_;
+	if (defined $self -> {__events} -> {$event})
+	{
+		push (@{$self -> {__events} -> {$event}}, $methode);
+		return $methode;
+	}
+	else
+	{
+		print "ERREUR : l'objet $self n'?met jamais l'evt $event... L'abonnement est donc inutile\n";
+	}
+}
+
+sub __removeListener {
+	my ($self, $event, $methode) = @_;
+	if (defined $self -> {__events} -> {$event})
+	{
+		my @events = @{$self -> {__events} -> {$event}};
+		for (my $i = @events - 1; $i >= 0; $i--) 
+		{
+			if ($events [$i] == $methode) 
+			{
+				splice (@{$self -> {__events} -> {$event}}, $i, 1);
+			}
+		}
+	}
+}
+
+1;
diff --git a/src/MTools/MState.pm b/src/MTools/MState.pm
new file mode 100644
index 0000000..bf7b9d4
--- /dev/null
+++ b/src/MTools/MState.pm
@@ -0,0 +1,149 @@
+package MTools::MState;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+use strict;
+use MTools;
+use MTools::MObjet;
+use MTools::SVG::SVGLoader;
+
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+sub new {
+	my ($class, %options) = @_;
+	my $self = {};
+	bless $self, $class;
+	$self -> {instance} = -1;
+	my %events = %{$options {events}};
+	$self -> {__transitions} =  $options {transitions};
+	my %transitions = %{$self -> {__transitions}};
+	
+	$self -> recordProperty ('state', $options {current_state});
+	
+	$self -> recordEvent('SET_STATE');
+	
+	# Cr?er les bind soit aupr?s de zinc, soit au niveau des objets MObjet
+	while ( my ($evt, $desc) = each (%events) )
+	{
+		my ($src, $spec) = @{$desc};
+		if ($spec =~ /<(.*)>/)
+		{
+			binding ($src, $spec, sub {$self -> evt ($evt, @_); });
+		}
+		else
+		{
+			$src -> binding ($spec, sub {$self -> evt ($evt, @_); });
+		}		
+	}
+	
+	# Abonne les switchs ecoutant les changements d'etat
+	my $sws = $options {switchs};
+	if (defined $sws)
+	{
+		my @abonnes;
+		if (ref ($sws) eq 'ARRAY')
+		{
+			@abonnes = @{$sws};
+		}
+		else
+		{
+			$abonnes [0] = $sws;
+		}
+		for (my $i = 0; $i < @abonnes; $i++)
+		{
+			$self -> binding ('SET_STATE', [$abonnes [$i], 'setState']);
+		}
+		$self -> notify ('SET_STATE', $self -> mget ('state'));
+	}
+	
+	# Enregistre les outputs
+	while ( my ($src, $trans) = each (%transitions) )
+	{
+		my %trs = %{$trans};
+		while ( my ($evt, $desc) = each (%trs) )
+		{
+			if (defined $desc -> {notify})
+			{
+				my @evts;
+				if (ref ($desc -> {notify}) eq 'ARRAY')
+				{
+					@evts = @{$desc -> {notify}};
+				}
+				else
+				{
+					$evts [0] = $desc -> {notify};
+				}
+				for (my $i = 0; $i < @evts; $i++)
+				{
+					$self -> recordEvent($evts [$i]);
+				}
+			}
+		}
+	}
+	
+	return $self;
+}
+
+sub evt {
+	my ($self, $evt, @args) = @_;
+	if (defined $self -> {__transitions} -> {$self -> mget ('state')} -> {$evt})
+	{
+		my $trans = $self -> {__transitions} -> {$self -> mget ('state')} -> {$evt};
+		if( defined $trans -> {do_before} )
+		{
+			executer ($trans -> {do_before}, @args);
+		}
+		if( defined $trans -> {to} )
+		{
+			$self -> mconfigure ('state', $self -> {__transitions} -> {$self -> mget ('state')} -> {$evt} -> {to});
+			$self -> notify ('SET_STATE', $self -> mget ('state'));
+		}
+		if( defined $trans -> {do_after} )
+		{
+			executer ($trans -> {do_after}, @args);
+		}
+		if( defined $trans -> {notify} )
+		{
+			my @evts;
+			if (ref ($trans -> {notify}) eq 'ARRAY')
+			{
+				@evts = @{$trans -> {notify}};
+			}
+			else
+			{
+				$evts [0] = $trans -> {notify};
+			}
+			for (my $i = 0; $i < @evts; $i++)
+			{
+				$self -> notify ($evts [$i], @args);
+			}
+		}
+	}
+}
+
+sub setState {
+	print "################## MTools::MState TODO\n";
+}
+
+1;
+	
diff --git a/src/MTools/MSwitch.pm b/src/MTools/MSwitch.pm
new file mode 100644
index 0000000..8933ca3
--- /dev/null
+++ b/src/MTools/MSwitch.pm
@@ -0,0 +1,201 @@
+package MTools::MSwitch;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Le composant MSwitch permet de mat?rialiser et contr?ler des "?tat" actif de l'application. 
+# Le principe est d'associer des composants (graphiques, abstraits, comportements, objets complexes) ? un ?tat.
+# Le composant MSwitch contr?le un ?tat actif de l'application et g?re l'option "-visible" des composants associ?s ? l'?tat. 
+#
+# Les param?tres :
+# 	* $parent : parent de l'objet MSwitch
+#	* %etats : table de hash d?finissant les ?tats de l'application
+#		Ex :
+#			etat1 => [], # ?tat ne comportant aucun composant
+#			etat2 => 'fichier_svg.svg#tag_svg', # l'?tat va instancier un objet issu d'un fichier svg
+#			etat3 => ['fichier_svg.svg#tag_svg', $obj], # l'?tat va contenir deux objets: l'un instancier par le MSwitch l'autre d?j? cr?? pr?alablement
+# Les propi?t?s :
+#	* state : contr?le l'?tat actif du MSwitch
+#	* -visible : permettre de rendre le MSwitch visible ou invisible et en cons?quence de rendre 
+#	"visible ou invisible" les composants de l'?tat actif du switch
+# Les fonctions public :
+#	* setState : $switch -> setState ('etat') ?quivalent ? $swicth -> mconfigure (state => 'etat')
+
+use strict;
+use MTools;
+use MTools::MGroup;
+use MTools::SVG::SVGLoader;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MGroup/;
+}
+
+sub new {
+	my ($class, $parent, %etats) = @_;
+	my $self = new MTools::MGroup ($parent);
+	bless $self, $class;
+
+	$self -> recordProperty ('state', '');
+	$self -> recordProperty ('-visible', 1);
+	$self -> {__last} = '';
+	$self -> plisten ('state', [$self, '__setState']);
+
+	my $first = '';
+
+	while ( my ($etat, $val) = each (%etats) )
+	{
+		if ($first eq '')
+		{
+			$first = $etat;
+		}
+		my @tb;
+		if (ref ($val) eq 'ARRAY')
+		{
+			@tb = @{$val};
+		}
+		else
+		{
+			$tb[0] = $val;
+		}
+		
+		for (my $i = 0; $i < @tb; $i ++)
+		{
+			if ( !defined $self -> {"__instance_".$tb [$i]})
+			{
+				if ( ref ($tb [$i]) eq '')
+				{
+					$self -> {"__instance_".$tb [$i]} = minstance ($tb [$i], $self);
+					MTools::mconfigure ($self -> {"__instance_".$tb [$i]}, -visible => 0, -sensitive => 0);
+				}
+				else
+				{
+					$self -> {"__instance_".$tb [$i]} = $tb [$i];
+					$self -> {"__instance_".$tb [$i]} -> mconfigure ( -visible => 0, -sensitive => 0);
+				}
+				
+			}
+		}
+		
+		$self -> {"__etat_$etat"} = \@tb;
+	}
+	if ($first ne '')
+	{
+		$self -> mconfigure ('state' => $first);
+	}
+	return $self;
+}
+
+sub setState {
+	my ($self, $etat) = @_;
+	$self -> mconfigure ('state', $etat);
+}
+
+sub __setState {
+	my ($self, $src, $key, $etat) = @_;
+	my $curr = $self -> {__last};
+	$self -> {__last} = $etat;
+	if(!$self -> mget ('-visible'))
+	{
+		return;
+	}
+	if ($curr ne '')
+	{
+		if (defined $self -> {"__etat_".$curr})
+		{
+			my @tb = @{$self -> {"__etat_".$curr}};
+			for (my $i = 0; $i < @tb; $i ++)
+			{
+				if ( ref ($tb [$i]) eq '')
+				{
+					MTools::mconfigure ($self -> {"__instance_".$tb [$i]}, -visible => 0, -sensitive => 0);
+				}
+				else
+				{
+					$self -> {"__instance_".$tb [$i]} -> mconfigure (-visible => 0, -sensitive => 0);
+				}
+			}
+		}
+		else
+		{
+			die  "MTools::MSwitch::__setState : you are trying to set a unknown state \"$curr\"\n";
+		}
+	}
+	if (defined $self -> {"__etat_$etat"})
+	{
+		my @tb = @{$self -> {"__etat_$etat"}};
+		for (my $i = 0; $i < @tb; $i ++)
+		{
+			if ( ref ($tb [$i]) eq '')
+			{
+				MTools::mconfigure ($self -> {"__instance_".$tb [$i]}, -visible => 1, -sensitive => 1);
+			}
+			else
+			{
+				$self -> {"__instance_".$tb [$i]} -> mconfigure (-visible => 1, -sensitive => 1);
+			}
+			raise ($self -> {"__instance_".$tb [$i]});
+		}
+	}
+	else
+	{
+		if ($etat ne '')
+		{
+			die  "MTools::MSwitch::__setState : you are trying to set a unknown state \"$etat\"\n";
+		}
+	}
+}
+
+sub mconfigure {
+	my ($self, %options) = @_;
+	if (defined $options {-visible})
+	{
+		my $curr = ::mget ($self, 'state');
+		if ($curr ne '')
+		{
+			if (defined $self -> {"__etat_".$curr})
+			{
+				my @tb = @{$self -> {"__etat_".$curr}};
+				my $v = $options {-visible};
+				for (my $i = 0; $i < @tb; $i ++)
+				{
+					if ( ref ($tb [$i]) eq '')
+					{
+						MTools::mconfigure ($self -> {"__instance_".$tb [$i]}, -visible => $v, -sensitive => $v);
+					}
+					else
+					{
+						$self -> {"__instance_".$tb [$i]} -> mconfigure (-visible => $v, -sensitive => $v);
+					}
+					if ($v)
+					{
+						raise ($self -> {"__instance_".$tb [$i]});
+					}
+				}
+			}
+			else
+			{
+				die  "MTools::MSwitch::mconfigure : you are trying to set a unknown state \"$curr\"\n";
+			}
+		}
+	}
+	MTools::mconfigure ($self, %options);
+}
+
+
+1;
diff --git a/src/MTools/MTimer.pm b/src/MTools/MTimer.pm
new file mode 100644
index 0000000..68d1a00
--- /dev/null
+++ b/src/MTools/MTimer.pm
@@ -0,0 +1,104 @@
+package MTools::MTimer;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+# Le composant MTimer encapsule la d?claration et l'utilisation d'un timer.
+# Les param?tres :
+# 	* $timeout : repr?sente timeout en ms du timer (totologique ? non...)
+#	* $repeat : active ou non le caract?re r?p?titif du timer (valeur 0 ou 1)
+#	* $callback : est optionnel et permet d'appeler une callback au timeout.
+# Les ?v?nements :
+#	* TIME_OUT : ?mis au timeout en plus de l'appel ? une ?ventuelle callback
+#	* TIMER_STOPPED : ?mis si le timer est interrompu avant un timeout
+# Les propi?t?s :
+#	* timeout : ...
+#	* repeat : ...
+#	* callback : ...
+#	* -visible : d?finie pour assurer la compatibilit? avec les autres objets MTools. 
+# 	Si la valeur est 0 le composant est d?sactiv? (appel ? la fonction stop),
+#	si la valeur est 1 (appel ? la fonction start), le composant est activ?.
+#	Cette propri?t? permet notamment d'activer un timer dans un ?tat d'un MSwitch.
+# Les fonctions public :
+# 	* start permet de d?marrer le timer
+# 	* stop permet de stopper le timer
+#	Nota : cf. ci-dessus, ces fonctions peuvent ?tre contr?l?es par la propri?t? -visible
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+
+sub new {
+	my ($class, $timeout, $repeat, $callback, %options) = @_;
+	my $self = {};
+	bless $self, $class;
+	
+	$repeat = 0 if !defined $repeat;
+	$repeat = 0 if !defined $callback;
+	
+	$self -> recordEvent ('TIME_OUT');
+	$self -> recordEvent ('TIMER_STOPPED');
+	$self -> recordProperty ('timeout', $timeout);
+	$self -> recordProperty ('repeat', $repeat);
+	$self -> recordProperty ('callback', $callback);
+	$self -> recordProperty ('-visible', 0);
+	$self -> plisten ('-visible', sub { 
+		my ($src, $key, $val) = @_;
+		if ($val == 0)
+		{
+			$self -> stop ();
+		}
+		else
+		{
+			$self -> start ();
+		}
+	});
+	$self -> mconfigure (%options);
+
+	return $self;
+}
+
+sub start {
+	my ($self) = @_;
+	my $repeat = $self -> mget ('repeat');
+	my $timeout = $self -> mget ('timeout');
+	my $callback = $self -> mget ('callback');
+	my $function = $repeat ? 'repeat' : 'after';
+	$self -> {__timer} = $zinc -> $function ($timeout, sub {
+		$self -> notify ('TIME_OUT');
+		if ($callback)
+		{
+			executer ($callback);
+		}
+	});	
+}
+
+sub stop {
+	my ($self) = @_;
+	$zinc -> afterCancel ($self -> {__timer});
+	$self -> notify ('TIMER_STOPPED');
+}
+1;
diff --git a/src/MTools/SVG/SVGLoader.pm b/src/MTools/SVG/SVGLoader.pm
new file mode 100644
index 0000000..1aeafc7
--- /dev/null
+++ b/src/MTools/SVG/SVGLoader.pm
@@ -0,0 +1,87 @@
+#!/usr/bin/perl
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+package MTools::SVG::SVGLoader;
+
+use strict;
+use Carp;
+
+use MTools;
+use SVG::SVG2zinc;
+
+sub load {
+	my ($path, $topgroup) = @_;
+	$topgroup = ref($topgroup) eq ''?$topgroup:$topgroup -> {instance};
+	my $svgfile = $path;
+	my $tag;
+	my $ftag;
+	if (index($svgfile, '#') == -1)
+	{
+		$tag = '';
+		$ftag = '';
+	}
+	else
+	{
+		$svgfile = substr ($path, 0, index ($path, '#'));
+		$tag = substr ($path, index ($path, '#') + 1, length ($path));
+		$ftag = "::$tag";
+	}
+	
+	if($svgfile =~ /(.*)\.svg/)
+	{
+		my $filename = $1;
+		my $svgfile = Tk::findINC ("$filename.svg");
+		if (!defined $svgfile)
+		{
+			print STDERR "##### Error undefined file $filename.svg\n";
+		}
+		my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat($svgfile);
+		my ($dev2,$ino2,$mode2,$nlink2,$uid2,$gid2,$rdev2,$size2,$atime2,$mtime2,$ctime2,$blksize2,$blocks2) = (0,0,0,0,0,0,0,0,0,0,0,0,0);
+		my $filepath = 'AUTOGEN::'.$filename;		
+		$filepath = "$filepath$ftag.pm";
+		$filepath =~ s/::/\//g;
+		$filename =~ s/\//::/g;
+		if(-e $filepath)
+		{
+			($dev2,$ino2,$mode2,$nlink2,$uid2,$gid2,$rdev2,$size2,$atime2,$mtime2,$ctime2,$blksize2,$blocks2) = stat($filepath);
+		}
+		if( $mtime2 < $mtime )
+		{
+			print "Regenarate SVG modified\n";
+			my $pack = $filename;
+			SVG::SVG2zinc::parsefile(
+				$svgfile, 
+				"PerlClass",
+				-out => "AUTOGEN::$filename$ftag.pm",
+			  	-verbose => 0,
+			  	-render => 1,
+			  	-namespace => 0,
+				-target => $tag
+			);
+		}
+		require "$filepath";
+		my $packagename = "AUTOGEN::$filename$ftag";
+		return new $packagename (
+			-zinc => $zinc,
+			-topgroup => $topgroup,
+		);
+	}
+		
+}
+
+1;
diff --git a/src/MTools/Transform/MRotation.pm b/src/MTools/Transform/MRotation.pm
new file mode 100644
index 0000000..16b405a
--- /dev/null
+++ b/src/MTools/Transform/MRotation.pm
@@ -0,0 +1,76 @@
+package MTools::Transform::MRotation;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, $target, $angle, $x, $y) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+	
+	if (!defined $x) {$x = 0;}
+	if (!defined $y) {$y = 0;}
+	if (!defined $angle) {$angle = 0;}
+
+	$self -> recordProperty ('-visible', 0);
+	$self -> recordProperty ('target', $target);
+	$self -> recordProperty ('angle', $angle);
+	$self -> recordProperty ('x', $x);
+	$self -> recordProperty ('y', $y);
+	$self -> plisten ('-visible', sub { 
+		my ($src, $key, $val) = @_;
+		if ($val == 0)
+		{
+			$self -> __rotate (0);
+		}
+		else
+		{
+			$self -> __rotate ($self -> mget ('angle'));
+		}
+	});
+	$self -> plisten ('angle', sub { 
+		my ($src, $key, $val) = @_;
+		$self -> __rotate ($val);
+	});
+	$self -> {__current_angle} = 0;
+	$self -> __rotate ($angle);
+	return $self;
+}
+
+sub __rotate {
+	my ($self, $angle) = @_;
+	my $new_angle = $angle - $self -> {__current_angle};
+	$self -> {__current_angle} = $angle;
+	my $target = $self -> mget ('target');
+	my $x = $self -> mget ('x');
+	my $y = $self -> mget ('y');
+	$target -> rotate ($new_angle, 1, $x, $y);	
+}
+
+1;
diff --git a/src/MTools/Widget/MBouton.pm b/src/MTools/Widget/MBouton.pm
new file mode 100644
index 0000000..73c0fc0
--- /dev/null
+++ b/src/MTools/Widget/MBouton.pm
@@ -0,0 +1,180 @@
+package MTools::Widget::MBouton;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+use strict;
+use MTools;
+use MTools::MGroup;
+use MTools::MSwitch;
+use MTools::MState;
+use MTools::MTimer;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MGroup/;
+}
+
+sub new {
+	my ($class, %options) = @_;
+	my $self = new MTools::MGroup ($options {parent});
+	
+	bless $self, $class;
+
+	my $on = minstance ($options {g_on}, $self);
+	my $off = minstance ($options {g_off}, $self);
+	my $over = defined $options {g_over} ? minstance ($options {g_over}, $self) : $on;
+	my $eventOn = defined $options {e_press} ? $options {e_press} : 'PRESS';
+	my $eventOff = defined $options {e_release} ? $options {e_release} : 'RELEASED';
+	my $cb = $options {call} if (defined $options {call});
+	
+	
+	$self -> recordEvent ('MAINTAIN_DOWN');
+	$self -> recordEvent ('PRESS');
+	$self -> recordEvent ('RELEASE');
+	$self -> mconfigure (-atomic => 1);
+	
+	my @gon;
+	push (@gon, $on);
+	my @goff;
+	push (@goff, $off);
+	my @gover;
+	push (@gover, $over);
+	
+	if (defined $options {g_text})
+	{
+		$self -> recordProperty ('text', $options {text});
+		my $txt = minstance ($options {g_text}, $self);
+		push (@gon, $txt);
+		push (@goff, $txt);
+		push (@gover, $txt);
+		plink ([$self, 'text'], [$txt, '-text']);
+	}
+	
+	$self -> {gp_over} = new MTools::MGroup ($self);
+	push (@gon, $self -> {gp_over});
+	push (@goff, $self -> {gp_over});
+	push (@gover, $self -> {gp_over});
+
+	my $timer = new MTools::MTimer (5, 1);	
+	my @gon_tmp = @gon;
+	push (@gon_tmp, $timer);
+		
+	my $sw = new MTools::MSwitch (
+		$self,
+		'up' => \@gon,
+		'up_tmp' => \@gon_tmp,
+		'down' => \@goff,
+		'over' => \@gover,
+		'maintain_down' => \@goff,
+	);
+
+	my $st = new MTools::MState (
+		current_state => 'up',
+		events => {
+			press => [$self, '<Button-1>'],
+			force_press => [$self, 'PRESS'],
+			maintain => [$self, 'MAINTAIN_DOWN'],
+			release => [$self, '<ButtonRelease-1>'],
+			force_release => [$self, 'RELEASE'],
+			enter => [$self, '<Enter>'],
+			leave => [$self, '<Leave>'],
+			timeout => [$timer, 'TIME_OUT']
+		},
+		transitions => {
+			'up' => {
+				'press' => {
+					to => 'down',
+					notify => $eventOn,
+				},
+				'force_press' => {
+					to => 'down',
+					notify => $eventOn,
+				},
+				'enter' => {
+					to => 'over',
+				},
+			},
+			'up_tmp' => {
+				'press' => {
+					to => 'down',
+					notify => $eventOn,
+				},
+				'force_press' => {
+					to => 'down',
+					notify => $eventOn,
+				},
+				'timeout' => {
+					to => 'up',
+				},
+			},
+			'over' => {
+				'press' => {
+					to => 'down',
+					notify => $eventOn,
+				},
+				'force_press' => {
+					to => 'down',
+					notify => $eventOn,
+				},
+				'leave' => {
+					to => 'up_tmp',
+				}
+			},
+			'down' => {
+				'release' => {
+					to => 'up',
+					notify => $eventOff,
+				},
+				'force_release' => {
+					to => 'up',
+					notify => $eventOff,
+				},
+				'maintain' => {
+					to => 'maintain_down',
+				},
+			},
+			'maintain_down' => {
+				'press' => {
+					to => 'down',
+				},
+				'force_release' => {
+					to => 'up',
+					notify => $eventOff,
+				},
+			},
+		},
+		switchs => [$sw],
+	);
+	
+	if (defined $cb)
+	{
+		$st -> binding ($eventOn, sub {
+			executer ($cb);
+		});
+	}
+	
+	$self -> propagate ($st, $eventOn);
+	$self -> propagate ($st, $eventOff);
+	
+	return $self;
+}
+
+
+1;
+
diff --git a/src/MTools/Widget/MRadioBouton.pm b/src/MTools/Widget/MRadioBouton.pm
new file mode 100644
index 0000000..630f0f6
--- /dev/null
+++ b/src/MTools/Widget/MRadioBouton.pm
@@ -0,0 +1,108 @@
+package MTools::Widget::MRadioBouton;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+use strict;
+use MTools;
+use MTools::MGroup;
+use MTools::MSwitch;
+use MTools::MState;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MGroup/;
+}
+
+sub new {
+	my ($class, %options) = @_;
+	my $self = new MTools::MGroup ($options {parent});
+	
+	bless $self, $class;
+		
+	my $on = $options {g_on};
+	my $off = $options {g_off};
+	
+	$self -> recordEvent ('RELEASE');
+	$self -> recordEvent ('PRESS');
+	$self -> recordProperty ('selected', 0);
+	
+	my @gon;
+	push (@gon, $on);
+	my @goff;
+	push (@goff, $off);
+	
+	if (defined $options {g_text})
+	{
+		$self -> recordProperty ('text', $options {text});
+		my $txt = minstance ($options {g_text}, $self);
+		push (@gon, $txt);
+		push (@goff, $txt);
+		plink ([$self, 'text'], [$txt, '-text']);
+	}
+	$self -> mconfigure (-atomic => 1);
+	my $sw = new MTools::MSwitch (
+		$self,
+		on => \@gon,
+		off => \@goff,
+	);
+	my $st = new MTools::MState (
+		current_state => 'on',
+		events => {
+			press => [$self, '<Button-1>'],
+			press2 => [$self, 'PRESS'],
+			release => [$self, 'RELEASE'],
+		},
+		transitions => {
+			on => {
+				press => {
+					to => 'off',
+					notify => 'PRESSED',
+				},
+				press2 => {
+					to => 'off',
+					notify => 'PRESSED',
+				},
+			},
+			off => {
+				release => {
+					to => 'on',
+					notify => 'RELEASED',
+				},
+			},
+		},
+		switchs => [$sw],
+	);
+	
+	$st -> binding ('PRESSED', sub {
+		$self -> mconfigure ('selected', 1);
+	});
+	
+	$st -> binding ('RELEASED', sub {
+		$self -> mconfigure ('selected', 0);
+	});
+	
+	$self -> propagate ($st, 'PRESSED');
+
+	
+	return $self;
+}
+
+
+1;
+
diff --git a/src/MTools/Widget/MRadioGroup.pm b/src/MTools/Widget/MRadioGroup.pm
new file mode 100644
index 0000000..13a38d8
--- /dev/null
+++ b/src/MTools/Widget/MRadioGroup.pm
@@ -0,0 +1,86 @@
+package MTools::Widget::MRadioGroup;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+use strict;
+
+use MTools;
+use MTools::MObjet;
+use vars qw / @ISA /;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+sub new {
+	my ($class, @buttons) = @_;
+	my $self = new MTools::MObjet ();
+	bless $self, $class;
+	
+	$self -> recordEvent ('BUTTON_SELECTED');
+	$self -> {buttons} = ();
+	
+	for (my $i = 0; $i < @buttons; $i ++)
+	{
+		$self -> addButton ($buttons [$i]);
+	}
+	
+	return $self;
+}
+
+sub addButton {
+	my ($self, $button) = @_;
+	push (@{$self -> {buttons}}, $button);
+	$button -> binding ('PRESSED', sub {
+		my @buttons = @{$self -> {buttons}};
+		for (my $i = 0; $i < @buttons; $i ++)
+		{
+			if ($buttons [$i] != $button)
+			{
+				$buttons [$i] -> notify ('RELEASE');
+			}
+		}
+		$self -> notify ('BUTTON_SELECTED', $button);
+	});
+}
+
+sub getSelected {
+	my ($self) = @_;
+	my @buttons = @{$self -> {buttons}};
+	for (my $i = 0; $i < @buttons; $i ++)
+	{
+		if ($buttons [$i] -> mget ('selected'))
+		{
+			return $buttons [$i];
+		}
+	}
+}
+
+sub setSelected {
+	my ($self, $button) = @_;
+	my @buttons = @{$self -> {buttons}};
+	for (my $i = 0; $i < @buttons; $i ++)
+	{
+		if ($buttons [$i] == $button)
+		{
+			$buttons [$i] -> notify ('PRESS');
+		}
+	}
+}
+
+1;
diff --git a/src/MTools/Widget/MSplitPane.pm b/src/MTools/Widget/MSplitPane.pm
new file mode 100644
index 0000000..dd593bf
--- /dev/null
+++ b/src/MTools/Widget/MSplitPane.pm
@@ -0,0 +1,224 @@
+package MTools::Widget::MSplitPane;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+use strict;
+
+use MTools;
+use MTools::SVG::SVGLoader;
+
+use vars qw /@ISA/;
+
+use MTools::MGroup;
+use MTools::Widget::MBouton;
+use MTools::Comp::MMover;
+use MTools::Anim::MTranslator;
+use MTools::GUI::MClip;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MGroup/;
+}
+
+sub new {
+	my ($class, $parent, %options) = @_;
+	my $self = new MTools::MGroup ($parent);
+	bless $self, $class;
+	
+	$self -> recordProperty ('percentage', 0.00001);
+	my $size = $options {size};
+	$self -> recordProperty ('size', $size);
+	
+	$self -> {__firstgp} = my $gp_first = $options {first_group};
+	$self -> {__secondgp} = my $gp_second = $options {second_group};
+	my $orientation = $options {orientation}? $options {orientation}:'vertical';
+	$self -> {__vertical} = my $vertical = $orientation eq 'vertical';
+	$self -> {__cursor_size} = $options {cursor_size}? $options {cursor_size}:'10';
+		
+	if ($vertical)
+	{
+		new MTools::GUI::MClip ($gp_first, ['rectangle', -2, -1000, $size, 1000]);
+		new MTools::GUI::MClip ($gp_second, ['rectangle', -2, -1000, $size, 1000]);
+	}
+	else
+	{
+		new MTools::GUI::MClip ($gp_first, ['rectangle', -1000, -2, 1000, $size]);
+		new MTools::GUI::MClip ($gp_second, ['rectangle',-1000, -2, 1000, $size]);
+	}
+	
+	$self -> {__curseur} = new MTools::MSwitch (
+		$self,
+		on => [$options {cursor_on}],
+		off => [$options {cursor_off}],
+	);
+	
+	$self -> {__mover} = my $mover = new MTools::Comp::MMover($self -> {__curseur}, $self, 1,
+		x_min => 0, 
+		y_min => 0, 
+		x_max => $vertical ? $options {size} : 0,
+		y_max => !$vertical ? $options {size} : 0,
+	);
+	
+	$self -> propagate ($mover, 'MOVED');
+	
+	if ($options {with_buttons})
+	{
+		my $bouton_open = new MTools::Widget::MBouton (
+			parent => $self,
+			g_on => $options {button_open_on},
+			g_off => $options {button_open_off},
+			e_press => 'PRESS',
+			e_release => 'OPEN',
+		);
+		my $bouton_close = new MTools::Widget::MBouton (
+			parent => $self,
+			g_on => $options {button_close_on},
+			g_off => $options {button_close_off},
+			e_press => 'PRESS',
+			e_release => 'CLOSE',
+		);
+		$self -> {__boutons} = new MTools::MSwitch (
+			$self,
+			open => $bouton_open,
+			close => $bouton_close,
+		);
+		$self -> {__boutons} -> mconfigure ('state' => 'open');
+		$self -> {__anim_open} = new MTools::Anim::MTranslator (
+			from_x => 0,
+			from_y => 0,
+			to_x => $vertical * $options {size},
+			to_y => (!$vertical) * $options {size},
+			targets => $mover,
+			duration => 0.5,
+		);
+		$bouton_open -> binding ('OPEN', [$self, \&opening]);
+		$bouton_close -> binding ('CLOSE', [$self, \&closing]);
+	}
+		
+	$gp_first -> scale ( $vertical? 0.00001:1, !$vertical? 0.00001:1);
+	$self -> {__old_val} = 0;
+	$gp_second -> translate ($vertical * $self -> {__cursor_size}, (!$vertical) * $self -> {__cursor_size});
+	
+	$mover -> binding ('MOVED', [$self, \&moved]);
+	
+	new MTools::MState (
+		current_state => 'on',
+		events => {
+			press => [$mover, 'PRESSED'],
+			release => [$mover, 'RELEASED'],
+		},
+		transitions => {
+			on => {
+				press => {
+					to => 'off',
+				},
+			},
+			off => {
+				release => {
+					to => 'on',
+				},
+			},
+		},
+		switchs => [$self -> {__curseur}],
+	);
+
+	return $self;
+}
+
+sub moved {
+	my ($self, $x, $y) = @_;
+	
+	my $gp_first = $self -> {__firstgp};
+	my $gp_second = $self -> {__secondgp};
+	
+	my $vertical = $self -> {__vertical};
+	my $val = $vertical ? $x : $y;
+
+	my $size = $self -> mget ('size');
+	my $oldperc = $self -> mget ('percentage');
+	my $perc = $val / $size;
+	my $operc = 1 - $perc;
+	my $oldoperc = 1 - $oldperc;
+	if ($perc < 0.00001)
+	{
+		$perc = 0.00001;
+	}
+	if ($operc < 0.00001)
+	{
+		$operc = 0.00001;
+	}
+	if ($oldoperc < 0.00001)
+	{
+		$oldoperc = 0.00001;
+	}
+	
+	$gp_first -> scale ($vertical ? $perc / $oldperc : 1, !$vertical ? $perc / $oldperc : 1);
+	my $trans = $val - $self -> {__old_val};
+	$gp_second -> translate ($vertical * $trans, (!$vertical) * $trans);
+	my $pos = $val + $self -> {__cursor_size};
+	$gp_second -> scale ($vertical ? $operc / $oldoperc : 1, !$vertical ? $operc / $oldoperc : 1, $vertical * $pos, (!$vertical) * $pos);
+
+	$self -> mconfigure ('percentage', $perc);
+	$self -> {__old_val} = $val;
+	if ($val > $size / 2)
+	{
+		$self -> {__boutons} -> mconfigure ('state' => 'close');
+	}
+	else
+	{
+		$self -> {__boutons} -> mconfigure ('state' => 'open');
+	}
+}
+
+sub opening {
+	my ($self) = @_;
+	if ($self -> {__vertical})
+	{
+		$self -> {__anim_open} -> mconfigure (
+			from_x => $self -> {__old_val},
+			to_x => $self -> mget ('size'),
+		);
+	}
+	else
+	{
+		$self -> {__anim_open} -> mconfigure (
+			from_y => $self -> {__old_val},
+			to_y => $self -> mget ('size'),
+		);
+	}
+	$self -> {__anim_open} -> start ();
+}
+
+sub closing {
+	my ($self) = @_;
+	if ($self -> {__vertical})
+	{
+		$self -> {__anim_open} -> mconfigure (
+			from_x => $self -> {__old_val},
+			to_x => 0,
+		);
+	}
+	else
+	{
+		$self -> {__anim_open} -> mconfigure (
+			from_y => $self -> {__old_val},
+			to_y => 0,
+		);
+	}
+	$self -> {__anim_open} -> start ();
+}
+1;
diff --git a/src/MTools/Widget/MToggleBouton.pm b/src/MTools/Widget/MToggleBouton.pm
new file mode 100644
index 0000000..56c976c
--- /dev/null
+++ b/src/MTools/Widget/MToggleBouton.pm
@@ -0,0 +1,81 @@
+package MTools::Widget::MToggleBouton;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+use strict;
+use MTools;
+use MTools::MGroup;
+use MTools::MSwitch;
+use MTools::MState;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MGroup/;
+}
+
+sub new {
+	my ($class, %options) = @_;
+	my $self = new MTools::MGroup ($options {parent});
+	
+	bless $self, $class;
+		
+	my $on = $options {g_on};
+	my $off = $options {g_off};
+	my $eventOn = $options {e_press};
+	my $eventOff = $options {e_release};
+	
+	my $sw = new MTools::MSwitch (
+		$self,
+		on => [$on],
+		off => [$off],
+	);
+	my $st = new MTools::MState (
+		current_state => 'on',
+		events => {
+			press => [$sw, '<Button-1>'],
+		},
+		transitions => {
+			on => {
+				press => {
+					to => 'off',
+					notify => $eventOn,
+				},
+			},
+			off => {
+				press => {
+					to => 'on',
+					notify => $eventOff,
+				},
+			},
+		},
+		switchs => [$sw],
+	);
+	
+	$self -> propagate ($st, $eventOn);
+	$self -> propagate ($st, $eventOff);
+	
+	return $self;
+}
+
+
+1;
+
+
+
+
diff --git a/src/MTools/ptkdb.pm b/src/MTools/ptkdb.pm
new file mode 100644
index 0000000..5962e63
--- /dev/null
+++ b/src/MTools/ptkdb.pm
@@ -0,0 +1,4229 @@
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+package DB ;
+
+##
+## Expedient fix for perl 5.8.0.  True DB::DB is further down.
+## 
+##
+sub DB {}
+
+use Tk ;
+
+#
+# If you've loaded this file via a browser
+# select "Save As..." from your file menu
+#
+#				 ptkdb Perl Tk perl Debugger
+#
+#					 Copyright 1998, Andrew E. Page
+#					All rights reserved.
+#
+#		 This program is free software; you can redistribute it and/or modify
+#		 it under the terms of either:
+#
+#	a) the GNU General Public License as published by the Free
+#	Software Foundation; either version 1, or (at your option) any
+#	later version, or
+#
+#	b) the "Artistic License" which comes with this Kit.
+#
+#		 This program 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 either
+#		 the GNU General Public License or the Artistic License for more details.
+#
+
+
+####################################
+### Sample .Xresources for ptkdb ###
+####################################
+#	 /*
+#		* Perl Tk Debugger XResources.	
+#		* Note... These resources are subject to change.	
+#		*
+#		* Use 'xfontsel' to select different fonts.
+#		*
+#		* Append these resource to ~/.Xdefaults | ~/.Xresources
+#		* and use xrdb -override ~/.Xdefaults | ~/.Xresources
+#		* to activate them.	 
+#		*/
+# /* Set Value to se to place scrollbars on the right side of windows 
+#		CAUTION:	extra whitespace at the end of the line is causing
+#		failures with Tk800.011.
+# */
+# ptkdb*scrollbars: sw
+# 
+# /* controls where the code pane is oriented, down the left side, or across the top */
+# /* values can be set to left, right, top, bottom */
+# ptkdb*codeside: left
+# /*
+# * Background color for the balloon
+# * CAUTION:	For certain versions of Tk trailing
+# * characters after the color produces an error
+# */
+# ptkdb.frame2.frame1.rotext.balloon.background: green
+# ptkdb.frame2.frame1.rotext.balloon.font: fixed											 /* Hot Variable Balloon Font */
+# 
+# 
+# ptkdb.frame*font: fixed														/* Menu Bar */
+# ptkdb.frame.menubutton.font: fixed								/* File menu */
+# ptkdb.frame2.frame1.rotext.font: fixed						/* Code Pane */
+# ptkdb.notebook.datapage.frame1.hlist.font: fixed	/* Expression Notebook Page */
+#							 
+# ptkdb.notebook.subspage*font: fixed								/* Subroutine Notebook Page */
+# ptkdb.notebook.brkptspage*entry.font: fixed				/* Delete Breakpoint Buttons */
+# ptkdb.notebook.brkptspage*button.font: fixed			/* Breakpoint Expression Entries */
+# ptkdb.notebook.brkptspage*button1.font: fixed			/* Breakpoint Expression Entries */
+# ptkdb.notebook.brkptspage*checkbutton.font: fixed /* Breakpoint Checkbuttons */
+# ptkdb.notebook.brkptspage*label.font: fixed				/* Breakpoint "Cond" label */
+#							 
+# ptkdb.toplevel.frame.textundo.font: fixed					/* Eval Expression Entry Window */
+# ptkdb.toplevel.frame1.text.font: fixed						/* Eval Expression Results Window */
+# ptkdb.toplevel.button.font:	 fixed								/* "Eval..." Button */
+# ptkdb.toplevel.button1.font: fixed								/* "Clear Eval" Button */
+# ptkdb.toplevel.button2.font: fixed								/* "Clear Results" Button */
+# ptkdb.toplevel.button3.font: fixed								/* "Clear Dismiss" Button */
+# 
+# 
+#	 /*
+#		* Background color for where the debugger has stopped	
+#		*/	
+#	 ptkdb*stopcolor: blue
+#
+#	 /*
+#		* Background color for set breakpoints	
+#		*/
+#	 ptkdb*breaktagcolor: red
+#
+#	 /*
+#		* Font for where the debugger has stopped
+#		*/
+#	 ptkdb*stopfont: -*-fixed-bold-*-*-*-*-*-*-*-*-*-*-*
+#
+#	 /*
+#		* Background color for the search tag
+#		*/	
+#	 ptkdb*searchtagcolor: green
+
+use strict ;
+use vars qw($VERSION @dbline %dbline);
+
+#
+# This package is the main_window object
+# for the debugger.	 We start with the Devel::
+# prefix because we want to install it with 
+# the DB:: package that is required to be in a Devel/
+# subdir of a directory in the @INC set.	
+#
+package Devel::ptkdb ;
+
+=head1 NAME
+
+Devel::ptkdb - Perl debugger using a Tk GUI
+
+=head1 DESCRIPTION
+
+  ptkdb is a debugger for perl that uses perlTk for a user interface.
+	Features include:
+
+		Hot Variable Inspection
+		Breakpoint Control Panel
+		Expression List
+		Subroutine Tree
+		
+
+=begin html
+
+		<body bgcolor=white>
+
+=end html
+
+=head1 SYNOPSIS
+
+To debug a script using ptkdb invoke perl like this:
+
+		perl -d:ptkdb myscript.pl
+
+=head1 Usage
+
+		perl -d:ptkdb myscript.pl
+
+=head1 Code Pane
+
+=over 4
+
+=item Line Numbers
+
+ Line numbers are presented on the left side of the window. Lines that
+ have lines through them are not breakable. Lines that are plain text
+ are breakable. Clicking on these line numbers will insert a
+ breakpoint on that line and change the line number color to
+ $ENV{'PTKDB_BRKPT_COLOR'} (Defaults to Red). Clicking on the number
+ again will remove the breakpoint.  If you disable the breakpoint with
+ the controls on the BrkPt notebook page the color will change to
+ $ENV{'PTKDB_DISABLEDBRKPT_COLOR'}(Defaults to Green).
+
+=item Cursor Motion
+
+If you place the cursor over a variable (i.e. $myVar, @myVar, or
+%myVar) and pause for a second the debugger will evaluate the current
+value of the variable and pop a balloon up with the evaluated
+result. I<This feature is not available with Tk400.>
+
+If Data::Dumper(standard with perl5.00502)is available it will be used
+to format the result.  If there is an active selection, the text of
+that selection will be evaluated.
+
+=back
+
+=head1 Notebook Pane
+
+=over 2
+
+=item Exprs
+
+ This is a list of expressions that are evaluated each time the
+ debugger stops. The results of the expresssion are presented
+ heirarchically for expression that result in hashes or lists.  Double
+ clicking on such an expression will cause it to collapse; double
+ clicking again will cause the expression to expand. Expressions are
+ entered through B<Enter Expr> entry, or by Alt-E when text is
+ selected in the code pane.
+
+ The B<Quick Expr> entry, will take an expression, evaluate it, and
+ replace the entries contents with the result.  The result is also
+ transfered to the 'clipboard' for pasting.
+
+=item Subs
+
+ Displays a list of all the packages invoked with the script
+ heirarchially. At the bottom of the heirarchy are the subroutines
+ within the packages.  Double click on a package to expand
+ it. Subroutines are listed by their full package names.
+
+=item BrkPts
+
+ Presents a list of the breakpoints current in use. The pushbutton
+ allows a breakpoint to be 'disabled' without removing it. Expressions
+ can be applied to the breakpoint.  If the expression evaluates to be
+ 'true'(results in a defined value that is not 0) the debugger will
+ stop the script.  Pressing the 'Goto' button will set the text pane
+ to that file and line where the breakpoint is set.  Pressing the
+ 'Delete' button will delete the breakpoint.
+
+=back
+
+=head1 Menus
+
+=head2 File Menu
+
+=over
+
+=item About...
+
+Presents a dialog box telling you about the version of ptkdb.  It
+recovers your OS name, version of perl, version of Tk, and some other
+information
+
+=item Open
+
+Presents a list of files that are part of the invoked perl
+script. Selecting a file from this list will present this file in the
+text window.
+
+=item Save Config...
+
+Requires Data::Dumper. Prompts for a filename to save the
+configuration to. Saves the breakpoints, expressions, eval text and
+window geometry. If the name given as the default is used and the
+script is reinvoked, this configuration will be reloaded
+automatically.
+
+		B<NOTE:>	You may find this preferable to using 
+
+=item Restore Config...
+
+Requires Data::Dumper.	Prompts for a filename to restore a configuration saved with
+the "Save Config..." menu item.	 
+
+=item Goto Line...
+
+Prompts for a line number.	Pressing the "Okay" button sends the window to the line number entered.
+item Find Text...
+
+Prompts for text to search for.  Options include forward search,
+backwards search, and regular expression searching.
+
+=item Quit
+
+ Causes the debugger and the target script to exit.	
+
+=back
+
+=head2 Control Menu
+
+=over
+
+=item Run
+
+The debugger allows the script to run to the next breakpoint or until the script exits.
+item Run To Here
+
+Runs the debugger until it comes to wherever the insertion cursor
+in text window is placed.
+
+=item Set Breakpoint
+
+Sets a breakpoint on the line at the insertion cursor.	
+item Clear Breakpoint
+
+Remove a breakpoint on the at the insertion cursor.
+
+=item Clear All Breakpoints
+
+Removes all current breakpoints
+
+=item Step Over
+
+Causes the debugger to step over the next line.  If the line is a
+subroutine call it steps over the call, stopping when the subroutine
+returns.
+
+=item Step In
+
+Causes the debugger to step into the next line.  If the line is a
+subroutine call it steps into the subroutine, stopping at the first
+executable line within the subroutine.
+
+=item Return
+
+Runs the script until it returns from the currently executing
+subroutine.	 
+
+=item Restart
+
+Saves the breakpoints and expressions in a temporary file and restarts
+the script from the beginning.  CAUTION: This feature will not work
+properly with debugging of CGI Scripts.
+
+=item Stop On Warning
+
+When C<-w> is enabled the debugger will stop when warnings such as, "Use
+of uninitialized value at undef_warn.pl line N" are encountered.  The debugger
+will stop on the NEXT line of execution since the error can't be detected
+until the current line has executed.  
+
+This feature can be turned on at startup by adding:
+
+$DB::ptkdb::stop_on_warning = 1 ;
+
+to a .ptkdbrc file
+
+=back
+
+=head2 Data Menu
+
+=over
+
+=item Enter Expression
+
+When an expression is entered in the "Enter Expression:" text box,
+selecting this item will enter the expression into the expression
+list.  Each time the debugger stops this expression will be evaluated
+and its result updated in the list window.
+
+=item Delete Expression
+
+ Deletes the highlighted expression in the expression window.
+
+=item Delete All Expressions
+
+ Delete all expressions in the expression window.
+
+=item Expression Eval Window
+
+Pops up a two pane window. Expressions of virtually unlimitted length
+can be entered in the top pane.  Pressing the 'Eval' button will cause
+the expression to be evaluated and its placed in the lower pane. If
+Data::Dumper is available it will be used to format the resulting
+text.  Undo is enabled for the text in the upper pane.
+
+HINT:	 You can enter multiple expressions by separating them with commas.	 
+
+=item Use Data::Dumper for Eval Window
+
+Enables or disables the use of Data::Dumper for formatting the results
+of expressions in the Eval window.	
+
+=back
+
+=head2 Stack Menu
+
+Maintains a list of the current subroutine stack each time the
+debugger stops. Selecting an item from this menu will set the text in
+the code window to that particular subourtine entry point.
+
+=head2 Bookmarks Menu
+
+Maintains a list of bookmarks.	The booksmarks are saved in ~/.ptkdb_bookmarks
+
+=over
+
+=item Add Bookmark
+
+Adds a bookmark to the bookmark list.	 
+
+=back
+
+=head1 Options
+
+Here is a list of the current active XResources options. Several of
+these can be overridden with environmental variables. Resources can be
+added to .Xresources or .Xdefaults depending on your X configuration.
+To enable these resources you must either restart your X server or use
+the xrdb -override resFile command.  xfontsel can be used to select
+fonts.
+
+		/*
+		* Perl Tk Debugger XResources.	 
+		* Note... These resources are subject to change.	 
+		*
+		* Use 'xfontsel' to select different fonts.
+		*
+		* Append these resource to ~/.Xdefaults | ~/.Xresources
+		* and use xrdb -override ~/.Xdefaults | ~/.Xresources
+		* to activate them.	
+		*/
+		/* Set Value to se to place scrollbars on the right side of windows 
+	CAUTION:	extra whitespace at the end of the line is causing
+		failures with Tk800.011.
+		
+		sw -> puts scrollbars on left, se puts scrollars on the right
+		
+		*/
+		ptkdb*scrollbars: sw
+		/* controls where the code pane is oriented, down the left side, or across the top */
+		/* values can be set to left, right, top, bottom */
+		ptkdb*codeside: left
+		
+		/*
+		* Background color for the balloon
+		* CAUTION:	For certain versions of Tk trailing
+		* characters after the color produces an error
+		*/
+		ptkdb.frame2.frame1.rotext.balloon.background: green
+		ptkdb.frame2.frame1.rotext.balloon.font: fixed											 /* Hot Variable Balloon Font */
+		
+		
+		ptkdb.frame*font: fixed														/* Menu Bar */
+		ptkdb.frame.menubutton.font: fixed								/* File menu */
+		ptkdb.frame2.frame1.rotext.font: fixed						/* Code Pane */
+		ptkdb.notebook.datapage.frame1.hlist.font: fixed	/* Expression Notebook Page */
+		
+		ptkdb.notebook.subspage*font: fixed								/* Subroutine Notebook Page */
+		ptkdb.notebook.brkptspage*entry.font: fixed				/* Delete Breakpoint Buttons */
+		ptkdb.notebook.brkptspage*button.font: fixed			/* Breakpoint Expression Entries */
+		ptkdb.notebook.brkptspage*button1.font: fixed			/* Breakpoint Expression Entries */
+		ptkdb.notebook.brkptspage*checkbutton.font: fixed /* Breakpoint Checkbuttons */
+		ptkdb.notebook.brkptspage*label.font: fixed				/* Breakpoint Checkbuttons */
+		
+		ptkdb.toplevel.frame.textundo.font: fixed					/* Eval Expression Entry Window */
+		ptkdb.toplevel.frame1.text.font: fixed						/* Eval Expression Results Window */
+		ptkdb.toplevel.button.font:	 fixed								/* "Eval..." Button */
+		ptkdb.toplevel.button1.font: fixed								/* "Clear Eval" Button */
+		ptkdb.toplevel.button2.font: fixed								/* "Clear Results" Button */
+		ptkdb.toplevel.button3.font: fixed								/* "Clear Dismiss" Button */
+		
+		/*
+		* Background color for where the debugger has stopped	
+		*/	
+		ptkdb*stopcolor: blue
+		
+		/*
+		* Background color for set breakpoints	
+		*/
+		ptkdb*breaktagcolor*background: yellow
+		ptkdb*disabledbreaktagcolor*background: white
+		/*
+		* Font for where the debugger has stopped
+		*/
+		ptkdb*stopfont: -*-fixed-bold-*-*-*-*-*-*-*-*-*-*-*
+		
+		/*
+		* Background color for the search tag
+		*/	
+		ptkdb*searchtagcolor: green
+
+=head1 Environmental Variables
+
+=over 4
+
+=item PTKDB_BRKPT_COLOR
+
+Sets the background color of a set breakpoint
+
+=item PTKDB_DISABLEDBRKPT_COLOR
+
+Sets the background color of a disabled breakpoint
+
+=item PTKDB_CODE_FONT
+
+Sets the font of the Text in the code pane.
+
+=item PTKDB_CODE_SIDE
+
+Sets which side the code pane is packed onto.	 Defaults to 'left'.
+Can be set to 'left', 'right', 'top', 'bottom'.	 
+
+Overrides the Xresource ptkdb*codeside: I<side>.
+
+=item PTKDB_EXPRESSION_FONT
+
+ Sets the font used in the expression notebook page.
+
+=item PTKDB_EVAL_FONT
+
+ Sets the font used in the Expression Eval Window
+
+=item PTKDB_EVAL_DUMP_INDENT
+
+ Sets the value used for Data::Dumper 'indent' setting.	See man Data::Dumper
+
+=item PTKDB_SCROLLBARS_ONRIGHT
+
+ A non-zero value Sets the scrollbars of all windows to be on the
+ right side of the window. Useful for Windows users using ptkdb in an
+ XWindows environment.
+
+=item PTKDB_LINENUMBER_FORMAT
+
+Sets the format of line numbers on the left side of the window.	 Default value is %05d.	 useful
+if you have a script that contains more than 99999 lines.	 
+
+=item PTKDB_DISPLAY
+
+Sets the X display that the ptkdb window will appear on when invoked.	 Useful for debugging CGI
+scripts on remote systems.	
+
+=item PTKDB_BOOKMARKS_PATH
+
+Sets the path of the bookmarks file.	Default is $ENV{'HOME'}/.ptkdb_bookmarks
+
+=item PTKDB_STOP_TAG_COLOR
+
+Sets the color that highlights the line where the debugger is stopped 
+
+=back
+
+=head1 FILES
+
+=head2 .ptkdbrc
+
+If this file is present in ~/ or in the directory where perl is
+invoked the file will be read and executed as a perl script before the
+debugger makes its initial stop at startup.  There are several 'api'
+calls that can be used with such scripts. There is an internal
+variable $DB::no_stop_at_start that may be set to non-zero to prevent
+the debugger from stopping at the first line of the script.  This is
+useful for debugging CGI scripts.
+
+There is a system ptkdbrc file in $PREFIX/lib/perl5/$VERS/Devel/ptkdbrc
+
+=over 4
+
+=item brkpt($fname, @lines)
+
+Sets breakspoints on the list of lines in $fname.  A warning message
+is generated if a line is not breakable.
+
+=item condbrkpt($fname, @($line, $expr) ) 
+
+Sets conditional breakpoints in $fname on pairs of $line and $expr. A
+warning message is generated if a line is not breakable.  NOTE: the
+validity of the expression will not be determined until execution of
+that particular line.
+
+=item brkonsub(@names)
+
+Sets a breakpoint on each subroutine name listed. A warning message is
+generated if a subroutine does not exist.  NOTE: for a script with no
+other packages the default package is "main::" and the subroutines
+would be "main::mySubs".
+
+=item brkonsub_regex(@regExprs)
+
+Uses the list of @regExprs as a list of regular expressions to set breakpoints.	 Sets breakpoints 
+on every subroutine that matches any of the listed regular expressions.
+
+=item textTagConfigure(tag, ?option?, ?value?)
+
+Allows the user to format the text in the code window. The option
+value pairs are the same values as the option for the tagConfigure
+method documented in Tk::Text. Currently the following tags are in
+effect:
+
+		
+		'code'							 Format for code in the text pane
+		'stoppt'						 Format applied to the line where the debugger is currently stopped
+		'breakableLine'			 Format applied to line numbers where the code is 'breakable'
+		'nonbreakableLine'	 Format applied to line numbers where the code is no breakable
+		'breaksetLine'			 Format applied to line numbers were a breakpoint is set
+		'breakdisabledLine'	 Format applied to line numbers were a disabled breakpoint is set
+		'search_tag'				 Format applied to text when located by a search.	 
+
+ Example:
+
+ #
+ # Turns off the overstrike on lines that you can't set a breakpoint on
+ # and makes the text color yellow.	
+ #
+		textTagConfigure('nonbreakableLine', -overstrike => 0, -foreground => "yellow") ;
+
+=item add_exprs(@exprList)
+
+Add a list of expressions to the 'Exprs' window. NOTE: use the single
+quote character \' to prevent the expression from being "evaluated" in
+the string context.
+
+
+	Example:
+
+		#
+		# Adds the $_ and @_ expressions to the active list
+		#
+
+		add_exprs('$_', '@_') ;
+
+=back
+
+=head1 NOTES
+
+=head2 Debugging Other perlTk Applications
+
+ptkdb can be used to debug other perlTk applications if some cautions
+are observed. Basically, do not click the mouse in the application's
+window(s) when you've entered the debugger and do not click in the
+debugger's window(s) while the application is running.  Doing either
+one is not necessarily fatal, but it can confuse things that are going
+on and produce unexpected results.
+
+Be aware that most perlTk applications have a central event loop.
+User actions, such as mouse clicks, key presses, window exposures, etc
+will generate 'events' that the script will process. When a perlTk
+application is running, its 'MainLoop' call will accept these events
+and then dispatch them to appropriate callbacks associated with the
+appropriate widgets.
+
+Ptkdb has its own event loop that runs whenever you've stopped at a
+breakpoint and entered the debugger. However, it can accept events
+that are generated by other perlTk windows and dispatch their
+callbacks.  The problem here is that the application is supposed to be
+'stopped', and logically the application should not be able to process
+events.
+
+A future version of ptkdb will have an extension that will 'filter'
+events so that application events are not processed while the debugger
+is active, and debugger events will not be processed while the target
+script is active.
+
+=head2 Debugging CGI Scripts
+
+One advantage of ptkdb over the builtin debugger(-d) is that it can be
+used to debug CGI perl scripts as they run on a web server. Be sure
+that that your web server's perl instalation includes Tk.
+
+Change your
+
+  #! /usr/local/bin/perl
+
+to
+
+  #! /usr/local/bin/perl -d:ptkdb
+
+TIP: You can debug scripts remotely if you're using a unix based
+Xserver and where you are authoring the script has an Xserver.  The
+Xserver can be another unix workstation, a Macintosh or Win32 platform
+with an appropriate XWindows package.  In your script insert the
+following BEGIN subroutine:
+
+		sub BEGIN {
+			$ENV{'DISPLAY'} = "myHostname:0.0" ;
+		}
+
+Be sure that your web server has permission to open windows on your
+Xserver (see the xhost manpage).
+
+Access your web page with your browswer and 'submit' the script as
+normal.  The ptkdb window should appear on myHostname's monitor. At
+this point you can start debugging your script.  Be aware that your
+browser may timeout waiting for the script to run.
+
+To expedite debugging you may want to setup your breakpoints in
+advance with a .ptkdbrc file and use the $DB::no_stop_at_start
+variable.  NOTE: for debugging web scripts you may have to have the
+.ptkdbrc file installed in the server account's home directory (~www)
+or whatever username your webserver is running under.  Also try
+installing a .ptkdbrc file in the same directory as the target script.
+
+=head1 KNOWN PROBLEMS
+
+=over
+
+=item I<Breakpoint Controls>
+
+If the size of the right hand pane is too small the breakpoint controls
+are not visible.	The breakpoints are still there, the window may have
+to be enlarged in order for them to be visible.	 
+
+=item Balloons and Tk400
+
+The Balloons in Tk400 will not work with ptkdb.	 All other functions
+are supported, but the Balloons require Tk800 or higher.
+
+=back
+
+=head1 AUTHOR
+
+Andrew E. Page, aep@world.std.com
+
+=head1 ACKNOWLEDGEMENTS
+
+Matthew Persico		 For suggestions, and beta testing.
+
+=cut
+
+
+require 5.004 ;
+
+
+##
+## Perform a check to see if we have the Tk library, if not, attempt
+## to load it for the user
+##
+
+sub BEGIN {
+
+eval {
+require Tk  ;
+} ;
+if( $@ ) {
+print << "__PTKDBTK_INSTALL__" ;
+***
+*** The PerlTk library could not be found.  Ptkdb requires the PerlTk library.
+***
+Preferably Tk800.015 or better: 
+
+In order to install this the following conditions must be met:
+
+1.  You have to have access to a C compiler.
+2.  You must have sufficient permissions to install the libraries on your system.
+
+To install PerlTk:
+
+a  Download the Tk library source from http://www.perl.com/CPAN/modules/by-category/08_User_Interfaces/Tk
+b  Uncompress the archive and run "perl Makefile.PL"
+c  run "make install"
+
+   If this process completes successfully ptkdb should be operational now.  
+
+We can attempt to run the CPAN module for you.  This will, after some questions, download
+and install the Tk library automatically.  
+
+Would you like to run the CPAN module? (y/n) 
+__PTKDBTK_INSTALL__
+
+my $answer = <STDIN> ;
+chomp $answer ;
+if( $answer =~ /y|yes/i) {
+	require CPAN ;
+	CPAN::install Tk ;
+} # if
+
+} # if $@
+
+
+} # end of sub BEGIN 
+
+use Tk 800 ;
+use Data::Dumper ;
+
+require Tk::Dialog;
+require Tk::TextUndo ;
+require Tk::ROText;
+require Tk::NoteBook ;
+require Tk::HList ;
+require Tk::Table ;
+
+use vars qw(@dbline) ;
+
+use Config ;
+#
+# Check to see if the package actually
+# exists. If it does import the routines
+# and return a true value ;
+#
+# NOTE:	 this needs to be above the 'BEGIN' subroutine,
+# otherwise it will not have been compiled by the time
+# that it is called by sub BEGIN.
+#
+sub check_avail {
+	my ($mod, @list) = @_ ;
+
+	eval {
+		require $mod ; import $mod @list ;
+	} ;
+
+	return 0 if $@ ;
+	return 1 ;
+
+} # end of check_avail
+
+sub BEGIN {
+
+ $DB::on = 0 ;		 
+	 
+ $DB::subroutine_depth = 0 ; # our subroutine depth counter
+ $DB::step_over_depth = -1 ;
+
+	 #
+	 # the bindings and font specs for these operations have been placed here
+	 # to make them accessible to people who might want to customize the 
+	 # operations.	REF The 'bind.html' file, included in the perlTk FAQ has
+	 # a fairly good explanation of the binding syntax.	 
+	 # 
+
+	 #
+	 # These lists of key bindings will be applied
+	 # to the "Step In", "Step Out", "Return" Commands
+	 #
+ $Devel::ptkdb::pathSep = '\x00' ;
+ $Devel::ptkdb::pathSepReplacement = "\0x01" ;
+
+ @Devel::ptkdb::step_in_keys = ( '<Shift-F9>', '<Alt-s>', '<Button-3>' ) ; # step into a subroutine
+ @Devel::ptkdb::step_over_keys = ( '<F9>', '<Alt-n>', '<Shift-Button-3>' ) ; # step over a subroutine
+ @Devel::ptkdb::return_keys		= ( '<Alt-u>', '<Control-Button-3>' ) ; # return from a subroutine
+ @Devel::ptkdb::toggle_breakpt_keys = ( '<Alt-b>' ) ; # set or unset a breakpoint
+
+	 # Fonts used in the displays
+	 
+	 #
+	 # NOTE:	 The environmental variable syntax here works like this:
+	 # $ENV{'NAME'} accesses the environmental variable "NAME"
+	 #
+	 # $ENV{'NAME'} || 'string'	results in	$ENV{'NAME'} or 'string' if	 $ENV{'NAME'} is not defined.	 
+	 #
+	 #
+	 
+ @Devel::ptkdb::button_font = $ENV{'PTKDB_BUTTON_FONT'} ? ( "-font" => $ENV{'PTKDB_CODE_FONT'} ) : () ; # font for buttons
+ @Devel::ptkdb::code_text_font = $ENV{'PTKDB_CODE_FONT'} ? ( "-font" => $ENV{'PTKDB_CODE_FONT'} ) : () ;
+
+ @Devel::ptkdb::expression_text_font = $ENV{'PTKDB_EXPRESSION_FONT'} ? ( "-font" => $ENV{'PTKDB_EXPRESSION_FONT'} ) : () ;
+ @Devel::ptkdb::eval_text_font = $ENV{'PTKDB_EVAL_FONT'} ? ( -font => $ENV{'PTKDB_EVAL_FONT'} ) : () ; # text for the expression eval window
+
+ $Devel::ptkdb::eval_dump_indent = $ENV{'PTKDB_EVAL_DUMP_INDENT'} || 1 ;
+
+	 #
+	 # Windows users are more used to having scroll bars on the right.
+	 # If they've set PTKDB_SCROLLBARS_ONRIGHT to a non-zero value
+	 # this will configure our scrolled windows with scrollbars on the right
+	 #
+	 # this can also be done by setting:
+	 #
+	 # ptkdb*scrollbars: se
+	 #
+	 # in the .Xdefaults/.Xresources file on X based systems
+	 #
+	 if( exists $ENV{'PTKDB_SCROLLBARS_ONRIGHT'} && $ENV{'PTKDB_SCROLLBARS_ONRIGHT'} ) {
+	 @Devel::ptkdb::scrollbar_cfg = ('-scrollbars' => 'se') ;
+	 }
+	 else {
+	 @Devel::ptkdb::scrollbar_cfg = ( ) ;
+	 }
+
+	 #
+	 # Controls how far an expression result will be 'decomposed'.	 Setting it
+	 # to 0 will take it down only one level, setting it to -1 will make it 
+	 # decompose it all the way down.	However, if you have a situation where
+	 # an element is a ref	 back to the array or a root of the array
+	 # you could hang the debugger by making it recursively evaluate an expression
+	 #
+ $Devel::ptkdb::expr_depth = -1 ;
+ $Devel::ptkdb::add_expr_depth = 1 ; # how much further to expand an expression when clicked
+
+ $Devel::ptkdb::linenumber_format = $ENV{'PTKDB_LINENUMBER_FORMAT'} || "%05d " ;
+ $Devel::ptkdb::linenumber_length = 5 ;
+
+ $Devel::ptkdb::linenumber_offset = length sprintf($Devel::ptkdb::linenumber_format, 0) ;
+ $Devel::ptkdb::linenumber_offset -= 1 ;
+
+	 #
+	 # Check to see if "Data Dumper" is available
+	 # if it is we can save breakpoints and other 
+	 # various "functions".	This call will also
+	 # load the subroutines needed.
+	 #
+ $Devel::ptkdb::DataDumperAvailable = 1 ; # assuming that it is now
+ $Devel::ptkdb::useDataDumperForEval = $Devel::ptkdb::DataDumperAvailable ;
+
+	 #
+	 # DB Options (things not directly involving the window)
+	 #
+
+	 # Flag to disable us from intercepting $SIG{'INT'}
+
+ $DB::sigint_disable = defined $ENV{'PTKDB_SIGINT_DISABLE'} && $ENV{'PTKDB_SIGINT_DISABLE'} ;
+#
+# Possibly for debugging perl CGI Web scripts on
+# remote machines.	
+#
+	 $ENV{'DISPLAY'} = $ENV{'PTKDB_DISPLAY'} if exists $ENV{'PTKDB_DISPLAY'} ;
+
+ } # end of BEGIN
+
+sub DESTROY {
+	my ($self) = @_ ;
+	
+	$self->save_bookmarks($self->{BookMarksPath}) if $Devel::ptkdb::DataDumperAvailable && $self->{'bookmarks_changed'};
+
+
+} # end of ptkdb::DESTROY
+
+##
+## subroutine provided to the user for initializing
+## files in .ptkdbrc
+##
+sub brkpt {
+	my ($fName, @idx) = @_ ;
+	my($offset) ;
+	local(*dbline) = $main::{'_<' . $fName} ;
+
+	$offset = $dbline[1] =~ /use\s+.*Devel::_?ptkdb/ ? 1 : 0 ;
+
+	for( @idx ) {
+		if( !&DB::checkdbline($fName, $_ + $offset) ) {
+			my ($package, $filename, $line) = caller ;
+			print "$filename:$line:	 $fName line $_ is not breakable\n" ;
+			next ;
+		}
+	$DB::window->insertBreakpoint($fName, $_, 1) ; # insert a simple breakpoint
+	}
+} # end of brkpt
+
+#
+# Set conditional breakpoint(s)
+#
+sub condbrkpt {
+	my ($fname) = shift ;
+	my($offset) ;
+	local(*dbline) = $main::{'_<' . $fname} ;
+
+	$offset = $dbline[1] =~ /use\s+.*Devel::_?ptkdb/ ? 1 : 0 ;
+
+	while( @_ ) { # arg loop
+		my($index, $expr) = splice @_, 0, 2 ; # take args 2 at a time
+
+		if( !&DB::checkdbline($fname, $index + $offset) ) {
+			my ($package, $filename, $line) = caller ;
+			print "$filename:$line:	 $fname line $index is not breakable\n" ;
+			next ;
+		}
+	$DB::window->insertBreakpoint($fname, $index, 1, $expr) ; # insert a simple breakpoint
+	} # end of arg loop
+
+} # end of conditionalbrkpt
+
+sub brkonsub {
+	my(@names) = @_ ;
+	
+	for( @names ) {
+		
+		# get the filename and line number range of the target subroutine
+		
+		if( !exists $DB::sub{$_} ) {
+			print "No subroutine $_.	Try main::$_\n" ;
+			next ;
+		}
+
+	$DB::sub{$_} =~ /(.*):([0-9]+)-([0-9]+)$/o ; # file name will be in $1, start line $2, end line $3
+
+		for( $2..$3 ) {
+			next unless &DB::checkdbline($1, $_) ;
+		$DB::window->insertBreakpoint($1, $_, 1) ;
+			last ; # only need the one breakpoint
+		}
+	} # end of name loop
+
+} # end of brkonsub
+
+#
+# set breakpoints on subroutines matching a regular
+# expression
+#
+sub brkonsub_regex {
+	my(@regexps) = @_ ;
+	my($regexp, @subList) ;
+
+	#
+	# accumulate matching subroutines
+	#
+	foreach $regexp ( @regexps ) {
+		study $regexp ;
+		push @subList, grep /$regexp/, keys %DB::sub ;
+	} # end of brkonsub_regex
+
+	brkonsub(@subList) ; # set breakpoints on matching subroutines
+
+} # end of brkonsub_regex
+
+#
+# Allow the user Access to our tag configurations
+#
+sub textTagConfigure {
+	my ($tag, @config) = @_ ;
+
+ $DB::window->{'text'}->tagConfigure($tag, @config) ;
+	
+} # end of textTagConfigure
+
+##
+## Change the tabs in the text field
+##
+sub setTabs {
+	
+ $DB::window->{'text'}->configure(-tabs => [ @_ ]) ;
+
+}
+
+#
+# User .ptkdbrc API
+# allows the user to add expressions to
+# the expression list window.	 
+#
+sub add_exprs {
+	push @{$DB::window->{'expr_list'}}, map { 'expr' => $_, 'depth' => $Devel::ptkdb::expr_depth }, @_ ;
+} # end of add_exprs
+
+
+##
+## register a subroutine reference that will be called whenever
+## ptkdb sets up it's windows
+##
+sub register_user_window_init {
+	push @{$DB::window->{'user_window_init_list'}}, @_ ;
+} # end of register_user_window_init
+
+##
+## register a subroutine reference that will be called whenever
+## ptkdb enters from code
+##
+sub register_user_DB_entry {
+	push @{$DB::window->{'user_window_DB_entry_list'}}, @_ ;
+} # end of register_user_DB_entry
+
+sub get_notebook_widget {
+	return $DB::window->{'notebook'} ;
+} # end of get_notebook_widget
+
+
+#
+# Run files provided by the user
+#
+sub do_user_init_files {
+	use vars qw($dbg_window) ;
+	local $dbg_window = shift ;
+
+	eval {
+		do "$Config{'installprivlib'}/Devel/ptkdbrc" ;
+	} if -e "$Config{'installprivlib'}/Devel/ptkdbrc" ;
+
+	if( $@ ) {
+		print "System init file $Config{'installprivlib'}/ptkdbrc failed: $@\n" ;
+	}
+
+	eval {
+		do "$ENV{'HOME'}/.ptkdbrc" ;
+	} if exists $ENV{'HOME'} && -e "$ENV{'HOME'}/.ptkdbrc" ;
+
+	if( $@ ) {
+		print "User init file $ENV{'HOME'}/.ptkdbrc failed: $@\n" ;
+	}
+
+	eval {
+		do ".ptkdbrc" ;
+	} if -e ".ptkdbrc" ;
+
+	if( $@ ) {
+		print "User init file .ptkdbrc failed: $@\n" ;
+	}
+
+	&set_stop_on_warning() ;
+}
+
+#
+# Constructor for our Devel::ptkdb
+#
+sub new {
+	my($type) = @_ ;
+	my($self) = {} ;
+	
+	bless $self, $type ;
+
+	# Current position of the executing program
+
+	$self->{DisableOnLeave} = [] ; # List o' Widgets to disable when leaving the debugger
+
+	$self->{current_file} = "" ; 
+	$self->{current_line} = -1 ; # initial value indicating we haven't set our line/tag
+	$self->{window_pos_offset} = 10 ; # when we enter how far from the top of the text are we positioned down
+	$self->{search_start} = "0.0" ;
+	$self->{fwdOrBack} = 1 ;
+	$self->{BookMarksPath} = $ENV{'PTKDB_BOOKMARKS_PATH'} || "$ENV{'HOME'}/.ptkdb_bookmarks" || '.ptkdb_bookmarks'	;
+
+	$self->{'expr_list'} = [] ; # list of expressions to eval in our window fields:	 {'expr'} The expr itself {'depth'} expansion depth
+
+
+	$self->{'brkPtCnt'} = 0 ;
+	$self->{'brkPtSlots'} = [] ; # open slots for adding breakpoints to the table 
+
+	$self->{'main_window'} = undef ;
+
+	$self->{'user_window_init_list'} = [] ;
+	$self->{'user_window_DB_entry_list'} = [] ;
+
+	$self->setup_main_window() ;
+
+	return $self ;
+
+} # end of new
+
+sub setup_main_window {
+	my($self) = @_ ;
+
+	# Main Window
+	
+	$self->{main_window} = MainWindow->new() ;
+	$self->{main_window}->geometry($ENV{'PTKDB_GEOMETRY'} || "800x600") ;
+
+	$self->setup_options() ; # must be done after MainWindow and before other frames are setup
+
+	$self->{main_window}->bind('<Control-c>', \&DB::dbint_handler) ;
+
+	#
+	# Bind our 'quit' routine to a close command from the window manager (Alt-F4) 
+	# 
+	$self->{main_window}->protocol('WM_DELETE_WINDOW', sub { $self->close_ptkdb_window() ; } ) ;
+
+	# Menu bar
+
+	$self->setup_menu_bar() ;
+
+	#
+	# setup Frames
+	#
+	# Setup our Code, Data, and breakpoints
+
+	$self->setup_frames() ;
+
+}
+
+
+#
+# This supports the File -> Open menu item
+# We create a new window and list all of the files
+# that are contained in the program.	We also
+# pick up all of the perlTk files that are supporting
+# the debugger.	 
+#
+sub DoOpen {
+	my $self = shift ;
+	my ($topLevel, $listBox, $frame, $selectedFile, @fList) ;
+
+	#
+	# subroutine we call when we've selected a file
+	#
+
+	my $chooseSub = sub { $selectedFile = $listBox->get('active') ;
+												print "attempting to open $selectedFile\n" ;
+											$DB::window->set_file($selectedFile, 0) ;
+												destroy $topLevel ; 
+											} ;
+
+	#
+	# Take the list the files and resort it.	
+	# we put all of the local files first, and
+	# then list all of the system libraries.
+	#
+	@fList = sort { 
+		# sort comparison function block
+		my $fa = substr($a, 0, 1) ;
+		my $fb = substr($b, 0, 1) ;
+
+		return $a cmp $b if ($fa eq '/') && ($fb eq '/') ;
+
+		return -1 if ($fb eq '/') && ($fa ne '/') ;
+		return 1 if ($fa eq '/' ) && ($fb ne '/') ;
+
+		return $a cmp $b ;
+
+	} grep s/^_<//, keys %main:: ;
+
+	#
+	# Create a list box with all of our files
+	# to select from
+	#
+	$topLevel = $self->{main_window}->Toplevel(-title => "File Select", -overanchor => 'cursor') ;
+
+	$listBox = $topLevel->Scrolled('Listbox', 
+															 @Devel::ptkdb::scrollbar_cfg,
+															 @Devel::ptkdb::expression_text_font,
+																 'width' => 30)->pack(side => 'top', fill => 'both', -expand => 1) ;
+
+
+	# Bind a double click on the mouse button to the same action
+	# as pressing the Okay button
+
+	$listBox->bind('<Double-Button-1>' => $chooseSub) ;
+	
+	$listBox->insert('end', @fList) ;
+
+	$topLevel->Button( text => "Okay", -command => $chooseSub, @Devel::ptkdb::button_font,
+										 )->pack(side => 'left', fill => 'both', -expand => 1) ;
+
+	$topLevel->Button( text => "Cancel", @Devel::ptkdb::button_font,
+										 -command => sub { destroy $topLevel ; } )->pack(side => 'left', fill => 'both', -expand => 1) ;
+} # end of DoOpen
+
+sub do_tabs {
+	my($tabs_str) ;
+	my($w, $result, $tabs_cfg) ;
+	require Tk::Dialog ;
+
+	$w = $DB::window->{'main_window'}->DialogBox(-title => "Tabs", -buttons => [qw/Okay Cancel/]) ;
+	
+	$tabs_cfg = $DB::window->{'text'}->cget(-tabs) ;
+
+	$tabs_str = join " ", @$tabs_cfg if $tabs_cfg ;
+
+	$w->add('Label', -text => 'Tabs:')->pack(-side => 'left') ;
+
+	$w->add('Entry', -textvariable => \$tabs_str)->pack(-side => 'left')->selectionRange(0,'end') ;
+
+	$result = $w->Show() ;
+
+	return unless $result eq 'Okay' ;
+
+ $DB::window->{'text'}->configure(-tabs => [ split /\s/, $tabs_str ]) ;
+}
+
+sub close_ptkdb_window {
+	my($self) = @_ ;
+
+	$DB::window->{'event'} = 'run' ;
+	$self->{current_file} = "" ; # force a file reset
+	$self->{'main_window'}->destroy ;
+	$self->{'main_window'} = undef ;
+}
+
+sub setup_menu_bar {
+	my ($self) = @_ ;
+	my $mw = $self->{main_window} ;
+	my ($mb, $items) ;
+	
+	#
+	# We have menu items/features that are not available if the Data::DataDumper module
+	# isn't present.	For any feature that requires it we add this option list.
+	#
+	my @dataDumperEnableOpt = ( state => 'disabled' ) unless $Devel::ptkdb::DataDumperAvailable ;
+
+
+	$self->{menu_bar} = $mw->Frame(-relief => 'raised', -borderwidth => '1')->pack(side => 'top', -fill => 'x') ;
+
+	$mb = $self->{menu_bar} ;
+
+	# file menu in menu bar
+
+	$items = [ [ 'command' => 'About...', -command => sub { $self->DoAbout() ; } ],
+						 "-",
+
+						 [ 'command' => 'Open', -accelerator => 'Alt+O',
+							 -underline => 0,
+							 -command => sub { $self->DoOpen() ; } ],
+
+						 [ 'command' => 'Save Config...', 
+							 -underline => 0,
+							 -command => \&DB::SaveState,
+							 @dataDumperEnableOpt ],
+
+						 [ 'command' => 'Restore Config...',
+							 -underline => 0,
+							 -command => \&DB::RestoreState,
+							 @dataDumperEnableOpt ],
+
+						 [ 'command' => 'Goto Line...',
+							 -underline => 0,
+							 -accelerator => 'Alt-g',
+							 -command => \&DB::RestoreState,
+							 @dataDumperEnableOpt ] ,
+
+						 [ 'command' => 'Find Text...',
+							 -accelerator => 'Ctrl-f',
+							 -underline => 0,
+							 -command => sub { $self->FindText() ; } ],
+
+						 [ 'command' => "Tabs...", -command => \&do_tabs ],
+
+						 "-",
+
+						 [ 'command' => 'Close Window and Run', -accelerator => 'Alt+W',
+							 -underline => 6, -command => sub { $self->close_ptkdb_window ; } ],
+						 
+						 [ 'command' => 'Quit...', -accelerator => 'Alt+Q',
+							 -underline => 0,
+							 -command => sub { exit } ]
+						 ] ;
+
+								 
+	$mw->bind('<Alt-g>' =>	sub { $self->GotoLine() ; }) ;
+	$mw->bind('<Control-f>' => sub { $self->FindText() ; }) ;
+	$mw->bind('<Control-r>' => \&Devel::ptkdb::DoRestart) ;
+	$mw->bind('<Alt-q>' => sub { $self->{'event'} = 'quit' } ) ;
+	$mw->bind('<Alt-w>' => sub { $self->close_ptkdb_window ; }) ;
+
+	$self->{file_menu_button} = $mb->Menubutton(text => 'File',
+																							underline => 0,
+																							-menuitems => $items
+																							)->pack(side =>, 'left',
+																											anchor => 'nw',
+																											'padx' => 2) ;
+
+	# Control Menu
+
+	my $runSub = sub { $DB::step_over_depth = -1 ; $self->{'event'} = 'run' } ;
+
+	my $runToSub = sub { $DB::window->{'event'} = 'run' if	$DB::window->SetBreakPoint(1) ; } ;
+
+	my $stepOverSub = sub { &DB::SetStepOverBreakPoint(0) ; 
+												$DB::single = 1 ; 
+												$DB::window->{'event'} = 'step' ; 
+												} ;
+	
+
+	my $stepInSub = sub { 
+	                    $DB::step_over_depth = -1 ; 
+	                    $DB::single = 1 ; 
+	                    $DB::window->{'event'} = 'step' ; } ;
+
+
+	my $returnSub =	 sub { 
+		&DB::SetStepOverBreakPoint(-1) ;
+		$self->{'event'} = 'run' ;
+	} ;
+
+
+	$items = [ [ 'command' => 'Run', -accelerator => 'Alt+r', underline => 0, -command => $runSub ],
+						 [ 'command' => 'Run To Here', -accelerator => 'Alt+t', -underline => 5, -command => $runToSub ],
+						 '-',
+						 [ 'command' =>  'Set Breakpoint', -underline => 4, -command => sub { $self->SetBreakPoint ; }, -accelerator => 'Ctrl-b' ],
+						 [ 'command' => 'Clear Breakpoint', -command => sub { $self->UnsetBreakPoint } ],
+						 [ 'command' => 'Clear All Breakpoints', -underline => 6, -command => sub {			
+						 $DB::window->removeAllBreakpoints($DB::window->{current_file}) ;
+							 &DB::clearalldblines() ;
+						 } ],
+						 '-',
+						 [ 'command' => 'Step Over', -accelerator => 'Alt+N', -underline => 0, -command => $stepOverSub ],
+						 [ 'command' => 'Step In', -accelerator => 'Alt+S', -underline => 5, -command => $stepInSub ],
+						 [ 'command' => 'Return', -accelerator => 'Alt+U', -underline => 3, -command => $returnSub ],
+						 '-',
+						 [ 'command' => 'Restart...', -accelerator => 'Ctrl-r', -underline => 0, -command => \&Devel::ptkdb::DoRestart ],
+						 '-',
+						 [ 'checkbutton' => 'Stop On Warning', -variable => \$DB::ptkdb::stop_on_warning, -command => \&set_stop_on_warning ]
+
+						 
+							 ] ; # end of control menu items
+
+	
+	$self->{control_menu_button} = $mb->Menubutton(text => 'Control',
+																								 -underline => 0,
+																								 -menuitems => $items,
+																								 )->pack(side =>, 'left',
+																												 'padx' => 2) ;
+
+
+	$mw->bind('<Alt-r>' => $runSub) ;
+	$mw->bind('<Alt-t>', $runToSub) ;
+	$mw->bind('<Control-b>', sub { $self->SetBreakPoint ; }) ;
+
+	for( @Devel::ptkdb::step_over_keys ) {
+		$mw->bind($_ => $stepOverSub );
+	}
+
+	for( @Devel::ptkdb::step_in_keys ) {
+		$mw->bind($_ => $stepInSub );
+	}
+
+	for( @Devel::ptkdb::return_keys ) {
+		$mw->bind($_ => $returnSub );
+	}
+
+	# Data Menu
+
+	$items = [ [ 'command' => 'Enter Expression', -accelerator => 'Alt+E', -command => sub { $self->EnterExpr() } ],
+						 [ 'command' => 'Delete Expression', -accelerator => 'Ctrl+D', -command => sub { $self->deleteExpr() } ],
+						 [ 'command' => 'Delete All Expressions',  -command => sub { 
+																			 $self->deleteAllExprs() ;
+																			 $self->{'expr_list'} = [] ; # clears list by dropping ref to it, replacing it with a new one	 
+																		 } ],
+						 '-',
+						 [ 'command' => 'Expression Eval Window...', -accelerator => 'F8', -command => sub { $self->setupEvalWindow() ; } ],
+						 [ 'checkbutton' => "Use DataDumper for Eval Window?", -variable => \$Devel::ptkdb::useDataDumperForEval, @dataDumperEnableOpt ]
+							] ;
+
+
+	$self->{data_menu_button} = $mb->Menubutton(text => 'Data', -menuitems => $items,
+																							underline => 0,
+																							)->pack(side => 'left',
+																											'padx' => 2) ;
+
+	$mw->bind('<Alt-e>' => sub { $self->EnterExpr() } ) ;
+	$mw->bind('<Control-d>' => sub { $self->deleteExpr() } );
+	$mw->bind('<F8>', sub { $self->setupEvalWindow() ; }) ;
+	#
+	# Stack menu
+	#
+	$self->{stack_menu} = $mb->Menubutton(text => 'Stack',
+																				underline => 2,
+																				)->pack(side => 'left',
+																								'padx' => 2) ;
+
+	#
+	# Bookmarks menu
+	#
+	$self->{bookmarks_menu} = $mb->Menubutton('text' => 'Bookmarks',
+																						underline => 0,
+																						@dataDumperEnableOpt
+																						)->pack(-side => 'left',
+																										'padx' => 2) ;
+	$self->setup_bookmarks_menu() ;
+
+	#
+	# Windows Menu
+	#
+	my($bsub) = sub { $self->{'text'}->focus() } ;
+	my($csub) = sub { $self->{'quick_entry'}->focus() } ;
+	my($dsub) = sub { $self->{'entry'}->focus() } ;
+
+	$items = [ [ 'command' => 'Code Pane', -accelerator => 'Alt+0', -command => $bsub ],
+						 [ 'command' => 'Quick Entry', -accelerator => 'F9', -command => $csub ],
+						 [ 'command' => 'Expr Entry', -accelerator => 'F11', -command => $dsub ]
+						 ] ;
+
+	$mb->Menubutton('text' => 'Windows', -menuitems => $items
+									)->pack(-side => 'left',
+													-padx => 2) ;
+
+	$mw->bind('<Alt-0>', $bsub) ;
+	$mw->bind('<F9>', $csub) ;
+	$mw->bind('<F11>', $dsub) ;
+
+	#
+	# Bar for some popular controls
+	#
+
+	$self->{button_bar} = $mw->Frame()->pack(side => 'top') ;
+
+	$self->{stepin_button} = $self->{button_bar}->Button(-text, => "Step In", @Devel::ptkdb::button_font,
+																											 -command => $stepInSub) ;
+	$self->{stepin_button}->pack(-side => 'left') ;
+
+	$self->{stepover_button} = $self->{button_bar}->Button(-text, => "Step Over", @Devel::ptkdb::button_font,
+																												 -command => $stepOverSub) ;
+	$self->{stepover_button}->pack(-side => 'left') ;
+
+	$self->{return_button} = $self->{button_bar}->Button(-text, => "Return", @Devel::ptkdb::button_font,
+																											 -command => $returnSub) ;
+	$self->{return_button}->pack(-side => 'left') ;
+
+	$self->{run_button} = $self->{button_bar}->Button(-background => 'green', -text, => "Run", @Devel::ptkdb::button_font,
+																										-command => $runSub) ;
+	$self->{run_button}->pack(-side => 'left') ;
+
+	$self->{run_to_button} = $self->{button_bar}->Button(-text, => "Run To", @Devel::ptkdb::button_font,
+																											 -command => $runToSub) ;
+	$self->{run_to_button}->pack(-side => 'left') ;
+
+	$self->{breakpt_button} = $self->{button_bar}->Button(-text, => "Break", @Devel::ptkdb::button_font,
+																												-command => sub { $self->SetBreakPoint ; } ) ;
+	$self->{breakpt_button}->pack(-side => 'left') ;
+
+	push @{$self->{DisableOnLeave}}, @$self{'stepin_button', 'stepover_button', 'return_button', 'run_button', 'run_to_button', 'breakpt_button'} ;
+	
+} # end of setup_menu_bar
+
+sub edit_bookmarks {
+	my ($self) = @_ ;
+
+	my ($top) =	 $self->{main_window}->Toplevel(-title => "Edit Bookmarks") ;
+	
+	my $list = $top->Scrolled('Listbox', -selectmode => 'multiple')->pack(-side => 'top', -fill => 'both', -expand => 1) ;
+	
+	my $deleteSub = sub {
+		my $cnt = 0 ;
+		for( $list->curselection ) {
+			$list->delete($_ - $cnt++) ;
+		}
+	} ;
+
+	my $okaySub = sub {
+		$self->{'bookmarks'} = [ $list->get(0, 'end') ]	 ; # replace the bookmarks
+	} ;
+	
+	my $frm = $top->Frame()->pack(-side => 'top', -fill => 'x', -expand => 1 ) ;
+	
+	my $deleteBtn = $frm->Button(-text => 'Delete', -command => $deleteSub)->pack(-side => 'left', -fill => 'x', -expand => 1 ) ;
+	my $cancelBtn = $frm->Button(-text => 'Cancel', -command => sub { destroy $top ; })->pack(-side	 =>'left', -fill => 'x', -expand => 1 ) ;
+	my $dismissBtn = $frm->Button(-text => 'Okay', -command => $okaySub)->pack(-side => 'left', -fill => 'x', -expand => 1 ) ;
+	
+	$list->insert('end', @{$self->{'bookmarks'}}) ;
+
+} # end of edit_bookmarks
+
+sub setup_bookmarks_menu {
+	my ($self) = @_ ;
+
+	#
+	# "Add bookmark" item
+	#
+	my $bkMarkSub = sub { $self->add_bookmark() ; } ;
+
+	$self->{'bookmarks_menu'}->command(-label => "Add Bookmark",
+																		 -accelerator => 'Alt+k',
+																		 -command => $bkMarkSub
+																		 ) ;
+
+	$self->{'main_window'}->bind('<Alt-k>', $bkMarkSub) ;
+
+	$self->{'bookmarks_menu'}->command(-label => "Edit Bookmarks", 
+																		 -command => sub { $self->edit_bookmarks() } ) ;
+
+	$self->{'bookmarks_menu'}->separator() ;
+
+	#
+	# Check to see if there is a bookmarks file
+	#
+	return unless -e $self->{BookMarksPath} && -r $self->{BookMarksPath} ;
+	
+	use vars qw($ptkdb_bookmarks) ;
+	local($ptkdb_bookmarks) ; # ref to hash of bookmark entries
+
+	do $self->{BookMarksPath} ; # eval the file
+
+	$self->add_bookmark_items(@$ptkdb_bookmarks) ;
+
+} # end of setup_bookmarks_menu
+
+#
+# $item = "$fname:$lineno"
+#
+sub add_bookmark_items {
+	my($self, @items) = @_ ;
+	my($menu) = ( $self->{'bookmarks_menu'} ) ;
+
+	$self->{'bookmarks_changed'} = 1 ;
+
+	for( @items ) {
+		my $item = $_ ;
+		$menu->command( -label => $_,
+										-command => sub { $self->bookmark_cmd($item) }) ;
+		push @{$self->{'bookmarks'}}, $item ;
+	}
+} # end of add_bookmark_item
+
+#
+# Invoked from the "Add Bookmark" command
+#
+sub add_bookmark {
+	my($self) = @_ ;
+	
+	my $line = $self->get_lineno() ;
+	my $fname = $self->{'current_file'} ;
+	$self->add_bookmark_items("$fname:$line") ;
+
+} # end of add_bookmark
+
+#
+# Command executed when someone selects
+# a bookmark
+#
+sub bookmark_cmd {
+	my ($self, $item) = @_ ;
+
+	$item =~ /(.*):([0-9]+)$/ ;
+
+	$self->set_file($1,$2) ;
+
+} # end of bookmark_cmd
+
+sub save_bookmarks {
+	my($self, $pathName) = @_ ;
+
+	return unless $Devel::ptkdb::DataDumperAvailable ; # we can't save without the data dumper
+	local(*F) ;
+
+	eval {
+		open F, ">$pathName" || die "open failed" ;
+		my $d = Data::Dumper->new([ $self->{'bookmarks'} ], 
+															[	 'ptkdb_bookmarks' ]) ;
+
+		$d->Indent(2) ; # make it more editable for people	
+
+		my $str ;
+		if( $d->can('Dumpxs') ) {
+			$str = $d->Dumpxs() ;
+		}
+		else {
+			$str = $d->Dump() ;
+		}
+
+		print F $str || die "outputing bookmarks failed" ;
+		close(F) ;
+	} ;
+
+	if( $@ ) {
+		$self->DoAlert("Couldn't save bookmarks file $@") ;
+		return ;
+	}
+
+} # end of save_bookmarks 
+
+#
+# This is our callback from a double click in our
+# HList.	A click in an expanded item will delete
+# the children beneath it, and the next time it
+# updates, it will only update that entry to that
+# depth.	If an item is 'unexpanded' such as 
+# a hash or a list, it will expand it one more
+# level.	How much further an item is expanded is
+# controled by package variable $Devel::ptkdb::add_expr_depth
+#
+sub expr_expand {
+	my ($path) = @_ ;
+	my $hl = $DB::window->{'data_list'} ;
+	my ($parent, $root, $index, @children, $depth) ;
+
+	$parent = $path ;
+	$root = $path ;
+	$depth = 0 ;
+
+	for( $root = $path ; defined $parent && $parent ne "" ; $parent = $hl->infoParent($root) ) {
+		$root = $parent ;
+		$depth += 1 ;
+	} #end of root search
+
+	#
+	# Determine the index of the root of our expression
+	#
+	$index = 0 ;
+	for( @{$DB::window->{'expr_list'}} ) {
+		last if $_->{'expr'} eq $root ;
+		$index += 1 ;
+	}
+
+	#
+	# if we have children we're going to delete them
+	#
+
+	@children = $hl->infoChildren($path) ;
+
+	if( scalar @children > 0 ) {
+
+		$hl->deleteOffsprings($path) ;
+
+	$DB::window->{'expr_list'}->[$index]->{'depth'} = $depth - 1 ; # adjust our depth
+	}
+	else {
+		#
+		# Delete the existing tree and insert a new one
+		#
+		$hl->deleteEntry($root) ;
+		$hl->add($root, -at => $index) ;
+	$DB::window->{'expr_list'}->[$index]->{'depth'} += $Devel::ptkdb::add_expr_depth ;
+		#
+		# Force an update on our expressions
+		#
+	$DB::window->{'event'} = 'update' ;
+	}
+} # end of expr_expand
+
+sub line_number_from_coord {
+	my($txtWidget, $coord) = @_ ;
+	my($index) ;
+	
+	$index = $txtWidget->index($coord) ;
+
+	# index is in the format of lineno.column
+
+	$index =~ /([0-9]*)\.([0-9]*)/o ;
+
+	#
+	# return a list of (col, line).	 Why
+	# backwards?	
+	#
+
+	return ($2 ,$1) ;
+	
+} # end of line_number_from_coord
+
+#
+# It may seem as if $txtWidget and $self are
+# erroneously reversed, but this is a result
+# of the calling syntax of the text-bind callback.	
+#
+sub set_breakpoint_tag {
+	my($txtWidget, $self, $coord, $value) = @_ ;
+	my($idx) ;
+
+	$idx = line_number_from_coord($txtWidget, $coord) ;
+
+	$self->insertBreakpoint($self->{'current_file'}, $idx, $value) ;
+
+} # end of set_breakpoint_tag
+
+sub clear_breakpoint_tag {
+	my($txtWidget, $self, $coord) = @_ ;
+	my($idx) ;
+
+	$idx = line_number_from_coord($txtWidget, $coord) ;
+	
+	$self->removeBreakpoint($self->{'current_file'}, $idx) ;
+
+} # end of clear_breakpoint_tag
+
+sub change_breakpoint_tag {
+	my($txtWidget, $self, $coord, $value) = @_ ;
+	my($idx, $brkPt, @tagSet) ;
+
+	$idx = line_number_from_coord($txtWidget, $coord) ;
+
+	#
+	# Change the value of the breakpoint
+	#
+	@tagSet = ( "$idx.0", "$idx.$Devel::ptkdb::linenumber_length" ) ;
+
+	$brkPt = &DB::getdbline($self->{'current_file'}, $idx + $self->{'line_offset'}) ;
+	return unless $brkPt ;
+
+	#
+	# Check the breakpoint tag
+	#
+
+	if ( $txtWidget ) {
+		$txtWidget->tagRemove('breaksetLine', @tagSet ) ;
+		$txtWidget->tagRemove('breakdisabledLine', @tagSet ) ;
+	}
+
+	$brkPt->{'value'} = $value ;
+	
+	if ( $txtWidget ) {
+		if ( $brkPt->{'value'} ) {
+			$txtWidget->tagAdd('breaksetLine', @tagSet ) ;
+		}
+		else {
+			$txtWidget->tagAdd('breakdisabledLine', @tagSet ) ;		 
+		}
+	}
+
+} # end of change_breakpoint_tag
+
+#
+# God Forbid anyone comment something complex and tightly optimized.
+#
+#	 We can get a list of the subroutines from the interpreter
+# by querrying the *DB::sub typeglob:	 keys %DB::sub
+#
+# The list appears broken down by module:
+#
+#	 main::BEGIN
+#	 main::mySub
+#	 main::otherSub
+#	 Tk::Adjuster::Mapped
+#	 Tk::Adjuster::Packed
+#	 Tk::Button::BEGIN
+#	 Tk::Button::Enter
+#	 
+#	 We would like to break this list down into a heirarchy.
+#
+#					main														 Tk
+#	 |				|				|												|
+# BEGIN		mySub	 OtherSub					 |								 |
+#																Adjuster					 Button 
+#															|					|				 |				|
+#														Mapped		Packed	 BEGIN		Enter
+#
+#
+#	 We translate this list into a heirarchy of hashes(say three times fast).
+# We take each entry and split it into elements.	Each element is a leaf in the tree.	 
+# We traverse the tree with the inner for loop.	 
+# With each branch we check to see if it already exists or
+# we create it.	 When we reach the last element, this becomes our entry.
+# 
+
+#
+# An incoming list is potentially 'large' so we
+# pass in the ref to it instead.
+#
+#	 New entries can be inserted by providing a $topH
+# hash ref to an existing tree.	 
+#
+sub tree_split {
+	my ($listRef, $separator, $topH) = @_ ; 
+	my ($h, $list_elem) ;
+
+	$topH = {} unless $topH ;
+
+	foreach $list_elem ( @$listRef ) {
+		$h = $topH ;
+		for( split /$separator/o, $list_elem ) { # Tk::Adjuster::Mapped	 -> ( Tk Adjuster Mapped )
+			$h->{$_} or $h->{$_} = {} ; # either we have an entry for this OR we create one
+			$h = $h->{$_} ;
+		}
+		@$h{'name', 'path'} = ($_, $list_elem) ; # the last leaf is our entry
+	} # end of tree_split loop
+
+	return $topH ;
+
+} # end of tree_split
+
+#
+# callback executed when someone double clicks
+# an entry in the 'Subs' Tk::Notebook page.
+#
+sub sub_list_cmd {
+	my ($self, $path) = @_ ;
+	my ($h) ;
+	my $sub_list = $self->{'sub_list'} ;
+
+	if (	$sub_list->info('children', $path)	) {
+		#
+		# Delete the children
+		#
+		$sub_list->deleteOffsprings($path) ;
+		return ;
+	}
+
+	#
+	# split the path up into elements
+	# end descend through the tree.
+	#
+	$h = $Devel::ptkdb::subs_tree ; 
+	for ( split /\./o, $path ) {
+		$h = $h->{$_} ; # next level down
+	}
+
+	#
+	# if we don't have a 'name' entry we
+	# still have levels to decend through.
+	#
+	if ( !exists $h->{'name'} ) {
+		#
+		# Add the next level paths
+		#		
+		for ( sort keys %$h ) {
+
+			if ( exists $h->{$_}->{'path'} ) {
+				$sub_list->add($path . '.' . $_, -text => $h->{$_}->{'path'}) ;
+			}
+			else {
+				$sub_list->add($path . '.' . $_, -text => $_) ;
+			}
+		}
+		return ;
+	}
+
+ $DB::sub{$h->{'path'}} =~ /(.*):([0-9]+)-[0-9]+$/o ; # file name will be in $1, line number will be in $2 */
+
+	$self->set_file($1, $2) ;
+
+} # end of sub_list_cmd
+
+sub fill_subs_page {
+	my($self) = @_ ;
+
+	$self->{'sub_list'}->delete('all') ; # clear existing entries
+
+	my @list = keys %DB::sub ;
+
+ $Devel::ptkdb::subs_tree = tree_split(\@list, "::") ;
+
+	# setup to level of list
+
+	for ( sort keys %$Devel::ptkdb::subs_tree ) {
+		$self->{'sub_list'}->add($_, -text => $_) ;
+	} # end of top level loop
+}
+
+sub setup_subs_page {
+	my($self) = @_ ;
+
+	$self->{'subs_page_activated'} = 1 ;
+
+	$self->{'sub_list'} = $self->{'subs_page'}->Scrolled('HList',	 -command => sub { $self->sub_list_cmd(@_) ; } ) ;
+
+	$self->fill_subs_page() ;
+
+	$self->{'sub_list'}->pack(side => 'left', fill => 'both', expand => 1
+														) ;
+
+	$self->{'subs_list_cnt'} = scalar keys %DB::sub ;
+
+
+} # end of setup_subs_page
+
+sub setup_search_panel {
+	my ($self, $parent, @packArgs) = @_ ;
+	my ($frm, $srchBtn, $regexBtn, $entry) ;
+
+	$frm = $parent->Frame() ;
+
+	$frm->Button(-text => 'Goto', -command => sub { $self->DoGoto($entry) })->pack(side => 'left') ;
+	$srchBtn = $frm->Button(-text => 'Search', -command => sub { $self->FindSearch($entry, $srchBtn, 0) ; }
+													)->pack(side => 'left' ) ;
+
+	$regexBtn = $frm->Button(-text => 'Regex',
+													 -command => sub { $self->FindSearch($entry, $regexBtn, 1) ; }
+													 )->pack(side => 'left',
+																	 ) ;
+
+
+	$entry = $frm->Entry(width => 50)->pack(side => 'left', fill => 'both', expand => 1) ;
+
+	$frm->pack(@packArgs) ;
+
+} # end of setup search_panel
+
+sub setup_breakpts_page {
+	my ($self) = @_ ;
+	require Tk::Table ;
+
+	$self->{'breakpts_page'} = $self->{'notebook'}->add("brkptspage", -label => "BrkPts") ;
+
+	$self->{'breakpts_table'} = $self->{'breakpts_page'}->Table(-columns => 1, -scrollbars => 'se')->
+			pack(side => 'top', fill => 'both', expand => 1
+					 )	 ;
+
+	$self->{'breakpts_table_data'} = { } ; # controls addressed by "fname:lineno"
+
+} # end of setup_breakpts_page
+
+sub setup_frames {
+	my ($self) = @_ ;
+	my $mw = $self->{'main_window'} ;
+	my ($txt, $place_holder, $frm) ;
+	require Tk::ROText ;
+	require Tk::NoteBook ;
+	require Tk::HList ;
+	require Tk::Balloon ;
+	require Tk::Adjuster ;
+
+	# get the side that we want to put the code pane on
+	
+	my($codeSide) = $ENV{'PTKDB_CODE_SIDE'} || $mw->optionGet("codeside", "") || 'left' ;
+
+	
+
+	$mw->update ; # force geometry manager to map main_window
+	$frm = $mw->Frame(-width => $mw->reqwidth()) ; # frame for our code pane and search controls
+
+	$self->setup_search_panel($frm, side => 'top', fill => 'x') ;
+
+	#
+	# Text window for the code of our currently viewed file
+	#
+	$self->{'text'} = $frm->Scrolled('ROText',
+																	 -wrap => "none",
+																 @Devel::ptkdb::scrollbar_cfg,
+																 @Devel::ptkdb::code_text_font
+																	 ) ;
+
+
+	$txt = $self->{'text'} ;
+	for( $txt->children ) {
+		next unless (ref $_) =~ /ROText$/ ;
+		$self->{'text'} = $_ ;
+		last ;
+	}
+
+	$frm->packPropagate(0) ;
+	$txt->packPropagate(0) ;
+
+	$frm->packAdjust(side => $codeSide, fill => 'both', expand => 1) ;
+	$txt->pack(side => 'left', fill => 'both', expand => 1) ;
+
+	# $txt->form(-top => [ $self->{'menu_bar'} ], -left => '%0', -right => '%50') ;
+	# $frm->form(-top => [ $self->{'menu_bar'} ], -left => '%50', -right => '%100') ;
+
+	$self->configure_text() ;
+
+	#
+	# Notebook
+	#
+
+	$self->{'notebook'} = $mw->NoteBook() ;
+	$self->{'notebook'}->packPropagate(0) ;
+	$self->{'notebook'}->pack(side => $codeSide, fill => 'both', -expand => 1) ;
+
+	#
+	# an hlist for the data entries
+	#
+	$self->{'data_page'} = $self->{'notebook'}->add("datapage", -label => "Exprs") ;
+
+	#
+	# frame, entry and label for quick expressions
+	#
+	my $frame = $self->{'data_page'}->Frame()->pack(side => 'top', fill => 'x') ;
+	
+	my $label = $frame->Label('text' => "Quick Expr:")->pack(side => 'left') ;
+	
+	$self->{'quick_entry'} = $frame->Entry()->pack(side => 'left', fill => 'x', -expand => 1) ;
+
+	$self->{'quick_entry'}->bind('<Return>', sub { $self->QuickExpr() ; } ) ;
+	
+
+	#
+	# Entry widget for expressions and breakpoints
+	#
+	$frame = $self->{'data_page'}->Frame()->pack(side => 'top', fill => 'x') ;
+
+	$label = $frame->Label('text' => "Enter Expr:")->pack(side => 'left') ;
+
+	$self->{'entry'} = $frame->Entry()->pack(side => 'left', fill => 'x', -expand => 1) ;
+
+	$self->{'entry'}->bind('<Return>', sub { $self->EnterExpr() }) ;
+
+	#
+	# Hlist for data expressions
+	#
+
+
+	$self->{data_list} = $self->{'data_page'}->Scrolled('HList',
+																										@Devel::ptkdb::scrollbar_cfg, 
+																											separator => $Devel::ptkdb::pathSep,
+																										@Devel::ptkdb::expression_text_font,
+																											-command => \&Devel::ptkdb::expr_expand,
+																											-selectmode => 'multiple'
+																											) ;
+
+	$self->{data_list}->pack(side => 'top', fill => 'both', expand => 1
+													 ) ;
+
+
+	$self->{'subs_page_activated'} = 0 ;
+	$self->{'subs_page'} = $self->{'notebook'}->add("subspage", -label => "Subs", -createcmd => sub { $self->setup_subs_page }) ;
+
+	$self->setup_breakpts_page() ;		
+
+} # end of setup_frames
+
+
+
+sub configure_text {
+	my($self) = @_ ;
+	my($txt, $mw) = ($self->{'text'}, $self->{'main_window'}) ;
+	my($place_holder) ;
+
+	$self->{'expr_balloon'} = $txt->Balloon();
+	$self->{'balloon_expr'} = ' ' ; # initial expression
+
+	# If Data::Dumper is available setup a dumper for the balloon
+	
+	if ( $Devel::ptkdb::DataDumperAvailable ) {
+		$self->{'balloon_dumper'} = new Data::Dumper([$place_holder]) ;
+		$self->{'balloon_dumper'}->Terse(1) ;
+		$self->{'balloon_dumper'}->Indent($Devel::ptkdb::eval_dump_indent) ;
+
+		$self->{'quick_dumper'} = new Data::Dumper([$place_holder]) ;
+		$self->{'quick_dumper'}->Terse(1) ;
+		$self->{'quick_dumper'}->Indent(0) ;
+	}
+	
+	$self->{'expr_ballon_msg'} = ' ' ;
+	
+	$self->{'expr_balloon'}->attach($txt, -initwait => 300,
+																	-msg => \$self->{'expr_ballon_msg'},
+																	-balloonposition => 'mouse',
+																	-postcommand => \&Devel::ptkdb::balloon_post,
+																	-motioncommand => \&Devel::ptkdb::balloon_motion ) ;
+	
+	# tags for the text
+	
+	my @stopTagConfig = ( -foreground => 'white', -background	 => $mw->optionGet("stopcolor", "background") || $ENV{'PTKDB_STOP_TAG_COLOR'} || 'blue' ) ;
+	
+	my $stopFnt = $mw->optionGet("stopfont", "background") || $ENV{'PTKDB_STOP_TAG_FONT'} ;
+	push @stopTagConfig, ( -font => $stopFnt ) if $stopFnt ; # user may not have specified a font, if not, stay with the default
+	
+	$txt->tagConfigure('stoppt', @stopTagConfig) ;
+	$txt->tagConfigure('search_tag', "-background" => $mw->optionGet("searchtagcolor", "background") || "green") ;
+	
+	$txt->tagConfigure("breakableLine", -overstrike => 0) ;
+	$txt->tagConfigure("nonbreakableLine", -overstrike => 1) ;
+	$txt->tagConfigure("breaksetLine", -background => $mw->optionGet("breaktagcolor", "background") || $ENV{'PTKDB_BRKPT_COLOR'} || 'red') ;
+	$txt->tagConfigure("breakdisabledLine", -background => $mw->optionGet("disabledbreaktagcolor", "background") || $ENV{'PTKDB_DISABLEDBRKPT_COLOR'} || 'green') ;
+	
+	$txt->tagBind("breakableLine", '<Button-1>', [ \&Devel::ptkdb::set_breakpoint_tag, $self, Ev('@'), 1 ]	) ;
+	$txt->tagBind("breakableLine", '<Shift-Button-1>', [ \&Devel::ptkdb::set_breakpoint_tag, $self, Ev('@'), 0 ]	) ;
+	
+	$txt->tagBind("breaksetLine", '<Button-1>',	 [ \&Devel::ptkdb::clear_breakpoint_tag, $self, Ev('@') ]	 ) ;
+	$txt->tagBind("breaksetLine", '<Shift-Button-1>',	 [ \&Devel::ptkdb::change_breakpoint_tag, $self, Ev('@'), 0 ]	 ) ;
+	
+	$txt->tagBind("breakdisabledLine", '<Button-1>', [ \&Devel::ptkdb::clear_breakpoint_tag, $self, Ev('@') ]	 ) ;
+	$txt->tagBind("breakdisabledLine", '<Shift-Button-1>', [ \&Devel::ptkdb::change_breakpoint_tag, $self, Ev('@'), 1 ]	 ) ;
+	
+} # end of configure_text
+
+
+sub setup_options {
+	my ($self) = @_ ;
+	my $mw = $self->{main_window} ;
+
+	return unless $mw->can('appname') ;
+	
+	$mw->appname("ptkdb") ;
+	$mw->optionAdd("stopcolor" => 'cyan', 60 ) ;
+	$mw->optionAdd("stopfont" => 'fixed', 60 ) ;
+	$mw->optionAdd("breaktag" => 'red', 60 ) ;
+	$mw->optionAdd("searchtagcolor" => 'green') ;
+	
+	$mw->optionClear ; #	necessary to reload xresources
+
+} # end of setup_options
+
+sub DoAlert {
+	my($self, $msg, $title) = @_ ;
+	my($dlg) ;
+	my $okaySub = sub {
+		destroy $dlg ;
+	} ;
+
+	$dlg = $self->{main_window}->Toplevel(-title => $title || "Alert", -overanchor => 'cursor') ;
+
+	$dlg->Label( 'text' => $msg )->pack( side => 'top' ) ;
+
+	$dlg->Button( 'text' => "Okay", -command => $okaySub )->pack( side => 'top' )->focus	 ;
+	$dlg->bind('<Return>', $okaySub) ;
+
+} # end of DoAlert
+
+sub simplePromptBox {
+	my ($self, $title, $defaultText, $okaySub, $cancelSub) = @_ ;
+	my ($top, $entry, $okayBtn) ;
+
+	$top = $self->{main_window}->Toplevel(-title => $title, -overanchor => 'cursor' ) ;
+
+ $Devel::ptkdb::promptString = $defaultText ;
+
+	$entry = $top->Entry('-textvariable' => 'Devel::ptkdb::promptString')->pack('side' => 'top', fill => 'both', -expand => 1) ;
+	
+	
+	$okayBtn = $top->Button( text => "Okay", @Devel::ptkdb::button_font, -command => sub {	&$okaySub() ; $top->destroy ;}
+													 )->pack(side => 'left', fill => 'both', -expand => 1) ;
+	
+	$top->Button( text => "Cancel", -command => sub { &$cancelSub() if $cancelSub ; $top->destroy() }, @Devel::ptkdb::button_font,
+								)->pack(side => 'left', fill => 'both', -expand => 1) ;
+	
+	$entry->icursor('end') ;
+	
+	$entry->selectionRange(0, 'end') if $entry->can('selectionRange') ; # some win32 Tk installations can't do this
+
+	$entry->focus() ;
+
+	return $top ;
+	
+} # end of simplePromptBox
+
+sub get_entry_text {
+	my($self) = @_ ;
+	
+	return $self->{entry}->get() ; # get the text in the entry
+} # end of get_entry_text
+
+
+#
+# Clear any text that is in the entry field.	If there
+# was any text in that field return it.	 If there
+# was no text then return any selection that may be active.	 
+#
+sub clear_entry_text {
+	my($self) = @_ ;
+	my $str =	 $self->{'entry'}->get() ;
+	$self->{'entry'}->delete(0, 'end') ;
+
+	#
+	# No String
+	# Empty String
+	# Or a string that is only whitespace
+	#
+	if( !$str || $str eq "" || $str =~ /^\s+$/ ) {
+		#
+		# If there is no string or the string is just white text
+		# Get the text in the selction( if any)
+		# 
+		if( $self->{'text'}->tagRanges('sel') ) { # check to see if 'sel' tag exists (return undef value)
+			$str = $self->{'text'}->get("sel.first", "sel.last") ; # get the text between the 'first' and 'last' point of the sel (selection) tag
+		}
+		# If still no text, bring the focus to the entry
+		elsif( !$str || $str eq "" || $str =~ /^\s+$/ ) {
+			$self->{'entry'}->focus() ;
+			$str = "" ;
+		}
+	}
+	#
+	# Erase existing text
+	#
+	return $str ;
+} # end of clear_entry_text
+
+sub brkPtCheckbutton {
+	my ($self, $fname, $idx, $brkPt) = @_ ;
+	my ($widg) ;
+
+	change_breakpoint_tag($self->{'text'}, $self, "$idx.0", $brkPt->{'value'}) if $fname eq $self->{'current_file'} ;
+
+} # end of brkPtCheckbutton
+
+#
+# insert a breakpoint control into our breakpoint list.	 
+# returns a handle to the control
+#
+#	 Expression, if defined, is to be evaluated at the breakpoint
+# and execution stopped if it is non-zero/defined.
+#
+# If action is defined && True then it will be evalled
+# before continuing.	
+#
+sub insertBreakpoint {
+	my ($self, $fname, @brks) = @_ ;
+	my ($btn, $cnt, $item) ;
+
+	my($offset) ;
+	local(*dbline) = $main::{'_<' . $fname} ;
+
+	$offset = $dbline[1] =~ /use\s+.*Devel::_?ptkdb/ ? 1 : 0 ;
+
+	while( @brks ) {
+		my($index, $value, $expression) = splice @brks, 0, 3 ; # take args 3 at a time
+
+		my $brkPt = {} ; 
+		my $txt = &DB::getdbtextline($fname, $index) ;
+		@$brkPt{'type', 'line',	 'expr',			'value', 'fname', 'text'} =
+				('user',	 $index, $expression, $value,		$fname,	 "$txt") ;
+
+		&DB::setdbline($fname, $index + $offset, $brkPt) ;
+		$self->add_brkpt_to_brkpt_page($brkPt) ;
+
+		next unless $fname eq $self->{'current_file'} ;
+
+		$self->{'text'}->tagRemove("breakableLine", "$index.0", "$index.$Devel::ptkdb::linenumber_length") ;		
+		$self->{'text'}->tagAdd($value ? "breaksetLine" : "breakdisabledLine",	"$index.0", "$index.$Devel::ptkdb::linenumber_length") ;
+	} # end of loop
+} # end of insertBreakpoint
+
+sub add_brkpt_to_brkpt_page { 
+	my($self, $brkPt) = @_ ;
+	my($btn, $fname, $index, $frm, $upperFrame, $lowerFrame) ; 
+	my ($row, $btnName, $width) ;
+	# 
+	# Add the breakpoint to the breakpoints page 
+	# 
+	($fname, $index) = @$brkPt{'fname', 'line'} ; 
+	return if exists $self->{'breakpts_table_data'}->{"$fname:$index"} ; 
+	$self->{'brkPtCnt'} += 1 ; 
+
+	$btnName = $fname ;
+	$btnName =~ s/.*\/([^\/]*)$/$1/o ; 
+
+	# take the last leaf of the pathname 
+	
+	$frm = $self->{'breakpts_table'}->Frame(-relief => 'raised') ; 
+	$upperFrame = $frm->Frame()->pack('side' => 'top', '-fill' => 'x', 'expand' => 1) ; 
+
+	
+	$btn = $upperFrame->Checkbutton(-text => "$btnName:$index",
+																	-variable => \$brkPt->{'value'}, # CAUTION value tracking
+																	-command => sub { $self->brkPtCheckbutton($fname, $index, $brkPt) }) ;
+
+	$btn->pack(side => 'left') ;
+
+	$btn = $upperFrame->Button(-text => "Delete", -command => sub { $self->removeBreakpoint($fname, $index) ; } ) ;
+	$btn->pack('side' => 'left', -fill => 'x', -expand => 1) ;
+	
+	$btn = $upperFrame->Button(-text => "Goto", -command => sub { $self->set_file($fname, $index) ; } ) ;
+	$btn->pack('side' => 'left', -fill => 'x', -expand => 1) ;
+
+	$lowerFrame = $frm->Frame()->pack('side' => 'top', '-fill' => 'x', 'expand' => 1) ;
+
+	$lowerFrame->Label(-text => "Cond:")->pack('side' => 'left') ;
+	
+	$btn = $lowerFrame->Entry(-textvariable => \$brkPt->{'expr'}) ;
+	$btn->pack('side' => 'left', fill => 'x', -expand => 1) ;
+	
+	$frm->pack(side => 'top', fill => 'x', -expand => 1) ;
+
+	$row = pop @{$self->{'brkPtSlots'}} or $row = $self->{'brkPtCnt'} ;
+
+	$self->{'breakpts_table'}->put($row, 1, $frm) ;
+	
+	$self->{'breakpts_table_data'}->{"$fname:$index"}->{'frm'} = $frm ;
+	$self->{'breakpts_table_data'}->{"$fname:$index"}->{'row'} = $row ;
+
+	$self->{'main_window'}->update ;
+
+	$width = $frm->width ;
+
+	if ( $width > $self->{'breakpts_table'}->width ) {
+		$self->{'notebook'}->configure(-width => $width) ;
+	}
+	
+} # end of add_brkpt_to_brkpt_page
+
+sub remove_brkpt_from_brkpt_page {
+	my($self, $fname, $idx) = @_ ;
+	my($table) ;
+
+	$table = $self->{'breakpts_table'} ;
+
+	# Delete the breakpoint control in the breakpoints window
+
+	$table->put($self->{'breakpts_table_data'}->{"$fname:$idx"}->{'row'}, 1) ; # delete?
+
+	#
+	# Add this now empty slot to the list of ones we have open
+	#
+
+	push @{$self->{'brkPtSlots'}}, $self->{'breakpts_table_data'}->{"$fname:$idx"}->{'row'} ;
+
+	$self->{'brkPtSlots'} = [ sort { $b <=> $a } @{$self->{'brkPtSlots'}} ] ;
+	
+	delete $self->{'breakpts_table_data'}->{"$fname:$idx"} ;
+	
+	$self->{'brkPtCnt'} -= 1 ;
+
+} # end of remove_brkpt_from_brkpt_page
+
+
+#
+# Supporting the "Run To Here..." command
+#
+sub insertTempBreakpoint {
+	my ($self, $fname, $index) = @_ ;
+	my($offset) ;
+	local(*dbline) = $main::{'_<' . $fname} ;
+
+	$offset = $dbline[1] =~ /use\s+.*Devel::_?ptkdb/ ? 1 : 0 ;
+
+	return if( &DB::getdbline($fname, $index + $offset) ) ; # we already have a breakpoint here
+
+	&DB::setdbline($fname, $index + $offset, {'type' => 'temp', 'line' => $index, 'value' => 1 } ) ;
+
+} # end of insertTempBreakpoint
+
+sub reinsertBreakpoints {
+	my ($self, $fname) = @_ ;
+	my ($brkPt) ;
+
+	foreach $brkPt ( &DB::getbreakpoints($fname) ) {
+		#
+		# Our breakpoints are indexed by line
+		# therefore we can have 'gaps' where there
+		# lines, but not breaks set for them.
+		#
+		next unless defined $brkPt ;
+		
+		$self->insertBreakpoint($fname, @$brkPt{'line', 'value', 'expr'}) if( $brkPt->{'type'} eq 'user' ) ;
+		$self->insertTempBreakpoint($fname, $brkPt->{line}) if( $brkPt->{'type'} eq 'temp' ) ;
+	} # end of reinsert loop
+
+} # end of reinsertBreakpoints
+
+sub removeBreakpointTags {
+	my ($self, @brkPts) = @_ ;
+	my($idx, $brkPt) ;
+	
+	foreach $brkPt (@brkPts) {
+
+		$idx = $brkPt->{'line'} ;
+
+		if ( $brkPt->{'value'} ) {
+			$self->{'text'}->tagRemove("breaksetLine", "$idx.0", "$idx.$Devel::ptkdb::linenumber_length") ;
+		}
+		else {
+			$self->{'text'}->tagRemove("breakdisabledLine", "$idx.0", "$idx.$Devel::ptkdb::linenumber_length") ; 
+		}
+		
+		$self->{'text'}->tagAdd("breakableLine", "$idx.0", "$idx.$Devel::ptkdb::linenumber_length") ;					
+	}
+} # end of removeBreakpointTags
+
+#
+# Remove a breakpoint from the current window
+#
+sub removeBreakpoint {
+	my ($self, $fname, @idx) = @_ ;
+	my ($idx, $chkIdx, $i, $j, $info) ;
+	my($offset) ;
+	local(*dbline) = $main::{'_<' . $fname} ;
+
+	$offset = $dbline[1] =~ /use\s+.*Devel::_?ptkdb/ ? 1 : 0 ;
+
+	foreach $idx (@idx) { # end of removal loop
+		next unless defined $idx ;
+		my $brkPt = &DB::getdbline($fname, $idx + $offset) ;
+		next unless $brkPt ; # if we do not have an entry
+		&DB::cleardbline($fname, $idx + $offset) ;
+
+		$self->remove_brkpt_from_brkpt_page($fname, $idx) ;
+
+		next unless $brkPt->{fname} eq $self->{'current_file'}	; # if this isn't our current file there will be no controls
+
+		# Delete the ext associated with the breakpoint expression (if any)		 
+
+		$self->removeBreakpointTags($brkPt) ;
+	} # end of remove loop
+	
+	return ;
+} # end of removeBreakpoint
+
+sub removeAllBreakpoints {
+	my ($self, $fname) = @_ ;
+	
+	$self->removeBreakpoint($fname, &DB::getdblineindexes($fname)) ;
+
+} # end of removeAllBreakpoints
+
+#
+# Delete expressions prior to an update
+#
+sub deleteAllExprs {
+	my ($self) = @_ ;
+	$self->{'data_list'}->delete('all') ;
+} # end of deleteAllExprs
+
+sub EnterExpr {
+	my ($self) = @_ ;
+	my $str = $self->clear_entry_text() ;
+	if( $str && $str ne "" && $str !~ /^\s+$/ ) { # if there is an expression and it's more than white space
+		$self->{'expr'} = $str ;
+		$self->{'event'} = 'expr' ;
+	}
+} # end of EnterExpr
+
+#
+#
+#
+sub QuickExpr {
+	my ($self) = @_ ;
+
+	my $str = $self->{'quick_entry'}->get() ;
+
+	if( $str && $str ne "" && $str !~ /^\s+$/ ) { # if there is an expression and it's more than white space
+		$self->{'qexpr'} = $str ;
+		$self->{'event'} = 'qexpr' ;
+	}
+} # end of QuickExpr
+
+sub deleteExpr {
+	my ($self) = @_ ;
+	my ($entry, $i, @indexes) ;
+	my @sList = $self->{'data_list'}->info('select') ;
+
+	#
+	# if we're deleteing a top level expression
+	# we have to take it out of the list of expressions
+	#
+
+	foreach $entry ( @sList ) {
+		next if ($entry =~ /\//) ; # goto next expression if we're not a top level ( expr/entry)
+		$i = 0 ;
+		grep { push @indexes, $i if ($_->{'expr'} eq $entry) ; $i++ ; } @{$self->{'expr_list'}} ;
+	} # end of check loop
+	
+	# now take out our list of indexes ;
+
+	for( 0..$#indexes ) {
+			 splice @{$self->{'expr_list'}}, $indexes[$_] - $_, 1 ;
+		 }
+
+	for( @sList ) {
+		$self->{'data_list'}->delete('entry', $_) ;
+	}
+} # end of deleteExpr
+
+sub fixExprPath {
+	my(@pathList) = @_ ;
+	
+	for (@pathList) {
+		s/$Devel::ptkdb::pathSep/$Devel::ptkdb::pathSepReplacement/go ;
+	} # end of path list
+
+	return $pathList[0] unless wantarray ;
+	return @pathList ;
+
+} # end of fixExprPath
+
+##
+##  Inserts an expression($theRef) into an HList Widget($dl).  If the expression
+## is an array, blessed array, hash, or blessed hash(typical object), then this
+## routine is called recursively, adding the members to the next level of heirarchy,
+## prefixing array members with a [idx] and the hash members with the key name.
+## This continues until the entire expression is decomposed to it's atomic constituents.
+## Protection is given(with $reusedRefs) to ensure that 'circular' references within
+## arrays or hashes(i.e. where a member of a array or hash contains a reference to a
+## parent element within the heirarchy.  
+##
+#
+# Returns 1 if sucessfully added 0 if not
+#
+sub insertExpr {
+	my($self, $reusedRefs, $dl, $theRef, $name, $depth, $dirPath) = @_ ;
+	my($label, $type, $result, $selfCnt, @circRefs) ;
+	local($^W) = 0 ; # spare us uncessary warnings about comparing strings with == 	
+
+	#
+	# Add data new data entries to the bottom
+	# 
+	$dirPath = "" unless defined $dirPath ;
+
+	$label = "" ;
+	$selfCnt = 0 ;
+
+	while( ref $theRef eq 'SCALAR' ) {
+		$theRef = $$theRef ;
+	}
+ REF_CHECK: for( ; ; ) {
+	 push @circRefs, $theRef ;
+	 $type = ref $theRef ;
+	 last unless ($type	eq "REF")	 ;
+	 $theRef = $$theRef ; # dref again
+	 
+	 $label .= "\\" ; # append a 
+	 if( grep $_ == $theRef, @circRefs ) {
+		 $label .= "(circular)" ;
+		 last ;
+	 }
+ }
+
+	if( !$type || $type eq "" || $type eq "GLOB" || $type eq "CODE") {
+		eval {
+			if( !defined $theRef ) {
+				$dl->add($dirPath . $name, -text => "$name = $label" . "undef") ;
+			}
+			else {
+				$dl->add($dirPath . $name, -text => "$name = $label$theRef") ;
+			}
+		} ;
+		$self->DoAlert($@), return 0 if $@ ;
+		return 1 ;
+	}
+
+	if( $type eq 'ARRAY' or "$theRef" =~ /ARRAY/ ) {
+		my ($r, $idx) ;
+		$idx = 0 ;
+		eval {
+			$dl->add($dirPath . $name, -text => "$name = $theRef") ;
+		} ;
+		if( $@ ) {
+			$self->DoAlert($@) ;
+			return 0 ;
+		}
+		$result = 1 ;
+		foreach $r ( @{$theRef} ) {
+
+			if( grep $_ == $r, @$reusedRefs ) { # check to make sure that we're not doing a single level self reference
+				eval {
+					$dl->add($dirPath .  fixExprPath($name) . $Devel::ptkdb::pathSep . "__ptkdb_self_path" . $selfCnt++, -text => "[$idx] = $r REUSED ADDR") ;
+				} ;
+				$self->DoAlert($@) if( $@ ) ;
+				next ;
+			}
+			
+			$^W = 0 ;
+
+			push @$reusedRefs, $r ;
+			$result = $self->insertExpr($reusedRefs, $dl, $r, "[$idx]", $depth-1, $dirPath . fixExprPath($name) . $Devel::ptkdb::pathSep) unless $depth == 0 ;
+			pop @$reusedRefs ;
+
+			return 0 unless $result ;
+			$idx += 1 ;
+		}
+		return 1 ;
+	} # end of array case
+
+	if(	 "$theRef" !~ /HASH\050\060x[0-9a-f]*\051/o ) {
+		eval {
+			$dl->add($dirPath . fixExprPath($name), -text => "$name = $theRef") ;
+		} ;
+		if( $@ ) {
+			$self->DoAlert($@) ;
+			return 0 ;
+		}
+		return 1 ;
+	}
+# 
+# Anything else at this point is
+# either a 'HASH' or an object
+# of some kind.
+#
+	my($r, @theKeys, $idx) ;
+	$idx = 0 ;
+	@theKeys = sort keys %{$theRef} ;
+	$dl->add($dirPath . $name, -text => "$name = $theRef") ;
+	$result = 1 ;
+
+	foreach $r ( @$theRef{@theKeys} ) { # slice out the values with the sorted list
+
+		if( grep $_ == $r, @$reusedRefs ) { # check to make sure that we're not doing a single level self reference
+			eval {
+				$dl->add($dirPath .  fixExprPath($name) . $Devel::ptkdb::pathSep . "__ptkdb_self_path" . $selfCnt++, -text => "$theKeys[$idx++] = $r REUSED ADDR") ;
+			} ;
+			print "bad path $@\n" if( $@ ) ;
+			next ;
+		}
+
+		$^W = 0 ;
+
+		push @$reusedRefs, $r ;
+
+		$result = $self->insertExpr($reusedRefs,                              # recursion protection
+																$dl,                                      # data list widget
+																$r,                                       # reference whose value is displayed
+																$theKeys[$idx],                           # name
+																$depth-1,                                 # remaining expansion depth
+																$dirPath . $name . $Devel::ptkdb::pathSep # path to add to
+																) unless $depth == 0 ;
+
+		pop @$reusedRefs ;
+
+		return 0 unless $result ;
+		$idx += 1 ;
+	} # end of ref add loop
+
+	return 1 ;
+} # end of insertExpr
+
+#
+# We're setting the line where we are stopped.	
+# Create a tag for this and set it as bold.	 
+#
+sub set_line {
+	my ($self, $lineno) = @_ ;
+	my $text = $self->{'text'} ;
+
+	return if( $lineno <= 0 ) ;
+
+	if( $self->{current_line} > 0 ) {
+		$text->tagRemove('stoppt', "$self->{current_line}.0 linestart", "$self->{current_line}.0 lineend") ;
+	}
+	$self->{current_line} = $lineno - $self->{'line_offset'} ;
+	$text->tagAdd('stoppt', "$self->{current_line}.0 linestart", "$self->{current_line}.0 lineend") ;
+
+	$self->{'text'}->see("$self->{current_line}.0 linestart") ;
+} # end of set_line
+
+#
+# Set the file that is in the code window.
+#
+# $fname the 'new' file to view
+# $line the line number we're at
+# $brkPts any breakpoints that may have been set in this file
+#
+
+use Carp ;
+
+sub set_file {
+	my ($self, $fname, $line) = @_ ;
+	my ($lineStr, $offset, $text, $i, @text) ;
+	my (@breakableTagList, @nonBreakableTagList) ;
+
+	return unless $fname ;  # we're getting an undef here on 'Restart...'
+
+	local(*dbline) = $main::{'_<' . $fname};
+
+	#
+	# with the #! /usr/bin/perl -d:ptkdb at the header of the file
+	# we've found that with various combinations of other options the
+	# files haven't come in at the right offsets
+	#
+	$offset = 0 ;
+	$offset = 1 if $dbline[1] =~ /use\s+.*Devel::_?ptkdb/ ;
+	$self->{'line_offset'} = $offset ;
+
+	$text = $self->{'text'} ;
+	 
+	if( $fname eq $self->{current_file} ) {
+		$self->set_line($line) ;
+		return ;
+	} ;
+
+	$fname =~ s/^\-// ; # Tk does not like leadiing '-'s 
+	$self->{main_window}->configure('-title' => $fname) ;
+
+	# Erase any existing text
+
+	$text->delete('0.0','end') ;
+	
+	my $len = $Devel::ptkdb::linenumber_length ;
+
+	#
+	# This is the tightest loop we have in the ptkdb code.
+	# It is here where performance is the most critical.
+	# The map block formats perl code for display.	Since
+	# the file could be potentially large, we will try
+	# to make this loop as thin as possible. 
+	#
+	# NOTE:	 For a new perl individual this may appear as
+	# if it was intentionally obfuscated.	 This is not
+	# not the case.	 The following code is the result
+	# of an intensive effort to optimize this code.
+	# Prior versions of this code were quite easier
+	# to read, but took 3 times longer.
+	# 
+
+	$lineStr = " " x 200 ; # pre-allocate space for $lineStr
+	$i = 1 ;
+
+	local($^W) = 0 ; # spares us useless warnings under -w when checking $dbline[$_] != 0
+	#
+	# The 'map' call will build list of 'string', 'tag' pairs
+	# that will become arguments to the 'insert' call.	Passing
+	# the text to insert "all at once" rather than one insert->('end', 'string', 'tag')
+	# call at time provides a MASSIVE savings in execution time.
+	#
+
+	$text->insert('end', map {
+		
+		#
+		# build collections of tags representing
+		# the line numbers for breakable and 
+		# non-breakable lines.	We apply these
+		# tags after we've built the text
+		#
+		
+		($_ != 0 && push @breakableTagList, "$i.0", "$i.$len") || push @nonBreakableTagList, "$i.0", "$i.$len" ;
+
+		$lineStr = sprintf($Devel::ptkdb::linenumber_format, $i++) . $_ ; # line number + text of the line
+		$lineStr .= "\n" unless /\n$/o ; # append a \n if there isn't one already
+		
+		($lineStr, 'code') ; # return value for block, a string,tag pair for text insert
+		
+	} @dbline[$offset+1 .. $#dbline] ) ;
+						
+						
+						#
+						# Apply the tags that we've collected
+						# NOTE:	 it was attempted to incorporate these
+						# operations into the 'map' block above, but that
+						# actually degraded performance.	
+						#
+						$text->tagAdd("breakableLine", @breakableTagList) if @breakableTagList ; # apply tag to line numbers where the lines are breakable
+						$text->tagAdd("nonbreakableLine", @nonBreakableTagList) if @nonBreakableTagList ; # apply tag to line numbers where the lines are not breakable.	
+						
+						#
+						# Reinsert breakpoints (if info provided)
+						#
+
+						$self->set_line($line) ;
+						$self->{current_file} = $fname ;
+						return $self->reinsertBreakpoints($fname) ;
+						
+					} # end of set_file
+
+#
+# Get the current line that the insert cursor is in
+#
+								sub get_lineno {
+									my ($self) = @_ ; 
+									my ($info) ;
+									
+									$info = $self->{'text'}->index('insert') ; # get the location for the insertion point
+									$info =~ s/\..*$/\.0/ ;
+
+									return int $info ;
+								} # end of get_lineno
+
+sub DoGoto {
+	my ($self, $entry) = @_ ;
+
+	my $txt = $entry->get() ;
+	
+	$txt =~ s/(\d*).*/$1/ ; # take the first blob of digits
+	if( $txt eq "" ) {
+		print "invalid text range\n" ;
+		return if $txt eq "" ;
+	}
+	
+	$self->{'text'}->see("$txt.0") ;
+	
+	$entry->selectionRange(0, 'end') if $entry->can('selectionRange')
+
+		} # end of DoGoto
+
+sub GotoLine {
+	my ($self) = @_ ;
+	my ($topLevel) ;
+
+	if( $self->{goto_window} ) {
+		$self->{goto_window}->raise() ;
+		$self->{goto_text}->focus() ;
+		return ;
+	}
+
+	#
+	# Construct a dialog that has an
+	# entry field, okay and cancel buttons
+	#
+	my $okaySub = sub { $self->DoGoto($self->{'goto_text'}) } ;
+	
+	$topLevel = $self->{main_window}->Toplevel(-title => "Goto Line?", -overanchor => 'cursor') ;
+
+	$self->{goto_text} = $topLevel->Entry()->pack(side => 'top', fill => 'both', -expand => 1) ;
+
+	$self->{goto_text}->bind('<Return>', $okaySub) ; # make a CR do the same thing as pressing an okay
+
+	$self->{goto_text}->focus() ;
+
+	# Bind a double click on the mouse button to the same action
+	# as pressing the Okay button
+
+	$topLevel->Button( text => "Okay", -command => $okaySub, @Devel::ptkdb::button_font,
+										 )->pack(side => 'left', fill => 'both', -expand => 1) ;
+
+	#
+	# Subroutone called when the 'Dismiss'
+	# button is pushed.
+	#
+	my $dismissSub = sub {
+		delete $self->{goto_text} ;
+		destroy {$self->{goto_window}} ;
+		delete $self->{goto_window} ; # remove the entry from our hash so we won't
+	} ;
+
+	$topLevel->Button( text => "Dismiss", @Devel::ptkdb::button_font,
+										 -command => $dismissSub )->pack(side => 'left', fill => 'both', -expand => 1) ;
+
+	$topLevel->protocol('WM_DELETE_WINDOW', sub { destroy $topLevel ; } ) ;
+
+	$self->{goto_window} = $topLevel ;
+
+} # end of GotoLine
+
+
+#
+# Subroutine called when the 'okay' button is pressed
+#
+sub FindSearch {
+	my ($self, $entry, $btn, $regExp) = @_ ;
+	my (@switches, $result) ;
+	my $txt = $entry->get() ;
+
+	return if $txt eq "" ; 
+
+	push @switches, "-forward" if $self->{fwdOrBack} eq "forward" ;
+	push @switches, "-backward" if $self->{fwdOrBack} eq "backward" ;
+	
+	if( $regExp ) {
+		push @switches, "-regexp" ;
+	}
+	else {
+		push @switches, "-nocase" ; # if we're not doing regex we may as well do caseless search
+	}
+
+	$result = $self->{'text'}->search(@switches, $txt, $self->{search_start}) ;
+
+	# untag the previously found text
+
+	$self->{'text'}->tagRemove('search_tag', @{$self->{search_tag}}) if defined $self->{search_tag} ;
+
+	if( !$result || $result eq "" ) {
+		# No Text was found
+		$btn->flash() ;
+		$btn->bell() ;
+
+		delete $self->{search_tag} ;
+		$self->{'search_start'} = "0.0" ;
+	}
+	else { # text found
+		$self->{'text'}->see($result) ;
+		# set the insertion of the text as well
+		$self->{'text'}->markSet('insert' => $result) ;
+		my $len = length $txt ;
+
+		if( $self->{fwdOrBack} ) {
+			$self->{search_start}	 = "$result +$len chars"	;
+			$self->{search_tag} = [ $result, $self->{search_start} ]	;
+		}
+		else {
+			# backwards search 
+			$self->{search_start}	 = "$result -$len chars"	;
+			$self->{search_tag} = [ $result, "$result +$len chars"	]	 ;
+		}
+
+		# tag the newly found text
+
+		$self->{'text'}->tagAdd('search_tag', @{$self->{search_tag}}) ;
+	} # end of text found
+
+	$entry->selectionRange(0, 'end') if $entry->can('selectionRange') ;
+
+} # end of FindSearch
+
+
+#
+# Support for the Find Text... Menu command
+#
+sub FindText {
+	my ($self) = @_ ;
+	my ($top, $entry, $rad1, $rad2, $chk, $regExp, $frm, $okayBtn) ;
+
+	#
+	# if we already have the Find Text Window
+	# open don't bother openning another, bring
+	# the existing one to the front.	
+	#
+	if( $self->{find_window} ) {
+		$self->{find_window}->raise() ;
+		$self->{find_text}->focus() ;
+		return ;
+	}
+
+	$self->{search_start} = $self->{'text'}->index('insert') if( $self->{search_start} eq "" ) ;
+
+	#
+	# Subroutine called when the 'Dismiss' button
+	# is pushed.	
+	#
+	my $dismissSub = sub {
+		$self->{'text'}->tagRemove('search_tag', @{$self->{search_tag}}) if defined $self->{search_tag} ;
+		$self->{search_start} = "" ;
+		destroy {$self->{find_window}} ; 
+		delete $self->{search_tag} ;
+		delete $self->{find_window} ;
+	} ;
+
+	#
+	# Construct a dialog that has an entry field, forward, backward, regex option, okay and cancel buttons
+	#
+	$top = $self->{main_window}->Toplevel(-title => "Find Text?") ;
+
+	$self->{find_text} = $top->Entry()->pack('side' => 'top', fill => 'both', -expand => 1) ;
+
+	
+	$frm = $top->Frame()->pack('side' => 'top', fill => 'both', -expand => 1) ;
+
+	$self->{fwdOrBack} = 'forward' ;
+	$rad1 = $frm->Radiobutton('text' => "Forward", 'value' => 1, 'variable' => \$self->{fwdOrBack}) ;
+	$rad1->pack(side => 'left', fill => 'both', -expand => 1) ;
+	$rad2 = $frm->Radiobutton('text' => "Backward", 'value' => 0, 'variable' => \$self->{fwdOrBack}) ;
+	$rad2->pack(side => 'left', fill => 'both', -expand => 1) ;
+
+	$regExp = 0 ;
+	$chk = $frm->Checkbutton('text' => "RegExp", 'variable' => \$regExp) ;
+	$chk->pack(side => 'left', fill => 'both', -expand => 1) ;
+
+	# Okay and cancel buttons
+
+	# Bind a double click on the mouse button to the same action
+	# as pressing the Okay button
+
+	$okayBtn = $top->Button( text => "Okay", -command => sub { $self->FindSearch($self->{find_text}, $okayBtn, $regExp) ; }, 
+												 @Devel::ptkdb::button_font,
+													 )->pack(side => 'left', fill => 'both', -expand => 1) ;
+
+	$self->{find_text}->bind('<Return>', sub { $self->FindSearch($self->{find_text}, $okayBtn, $regExp) ; }) ;
+
+	$top->Button( text => "Dismiss", @Devel::ptkdb::button_font,
+								-command => $dismissSub)->pack(side => 'left', fill => 'both', -expand => 1) ;
+
+	$top->protocol('WM_DELETE_WINDOW', $dismissSub) ;
+
+	$self->{find_text}->focus() ;
+
+	$self->{find_window} = $top ;
+
+} # end of FindText
+
+sub main_loop {
+	my ($self) = @_ ;
+	my ($evt, $str, $result) ;
+	my $i = 0;
+ SWITCH: for ($self->{'event'} = 'null' ; ; $self->{'event'} = undef ) {
+
+   Tk::DoOneEvent(0);
+	 next unless $self->{'event'} ;
+
+	 $evt = $self->{'event'} ;
+	 $evt =~ /step/o && do { last SWITCH ; } ;
+	 $evt =~ /null/o && do { next SWITCH ; } ;
+	 $evt =~ /run/o && do { last SWITCH ; } ;
+	 $evt =~ /quit/o && do { $self->{main_window}->destroy if $self->{main_window} ; 
+													 $self->{main_window} = undef if defined $self->{main_window} ; exit ; } ;
+	 $evt =~ /expr/o && do { return $evt ; } ; # adds an expression to our expression window
+	 $evt =~ /qexpr/o && do { return $evt ; } ; # does a 'quick' expression
+	 $evt =~ /update/o && do { return $evt ; } ; # forces an update on our expression window
+	 $evt =~ /reeval/o && do { return $evt ; } ; # updated the open expression eval window
+	 $evt =~ /balloon_eval/ && do { return $evt } ;
+ } # end of switch block
+	return $evt ;
+} # end of main_loop
+
+#
+# $subStackRef	 A reference to the current subroutine stack
+#
+
+sub goto_sub_from_stack {
+	my ($self, $f, $lineno) = @_ ;
+	$self->set_file($f, $lineno) ;
+} # end of goto_sub_from_stack ;
+
+sub refresh_stack_menu {
+	my ($self) = @_ ;
+	my ($str, $name, $i, $sub_offset, $subStack) ;
+
+	#
+	# CAUTION:	In the effort to 'rationalize' the code
+	# are moving some of this function down from DB::DB
+	# to here.	$sub_offset represents how far 'down'
+	# we are from DB::DB.	 The $DB::subroutine_depth is
+	# tracked in such a way that while we are 'in' the debugger
+	# it will not be incremented, and thus represents the stack depth
+	# of the target program.	
+	#
+	$sub_offset = 1 ;
+	$subStack = [] ;
+
+	# clear existing entries
+
+	for( $i = 0 ; $i <= $DB::subroutine_depth ; $i++ ) {
+		my ($package, $filename, $line, $subName) = caller $i+$sub_offset ;
+		last if !$subName ;
+		push @$subStack, { 'name' => $subName, 'pck' => $package, 'filename' => $filename, 'line' => $line } ;
+	}
+
+	$self->{stack_menu}->menu->delete(0, 'last') ; # delete existing menu items
+
+	for( $i = 0 ; $subStack->[$i] ; $i++ ) {
+
+		$str = defined $subStack->[$i+1] ? "$subStack->[$i+1]->{name}" : "MAIN" ;
+
+		my ($f, $line) = ($subStack->[$i]->{filename}, $subStack->[$i]->{line}) ; # make copies of the values for use in 'sub'
+		$self->{stack_menu}->command(-label => $str, -command => sub { $self->goto_sub_from_stack($f, $line) ; } ) ;
+	}
+} # end of refresh_stack_menu
+
+no strict ;
+
+sub get_state {
+	my ($self, $fname) = @_ ;
+	my ($val) ;
+	local($files, $expr_list, $eval_saved_text, $main_win_geometry) ;
+	
+	do "$fname"	 ;
+
+	if( $@ ) {
+		$self->DoAlert($@) ;
+		return ( undef ) x 4 ; # return a list of 4 undefined values
+	}
+
+	return ($files, $expr_list, $eval_saved_text, $main_win_geometry) ;
+} # end of get_state
+
+use strict ;
+
+sub restoreStateFile {
+	my ($self, $fname) = @_ ;
+	local(*F) ;
+	my ($saveCurFile, $s, @n, $n) ;
+
+	if (!(-e $fname && -r $fname)) {
+		$self->DoAlert("$fname does not exist") ;
+		return ;
+	}
+
+	my ($files, $expr_list, $eval_saved_text, $main_win_geometry) = $self->get_state($fname) ;
+	my ($f, $brks) ;
+
+	return unless defined $files || defined $expr_list ;
+
+	&DB::restore_breakpoints_from_save($files) ;
+
+	#
+	# This should force the breakpoints to be restored
+	#
+	$saveCurFile = $self->{current_file} ;
+
+	@$self{ 'current_file', 'expr_list', 'eval_saved_text' } =
+			( ""						 , $expr_list,	$eval_saved_text) ;
+
+	$self->set_file($saveCurFile, $self->{current_line}) ;
+
+	$self->{'event'} = 'update' ;
+
+	if ( $main_win_geometry && $self->{'main_window'} ) { 
+		# restore the height and width of the window
+		$self->{main_window}->geometry( $main_win_geometry ) ;
+	}
+} # end of retstoreState
+
+sub updateEvalWindow {
+	my ($self, @result) = @_ ;
+	my ($leng, $str, $d) ;
+
+	$leng = 0 ;
+	for( @result ) {
+		if( !$Devel::ptkdb::DataDumperAvailable || !$Devel::ptkdb::useDataDumperForEval ) {
+			$str = "$_\n" ;
+		}
+		else {
+			$d = Data::Dumper->new([ $_ ]) ;
+			$d->Indent($Devel::ptkdb::eval_dump_indent) ;
+			$d->Terse(1) ;
+			if( Data::Dumper->can('Dumpxs') ) { 
+				$str = $d->Dumpxs( $_ ) ;
+			}
+			else {
+				$str = $d->Dump( $_ ) ;
+			}
+		}
+		$leng += length $str ;
+		$self->{eval_results}->insert('end', $str) ;
+	}
+} # end of updateEvalWindow
+
+sub setupEvalWindow {
+	my($self) = @_ ;
+	my($top, $dismissSub) ;
+	my $f ;
+	$self->{eval_window}->focus(), return if exists $self->{eval_window} ; # already running this window?
+
+	$top = $self->{main_window}->Toplevel(-title => "Evaluate Expressions...") ;
+	$self->{eval_window} = $top ;
+	$self->{eval_text} = $top->Scrolled('TextUndo',
+																		@Devel::ptkdb::scrollbar_cfg,
+																		@Devel::ptkdb::eval_text_font,
+																			width => 50,
+																			height => 10,
+																			-wrap => "none",
+																			)->packAdjust('side' => 'top', 'fill' => 'both', -expand => 1) ;
+
+	$self->{eval_text}->insert('end', $self->{eval_saved_text}) if exists $self->{eval_saved_text} && defined $self->{eval_saved_text} ;
+
+	$top->Label(-text, "Results:")->pack('side' => 'top', 'fill' => 'both', -expand => 'n') ;
+
+	$self->{eval_results} = $top->Scrolled('Text',
+																			 @Devel::ptkdb::scrollbar_cfg,
+																				 width => 50,
+																				 height => 10,
+																				 -wrap => "none",
+																			 @Devel::ptkdb::eval_text_font
+																				 )->pack('side' => 'top', 'fill' => 'both', -expand => 1) ;
+
+	my $btn = $top->Button(-text => 'Eval...', -command => sub { $DB::window->{event} = 'reeval' ; }
+												 )->pack('side' => 'left', 'fill' => 'x', -expand => 1) ;
+
+	$dismissSub = sub { 
+		$self->{eval_saved_text} = $self->{eval_text}->get('0.0', 'end') ;
+		$self->{eval_window}->destroy ;
+		delete $self->{eval_window} ;
+	} ;
+
+	$top->protocol('WM_DELETE_WINDOW', $dismissSub ) ;
+
+	$top->Button(-text => 'Clear Eval', -command => sub { $self->{eval_text}->delete('0.0', 'end') }
+							 )->pack('side' => 'left', 'fill' => 'x', -expand => 1) ;
+
+	$top->Button(-text => 'Clear Results', -command => sub { $self->{eval_results}->delete('0.0', 'end') }
+							 )->pack('side' => 'left', 'fill' => 'x', -expand => 1) ;
+
+	$top->Button(-text => 'Dismiss', -command => $dismissSub)->pack('side' => 'left', 'fill' => 'x', -expand => 1) ;
+
+} # end of setupEvalWindow ;
+
+sub filterBreakPts {
+	my ($breakPtsListRef, $fname) = @_ ;
+	my $dbline = $main::{'_<' . $fname}; # breakable lines
+	local($^W) = 0 ;
+	#
+	# Go through the list of breaks and take out any that
+	# are no longer breakable
+	#
+
+	for( @$breakPtsListRef ) {
+		next unless defined $_ ;
+
+		next if $dbline->[$_->{'line'}] != 0 ; # still breakable
+
+		$_ = undef ;
+	}
+} # end of filterBreakPts
+
+sub DoAbout {
+	my $self = shift ;
+	my $str = "ptkdb $DB::VERSION\nCopyright 1998 by Andrew E. Page\nFeedback to aep\@world.std.com\n\n" ;
+	my $threadString = "" ;
+	
+	$threadString = "Threads Available" if $Config::Config{usethreads} ;
+	$threadString = " Thread Debugging Enabled" if $DB::usethreads ;
+	
+	$str .= <<"__STR__" ;
+	This program is free software; you can redistribute it and/or modify
+			it under the terms of either:
+
+			a) the GNU General Public License as published by the Free
+		Software Foundation; either version 1, or (at your option) any
+		later version, or
+
+		b) the "Artistic License" which comes with this Kit.
+
+		This program 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 either
+		the GNU General Public License or the Artistic License for more details.
+
+		OS $^O
+		Tk Version $Tk::VERSION
+		Perl Version $]
+Data::Dumper Version $Data::Dumper::VERSION
+		$threadString
+__STR__
+
+		$self->DoAlert($str, "About ptkdb") ;
+} # end of DoAbout
+
+#
+# return 1 if succesfully set,
+# return 0 if otherwise
+#
+sub SetBreakPoint {
+	my ($self, $isTemp) = @_ ;
+	my $dbw = $DB::window ;
+	my $lineno = $dbw->get_lineno() ;
+	my $expr = $dbw->clear_entry_text() ;
+	local($^W) = 0 ;
+
+	if( !&DB::checkdbline($DB::window->{current_file}, $lineno + $self->{'line_offset'}) ) {
+		$dbw->DoAlert("line $lineno in $DB::window->{current_file} is not breakable") ;
+		return 0 ;
+	}
+
+	if( !$isTemp ) {
+		$dbw->insertBreakpoint($DB::window->{current_file}, $lineno, 1, $expr) ;
+		return 1 ;
+	}
+	else {
+		$dbw->insertTempBreakpoint($DB::window->{current_file}, $lineno) ;
+		return 1 ;
+	}
+
+	return 0 ;
+} # end of SetBreakPoint
+
+sub UnsetBreakPoint {
+	my ($self) = @_ ;
+	my $lineno = $self->get_lineno() ;
+	
+	$self->removeBreakpoint($DB::window->{current_file}, $lineno) ;
+} # end of UnsetBreakPoint
+
+sub balloon_post {
+	my $self = $DB::window ;
+	my $txt = $DB::window->{'text'} ;
+
+	return 0 if ($self->{'expr_ballon_msg'} eq "") || ($self->{'balloon_expr'} eq "") ; # don't post for an empty string
+
+	return $self->{'balloon_coord'} ;
+}
+
+sub balloon_motion {
+	my ($txt, $x, $y) = @_ ;
+	my ($offset_x, $offset_y) = ($x + 4, $y + 4) ;
+	my $self = $DB::window ;
+	my $txt2 = $self->{'text'} ;
+	my $data ;
+
+	$self->{'balloon_coord'} = "$offset_x,$offset_y" ;
+
+	$x -= $txt->rootx ;
+	$y -= $txt->rooty ;
+	#
+	# Post an event that will cause us to put up a popup
+	#
+	
+	if( $txt2->tagRanges('sel') ) { # check to see if 'sel' tag exists (return undef value)
+		$data = $txt2->get("sel.first", "sel.last") ; # get the text between the 'first' and 'last' point of the sel (selection) tag
+	}
+	else {
+		$data = $DB::window->retrieve_text_expr($x, $y) ;
+	}
+
+	if( !$data ) {
+		$self->{'balloon_expr'} = "" ;
+		return 0 ; 
+	}
+	
+	return 0 if ($data eq $self->{'balloon_expr'}) ; # nevermind if it's the same expression
+
+	$self->{'event'} = 'balloon_eval' ;
+	$self->{'balloon_expr'} = $data ;
+
+	return 1 ; # ballon will be canceled and a new one put up(maybe)
+} # end of balloon_motion
+
+sub retrieve_text_expr {
+	my($self, $x, $y) = @_ ;
+	my $txt = $self->{'text'} ;
+
+	my $coord = "\@$x,$y" ;
+
+	my($idx, $col, $data, $offset) ;
+
+	($col, $idx) = line_number_from_coord($txt, $coord) ;
+
+	$offset = $Devel::ptkdb::linenumber_length + 1 ; # line number text + 1 space
+
+	return undef if $col < $offset ; # no posting
+
+	$col -= $offset ;
+
+	local(*dbline) = $main::{'_<' . $self->{current_file}} ;	 
+
+	return undef if( !defined $dbline[$idx] || $dbline[$idx] == 0 ) ; # no executable text, no real variable(?)
+	
+	$data = $dbline[$idx] ;
+	
+	# if we're sitting over white space, leave
+	my $len = length $data ;
+	return unless $data && $col && $len > 0 ;
+
+	return if substr($data, $col, 1) =~ /\s/ ;
+
+	# walk backwards till we find some whitespace
+
+	$col = $len if $len < $col ;
+	while( --$col >= 0 ) {
+		last if	 substr($data, $col, 1) =~ /[\s\$\@\%]/ ;
+	}
+
+	substr($data, $col) =~ /^([\$\@\%][a-zA-Z0-9_]+)/ ;
+
+	return $1 ;
+}
+
+#
+# after DB::eval get's us a result
+#
+sub code_motion_eval {
+	my ($self, @result) = @_ ;
+	my $str ;
+
+	if( exists $self->{'balloon_dumper'} ) {
+
+		my $d = $self->{'balloon_dumper'} ;
+
+		$d->Reset() ;
+		$d->Values( [ $#result == 0 ? @result : \@result ] ) ;			
+
+									if( $d->can('Dumpxs') ) {
+										$str = $d->Dumpxs() ;
+									}
+									else {
+										$str = $d->Dump() ;
+									}
+
+									chomp($str) ;
+								}
+								else {
+									$str = "@result" ;
+								}
+
+								#
+								# Cut the string down to 1024 characters to keep from
+								# overloading the balloon window
+								#
+								
+								$self->{'expr_ballon_msg'} = "$self->{'balloon_expr'} = " . substr $str, 0, 1024 ;
+							} # end of code motion eval
+
+#
+# Subroutine called when we enter DB::DB()
+# In other words when the target script 'stops'
+# in the Debugger
+#
+sub EnterActions {
+	my($self) = @_ ;
+
+#	 $self->{'main_window'}->Unbusy() ;
+
+} # end of EnterActions
+
+#
+# Subroutine called when we return from DB::DB()
+# When the target script resumes.	 
+#
+sub LeaveActions {
+	my($self) = @_ ;
+	
+	#	 $self->{'main_window'}->Busy() ;
+} # end of LeaveActions
+
+
+sub BEGIN {
+ $Devel::ptkdb::scriptName = $0 ;
+ @Devel::ptkdb::script_args = @ARGV ; # copy args
+
+}
+
+##
+## Save the ptkdb state file and restart the debugger
+##
+sub DoRestart {
+	my($fname) ;
+
+	$fname = $ENV{'TMP'} || $ENV{'TMPDIR'} || $ENV{'TMP_DIR'} || $ENV{'TEMP'} || $ENV{'HOME'} ;
+	$fname .= '/' if $fname ;
+	$fname = "" unless $fname ;
+
+	$fname .= "ptkdb_restart_state$$" ;
+
+	# print "saving temp state file $fname\n" ;
+	
+	&DB::save_state_file($fname) ;
+
+	$ENV{'PTKDB_RESTART_STATE_FILE'} = $fname ;
+
+	##
+	## build up the command to do the restart
+	##
+
+	$fname = "perl -w -d:ptkdb $Devel::ptkdb::scriptName @Devel::ptkdb::script_args" ;
+
+	# print "$$ doing a restart with $fname\n" ;
+
+	exec $fname ;
+
+} # end of DoRestart
+
+##
+## Enables/Disables the feature where we stop
+## if we've encountered a perl warning such as:
+## "Use of uninitialized value at undef_warn.pl line N"
+##
+
+sub stop_on_warning_cb {
+	&$DB::ptkdb::warn_sig_save() if $DB::ptkdb::warn_sig_save ; # call any previously registered warning
+ $DB::window->DoAlert(@_) ;
+ $DB::single = 1 ; # forces debugger to stop next time
+}
+
+sub set_stop_on_warning {
+
+	if( $DB::ptkdb::stop_on_warning ) {
+		
+		return if $DB::ptkdb::warn_sig_save == \&stop_on_warning_cb ; # prevents recursion
+
+	  $DB::ptkdb::warn_sig_save = $SIG{'__WARN__'} if $SIG{'__WARN__'} ;
+		$SIG{'__WARN__'} = \&stop_on_warning_cb ;
+		 }
+	else {
+		##
+		## Restore any previous warning signal
+		##
+		local($^W) = 0 ;
+		$SIG{'__WARN__'} = $DB::ptkdb::warn_sig_save ;
+	}
+} # end of set_stop_on_warning
+
+1 ; # end of Devel::ptkdb
+
+package DB ;
+
+use vars '$VERSION', '$header' ;
+
+$VERSION = '1.108' ;
+$header = "ptkdb.pm version $DB::VERSION";
+$DB::window->{current_file} = "" ;
+
+#
+# Here's the clue...
+# eval only seems to eval the context of
+# the executing script while in the DB
+# package.	When we had updateExprs in the Devel::ptkdb
+# package eval would turn up an undef result.
+#
+
+sub updateExprs {
+	my ($package) = @_ ;
+	#
+	# Update expressions
+	# 
+ $DB::window->deleteAllExprs() ;
+	my ($expr, @result);
+
+	foreach $expr ( @{$DB::window->{'expr_list'}} ) {
+		next if length $expr == 0 ;
+
+		@result = &DB::dbeval($package, $expr->{'expr'}) ;
+
+		if( scalar @result == 1 ) {
+		$DB::window->insertExpr([ $result[0] ], $DB::window->{'data_list'}, $result[0], $expr->{'expr'}, $expr->{'depth'}) ;
+		}
+		else {
+		$DB::window->insertExpr([ \@result ], $DB::window->{'data_list'}, \@result, $expr->{'expr'}, $expr->{'depth'}) ;
+		}
+	}
+
+} # end of updateExprs
+
+no strict ; # turning strict off (shame shame) because we keep getting errrs for the local(*dbline)
+
+#
+# returns true if line is breakable
+#
+use Carp ;
+sub checkdbline($$) { 
+	my ($fname, $lineno) = @_ ;
+
+	return 0 unless $fname; # we're getting an undef here on 'Restart...'
+
+	local(*dbline) = $main::{'_<' . $fname} ;
+	local($^W) = 0 ; # spares us warnings under -w
+
+	my $flag = $dbline[$lineno] != 0 ;
+
+	return $flag;
+	
+} # end of checkdbline
+
+#
+# sets a breakpoint 'through' a magic 
+# variable that perl is able to interpert
+#
+sub setdbline($$$) {
+	my ($fname, $lineno, $value) = @_ ;
+	local(*dbline) = $main::{'_<' . $fname};
+
+	$dbline{$lineno} = $value ;
+} # end of setdbline
+
+sub getdbline($$) {
+	my ($fname, $lineno) = @_ ;
+	local(*dbline) = $main::{'_<' . $fname};
+	return $dbline{$lineno} ;
+} # end of getdbline
+
+sub getdbtextline {
+	my ($fname, $lineno) = @_ ;
+	local(*dbline) = $main::{'_<' . $fname};
+	return $dbline[$lineno] ;
+} # end of getdbline
+
+
+sub cleardbline($$;&) {
+	my ($fname, $lineno, $clearsub) = @_ ;
+	local(*dbline) = $main::{'_<' . $fname};
+	my $value ; # just in case we want it for something
+
+	$value = $dbline{$lineno} ;
+	delete $dbline{$lineno} ;
+	&$clearsub($value) if $value && $clearsub ;
+
+	return $value ;
+} # end of cleardbline
+
+sub clearalldblines(;&) {
+	my ($clearsub) = @_ ;
+	my ($key, $value, $brkPt, $dbkey) ;
+	local(*dbline) ;
+
+	while ( ($key, $value) = each %main:: )	 { # key loop
+		next unless $key =~ /^_</ ;
+		*dbline = $value ;
+
+		foreach $dbkey (keys %dbline) {
+			$brkPt = $dbline{$dbkey} ;
+			delete $dbline{$dbkey} ;
+			next unless $brkPt && $clearSub ;
+			&$clearsub($brkPt) ; # if specificed, call the sub routine to clear the breakpoint
+		}
+
+	} # end of key loop
+
+} # end of clearalldblines
+
+sub getdblineindexes {
+	my ($fname) = @_ ;
+	local(*dbline) = $main::{'_<' . $fname} ;
+	return keys %dbline ;
+} # end of getdblineindexes
+
+sub getbreakpoints {
+	my (@fnames) = @_ ;
+	my ($fname, @retList) ;
+
+	foreach $fname (@fnames) {
+		next unless	 $main::{'_<' . $fname} ;
+		local(*dbline) = $main::{'_<' . $fname} ;		 
+		push @retList, values %dbline ;
+	}
+	return @retList ;
+} # end of getbreakpoints
+
+#
+# Construct a hash of the files
+# that have breakpoints to save
+#
+sub breakpoints_to_save {
+	my ($file, @breaks, $brkPt, $svBrkPt, $list) ;
+	my ($brkList) ;
+
+	$brkList = {} ;
+
+	foreach $file ( keys %main:: ) { # file loop
+		next unless $file =~ /^_</ && exists $main::{$file} ;
+		local(*dbline) = $main::{$file} ;
+
+		next unless @breaks = values %dbline ;
+		$list = [] ;
+		foreach $brkPt ( @breaks ) {
+			
+			$svBrkPt = { %$brkPt } ; # make a copy of it's data
+			
+			push @$list, $svBrkPt ;
+
+		} # end of breakpoint loop
+
+		$brkList->{$file} = $list ;
+
+	} # end of file loop
+
+	return $brkList ;
+
+} # end of breakpoints_to_save
+
+#
+# When we restore breakpoints from a state file
+# they've often 'moved' because the file
+# has been editted.	 
+#
+# We search for the line starting with the original line number,
+# then we walk it back 20 lines, then with line right after the
+# orginal line number and walk forward 20 lines.	
+#
+# NOTE: dbline is expected to be 'local'
+# when called
+#
+sub fix_breakpoints {
+	my(@brkPts) = @_ ;
+	my($startLine, $endLine, $nLines, $brkPt) ;
+	my (@retList) ;
+	local($^W) = 0 ;
+
+	$nLines = scalar @dbline ;
+
+	foreach $brkPt (@brkPts) {
+
+		$startLine = $brkPt->{'line'} > 20 ? $brkPt->{'line'} - 20 : 0 ;
+		$endLine	 = $brkPt->{'line'} < $nLines - 20 ? $brkPt->{'line'} + 20 : $nLines ;
+
+		for( (reverse $startLine..$brkPt->{'line'}), $brkPt->{'line'} + 1 .. $endLine ) {
+			next unless $brkPt->{'text'} eq $dbline[$_] ;
+			$brkPt->{'line'} = $_ ;
+			push @retList, $brkPt ;
+			last ;
+		}
+	} # end of breakpoint list
+	
+	return @retList ;
+
+} # end of fix_breakpoints
+
+#
+# Restore breakpoints saved above
+#
+sub restore_breakpoints_from_save {
+	my ($brkList) = @_ ;
+	my ($offset, $key, $list, $brkPt, @newList) ;
+	
+	while ( ($key, $list) = each %$brkList ) { # reinsert loop
+		next unless exists $main::{$key} ;
+		local(*dbline) = $main::{$key} ;
+
+		$offset = 0 ;
+		$offset = 1 if $dbline[1] =~ /use\s+.*Devel::_?ptkdb/ ;
+
+		@newList = fix_breakpoints(@$list) ;
+		
+		foreach $brkPt ( @newList ) {
+			if( !&DB::checkdbline($key, $brkPt->{'line'} + $offset) ) {
+				print "Breakpoint $key:$brkPt->{'line'} in config file is not breakable.\n" ;
+				next ;
+			}
+			$dbline{$brkPt->{'line'}} = { %$brkPt } ; # make a fresh copy
+		}
+	} # end of reinsert loop
+	
+} # end of restore_breakpoints_from_save ;
+
+use strict ;
+
+sub dbint_handler {
+	my($sigName) = @_ ;
+ $DB::single = 1 ;
+	print "signalled\n" ;
+} # end of dbint_handler
+
+#
+# Do first time initialization at the startup
+# of DB::DB
+#
+sub Initialize {
+	my ($fName) = @_ ;
+
+	return if $DB::ptkdb::isInitialized ;
+ $DB::ptkdb::isInitialized = 1 ;
+
+ $DB::window = new Devel::ptkdb	;
+
+ $DB::window->do_user_init_files() ;
+
+
+ $DB::dbint_handler_save = $SIG{'INT'} unless $DB::sigint_disable ; # saves the old handler
+	$SIG{'INT'} = "DB::dbint_handler" unless $DB::sigint_disable ;
+	
+	# Save the file name we started up with
+ $DB::startupFname = $fName ;
+
+	# Check for a 'restart' file
+
+	if( $ENV{'PTKDB_RESTART_STATE_FILE'} && $Devel::ptkdb::DataDumperAvailable && -e $ENV{'PTKDB_RESTART_STATE_FILE'} ) {
+		##
+		## Restore expressions and breakpoints in state file
+		##
+	  $DB::window->restoreStateFile($ENV{'PTKDB_RESTART_STATE_FILE'}) ;
+		unlink $ENV{'PTKDB_RESTART_STATE_FILE'} ; # delete state file
+
+		# print "restoring state from $ENV{'PTKDB_RESTART_STATE_FILE'}\n" ;
+
+		$ENV{'PTKDB_RESTART_STATE_FILE'} = "" ; # clear entry
+	}
+	else {
+		&DB::restoreState($fName) if $Devel::ptkdb::DataDumperAvailable ;
+	}
+
+} # end of Initialize 
+
+sub restoreState {
+	my($fName) = @_ ;
+	my ($stateFile, $files, $expr_list, $eval_saved_text, $main_win_geometry, $restoreName) ;
+
+	$stateFile = makeFileSaveName($fName) ;
+	
+	if( -e $stateFile && -r $stateFile ) {
+		($files, $expr_list, $eval_saved_text, $main_win_geometry) = $DB::window->get_state($stateFile) ;
+		&DB::restore_breakpoints_from_save($files) ;
+	$DB::window->{'expr_list'} = $expr_list if defined $expr_list ;
+	$DB::window->{eval_saved_text} = $eval_saved_text ;
+		
+		if ( $main_win_geometry ) { 
+			# restore the height and width of the window
+		$DB::window->{main_window}->geometry($main_win_geometry) ;
+		}
+	}
+
+} # end of Restore State
+
+sub makeFileSaveName {
+	my ($fName) = @_ ;
+	my $saveName = $fName ;
+
+	if(	 $saveName =~ /.p[lm]$/ ) {
+		$saveName =~ s/.pl$/.ptkdb/ ;
+	}
+	else {
+		$saveName .= ".ptkdb" ;
+	}
+
+	return $saveName ;
+} # end of makeFileSaveName
+
+sub save_state_file {
+	my($fname) = @_ ;
+	my($files, $d, $saveStr) ;
+			
+	$files = &DB::breakpoints_to_save() ;
+	
+	$d = Data::Dumper->new( [ $files, $DB::window->{'expr_list'}, "" ], 
+													[ "files", "expr_list",	 "eval_saved_text" ] ) ;
+		
+	$d->Purity(1) ;
+	if( Data::Dumper->can('Dumpxs') ) {
+		$saveStr = $d->Dumpxs() ;
+	} else {
+		$saveStr = $d->Dump() ;
+	}		 
+	
+	local(*F) ;
+	open F, ">$fname" || die "Couldn't open file $fname" ;
+	
+	print F $saveStr || die "Couldn't write file" ;
+		
+	close F ;
+} # end of save_state_file
+
+sub SaveState {
+	my($name_in) = @_ ;
+	my ($top, $entry, $okayBtn, $win) ;
+	my ($fname, $saveSub, $cancelSub, $saveName, $eval_saved_text, $d) ;		
+	my ($files, $main_win_geometry);
+	#
+	# Create our default name
+	#
+	$win = $DB::window ;
+	
+	#
+	# Extract the height and width of our window
+	#
+	$main_win_geometry = $win->{main_window}->geometry ;
+
+	if ( defined $win->{save_box} ) {
+		$win->{save_box}->raise ;
+		$win->{save_box}->focus ;
+		return ;
+	}
+
+	$saveName = $name_in || makeFileSaveName($DB::startupFname) ;
+	
+	
+
+	$saveSub = sub {
+		$win->{'event'} = 'null' ;
+
+		my $saveStr ;
+
+		delete $win->{save_box} ;
+
+		if( exists $win->{eval_window} ) {
+			$eval_saved_text = $win->{eval_text}->get('0.0', 'end') ;
+		}
+		else {
+			$eval_saved_text =	$win->{eval_saved_text} ;
+		}
+		
+		$files = &DB::breakpoints_to_save() ;
+
+		$d = Data::Dumper->new( [ $files, $win->{'expr_list'}, $eval_saved_text,	 $main_win_geometry ], 
+														[ "files", "expr_list",				 "eval_saved_text",	 "main_win_geometry"] ) ;
+		
+		$d->Purity(1) ;
+		if( Data::Dumper->can('Dumpxs') ) {
+			$saveStr = $d->Dumpxs() ;
+		} else {
+			$saveStr = $d->Dump() ;
+		}		 
+		
+		local(*F) ;
+		eval {
+			open F, ">$saveName" || die "Couldn't open file $saveName" ;
+			
+			print F $saveStr || die "Couldn't write file" ;
+			
+			close F ;
+		} ;
+		$win->DoAlert($@) if $@ ;
+	} ; # end of save sub
+
+	$cancelSub = sub {
+		delete $win->{'save_box'}
+	} ; # end of cancel sub
+	
+	#
+	# Create a dialog
+	#
+	
+	$win->{'save_box'} = $win->simplePromptBox("Save Config?", $saveName, $saveSub, $cancelSub) ;
+
+} # end of SaveState
+
+sub RestoreState {
+	my ($top, $restoreSub) ;
+
+	$restoreSub = sub {
+	$DB::window->restoreStateFile($Devel::ptkdb::promptString) ;
+	} ;
+
+	$top = $DB::window->simplePromptBox("Restore Config?", makeFileSaveName($DB::startupFname), $restoreSub) ;
+
+} # end of RestoreState
+
+sub SetStepOverBreakPoint {
+	my ($offset) = @_ ;
+ $DB::step_over_depth = $DB::subroutine_depth + ($offset ? $offset : 0) ;
+} # end of SetStepOverBreakPoint
+
+#
+# NOTE:		It may be logical and somewhat more economical
+#					lines of codewise to set $DB::step_over_depth_saved 
+#					when we enter the subroutine, but this gets called
+#					for EVERY callable line of code in a program that
+#					is being debugged, so we try to save every line of
+#					execution that we can.
+#
+sub isBreakPoint {
+	my ($fname, $line, $package) = @_ ;
+	my ($brkPt) ;
+
+	if ( $DB::single && ($DB::step_over_depth < $DB::subroutine_depth) && ($DB::step_over_depth > 0) && !$DB::on) {
+	$DB::single = 0	 ;
+		return 0 ;
+	}
+	#
+	# doing a step over/in
+	# 
+
+	if( $DB::single || $DB::signal ) {
+	$DB::single = 0 ;
+	$DB::signal = 0 ;
+	$DB::subroutine_depth = $DB::subroutine_depth ;
+		return 1 ;
+	}
+	#
+	# 1st Check to see if there is even a breakpoint there.	 
+	# 2nd If there is a breakpoint check to see if it's check box control is 'on'
+	# 3rd If there is any kind of expression, evaluate it and see if it's true.	 
+	#
+	$brkPt = &DB::getdbline($fname, $line) ;
+
+	return 0 if( !$brkPt || !$brkPt->{'value'} || !breakPointEvalExpr($brkPt, $package) ) ;
+
+	&DB::cleardbline($fname, $line) if( $brkPt->{'type'} eq 'temp' ) ;
+
+ $DB::subroutine_depth = $DB::subroutine_depth ;
+
+	return	1 ;
+} # end of isBreakPoint
+
+#
+# Check the breakpoint expression to see if it
+# is true.	
+#
+sub breakPointEvalExpr {
+	my ($brkPt, $package) = @_ ;
+	my (@result) ;
+
+	return 1 unless $brkPt->{expr} ; # return if there is no expression
+
+	no strict ;
+
+	@result = &DB::dbeval($package, $brkPt->{'expr'}) ;
+
+	use strict ;
+	
+ $DB::window->DoAlert($@) if $@ ;
+
+	return $result[0] or @result ; # we could have a case where the 1st element is undefined
+	# but subsequent elements are defined
+
+} # end of breakPointEvalExpr
+
+#
+# Evaluate the given expression, return the result.
+# MUST BE CALLED from within DB::DB in order for it
+# to properly interpret the vars
+#
+sub dbeval {
+	my($ptkdb__package, $ptkdb__expr) = @_ ;
+	my(@ptkdb__result, $ptkdb__str, $ptkdb__saveW) ;
+	my(@ptkdb_args) ;
+	
+	no strict ;
+	$ptkdb__saveW = $^W ; # save the state of the "warning"(-w) flag
+	$^W = 0 ;
+
+	#
+	# This substitution is done so that 
+	# we return HASH, as opposed to an ARRAY.
+	# An expression of %hash results in a
+	# list of key/value pairs.	
+	#
+
+	$ptkdb__expr =~ s/^\s*%/\\%/o ;
+
+	@_ = @DB::saved_args ; # replace @_ arg array with what we came in with
+
+	@ptkdb__result = eval <<__EVAL__ ;
+
+
+	\$\@ = \$DB::save_err ;
+
+	package $ptkdb__package ;
+
+	$ptkdb__expr ;
+
+__EVAL__
+
+			@ptkdb__result = ("ERROR ($@)") if $@ ;
+
+	$^W = $ptkdb__saveW ; # restore the state of the "warning"(-w) flag
+
+	use strict ;
+
+	return @ptkdb__result ;
+} # end of dbeval
+
+#
+# Call back we give to our 'quit' button
+# and binding to the WM_DELETE_WINDOW protocol
+# to quit the debugger.	 
+#
+sub dbexit {
+	exit ;
+} # end of dbexit
+
+#
+# This is the primary entry point for the debugger.	 When a perl program
+# is parsed with the -d(in our case -d:ptkdb) option set the parser will
+# insert a call to DB::DB in front of every excecutable statement.	
+# 
+# Refs:	 Progamming Perl 2nd Edition, Larry Wall, O'Reilly & Associates, Chapter 8
+#
+sub DB {
+	@DB::saved_args = @_ ; # save arg context
+ $DB::save_err = $@ ; # save value of $@
+	 my ($package, $filename, $line) = caller ;
+	 my ($stop, $cnt) ;
+
+	 unless( $DB::ptkdb::isInitialized ) {
+		 return if( $filename ne $0 ) ; # not in our target file
+				 
+		 &DB::Initialize($filename) ;
+	 }
+
+	 if (!isBreakPoint($filename, $line, $package) ) {
+	 $DB::single = 0 ;
+		 $@ = $DB::save_err ;
+		 return ;
+	 }
+
+	 
+
+	 if ( !$DB::window ) { # not setup yet
+		 $@ = $DB::save_err ;
+		 return ;
+	 }
+
+ $DB::window->setup_main_window() unless $DB::window->{'main_window'} ;
+
+ $DB::window->EnterActions() ; 
+
+	 my ($saveP) ;
+	 $saveP = $^P ;
+	 $^P = 0 ;
+
+ $DB::on = 1 ;
+
+#
+# The user can specify this variable in one of the startup files,
+# this will make the debugger run right after startup without
+# the user having to press the 'run' button.	
+#
+	 if( $DB::no_stop_at_start ) {
+	 $DB::no_stop_at_start = 0 ;
+	 $DB::on = 0 ;
+		 $@ = $DB::save_err ;
+		 return ;
+	 }
+
+	 if( !$DB::sigint_disable ) {
+		 $SIG{'INT'} = $DB::dbint_handler_save if $DB::dbint_handler_save ; # restore original signal handler
+		 $SIG{'INT'} = "DB::dbexit" unless	 $DB::dbint_handler_save ;
+	 }
+
+  #$DB::window->{main_window}->raise() ; # bring us to the top make sure OUR event loop runs
+ $DB::window->{main_window}->focus() ;
+
+ $DB::window->set_file($filename, $line) ;
+	 #
+	 # Refresh the exprs to see if anything has changed
+	 #
+	 updateExprs($package) ;
+
+	 #
+	 # Update subs Page if necessary
+	 #
+	 $cnt = scalar keys %DB::sub ;
+	 if ( $cnt != $DB::window->{'subs_list_cnt'} && $DB::window->{'subs_page_activated'} ) {
+	   $DB::window->fill_subs_page() ;
+	   $DB::window->{'subs_list_cnt'} = $cnt ;
+	 }
+	 #
+	 # Update the subroutine stack menu
+	 #
+ $DB::window->refresh_stack_menu() ;
+	 
+ $DB::window->{run_flag} = 1 ;
+
+	 my ($evt, @result, $r) ;
+
+	 for( ; ; ) {
+		 #
+		 # we wait here for something to do
+		 #
+		 $evt = $DB::window->main_loop() ;
+
+		 last if( $evt eq 'step' ) ;
+
+	 $DB::single = 0 if ($evt eq 'run' )	;
+
+		 if ($evt eq 'balloon_eval' ) {
+		 $DB::window->code_motion_eval(&DB::dbeval($package, $DB::window->{'balloon_expr'})) ;
+			 next ;
+		 }
+
+		 if ( $evt eq 'qexpr' ) {
+			 my $str ;
+			 @result = &DB::dbeval($package, $DB::window->{'qexpr'}) ;
+		 $DB::window->{'quick_entry'}->delete(0, 'end') ; # clear old text
+			 if (exists $DB::window->{'quick_dumper'}) {
+			 $DB::window->{'quick_dumper'}->Reset() ;
+			 $DB::window->{'quick_dumper'}->Values( [ $#result == 0 ? @result : \@result ] ) ;
+																								if( $DB::window->{'quick_dumper'}->can('Dumpxs') ) {
+																									$str = $DB::window->{'quick_dumper'}->Dumpxs() ;
+																								}
+																								else {
+																									$str = $DB::window->{'quick_dumper'}->Dump() ;
+																								} 
+																							}
+																							else {
+																								$str = "@result" ;
+																							}
+																						$DB::window->{'quick_entry'}->insert(0, $str) ; #enter the text
+																						$DB::window->{'quick_entry'}->selectionRange(0, 'end') ; # select it
+																							$evt = 'update' ; # force an update on the expressions
+																						}
+
+				 if( $evt eq 'expr' ) {
+					 #
+					 # Append the new expression to the list
+					 # but first check to make sure that we don't
+					 # already have it.
+					 #
+					 
+					 if ( grep $_->{'expr'} eq $DB::window->{'expr'}, @{$DB::window->{'expr_list'}} ) {
+					 $DB::window->DoAlert("$DB::window->{'expr'} is already listed") ;
+						 next ;
+					 }
+
+					 @result = &DB::dbeval($package, $DB::window->{expr}) ;
+
+					 if( scalar @result == 1 ) {
+						 $r = $DB::window->insertExpr([ $result[0] ], $DB::window->{'data_list'}, $result[0], $DB::window->{'expr'}, $Devel::ptkdb::expr_depth) ;
+					 }
+					 else {
+						 $r = $DB::window->insertExpr([ \@result ], $DB::window->{'data_list'}, \@result, $DB::window->{'expr'}, $Devel::ptkdb::expr_depth)	 ;
+					 }
+
+					 #
+					 # $r will be 1 if the expression was added succesfully, 0 if not,
+					 # and it if wasn't added sucessfully it won't be reevalled the 
+					 # next time through.	 
+					 #
+					 push @{$DB::window->{'expr_list'}}, { 'expr' => $DB::window->{'expr'}, 'depth' => $Devel::ptkdb::expr_depth } if $r ;
+					 
+					 next ;
+				 }
+				 if( $evt eq 'update' ) {
+					 updateExprs($package) ;
+					 next ;
+				 }
+				 if( $evt eq 'reeval' ) {
+					 #
+					 # Reevaluate the contents of the expression eval window
+					 #
+					 my $txt = $DB::window->{'eval_text'}->get('0.0', 'end') ;
+					 my @result = &DB::dbeval($package, $txt) ;
+
+				 $DB::window->updateEvalWindow(@result) ;
+
+					 next ;
+				 }
+				 last ;
+			 }
+			 $^P = $saveP ;
+			 $SIG{'INT'} = "DB::dbint_handler"	 unless $DB::sigint_disable ; # set our signal handler
+
+		 $DB::window->LeaveActions() ;
+
+			 $@ = $DB::save_err ;
+		 $DB::on = 0 ;
+		 } # end of DB
+
+#
+# This is another place where we'll try and keep the
+# code as 'lite' as possible to prevent the debugger
+# from slowing down the user's application
+#
+# When a perl program is parsed with the -d(in our case a -d:ptkdb) option
+# the parser will route all subroutine calls through here, setting $DB::sub
+# to the name of the subroutine to be called, leaving it to the debugger to
+# make the actual subroutine call and do any pre or post processing it may
+# need to do.	 In our case we take the opportunity to track the depth of the call
+# stack so that we can update our 'Stack' menu when we stop.	
+#
+# Refs:	 Progamming Perl 2nd Edition, Larry Wall, O'Reilly & Associates, Chapter 8
+#
+#
+		 sub sub {
+			 my ($result, @result) ;
+#
+# See NOTES(1)
+#
+			 if( wantarray ) {
+			 $DB::subroutine_depth += 1 unless $DB::on ;
+			 $DB::single = 0 if ( ($DB::step_over_depth < $DB::subroutine_depth) && ($DB::step_over_depth >= 0) && !$DB::on) ;
+
+				 no strict ; # otherwise perl gripes about calling the sub by the reference
+				 @result = &$DB::sub ; # call the subroutine by name
+				 use strict ;
+
+			 $DB::subroutine_depth -= 1 unless $DB::on ;
+			 $DB::single = 1 if ($DB::step_over_depth >= $DB::subroutine_depth && !$DB::on) ;	 
+				 return @result ;
+			 }
+			 else {
+			 $DB::subroutine_depth += 1 unless $DB::on ;
+			 $DB::single = 0 if ( ($DB::step_over_depth < $DB::subroutine_depth) && ($DB::step_over_depth >= 0) && !$DB::on) ;
+
+				 no strict ; # otherwise perl gripes about calling the sub by the reference
+				 $result = &$DB::sub ; # call the subroutine by name
+				 use strict ;
+
+			 $DB::subroutine_depth -= 1 unless $DB::on ;
+			 $DB::single = 1 if ($DB::step_over_depth >= $DB::subroutine_depth	 && !$DB::on) ;
+				 return $result ;	
+			 }
+			 
+		 } # end of sub 
+
+1 ; # return true value
diff --git a/src/Math/Bezier/Convert.pm b/src/Math/Bezier/Convert.pm
new file mode 100644
index 0000000..717d887
--- /dev/null
+++ b/src/Math/Bezier/Convert.pm
@@ -0,0 +1,349 @@
+package Math::Bezier::Convert;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+require 5.005_62;
+use strict;
+use warnings;
+use Carp;
+
+require Exporter;
+
+our @ISA = qw(Exporter);
+
+our %EXPORT_TAGS = ( 'all' => [ qw(
+    divide_cubic
+    divide_quadratic
+    cubic_to_quadratic
+    quadratic_to_cubic
+    cubic_to_lines
+    quadratic_to_lines
+) ] );
+
+our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+our @EXPORT = qw(
+	
+);
+our $VERSION = '0.01';
+
+# Globals
+
+our $APPROX_QUADRATIC_TOLERANCE = 1;
+our $APPROX_LINE_TOLERANCE = 1;
+our $CTRL_PT_TOLERANCE = 3;
+
+sub divide_cubic {
+    my ($p0x, $p0y, $p1x, $p1y, $p2x, $p2y, $p3x, $p3y, $sep) = @_;
+    my ($p10x, $p10y, $p11x, $p11y, $p12x, $p12y, $p20x, $p20y, $p21x, $p21y, $p30x, $p30y);
+
+    $p10x = $p0x + $sep * ($p1x - $p0x);
+    $p10y = $p0y + $sep * ($p1y - $p0y);
+    $p11x = $p1x + $sep * ($p2x - $p1x);
+    $p11y = $p1y + $sep * ($p2y - $p1y);
+    $p12x = $p2x + $sep * ($p3x - $p2x);
+    $p12y = $p2y + $sep * ($p3y - $p2y);
+    $p20x = $p10x+ $sep * ($p11x-$p10x);
+    $p20y = $p10y+ $sep * ($p11y-$p10y);
+    $p21x = $p11x+ $sep * ($p12x-$p11x);
+    $p21y = $p11y+ $sep * ($p12y-$p11y);
+    $p30x = $p20x+ $sep * ($p21x-$p20x);
+    $p30y = $p20y+ $sep * ($p21y-$p20y);
+
+    return ($p0x, $p0y, $p10x, $p10y, $p20x, $p20y, $p30x, $p30y, $p21x, $p21y, $p12x, $p12y, $p3x, $p3y);
+}
+
+sub divide_quadratic {
+    my ($p0x, $p0y, $p1x, $p1y, $p2x, $p2y, $sep) = @_;
+    my ($p10x, $p10y, $p11x, $p11y, $p20x, $p20y);
+
+    $p10x = $p0x + $sep * ($p1x - $p0x);
+    $p10y = $p0y + $sep * ($p1y - $p0y);
+    $p11x = $p1x + $sep * ($p2x - $p1x);
+    $p11y = $p1y + $sep * ($p2y - $p1y);
+    $p20x = $p10x+ $sep * ($p11x-$p10x);
+    $p20y = $p10y+ $sep * ($p11y-$p10y);
+
+    return ($p0x, $p0y, $p10x, $p10y, $p20x, $p20y, $p11x, $p11y, $p2x, $p2y);
+}
+
+sub cubic_to_quadratic {
+    my ($p0x, $p0y, @cp) = @_;
+    my ($p1x, $p1y, $p2x, $p2y, $p3x, $p3y);
+    my ($a1, $b1, $a2, $b2, $cx, $cy) = (undef) x 6;
+    my @qp = ($p0x, $p0y);
+    my @p;
+
+    croak '$CTRL_PT_TOLERANCE must be more than 1.5 ' unless $CTRL_PT_TOLERANCE > 1.5;
+
+CURVE:
+    while (@cp and @p = ($p1x, $p1y, $p2x, $p2y, $p3x, $p3y) = splice(@cp, 0, 6)) {
+
+	my $step = 0.5;
+	my $sep = 1;
+	my @qp1 = ();
+	my @cp1 = ();
+	my ($cp3x, $cp3y);
+
+	while ($step > 0.0000001) {
+
+	    my ($v01x, $v01y) = ($p1x-$p0x, $p1y-$p0y);
+	    my ($v02x, $v02y) = ($p2x-$p0x, $p2y-$p0y);
+	    my ($v03x, $v03y) = ($p3x-$p0x, $p3y-$p0y);
+	    my ($v32x, $v32y) = ($p2x-$p3x, $p2y-$p3y);
+
+	    next CURVE if (abs($v01x)<0.0001 and abs($v02x)<0.0001 and abs($v03x)<0.0001 and
+			   abs($v01y)<0.0001 and abs($v02y)<0.0001 and abs($v03y)<0.0001);
+
+
+	    if (abs($v01x)<0.0001 and abs($v32x)<0.0001 and
+		abs($v01y)<0.0001 and abs($v32y)<0.0001) {
+
+		@qp1 = (($p0x+$p3x)/2, ($p0y+$p3y)/2);
+		last;
+	    }	    
+
+	    my $n = $v01y*$v32x - $v01x*$v32y;
+	    if ($n == 0) {
+		if ($v02x*$v32y - $v02y*$v32x == 0) {
+		    @qp1 = (($p0x+$p3x)/2, ($p0y+$p3y)/2);
+		    last;
+		} else {
+		    $sep -= $step;
+		    $step /= 2;
+		    next;
+		}
+	    }
+	    my $m1 = $v01x*$v03y - $v01y*$v03x;
+	    my $m2 = $v02x*$v03y - $v03x*$v02y;
+	    if ($m1/$n < 1 or $m2/$n < 1 or $m1/$n >$CTRL_PT_TOLERANCE or $m2/$n > $CTRL_PT_TOLERANCE) {
+		$sep -= $step;
+		$step /= 2;
+		next;
+	    }
+	    $cx = $p0x + $m2 * $v01x / $n;
+	    $cy = $p0y + $m2 * $v01y / $n;
+	
+	    if (defined $cx and _q_c_check($p0x, $p0y, $p1x, $p1y, $p2x, $p2y, $p3x, $p3y, $cx, $cy)) {
+		@qp1 = ($cx, $cy);
+		last if $sep>=1;
+		$sep += $step;
+	    } else {
+		$sep -= $step;
+	    }
+	    $step /= 2;
+	} continue {
+	    (undef, undef, $p1x, $p1y, $p2x, $p2y, $p3x, $p3y, @cp1) = divide_cubic($p0x, $p0y, @p, $sep);
+	}
+	unless (@qp1) {
+	    die "Can't approx @p";
+#	    return @qp;
+	}
+	push @qp, @qp1, $p3x, $p3y;
+	$p0x = $p3x;
+	$p0y = $p3y;
+	if (@cp1) {
+	    @p = ($p1x, $p1y, $p2x, $p2y, $p3x, $p3y) = @cp1;
+	    redo;
+	}
+    }
+    return @qp;
+}
+
+sub _q_c_check {
+    my ($cx0, $cy0, $cx1, $cy1, $cx2, $cy2, $cx3, $cy3, $qx1, $qy1) = @_;
+    my ($a, $b, $c, $d, $sep);
+
+    $a = (($cx0-$cx3)*($cy1-$cy3)-($cy0-$cy3)*($cx1-$cx3)<=>0);
+    $b = (($cx0-$cx3)*($cy2-$cy3)-($cy0-$cy3)*($cx2-$cx3)<=>0);
+    return if ($a == 0 or $b == 0 or $a != $b);
+
+    my ($cx, $cy) = (divide_cubic($cx0,$cy0,$cx1,$cy1,$cx2,$cy2,$cx3,$cy3, 0.5))[6,7];
+    $a = $cx0-2*$qx1+$cx3;
+    $b = 2*$qx1-2*$cx0;
+    $c = $cx0-$cx;
+    $d = $b*$b-4*$a*$c;
+    return if ($d<0);
+    my ($qx, $qy);
+    if ($a!=0) {
+	$sep = (-$b-sqrt($d))/2/$a;
+	$sep = (-$b+sqrt($d))/2/$a if ($sep<=0 or $sep>=1);
+	return if ($sep<=0 or $sep>=1);
+	($qx, $qy) = (divide_quadratic($cx0,$cy0,$qx1,$qy1,$cx3,$cy3, $sep))[4, 5];
+    } else {
+	($qx, $qy) = ($qx1, $qy1);
+    }
+    return ($cx-$qx)*($cx-$qx)+($cy-$qy)*($cy-$qy) < $APPROX_QUADRATIC_TOLERANCE;
+}
+
+sub quadratic_to_cubic {
+    my ($p0x, $p0y, @qp) = @_;
+    my @cp = ($p0x, $p0y);
+    my ($p1x, $p1y, $p2x, $p2y);
+
+    while (@qp and ($p1x, $p1y, $p2x, $p2y) = splice(@qp, 0, 4)) {
+	push @cp, $p0x+($p1x-$p0x)*2/3, $p0y+($p1y-$p0y)*2/3, $p1x+($p2x-$p1x)/3, $p1y+($p2y-$p1y)/3, $p2x, $p2y;
+	$p0x = $p2x;
+	$p0y = $p2y;
+    }
+    return @cp;
+}
+
+sub cubic_to_lines {
+    my @cp = @_;
+    my @p;
+    my @last = splice(@cp, 0, 2);
+    my @lp = @last;
+
+    while (@cp and @p = splice(@cp, 0, 6)) {
+	push @lp, _c2lsub(@last, @p);
+	push @lp, @last = @p[4,5];
+    }
+    return @lp;
+}
+
+sub _c2lsub {
+    my @p = @_;
+    my ($p0x, $p0y, $p10x, $p10y, $p20x, $p20y, $p30x, $p30y, $p21x, $p21y, $p12x, $p12y, $p3x, $p3y) =
+	divide_cubic(@p[0..7], 0.5);
+    my ($cx, $cy) = (($p0x+$p3x)/2, ($p0y+$p3y)/2);
+    return () if (($p30x-$cx)*($p30x-$cx)+($p30y-$cy)*($p30y-$cy) < $APPROX_LINE_TOLERANCE);
+    return (_c2lsub($p0x, $p0y, $p10x, $p10y, $p20x, $p20y, $p30x, $p30y), $p30x, $p30y, _c2lsub($p30x, $p30y, $p21x, $p21y, $p12x, $p12y, $p3x, $p3y));
+}
+
+sub quadratic_to_lines {
+    my @qp = @_;
+    my @p;
+    my @last = splice(@qp, 0, 2);
+    my @lp = @last;
+
+    while (@qp and @p = splice(@qp, 0, 4)) {
+	push @lp, _q2lsub(@last, @p);
+	push @lp, @last = @p[2,3];
+    }
+    return @lp;
+}
+
+sub _q2lsub {
+    my @p = @_;
+    my ($p0x, $p0y, $p10x, $p10y, $p20x, $p20y, $p11x, $p11y, $p2x, $p2y) =
+	divide_quadratic(@p[0..5], 0.5);
+    my ($cx, $cy) = (($p0x+$p2x)/2, ($p0y+$p2y)/2);
+    return () if (($p20x-$cx)*($p20x-$cx)+($p20y-$cy)*($p20y-$cy) < $APPROX_LINE_TOLERANCE);
+    return (_q2lsub($p0x, $p0y, $p10x, $p10y, $p20x, $p20y), $p20x, $p20y, _q2lsub($p20x, $p20y, $p11x, $p11y, $p2x, $p2y));
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Math::Bezier::Convert - Convert cubic and quadratic bezier each other.
+
+=head1 SYNOPSIS
+
+  use Math::Bezier::Convert;
+
+  @new_cubic = divide_cubic($cx1, $cy1, $cx2, $cy2, $cx3, $cy3, $cx4, $cy4, $t);
+  @new_quad  = divide_quadratic($cx1, $cy1, $cx2, $cy2, $cx3, $cy3, $t);
+  @quad = cubic_to_quadratic(@cubic);
+  @cubic = quadratic_to_cubic(@quad);
+  @lines = cubic_to_lines(@cubic);
+  @lines = quadratic_to_lines(@cubic);
+
+=head1 DESCRIPTION
+
+Math::Bezier::Convert provides functions to convert quadratic bezier to cubic, 
+to approximate cubic bezier to quadratic, and to approximate cubic and quadratic 
+bezier to polyline.
+
+Each function takes an array of the coordinates of control points of the bezier curve.
+Cubic bezier consists of one I<ANCHOR> control point, two I<DIRECTOR> control points, one I<ANCHOR>, two I<DIRECTORS>, ... and the last I<ANCHOR>. 
+Quadratic bezier consists of one I<ANCHOR>, one I<DIRECTOR>, ... and the last I<ANCHOR>.
+The curve pass over the I<ANCHOR> point, but dose not the I<DIRECTOR> point.  
+Each point consists of X and Y coordinates.  Both are flatly listed in the 
+array of the curve, like ($x1, $y1, $x2, $y2, ...).
+
+=over 4
+
+=item divide_cubic( $cx1, $cy1, $cx2, $cy2, $cx3, $cy3, $cx4, $cy4, $t )
+
+divides one segment of the cubic bezier curve at ratio $t, and returns 
+new cubic bezier which has two segment (7 points).
+
+=item divide_quadratic( $cx1, $cy1, $cx2, $cy2, $cx3, $cy3, $t )
+
+divides one segment of the quadratic bezier curve at ratio $t, and returns 
+new quadratic bezier which has two segment (5 points).
+
+=item cubic_to_quadratic( @cubic )
+
+approximates cubic bezier to quadratic bezier, and returns an array of the 
+control points of the quadratic bezier curve.
+
+=item quadratic_to_cubic( @quadratic )
+
+converts quadratic bezier to cubic bezier, and returns an array of the 
+control points of the cubic bezier curve.
+
+=item cubic_to_lines( @cubic )
+
+approximates cubic bezier to polyline, and returns an array of endpoints.
+
+=item quadratic_to_lines( @cubic )
+
+approximates quadratic bezier to polyline, and returns an array of endpoints.
+
+=back
+
+=head2 GLOBALS
+
+=over 4
+
+=item $Math::Bezier::Convert::APPROX_QUADRATIC_TOLERANCE
+
+=item $Math::Bezier::Convert::APPROX_LINE_TOLERANCE
+
+Tolerance of the distance between the half point of the cubic bezier and the approximation point.
+Default is 1.
+
+=item $Math::Bezier::Convert::CTRL_PT_TOLERANCE
+
+Tolerance of the I<ANCHOR-DIRECTOR> distance ratio of quadratic to cubic.
+Default is 3.  It must be specified more than 1.5.
+
+=back
+
+=head2 EXPORT
+
+None by default.
+All functions described above are exported when ':all' tag is specified.
+All global variables are not exported in any case.
+
+=head1 COPYRIGHT
+
+Copyright 2000 Yasuhiro Sasama (ySas), <ysas@nmt.ne.jp>
+
+This library is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
+
diff --git a/src/Math/Path.pm b/src/Math/Path.pm
new file mode 100644
index 0000000..d7afc20
--- /dev/null
+++ b/src/Math/Path.pm
@@ -0,0 +1,171 @@
+package Math::Path;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+use strict;
+our $recursive_depth = 2;
+
+sub new {
+	my ($class, @coords) = @_;
+	my $self = {};
+	bless $self, $class;
+	$self -> {content} = ();
+	my @path = ();
+	my $tmp = [];
+	
+	for (my $i = 0; $i < @coords; $i ++)
+	{
+		my @arr = @{$coords [$i]};
+		if (@arr == 3)
+		{
+			push (@{$tmp}, \@arr);
+		}
+		else
+		{
+			push (@{$tmp}, \@arr);
+			push (@path, $tmp);
+			$tmp = [];
+		}
+	}	
+	$self -> {curves} = \@path;
+	$self -> {lastPoint} = undef;
+	$self -> {lenght} = 0;
+	$self -> update ();
+	return $self;
+}	
+	
+sub drawLine {
+	my ($self, $x0, $y0, $x1, $y1) = @_;
+	if (!defined $self -> {content} || @{$self -> {content}} == 0)
+	{
+		push (@{$self -> {content}}, [$x0, $y0]);
+	}
+	push (@{$self -> {content}}, [$x1, $y1]);
+}
+
+sub _calcul_lenght {
+	my ($self) = @_;
+	my @content = @{$self -> {content}};
+	my $x = $content [0] -> [0];
+	my $y = $content [0] -> [1];
+	my $lenght = 0;
+	for (my $i = 0; $i < @content; $i ++)
+	{
+		my $dx = $content [$i] -> [0] - $x;
+		my $dy = $content [$i] -> [1] - $y;
+		my $d = sqrt (($dx) ** 2 + ($dy) ** 2);
+		$lenght += $d;
+		$x = $content [$i] -> [0];
+		$y = $content [$i] -> [1];
+	}
+	$self -> {lenght} = $lenght;
+}
+
+sub drawBezierRecursive {
+	my ($self, $p0, $p1, $p2, $p3, $level) = @_;
+	if ($level <= 0) 
+	{
+		$self -> drawLine ($p0 -> [0] + 0.5, $p0 -> [1] + 0.5, $p3 -> [0] + 0.5, $p3 -> [1] + 0.5);
+	}
+	else
+	{
+		my $left0 = [$p0 -> [0], $p0 -> [1]];
+		my $left1 = [($p0 -> [0] + $p1 -> [0]) / 2, ($p0 -> [1] + $p1 -> [1]) / 2];
+		my $left2 = [($p0 -> [0] + 2*$p1 -> [0] + $p2 -> [0]) / 4, ($p0 -> [1] + 2*$p1 -> [1] + $p2 -> [1]) / 4];
+		my $left3 = [($p0 -> [0] + 3*$p1 -> [0] + 3*$p2 -> [0] + $p3 -> [0]) / 8, ($p0 -> [1] + 3*$p1 -> [1] + 3*$p2 -> [1] + $p3 -> [1]) / 8];
+		my $right0 = [$left3 -> [0], $left3 -> [1]];
+		my $right1 = [($p1 -> [0] + 2*$p2 -> [0] + $p3 -> [0]) / 4, ($p1 -> [1] + 2*$p2 -> [1] + $p3 -> [1]) / 4];
+		my $right2 = [($p2 -> [0] + $p3 -> [0]) / 2, ($p2 -> [1] + $p3 -> [1]) / 2];
+		my $right3 = [$p3 -> [0],$p3 -> [1]];
+		$self -> drawBezierRecursive ($left0, $left1, $left2, $left3, $level -1);
+		$self -> drawBezierRecursive ($right0, $right1, $right2, $right3, $level -1);
+	}
+}
+
+sub update {
+	my ($self) = @_;
+	my @curr_curve = ();
+	$self -> {content} = ();
+	$self -> {lastPoint} = undef;
+	my @curves = @{$self -> {curves}};
+	for (my $i = 0; $i < @curves; $i++)
+	{
+		@curr_curve = @{$curves [$i]};
+		if (@curr_curve == 1)
+		{
+			push (@{$self -> {content}}, $curr_curve [0]);
+			$self -> {lastPoint} = $curr_curve [0];
+		}
+		elsif (@curr_curve == 2)
+		{
+			push (@{$self -> {content}}, $curr_curve [0]);
+			push (@{$self -> {content}}, $curr_curve [1]);
+			$self -> {lastPoint} = $curr_curve [1];
+		}
+		elsif (@curr_curve == 3)
+		{
+			$self -> drawBezierRecursive ($self -> {lastPoint}, $curr_curve [0], $curr_curve [1], $curr_curve [2], $recursive_depth);
+			$self -> {lastPoint} = $curr_curve [2];
+		}
+		elsif (@curr_curve == 4)
+		{
+			$self -> drawBezierRecursive ($curr_curve [0], $curr_curve [1], $curr_curve [2], $curr_curve [3], $recursive_depth);
+			$self -> {lastPoint} = $curr_curve [3];
+		}
+	}
+	$self -> _calcul_lenght ();
+}
+
+sub getRegularPoints {
+	my ($self, $nb) = @_;
+	my @points = ();
+	my $troncon = $self -> {lenght} / $nb;
+	my @content = @{$self -> {content}};
+	my $current_troncon = 0;
+	my $x = $content [0] -> [0];
+	my $y = $content [0] -> [1];
+	my $dx = 1;
+	my $dy = 1;
+	my $lenght = 0;
+	for (my $i = 0; $i < @content; $i ++)
+	{
+		$dx = $content [$i] -> [0] - $x;
+		$dy = $content [$i] -> [1] - $y;
+		
+		my $d = sqrt (($dx) ** 2 + ($dy) ** 2);
+		$lenght += $d;
+		$current_troncon += $d;
+		while ($current_troncon >= $troncon)
+		{
+			my $dtp = $troncon - ($current_troncon - $d);
+			my $px = $x + $dx * $dtp / $d;
+			my $py = $y + $dy * $dtp / $d;
+			$x = $px;
+			$y = $py;
+			$d -= $dtp;
+			$dx = $content [$i] -> [0] - $x;
+			$dy = $content [$i] -> [1] - $y;
+			$current_troncon -= $troncon;
+			push (@points, [$x, $y, atan2 ($dx, $dy)]);
+		}
+		
+		$x = $content [$i] -> [0];
+		$y = $content [$i] -> [1];
+	}
+	push (@points, [$x, $y, atan2 ($dx, $dy)]);
+	return @points;
+}
diff --git a/src/SVG/SVG2zinc.pm b/src/SVG/SVG2zinc.pm
new file mode 100644
index 0000000..f344b96
--- /dev/null
+++ b/src/SVG/SVG2zinc.pm
@@ -0,0 +1,2245 @@
+package SVG::SVG2zinc;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+#
+#	convertisseur SVG->TkZinc
+# 
+#	Copyright 2002-2003
+#	Centre d'?tudes de la Navigation A?rienne
+#
+#	Author: Christophe Mertz <mertz at intuilab dot com> 
+#								previously <mertz at cena dot fr>
+#		  with many helps from
+#		  Alexandre Lemort <lemort at intuilab dot com>
+#		  Celine Schlienger <celine at intuilab dot com>
+#		  St?phane Chatty <chatty at intuilab dot com>
+#
+# $Id: SVG2zinc.pm,v 1.6 2007-03-06 07:53:22 merlin Exp $
+#############################################################################
+#
+# this is the main module of the a converter from SVG file
+# to either perl script/module (an eventually other scripting language)
+# It is also usable to display SVG graphic file in Tk::Zinc
+
+#############################################################################
+# limitations are now listed in the POD at the end of this file
+#############################################################################
+
+use strict;
+use XML::Parser;
+use Carp;
+use Math::Trig;
+use English;
+use File::Basename;
+
+use SVG::SVG2zinc::Conversions;
+
+use vars qw($VERSION $REVISION @ISA @EXPORT);
+@EXPORT = qw( parsefile findINC );
+
+$REVISION = q$Revision: 1.6 $ ;
+$VERSION = "0.10";
+
+# to suppress some stupid warning usefull for debugging only
+my $warn=0;
+
+my $verbose;
+
+my $current_group;
+my @prev_groups = ();
+my %current_context;
+my @prev_contexts = ();
+
+my $itemCount = 0;
+my $effectiveItemCount = 0;  # to know if some groups are empty (cf &defs et &defs_)
+my $prefix;				  # prefix used in tags associated to generated items
+my $colorSep = ";";
+
+my $includeFollowingItems = 0;
+my $targetName = '';
+my @nameStack = ();
+
+sub InitVars {
+	@prev_groups = ();
+	%current_context = ();
+	@prev_contexts = ();
+	$itemCount = 0;
+	$effectiveItemCount = 0;
+	$colorSep = ";";
+	$includeFollowingItems = 0;
+	$targetName = '';
+	@nameStack = ();
+}
+
+# This hash table indicates all non-implemented extensions
+# Normaly, the href extension is the only implemented extension listed in the SVG entity
+# The hash-value associated to a not implemented etension is 0
+# The hash-value is then set to 1 when an warning message has been printed once
+my %notImplementedExtensionPrefix; 
+
+
+# events on "graphics and container elements"
+my @EVENT_ON_GRAPHICS = qw/
+	onfocusin onfocusout onactivate onclick
+	onmousedown onmouseup onmouseover onmousemove onmouseout onload
+/;
+# events on "Document-level event attributes"
+my @EVENT_ON_DOC = qw /onunload onabort onerror onresize onscroll onzoom/;
+# events "Animation event attributes"
+my @EVENT_ON_ANIM = qw /onbegin onend onrepeat/ ;
+
+my %EVENT_ON_GRAPHICS = map { $_ => 1 } @EVENT_ON_GRAPHICS;
+my %EVENT_ON_DOC	  = map { $_ => 1 } @EVENT_ON_DOC;
+my %EVENT_ON_ANIM	 = map { $_ => 1 } @EVENT_ON_ANIM;
+
+
+### @STYLE_ATTRS and %STYLE_ATTRS are "constant" array and hash used in
+#### &analyze_style , &analyze_text_style , &groupContext , &attrs_implemented
+my @STYLE_ATTRS = qw(
+	class style display ddisplay fill fill-opacity fill-rule stroke
+	stroke-width stroke-opacity opacity font-size font-family
+	font-weight stroke-linejoin stroke-linecap stroke-dasharray text-anchor
+) ;
+my %STYLE_ATTRS = map { $_ => 1 } @STYLE_ATTRS;
+
+#### not implemented / not implementable attributes
+#### these attributes will generate only limited warning
+#### used in &attrs_implemented
+my @STYLE_ATTRS_NYI = qw (
+	stroke-miterlimit
+	gradientUnits gradientTransform spreadMethod
+	clip-rule clip-path
+	name
+) ;   # what is the foolish name?
+my %STYLE_ATTRS_NYI = map { $_ => 1 } @STYLE_ATTRS_NYI;
+
+#### not yet implemented tags (to avoid many many error messages)
+#### this list could be used to clearly distinguishe TAGS
+#### not yet implemented or not implementable.
+#### This list is curently not used! consider it as a piece of comment!
+my @NO_YET_IMPLEMENTED_TAGS = qw ( midPointStop filter feColorMatrix feComponentTransfer feFuncA);
+
+my $fileDir; ## in fact this could be a part of an url
+			 ## but we currently only get files in the some directories
+my $backend; ## the backend used to produce/interpret  perl or tcl or whatever...
+
+my $expat;
+sub parsefile {
+	my ($svgfile, $backendName, %args) = @_;
+	&InitVars;
+	$fileDir = dirname($svgfile)."/";
+	$targetName = defined $args{-target} ? $args{-target}: '';
+	delete ($args{"-target"});
+	$includeFollowingItems = $targetName ne '' ? 0 : 1;
+	$verbose = defined $args{-verbose} ? $args{-verbose}: 0;
+	$prefix =  defined $args{-prefix} ? $args{-prefix} : "";
+	delete $args{-prefix};
+	my $namespace = defined $args{-namespace} ? $args{-namespace} : 0;
+	delete $args{-namespace};
+	&SVG::SVG2zinc::Conversions::InitConv(\&myWarn, \&current_line);
+	require SVG::SVG2zinc::Backend::PerlClass;
+	$backend = SVG::SVG2zinc::Backend::PerlClass -> new (-in => $svgfile, %args);
+	$current_group = $backend -> _topgroup;
+	$backend -> fileHeader;
+	my $parser = new XML::Parser(
+		Style => 'SVG2zinc',
+		Namespaces => $namespace,  # well this works for dia shape dtd!
+		Pkg => 'SVG::SVG2zinc',
+		ErrorContext => 3,
+	);
+	$parser -> setHandlers(
+		Char	=> \&Char,
+		Init	=> \&Init,
+		Final   => \&Final,
+		XMLDecl => \&XMLDecl,
+	);
+	my $svg = $parser->parsefile($svgfile);
+	$backend -> fileTail;
+	&print_warning_for_not_implemented_attr;
+}
+
+## as it seems that some svg files are using differencies between dtd 1.0 and 1.1
+## we need to know which version of the dtd we are using (defaulted to 1.0)
+my $dtdVersion;
+sub XMLDecl {
+	my ($parser, $Version, $Encoding, $Standalone) = @_;
+	if (defined $Version) 
+	{
+		$dtdVersion = $Version;
+	}
+	else
+	{
+		$dtdVersion = 1.0;
+	}
+}
+
+
+
+# the svg tags are translated in group items.
+# If the SVG tag contains both width and height properties
+# they will be reported in the generated group as tags :
+# 'height=xxx' 'width=xxx'
+
+sub svg {
+}
+
+sub svgold {
+	my ($parser, $elementname, %attrs) = @_;
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	delete $attrs{xmlns}; # this attribute is mandatory, but useless for SVG2zinc
+
+	my ($width,$height)=&sizesConvert( \%attrs , qw (width height)); #! this defines the Zinc size!
+	# case when the width or height is defined in %
+	# the % refers to the size of an including document
+	undef $width if defined $attrs{width} and $attrs{width} =~ /%/ ;
+	undef $height if defined $attrs{height} and $attrs{height}=~ /%/ ;
+	my $widthHeightTags="";
+	if (defined $width and defined $height) 
+	{
+		$widthHeightTags = ", 'width=" . &float2int($width) . 
+		"', 'height=" . &float2int($height) . "'";
+	}
+	if (!@prev_contexts) 
+	{ # we are in the very top svg group!
+		$widthHeightTags .= ", 'svg_top'";
+	}
+	my $res = "->add('group',$current_group, -tags => [$name$widthHeightTags], -priority => 10";
+	unshift @prev_contexts, \%current_context;
+	my $prop;
+	($prop, %current_context) = &groupContext ($name, %attrs);
+	$res .= $prop . ");";
+	
+	unshift @prev_groups, $current_group;
+	foreach my $attr (keys %attrs) 
+	{
+		if ($attr =~ /^xmlns:(.+)/ ) 
+		{
+			my $extensionPrefix = $1;
+			# this xlink extension is only partly implemented
+			# (ie. when the url refers an image file in the same directory than the SVG file)
+			next if ($extensionPrefix eq 'xlink');  
+			print "$extensionPrefix is not implemented\n";
+			$notImplementedExtensionPrefix{$extensionPrefix} = 0;
+		}
+	}
+	&attrs_implemented ( 'svg', $name, 
+		[qw ( id width height viewBox preserveAspectRatio xmlns),
+		# the following attributes are not currently implementable
+		qw ( enable-background overflow )], %attrs 
+	);
+	&stackPort($name, $width,$height, $attrs{viewBox}, $attrs{preserveAspectRatio});
+	&display ($res);
+}
+
+my @portStack;
+sub stackPort {
+#	my ($name, $width,$height,$viewbox,$aspectRatio)=@_;
+	unshift @portStack, [ @_ ];
+}
+
+## to treat the viewbox, preserveAspectRatio attributes
+## of the svg, symbol, image, foreignObject... entities
+sub viewPortTransforms {
+	my $portRef = shift @portStack;
+	my ($name, $width,$height,$viewbox,$aspectRatio)=@{$portRef};
+	$viewbox = "" unless defined $viewbox;
+	$aspectRatio = "" unless defined $aspectRatio;
+	$width = "" unless defined $width;
+	$height = "" unless defined $height;
+#	print "In $name: width=$width height=$height viewbox=$viewbox aspectRatio=$aspectRatio\n";
+	if ($viewbox and $width and $height ) {
+	my $expr = "->adaptViewport($name, $width,$height, '$viewbox', '$aspectRatio');";
+#	print "Expr = $expr\n";
+	&display($expr);
+#	if (!$aspectRatio or $aspectRatio eq "none") {
+#		my $translateX = $minx;
+#		my $translateY = $miny;
+#		my $scaleX= $width /  ($portWidth - $minx);
+#		my $scaleY= $height / ($portHeight - $miny);
+#		@transfs = ("->translate($name, $translateX, $translateY);",
+#			"->scale($name, $scaleX, $scaleY);");
+#		   &display(@transfs);
+	}
+}
+
+
+sub svgold_ {
+	my ($parser, $elementname) = @_;
+	print "############ End of $elementname:\n" if $verbose;
+	&viewPortTransforms;
+	$current_group = shift @prev_groups;
+	%current_context = %{shift @prev_contexts};
+}
+
+# just to avoid useless warning messages
+sub desc {}
+sub desc_ { }
+
+# just to avoid useless warning messages
+sub title {}
+sub title_ { }
+
+# just to avoid useless warning messages in svg tests suites
+sub Paragraph {}
+sub Paragraph_ { }
+
+## return either the id of the object or a name of the form '__<elementtype>__<$counter>'
+## the returned named includes single quotes!
+## it also increments two counters:
+##  - the itemCount used for naming any item
+##  - the effectiveItemCount for counting graphic items only
+##	This counter is used at the end of a defs to see if a group
+##	must be saved, or if the group is just empty
+sub name {
+	my ($type, $id) = @_;
+	print "############ In $type:\n" if $verbose;
+	$itemCount++;
+	$effectiveItemCount++ if (defined $id and
+				  $type ne 'defs' and
+				  $type ne 'switch' and
+				  $type ne 'g' and
+				  $type ne 'svg' and
+				  $type !~ /Gradient/
+				  );
+	if (defined $id) {
+	$id = &cleanName ($id);
+	return ("'$id'", 1);
+	} else {
+	return ("'" . $prefix . "__$type"."__$itemCount'",0);
+	}
+}
+
+sub g {
+	my ($parser, $elementname, %attrs) = @_;
+	push (@nameStack, $attrs{id});
+	if($attrs{id} eq $targetName)
+	{
+		$includeFollowingItems = 1;
+	}
+	if( !$includeFollowingItems )
+	{
+		return;
+	}
+	%attrs = &expandAttributes ($elementname, %attrs);
+	my ($name,$natural) = &name ($elementname, $attrs {id});
+	my $res = '$parent = $previous = '." -> add ('group', $current_group, -tags => [$name], -priority => 10";
+	unshift @prev_groups, $current_group;
+	$current_group = '$parent';
+   	unshift @prev_contexts, \%current_context;
+   	my $prop;
+	($prop, %current_context) = &groupContext ($name, %attrs);
+   	$res .= $prop . ");\n";
+	$res .= 'push (@parents, $parent);';
+	&attrs_implemented ( 'g', $name, [qw ( id transform ) , @EVENT_ON_GRAPHICS ], %attrs ); ### les styles attrs sont ? traiter ? part!
+	&ddisplay ($res, &transform('$previous', $attrs{transform}));
+	&treatGroupEvent ($name, %attrs);
+}
+
+## returns true if the parameter is an EVENT_ON_GRAPHICS (ie. applies only to group-like tags)
+sub isGroupEvent {
+	my ($attr) = @_;
+	return $EVENT_ON_GRAPHICS{$attr} or 0;
+}
+
+## should bing callbacks to group, depending on events and scripts...
+## not yet implemented
+sub treatGroupEvent {
+	my ($objname, %attr) = (@_);
+	foreach my $event (@EVENT_ON_GRAPHICS) 
+	{
+		my $value = $attr{$event};
+		next unless defined $value;
+	#	print "## $objname HAS EVENT $event = $value\n";
+		# XXX what should I do here?
+	}
+}
+
+sub groupContext {
+	my ($name, %attrs) = @_;
+	my %childrenContext;
+	my $prop = "";
+	foreach my $attr (keys %attrs) 
+	{
+		my $value = $attrs{$attr};
+		if (!defined $value) 
+		{
+			&myWarn ("!! Undefined value for attribute $attr in group $name !?");
+			next;
+		}
+		elsif (&isGroupEvent ($attr)) 
+		{
+			next;
+		}
+		$value = &removeComment($value);
+		if ($attr eq 'opacity') 
+		{
+			$value = &convertOpacity ($value);
+			$prop = sprintf ", -alpha => %i", &float2int($value * 100); 
+		}
+		elsif ($attr eq 'id' or $attr eq 'transform') 
+		{
+			next;
+		}
+		elsif ($attr eq 'display' and $value eq 'none') 
+		{
+			$prop .= ", -visible => 0, -sensitive => 0";
+			&myWarn ("!! The following group is not visible: $name  !?\n");
+		}
+		elsif (&isAnExtensionAttr($attr))
+		{
+			next;
+		}
+		elsif ($attr eq 'viewBox' or $attr eq 'preserveAspectRatio'  or $attr eq 'height' or $attr eq 'width') 
+		{
+		
+		}
+		elsif (!defined $STYLE_ATTRS{$attr}) 
+		{
+			if (defined $STYLE_ATTRS_NYI{$attr}) 
+			{
+				&not_implemented_attr($attr);
+			}
+			else
+			{
+				&myWarn ("!!! Unimplemented attribute '$attr' (='$value') in group $name\n");
+			}
+			next;
+		}
+		else
+		{
+			$childrenContext{$attr} = $value;
+		}
+	}
+	print "children context: ", join (", ", (%childrenContext)) , "\n" if $verbose;
+	return ($prop, %childrenContext);
+}
+		
+
+sub g_ {
+	my ($parser, $elementname, %attrs) = @_;
+	if( !$includeFollowingItems )
+	{
+		return;
+	}
+#	 $current_group = shift @prev_groups;
+	if (!defined $attrs{opacity_group})
+	{
+		%current_context = %{shift @prev_contexts};
+	}
+	$attrs{id} = pop (@nameStack);
+	if ((defined $attrs{id}) && ($attrs{id} eq $targetName))
+	{
+		$includeFollowingItems = 0;
+	}
+	my $res = 'pop (@parents);'."\n";
+	$res .= '$parent = $parents [$#parents];'."\n";
+	&ddisplay ($res);
+}
+
+## A switch is implemented as a group.
+## BUG: In fact, we should select either the first if the tag is implemented
+## or the secund sub-tag if not.
+## In practice, the first sub-tag is not implemented in standard SVG, so we
+## we forget it and take the second one.
+## A problem will appear if the first tag is implemented, because, in this case
+## we will instanciantes both the first and second
+sub switch {
+	my ($parser, $elementname, %attrs) = @_;
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name) = &name ($elementname, $attrs{id});
+	$name =~ s/\'//g;
+	$attrs{id} = $name;
+	&g($parser, $elementname, %attrs);
+}
+
+sub switch_ {
+	&g_;
+}
+
+# a clipath is a not-visible groupe whose items define a clipping area
+# usable with the clip-path attribute
+# BUG: currently, the clipping is not implemented, but at least clipping
+## items are put in a invisible sub-group and are not displayed
+sub clipPath {
+	my ($parser, $elementname, %attrs) = @_;
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	print "In clippath $name NYI\n";
+	my $res = "->add('group',$current_group, -tags => [$name, '__clipPath'], -priority => 10, -atomic => 1, -visible => 0";
+	unshift @prev_groups, $current_group;
+	unshift @prev_contexts, \%current_context;
+	my $prop;
+	($prop, %current_context) = &groupContext ($name, %attrs);
+	$res .= $prop . ");";
+	&display ($res, &transform('$previous', $attrs{transform}));
+}
+
+sub clipPath_ {
+	my ($parser, $elementname) = @_;
+	print "############ End of $elementname:\n" if $verbose;
+	%current_context = %{shift @prev_contexts};
+}
+
+# a symbol is a non-visible group which will be instancianted (cloned) 
+# latter in a <use> tag
+sub symbol {
+	my ($parser, $elementname, %attrs) = @_;
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	## should we verify that the clippath has an Id?
+	## should we verify that <symbols> is defined inside a <defs> tag?
+	my $res = "-> add('group', $current_group, -tags => [$name], -priority => 10, -atomic => 1, -visible => 0";
+	unshift @prev_groups, $current_group;
+	unshift @prev_contexts, \%current_context;
+	my $prop;
+	($prop, %current_context) = &groupContext ($name, %attrs);
+	$res .= $prop . ");";
+#	&attrs_implemented ( 'g', $name, [qw ( id transform ) , @EVENT_ON_GRAPHICS ], %attrs ); ### les styles attrs sont ? traiter ? part!
+	&display ($res, &transform('$previous', $attrs{transform}));
+#	&treatGroupEvent ($name, %attrs);
+}
+
+sub symbol_ {
+	my ($parser, $elementname) = @_;
+	print "############ End of $elementname:\n" if $verbose;
+#	 $current_group = shift @prev_groups;
+	%current_context = %{shift @prev_contexts};
+}
+
+# this will clone and make visible either symbols or other items based on the Id refered by the xlink:href attribute
+sub use {
+	my ($parser, $elementname, %attrs) = @_;
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	my $ref = $attrs{'xlink:href'};
+	if (!defined $ref) {
+	&myWarn ("!! $elementname must have a xlink:href attribute\n");
+	return;
+	}
+	$ref =~ s/\#//;
+	my $cleanedId = &cleanName($ref); # to make the name zinc compliant
+	my $res = "-> clone ('$cleanedId', -visible => 1, -tags => [$name, 'cloned_$cleanedId']";
+	$res .= &analyze_style (\%attrs);
+	$res .=");";
+	my ($x,$y,$width,$height) = ($attrs{x},$attrs{y},$attrs{width},$attrs{height});
+	my @transforms = "-> chggroup ($name, $current_group);";
+	if (defined $x) 
+	{
+		push @transforms, "-> translate ($name, $x,$y);";
+	}
+	&display ($res,@transforms);
+}
+
+{   ## start of defs block to share $res and other variables between many functions
+
+	## XXX: BUG this code DOES NOT allow recursive defs! (this is also probably a bug in the SVG file)
+	my $defsCounter = 0;
+	my $insideGradient = 0;  ## should never exceed 1!
+	my $res; # the current gradient/object being defined
+	my $defsId; # the group id containing items to be cloned
+	# this group will be deleted later if it is empty
+	
+	my $effectiveItem;
+	## a <defs> will generate the creation of an invisible group in Tk::Zinc
+	## to be cloned latter in a <use> tag
+	## This group can be potentialy empty and in this cas it would be better
+	## not to create it, or at least delete it latter if it is empty
+	
+	sub defs {
+	}
+	
+	sub defsold {
+	my ($parser, $elementname, %attrs) = @_;
+	%attrs = &expandAttributes ($elementname,%attrs);
+	($defsId) = &name ($elementname, $attrs{id});
+	$defsId =~ s/\'//g;
+	$attrs{id} = $defsId;
+	&g($parser, $elementname, %attrs);
+	&display("-> itemconfigure ('$defsId', -visible => 0);");
+	$defsCounter++;
+	$effectiveItem = $effectiveItemCount;
+	print "############ $elementname: $defsId\n" if $verbose;
+	}
+
+sub defsold_ {
+	my ($parser, $elementname) = @_;
+	$defsCounter++;
+#	print "end of defs $defsId:", $effectiveItemCount , $effectiveItem, "\n";
+	&g_;
+	if ($effectiveItemCount == $effectiveItem) {
+	&display ("-> remove ('$defsId');");
+	}
+}
+
+
+######################################################################
+### CSS : Cascading Style Sheet
+######################################################################
+{ ### css
+	my @styles;
+	my %classes;
+	my %elementClasses;
+	my %idClasses;
+	my $in_css=0;
+sub nextStyle {
+	my $text = shift;
+	push @styles,$text;
+#	print "Style: $text\n";
+}
+
+## returns a reference to a hash-table defining pair of (attribut value) describing
+## a CSS style associated to a Class
+## returns undef if such class is not defined
+sub getClass {
+	my $class = shift;
+	my $ref_styles = $classes{$class};
+#	print "in getClass: $class  ",%classes, "\n";
+#	my %styles = %{$ref_styles}; print "in getClass: $class ", (%styles), "\n";
+	return ($ref_styles);
+}
+
+## returns a reference to a hash-table defining pair of (attribut value) describing
+## a CSS style associated to an element type
+## returns undef if such element type is not defined
+sub getElementClass {
+	my $element = shift;
+	my $ref_styles = $elementClasses{$element};
+#	my %styles = %{$ref_styles};
+#	print "in getElementClass: $element ", (%styles), "\n";
+	return ($ref_styles);
+}
+
+## returns a reference to a hash-table defining pair of (attribut value) describing
+## a CSS style associated to an Id
+## returns undef if such class is not defined
+sub getIdClass {
+	my $id = shift;
+	my $ref_styles = $idClasses{$id};
+#	my %styles = %{$ref_styles};
+#	print "in getIdClass: $id ", (%styles), "\n";
+	return ($ref_styles);
+}
+
+sub style {
+	my ($parser, $elementname, %attrs) = @_;
+	if ($attrs{type} eq "text/css") {
+	$in_css=1;
+	}
+} # end of style
+
+sub style_ {
+	my ($parser, $elementname) = @_;
+	my $str = "";
+	foreach my $s (@styles) {
+	$s = &removeComment($s);
+	$s =~ s/\s(\s+)//g ; # removing blocks of blanks
+	$str .= " " . $s;
+	}
+#	print "in style_: $str\n";
+	while ($str) {
+#	print "remaning str in style_: $str\n";
+	if ($str =~ /^\s*\.(\S+)\s*\{\s*([^\}]*)\}\s*(.*)/ ) {
+		# class styling
+		my ($name,$value) = ($1,$2);
+		$str = $3;
+#		$value =~ s/\s+$//;
+		print "STYLE of class: '$name' => '$value'\n";
+		## and now do something!
+		my %style = &expandStyle($value);
+		$classes{$1} = \%style;
+	} elsif ( $str =~ /^\s*\#([^\{]+)\s*\{\s*([^\}]*)\}\s*(.*)/ ) {
+		my ($ids,$value) = ($1,$2);
+		$str = $3;
+		print "STYLE of ids: '$ids' => '$value'\n";
+		## and now do something!
+	} elsif ( $str =~ /^\s*\[([^\{]+)\]\s*\{\s*([^\}]*)\}\s*(.*)/ ) {
+		my ($attr_val,$value) = ($1,$2);
+		$str = $3;
+		print "STYLE of attr_values: '$attr_val' => '$value'\n";
+		## and now do something!
+	} elsif  ( $str =~ /^\s*\@font-face\s*\{\s*[^\}]*\}\s*(.*)/ ) {
+		print "STYLE of font-face", substr($str, 0, 100),"....\n";
+		$str = $1;
+	} elsif  ( $str =~ /^\s*([^\s\{]+)\s*\{\s*([^\}]*)\}\s*(.*)/ ) {
+		my ($name,$value) = ($1,$2);
+		$str = $3;
+		print "STYLE of tags: '$name' => '$value'\n";
+		## and now do something... NYI
+	} else {
+		&myWarn ("unknown style : $str\nskipping this style");
+		return;
+	}
+	}
+	$in_css=0;
+	@styles=();
+} # end of style_
+
+} ### end of css
+
+######################################################################
+### gradients
+######################################################################
+
+my $gname;
+my @stops;
+my @inheritedStops;
+my $angle;
+my $center;
+my $gradientUnits;
+my @linearCoords;
+my @transformsGrad;
+
+sub radialGradient {
+	my ($parser, $elementname, %attrs) = @_;
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	&myWarn ("!! $elementname must have an id\n") unless $natural;
+	$gname = substr ($name,1,-1); # remove quote (') at the very beginning and end of $name
+	$insideGradient ++;
+	&myWarn ("Gradient '$gname' definition inside a previous gradient definition. This is bug in svg source\n")
+		unless $insideGradient == 1;
+	@stops = ();
+	@inheritedStops = ();
+	if (defined $attrs{'xlink:href'}) 
+	{
+		my $unused;
+		my $link = delete $attrs{'xlink:href'};
+		if ($link =~ /^\#(.+)$/) 
+		{
+			$link = $1;
+			@inheritedStops = @{getGradient ($link)};
+		} 
+		else 
+		{
+			# BUG??: we only treat internal links like #gradientName
+			carp "bad link towards a gradient: $link";
+		}
+	}
+	my ($fx,$fy,$cx,$cy, $r) = &sizesConvert( \%attrs , qw (fx fy cx cy r));
+	# BUG: a serious limitation is that TkZinc (3.2.6i) does not support
+	#	  the cx, cy and r parameters
+	$gradientUnits = $attrs{gradientUnits} ? $attrs{gradientUnits} : 'objectBoundingBox';
+	if (defined $cx and $cx == $fx) { delete $attrs{cx}; }  # to avoid needless warning of &attrs_implemented
+	if (defined $cy and $cy == $fy) { delete $attrs{cy}; }  # to avoid needless warning of &attrs_implemented
+	&attrs_implemented ( 'radialGradient', $name, [qw ( id fx fy r gradientUnits)], %attrs );
+
+	$fx = &float2int(($fx -0.5) * 100);
+	$fy = &float2int(($fy -0.5) * 100);
+	@linearCoords = ($fx, $fy);
+#	 $center = "$fx $fy";
+}
+
+sub radialGradient_ {
+	$insideGradient --;
+	if (!@stops) {
+	if (@inheritedStops) {
+		@stops = @inheritedStops;
+	} else {
+		carp ("Bad gradient def: nor stops, neither xlink;href");
+	}
+	}
+	my @stps = @stops;
+	my @co = @linearCoords;
+	my $gradientDefs = {type => 'radial', coords => \@co, stops => \@stps, gradientUnits => $gradientUnits, transform => []};
+	recordGradient ($gname, $gradientDefs);
+	@stops = ();
+}
+
+sub linearGradient {
+	my ($parser, $elementname, %attrs) = @_;
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	&myWarn ("!! $elementname must have an id\n") unless $natural;
+	$gname = substr ($name,1,-1); # remove quote (') at the very beginning and end of $name
+	$insideGradient ++;
+	&myWarn ("Gradient '$gname' definition inside a previous gradient Definition. This will bug\n")
+		unless $insideGradient == 1;
+	@stops = ();
+	@inheritedStops = ();
+	if (defined $attrs{'xlink:href'}) 
+	{
+		my $unused;
+		my $link = delete $attrs{'xlink:href'};
+		if ($link =~ /^\#(.+)$/) 
+		{
+			$link = $1;
+			@inheritedStops = @{getGradient ($link)};
+		} 
+		else 
+		{
+			# BUG??: we only treat internal links like #gradientName
+			carp "bad link towards a gradient: $link";
+		}
+	}
+	&attrs_implemented ( 'linearGradient', $name, [qw (gradientTransform x1 x2 y1 y2 id gradientUnits)], %attrs );
+	@linearCoords = &sizesConvert( \%attrs , qw (x1 y1 x2 y2));
+	@transformsGrad = parseGradientTransforms ($attrs{'gradientTransform'});
+	$gradientUnits = $attrs{gradientUnits} ? $attrs{gradientUnits} : 'objectBoundingBox';
+}
+
+sub linearGradient_ {
+	$insideGradient --;
+	if (!@stops) 
+	{
+		if (@inheritedStops) 
+		{
+			@stops = @inheritedStops;
+		}
+		else 
+		{
+			carp ("Bad gradient def: nor stops, neither xlink;href");
+		}
+	}
+	my @stps = @stops;
+	my @co = @linearCoords;
+	
+	my @transform = @transformsGrad;
+	my $gradientDefs = {type => 'axial', coords => \@co, stops => \@stps, gradientUnits => $gradientUnits, transform => \@transform};
+	recordGradient ($gname, $gradientDefs);
+}
+
+sub parseGradientTransforms {
+	my ($str) = @_;
+	return (1,0,0,1,0,0) if !defined $str;
+	my @fullTrans;
+
+	while ($str) {
+	my ($trans, $params, $rest) = $str =~ /\s*(\w+)\s*\(([^\)]*)\)\s*(.*)/ ;
+
+	my @params = (defined $params) ? split (/[\s,]+/, $params) : ();
+
+	if (!(defined $trans)) {
+	} elsif ($trans eq 'translate') {
+		$params[1] = 0 if scalar @params == 1;
+		push @fullTrans, [1,0,0,1,@params];
+
+	} elsif ($trans eq 'rotate') {
+		my $angle = $params[0] = &deg2rad($params[0]);
+		push @fullTrans, [cos($angle),sin($angle),-sin($angle),cos($angle),0,0];
+
+	} elsif ($trans eq 'scale') {
+		$params[1] = $params[0] if scalar @params == 1;
+		push @fullTrans, [$params[0],0,0,$params[1],0,0];
+
+	} elsif ($trans eq 'matrix') {
+		push @fullTrans, [@params];
+		
+	} elsif ($trans eq 'skewX') {
+		$params[0] = &deg2rad($params[0]);
+		push @fullTrans, [1,0,tan($params[0]),1,0,0];
+		
+	} elsif ($trans eq 'skewY') {
+		$params[0] = &deg2rad($params[0]);
+		push @fullTrans, [1,tan($params[0]),0,1,0,0];
+	   
+	} elsif ($trans eq 'skew'){
+		myWarn ("!!! Transformation $trans NOT implemented\n");
+
+	} else {
+		myWarn ("!!! Unkown transformation '$trans'\n");
+	}
+	$str = $rest;
+	}
+
+	my @transList = reverse @fullTrans;
+	my @matrix = (1,0,0,1,0,0);
+
+	foreach my $trans (@transList) {
+	my @t = @{$trans};
+	
+	my $a00 = $t[0] * $matrix[0] + $t[2] * $matrix[1];
+	my $a01 = $t[1] * $matrix[0] + $t[3] * $matrix[1];
+	my $a10 = $t[0] * $matrix[2] + $t[2] * $matrix[3];
+	my $a11 = $t[1] * $matrix[2] + $t[3] * $matrix[3];
+	my $a20 = $t[0] * $matrix[4] + $t[2] * $matrix[5] + $t[4];
+	my $a21 = $t[1] * $matrix[4] + $t[3] * $matrix[5] + $t[5];
+	
+	@matrix = ($a00,$a01,$a10,$a11,$a20,$a21);
+	}
+	return (@matrix);
+}
+
+sub stop {
+	my ($parser, $elementname, %attrs) = @_;
+	%attrs = &expandAttributes ($elementname,%attrs);
+	&myWarn ("$elementname should be defined inside <linearGradient> or <radialGradiant>\n") unless $insideGradient;
+
+	my $style = delete $attrs{'style'};
+	if (defined $style) {
+	my %keyvalues = &expandStyle($style);
+	%attrs = (%attrs , %keyvalues);
+	}
+	my $offset = $attrs{'offset'};
+	my $color = $attrs{'stop-color'};
+	if (!defined $color) {
+	&myWarn ("!! Undefined  stop-color in a <stop>\n");
+	} elsif (!defined $offset) {
+	&myWarn ("!! Undefined offset in a <stop>\n");
+	} else {
+	if ($offset =~ /([\.\d]+)%/){  
+		$offset = &float2int($1);
+#	} elsif ($offset =~ /^([.\d]+)$/) {
+#		$offset = &float2int($1*100);
+	} else {
+		$offset = &float2int($offset*100);
+	}
+ 	my ($newcol, $gd) = &colorConvert($color);
+ 	if ($newcol ne '')
+ 	{
+	 	$color = $newcol;
+ 	}
+	if (defined (my $stopOpacity = $attrs{'stop-opacity'})) {
+		$stopOpacity = &float2int($stopOpacity*100);
+		push @stops, "$color$colorSep$stopOpacity $offset";
+	} else {
+		push @stops, "$color $offset";
+	}
+	}
+} # end of stop
+
+} # end of gradient closure
+
+
+my $opacity_group = 100;
+my $start_opacity_group = 0;
+
+sub start_opacity_gp {
+	my ($parser, $elementname, $alpha) = @_;
+	if ($start_opacity_group)
+	{
+		my $res = '$parent ='." -> add ('group', $current_group, -priority => 10, -alpha => $opacity_group);";
+		unshift @prev_groups, $current_group;
+		$current_group = '$parent';
+		$res .= 'push (@parents, $parent);';
+		return $res;
+	}
+	return '';
+}
+
+sub close_opacity_gp {
+	my ($parser, $elementname, $alpha) = @_;
+	if ($start_opacity_group)
+	{
+		my $res = 'pop (@parents);'."\n";
+		$res .= '$parent = $parents [$#parents];'."\n";
+		$start_opacity_group = 0;
+		return $res;
+	}
+	return '';
+}
+
+my %convertFormat = (
+	'jpg' => 'jpeg',
+	'jpeg' => 'jpeg',
+	'png' => 'png',
+);
+
+sub image {
+	my ($parser, $elementname, %attrs) = @_;
+	push (@nameStack, $attrs{id});
+	if($attrs{id} eq $targetName)
+	{
+		$includeFollowingItems = 1;
+	}
+	if( !$includeFollowingItems )
+	{
+		return;
+	}
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+
+	my $group = $current_group;
+	my @RES;
+	if (my $opacity = $attrs{'opacity'}) 
+	{
+		# creating an intermediate group for managing the transparency
+		# BUG: we could used the attribute -color := white:$opacity
+		$opacity = &convertOpacity ($opacity);
+		if ($opacity != 1) 
+		{
+			## on cr?e un groupe pour g?rer la transparence
+			my $opacity = &float2int(100 * $opacity);
+			my $newgroup = substr ($name, 0, -1) . "transparency'";
+			push @RES , '$previous = '." -> add('group', $current_group, -alpha => $opacity, -tags => [ $newgroup ], -priority => 10);\n";
+			$group = $newgroup;
+		}
+	}
+	my $res = "";
+	my $ref = "";
+	if ($ref = $attrs {'xlink:href'}) 
+	{
+		if ($ref =~ /^data:image\/(\w+);base64,(.+)/) 
+		{
+			my $format = $1;
+			my $data = $2;
+			$ref = "data:image/$format;base64"; # $ref is used later in a tag of the icon
+			$format = $convertFormat {lc($format)};
+			$res .= '$previous = '." -> add ('icon', $group, -image => -> Photo (-data => '$data', -format => '$format')";
+		}
+		elsif ($ref =~ /^data:;base64,(.+)/) 
+		{
+			## the following piece of code works more or less ?!
+	 		## BUG: there is a pb with scaling (ex: data-svg/vero_data/propal_crea_boutons.svg) 
+			my $data = $1;
+			$ref = "data:;base64";
+			$res .= '$previous = '." -> add ('icon',$group, -image => -> Photo (-data => '$data')";
+		} 
+		else 
+		{
+			if (open REF, "$fileDir$ref") 
+			{
+				close REF;
+				$res .= '$previous = '." -> add ('icon',$group, -image => -> Photo ('$ref', -file => '$fileDir$ref')";
+			}
+			else
+			{
+				&myWarn ("When parsing the image '$name': no such file: '" . substr ("$fileDir$ref", 0,50) . "'\n") ;
+				return;
+			}
+		}
+	}
+	else 
+	{
+		&myWarn ("Unable to parse the image '$name'") ;
+		return;
+	}
+
+	$res .= ", -tags => [$name, '$ref'], -composescale => 1, -composerotation => 1, -priority => 10);";
+	push @RES, $res ;
+
+	my ($x, $y, $width, $height) = &sizesConvert ( \%attrs , qw (x y width height));
+	if ($width == 0 or $height == 0) 
+	{
+		&myWarn ("Skipping a 0 sized image: '$name' size is $width x $height\n");
+	}
+	elsif ($width < 0 or $height < 0)
+	{
+		&myWarn ("Error in the size of the image '$name' : $width x $height\n");
+	}
+	else
+	{
+		#push @RES, " -> adaptViewport ($name, $width,$height);";
+	}
+	if ($x or $y) 
+	{
+		push @RES, " -> translate (\$previous, $x,$y);";
+	}
+	
+	&attrs_implemented ( 'image', $name, [qw (transform x y width height id )], %attrs );
+	&ddisplay (@RES, &transform('$previous', $attrs{transform}));
+} # end of image
+
+sub image_ {
+	my ($parser, $elementname, %attrs) = @_;
+	$attrs{id} = pop (@nameStack);
+	if ((defined $attrs{id}) && ($attrs{id} eq $targetName))
+	{
+	$includeFollowingItems = 0;
+	}
+}
+
+sub line {
+	my ($parser, $elementname, %attrs) = @_;
+	push (@nameStack, $attrs{id});
+	if($attrs{id} eq $targetName)
+	{
+	$includeFollowingItems = 1;
+	}
+	if( !$includeFollowingItems )
+	{
+	return;
+	}
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	my $res = "->add ('curve', $current_group, [$attrs{x1}, $attrs{y1}, $attrs{x2}, $attrs{y2}], -priority => 10";
+	$res .= ", -tags => ['line'";
+	$res .= ", $name" if ($natural or $attrs{transform});
+	$res .= "]";
+	$res .= &analyze_style (\%attrs);
+	$res .=");";
+	&attrs_implemented ( 'line', $name, [qw (x1 y1 x2 y2 style id transform )], %attrs );
+	&ddisplay ($res,
+	&transform('$previous', $attrs{transform}) );
+} # end of line
+
+sub line_ {
+	my ($parser, $elementname, %attrs) = @_;
+	$attrs{id} = pop (@nameStack);
+	if ((defined $attrs{id}) && ($attrs{id} eq $targetName))
+	{
+	$includeFollowingItems = 0;
+	}
+}
+
+sub Char {
+	my ($expat, $text) = @_;
+	return if !defined $text;
+	my $type = ($expat->context)[-1];
+	return if !defined $type;
+	chomp $text;
+	return if (!$text && ($text ne "0")); # empty text!
+	if ($type eq 'tspan') 
+	{
+		&nextText ($text);
+	}
+	elsif ($type eq 'style') 
+	{
+		&nextStyle ($text);
+	}
+} # end of char
+
+my $current_font_key = '';
+my %save_current_context = ();
+
+## this lexical block allows &text, &nextTetx, &tspan, and &text_ to share common variables
+{
+	my $res;
+	my @transforms;
+	my @texts;
+	my $text_x;
+	my $text_y;
+	sub text 
+	{
+		my ($parser, $elementname, %attrs) = @_;
+		push (@nameStack, $attrs{id});
+		if($attrs{id} eq $targetName)
+		{
+			$includeFollowingItems = 1;
+		}
+		if( !$includeFollowingItems )
+		{
+			return;
+		}
+		
+		my $prop;
+		%save_current_context = %current_context;
+		($prop, %current_context) = &groupContext ("", %attrs);
+		
+		%attrs = &expandAttributes ($elementname,%attrs);
+		my ($name,$natural) = &name ($elementname, $attrs{id});
+		($text_x, $text_y) = &sizesConvert( \%attrs , qw (x y));
+		$res = "->add('text',$current_group, -composescale => 1, -composerotation => 1, -position => [0, 0], -tags => ['text'";
+		$res .= ", $name" if ($natural or $attrs{transform});
+		$res .= "], -anchor => 'nw'"; 
+		$res .= &analyze_text_style (\%attrs);
+		@texts = ();
+		@transforms = &transform('$previous', $attrs{transform});
+		&attrs_implemented ( 'text', $name, [qw (stroke-miterlimit x y id transform text-anchor font-family font-size)], %attrs );
+	}
+
+	sub nextText {
+		my $txt = shift;
+		push @texts,$txt;
+	}
+	
+	## BUG: <tspan> tags can be used to modiofy many graphics attributs of the part of the text
+	## such as colors, fonte, size and position...
+	## this is currently hard to implement as in Tk::Zinc a text item can only have one color, one size...
+	sub tspan {
+		my ($expat, $elementname, %attrs) = @_;
+		$res .= &analyze_text_style (\%attrs);
+	}
+	
+	sub text_ {
+		my ($parser, $elementname, %attrs) = @_;
+		if( !$includeFollowingItems )
+		{
+			return;
+		}
+		for (my $i=0 ; $i <= $#texts ; $i++) 
+		{
+			$texts[$i] =~ s/\'/\\'/g ;  #'
+		}
+		my $theText = join ('', @texts);
+		$res .= ", -text => '$theText', -priority => 10);";
+		my @ascent;
+		if ($text_x != 0 || $text_y != 0)
+		{
+			push (@ascent, "->  translate(\$previous, $text_x, $text_y);");
+		}
+		push (@ascent, "my \$ascent = -> fontMetrics (\$fonts{\"$current_font_key\"}, -ascent);");
+		push (@ascent, "-> translate(\$previous,0, -\$ascent);");
+	
+		&ddisplay ($res, @ascent, @transforms);
+		
+		$attrs{id} = pop (@nameStack);
+		if ((defined $attrs{id}) && ($attrs{id} eq $targetName))
+		{
+			$includeFollowingItems = 0;
+		}
+		%current_context = %save_current_context;
+	
+	}
+
+} ## end of text lexical block
+
+sub polyline {
+	my ($parser, $elementname, %attrs) = @_;
+	push (@nameStack, $attrs{id});
+	if($attrs{id} eq $targetName)
+	{
+	$includeFollowingItems = 1;
+	}
+	if( !$includeFollowingItems )
+	{
+	return;
+	}
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	my $res = "->add('curve',$current_group,[" . &points(\%attrs);
+	$res .= "], -tags => ['polyline'";
+	$res .= ", $name" if ($natural or $attrs{transform});
+	$res .= "], -priority => 10";
+	$res .= &analyze_style (\%attrs);
+	$res .=");";
+	&attrs_implemented ( 'polyline', $name, [qw (points style transform id )], %attrs );
+	&ddisplay ($res,
+		  &transform('$previous', $attrs{transform}) );
+}
+
+sub polyline_ {
+	my ($parser, $elementname, %attrs) = @_;
+	$attrs{id} = pop (@nameStack);
+	if ((defined $attrs{id}) && ($attrs{id} eq $targetName))
+	{
+	$includeFollowingItems = 0;
+	}
+}
+
+my $add_stroke = 0;
+
+sub rect {
+	my ($parser, $elementname, %attrs) = @_;
+	push (@nameStack, $attrs{id});
+	if($attrs{id} eq $targetName)
+	{
+	$includeFollowingItems = 1;
+	}
+	if( !$includeFollowingItems )
+	{
+	return;
+	}
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	my ($x,$y,$width,$height)=&sizesConvert( \%attrs , qw (x y width height));
+	
+	my ($type, $path) = getRectData ($x, $y, $width, $height, $attrs {rx}, $attrs {ry});
+
+	$add_stroke = 0;
+	
+	my $res = "\$previous = -> add('$type',$current_group, [$path], -tags => ['rect'";
+	$res .= ", $name" if ($natural or $attrs{transform});
+	$res .= "], -priority => 10";
+
+	$res .= ", -filled => 1" unless defined $attrs{fill} and $attrs{fill} eq 'none';
+	$add_stroke = 1 if defined $attrs{stroke};
+	delete $attrs{'stroke-linejoin'}; ## BUG: due to TkZinc limitation: no -joinstyle for rectangle 
+	$res .= &analyze_style (\%attrs);
+	$res .= ", -linewidth => 0" if !$add_stroke;
+	$res .=");";
+	&attrs_implemented ( 'rect', $name, [qw (id x y width height style transform rx ry )], %attrs );
+	&ddisplay ($res,
+		  &transform('$previous', $attrs{transform}) );
+}
+
+sub getRectData {
+	my ($x, $y, $width, $height, $rx, $ry) = @_;
+	my $xf = $x + $width;
+	my $yf = $y + $height;
+	if (( !defined $rx ) && ( !defined $ry ))
+	{
+		return ('rectangle', "$x,$y, ".($x+$width).','.($y+$height));
+	}
+
+	$rx = (defined $rx) ? $rx : $ry;
+	$ry = (defined $ry) ? $ry : $rx;
+	$rx = 0 if ($rx < 0);
+	$ry = 0 if ($ry < 0);
+	$rx = ($rx > $width / 2) ? $width / 2 : $rx;
+	$ry = ($ry > $width / 2) ? $width / 2 : $ry;
+	
+	my $c = (sqrt (2) - 1) * 4/3;	
+	my $retour = "[$x + $rx, $y], [$x + (1 - $c) * $rx, $y, 'c'],";
+	$retour .= "[$x, $y + (1 - $c) * $ry, 'c'], [$x, $y + $ry],";
+	$retour .= "[$x, $yf - $ry], [$x, $yf - (1 - $c) * $ry, 'c'],";
+	$retour .= "[$x + (1 - $c) * $rx, $yf, 'c'], [$x + $rx, $yf],";
+	$retour .= "[$xf - $rx, $yf], [$xf - (1 - $c) * $rx, $yf, 'c'],";
+	$retour .= "[$xf, $yf - (1 - $c) * $ry, 'c'], [$xf, $yf - $ry],";
+	$retour .= "[$xf, $y + $ry], [$xf, $y + (1 - $c) * $ry, 'c'],";
+	$retour .= "[$xf - (1 - $c) * $rx, $y, 'c'], [$xf - $rx, $y],";
+	$retour .= "[$x + $rx, $y]";
+	
+	return ('curve', $retour);
+}
+
+sub rect_ {
+	my ($parser, $elementname, %attrs) = @_;
+	$attrs{id} = pop (@nameStack);
+	if ((defined $attrs{id}) && ($attrs{id} eq $targetName))
+	{
+	$includeFollowingItems = 0;
+	}
+}
+
+sub ellipse {
+	my ($parser, $elementname, %attrs) = @_;
+	push (@nameStack, $attrs{id});
+	if($attrs{id} eq $targetName)
+	{
+	$includeFollowingItems = 1;
+	}
+	if( !$includeFollowingItems )
+	{
+	return;
+	}
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	my ($cx,$cy,$rx,$ry)=&sizesConvert( \%attrs , qw (cx cy rx ry));
+	my $res = "\$previous = ->add('arc', $current_group, [". ($cx-$rx) . ", ". ($cy-$ry) .
+	", " . ($cx+$rx) . ", ". ($cy+$ry) . "], -tags => ['ellipse',";
+	$res .= ", $name" if ($natural or $attrs{transform});
+	$res .= "], -priority => 10";
+	# by default, ellipses are filled
+	# from svg specifs). The value is set here, and can be overidden later
+	# in the  &analyze_style
+	$res .= ", -filled => 1" unless defined $attrs{fill} and $attrs{fill} eq 'none';
+	delete $attrs{'stroke-linejoin'}; ## BUG: due to TkZinc limitation: no -joinstyle for arc 
+	$res .= &analyze_style (\%attrs);
+	$res .=");";
+	&attrs_implemented ( 'ellipse', $name, [qw (cx cy rx ry style transform id )], %attrs );
+	&ddisplay ($res,
+		  &transform('$previous', $attrs{transform}) );
+}
+
+sub ellipse_ {
+	my ($parser, $elementname, %attrs) = @_;
+	$attrs{id} = pop (@nameStack);
+	if ((defined $attrs{id}) && ($attrs{id} eq $targetName))
+	{
+	$includeFollowingItems = 0;
+	}
+}
+
+sub circle {
+	my ($parser, $elementname, %attrs) = @_;
+	push (@nameStack, $attrs{id});
+	if($attrs{id} eq $targetName)
+	{
+	$includeFollowingItems = 1;
+	}
+	if( !$includeFollowingItems )
+	{
+	return;
+	}
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	my ($cx,$cy,$r)=&sizesConvert( \%attrs , qw (cx cy r));
+	my $res = "\$previous = -> add('arc',$current_group,[". ($cx-$r) . ", ". ($cy-$r) .
+	", " . ($cx+$r) . ", ". ($cy+$r) . "], -tags => ['circle'";
+	$res .= ", $name" if ($natural or $attrs{transform});
+	$res .= "], -priority => 10";
+	# by default, circles are filled
+	# from svg specifs). The value is set here, and can be overidden later
+	# in the  &analyze_style
+	$res .= ", -filled => 1" unless defined $attrs{fill} and $attrs{fill} eq 'none';
+	$res .= &analyze_style (\%attrs);
+	$res .=");";
+	delete $attrs{'stroke-linejoin'}; ## BUG: due to TkZinc limitation: no -joinstyle for arc 
+	&attrs_implemented ( 'circle', $name, [qw ( cx cy r transform id )], %attrs );
+	&ddisplay ($res,
+		  &transform('$previous', $attrs{transform}) );
+}
+
+sub circle_ {
+	my ($parser, $elementname, %attrs) = @_;
+	$attrs{id} = pop (@nameStack);
+	if ((defined $attrs{id}) && ($attrs{id} eq $targetName))
+	{
+	$includeFollowingItems = 0;
+	}
+}
+
+sub polygon {
+	my ($parser, $elementname, %attrs) = @_;
+	push (@nameStack, $attrs{id});
+	if($attrs{id} eq $targetName)
+	{
+	$includeFollowingItems = 1;
+	}
+	if( !$includeFollowingItems )
+	{
+	return;
+	}
+	%attrs = &expandAttributes ($elementname,%attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	my $res = "\$previous = -> add('curve',$current_group,[" . &points(\%attrs);
+	$res .= "], -closed => 1, -tags => ['polygon'";
+	$res .= ", $name" if ($natural or $attrs{transform});
+	$res .= "], -priority => 10";
+	# by default, polygones are filled
+	# from svg specifs). The value is set here, and can be overidden later
+	# in the  &analyze_style
+	$res .= ", -filled => 1" unless defined $attrs{fill} and $attrs{fill} eq 'none';
+	$res .= &analyze_style (\%attrs);
+	$res .= ");";
+	&attrs_implemented ( 'polygone', $name, [qw ( points style transform id )], %attrs );
+	&ddisplay ($res,
+		  &transform('$previous', $attrs{transform}) );
+}
+
+sub polygon_ {
+	my ($parser, $elementname, %attrs) = @_;
+	$attrs{id} = pop (@nameStack);
+	if ((defined $attrs{id}) && ($attrs{id} eq $targetName))
+	{
+	$includeFollowingItems = 0;
+	}
+}
+
+
+sub path {
+	my ($parser, $elementname, %attrs) = @_;
+	push (@nameStack, $attrs{id});
+	if($attrs{id} eq $targetName)
+	{
+		$includeFollowingItems = 1;
+	}
+	if( !$includeFollowingItems )
+	{
+		return;
+	}
+	$add_stroke = 0;
+	%attrs = &expandAttributes ($elementname, %attrs);
+	my ($name,$natural) = &name ($elementname, $attrs{id});
+	my $res = "";
+	my ($closed, @listOfListpoints) = &pathPoints (\%attrs);
+	my $refPoints = shift @listOfListpoints;
+	$res .= join (", ", @{$refPoints});
+	$res .= "], -tags => [$name], -priority => 10";
+	$res .= ", -filled => 1" unless defined $attrs {fill} and $attrs {fill} eq 'none';
+	$add_stroke = 1 if defined $attrs {stroke};
+	if ( defined $attrs{'fill-rule'} ) 
+	{
+		$res .= ", -fillrule => 'nonzero'" unless $attrs{'fill-rule'} eq 'evenodd';
+		delete $attrs{'fill-rule'};
+	}
+	$res .= ", -closed => $closed";
+	$res .= &analyze_style (\%attrs);
+	$res .= ", -linewidth => 0" if !$add_stroke;
+	$res .= ");";
+	# and process other contours
+	my @contours = ();
+	foreach my $refPoints (@listOfListpoints) 
+	{
+		my @points = @{$refPoints};
+		my $contour = "-> contour($name, 'add', 0, [";
+		$contour .= join (", ", @points);
+		$contour .= "]);";
+		push @contours, $contour;
+	}
+	&attrs_implemented ( 'path', $name, [qw ( d style stroke-linejoin stroke-linecap transform id stroke-dasharray )], %attrs );
+	$res = start_opacity_gp ($parser, $elementname)."\$previous = -> add('curve', $current_group, [".$res;
+	
+	&ddisplay ($res, @contours, &transform('$previous', $attrs{transform}));
+   	$res = close_opacity_gp ($parser, $elementname);
+   	&ddisplay ($res);
+
+} # end of path
+
+
+sub path_ {
+	my ($parser, $elementname, %attrs) = @_;
+	$attrs{id} = pop (@nameStack);
+	if ((defined $attrs{id}) && ($attrs{id} eq $targetName))
+	{
+	$includeFollowingItems = 0;
+	}
+}
+
+sub expandAttributes {
+	my ($elementName, %rawAttrs) = @_;
+	my (%styleKeyValues, %classKeyValues, %elementKeyValues, %idKeyValues);
+	my $style = delete $rawAttrs{'style'};
+	if (defined $style) {
+	%styleKeyValues = &expandStyle($style);
+	}
+	my $class = delete $rawAttrs{'class'};
+	if (defined $class) {  ## for the css
+	my $ref_styles = &getClass($class);
+	if (defined $ref_styles) {
+		%classKeyValues = %{$ref_styles};
+	} else {
+		&myWarn ("class attribute refers an illegal style: '$class'\n");
+	}
+	}
+	my $ref_styles = &getElementClass($elementName);
+	if (defined $ref_styles) {
+	%elementKeyValues = %{$ref_styles};
+	}
+	my $id = $rawAttrs{id};
+	if (defined $id) {
+	my $ref_style = &getIdClass($id);
+	if (defined $ref_style) {
+		%idKeyValues = %{$ref_styles};
+	}
+	} 
+   return (%rawAttrs, %elementKeyValues, %classKeyValues, %styleKeyValues, %idKeyValues); ## the order is important!
+}
+
+### CM 19/1/03: This function could be really simplified (CM 09/09/3 why??? I do not remember!)
+## analyze styles attached to an item (non text item) and on any of its groups
+sub analyze_style {
+	my ($ref_attr) = @_;
+	my %ref_attr = %{$ref_attr};
+	my %attrs = (%current_context , %ref_attr );
+	my %directkeyvalues;
+	foreach my $attr (@STYLE_ATTRS) 
+	{
+		my $value = $attrs {$attr};
+		if (defined $value) 
+		{  
+			$directkeyvalues {$attr} = &removeComment ($value);
+		}
+	}
+	return &analyze_style_hash (\%directkeyvalues);
+}
+
+
+## analyze styles attached to a text item and on any of its groups
+sub analyze_text_style {
+	my ($ref_attr) = @_;
+	my %attrs = ( %current_context , %{$ref_attr} );
+	my $res = "";
+	my $style = delete $attrs{'style'};
+	if (defined $style) 
+	{
+		my %keyvalues = &expandStyle($style);
+		$res = &analyze_text_style_hash (\%keyvalues);
+	}
+	my %directkeyvalues;
+	foreach my $attr (@STYLE_ATTRS) 
+	{
+		my $value = $attrs{$attr};
+		if (defined $value) 
+		{
+			$directkeyvalues{$attr} = &removeComment($value);
+		}
+	}
+	$res .= &analyze_text_style_hash (\%directkeyvalues);
+	return $res;
+}
+
+
+## expanses the attribute = "prop:val;prop2:val2" in a hashtable like {prop => val, prop2 => val2, ...}
+## and return this hash (BUG: may be it should return a reference!)
+sub expandStyle {
+	my ($style) = @_;
+	return () unless defined $style;
+	my %keyvalues;
+	$style = &removeComment ($style);
+	foreach my $keyvalue ( split ( /\s*;\s*/ , $style) ) 
+	{
+		my ($key, $value) = $keyvalue =~ /(.*)\s*:\s*(.*)/ ;
+		$keyvalues{$key} = $value;
+	}
+	return %keyvalues;
+}
+
+
+## Analyze attributes contained in the hashtable given as ref
+## This hashtable {attribut =>value...} must contain all
+## attributes to analyze
+## returns a string containing the TkZinc attributes
+sub analyze_style_hash {
+	my ($ref_keyvalues) = @_;
+	my %keyvalues = %{$ref_keyvalues};
+	my $res = "";
+	my $opacity = &convertOpacity (delete $keyvalues {'opacity'});
+	my $stroke = delete $keyvalues {'stroke'};
+	my $strokeOpacity = delete $keyvalues {'stroke-opacity'};
+	$strokeOpacity = 1 if !defined $strokeOpacity;
+	$strokeOpacity = &float2int (&convertOpacity ($strokeOpacity) * $opacity * 100);
+	if (defined $stroke) 
+	{
+ 		my ($color, $gd) = &colorConvert ($stroke);
+ 		if ($gd)
+ 		{
+	 		&applyGradient ($color, '-linecolor');
+ 		}
+		elsif ($color eq "none") 
+		{
+			$res .= ", -linewidth => 0";
+			delete $keyvalues {'stroke-width'};
+		} 
+		elsif ($strokeOpacity != 100)
+		{
+			if (&existsGradient ($color)) 
+			{
+				my $newColor = &addTransparencyToGradient ($color, $strokeOpacity);
+				$res .= ", -linecolor => \"$newColor\", -filled => 1";
+			} 
+			else 
+			{
+				$res .= ", -linecolor => \"$color$colorSep$strokeOpacity\"";
+			}
+		} 
+		else 
+		{
+			$res .= ", -linecolor => \"$color\"";
+		}
+		$add_stroke = 1;
+	} 
+	elsif ( $strokeOpacity != 1 ) 
+	{ 
+		# no stroke color, but opacity
+		## what should I do?!
+	}
+   	
+
+	my $fill = delete $keyvalues{'fill'};
+	my $fillOpacity = delete $keyvalues{'fill-opacity'};
+	$fillOpacity = 1 if !defined $fillOpacity;
+	$fillOpacity = &float2int(&convertOpacity($fillOpacity) * $opacity * 100);
+	delete $keyvalues{'fill-opacity'};
+	if (defined $fill) 
+	{  
+ 		my ($color, $gd) = &colorConvert ($fill);
+ 		if ($gd)
+ 		{
+ 			if ($fillOpacity != 100)
+ 			{
+ 			 	print STDERR "Attention, gros hack\n";
+ 				$start_opacity_group = 1;
+	 			$opacity_group = $fillOpacity;
+ 			}
+	 		&applyGradient ($color, '-fillcolor');
+ 		}
+		elsif ($color eq "none") 
+		{
+	   		$res .= ", -filled => 0";
+			delete $keyvalues {'fill-opacity'};
+		} 
+		elsif ( $fillOpacity != 100 ) 
+		{
+			if (&existsGradient ($color)) 
+			{
+				my $newColor = &addTransparencyToGradient ($color, $fillOpacity);
+				$res .= ", -fillcolor => \"$newColor\", -filled => 1";
+				$res .= ", -linecolor => \"$newColor\"," unless defined $stroke;
+			} 
+			else 
+			{
+				$res .= ", -fillcolor => \"$color$colorSep$fillOpacity\", -filled => 1";
+				$res .= ", -linecolor => \"$color$colorSep$fillOpacity\"," unless defined $stroke;
+			}
+		} 
+		else 
+		{
+			$res .= ", -fillcolor => \"$color\", -filled =>1";
+			$res .= ", -linecolor => \"$color\"" unless defined $stroke;
+		}
+	}
+
+	foreach my $key (sort keys %keyvalues) 
+	{
+		my $value = $keyvalues{$key};
+		next if (!defined $value);
+		if ($key eq 'stroke-width') 
+		{
+			if ( defined $keyvalues{stroke} and $keyvalues{stroke} eq 'none' ) 
+			{
+				delete $keyvalues{stroke};
+				next;
+			}
+			$value = &sizeConvert($value);
+			if ($value == 0 and $dtdVersion eq "1.0") 
+			{
+				$value = 0.1;	  # BUG? a widht of 0 is the smallest possible width in SVG 1.0 [true or false?]
+			}
+			$res .= ", -linewidth => $value";
+		} 
+		elsif ($key eq 'stroke-dasharray') 
+		{
+			$res .= ", -linestyle => \"dashed\"";
+		} 
+		elsif ($key eq 'display') 
+		{
+			if ($value eq 'none') 
+			{
+				$res .= ", -visible => 0, -sensitive => 0";
+			}
+		} 
+		elsif ($key eq 'visibility') 
+		{
+			## BUG? if a "not-visible" <g> group contains a visible graphic element
+			## this element WILL NOT be visible in TkZinc , but should be visible in SVG!!
+			## Cf specif svg p. 284
+			if ($value eq 'hidden' or $value eq 'collapse') 
+			{
+				$res .= ", -visible => 0";
+			}
+		} 
+		elsif ($key eq 'stroke-linecap') 
+		{
+			if ($value eq 'butt' or $value eq 'round') 
+			{
+				$res .= ", -capstyle => \"$value\"";
+			} 
+			elsif ($value eq 'square') 
+			{
+				$res .= ", -capstyle => \"projecting\"";
+			} 
+			else 
+			{
+				&myWarn ("!! bad value for $key style : $value\n");
+			}
+		} 
+		elsif ($key eq 'stroke-linejoin') 
+		{
+			($value) = $value =~ /(\w+)/ ;
+			$res .= ", -joinstyle => \"$value\"";
+		} 
+		elsif ($key eq 'fill-rule') 
+		{
+			### this attributes is for shape only and is analyzed in &path
+		} 
+		elsif ($key eq 'font-size') 
+		{
+			### this attributes is for text only and is analyzed in &analyze_text_style_hash
+		}
+		else 
+		{
+			&myWarn ("Unknown Style (in analyze_style_hash): $key (value is $value)\n") if $warn;
+		}
+	}
+	return $res;
+}
+
+
+sub analyze_text_style_hash 
+{
+	my ($ref_keyvalues) = @_;
+	my %keyvalues = %{$ref_keyvalues};
+
+	my $res = "";
+	my $opacity = &convertOpacity($keyvalues{opacity});
+	delete $keyvalues{'opacity'};
+
+	my $fontFamily="";
+	my $fontSize ="";
+	my $fontWeight ="";
+
+	foreach my $key (keys %keyvalues) 
+	{
+		my $value = $keyvalues{$key};
+		next if (!defined $value);  # in this case, the SVG code is invalide (TBC)
+		if ($key eq 'text-anchor') 
+		{
+			if ($value eq 'start') 
+			{
+				$res .= ", -anchor => 'nw'";
+			} 
+			elsif ($value eq 'end') 
+			{
+				$res .= ", -anchor => 'ne'";
+			} 
+			elsif ($value eq 'middle') 
+			{
+				$res .= ", -anchor => 'n'"
+			}
+		} 
+		elsif ($key eq 'display') 
+		{
+			if ($value eq 'none') 
+			{
+				$res .= ", -visible => 0, -sensitive => 0";
+			}
+		} 
+		elsif ($key eq 'visibility') 
+		{
+			## BUG? if a "not-visible" <g> group contains a visible graphic element
+			## this element WILL NOT be visible in TkZinc , but should be visible in SVG!!
+			## Cf specif svg p. 284
+			if ($value eq 'hidden' or $value eq 'collapse') 
+			{
+				$res .= ", -visible => 0";
+			}
+			## We do not treat the other possible values for display as defined in CSS2?!
+		} 
+		elsif ($key eq 'font-family') 
+		{
+			$value =~ s/\'//g;  # on removing quotes around the fonte name
+			$fontFamily = $value;
+		} 
+		elsif ($key eq 'font-size') 
+		{
+			$fontSize = $value;
+		} 
+		elsif ($key eq 'font-weight') 
+		{
+			$fontWeight = $value;
+		} 
+		elsif ($key eq 'fill') 
+		{
+			my $fillOpacity;
+ 			my ($color, $gd) = &colorConvert($value);
+ 			if ( $gd )
+ 			{
+	 			&applyGradient ($color, '-color');
+ 			}
+			elsif ($color eq 'none') 
+			{
+				# $res .= ", -filled => 0"; # this is the default value in Tk::Zinc
+			} 
+			elsif ( ($fillOpacity = $keyvalues{'fill-opacity'} or $opacity != 1) ) 
+			{
+				$fillOpacity = &convertOpacity($fillOpacity) * $opacity;
+				delete $keyvalues{'fill-opacity'};
+				if ( &existsGradient($color) )
+				{
+					#  so, apply a transparency to a Tk::Zinc named gradient
+					my $newColor = &addTransparencyToGradient($color,$fillOpacity);
+					$res .= ", -color => \"$newColor\"";
+				} 
+				else 
+				{
+					$fillOpacity = int ($fillOpacity * 100);
+					$res .= ", -color => \"$color$colorSep$fillOpacity\"";
+				}
+			} 
+			else 
+			{
+				$res .= ", -color => \"$color\"";
+			}
+		} 
+		else 
+		{
+			&myWarn ("Unknown Style of text: $key (value is $value)\n") if $warn;
+		}
+	}
+	if ($fontFamily or $fontSize or $fontWeight) 
+	{
+		## to be extended to all other fonts definition parameters
+		## NB: fontWeight is not used yet!
+		my ($fontKey,$code) = &createNamedFont ($fontFamily, $fontSize, "");
+		&display("\$fonts{\"$fontKey\"} = ") if $code;
+		&display($code) if $code;
+		$res .= ", -font => \"$fontKey\"";
+		$current_font_key = $fontKey;
+	}
+	return $res;
+}
+
+
+
+
+## print warnings for all used attributes unkonwn or not implemented
+sub attrs_implemented {
+	my ($type, $name, $ref_attrs_implemented, %attrs) = @_;
+	my %attrs_implemented;
+	foreach my $attr (@{$ref_attrs_implemented}) {
+	$attrs_implemented{$attr}=1;
+	}
+	my %expandStyle = &expandStyle ($attrs{style});
+	my %attributes = ( %expandStyle, %attrs);
+	foreach my $attr ( keys %attributes ) {
+#	print "attr: $attr  $attributes{$attr}\n";
+	if (!&isAnExtensionAttr($attr) and
+		!defined $STYLE_ATTRS{$attr} and
+		!defined $attrs_implemented{$attr}) {
+		if (defined $STYLE_ATTRS_NYI{$attr}) {
+		&not_implemented_attr($attr);
+		} else {
+		&myWarn ("!!! Unimplemented attribute '$attr' (='$attributes{$attr}') in '$type' $name\n");
+		}
+	}
+	}
+} # end of attrs_implemented
+
+# These hashes contain the number of usage of not implemented attributes and
+# the lines on svg source files where a not implemented attributes is used
+# so that they can be displayed by the sub &print_warning_for_not_implemented_attr
+my %not_implemented_attr;
+my %not_implemented_attr_lines;
+sub not_implemented_attr {
+	my ($attr) = @_;
+	$not_implemented_attr{$attr}++;
+	if (defined $not_implemented_attr_lines{$attr}) {
+	push @{$not_implemented_attr_lines{$attr}},&current_line;
+	} else {
+	$not_implemented_attr_lines{$attr} = [&current_line];
+	}
+}
+
+sub print_warning_for_not_implemented_attr {
+	foreach my $k (sort keys %not_implemented_attr) {
+	print "not implemented/implementable attribute '$k' was used $not_implemented_attr{$k} times in lines ";
+	my @lines;
+	if ($not_implemented_attr{$k} > 20) {
+		@lines = @{$not_implemented_attr_lines{$k}}[0..19];
+		print join (", ",@lines) ,"...\n";
+	} else {
+		@lines = @{$not_implemented_attr_lines{$k}};
+		print join (", ",@lines) ,"...\n";
+	}
+	}
+}
+
+
+# print a warning for the first use of an attribute of a non-implemented extension to SVG
+# return  :
+# - true if the attribute belong to an extension of SVG
+# - false if its supposed to be a standard SVG attribute (or a non-existing attribute)
+sub isAnExtensionAttr {
+	my ($attr) = @_;
+	if ( $attr =~ /^(.+):.+/ ) {
+	my $prefix = $1;
+	if (defined $notImplementedExtensionPrefix{$prefix} and
+		$notImplementedExtensionPrefix{$prefix} == 0) {
+		&myWarn ("!! XML EXTENSION '$prefix' IS NOT IMPLEMENTED\n");
+		# we set the value to 1 so that the next time we will not prnt another message
+		$notImplementedExtensionPrefix{$prefix} = 1;
+	}
+	return 1;
+	} else {
+	return 0;
+	}
+} # end of isAnExtensionAttr
+
+{
+	my $inMetadata=0;
+	sub metadata {
+	$inMetadata++;
+	}
+sub _metadata {
+	$inMetadata--;
+}
+
+sub inMetadata {
+	return $inMetadata;
+}
+}
+
+sub notYetImplemented {
+	my ($elementname) = @_;
+	&myWarn ("####### $elementname: Not Yet Implemented\n");
+}
+
+{
+	my $expat;
+sub Init {
+	$expat = shift;
+}
+sub Final {
+	undef $expat;
+}
+
+## takes 1 arg : 'message'
+sub myWarn {
+	my ($mess) = @_;
+	if (defined $expat) {
+	print STDOUT ("at ", $expat->current_line, ": $mess");
+	} else {
+	print STDOUT $mess;
+	}
+}
+
+sub current_line {
+	if (defined $expat) 
+	{
+		return $expat->current_line; 
+	} 
+	else 
+	{
+		return "_undef_";
+	}
+}
+}
+
+sub applyGradient {
+	my (@res) = @_;
+	$backend -> applyGradient(@res);
+}
+
+sub recordGradient {
+	my (@res) = @_;
+	$backend -> recordGradient(@res);
+}
+
+sub getGradient {
+	my (@res) = @_;
+	return $backend -> getGradient(@res);
+}
+
+sub display {
+	my (@res) = @_;
+	$backend -> treatLines(@res);
+}
+
+sub ddisplay {
+	my (@res) = @_;
+	$backend -> dtreatLines(@res);
+}
+
+sub findINC
+{
+ my $file = join('/',@_);
+ my $dir;
+ $file  =~ s,::,/,g;
+ foreach $dir (@INC)
+  {
+   my $path;
+   return $path if (-e ($path = "$dir/$file"));
+  }
+ return undef;
+}
+
+
+###################################################################
+### this a slightly different implementation of the subs style as defined in XML::Parser
+### Differences are :
+# - when an error occure in a callback, the error is handled and a warning is
+#	 printed with the line number of the SVG source file
+# - namespace can be used (this is usefull for example to treat the SVG included in dia data files)
+#
+
+package XML::Parser::SVG2zinc;
+$XML::Parser::Built_In_Styles{'SVG2zinc'} = 1;
+
+
+sub Start {
+	no strict 'refs';
+	my $expat = shift;
+	my $tag = shift;
+	my $ns = $expat->namespace($tag);
+	if (!defined $ns || $ns =~ /\/svg$/) 
+	{
+		## the tag is a SVG tag
+		## BUG: we should also get some tags of XML standard used by
+		## the SVG standard. Exemple: xlink:href
+		my $sub = $expat->{Pkg} . "::$tag";
+		if (defined &$sub) 
+		{
+	  		eval { &$sub($expat, $tag, @_) };
+			if ($@) 
+			{
+				$expat->xpcarp("An Error occured while evaluationg $tag {...} :\n$@");
+			}
+		} 
+		elsif (&SVG::SVG2zinc::inMetadata) 
+		{
+	  		# we do othing, unless tags were treated before!
+		}
+	  	else 
+		{
+			if ($tag eq 'a:midPointStop') {return;}
+			## skipping the tag if it is part of not implemented extension
+			my ($extension) = $tag =~ /(\w+):.*/;
+			return if defined $extension &&  defined $notImplementedExtensionPrefix{$extension};
+		 warn "## Unimplemented SVG tag: $tag\n";
+		}
+	}
+}
+
+sub End {
+  no strict 'refs';
+  my $expat = shift;
+  my $tag = shift;
+  my $ns = $expat->namespace($tag);
+  if (!defined $ns || $ns =~ /\/svg$/) {
+	  my $sub = $expat->{Pkg} . "::${tag}_";
+	  ## the tag is a SVG tag
+	  if (defined &$sub) {
+	  eval { &$sub($expat, $tag) };
+	  if ($@) {
+		  $expat->xpcarp("An Error occured while evaluationg ${tag}_ {...}) :\n$@");
+	  }
+	  } else {
+	  # the following error message is not usefull, as there were already
+	  # an error message at the opening tag
+	  # warn "## Unimplemented SVG tag: ${tag}_\n";
+	  }
+  }
+}
+
+
+
+###################################################################
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+SVG::SVG2zinc - a module to display or convert svg files in scripts, classes, images...
+
+=head1 SYNOPSIS
+
+ use SVG::SVG2zinc;
+
+ &SVG::SVG2zinc::parsefile('file.svg', 'Backend','file.svg',
+			   -out => 'outfile',
+			   -verbose => $verbose,
+			   -namespace => 0|1,
+			   -prefix => 'string', 
+			   );
+
+ # to generate a Perl script: 
+ &SVG::SVG2zinc::parsefile('file.svg','PerlScript', 
+			   -out => 'file.pl');
+
+ # to generate a Perl Class:
+ &SVG::SVG2zinc::parsefile('file.svg','PerlClass', 
+			   -out => 'Class.pm');
+
+ # to display a svgfile:
+ &SVG::SVG2zinc::parsefile('file.svg', 'Display'); 
+
+ #To convert a svgfile in png/jpeg file:
+ &SVG::SVG2zinc::parsefile('file.svg', 'Image', 
+				   -out => 'file.jpg');
+
+ # to generate a Tcl script: 
+ &SVG::SVG2zinc::parsefile('file.svg','TclScript', 
+			   -out => 'file.tcl');
+
+
+=head1 DESCRIPTION
+
+Depending on the used Backend, &SVG::SVG2zinc::parsefile either generates a Perl Class,
+Perl script, Tcl Script, bitmap images or displays SVG files inside a Tk::Zinc widget.
+
+SVG::SVG2zinc could be extended to generate Python scripts and/or
+classes, or other files, just by sub-classing SVG::SVG2zinc::Backend(3pm)
+
+==head1 HOW IT WORKS
+
+This converter creates some TkZinc items associated to most SVG tags.
+For example, <SVG> or <G> tags are transformed in TkZinc groups. <PATH>
+are converted in TkZinc curves.... many more to come...
+
+==head2 TkZinc items tags
+
+Every TkZinc item created by the parser get one or more tags. If the
+corresponding svg tag has an Id, this Id will be used as a tag, after
+some cleaning due to TkZinc limitation on tag values (no dot, star, etc...).
+If the corresponding svg tag has no Id, the parser add a tag of the
+following form : __<itemtype>__<integer>. If the parser is provided
+a B<-prefix> option, the prefix is prepended to the tag:
+<prefix>__<itemtype>__<integer>
+
+The TkZinc group associated to the top <SVG> tag has the following tag 'svg_top', as well as 'width=integer' 'heigth=integer' tags if width and height are defined in the top <SVG> tag. These tags can be used to find the group and to get its desired width and height.
+
+==head2 RunTime code
+
+There is currently on new Tk::Zinc method needed when executing perl code generated.
+This perl Tk::Zinc::adaptViewport function should be translated and included or
+imported in any script generated in an other scripting language (eg. Tcl or Python).
+
+=head1 BUGS and LIMITATIONS
+
+Some limitations are due to differences between Tk::Zinc and SVG graphic models :
+
+=over 2
+
+=item B<Drawing width>
+
+Drawing width are zoomed in SVG but are not in Tk::Zinc where it is constant whatever the zoom factor is.
+
+=item B<Gradient Transformation>
+
+Gradient Transformation is not possible in Tk::Zinc. May be it could be implemented by the converter?
+
+=item B<Rounded Rectangles>
+
+Rectangles cannot have rounded corners in Tk::Zinc. Could be implemented, by producing curve item rather than rectangles in Tk::zinc. Should be implemented in a future release of Tk::Zinc  
+
+=item B<Text and tspan tags>
+
+Text and tspan tags are very complex items in SVG, for example placement can be very precise and complex. Many such features are difficult
+to implement in Tk::Zinc and are not currently implemented
+
+=item B<Font>
+
+Font management is still limited. It will be rotatable and zoomable in future release of Tk::Zinc. SVG fonts included in a document are not readed, currently.
+
+=item B<SVG image filtering>
+
+No image filtering functions are (and will be) available with Tk::Zinc, except if YOU want to contribute?
+
+=item B<ClipPath tag>
+
+The SVG ClipPath tag is a bit more powerfull than Tk::Zinc clipping (clipper is limited to one item). So currently this is not implemented at all in SVG::SVG2zinc 
+
+=back
+
+
+There are also some limitations due to the early stage of the converter:
+
+=over 2
+
+=item B<CSS>
+
+CSS in external url is not yet implemented
+
+=item B<SVG animation and scripting>
+
+No animation is currently available, neither scripting in the SVG file. But Perl or Tcl are scripting languages, are not they?
+
+=item B<switch tag>
+
+The SVG switch tag is only partly implemented, but should work in most situations
+
+=item B<href for images>
+
+href for images can only reference a file in the same directory than the SVG source file.
+
+=back
+
+It was said there is still one hidden bug... but please patch and/or report it to the author! Any (simple ?)
+
+SVG file not correctly rendered by this module (except for limitations
+listed previously) could be send to the author with little comments
+about the expected rendering and observed differences.
+
+=head1 SEE ALSO
+
+svg2zinc.pl(1) a sample script using and demonstrating SVG::SVG2zinc
+
+SVG::SVG2zinc::Backend(3pm) to defined new backends.
+
+Tk::Zinc(3) TkZinc is available at www.openatc.org/zinc/
+
+=head1 AUTHORS
+
+Christophe Mertz <mertz at intuilab dot com>
+
+many patches and extensions from Alexandre Lemort <lemort at intuilab dot com>
+
+helps from Celine Schlienger <celine at intuilab dot com> and St?phane Chatty <chatty at intuilab dot com>
+
+=head1 COPYRIGHT
+
+CENA (C) 2002-2004, IntuiLab (C) 2004
+
+This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence.
+
+=cut
diff --git a/src/SVG/SVG2zinc/Backend.pm b/src/SVG/SVG2zinc/Backend.pm
new file mode 100644
index 0000000..badee67
--- /dev/null
+++ b/src/SVG/SVG2zinc/Backend.pm
@@ -0,0 +1,293 @@
+package SVG::SVG2zinc::Backend;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+#	Backend for SVG2zinc
+#
+#	Copyright 2003-2004
+#	Centre d'?tudes de la Navigation A?rienne
+#
+#	Author: Christophe Mertz <mertz at intuilab dot com>
+#
+#       An abstract class for code generation
+#       Concrete sub-classes can generate code for perl (script / module), tcl,
+#       printing, or direct execution
+#
+# $Id: Backend.pm,v 1.1.1.2 2006-11-16 14:51:45 merlin Exp $
+#############################################################################
+
+use strict;
+use Carp;
+use FileHandle;
+
+use vars qw( $VERSION);
+($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.2 $ =~ /(\d+)\.(\d+)/);
+
+sub new {
+    my ($class, %passed_options) = @_;
+    my $self = {};
+    bless $self, $class;
+    $self->_initialize(%passed_options);
+    return $self;
+}
+
+my %new_options = (
+		   -render => 1,
+		   -out => 1,
+		   -in => 1,
+		   -verbose => 1,
+);
+
+sub _initialize {
+    my ($self, %passed_options) = @_;
+    foreach my $opt (keys (%passed_options)) 
+    {
+		if (defined ($new_options{$opt})) 
+		{
+	    	$self->{$opt} = $passed_options{$opt};
+		} 
+		else 
+		{
+	    	carp ("Warning: option $opt unknown for a ".ref($self)."\n");
+		}
+    }
+    $self -> {-render} = 1 unless defined $self -> {-render};
+    croak("undefined mandatory -in options") unless defined $self -> {-in};
+    if (defined $self -> {-out} and $self -> {-out}) 
+    {
+		my $out = $self->{-out};
+		if (ref($out) eq 'GLOB') 
+		{
+	    	## nothing to do, the $out is supposed to be open!?
+		} 
+		else 
+		{
+		    my @reps = split ('::', $out);
+			my $file = $reps [0];
+			for (my $i = 0; $i < @reps - 1; $i++)
+			{
+				if(not -d $file)
+				{
+					if(!mkdir ($file))
+					{
+						print STDERR "##### Error creating directory: $file\n";
+					}
+				}
+				$file .= '/'.$reps [$i + 1];
+			}
+			print STDERR "writing $file...\n";
+			my $fh = FileHandle -> new("> " . $file);
+		    if ($fh) 
+		    {
+				$self->{-filehandle} = $fh;
+		    } 
+		    else 
+		    {
+				carp ("unable to open " . $out);
+		    }
+		}
+    }
+    return $self;
+}
+
+# used by SVG2zinc to know the zinc group in which the svg topgroup  
+# by default: 1
+# currently default need be overriden by PerlClass only, as far as I now!?
+sub _topgroup {
+    my ($self) = @_;
+    if ($self->{-topgroup}) {
+	return $self->{-topgroup};
+    } else {
+	return 1;
+    }
+}
+
+# returns true if code is put in a file
+sub inFile {
+    my ($self) = @_;
+    return (defined $self->{-filehandle});
+}
+
+sub printLines {
+    my ($self, @lines) = @_;
+    if ($self->inFile) {
+	my $fh = $self->{-filehandle};
+	foreach my $l (@lines) {
+	    print $fh "$l\n";
+	}
+    } else {
+	carp "printLines cannot print if no outfile has been given\n";
+    }
+}
+
+sub treatLines {
+    my ($self, @lines) = @_;
+    if ($self->inFile) {
+	$self->printLines(@lines);
+    }
+}
+
+
+## in case of file generation, should print a comment
+## the default is to print comment starting with #
+sub comment {
+    my ($self, @lines) = @_;
+    if ($self->inFile) {
+	foreach my $l (@lines) {
+	    $self->printLines("##  $l");
+	}
+    }
+}
+
+sub close {
+    my ($self) = @_;
+    if ($self->inFile) {
+	$self->{-filehandle}->close;
+    }
+}
+
+sub fileHeader {
+    my ($self) = @_;
+    $self->comment ("", "default Header of SVG::SVG2zinc::Backend", "");
+}
+
+
+sub fileTail {
+    my ($self) = @_;
+    $self->comment ("", "default Tail of SVG::SVG2zinc::Backend", "");
+    $self->close;
+}
+
+
+	
+1;
+
+
+__END__
+
+=head1 NAME
+
+SVG::SVG2zinc::Backend - a virtual class SVG::SVG2zinc svg reader. Sub-class are specialized for different type of generation
+
+=head1 SYNOPSIS
+
+package SVG::SVG2zinc::Backend::SubClass
+
+use SVG::SVG2zinc::Backend;
+
+## some methods definition
+
+....
+
+ ## when using a specialized backend:
+
+ use SVG::SVG2zinc::Backend::SubClass;
+
+ $backend = SVG::SVG2zinc::Backend::SubClass->new(
+	       -out => filename_or_handle,
+               -in => svgfilename,
+	       -verbose => 0|1,
+	       [otheroptions],
+	       );
+
+ $backend->fileHeader();
+
+ $backend->treatLines("lineOfCode1", "lineOfCode2",...);
+
+ $backend->comment("comment1", "comment2", ...);
+
+ $backend->printLines("comment1", "comment2", ...);
+
+ $backend->fileTail();
+
+=head1 DESCRIPTION
+
+SVG::SVG2zinc::Backend is a perl virtual class which should be specialized in sub-classes. It defines
+a common interface ot classes which can for example generate perl code with Tk::Zinc, display
+SVG file in a Tk::Zinc widget, convert svg file in image files (e.g. png) or generate tcl code
+to be used with TkZinc etc...
+
+A backend should provide the following methods:
+
+=over
+
+=item B<new>
+
+This creation class method should accept pairs of (-option => value) as well as the following arguments:
+
+=over
+
+=item B<-out>
+
+A filename or a filehandle ready for writing the output. In same rare cases
+(e.g. the Display backend which only displays the SVG file on the screen,
+this option will not be used)
+
+=item B<-in>
+
+The svg filename. It should be used in comments only in the generated file
+
+=item B<-verbose>
+
+It will be used for letting the backend being verbose
+
+=back
+
+=item B<fileHeader>
+
+Generates the header in the out file, if needed. This method should be called just after creating a backend and prior any treatLines or comment method call.
+
+=item B<treatLines>
+
+Processes the given arguments as lines of code. The arguments are very close to Tk::Zinc perl code. When creating a new backend, using the B<Print> backend can help understanding what are exactly these arguments.
+
+=item B<comment>
+
+Processes the given arguments as comments. Depending on the backend, this method must be redefined so that arguments are treated as comments, or just skipped.
+
+=item B<printLines>
+
+Print in an outfile the given arguments as lines of text. This method should not be re-defined, but used by any Backend which generates code.
+
+=item B<fileTail>
+
+Generate the tail in the out file if needed and closes the out file. This must be the last call.
+
+=back
+
+A backend can use the printLines method to print lines in the generated file.
+
+=head1 SEE ALSO
+
+SVG::SVG2zinc::Backend::Display(3pm), SVG::SVG2zinc::Backend::PerlScript(3pm),
+SVG::SVG2zinc::Backend::TclScript(3pm), SVG::SVG2zinc::Backend::PerlClass(3pm) code
+as examples of SVG::SVG2zinc::Backend subclasses.
+
+SVG::SVG2zinc(3pm)
+
+=head1 AUTHORS
+
+Christophe Mertz <mertz at intuilab dot com> with some help from Daniel Etienne <etienne at cena dot fr>
+
+=head1 COPYRIGHT
+    
+CENA (C) 2003-2004
+
+This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence.
+
+=cut
+
diff --git a/src/SVG/SVG2zinc/Backend/Display.pm.k b/src/SVG/SVG2zinc/Backend/Display.pm.k
new file mode 100644
index 0000000..8da4b9b
--- /dev/null
+++ b/src/SVG/SVG2zinc/Backend/Display.pm.k
@@ -0,0 +1,257 @@
+package SVG::SVG2zinc::Backend::Display;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+#	Backend Class for SVG2zinc to display a svg file in a Tk::Zinc canvas
+# 
+#	Copyright 2003
+#	Centre d'Études de la Navigation Aérienne
+#
+#	Author: Christophe Mertz <mertz at intuilab dot com>
+#
+# $Id: Display.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $
+#############################################################################
+
+use SVG::SVG2zinc::Backend;
+
+@ISA = qw( SVG::SVG2zinc::Backend );
+
+use vars qw( $VERSION);
+($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/);
+
+use strict;
+use Carp;
+use Tk::Zinc::SVGExtension;
+
+eval (require Tk::Zinc);
+if ($@) {
+    die "$@\nSVG::SVG2zinc::Backend requires Tk::Zinc to be installed\n";
+} elsif (eval ('$Tk::Zinc::VERSION !~ /^\d\.\d+$/ or $Tk::Zinc::VERSION < 3.295') ) {
+    die "Tk::Zinc must be at least 3.295";
+}
+
+
+sub new {
+    my ($class, %passed_options) = @_;
+    my $self = {};
+    bless $self, $class;
+    $self->_initialize(%passed_options);
+    return $self;
+}
+
+my $zinc;
+my ($WIDTH, $HEIGHT);
+my $top_group;
+sub _initialize {
+    my ($self, %passed_options) = @_;
+    $WIDTH = delete $passed_options{-width};
+    $WIDTH = 600 unless defined $WIDTH;
+    $HEIGHT = delete $passed_options{-height};
+    $HEIGHT = 600 unless defined $HEIGHT;
+    
+    $self->SUPER::_initialize(%passed_options);
+
+    require Tk::Zinc::Debug; # usefull for browsing items herarchy
+    my $mw = MainWindow->new();
+    my $svgfile = $self->{-in};
+    $mw->title($svgfile);
+    $zinc = $mw->Zinc(-width => $WIDTH, -height => $HEIGHT,
+		      -borderwidth => 0,
+		      -render => $self->{-render},
+		      -backcolor => "white", ## why white?
+		      )->pack(qw/-expand yes -fill both/);
+
+    if (Tk::Zinc::Debug->can('init')) {
+	# for TkZinc >= 3.2.96
+	&Tk::Zinc::Debug::init($zinc, -optionsToDisplay => "-tags", -optionsFormat => "row");
+    } else {
+	# for TkZinc <= 3.2.95
+	&Tk::Zinc::Debug::finditems($zinc);
+	&Tk::Zinc::Debug::tree($zinc, -optionsToDisplay => "-tags", -optionsFormat => "row");
+    }
+}
+
+
+sub treatLines {
+    my ($self,@lines) = @_;
+    my $verbose = $self->{-verbose};
+    foreach my $l (@lines) {
+	my $expr = $l;
+	$expr =~ s/->/\$zinc->/g;
+	my $unused = $zinc; ## due to a perl bug, this is needed so that $zinc will be known in $expr
+	my $r = eval ($expr);
+	if ($@) {
+#	    &myWarn ("While evaluationg:\n$expr\nAn Error occured: $@\n");
+	    print ("While evaluationg:\n$expr\nAn Error occured: $@\n");
+	} elsif ($verbose) {
+	    if ($l =~ /^->add/) {
+		print "$r == $expr\n" if $verbose;
+	    } else {
+		print "$expr\n" if $verbose;
+	    }
+	}
+    }
+}
+
+
+sub fileHeader {
+#    my ($self) = @_;
+}
+
+
+my $zoom;
+sub fileTail {
+    # resizing to make them all visible
+    $top_group = $zinc->find ('withtag', ".1");
+    my @bbox = $zinc->bbox($top_group);
+    $zinc->translate($top_group, -$bbox[0], -$bbox[1]) if defined $bbox[0] and $bbox[1];
+    @bbox = $zinc->bbox($top_group);
+    my $ratio = 1;
+    $ratio = $WIDTH / $bbox[2] if ($bbox[2] and $bbox[2] > $WIDTH);
+    $ratio = $HEIGHT/ $bbox[3] if ($bbox[3] and $HEIGHT/$bbox[3] lt $ratio);
+
+    $zoom=1;
+    $zinc->scale($top_group, $ratio, $ratio);
+
+    # adding some usefull callbacks
+    $zinc->Tk::bind('<ButtonPress-1>', [\&press, \&motion]);
+    $zinc->Tk::bind('<ButtonRelease-1>', [\&release]);
+    
+    $zinc->Tk::bind('<ButtonPress-2>', [\&press, \&zoom]);
+    $zinc->Tk::bind('<ButtonRelease-2>', [\&release]);
+
+    $zinc->Tk::bind('<Control-ButtonPress-1>', [\&press, \&mouseRotate]);
+    $zinc->Tk::bind('<Control-ButtonRelease-1>', [\&release]);
+    $zinc->bind('all', '<Enter>',
+                [ sub { my ($z)=@_; my $i=$z->find('withtag', 'current');
+                        my @tags = $z->gettags($i);
+                        pop @tags; # to remove the tag 'current'
+                        print "$i (", $z->type($i), ") [@tags]\n";}] );
+
+  Tk::MainLoop;
+}
+
+##### bindings for moving, rotating, scaling the displayed items
+my ($cur_x, $cur_y, $cur_angle);
+sub press {
+    my ($zinc, $action) = @_;
+    my $ev = $zinc->XEvent();
+    $cur_x = $ev->x;
+    $cur_y = $ev->y;
+    $cur_angle = atan2($cur_y, $cur_x);
+    $zinc->Tk::bind('<Motion>', [$action]);
+}
+
+sub motion {
+    my ($zinc) = @_;
+    my $ev = $zinc->XEvent();
+    my $lx = $ev->x;
+    my $ly = $ev->y;
+    
+    my @res = $zinc->transform($top_group, [$lx, $ly, $cur_x, $cur_y]);
+    $zinc->translate($top_group, ($res[0] - $res[2])*$zoom, ($res[1] - $res[3])*$zoom);
+    $cur_x = $lx;
+    $cur_y = $ly;
+}
+
+sub zoom {
+    my ($zinc, $self) = @_;
+    my $ev = $zinc->XEvent();
+    my $lx = $ev->x;
+    my $ly = $ev->y;
+    my ($maxx, $maxy);
+    
+    if ($lx > $cur_x) {
+        $maxx = $lx;
+    } else {
+        $maxx = $cur_x;
+    }
+    if ($ly > $cur_y) {
+        $maxy = $ly
+    } else {
+        $maxy = $cur_y;
+    }
+    return if ($maxx == 0 || $maxy == 0);
+    my $sx = 1.0 + ($lx - $cur_x)/$maxx;
+    my $sy = 1.0 + ($ly - $cur_y)/$maxy;
+    $cur_x = $lx;
+    $cur_y = $ly;
+    $zoom = $zoom * $sx;
+    $zinc->scale($top_group, $sx, $sx); #$sy);
+}
+
+sub mouseRotate {
+    my ($zinc) = @_;
+    my $ev = $zinc->XEvent();
+    my $langle = atan2($ev->y, $ev->x);
+    $zinc->rotate($top_group, -($langle - $cur_angle), $cur_x, $cur_y);
+    $cur_angle = $langle;
+}
+
+sub release {
+    my ($zinc) = @_;
+    $zinc->Tk::bind('<Motion>', '');
+}
+
+
+sub displayVersion {
+    print $0, " : Version $VERSION\n\tSVG::SVG2zinc.pm Version : $SVG::SVG2zinc::VERSION\n";
+    exit;
+}
+
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+SVG:SVG2zinc::Backend::Display - a backend class for displaying SVG file
+
+=head1 DESCRIPTION
+
+SVG:SVG2zinc::Backend::Display is a class for displaying SVG files.
+
+For more information, you should look at SVG:SVG2zinc::Backend(3pm).
+
+The new method accepts parameters described in the SVG:SVG2zinc::Backend class and the following additionnal parameters:
+
+=over
+
+=item B<-render>
+
+The render value of the Tk::Zinc widget. 0 means no openGL, 1 or 2 for openGL. Defaults to 1.
+
+=back
+
+=head1 SEE ALSO
+
+SVG::SVG2zinc::Backend(3pm) and SVG::SVG2zinc(3pm)
+
+=head1 AUTHORS
+
+Christophe Mertz <mertz at intuilab dot com>
+
+=head1 COPYRIGHT
+    
+CENA (C) 2003-2004 IntuiLab 2004
+
+This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence.
+
+=cut
+
diff --git a/src/SVG/SVG2zinc/Backend/Image.pm.k b/src/SVG/SVG2zinc/Backend/Image.pm.k
new file mode 100644
index 0000000..bfd7851
--- /dev/null
+++ b/src/SVG/SVG2zinc/Backend/Image.pm.k
@@ -0,0 +1,201 @@
+package SVG::SVG2zinc::Backend::Image;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+#	Backend Class for SVG2zinc to generate image files
+# 
+#	Copyright 2003
+#	Centre d'Études de la Navigation Aérienne
+#
+#	Author: Christophe Mertz <mertz at intuilab dot com>
+#
+# $Id: Image.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $
+#############################################################################
+
+use SVG::SVG2zinc::Backend;
+
+@ISA = qw( SVG::SVG2zinc::Backend );
+
+use vars qw( $VERSION);
+($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/);
+
+use strict;
+use Carp;
+use Tk::Zinc::SVGExtension;
+
+eval (require Tk::Zinc);
+if ($@) {
+    print "$@\nSVG::SVG2zinc::Backend requires Tk::Zinc to be installed\n";
+}
+
+sub new {
+    # testing that 'import' is available
+    # is this test portable?
+    my $ret = `which import`;
+    croak ("## You need the 'import' command from 'imagemagic' package to use the Image backend.\n")
+	if !$ret;
+    
+    my ($class, %passed_options) = @_;
+    my $self = {};
+    bless $self, $class;
+    $self->_initialize(%passed_options);
+    return $self;
+}
+
+my $zinc;
+sub _initialize {
+    my ($self, %passed_options) = @_;
+    if (defined $passed_options{-ratio}) {
+	if ($passed_options{-ratio} !~ /^\d+%$/) {
+	    croak ("## -ratio should look like nn%");
+	} else {
+	    $self->{-ratio} = delete $passed_options{-ratio};
+	}
+    }
+    if (defined $passed_options{-width}) {
+	$self->{-width} = delete $passed_options{-width};
+    }
+    if (defined $passed_options{-height}) {
+	$self->{-height} = delete $passed_options{-height};
+    }
+
+    $self->SUPER::_initialize(%passed_options);
+
+    my $mw = MainWindow->new();
+    my $svgfile = $self->{-in};
+    $mw->title($svgfile);
+    my $render = (defined $self->{-render}) ? $self->{-render} : 1;
+    $zinc = $mw->Zinc(-borderwidth => 0,
+		      -render => $render,
+		      -backcolor => "white", ## why white?
+		      )->pack(qw/-expand yes -fill both/);
+}
+
+
+sub treatLines {
+    my ($self,@lines) = @_;
+    my $verbose = $self->{-verbose};
+    foreach my $l (@lines) {
+	my $expr = $l;
+	$expr =~ s/->/\$zinc->/g;
+	my $unused = $zinc; ## due to a perl bug, this is needed so that $zinc will be known in $expr
+	my $r = eval ($expr);
+	if ($@) {
+#	    &myWarn ("While evaluationg:\n$expr\nAn Error occured: $@\n");
+	    print ("While evaluationg:\n$expr\nAn Error occured: $@\n");
+	} elsif ($verbose) {
+	    if ($l =~ /^->add/) {
+		print "$r == $expr\n" if $verbose;
+	    } else {
+		print "$expr\n" if $verbose;
+	    }
+	}
+    }
+}
+
+
+sub fileHeader {
+#    my ($self) = @_;
+}
+
+
+sub fileTail {
+    my ($self) = @_;
+    my $outfile = $self->{-out};
+
+    # to find the top group containing width and height
+    my $svgGroup = $zinc->find('withtag', 'svg_top') ; 
+
+    my $tags = join " ", $zinc->gettags($svgGroup);
+#    print "svgGroup=$svgGroup  => $tags\n";
+    my ($width) = $tags =~ /width=(\d+)/ ;
+    my ($height) = $tags =~ /height=(\d+)/ ;
+#    print "height => $height width => $width\n";
+    
+    $zinc->configure (-width => $width, -height => $height);
+    $zinc->update;
+
+    my $requiredWidth = $self->{-width};
+    my $requiredHeigth = $self->{-height};
+    my $importParams="";
+    if (defined $requiredWidth and defined $requiredHeigth) {
+	$importParams=" -resize $requiredWidth"."x$requiredHeigth";
+    } elsif (defined $self->{-ratio}) {
+	$importParams=" -resize ".$self->{-ratio};
+    }
+#    print "importParams=$importParams\n";
+
+    ## following are for comments:
+    my ($svg2zincPackage) = caller;
+    my $VERSION = eval ( "\$".$svg2zincPackage."::VERSION" );
+    my $svgfile = $self->{-in};
+
+    my $command = "import -window " . $zinc->id . $importParams ." -comment 'created with SVG::SVG2zinc from $svgfile v$VERSION (c) CENA 2003 C.Mertz.' $outfile";
+#    print "command=$command\n";
+    my $return = system ($command);
+
+    if ($return) {
+	## -1 when import is not available
+	print "## To use the Image Backend you need the 'import' command\n";
+	print "## from the 'imagemagick' package on your system\n";
+    }
+}
+
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+SVG:SVG2zinc::Backend::Image - a backend class for generating image file from SVG file
+
+=head1 DESCRIPTION
+
+SVG:SVG2zinc::Backend::Image is a backend class for generating image file from SVG files. It uses the 'import' command included in the ImageMagick package.
+
+For more information, you should look at SVG:SVG2zinc::Backend(3pm).
+
+The new method accepts parameters described in the SVG:SVG2zinc::Backend class and the following additionnal parameters:
+
+=over
+
+=item B<none>
+
+=back
+
+=head1 SEE ALSO
+
+SVG::SVG2zinc::Backend(3pm) and SVG::SVG2zinc(3pm)
+
+=head1 BUGS and LIMITATIONS
+
+This backend generates images files from the content of a displayed Tk::Zinc window. The size (in pixels) of the generated image is thus limited to the maximal size of a window on your system. 
+
+=head1 AUTHORS
+
+Christophe Mertz <mertz at intuilab dot com>
+
+=head1 COPYRIGHT
+    
+CENA (C) 2003-2004 IntuiLab 2004
+
+This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence.
+
+=cut
+
diff --git a/src/SVG/SVG2zinc/Backend/PerlClass.pm b/src/SVG/SVG2zinc/Backend/PerlClass.pm
new file mode 100644
index 0000000..9b47ee7
--- /dev/null
+++ b/src/SVG/SVG2zinc/Backend/PerlClass.pm
@@ -0,0 +1,203 @@
+package SVG::SVG2zinc::Backend::PerlClass;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+#	Backend Class for SVG2zinc
+# 
+#	Copyright 2003-2004
+#	Centre d'?tudes de la Navigation A?rienne
+#
+#	Author: Christophe Mertz <mertz at intuilab dot com>
+#
+#       An concrete class for code generation for Perl Class
+#
+# $Id: PerlClass.pm,v 1.4 2007-03-12 10:25:18 merlin Exp $
+#############################################################################
+
+use SVG::SVG2zinc::Backend;
+use File::Basename;
+
+use Tk::Zinc;
+
+@ISA = qw( SVG::SVG2zinc::Backend );
+
+use vars qw( $VERSION);
+($VERSION) = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
+
+use strict;
+use Carp;
+
+our $current_package_name = '';
+
+sub _initialize {
+    my ($self, %passed_options) = @_;
+    $self->{-topgroup} = '$self->{-topgroup}'; # this code is used by SVG2zinc
+    $self->SUPER::_initialize(%passed_options);
+    $self -> {delayed_lines} = ();
+    $self -> {gradient} = {};
+    $self -> {gradient_id} = 0;
+    return $self;
+}
+
+sub recordGradient {
+	my ($self, $name, $def) = @_;
+	$self -> {gradient} -> {$name} = $def;
+}
+
+sub getGradient {
+	my ($self, $name) = @_;
+	return $self -> {gradient} -> {$name} -> {stops};
+}
+
+sub applyGradient {
+	my ($self, $name, $prop) = @_;
+	my $grad = $self -> {gradient} -> {$name};
+	my $id = $self -> {gradient_id} ++;
+	my %hash = %{$grad};
+	my @lignes = 'my ($x1, $y1, $x2, $y2) = $_zinc -> bbox ($previous);';
+#	push (@lignes, 'my ($parent) = $_zinc -> find(\'ancestors\', $previous);');
+	push (@lignes, '($x1, $y1, $x2, $y2) = $_zinc -> transform(\'device\', $parent, [$x1+1, $y1+1, $x2-2, $y2-2]);');
+	push (@lignes, "my \$grad = getGradient (");
+	push (@lignes, "\t'$current_package_name',");
+	push (@lignes, "\t'$id',");
+	push (@lignes, "\t'".$hash {type}."',");
+	push (@lignes, "\t'".$hash {gradientUnits}."',");
+	push (@lignes, "\t".join (',' , @{$hash{coords}}).",");
+	push (@lignes, "\t'".join ('|' , @{$hash{stops}})."',");
+	push (@lignes, "\t".join (',' , @{$hash{transform}}).",");
+	push (@lignes, "\t\$x1, \$y1, \$x2, \$y2");
+	push (@lignes, ");");
+	push (@lignes, "mconfigure (\$previous, $prop => \$grad);");
+	
+	$self -> {current_gradient} = \@lignes;
+}
+
+sub treatLines {
+    my ($self,@lines) = @_;
+    foreach my $l (@lines) 
+    {
+		$l =~ s/^(\s*)->/$1\$_zinc->/g;
+		$l =~ s/(\W)->/$1\$_zinc->/g;
+		$self -> printLines($l);
+    }
+}
+
+sub dtreatLines {
+    my ($self, @lines) = @_;
+    foreach my $l (@lines) 
+    {
+		$l =~ s/^(\s*)->add/$1\$previous = \$_zinc-> add/g;
+		$l =~ s/(\W)->add/$1\$previous = \$_zinc-> add/g;
+		
+		$l =~ s/^(\s*)->/$1\$_zinc-> /g;
+		$l =~ s/(\W)->/$1\$_zinc-> /g;
+		
+    }
+    if (defined @lines)
+    {
+		my $rule = shift (@lines);
+		push (@{$self -> {delayed_lines}}, $rule);
+    }
+    if (defined $self -> {current_gradient})
+    {
+	    my @grad = @{$self -> {current_gradient}};
+	    foreach my $l (@grad) 
+    	{
+	    	push (@{$self -> {delayed_lines}}, $l);
+    	}
+    	$self -> {current_gradient} = undef;
+    }
+    foreach my $l (@lines) 
+    {
+    	push (@{$self -> {delayed_lines}}, $l);
+    }
+}
+
+sub fileHeader {
+    my ($self) = @_;
+    my $file = $self -> {-in}; # print "file=$file\n";
+    my ($svg2zincPackage) = caller;
+    my $VERSION = eval ( "\$".$svg2zincPackage."::VERSION" );
+    my ($package_name) = $self -> {-out} =~ /(.*)\.pm$/ ;
+	$current_package_name = $package_name;
+	$self -> printLines("package $package_name;
+
+####### This file has been generated from $file by SVG::SVG2zinc.pm Version: $VERSION
+
+");
+    $self->printLines(
+<<'HEADER'
+
+use strict;
+use MTools;
+use MTools::MGroup;
+use vars qw /@ISA @EXPORT @EXPORT_OK/;
+use Tk::PNG;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MGroup/;
+}
+	      
+
+sub new {
+    my ($class, %passed_options) = @_;
+    my $self = {};
+    bless $self, $class;
+
+    my $_zinc = $passed_options {-zinc};
+    croak ("-zinc option is mandatory at instanciation") unless defined $_zinc;
+
+    if (defined $passed_options {-topgroup}) 
+    {
+		$self -> {-topgroup} = $passed_options {-topgroup};
+    }
+    else 
+    {
+		$self -> {-topgroup} = 1;
+    }
+    
+    my $parent = $self -> {-topgroup};
+    my @parents = ();
+    my $previous = ();
+    push (@parents, $parent);
+
+# on now items creation!
+HEADER
+);
+}
+
+
+sub fileTail {
+    my ($self) = @_;
+    $self->comment ("", "Tail of SVG2zinc::Backend::PerlScript", "");
+    unshift (@{$self -> {delayed_lines}}, '$self -> {instance} = $previous = ');
+    $self -> printLines(@{$self -> {delayed_lines}});
+    $self -> printLines(
+<<'TAIL'
+return $self;
+}
+
+1;
+TAIL
+);
+    $self->close;
+}
+
+
+1;
+
diff --git a/src/SVG/SVG2zinc/Backend/PerlScript.pm.k b/src/SVG/SVG2zinc/Backend/PerlScript.pm.k
new file mode 100644
index 0000000..b3b453c
--- /dev/null
+++ b/src/SVG/SVG2zinc/Backend/PerlScript.pm.k
@@ -0,0 +1,275 @@
+package SVG::SVG2zinc::Backend::PerlScript;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+#	Backend Class for SVG2zinc
+# 
+#	Copyright 2003-2004
+#	Centre d'Études de la Navigation Aérienne
+#
+#	Author: Christophe Mertz <mertz at intuilab dot com>
+#
+#       A concrete class for code generation for Perl Scripts
+#
+# $Id: PerlScript.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $
+#############################################################################
+
+use strict;
+use Carp;
+
+use SVG::SVG2zinc::Backend;
+use File::Basename;
+
+use vars qw( $VERSION @ISA  );
+@ISA = qw( SVG::SVG2zinc::Backend );
+($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/);
+
+
+sub treatLines {
+    my ($self,@lines) = @_;
+    foreach my $l (@lines) {
+	$l =~ s/->/\$_zinc->/g;
+	$self->printLines($l);
+    }
+}
+
+sub fileHeader {
+    my ($self) = @_;
+    my $svgfile = $self->{-in};
+    my ($svg2zincPackage) = caller;
+    my $VERSION = eval ( "\$".$svg2zincPackage."::VERSION" );
+    $self->printLines("#!/usr/bin/perl -w
+
+####### This file has been generated from $svgfile by SVG::SVG2zinc.pm Version: $VERSION
+");
+
+
+    $self->printLines(
+<<'HEADER'
+use Tk::Zinc 3.295;
+use Tk::Zinc::Debug;
+use Tk::PNG;  # only usefull if loading png file
+use Tk::JPEG; # only usefull if loading png file
+
+use Tk::Zinc::SVGExtension;
+
+my $mw = MainWindow->new();
+HEADER
+		      );
+    my $svgfilename = basename($svgfile);
+    $self->printLines("
+\$mw->title('$svgfile');
+my (\$WIDTH, \$HEIGHT) = (800, 600);
+" );
+    my $render = $self->{-render};
+    $self->printLines("
+my \$zinc = \$mw->Zinc(-width => \$WIDTH, -height => \$HEIGHT,
+		     -borderwidth => 0,
+                     -backcolor => 'white', # why white?
+		     -render => $render,
+		      )->pack(qw/-expand yes -fill both/);;
+");
+
+    $self->printLines(
+<<'HEADER'
+if (Tk::Zinc::Debug->can('init')) {
+    # for TkZinc >= 3.2.96
+    &Tk::Zinc::Debug::init($zinc, -optionsToDisplay => "-tags", -optionsFormat => "row");
+} else {
+    # for TkZinc <= 3.2.95
+    &Tk::Zinc::Debug::finditems($zinc);
+    &Tk::Zinc::Debug::tree($zinc, -optionsToDisplay => "-tags", -optionsFormat => "row");
+}
+
+my $top_group = 1; ###$zinc->add('group', 1);
+
+my $_zinc=$zinc;
+
+{ ###
+
+HEADER
+    );
+}
+
+
+sub fileTail {
+    my ($self) = @_;
+    $self->printLines(
+<<'TAIL'
+	   }
+
+### on va retailler et translater les objets créés!
+
+my @bbox = $_zinc->bbox($top_group);
+$_zinc->translate($top_group, -$bbox[0], -$bbox[1]);
+@bbox = $_zinc->bbox($top_group);
+my $ratio = 1;
+$ratio = $WIDTH / $bbox[2] if ($bbox[2] > $WIDTH);
+$ratio = $HEIGHT/$bbox[3] if ($HEIGHT/$bbox[3] lt $ratio);
+$zinc->scale($top_group, $ratio, $ratio);
+
+### on ajoute quelques binding bien pratiques pour la mise au point
+
+$_zinc->Tk::bind('<ButtonPress-1>', [\&press, \&motion]);
+$_zinc->Tk::bind('<ButtonRelease-1>', [\&release]);
+$_zinc->Tk::bind('<ButtonPress-2>', [\&press, \&zoom]);
+$_zinc->Tk::bind('<ButtonRelease-2>', [\&release]);
+
+# $_zinc->Tk::bind('<ButtonPress-3>', [\&press, \&mouseRotate]);
+# $_zinc->Tk::bind('<ButtonRelease-3>', [\&release]);
+$_zinc->bind('all', '<Enter>',
+	[ sub { my ($z)=@_; my $i=$z->find('withtag', 'current');
+			my @tags = $z->gettags($i);
+			pop @tags; # pour enlever 'current'
+			print "$i (", $z->type($i), ") [@tags]\n";}] );
+
+&Tk::MainLoop;
+
+
+##### bindings for moving, rotating, scaling the items
+my ($cur_x, $cur_y, $cur_angle);
+sub press {
+    my ($zinc, $action) = @_;
+    my $ev = $zinc->XEvent();
+    $cur_x = $ev->x;
+    $cur_y = $ev->y;
+    $cur_angle = atan2($cur_y, $cur_x);
+    $zinc->Tk::bind('<Motion>', [$action]);
+}
+
+sub motion {
+    my ($zinc) = @_;
+    my $ev = $zinc->XEvent();
+    my $lx = $ev->x;
+    my $ly = $ev->y;
+    my @res = $zinc->transform($top_group, [$lx, $ly, $cur_x, $cur_y]);
+    $zinc->translate($top_group, $res[0] - $res[2], $res[1] - $res[3]);
+    $cur_x = $lx;
+    $cur_y = $ly;
+}
+
+sub zoom {
+    my ($zinc, $self) = @_;
+    my $ev = $zinc->XEvent();
+    my $lx = $ev->x;
+    my $ly = $ev->y;
+    my $maxx;
+    my $maxy;
+    my $sx;
+    my $sy;
+    
+    if ($lx > $cur_x) {
+	$maxx = $lx;
+    } else {
+	$maxx = $cur_x;
+    }
+    if ($ly > $cur_y) {
+	$maxy = $ly
+    } else {
+	$maxy = $cur_y;
+    }
+    return if ($maxx == 0 || $maxy == 0);
+    $sx = 1.0 + ($lx - $cur_x)/$maxx;
+    $sy = 1.0 + ($ly - $cur_y)/$maxy;
+    $cur_x = $lx;
+    $cur_y = $ly;
+    $zinc->scale($top_group, $sx, $sx); #$sy);
+}
+
+sub mouseRotate {
+    my ($zinc) = @_;
+    my $ev = $zinc->XEvent();
+    my $lx = $ev->x;
+    my $ly = $ev->y;
+    my $langle = atan2($ly, $lx);
+    $zinc->rotate($top_group, -($langle - $cur_angle));
+    $cur_angle = $langle;
+}
+
+sub release {
+    my ($zinc) = @_;
+    $zinc->Tk::bind('<Motion>', '');
+}
+TAIL
+);
+    $self->close;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+SVG:SVG2zinc::Backend::PerlScript - a backend class generating Perl script displaying the content of a SVG file
+
+=head1 SYNOPSIS
+
+ use SVG:SVG2zinc::Backend::PerlScript;
+
+ $backend = SVG:SVG2zinc::Backend::PerlScript->new(
+	       -out => filename_or_handle,
+               -in => svgfilename,
+	       -verbose => 0|1,
+	       -render => 0|1|2,
+	       );
+
+ $backend->fileHeader();
+
+ $backend->treatLines("lineOfCode1", "lineOfCode2",...);
+
+ $backend->comment("comment1", "comment2", ...);
+
+ $backend->printLines("comment1", "comment2", ...);
+
+ $backend->fileTail();
+
+=head1 DESCRIPTION
+
+SVG:SVG2zinc::Backend::PerlScript is a class for generating perl script which displays the content of a SVG file. The generated script requires Tk::Zinc.
+
+For more information, you should look at SVG::SVG2zinc::Backend(3pm).
+
+The generated perl script uses the Tk::Zinc::Debug tool, so it is easy to inspect items created in Tk::Zinc. Use the <ESC> key to get some help when the cursor is in the Tk::Zinc window. 
+
+The B<new> method accepts parameters described in the SVG:SVG2zinc::Backend class and the following additionnal parameter:
+
+=over
+
+=item B<-render>
+
+The render option of the Tk::Zinc widget. A value of 0 means no openGL, 1 or 2 for openGL. Defaults to 1.
+
+=back
+
+=head1 SEE ALSO
+
+SVG::SVG2zinc::Backend(3pm) and SVG::SVG2zinc(3pm)
+
+=head1 AUTHORS
+
+Christophe Mertz <mertz at intuilab dot com>
+
+=head1 COPYRIGHT
+    
+CENA (C) 2003-2004 IntuiLab (C) 2004
+
+This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence.
+
+=cut
+
diff --git a/src/SVG/SVG2zinc/Backend/Print.pm.k b/src/SVG/SVG2zinc/Backend/Print.pm.k
new file mode 100644
index 0000000..8e533ac
--- /dev/null
+++ b/src/SVG/SVG2zinc/Backend/Print.pm.k
@@ -0,0 +1,61 @@
+package SVG::SVG2zinc::Backend::Print;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+#	Backend Class for SVG2zinc
+# 
+#	Copyright 2003
+#	Centre d'Études de la Navigation Aérienne
+#
+#	Author: Christophe Mertz <mertz at intuilab dot com>
+#
+#       An concrete class for code printing for Perl Scripts/Modules
+#       This Backend is for svg2zinc debug purpose mainly
+#
+# $Id: Print.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $
+#############################################################################
+
+use SVG::SVG2zinc::Backend;
+
+@ISA = qw( SVG::SVG2zinc::Backend );
+
+use vars qw( $VERSION);
+($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/);
+
+use strict;
+use Carp;
+
+sub treatLines {
+    my ($self,@lines) = @_;
+    foreach my $l (@lines) {
+	print "$l\n";
+    }
+}
+
+
+sub fileHeader {
+#    my ($self) = @_;
+}
+
+
+sub fileTail {
+#    my ($self) = @_;
+}
+
+
+1;
+
diff --git a/src/SVG/SVG2zinc/Backend/Tcl.pm.k b/src/SVG/SVG2zinc/Backend/Tcl.pm.k
new file mode 100644
index 0000000..3149ef6
--- /dev/null
+++ b/src/SVG/SVG2zinc/Backend/Tcl.pm.k
@@ -0,0 +1,96 @@
+package SVG::SVG2zinc::Backend::Tcl;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+#	Backend Class for SVG2zinc
+# 
+#	Copyright 2003-2004
+#	Centre d'Études de la Navigation Aérienne
+#
+#	Author: Christophe Mertz <mertz at intuilab dot com>
+#
+#       A module for code translation from perl to tcl generation
+#
+# $Id: Tcl.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $
+#############################################################################
+
+
+use vars qw( $VERSION);
+($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/);
+
+@ISA = qw( Exporter );
+@EXPORT = qw( perl2tcl );
+
+use strict;
+use Carp;
+
+
+sub perl2tcl {
+    my (@lines) = @_;
+    my @res;
+    foreach my $l (@lines) {
+
+	$l =~ s/->(\w*)\((.*)\)/\$w\.zinc $1 $2/g;  # ->add(....) => $w.zinc add ...
+
+	$l =~ s/\s*,\s*/ /g;  # replacing commas by spaces
+	$l =~ s/\s*=>\s*/ /g;  # replacing => by spaces
+
+ 	$l =~ s/\s*\'([^\s;]+)\'\s*/ $1 /g ;  # removing single-quotes around string without spaces
+	$l =~ s/\s*\"([^\s;]+)\"\s*/ $1 /g ;  # removing double-quotes around string without spaces
+	$l =~ s/([\"\s])\#/$1\\\#/g ;  # prefixing # by a slash
+
+	$l =~ s/\[/\{/g;  # replacing [ by }
+	$l =~ s/\]/\}/g;  # replacing ] by }
+	$l =~ s/\{\s+/\{/g;  # removing spaces after {
+	$l =~ s/\s+\}/\}/g;  # removing spaces before }
+
+	$l =~ s/-tags \{(\S+)\}/-tags $1/g;  # -tags {toto}  ==>> -tags toto
+	$l =~ s/\'/\"/g;  # replacing all single quotes by double quotes
+
+	$l = &hack($l);
+    
+	$l =~ s/\s+/ /g;  # dangerous: removing multiple occurences of blanks
+
+	$l =~ s/^\s+//;   # removing blanks at the beginning
+	$l =~ s/\s+$//;   # removing trailing blanks
+	$l =~ s/\s*;$//;  # removing trailing ;
+	push @res, $l;
+    }
+    return (@res);
+}
+
+
+# this routine is used to do some special code transformation,
+# due to soem discrepancies between tcl/tk and perl/tk
+# the following code is more or less dependant from the generated
+# code by SVG2zinc.pm
+#
+# We assume is code has already been tcl-ised
+sub hack {
+    my ($l) = @_;
+
+    if ($l =~ /^\$w\.zinc fontCreate/) {
+	# this works because I know how fontCreate is used in SVG2zinc
+	$l =~ s/\$w\.zinc fontCreate/font create/;
+	$l =~ s/-weight medium/-weight normal/;
+    }
+
+    return $l;
+}
+
+1;
+
diff --git a/src/SVG/SVG2zinc/Backend/TclScript.pm.k b/src/SVG/SVG2zinc/Backend/TclScript.pm.k
new file mode 100644
index 0000000..90ecf4b
--- /dev/null
+++ b/src/SVG/SVG2zinc/Backend/TclScript.pm.k
@@ -0,0 +1,275 @@
+package SVG::SVG2zinc::Backend::TclScript;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+#	Backend Class for SVG2zinc
+# 
+#	Copyright 2003
+#	Centre d'Études de la Navigation Aérienne
+#
+#	Author: Christophe Mertz <mertz at intuilab dot com>
+#
+#       A concrete class for code generation for Tcl Scripts
+#
+# $Id: TclScript.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $
+#############################################################################
+
+use strict;
+use Carp;
+
+use SVG::SVG2zinc::Backend;
+use SVG::SVG2zinc::Backend::Tcl;
+use File::Basename;
+
+use vars qw( $VERSION @ISA  );
+@ISA = qw( SVG::SVG2zinc::Backend );
+($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/);
+
+sub new {
+    my ($class, %passed_options) = @_;
+    my $self = {};
+    bless $self, $class;
+    $self->{-render} = defined $passed_options{-render} ? delete $passed_options{-render} : 1;
+    $self->_initialize(%passed_options);
+    return $self;
+}
+
+
+sub treatLines {
+    my ($self,@lines) = @_;
+    foreach my $l (@lines) {
+	$self->printLines( &perl2tcl($l) );
+    }
+}
+
+sub fileHeader {
+    my ($self) = @_;
+    my $svgfile = $self->{-in};
+    my $svgfilename = basename($svgfile);
+    $svgfilename =~ s/\./_/g;
+    my ($svg2zincPackage) = caller;
+    my $VERSION = eval ( "\$".$svg2zincPackage."::VERSION" );
+    $self->printLines('#!/bin/sh
+# the next line restarts using wish \
+    exec wish "$0" "$@"
+');
+
+    $self->printLines("
+
+####### This Tcl script file has been generated
+####### from $svgfile
+####### by SVG::SVG2zinc.pm Version: $VERSION
+
+");
+
+    $self->printLines('
+#
+# Locate the zinc top level directory.
+#
+set zincRoot [file join [file dirname [info script]] ..]
+
+#
+# And adjust the paths accordingly.
+#
+lappend auto_path $zincRoot
+set zinc_library $zincRoot
+
+package require Tkzinc 3.2
+
+## here we should import img for reading jpeg, png, gif files
+
+');
+
+    my $render = $self->{-render};
+    $self->printLines(
+<<HEADER
+set w .$svgfilename
+## catch {destroy \$w}
+toplevel \$w
+wm title \$w $svgfilename
+wm iconname \$w $svgfilename
+
+###########################################
+# Zinc
+##########################################
+zinc \$w.zinc -width 600 -height 600 -font 9x15 -borderwidth 0 -backcolor grey90 -render $render
+
+pack \$w.zinc
+
+set topGroup [\$w.zinc add group 1]
+
+
+HEADER
+    );
+}
+
+
+sub fileTail {
+    my ($self) = @_;
+    $self->printLines(
+<<'TAIL'
+### translating ojects for making them all visibles
+
+#set bbox [$w.zinc bbox $topGroup]
+
+$w.zinc translate $topGroup 200 150
+
+
+##### bindings for moving rotating scaling the items
+
+bind $w.zinc <ButtonPress-1>  "press motion %x %y"
+bind $w.zinc <ButtonRelease-1>  release
+bind $w.zinc <ButtonPress-2>  "press zoom %x %y"
+bind $w.zinc <ButtonRelease-2>  release
+bind $w.zinc <ButtonPress-3>  "press mouseRotate %x %y"
+bind $w.zinc <ButtonRelease-3>  release
+
+
+set curX 0
+set curY 0
+set curAngle 0
+
+proc press {action x y} {
+    global w curAngle curX curY
+
+    set curX $x
+    set curY $y
+    set curAngle [expr atan2($y, $x)]
+    bind $w.zinc <Motion> "$action %x %y"
+}
+
+proc motion {x y} {
+    global w topGroup curX curY
+
+    foreach {x1 y1 x2 y2} [$w.zinc transform $topGroup \
+			       [list $x $y $curX $curY]] break
+    $w.zinc translate $topGroup [expr $x1 - $x2] [expr $y1 - $y2]
+    set curX $x
+    set curY $y
+}
+
+proc zoom {x y} {
+    global w curX curY
+
+    if {$x > $curX} {
+	set maxX $x
+    } else {
+	set maxX $curX
+    }
+    if {$y > $curY} {
+	set maxY $y
+    } else {
+	set maxY $curY
+    }
+    if {($maxX == 0) || ($maxY == 0)} {
+	return;
+    }
+    set sx [expr 1.0 + (double($x - $curX) / $maxX)]
+    set sy [expr 1.0 + (double($y - $curY) / $maxY)]
+    $w.zinc scale __svg__1 $sx $sx
+    set curX $x
+    set curY $y
+}
+
+proc mouseRotate {x y} {
+    global w curAngle
+
+    set lAngle [expr atan2($y, $x)]
+    $w.zinc rotate __svg__1 [expr $lAngle - $curAngle]
+    set curAngle  $lAngle
+}
+
+proc release {} {
+    global w
+
+    bind $w.zinc <Motion> {}
+}
+TAIL
+);
+
+    $self->close;
+}
+
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+SVG:SVG2zinc::Backend::TclScript - a backend class for generating Tcl script
+
+=head1 SYNOPSIS
+
+ use SVG:SVG2zinc::Backend::TclScript;
+
+ $backend = SVG:SVG2zinc::Backend::TclScript->new(
+	       -out => filename_or_handle,
+               -in => svgfilename,
+	       -verbose => 0|1,
+	       -render => 0|1|2,
+	       );
+
+ $backend->fileHeader();
+
+ $backend->treatLines("lineOfCode1", "lineOfCode2",...);
+
+ $backend->comment("comment1", "comment2", ...);
+
+ $backend->printLines("comment1", "comment2", ...);
+
+ $backend->fileTail();
+
+=head1 DESCRIPTION
+
+SVG:SVG2zinc::Backend::TclScript is a class for generating Tcl script to display SVG files. The generated script is based on TkZinc.
+
+For more information, you should look at SVG:SVG2zinc::Backend(3pm).
+
+The new method accepts parameters described in the SVG:SVG2zinc::Backend class and the following additionnal parameters:
+
+=over
+
+=item B<-render>
+
+The render value of the TkZinc widget. 0 means no openGL, 1 or 2 for openGL. Defaults to 1.
+
+=back
+
+=head1 SEE ALSO
+
+SVG::SVG2zinc::Backend and SVG::SVG2zinc(3pm)
+
+=head1 BUGS and LIMITATIONS
+
+This is higly experimental. Only few tests... The author is not a Tcl coder!
+
+The Tk::Zinc::SVGExtension perl module provided with SVG::SVG2zinc should be converted in Tcl and imported by (or included in) the generated Tcl script.
+
+=head1 AUTHORS
+
+Christophe Mertz <mertz at intuilab dot com>
+
+=head1 COPYRIGHT
+    
+CENA (C) 2003-2004
+
+This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence.
+
+=cut
+
diff --git a/src/SVG/SVG2zinc/Conversions.pm b/src/SVG/SVG2zinc/Conversions.pm
new file mode 100644
index 0000000..9a8ccb9
--- /dev/null
+++ b/src/SVG/SVG2zinc/Conversions.pm
@@ -0,0 +1,909 @@
+package SVG::SVG2zinc::Conversions;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+use Math::Trig;
+use Math::Bezier::Convert;
+use strict;
+use Carp;
+
+use vars qw( $VERSION @ISA @EXPORT );
+
+($VERSION) = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/);
+
+@ISA = qw( Exporter );
+
+@EXPORT = qw( InitConv
+	      removeComment convertOpacity
+	      createNamedFont
+	      defineNamedGradient namedGradient namedGradientDef existsGradient
+	      extractGradientTypeAndStops addTransparencyToGradient 
+	      colorConvert
+	      pathPoints points
+	      cleanName
+	      float2int sizesConvert sizeConvert
+	      transform
+	      );
+
+# some variables to be initialized at the beginning
+
+my ($warnProc, $lineNumProc); # two proc
+my %fonts; # a hashtable to identify all used fonts 
+my %gradients;
+
+sub InitConv {
+    ($warnProc, $lineNumProc) = @_;
+    %fonts = ();
+    %gradients = ();
+    return 1;
+}
+
+sub myWarn{
+    &{$warnProc}(@_);
+}
+
+### remove SVG comments in the form  /* */  in $str
+### returns the string without these comments
+sub removeComment {
+    my ($str) = @_;
+#    my $strOrig = $str;
+    return "" unless defined $str;
+
+    while ($str =~ s|(.*)(/\*.*\*/){1}?|$1|) {
+#	print "begin='$str'\n";
+    }
+#    print "'$strOrig' => '$str'\n";
+    $str =~ s/^\s*// ;
+    return $str;
+}
+
+## returns an opacity value between 0 and 1
+## returns 1 if the argument is undefined
+sub convertOpacity {
+    my ($opacity) = @_;
+    $opacity = 1 unless defined $opacity;
+    $opacity = 0 if $opacity<0;
+    $opacity = 1 if $opacity>1;
+    return $opacity;
+}
+
+
+######################################################################################
+#   fontes management
+######################################################################################
+
+# the following hashtable is used to maps SVG font names to X font names
+# BUG: obvioulsy this hashtable should be defined in the system or at
+# least as a configuration file or in the SVG2zinc parser parameters
+
+my %fontsMapping = (
+	'comicsansms' => "comic sans ms",
+	'arialmt' => "arial",
+	'arial black' => "arial-bold",
+	'bleriottextmono-roman' => 'bleriot-radar',
+	'bleriottext-roman' => 'bleriot',
+	'cityd' => 'city d',
+	'cityd-medi' => 'city d',
+);
+
+my $last_key = "verdana";
+
+sub createNamedFont {
+    my ($fullFamily, $size, $weight) = @_;
+    if ($fullFamily eq "")
+    {
+    	$fullFamily = $last_key if $fullFamily eq "";
+    }
+    else
+    {
+    	$last_key = $fullFamily;
+    }
+    my $family = lc($fullFamily);
+
+    $weight = "normal" unless $weight;
+    if ( $size =~ /(.*)pt/ ) 
+    {
+		$size = -$1;
+    } 
+    elsif ( $size =~ /(.*)px/ ) 
+    {
+		$size = -$1;
+    }
+    elsif ( $size =~ /(\d*(.\d*)?)\s*$/ ) 
+    {
+		$size = -$1;
+    }
+#     $size = &float2int($size); # I round the font size, at least until we have vectorial font in Tk::Zinc
+
+	$family = $fontsMapping{$family} if defined $fontsMapping{$family};    
+    if ( $family =~ /(\w*)-bold/ ) 
+    {
+		$family = $1;
+		$weight = "bold";
+    }
+    else
+    {
+		$weight = "medium";
+    }
+
+    my $fontKey = join "_", ($family, $size, $weight);
+    if (!defined $fonts{$fontKey}) 
+    {
+		$fonts{$fontKey} = $fontKey;
+		return ($fontKey, "->fontCreate('$fontKey', -family => \"$family\", -size => $size, -weight => \"$weight\") if ! \$fonts {\"$fontKey\"};");
+    } 
+    else 
+    {
+		return ($fontKey,"");
+    }
+    
+} # end of createNamedFont
+
+######################################################################################
+#   gradients management
+######################################################################################
+# my %gradients;
+
+## Check if the new gradient does not already exists (with another name)
+## In this case, the hash is extended with an "auto-reference"
+##   $gradients{newName} = "oldName"
+## and the function returns 0
+## Otherwise, add an entry in the hastable
+##   $gradients{newName} = "newDefinition"
+## and returns 1
+sub defineNamedGradient {
+    my ($newGname, $newGradDef) = @_;
+    my $prevEqGrad;
+    $newGradDef =~ s/^\s*(.*\S)\s*$/$1/ ; # removing trailing/leading blank
+    $newGradDef =~ s/\s*\|\s*/ \| /g ;    # inserting blanks around the |
+    $newGradDef =~ s/\s\s+/ /g;  # removing multiple occurence of blanks
+#    print "CLEANED grad='$newGradDef'\n";
+    foreach my $gname (keys %gradients) {
+	if ($gradients{$gname} eq $newGradDef) {
+	    ## such a gradient already exist with another name
+	    $gradients{$newGname} = $gname;
+#	    print "GRADIENT: $newGname == $gname\n";
+
+#	    $res .= "\n###### $newGname => $gname"; ### 
+
+	    return 0;
+	}
+    }
+    ## there is no identical gradient with another name
+    ## we add the definition in the hashtable
+    $gradients{$newGname} = $newGradDef;
+    return $newGradDef;
+}
+
+## returns the name of a gradient, by following if necessary
+## "auto-references" in the hashtable
+sub namedGradient {
+    my ($gname) = @_;
+    my $def = $gradients{$gname};
+    return $gname unless defined $def; 
+    ## to avoid looping if the hashtable is buggy:
+    return $gname if !defined $gradients{$def} or $def eq $gradients{$def}; 
+    return &namedGradient($gradients{$gname});
+}
+
+## returns the definition associated to a named gradient, following if necessary
+## "auto-references" in the hashtable
+sub namedGradientDef {
+    my ($gname) = @_;
+    my $def = $gradients{$gname};
+    return "" unless defined $def; 
+    ## to avoid looping if the hashtable is buggy:
+    return $def if !defined $gradients{$def} or $def eq $gradients{$def}; 
+    return $gradients{&namedGradient($gradients{$gname})};
+}
+
+# returns 1 if the named has an associated gradient
+sub existsGradient {
+    my ($gname) = @_;
+    if (defined $gradients{$gname}) {return 1} else {return 0}; 
+}
+
+## this function returns both the radial type with its parameters AND
+## a list of stops characteristics as defined in TkZinc
+## usage: ($radialType, @stops) = &extractGradientTypeAndStops(<namedGradient>);
+## this func assumes that <namedGradient> DOES exist
+sub extractGradientTypeAndStops {
+    my ($namedGradient) = @_;
+    my $gradDef = &namedGradientDef($namedGradient);
+    my @defElements = split (/\s*\|\s*/ , $gradDef);
+    my $gradientType;
+    $gradientType = shift @defElements;
+    return ($gradientType, @defElements); 
+}
+
+## combines the opacity to every parts of a named gradient
+## if some parts of the gradients are themselves partly transparent, they are combined
+## if $opacity is 1, returns directly $gname
+## else returns a new definition of a gradient
+sub addTransparencyToGradient {
+    my ($gname,$opacity) = @_;
+    return $gname if $opacity == 100;
+    &myWarn ("ATTG: ERROR $gname\n"), return $gname if !&namedGradientDef($gname); ## this cas is certainly an error in the SVG source file!
+    my ($gradientType, @stops) = &extractGradientTypeAndStops($gname);
+
+    my @newStops;
+    foreach my $stop (@stops) {
+	my $newStop="";
+	if ($stop =~ /^([^\s;]+)\s*;\s*(\d+)\s*(\d*)\s*$/   #   red;45 50   or red;45
+	    ) {
+	    my ($color,$trans,$pos) = ($1,$2,$3);
+#	    print "$stop => '$color','$trans','$pos'\n";
+	    my $newtransp = &float2int($trans*$opacity/100);
+	    if ($pos) {
+		$newStop="$color;$newtransp $pos";
+	    } else {
+		$newStop="$color;$newtransp";
+	    }
+	} elsif ($stop =~ /^(\S+)\s+(\d+)$/) {             # red 50
+	    my ($color,$pos) = ($1,$2);
+#	    print "$stop => '$color','$pos'\n";
+	    my $newtransp = &float2int($opacity);
+	    $newStop="$color;$newtransp $pos";
+	} elsif ($stop =~ /^(\S+)$/) {
+	    my ($color) = ($1);
+#	        print "$stop => '$color'\n";
+	    my $newtransp = &float2int($opacity);
+	    $newStop="$color;$newtransp";
+	} else {
+	    &myWarn ("In addTransparencyToGradient: bad gradient Elements: '$stop'\n");
+	}
+	push @newStops, $newStop;
+    }
+    return ( $gradientType . " | " . join (" | ", @newStops));
+} # end of addTransparencyToGradient
+
+
+######################################################################################
+# color conversion
+######################################################################################
+# a hash table to define non-X SVG colors
+# THX to Lemort for bug report and correction!
+my %color2color = ('lime'    => 'green',
+		   'Lime'    => 'green',
+		   'crimson' => '#DC143C',
+		   'Crimson' => '#DC143C',
+		   'aqua'    => '#00ffff',
+		   'Aqua'    => '#00ffff',
+		   'fuschia' => '#ff00ff',
+		   'Fuschia' => '#ff00ff',
+		   'fuchsia' => '#ff00ff',
+		   'Fuchsia' => '#ff00ff',
+		   'indigo'  => '#4b0082',
+		   'Indigo'  => '#4b0082',
+		   'olive'   => '#808000',
+		   'Olive'   => '#808000',
+		   'silver'  => '#c0c0c0',
+		   'Silver'  => '#c0c0c0',
+		   'teal'    => '#008080',
+		   'Teal'    => '#008080',
+		   'green'   => '#008000',
+		   'Green'   => '#008000',
+		   'grey'    => '#808080',
+		   'Grey'    => '#808080',
+		   'gray'    => '#808080',
+		   'Gray'    => '#808080',
+		   'maroon'  => '#800000',
+		   'Maroon'  => '#800000',
+		   'purple'  => '#800080',
+		   'Purple'  => '#800080',
+		   );
+
+#### BUG: this is certainly only a partial implementation!!
+sub colorConvert {
+    my ($color) = @_;
+  
+    if ($color =~ /^\s*none/m) 
+    {
+		return ('none', 0);
+    } 
+    elsif ($color =~ /rgb\(\s*(.+)\s*\)/ ) 
+    {
+		## color like "rgb(...)"
+		my $rgbs = $1;
+		if ($rgbs =~ /([\d.]*)%\s*,\s*([\d.]*)%\s*,\s*([\d.]*)%/ ) 
+		{
+  	    	## color like "rgb(1.2% , 45%,67.%)"
+		    my ($r,$g,$b) = ($1,$2,$3);
+		    $color = sprintf ("#%02x%02x%02x",
+			      sprintf ("%.0f",2.55*$r),
+			      sprintf ("%.0f",2.55*$g),
+			      sprintf ("%.0f",2.55*$b));
+	    	return ($color, 0);
+		} 
+		elsif ($rgbs =~ /(\d*)\s*,\s*(\d*)\s*,\s*(\d*)/ ) 
+		{
+	    	## color like "rgb(255, 45,67)"
+	    	my ($r,$g,$b) = ($1,$2,$3);
+	    	$color = sprintf "#%02x%02x%02x", $r,$g,$b;
+	    	return ($color, 0);
+	    } 
+	    else 
+	    {
+	    	&myWarn ("Unknown rgb color coding: $color\n");
+		}
+    } 
+    elsif ($color =~ /^url\(\#(.+)\)/ ) 
+    {
+		## color like "url(#monGradient)"
+# 		$color = $1;
+#		my $res = &namedGradient($color);
+		return ($1, 1); #&namedGradient($1);
+    } 
+    elsif ( $color =~ /\#([0-9a-fA-F]{3}?)$/ ) 
+    {
+		## color like #fc1 => #ffcc11
+		$color =~ s/([0-9a-fA-F])/$1$1/g ;
+        # on doubling the digiys, because Tk does not do it properly
+		return ($color, 0);
+    } 
+    elsif ( $color =~ /\#([0-9a-fA-F]{6}?)$/ ) 
+    {
+	    return ($color, 0);
+    }
+    else 
+    {
+	## named colors!
+	## except those in the %color2color, all other should be defined in the
+	## standard rgb.txt file
+# 	my $converted = $color2color{lc($color)}; # THX to Lemort for bug report!
+# 	if (defined $converted) {
+# 	    return $converted;
+# 	} else {
+	    return ($color, 0);
+# 	}
+    }
+} # end of colorConvert
+
+######################################################################################
+# path points commands conversion
+######################################################################################
+
+
+# &pathPoints (\%attrs)
+# returns a boolean and a list of table references
+# - the boolean is true is the path has more than one contour or if it must be closed
+# - every table referecne pints to a table of strings, each string describing coordinates
+# possible BUG: in Tk::Zinc when a curve has more than one contour, they are all closed
+#  how is it in SVG?
+sub pathPoints {
+    my ($ref_attrs) = @_;
+    my $str = $ref_attrs->{d};
+#    print "#### In PathPoints : $str\n";
+    my ($x,$y) = (0,0); # current values
+    my $closed = 1;
+    my $atLeastOneZ=0; # true if at least one z/Z command. The curve must then be closed
+    my @fullRes;
+    my @res ;
+    my ($firstX, $firstY); # for memorizing the first point for a 'm' command after a 'z'!
+    my ($prevContrlx,$prevContrly); # useful for the s/S commande
+
+    # I use now a repetitive search on the same string, without allocating
+    # a $last string for the string end; with very long list of points, such
+    # as iceland.svg, we can gain 30% in this function and about 3s over 30s
+    while ( $str =~ m/\s*([aAmMzZvVhHlLcCsSqQtT])\s*([^aAmMzZvVhHlLcCsSqQtT]*)\s*/g ) {
+	my ($command, $args)=($1,$2);
+	&myWarn ("!!!! Ill-formed path command: '", substr($str,pos($str), 40), "...'\n") unless defined $command ;
+#	print "Command=$command args=$args x=$x y=$y\n";
+	if ($command eq "M") {   ## moveto absolute
+	    if (!$closed) {
+		## creating a new contour
+		push @fullRes, [ @res ];
+		$atLeastOneZ = 1;
+		@res = ();
+	    }
+	    my @points = &splitPoints($args);
+	    ($prevContrlx,$prevContrly) = (undef,undef);
+	    $firstX = $points[0];
+	    $firstY = $points[1];
+	    while (@points) {
+		$x = shift @points;
+		$y = shift @points;
+		push @res , "[$x, $y]";
+	    }
+	    next;
+	} elsif ($command eq "m") {  ## moveto relative
+	    if (!$closed) {
+		## creating a new contour
+		push @fullRes, [ @res ];
+		$atLeastOneZ = 1;
+		@res = ();
+	    }
+	    my @dxy = &splitPoints($args);
+	    $firstX = $x+$dxy[0];
+	    $firstY = $y+$dxy[1];
+# 	    print "m command: $args  => @dxy ,$x,$y\n";
+	    while (@dxy) {
+		## trying to minimize the number of operation
+		## to speed a bit this loop
+		$x += shift @dxy;
+		$y += shift @dxy;
+		push @res, "[$x, $y]";
+	    }
+	    next;
+	} elsif ($command eq 'z' or $command eq 'Z') {
+	    push @fullRes, [ @res ];
+	    $closed = 1;
+	    $atLeastOneZ = 1;
+	    @res = ();
+	    $x=$firstX;
+	    $y=$firstY;
+	    next;
+	}
+	# as a command will/should follow, the curve is no more closed
+	$closed = 0;
+	if ($command eq "V") {  ## vertival lineto absolute
+	    ($y) = $args =~ /(\S+)/m ;  ## XXXX what about multiple y !?
+	    push @res , "[$x, $y]";
+	} elsif ($command eq "v") {  ## vertical lineto relative
+	    my ($dy) = $args =~ /(\S+)/m ;  ## XXXX what about multiple dy !?
+	    $y += $dy;
+	    push @res , "[$x, $y]";
+	} elsif ($command eq "H") {  ## horizontal lineto absolute
+	    ($x) = $args =~ /(\S+)/m ;  ## XXXX what about multiple x !?
+	    push @res , "[$x, $y]";
+	} elsif ($command eq "h") {  ## horizontal lineto relative
+	    my ($dx) = $args =~ /(\S+)/m ;  ## XXXX what about multiple dx !?
+	    $x += $dx;
+	    push @res , "[$x, $y]";
+	} elsif ($command eq "L") {  ## lineto absolute
+	    my @points = &splitPoints($args);
+	    while (@points) {
+		$x = shift @points;
+		$y = shift @points;
+		push @res , "[$x, $y]";
+	    }
+	} elsif ($command eq "l") {  ## lineto relative
+	    ### thioscommand can have more than one point as arguments
+	    my @points = &splitPoints($args);
+	    # for (my $i = 0; $i < $#points; $i+=2)
+	    # is not quicker than the following while
+  	    while (@points) {
+		## trying to minimize the number of operation
+		## to speed a bit this loop
+  		$x += shift @points;
+  		$y += shift @points;
+  		push @res , "[$x, $y]";
+  	    }
+	} elsif ($command eq "C" or $command eq "c") {  ## cubic bezier
+	    &myWarn ("$command command in a path must not be the first one") ,last
+		if (scalar @res < 1);
+	    my @points = &splitPoints($args);
+	    while (@points) {
+		&myWarn ("$command command must have 6 coordinates x N times") ,last
+		    if (scalar @points < 6);
+		my $x1 = shift @points;
+		my $y1 = shift @points;
+		$prevContrlx = shift @points;
+		$prevContrly = shift @points;
+		my $xf = shift @points;
+		my $yf = shift @points;
+		if ($command eq "c") { $x1+=$x; $y1+=$y; $prevContrlx+=$x; $prevContrly+=$y; $xf+=$x; $yf+=$y}
+		push @res, ( "[$x1, $y1, 'c'], [$prevContrlx, $prevContrly, 'c'], [$xf, $yf]");
+		$x=$xf;
+		$y=$yf;
+	    }
+	} elsif ($command eq "S" or $command eq "s") {  ## cubic bezier with opposite last control point
+	    &myWarn ("$command command in a path must not be the first one") ,last
+		if (scalar @res < 1);
+#	    print "$command command : $args\n";
+	    my @points = &splitPoints($args);
+	    if ($command eq "s") {
+		for (my $i=0; $i <= $#points; $i += 2) {
+		    $points[$i] += $x;
+		}
+		for (my $i=1; $i <= $#points; $i += 2) {
+		    $points[$i] += $y;
+		}
+	    }
+	    while (@points) {
+		&myWarn ("$command command must have 4 coordinates x N times; skipping @points") ,last
+		    if (scalar @points < 4);
+		my $x1 = (defined $prevContrlx) ? $prevContrlx : $x;
+		$x1 = 2*$x-$x1;
+		my $y1 = (defined $prevContrly) ? $prevContrly : $y;
+		$y1 = 2*$y-$y1;
+		$prevContrlx = shift @points;
+		$prevContrly = shift @points;
+		$x = shift @points;
+		$y = shift @points;
+		push @res, ( "[$x1, $y1, 'c'], [$prevContrlx, $prevContrly, 'c'], [$x, $y]");
+	    }
+
+
+	} elsif ($command eq "Q" or $command eq "q") {  ## quadratic bezier
+	    &myWarn ("$command command in a path must not be the first one") ,last
+		if (scalar @res < 1);
+	    my @points = &splitPoints($args);
+	    if ($command eq "q") {
+		for (my $i=0; $i <= $#points; $i += 2) {
+		    $points[$i] += $x;
+		}
+		for (my $i=1; $i <= $#points; $i += 2) {
+		    $points[$i] += $y;
+		}
+	    }
+	    while (@points) {
+		&myWarn ("$command command must have 4 coordinates x N times") ,last
+		    if (scalar @points < 4);
+		$prevContrlx = shift @points;
+		$prevContrly = shift @points;
+		
+		my $last_x = $x;
+		my $last_y = $y;
+
+		$x = shift @points;
+		$y = shift @points;
+
+		# the following code has been provided by Lemort@intuilab.com
+		my @coordsToConvert = ($last_x,$last_y, $prevContrlx, $prevContrly,$x,$y);
+		my @convertCoords = Math::Bezier::Convert::quadratic_to_cubic(@coordsToConvert);
+		# removing the first point, already present
+		splice(@convertCoords, 0, 2);
+		
+		while (@convertCoords) {
+		    my ($ctrl1_x, $ctrl1_y) = splice(@convertCoords, 0, 2);
+		    my ($ctrl2_x, $ctrl2_y) = splice(@convertCoords, 0, 2);
+		    my ($pt_x, $pt_y) = splice(@convertCoords, 0, 2);
+
+		    push @res, ("[$ctrl1_x, $ctrl1_y, 'c'], [$ctrl2_x, $ctrl2_y, 'c'], [$pt_x, $pt_y]");
+		}
+
+	    }
+
+	} elsif ($command eq "T" or $command eq "t") {  ## quadratic bezier with opposite last control point?!
+	    &myWarn ("$command command in a path must not be the first one") ,last
+		if (scalar @res < 1);
+	    my @points = &splitPoints($args);
+
+	    if ($command eq "t") {
+		for (my $i=0; $i <= $#points; $i += 2) {
+		    $points[$i] += $x;
+		}
+		for (my $i=1; $i <= $#points; $i += 2) {
+		    $points[$i] += $y;
+		}
+	    }
+	    while (@points) {
+		&myWarn ("$command command must have 2 coordinates x N times") ,last
+		    if (scalar @points < 2);
+		my $x1 = (defined $prevContrlx) ? $prevContrlx : $x;
+		$prevContrlx = 2*$x-$x1;
+		my $y1 = (defined $prevContrly) ? $prevContrly : $y;
+		$prevContrly = 2*$y-$y1;
+		
+		my $last_x = $x;
+		my $last_y = $y;
+
+		$x = shift @points;
+		$y = shift @points;
+
+		# the following code has been provided by Lemort@intuilab.com
+		my @coordsToConvert = ($last_x,$last_y, $prevContrlx, $prevContrly,$x,$y);
+		my @convertCoords = Math::Bezier::Convert::quadratic_to_cubic(@coordsToConvert);
+		# removing the first point, already present
+		splice(@convertCoords, 0, 2);
+		
+		while (@convertCoords) {
+		    my ($ctrl1_x, $ctrl1_y) = splice(@convertCoords, 0, 2);
+		    my ($ctrl2_x, $ctrl2_y) = splice(@convertCoords, 0, 2);
+		    my ($pt_x, $pt_y) = splice(@convertCoords, 0, 2);
+
+		    push @res, ("[$ctrl1_x, $ctrl1_y, 'c'], [$ctrl2_x, $ctrl2_y, 'c'], [$pt_x, $pt_y]");
+		}
+
+	    }
+	} elsif ($command eq 'a' or $command eq 'A') {
+	    my @points = &splitPoints($args);
+	    while (@points) {
+		&myWarn ("bad $command command parameters: @points\n") if (scalar @points < 7);
+#	    print "($x,$y) $command command: @points\n";
+		if ($command eq 'a') {
+		    $points[5] += $x;
+		    $points[6] += $y;
+		}
+#	    print "($x,$y) $command command: @points\n";
+		my @coords = &arcPathCommand ( $x,$y, @points[0..6] );
+		push @res, @coords;
+		$x = $points[5];
+		$y = $points[6];
+		last if (scalar @points == 7);
+		@points = @points[7..$#points]; ### XXX ? tester!
+	    }
+	} else {
+	    &myWarn ("!!! bad path command: $command\n");
+	}
+    }
+    if (@res) {
+	return ( $atLeastOneZ, [@res], @fullRes);
+    } else { return ( $atLeastOneZ, @fullRes) }
+} # end of pathPoints
+
+
+
+
+# this function can be called many many times; so it has been "optimized"
+# even if a bit less readable
+sub splitPoints {
+    $_ = shift;
+    ### adding a space before every dash (-) when the dash preceeds by a digit
+    s/(\d)-/$1 -/g;
+    ### adding a space before ? dot (.) when more than one real are not separated;
+    ### e.g.:  '2.3.45.6.' becomes '2.3 .45 .5'
+    while ( scalar s/\.(\d+)\.(\d+)/\.$1 \.$2/) {
+    }
+    return  split ( /[\s,]+/ );
+}
+
+
+
+sub arcPathCommand {
+    my ($x1,$y1, $rx,$ry, $x_rot, $large_arc_flag,$sweep_flag, $x2,$y2) = @_;
+    return ($x2,$y2) if ($rx == 0 and $ry == 0);
+    $rx = -$rx if $rx < 0;
+    $ry = -$ry if $ry < 0;
+
+    # computing the center
+    my $phi = deg2rad($x_rot);
+
+    # compute x1' and y1' (formula F.6.5.1)
+    my $deltaX = ($x1-$x2)/2;
+    my $deltaY = ($y1-$y2)/2;
+    my $xp1 =  cos($phi)*$deltaX + sin($phi)*$deltaY;
+    my $yp1 = -sin($phi)*$deltaX + cos($phi)*$deltaY;
+#    print "xp1,yp1= $xp1 , $yp1\n";
+
+    # the radius_check has been suggested by lemort@intuilab.com
+    # checking that radius are correct
+    my $radius_check = ($xp1/$rx)**2 + ($yp1/$ry)**2;
+    
+    if ($radius_check > 1) {
+        $rx *= sqrt($radius_check);
+        $ry *= sqrt($radius_check);
+    }
+
+    # compute the sign:  (formula F.6.5.2)
+    my $sign = 1;
+    $sign = -1 if $large_arc_flag eq $sweep_flag;
+    # compute the big square root  (formula F.6.5.2)
+#    print "denominator: ", ( ($rx*$ry)**2 - ($rx*$yp1)**2 - ($ry*$xp1)**2 ),"\n";
+    my $bigsqroot = (
+		     abs( ($rx*$ry)**2 - ($rx*$yp1)**2 - ($ry*$xp1)**2 ) ### ABS ?!?!
+		     /
+		     ( ($rx*$yp1)**2 + ($ry*$xp1)**2 )
+		     );
+    # computing c'x and c'y  (formula F.6.5.2) 
+    $bigsqroot = $sign * sqrt ($bigsqroot);
+    my $cpx = $bigsqroot * ($rx*$yp1/$ry);
+    my $cpy = $bigsqroot * (- $ry*$xp1/$rx);
+
+    # compute cx and cy  (formula F.6.5.3)
+    my $middleX = ($x1+$x2)/2;
+    my $middleY = ($y1+$y2)/2;
+    my $cx = cos($phi)*$cpx - sin($phi)*$cpy + $middleX;
+    my $cy = sin($phi)*$cpx + cos($phi)*$cpy + $middleY;
+
+    # computing theta1   (formula F.6.5.5)
+    my $XX = ($xp1-$cpx)/$rx;
+    my $YY = ($yp1-$cpy)/$ry;
+    my $theta1 = rad2deg (&vectorProduct ( 1,0, $XX,$YY));
+    # computing dTheta (formula F.6.5.6)
+    my $dTheta = rad2deg (&vectorProduct ( $XX,$YY, (-$xp1-$cpx)/$rx,(-$yp1-$cpy)/$ry ));
+
+        if (!$sweep_flag and $dTheta>0) {
+	$dTheta-=360;
+    }
+    if ($sweep_flag and $dTheta<0) {
+	$dTheta+=360;
+    }
+    return  join (",", &computeArcPoints($cx,$cy,$rx,$ry,
+				       $phi,deg2rad($theta1),deg2rad($dTheta))), "\n";
+}
+
+sub computeArcPoints {
+	my ($cx,$cy,$rx,$ry,$phi,$theta1,$dTheta) = @_;
+	my $Nrad = 3.14/18;
+	my $N = &float2int(abs($dTheta/$Nrad));
+	my $cosPhi = cos($phi);
+	my $sinPhi = sin($phi);
+	my $dd = $dTheta/$N;
+	my @res;
+	for (my $i=0; $i<=$N; $i++) 
+	{
+		my $a = $theta1 + $dd*$i;
+		my $xp = $rx*cos($a);
+		my $yp = $ry*sin($a);
+		my $x1 = $cosPhi*$xp - $sinPhi*$yp + $cx;
+		my $y1 = $sinPhi*$xp + $cosPhi*$yp + $cy;
+		push @res, "[$x1, $y1]";
+	}
+	return @res;
+}
+
+## vectorial product
+sub vectorProduct {
+    my ($x1,$y1, $x2,$y2) = @_;
+    my $sign = 1;
+    $sign = -1 if ($x1*$y2 - $y1*$x2) < 0;
+
+    return $sign * acos ( ($x1*$x2 + $y1*$y2)
+			  /
+			  sqrt ( ($x1**2 + $y1**2) * ($x2**2 + $y2**2) )
+			  );
+}
+
+######################################################################################
+# points conversions for polygone / polyline
+######################################################################################
+
+# &points (\%attrs)
+# converts the string, value of an attribute points
+# to a string of coordinate list for Tk::Zinc
+sub points {
+    my ($ref_attrs) = @_;
+    my $str = $ref_attrs->{points};
+    # suppressing leading and trailing blanks:
+    ($str) = $str =~ /^\s*   # leading blanks
+                      (.*\S) # 
+		      \s*$   # trailing blanks
+		     /x;
+
+    $str =~ s/([^,])[\s]+([^,])/$1,$2/g ;  # replacing blanks separators by a comma
+    return $str;
+}
+
+######################################################################################
+# cleaning an id to make it usable as a TkZinc Tag
+######################################################################################
+
+## the following function cleans an id, ie modifies it so that it
+## follows the TkZinc tag conventions.
+## BUG: the cleanning is far from being complete
+sub cleanName {
+    my $id = shift;
+     # to avoid numeric ids
+    if ($id =~ /^\d+$/) {
+#	&myWarn ("id: $id start with digits\n");
+	$id = "id_".$id;
+    }
+    # to avoid any dots in a tag
+    if ($id =~ /\./) {
+#	&myWarn ("id: $id contains dots\n");
+	$id =~ s/\./_/g ;
+    }
+    return $id;
+}
+
+################################################################################
+# size conversions
+################################################################################
+
+## get a list of "size" attributes as listed in @attrs (e.g.: x y width height...)
+## - convert all in pixel
+## - return 0 for attributes listed in @attrs and not available in %{$ref_attrs}
+sub sizesConvert {
+    my ($ref_attrs,@attrs) = @_;
+    my %attrs = %{$ref_attrs};
+    my @res;
+    foreach my $attr (@attrs) 
+    {
+		my $value;
+		if (!defined ($value = $attrs{$attr}) ) 
+		{
+			if ($attr eq 'x2')
+			{
+				push (@res, 1);
+			}
+			else
+			{
+		    		push (@res, 0);
+			}
+		} 
+		else 
+		{
+		    push @res,&sizeConvert ($value);
+		}
+    }
+    return @res;
+} # end of sizesConvert
+
+# currently, to simplify this code, I suppose the screen is 100dpi!
+# at least the generated code is currently independant from the host
+# where is is supposed to run
+# maybe this should be enhanced
+sub sizeConvert {
+    my ($value) = @_;
+    if ($value =~ /(.*)cm/) {
+	return $1 * 40;   ## approximative pixel / cm
+    } elsif ($value =~ /(.*)mm/) {
+	return $1 * 4;   ## approximative pixel / mm
+    } elsif ($value =~ /(.*)px/) {
+	return $1;   ## exact! pixel / pixel
+    } elsif ($value =~ /(.*)in/) {
+	return &float2int($1 * 100);   ## approximative pixel / inch
+    } elsif ($value =~ /(.*)pt/) {
+	return &float2int($1 * 100 / 72);   ## approximative pixel / pt  (a pt = 1in/72)
+    } elsif ($value =~ /(.*)pc/) {
+	return &float2int($1 * 100 / 6);   ##   (a pica = 1in/6)
+    } elsif ($value =~ /(.*)%/) {
+	return $1/100;   ## useful for coordinates using % 
+	                 ## in lienar gradient (x1,x2,y2,y2)
+    } elsif ($value =~ /(.*)em/) { # not yet implemented
+	&myWarn ("em unit not yet implemented in sizes");
+	return $value;
+    } elsif ($value =~ /(.*)ex/) { # not yet implemented
+	&myWarn ("ex unit not yet implemented in sizes");
+	return $value;
+    } else {
+	return $value;
+    }
+} # end of sizeConvert
+
+
+sub float2int {
+    return sprintf ("%.0f",$_[0]);
+}
+
+
+# process a string describing transformations
+# returns a list of string describing transformations
+# to be applied to Tk::Zinc item Id
+sub transform {
+    my ($id, $str) = @_;
+    return () if !defined $str;
+    &myWarn ("!!! Need an Id for applying a transformation\n"), return () if !defined $id;
+    my @fullTrans;
+    while ($str  =~ m/\s*(\w+)\s*\(([^\)]*)\)\s*/g) {
+	my ($trans, $params) = ($1,$2);
+	my @params = split (/[\s,]+/, $params);
+	if ($trans eq 'translate') {
+	    $params[1] = 0 if scalar @params == 1; ## the 2nd paramter defaults to 0
+	    my $translation = "-> translate ($id," . join (",",@params) . ");"  ;
+	    push @fullTrans, $translation;
+	} elsif ($trans eq 'rotate') {
+	    $params[0] = deg2rad($params[0]);
+	    my $rotation = "-> rotate ($id," . join (",",@params) . ");";
+	    push @fullTrans, $rotation;
+	} elsif ($trans eq 'scale') {
+	    $params[1] = $params[0] if scalar @params == 1; ## the 2nd scale parameter defaults to the 1st
+	    my $scale = "-> scale ($id," . join (",",@params) . ");";
+	    push @fullTrans,$scale;
+	} elsif ($trans eq 'matrix') {
+	    my $matrixParams = join ',',@params;
+	    my $matrix = "-> tset ($id, $matrixParams);";
+	    push @fullTrans, $matrix;
+	} elsif ($trans eq 'skewX'){
+	    my $skewX = "-> skew ($id, " . deg2rad($params[0]) . ",0);";
+#	    print "skewX=$skewX\n";
+	    push @fullTrans, $skewX;
+	} elsif ($trans eq 'skewY'){
+	    my $skewY = "-> skew ($id, 0," . deg2rad($params[0]) . ");";
+#	    print "skewY=$skewY\n";
+	    push @fullTrans, $skewY;
+	} else {
+	    &myWarn ("!!! Unknown transformation '$trans'\n");
+	}
+#	$str = $rest;
+    }
+    return reverse @fullTrans;
+} # end of transform
+
+1;
diff --git a/src/Tk/Zinc/SVGExtension.pm b/src/Tk/Zinc/SVGExtension.pm
new file mode 100644
index 0000000..fc1e17c
--- /dev/null
+++ b/src/Tk/Zinc/SVGExtension.pm
@@ -0,0 +1,140 @@
+package SVGExtension;
+#	This program is free software; you can redistribute it and/or
+#	modify it under the terms of the GNU LGPL Libray General Public License
+#	as published by the Free Software Foundation; either version 2
+#	of the License, or (at your option) any later version.
+#
+#	This program 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 Library General Public License for more details.
+#
+#	You should have received a copy of the GNU Library General Public License
+#	along with this program; if not, write to the Free Software
+#	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA,
+#	or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+#       Zinc methods, usefull at display time of Zinc code generated for SVG file
+# 
+#	Copyright 2003
+#	Centre d'Études de la Navigation Aérienne
+#
+#	Author: Christophe Mertz <mertz@cena.fr>
+#
+# $Id: SVGExtension.pm,v 1.1.1.1 2006-10-20 13:34:25 merlin Exp $
+#############################################################################
+
+use strict;
+use Carp;
+
+
+use vars qw( $VERSION );
+
+($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/);
+
+# To implement SVG viewport.
+# This method must be called when dispalying zinc objects, because the bbox of
+# Zinc objects must be known.
+## BUG: Zinc method bbox return an oversized bbox (Zinc 3.2.6h).
+## So this method cannot currently be fully exact.
+sub Tk::Zinc::adaptViewport {
+    my ($zinc, $name, $width,$height, $viewbox, $aspectRatio) = @_;
+    my($x0,$y0,$x1,$y1)=$zinc->bbox($name); 
+    ($x0,$y0,$x1,$y1)=($x0+2,$y0+2,$x1-2,$y1-2); # 2 is a delta induced by zinc!
+    my $dx=$x1-$x0;
+    my $dy=$y1-$y0;
+#    print "In adaptViewport: $name w=$width h=$height dx=$dx dy=$dy x0=$x0,y0=$y0,x1=$x1,y1=$y1\n";
+    if (!$aspectRatio) {
+	## simple scale should be enough!
+	my ($scaleX,$scaleY) = ($width/$dx, $height/$dy);
+	$zinc->scale($name, $scaleX,$scaleY);
+    } else {	
+	my ($minx,$miny,$portWidth,$portHeight) = split /[\s,]+/ , $viewbox;
+	my ($xalign,$yalign,$meet) = $aspectRatio =~ /x(.*)Y(.*)\s+(.*)/ ;
+	print "In adaptViewport: $name viewbox=$viewbox xalign=$xalign yalign=$yalign meet=$meet\n";
+	if ($meet eq 'meet') {
+	    ## il faut réduire la taille
+	    my $scale = 1;
+	    my ($scaleX,$scaleY) = ($width/$dx, $height/$dy);
+	    if ($scaleX < $scaleY) {
+		if ($scaleX < 1) {
+		    $scale = $scaleX;
+		}
+	    } elsif ($scaleY < 1) {
+		$scale = $scaleY;
+	    }
+	    print "In adaptViewport: meet scale=$scale\n";
+	    $zinc->scale($name, $scale,$scale);
+	    
+	    my ($shiftX,$shiftY)=(0,0);
+	    if ($xalign eq 'Min') {
+	    } elsif ($xalign eq 'Max') {
+		$shiftX = $width - $dx*$scale;
+	    } elsif ($xalign eq 'Mid') {
+		$shiftX = ($width - $dx*$scale)/2;
+	    } else {
+		print "ERROR bad aspectratio value (for X): $aspectRatio\n";
+	    }
+	    
+	    if ($yalign eq 'Min') {
+	    } elsif ($yalign eq 'Max') {
+		$shiftY = $height - $dy*$scale;
+	    } elsif ($yalign eq 'Mid') {
+		$shiftY = ($height - $dy*$scale)/2;
+	    } else {
+		print "ERROR: bad aspectratio value (for Y): $aspectRatio \n";
+	    }
+	    $zinc->translate($name, $shiftX,$shiftY);
+	} elsif ($meet eq 'slice') {
+	    ## il faut clipper
+	    my $scale = 1;
+	    if ($dx < $width)  {
+		$scale = $width/$dx;
+	    }
+	    if ($dy < $height) {
+		my $scaleY = $height/$dy;
+		if ($scaleY > $scale) {$scale=$scaleY};
+	    }
+	    print "In adaptViewport: slice scale=$scale\n";
+	    $zinc->scale($name, $scale,$scale);
+		my ($shiftX,$shiftY)=(0,0);
+	    
+	    if ($xalign eq 'Min') {
+	    } elsif ($xalign eq 'Max') {
+		$shiftX = $width - $dx*$scale;
+	    } elsif ($xalign eq 'Mid') {
+		$shiftX = ($width - $dx*$scale)/2;
+	    } else {
+		print "ERROR bad aspectratio value (for X): $aspectRatio\n";
+	    }
+	    
+	    if ($yalign eq 'Min') {
+	    } elsif ($yalign eq 'Max') {
+		$shiftY = $height - $dy*$scale;
+	    } elsif ($yalign eq 'Mid') {
+		$shiftY = ($height - $dy*$scale)/2;
+	    } else {
+		print "ERROR: bad aspectratio value (for Y): $aspectRatio \n";
+	    }
+	    $zinc->translate($name, $shiftX,$shiftY);
+	    
+	    my $g=$zinc->group($name);
+	    my ($tag)= $zinc->gettags($name); # there should only be one!
+	    $zinc->add('group', $g, -tags => [ "sub$tag" ]);
+	    $zinc->chggroup($name, "sub$tag");
+	    print "clipping with [0,0, $width,$height]\n";
+	    $zinc->add('rectangle', "sub$tag", [0,0, $width+1,$height+1],
+		       -tags => ["clipper_sub$tag"]);
+	    $zinc->itemconfigure("sub$tag", -clip => "clipper_sub$tag"); 
+	}
+	print "\n";
+    }
+}
+
+
+###################################################################
+
+
+1;
diff --git a/src/emptycursor.mask b/src/emptycursor.mask
new file mode 100644
index 0000000..7da7b3b
--- /dev/null
+++ b/src/emptycursor.mask
@@ -0,0 +1,4 @@
+#define cursor_mask_width 1
+#define cursor_mask_height 1
+static char cursor_mask_bits[] = {
+	0x20};
diff --git a/src/emptycursor.xbm b/src/emptycursor.xbm
new file mode 100644
index 0000000..fe79339
--- /dev/null
+++ b/src/emptycursor.xbm
@@ -0,0 +1,6 @@
+#define cursor_width 1
+#define cursor_height 1
+#define cursor_x_hot 0
+#define cursor_y_hot 0 
+static char cursor_bits[] = {
+	0x20};