diff options
Diffstat (limited to 'src')
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, \¤t_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}) + { + ¬_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] = °2rad($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] = °2rad($params[0]); + push @fullTrans, [1,0,tan($params[0]),1,0,0]; + + } elsif ($trans eq 'skewY') { + $params[0] = °2rad($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}) { + ¬_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}},¤t_line; + } else { + $not_implemented_attr_lines{$attr} = [¤t_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}; |