From c5866f304210618979d03c561b1e3f6f83200bce Mon Sep 17 00:00:00 2001
From: ribet
Date: Wed, 21 Mar 2007 10:19:39 +0000
Subject: Import initial

---
 src/MTools.pm | 711 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 711 insertions(+)
 create mode 100644 src/MTools.pm

(limited to 'src/MTools.pm')

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;
-- 
cgit v1.1