aboutsummaryrefslogtreecommitdiff
path: root/src/MTools.pm
diff options
context:
space:
mode:
Diffstat (limited to 'src/MTools.pm')
-rw-r--r--src/MTools.pm711
1 files changed, 711 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;
generated by cgit v1.1 at 2024-09-21 07:44:36 +0000