ZincTraceUtils, Tk::ZincText and LogoZinc are renamed

Tk::Zinc::TraceUtils, Tk::Zinc::Text and Tk::Zinc::Logo.

ZincTrace et ZincTraceErrors which load Tk::Zinc::TraceUtils
need update.

5 files changed, 539 insertions, 2 deletions

diff --git a/Perl/Zinc/Logo.pm b/Perl/Zinc/Logo.pm
new file mode 100644
index 0000000..5e9db69
--- /dev/null
+++ b/Perl/Zinc/Logo.pm
@@ -0,0 +1,187 @@
+#!/usr/bin/perl
+#---------------------------------------------------------------
+#  Project         : Harmony
+#  Module          : Harmony
+#  File            : Logo.pm
+#
+#  Copyright (C) 2001
+#  Centre d'Études de la Navigation Aérienne
+#  Authors: Vinot Jean-Luc <vinot@cena.fr>
+#
+#---------------------------------------------------------------
+
+package Tk::Zinc::Logo;
+
+use strict;
+use Carp;
+use Math::Trig;
+
+Construct Tk::Widget 'Tk::Zinc::Logo';
+
+
+my @Gradiants;
+
+# paramètres de construction graphique
+my %builder = (-gradset => {'logoshape' => '=axial 270 |#ffffff;100 0 28|#66848c;100 96|#7192aa;100 100',
+			    'logopoint' => '=radial -20 -20 |#ffffff;100 0|#f70000;100 48|#900000;100 80|#ab0000;100 100',
+			    'logoptshad' => '=path 0 0 |#770000;64 0|#770000;70 78|#770000;0 100',
+			    },
+
+	       -shape => {-form => {-itemtype => 'curve',
+				    -coords => [[0, 0],[106, 0],[106, 58],[122, 41],[156, 41],[131, 69],
+						[153, 99],[203, 41],[155, 41],[155, 0],[218, 0],[240, 0, 'c'],
+						[252, 17, 'c'],[252, 34],[252, 40, 'c'],[249, 50, 'c'],
+						[244, 56],[202, 105],[246, 105],[246, 87],[246, 60, 'c'],
+						[271, 37, 'c'],[297, 37],[323, 37, 'c'],[342, 57, 'c'],[344, 68],
+						[347, 64, 'c'],[350, 60, 'c'],[353, 56],[363, 46, 'c'],[375, 37, 'c'],
+						[395, 37],[395, 79],[393, 79],[385, 79, 'c'],[379, 86, 'c'],
+						[379, 93],[379, 100, 'c'],[385, 107, 'c'],[393, 107],[409, 107],
+						[409, 148],[397, 148],[378, 148, 'c'],[364, 144, 'c'],[354, 133],
+						[346, 124],[346, 148],[305, 148],[305, 87],[305, 83, 'c'],[301, 79, 'c'],
+						[297, 79],[293, 79, 'c'],[289, 83, 'c'],[289, 87],[289, 150],[251, 150],
+						[251, 130],[251, 126, 'c'],[247, 122, 'c'],[243, 122],[239, 122, 'c'],
+						[235, 126, 'c'],[235, 130],[235, 150],[176, 150],[154, 150,'c'],
+						[146, 131,'c'],[146, 114],[148, 105],[120, 105],[104, 81],[104, 105],
+						[74, 105],[74, 41],[52, 41],[52, 105],[20, 105],[20, 41],[0, 41],
+					       ],
+
+				    -params => {-priority => 50,
+						-linewidth => 3,
+						-linecolor => '#000000;100',
+						-filled => 1,
+						-closed => 0,
+						-fillcolor => 'logoshape',
+					       },
+				   },
+
+			  -shadow => {-clone => '-form',
+				      -translate => [6, 6],
+				      -params => {-fillcolor => '#000000;18',
+						  -linewidth => 0,
+						  -priority => 20,
+						 },
+				     },
+			 },
+
+	       -point => {-coords => [240, 96],
+			  -params => {-alpha => 80,
+				      -priority => 100,
+				     },
+
+			  -form => {-itemtype => 'arc',
+				    -coords => [[-20, -20], [20, 20]],
+				    -params => {-priority => 50,
+						-filled => 1,
+						-linewidth => 1,
+						-linecolor => '#a10000;100',
+						-fillcolor => 'logopoint',
+						-closed => 1,
+					       },
+				   },
+
+			  -shadow => {-clone => '-form',
+				      -translate => [5, 5],
+				      -params => {-fillcolor => 'logoptshad',
+						  -linewidth => 0,
+						  -priority => 20,
+						 },
+				     },
+			 },
+	      );
+
+
+
+sub new {
+    my $proto = shift;
+    my $type = ref($proto) || $proto;
+    my $widget = shift;
+    my %params = @_;
+
+    my $self = {};
+    bless ($self, $type);
+
+    $self->{'-widget'} = $widget;
+    $self->{'-parent'} = (exists $params{'-parent'}) ? $params{'-parent'} : 1;
+    $self->{'-priority'} = (exists $params{'-priority'}) ? $params{'-priority'} : 500;
+    $self->{'-position'} = (exists $params{'-position'}) ? $params{'-position'} : [0, 0];
+    $self->{'-scale'} = (exists $params{'-scale'}) ? $params{'-scale'} : [1, 1];
+
+    $self->drawLogo();
+
+    return bless $self, $type;
+}
+
+
+
+sub drawLogo {
+  my ($self) = @_;
+  my $zinc = $self->{'-widget'}; 
+  my $parent = $self->{'-parent'};
+  my $priority = $self->{'-priority'};
+
+
+  if ($builder{'-gradset'}) {
+    while (my ($name, $gradiant) = each( %{$builder{'-gradset'}})) {
+      # création des gradiants nommés
+      $zinc->gname($gradiant, $name) unless $zinc->gname($name);
+      push(@Gradiants, $name);
+    }
+  }
+
+  # création des groupes logo
+  # logogroup : groupe de coordonnées
+  my $logogroup =  $self->{'-item'} = $zinc->add('group', $parent, -priority => $priority);
+  $zinc->coords($logogroup, $self->{'-position'}) if ($self->{'-position'});
+
+  # group de scaling
+  my $group = $self->{'-scaleitem'} = $zinc->add('group', $logogroup);
+  $zinc->scale($group,  @{$self->{'-scale'}}) if ($self->{'-scale'});
+
+
+  # création de l'item shape (Zinc)
+  my $formstyle = $builder{'-shape'}->{'-form'};
+  $self->ajustLineWidth($formstyle->{'-params'});
+  my $shape = $zinc->add('curve', $group,
+			$formstyle->{'-coords'},
+			%{$formstyle->{'-params'}},
+		       );
+
+  # ombre portée de la shape
+  my $shadstyle = $builder{'-shape'}->{'-shadow'};
+  my $shadow = $zinc->clone($shape, %{$shadstyle->{'-params'}});
+  $zinc->translate($shadow, @{$shadstyle->{'-translate'}}) if ($shadstyle->{'-translate'});
+
+  # réalisation du point
+  my $pointconf = $builder{'-point'};
+  my $ptgroup = $zinc->add('group', $group, %{$pointconf->{'-params'}});
+  $zinc->coords($ptgroup,  $pointconf->{'-coords'});
+
+  my $pointstyle =  $pointconf->{'-form'};
+  my $point = $zinc->add('arc', $ptgroup,
+			 $pointstyle->{'-coords'},
+			 %{$pointstyle->{'-params'}},
+			 );
+
+  my $shadpoint = $zinc->clone($point, %{$shadstyle->{'-params'}});
+  $shadstyle = $pointconf->{'-shadow'};
+  $zinc->translate($shadpoint, @{$shadstyle->{'-translate'}});
+
+}
+
+
+sub ajustLineWidth {
+  my ($self, $style, $scale) = @_;
+
+  if ($style->{'-linewidth'}) {
+    my ($sx, $sy) = @{$self->{'-scale'}};
+    my $linewidth = $style->{'-linewidth'};
+    if ($linewidth >= 2) {
+      my $ratio = ($sx > $sy) ? $sy : $sx;
+      $style->{'-linewidth'} = $linewidth * $ratio;
+    }
+  }
+}
+
+1;
+
+
diff --git a/Perl/Zinc/Text.pm b/Perl/Zinc/Text.pm
new file mode 100644
index 0000000..2cf4fd2
--- /dev/null
+++ b/Perl/Zinc/Text.pm
@@ -0,0 +1,260 @@
+
+package Tk::Zinc::Text;
+
+
+sub new {
+  my $proto = shift;
+  my $type = ref($proto) || $proto;
+  my ($zinc) = @_;
+  my $self = {};
+
+  $zinc->bind('text', '<1>' => sub {startSel($zinc)});
+  $zinc->bind('text', '<2>' => sub {pasteSel($zinc)});
+  $zinc->bind('text', '<B1-Motion>' => sub {extendSel($zinc)});
+  $zinc->bind('text', '<Shift-B1-Motion>' => sub {extendSel($zinc)});
+  $zinc->bind('text', '<Shift-1>' => sub {
+		my $e = $zinc->XEvent();
+		my($x, $y) = ($e->x, $e->y);
+		$zinc->select('adjust', 'current', "\@$x,$y"); });
+  $zinc->bind('text', '<Left>' => sub {moveCur($zinc, -1);});
+  $zinc->bind('text', '<Right>' => sub {moveCur($zinc, 1);});
+  $zinc->bind('text', '<Up>' => sub {setCur($zinc, 'up');});
+  $zinc->bind('text', '<Down>' => sub {setCur($zinc, 'down');});
+  $zinc->bind('text', '<Control-a>' => sub {setCur($zinc, 'bol');});
+  $zinc->bind('text', '<Home>' => sub {setCur($zinc, 'bol');});
+  $zinc->bind('text', '<Control-e>' => sub {setCur($zinc, 'eol');});
+  $zinc->bind('text', '<End>' => sub {setCur($zinc, 'eol');});
+  $zinc->bind('text', '<Meta-less>' => sub {setCur($zinc, 0);});
+  $zinc->bind('text', '<Meta-greater>' => sub {setCur($zinc, 'end');});
+  $zinc->bind('text', '<KeyPress>' => sub {insertKey($zinc);});
+  $zinc->bind('text', '<Shift-KeyPress>' => sub {insertKey($zinc);});
+  $zinc->bind('text', '<Return>' => sub { insertChar($zinc, chr(10)); });
+  $zinc->bind('text', '<BackSpace>' => sub {textDel($zinc, -1)});
+  $zinc->bind('text', '<Control-h>' => sub {textDel($zinc, -1)});
+  $zinc->bind('text', '<Delete>' => sub {textDel($zinc, 0)});
+
+  bless ($self, $type);
+  return $self;
+}
+
+
+sub pasteSel {
+  my ($w) = @_;
+  my $e = $w->XEvent;
+  my($x, $y) = ($e->x(), $e->y());
+  my @it = $w->focus();
+
+  if (@it != 0) {
+    eval { $w->insert(@it, "\@$x,$y", $w->SelectionGet()); };
+  }
+}
+
+
+sub insertChar {
+  my ($w, $c) = @_;
+  my @it = $w->focus();
+  my @selit = $w->select('item');
+
+  if (@it == 0) {
+    return;
+  }
+
+  if ((scalar(@selit) == scalar(@it)) &&
+      ($selit[0] eq $it[0]) && ($selit[1] eq $it[1])) {
+    $w->dchars(@it, 'sel.first', 'sel.last');
+  }
+  $w->insert(@it, 'insert', $c);
+}
+
+
+sub insertKey {
+  my ($w) = @_;
+  my $c = $w->XEvent->A();
+
+  if ((ord($c) < 32) || (ord($c) == 128)) {
+    return;
+  }
+
+  insertChar($w, $c);
+}
+
+
+sub setCur {
+  my ($w, $where) = @_;
+  my @it = $w->focus();
+
+  if (@it != 0) {
+    $w->cursor(@it, $where);
+  }
+}
+
+
+sub moveCur {
+  my ($w, $dir) = @_;
+  my @it = $w->focus();
+  my $index;
+
+  if (@it != 0) {
+    $index = $w->index(@it, 'insert');
+    $w->cursor(@it, $index + $dir);
+  }
+}
+
+
+sub startSel {
+  my($w) = @_;
+  my $e = $w->XEvent;
+  my($x, $y) = ($e->x(), $e->y());
+  my $part = $w->currentpart(1);
+
+  $w->cursor('current', $part, "\@$x,$y");
+  $w->focus('current', $part);
+  $w->Tk::focus();
+  $w->select('from', 'current', $part, "\@$x,$y");
+}
+
+
+sub extendSel {
+  my($w) = @_;
+  my $e = $w->XEvent;
+  my($x, $y) = ($e->x, $e->y);
+  my $part = $w->currentpart(1);
+
+  $w->select('to', 'current', $part, "\@$x,$y");
+}
+
+
+sub textDel {
+  my($w, $dir) = @_;
+  my @it = $w->focus();
+  my @selit = $w->select('item');
+  my $ind;
+
+  if (@it == 0) {
+    return;
+  }
+
+  if ((scalar(@selit) == scalar(@it)) &&
+      ($selit[0] eq $it[0]) && ($selit[1] eq $it[1])) {
+    $w->dchars(@it, 'sel.first', 'sel.last');
+  }
+  else {
+    $ind = $w->index(@it, 'insert') + $dir;
+    $w->dchars(@it, $ind, $ind) if ($ind >= 0);
+  }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Tk::Zinc::Text - Zinc extension for easing text input on text item or on fields
+
+=head1 SYNOPSIS
+
+ use Tk::Zinc::Text;
+
+ $zinc = $mw->Zinc();
+ new Tk::Zinc::Text ($zinc);
+ ....
+ $zinc->addtag('text', 'withtag', $a_text);
+ $zinc->addtag('text', 'withtag', $a_track);
+ $zinc->addtag('text', 'withtag', $a_waypoint);
+ $zinc->addtag('text', 'withtag', $a_tabular);
+
+=head1 DESCRIPTION
+
+This module implements text input with the mouse and keyboard 'a la emacs'.
+Text items must have the 'text' tag and must of course be sensitive.
+Track, waypoint and tabular items have fields and these fields can
+be edited the same way. Only sensitive fields can be edited. the following
+interactions are supported:
+
+=over 2
+
+=item B<click 1>
+
+To set the cursor position
+
+=item B<click 2>
+
+To paste the current selection
+
+=item B<drag 1>
+
+To make a selection
+
+=item B<shift drag 1>
+
+To extend the current selection
+
+=item B<shift 1>
+
+To extend the current selection
+
+=item B<left arrow>, B<right arrow>
+
+To move the cursor to the left or to the right
+
+=item B<up arrow>, B<down arrow>
+
+To move the cursor up or down a line
+
+=item B<ctrl+a>, B<home>
+
+To move the cursor at the begining of the line
+
+=item B<ctrl+e>, B<end>
+
+To move the cursor at the end of the line
+
+=item B<meta+<>, B<meta+E<gt>>
+
+To move the cursor at the beginning / end of the text
+
+=item B<BackSpace>, B<ctrl+h>
+
+To delete the char just before the cursor
+
+=item B<Delete>
+
+To delete the char just after the cursor
+
+=item B<Return>
+
+To insert a return char. This does not validate the input!
+
+=back
+
+=head1 BUGS
+
+No known bugs at this time. If you find one, please report them to the authors.
+
+=head1 SEE ALSO
+
+perl(1), Tk(1), Tk::Zinc(3), zinc-demos(1)
+
+=head1 AUTHORS
+
+Patrick Lecoanet <lecoanet@cena.fr>
+(and some documentation by Christophe Mertz <mertz@cena.fr>)
+
+=head1 COPYRIGHT
+
+CENA (C) 2002
+
+Tk::Zinc::Text is part of Zinc and has been developed by the CENA (Centres d'Etudes de la Navigation Aérienne)
+for its own needs in advanced HMI (Human Machine Interfaces or Interactions). Because we are confident
+in the benefit of free software, the CENA delivered this toolkit under the GNU
+Library General Public License.
+
+This code is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even
+the implied warranty of MER­CHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library
+General Public License for more details.
+
+=head1 HISTORY
+
+June 2002 : initial release with Zinc-perl 3.2.6
+
+=cut
diff --git a/Perl/Zinc/Trace.pm b/Perl/Zinc/Trace.pm
index 0a2b7c4..e9bb01c 100644
--- a/Perl/Zinc/Trace.pm
+++ b/Perl/Zinc/Trace.pm
@@ -26,7 +26,7 @@ package ZincTrace;
 
 use Tk;
 use strict;
-use ZincTraceUtils;
+use Tk::Zinc::TraceUtils;
 
 my $WidgetMethodfunction;
 BEGIN {
diff --git a/Perl/Zinc/TraceErrors.pm b/Perl/Zinc/TraceErrors.pm
index f5d1069..43c4e3d 100644
--- a/Perl/Zinc/TraceErrors.pm
+++ b/Perl/Zinc/TraceErrors.pm
@@ -29,7 +29,7 @@ package ZincTraceErrors;
 
 use Tk;
 use strict;
-use ZincTraceUtils;
+use Tk::Zinc::TraceUtils;
 
 my $WidgetMethodfunction;
 my $bold = "";
diff --git a/Perl/Zinc/TraceUtils.pm b/Perl/Zinc/TraceUtils.pm
new file mode 100644
index 0000000..07b0413
--- /dev/null
+++ b/Perl/Zinc/TraceUtils.pm
@@ -0,0 +1,90 @@
+package Tk::Zinc::TraceUtils;
+
+use Tk;
+use strict;
+use Tk::Font;
+use Tk::Photo;
+use vars qw(@EXPORT);
+@EXPORT = qw(printItem printArray printList);
+
+
+### to print something
+sub printItem {
+    my ($value) = @_;
+    my $ref = ref($value);
+#    print "VALUE=$value REF=$ref\n";
+    if ($ref eq 'ARRAY') {
+	printArray ( @{$value} );
+    }
+    elsif ($ref eq 'CODE') {
+	print "{CODE}";
+    }
+    elsif ($ref eq 'Tk::Photo') {
+#	print " **** $value ***** ";
+	print "Tk::Photo(\"". scalar $value->cget('-file') . "\")";
+    }
+    elsif ($ref eq 'Tk::Font') {
+	print "'$value'";
+    }
+    elsif ($ref eq '') {  # scalar 
+	if (defined $value) {
+	    if ($value eq '') {
+		print  "''";
+	    } elsif ($value =~ /\s/
+		     or $value =~ /^[a-zA-Z]/
+		     or $value =~ /^[\W]$/ ) {
+		print "'$value'";
+	    }  else {
+		print $value;
+	    }
+	}
+	else {
+	    print "undef";
+	}
+    }
+    else { # some  class instance
+	return $value;
+    }
+    
+} # end printitem
+
+
+### to print a list of something
+sub printArray {
+    my (@values) = @_;
+    if (! scalar @values) {
+	print "[]";
+    }
+    else {  # the list is not empty
+	my @res;
+	print "[";
+	while (@values) {
+	    my $value = shift @values;
+	    &printItem ($value);
+	    print ", " if (@values);
+	}
+	print "]" ;
+    }
+    
+} # end printArray
+
+
+sub printList {
+    print "(";
+    while (@_) {
+	my $v = shift @_;
+	printItem $v;
+	if ($v =~ /^-\w+/) {
+	    print " => ";
+	} elsif (@_) {
+	    print ", ";
+	}
+    }
+    print ")";
+    
+} # end printList
+
+1;
+
+
+