A very first test for bbox (to reproduce a 3.2.98 bug)

1 files changed, 136 insertions, 0 deletions

diff --git a/Perl/t/Bbox.t b/Perl/t/Bbox.t
new file mode 100644
index 0000000..c2d08cc
--- /dev/null
+++ b/Perl/t/Bbox.t
@@ -0,0 +1,136 @@
+#!/usr/bin/perl -w
+
+#
+# $Id: Bbox.t,v 1.1 2004-05-18 15:39:38 mertz Exp $
+# Author: Christophe Mertz
+#
+
+# testing all the import
+
+BEGIN {
+    if (!eval q{
+        use Test::More tests => 2;
+        1;
+    }) {
+        print "# tests only work properly with installed Test::More module\n";
+        print "1..1\n";
+        print "ok 1\n";
+        exit;
+    }
+    if (!eval q{
+	use Tk::Zinc;
+        use Tk::Font;
+ 	1;
+    }) {
+        print "unable to load Tk::Zinc";
+        print "1..1\n";
+        print "ok 1\n";
+        exit;
+    }
+    if (!eval q{
+ 	MainWindow->new();
+ 	1;
+    }) {
+        print "# tests only work properly when it is possible to create a mainwindow in your env\n";
+        print "1..1\n";
+        print "ok 1\n";
+        exit;
+    }
+}
+
+
+$mw = MainWindow->new();
+$zinc = $mw->Zinc(-width => 100, -height => 100);
+like  ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created");
+
+my $coords = [ [10,10], [40, 40] ];
+
+
+my $font = $zinc->fontCreate('font20pixels', -size => -20);
+my $t = $zinc->add('text', 1, 
+                   -font => 'font20pixels',
+                   -alignment => 'center',
+                   #-text => 'text', # an empty text
+                   -position => [30,25],
+                  );
+
+ok(&similarFlatArray ([$zinc->bbox($t)],
+                      [30, 25, 30, 25+20+3],
+                      [4,   4,  4,  4],
+                     ),
+   "bbox of empty text");
+
+# print "bbox=(", join(',', $zinc->bbox($t)),")\n";
+
+sub similarPoints {
+  my ($ref1, $ref2)= @_;
+  diag ("waiting a reference for \$ref1" . ref ($ref1)), return 0 unless ref ($ref1) eq 'ARRAY';
+  diag ("waiting a reference for \$ref2"), return 0 unless ref ($ref2) eq 'ARRAY';
+
+  my @array1 = @{$ref1};
+  my @array2 = @{$ref2};
+
+  diag ("arrays for \$ref1 and \$ref2 are not of same length"), return 0 
+    unless scalar @array1 == @array2;
+
+  for my $i (0.. $#array1) {
+    my $pt1 = $array1[$i];
+    my $pt2 = $array2[$i];
+    diag ("waiting a reference to a point in elt $i \$ref1"), return 0 
+      unless ref $pt1 eq 'ARRAY';
+    my (@pt1) = @{$pt1};
+    diag ("waiting a reference to a point (x,y) in elt $i \$ref1"), return 0 
+      unless scalar @pt1 == 2 and &numerical($pt1[0]) and &numerical($pt1[1]) ;
+    
+    diag ("waiting a reference to a point in elt $i \$ref1"), return 0 
+      unless ref $pt2 eq 'ARRAY';
+    my (@pt2) = @{$pt2};
+    diag ("waiting a reference to a point (x,y) in elt $i \$ref2"), return 0 
+      unless scalar @pt2 == 2 and &numerical($pt2[0]) and &numerical($pt2[1]) ;
+    
+    diag ("delta > 0.001 between x of pt$i"), return 0 if abs($pt1[0]-$pt2[0]) > 0.001;
+    diag ("delta > 0.001 between y of pt$i"), return 0 if abs($pt1[1]-$pt2[1]) > 0.001;
+  }
+  return 1;
+}
+
+sub similarFlatArray {
+  my ($ref1, $ref2, $deltaref)= @_;
+  diag ("waiting a reference for \$ref1"), return 0 unless ref ($ref1) eq 'ARRAY';
+  diag ("waiting a reference for \$ref2"), return 0 unless ref ($ref2) eq 'ARRAY';
+  diag ("waiting a reference for \$deltaref"), return 0 unless ref ($deltaref) eq 'ARRAY';
+  
+  my @array1 = @{$ref1};
+  my @array2 = @{$ref2};
+  my @deltaarray = @{$deltaref};
+  diag ("arrays for \$ref1 and \$ref2 and \$deltaref are not of same length,".$#array1.",".$#array2.",".$#deltaarray), return 0 
+    unless ($#array1 == $#array2) and ($#array2 == $#deltaarray);
+  for my $i (0.. $#array1) {
+    my $a = $array1[$i];
+    my $b = $array2[$i];
+    my $delta = $deltaarray[$i];
+    diag ("waiting a numeric value for elt $i of \$ref1"), return 0 
+      unless &numerical($a);
+    diag ("waiting a numeric value for elt $i of \$ref2"), return 0 
+      unless &numerical($b);
+    diag ("waiting a numeric value for elt $i of \$deltaref"), return 0 
+      unless &numerical($delta);
+        
+    diag ("delta > $delta between elt $i of \$ref1 ($a) and \$ref2 ($b)"), return 0 
+      if (abs($a-$b) > $delta) ;
+  }
+  return 1;
+}
+
+
+sub numerical {
+  my ($v) = @_;
+  return 0 unless defined $v;
+  ### this really works!!
+  return $v eq $v*1;
+  }
+
+
+diag("############## bbox test");
+
+