aboutsummaryrefslogtreecommitdiff
path: root/Perl/t
diff options
context:
space:
mode:
authorcvs2svn2005-01-24 15:46:33 +0000
committercvs2svn2005-01-24 15:46:33 +0000
commite6a05dbef707dc10e546ef8fef8fc2a8b7d805bf (patch)
tree7061a2d781348fa7d5965b7d7dd5d7ef6b27a7b0 /Perl/t
parente1ed2c6d78bb616e24166c13126adba1b95ea4ea (diff)
downloadtkzinc-POSTSCRIPT.zip
tkzinc-POSTSCRIPT.tar.gz
tkzinc-POSTSCRIPT.tar.bz2
tkzinc-POSTSCRIPT.tar.xz
This commit was manufactured by cvs2svn to create branch 'POSTSCRIPT'.POSTSCRIPT
Diffstat (limited to 'Perl/t')
-rw-r--r--Perl/t/.cvsignore2
-rw-r--r--Perl/t/AnimatedGradient.t175
-rw-r--r--Perl/t/Bbox.t242
-rw-r--r--Perl/t/Coords.t151
-rw-r--r--Perl/t/Images.t212
-rw-r--r--Perl/t/Import.t31
-rw-r--r--Perl/t/PreviousKnownBugs.t61
-rw-r--r--Perl/t/Test/Builder.pm1408
-rw-r--r--Perl/t/Test/Harness.pm1168
-rw-r--r--Perl/t/Test/Harness/Assert.pm68
-rw-r--r--Perl/t/Test/Harness/Iterator.pm61
-rw-r--r--Perl/t/Test/Harness/Straps.pm667
-rw-r--r--Perl/t/Test/More.pm1248
-rw-r--r--Perl/t/TestLog.pm306
-rw-r--r--Perl/t/Text.t58
-rw-r--r--Perl/t/Transformations.t304
-rw-r--r--Perl/t/find.t200
-rw-r--r--Perl/t/test-methods.pl689
-rw-r--r--Perl/t/test-no-crash.pl880
-rw-r--r--Perl/t/testdoc.pl274
-rw-r--r--Perl/t/text.t161
-rw-r--r--Perl/t/traceutils.t89
22 files changed, 0 insertions, 8455 deletions
diff --git a/Perl/t/.cvsignore b/Perl/t/.cvsignore
deleted file mode 100644
index 532f21c..0000000
--- a/Perl/t/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-*.log
-*.log.prev
diff --git a/Perl/t/AnimatedGradient.t b/Perl/t/AnimatedGradient.t
deleted file mode 100644
index e65f9a3..0000000
--- a/Perl/t/AnimatedGradient.t
+++ /dev/null
@@ -1,175 +0,0 @@
-#!/usr/bin/perl -w
-
-#
-# $Id: AnimatedGradient.t,v 1.1 2004-09-20 20:07:06 mertz Exp $
-# Author: Christophe Mertz mertz@intuilab.com
-#
-
-# this test mainly does funny effects when openGL is on
-
-
-# testing all the import
-
-BEGIN {
- if (!eval q{
-# use Test::More qw(no_plan);
- use Test::More tests => 18;
- 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;
- 1;
- }) {
- print "unable to load Tk::Zinc";
- print "1..1\n";
- print "ok 1\n";
- exit;
- }
-}
-
-use strict;
-my $mw = MainWindow->new();
-my $zinc = $mw->Zinc(-width => 200, -height => 200, -backcolor => "white",
- -render => 1)->pack;
-
-like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created");
-
-$zinc->add('text', 1, -position => [10,5], -text =>
-"the gradient fills a rectangle
-which is clipped by the curve
-made of two circles...\n"x5);
-
-
-my $circle1 = $zinc->add('arc', 1, [20,20,180,180]);
-my $circle2 = $zinc->add('arc', 1, [70,70,130,130]);
-
-my $curve = $zinc->add('curve', 1, [],
- -fillcolor => 'red', -filled => 1, -linewidth => 1);
-$zinc->contour($curve, 'add', 1, $circle1);
-$zinc->contour($curve, 'add', -1, $circle2);
-
-$zinc->remove($circle1);
-$zinc->remove($circle2);
-
-my $gradient;
-for (1..4) {
- for (my $i = 0; $i <=360; $i++) {
- $gradient = "=axial $i | red | white 50 | blue";
- $zinc->itemconfigure($curve, -fillcolor => $gradient);
- $zinc->update;
- }
-}
-pass("turning gradient one side");
-
-for (1..4) {
- for (1..100) {
- $zinc->translate($curve,0.5,0.5);
- $zinc->update;
- }
- for (1..800) {
- $zinc->rotate($curve, 3.14159/400, 100,100);
- $zinc->update;
- }
- for (1..100) {
- $zinc->translate($curve,0.5,0.5);
- $zinc->update;
- }
-
- for (1..400) {
- $zinc->translate($curve,-0.5,-0.5);
- $zinc->update;
- }
- for (1..200) {
- $zinc->translate($curve,0.5,0.5);
- $zinc->update;
- }
- pass ("shaking the circle around");
-}
-
-for (1..4) {
- for (my $i = 359; $i > 0; $i--) {
- $gradient = "=axial $i | red | white 50 | blue";
- $zinc->itemconfigure($curve, -fillcolor => $gradient);
- $zinc->update;
- }
-}
-pass("turning gradient the other side");
-
-
-my $gr = $zinc->add('group', 1);
-my $rect = $zinc->add('rectangle', $gr, [0,-480,200,180], -filled => 1,
- -fillcolor => "=axial 90 |blue|white 10|red 20|white 30|blue 40|white 50|red 60|white 70|blue 80|white 90|red");
-
-$zinc->chggroup($curve, $gr);
-$zinc->itemconfigure($curve, -visible => 0);
-
-$zinc->itemconfigure($gr, -clip => $curve);
-
-
-pass("displaying a translated rectangle filled with froggy colors and clipped by two circles");
-for (1..2) {
- for (my $i = 0; $i<500 ; $i++) {
- $zinc->translate($rect, 0,1);
- $zinc->update;
- }
- for (my $i = 0; $i<500 ; $i++) {
- $zinc->translate($rect, 0,-1);
- $zinc->update;
- }
- pass ("a thousand translation");
-}
-
-$zinc->translate($rect, 0,250);
-
-
-for (1..1000) {
- $zinc->scale($rect, 1, 0.998, 100,100);
- $zinc->update;
-}
-pass("a thousand scaling down");
-
-
-for (1..360) {
- $zinc->rotate($rect, 3.14159/180, 100,100);
- $zinc->update;
-}
-pass("360 rotation of 1°");
-
-
-for (1..360) {
- $zinc->rotate($rect, -3.14159/180, 100,100);
- $zinc->update;
-}
-pass("360 rotation of 1°");
-
-
-for (1..360) {
- $zinc->rotate($rect, -3.14159/180, 100,100);
- $zinc->update;
-}
-
-
-for (1..1000) {
- $zinc->scale($rect, 1, 1/0.998, 100,100);
- $zinc->update;
-}
-pass("a thousand scaling up");
-
-
-
-for (1..4) {
- for my $i (0..200) {
- $zinc->itemconfigure($gr, -alpha => (200-$i)/2);
- $zinc->update;
- }
- for my $i (0..200) {
- $zinc->itemconfigure($gr, -alpha => $i/2);
- $zinc->update;
- }
- pass("fade out/in in 400 steps");
-}
diff --git a/Perl/t/Bbox.t b/Perl/t/Bbox.t
deleted file mode 100644
index 5840fc3..0000000
--- a/Perl/t/Bbox.t
+++ /dev/null
@@ -1,242 +0,0 @@
-#!/usr/bin/perl -w
-
-#
-# $Id: Bbox.t,v 1.7 2004-11-16 20:46:14 mertz Exp $
-# Author: Christophe Mertz
-#
-
-# testing all the import
-
-BEGIN {
- if (!eval q{
- use Test::More tests => 12;
- 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 => 400, -height => 400)->pack;
-like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created");
-
-my $coords = [ [10,10], [40, 40] ];
-
-
-my $font = $zinc->fontCreate('font20pixels', -size => -20);
-#my @metrics = $zinc->fontMetrics('font20pixels');
-#print "metrics = @metrics\n";
-my $linespace = $zinc->fontMetrics('font20pixels', -linespace);
-
-my $txt1 = $zinc->add('text', 1,
- -font => 'font20pixels',
- -alignment => 'center',
- #-text => 'text', # an empty text
- -position => [30,25],
- );
-#print "bbox=(", join(',', $zinc->bbox($txt1)),")\n";
-
-# from v3.30 the bbox of an empty text is ()
-ok(&similarFlatArray ([$zinc->bbox($txt1)],
- [],
- [],
- ),
- "bbox of empty text");
-
-my $width = $zinc->fontMeasure('font20pixels', 'dummy');
-#print "width = $width\n";
-my $txt2 = $zinc->add('text', 1,
- -font => 'font20pixels',
- -alignment => 'left',
- -text => 'dummy',
- -position => [200,100],
- );
-# print "bbox=(", join(',', $zinc->bbox($txt2)),")\n";
-
-ok(&similarFlatArray ([$zinc->bbox($txt2)],
- [200,100, 200+$width, 100+$linespace],
- [4,4, 4,4 ],
- ),
- "bbox of 'dummy' text");
-
-my $txt3 = $zinc->add('text', 1,
- -font => 'font20pixels',
- -alignment => 'center',
- -text => 'dummy',
- -position => [200,200],
- );
-# print "bbox=(", join(',', $zinc->bbox($txt3)),")\n";
-
-ok(&similarFlatArray ([$zinc->bbox($txt3)],
- [200,200, 200+$width, 200+$linespace],
- [4,4, 4,4 ],
- ),
- "bbox of 'dummy' aligned-centered text");
-
-my $txt4 = $zinc->add('text', 1,
- -font => 'font20pixels',
- -anchor => 'center',
- -text => 'dummy',
- -position => [200,100],
- );
-# print "bbox=(", join(',', $zinc->bbox($txt4)),")\n";
-
-ok(&similarFlatArray ([$zinc->bbox($txt4)],
- [200-$width/2,100-$linespace/2, 200+$width/2, 100+$linespace/2],
- [4,4, 4,4 ],
- ),
- "bbox of 'dummy' centered text");
-
-
-### testing bbox of fields or labels of track/waypoint and tabular items
-my $track = $zinc->add('track', 1, 4, -position => [56, 78]);
-# print "bbox11=(", $bbox,")\n";
-
-is($zinc->bbox(-label, $track), (),
- "bbox of a track label without labelformat is ()");
-
-my $bbox = $zinc->bbox(-field, 0, $track);
-#print "bbox22=(", $bbox,")\n";
-
-is( $bbox, undef, "bbox of a track field without labelformat is undef");
-
-
-$zinc->itemconfigure($track, -labelformat => 'x20x18+0+0');
-#print "bbox=(", join(',', $zinc->bbox(-label, $track)),")\n";
-
-$bbox = eval { $zinc->bbox(-field, 4, $track) } ;
-#print "bbox=(", $bbox,")\n";
-
-is( $bbox, (),
- "bbox of a track field which field is out of bound is undef");
-
-my $wpt = $zinc->add('waypoint', 1, 0, -position => [561, 781]);
-#print "wpt bbox=(", join(',', $zinc->bbox($wpt)),")\n";
-ok(&similarFlatArray ([ $zinc->bbox($wpt) ],
- [ 561,781, 561,781],
- [4,4, 4,4],
- ),
- "coords of a waypoint without label");
-
-
-my $tab = $zinc->add('tabular', 1, 1, -position => [61, 81]);
-is_deeply([ $zinc->bbox($tab) ],
- [ ],
- "bbox of a tabular without labelformat");
-
-#print "tab bbox=(", join(',', $zinc->bbox(-label, $tab)),")\n";
-is_deeply([ $zinc->bbox(-label, $tab) ],
- [ ],
- "bbox of a tabular without labelformat");
-
-#print "tab bbox=(", join(',', $zinc->bbox(-field, 0, $tab)),")\n";
-is_deeply([ $zinc->bbox(-field, 0, $tab) ],
- [ ],
- "bbox of a tabular field without labelformat");
-
-
-# $zinc->itemconfigure($tab, -labelformat => 'x20x18+0+0');
-# is_deeply([ $zinc->coords($tab) ],
-# [ 61,81 ],
-# "coords of a tabular with a labelformat");
-
-
-
-
-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;
-}
-
-## ref1 is the obtained array
-## ref2 is the expected array
-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 obtained, expected and deltas 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 obtained array"), return 0
- unless &numerical($a);
- diag ("waiting a numeric value for elt $i of expected array"), return 0
- unless &numerical($b);
- diag ("waiting a numeric value for elt $i of deltas array"), return 0
- unless &numerical($delta);
-
- diag ("delta > $delta between elt $i of obtained array ($a) and expected array ($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");
-
-
diff --git a/Perl/t/Coords.t b/Perl/t/Coords.t
deleted file mode 100644
index b8c4662..0000000
--- a/Perl/t/Coords.t
+++ /dev/null
@@ -1,151 +0,0 @@
-#!/usr/bin/perl -w
-
-#
-# $Id: Coords.t,v 1.6 2004-05-24 19:56:23 mertz Exp $
-# Author: Christophe Mertz
-#
-
-# testing all the import
-
-BEGIN {
- if (!eval q{
-# use Test::More qw(no_plan);
- use Test::More tests => 21;
- 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;
- 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 $rect = $zinc->add('rectangle', 1, [10,20,40,50]);
-
-
-is_deeply([ $zinc->coords($rect) ],
- [ [10,20], [40, 50] ],
- "coords are list of arrays");
-
-is_deeply([ $zinc->coords($rect,0) ],
- [ [10,20], [40, 50] ],
- "coords of first contour is a list of arrays");
-
-is_deeply([ $zinc->coords($rect,0,0) ],
- [ 10,20 ],
- "coords of one point of a contour is a list of two numbers");
-
-is_deeply([ $zinc->coords($rect,0,1) ],
- [ 40,50 ],
- "coords of one point of a contour is a list of two numbers");
-
-my $curve = $zinc->add('curve', 1, [ [10,20] ,[40,50,'c'], [90,10,'c'], [30,60] ]);
-
-is_deeply([ $zinc->coords($curve) ],
- [ [10,20] ,[40,50,'c'], [90,10,'c'], [30,60] ],
- "coords of a curve is a list of arrays");
-
-is_deeply([ $zinc->coords($curve,0) ],
- [ [10,20] ,[40,50,'c'], [90,10,'c'], [30,60] ],
- "coords of contour 0 of a curve is a list of arrays");
-
-is_deeply([ $zinc->coords($curve,0,0) ],
- [ 10,20 ],
- "coords of first point of contour 0 of a curve is list of two numbers");
-
-is_deeply([ $zinc->coords($curve,0,1) ],
- [ 40,50,'c' ],
- "coords of a control point of a curve contour is list of three elements");
-
-my $text = $zinc->add('text', 1, -position => [10,20], -text => 'test');
-
-is_deeply([ $zinc->coords($text) ],
- [ 10,20 ],
- "coords of a text");
-
-is_deeply([ $zinc->coords($text,0) ],
- [ 10,20 ],
- "coords of text contour");
-
-is_deeply([ $zinc->coords($text,0,0) ],
- [ 10,20 ],
- "coords of text contour first point");
-
-
-my $group = $zinc->add('group', 1);
-
-is_deeply([ $zinc->coords($group) ],
- [ 0,0 ],
- "coords of a empty group, not moved");
-
-$zinc->translate($group, 23, 45);
-#my @coords = @{$zinc->coords($group)}[0];
-#print "coords = @coords", $coords[0][0], $coords[0][1], "\n";
-is_deeply([ $zinc->coords($group) ],
- [ 23,45 ],
- "coords of a empty group, translated");
-
-
-my $track = $zinc->add('track', 1, 0, -position => [56, 78]);
-is_deeply([ $zinc->coords($track) ],
- [ 56,78 ],
- "coords of a track");
-
-my $wpt = $zinc->add('waypoint', 1, 0, -position => [561, 781]);
-is_deeply([ $zinc->coords($wpt) ],
- [ 561,781 ],
- "coords of a waypoint");
-
-my $tab = $zinc->add('tabular', 1, 1, -position => [61, 81]);
-is_deeply([ $zinc->coords($tab) ],
- [ 61,81 ],
- "coords of a empty tabular");
-$zinc->itemconfigure($tab, -labelformat => 'x20x18+0+0');
-is_deeply([ $zinc->coords($tab) ],
- [ 61,81 ],
- "coords of a tabular with a labelformat");
-
-
-my $arc = $zinc->add('arc', 1, [13,31, 42,24]);
-is_deeply([ $zinc->coords($arc) ],
- [ [13,31], [42,24] ],
- "coords of an arc");
-
-my $tri = $zinc->add('triangles', 1, [ [10,20], [30,40], [50,60], [70,80], [90,99] ]);
-is_deeply([ $zinc->coords($tri) ],
- [ [10,20], [30,40], [50,60], [70,80], [90,99] ],
- "coords of an triangle");
-
-my $photoMickey = $zinc->Photo('mickey.gif', -file => Tk->findINC("demos/images/mickey.gif"));
-my $icon = $zinc->add('icon', 1, -position => [20,100], -image => $photoMickey);
-is_deeply([ $zinc->coords($icon) ],
- [ 20,100 ],
- "coords of an icon");
-
-diag("############## coords test");
-
-
diff --git a/Perl/t/Images.t b/Perl/t/Images.t
deleted file mode 100644
index 99111c5..0000000
--- a/Perl/t/Images.t
+++ /dev/null
@@ -1,212 +0,0 @@
-#!/usr/bin/perl -w
-
-#
-# $Id: Images.t,v 1.5 2004-05-12 12:33:33 mertz Exp $
-# Author: Christophe Mertz
-#
-
-# testing all the -tile, -image, -mask, -fillpattern, -linepattern widget and items options
-
-# this script can be used with an optionnal argument, an integer giving
-# the delay in seconds during which the graphic updates will be displayed
-# this is usefull for visual inspection!
-
-BEGIN {
- if (!eval q{
-# use Test::More qw(no_plan);
- use Test::More tests => 36;
- 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;
- 1;
- }) {
- print "unable to load Tk::Zinc";
- print "1..1\n";
- print "ok 1\n";
- exit;
- }
- if (!eval q{
- $mw = 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;
- }
-}
-
-
-$zinc = $mw->Zinc(-render => 0,
- -width => 400, -height => 400)->pack;
-
-like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created");
-
-#### creating different images, bitmaps and pixmaps...
-my $photoMickey = $zinc->Photo('mickey.gif', -file => Tk->findINC("demos/images/mickey.gif"));
-like ($photoMickey, qr/^Tk::Photo=HASH/ , "creating a Tk::Photo with a .gif");
-
-my $bitmap = $zinc->Bitmap('file.xbm', -file => Tk->findINC("file.xbm"));
-like ($bitmap, qr/^Tk::Bitmap=HASH/ , "creating a Tk::Bitmap with a .xbm");
-
-my $xpm = $zinc->Photo('QuitPB.xpm', -file => Tk->findINC("demos/images/QuitPB.xpm"));
-like ($xpm, qr/^Tk::Photo=HASH/ , "creating a Tk::Photo with a .xpm");
-
-#### tiling Tk::Zinc
-$zinc->configure(-tile => $xpm);
-if ($Tk::VERSION < 804) {
- is ($zinc->cget(-tile), "QuitPB.xpm", "verifying Tk::Zinc -tile option value");
-} else {
- is ($zinc->cget(-tile), $xpm, "verifying Tk::Zinc -tile option value");
-}
-
-&wait ("-tile of Tk::Zinc with QuitPB.xpm");
-
-$zinc->configure(-tile => $photoMickey);
-if ($Tk::VERSION < 804) {
- is ($zinc->cget(-tile), "mickey.gif", "verifying Tk::Zinc -tile option value");
-} else {
- is ($zinc->cget(-tile), $photoMickey, "verifying Tk::Zinc -tile option value");
-}
-&wait ("-tile of Tk::Zinc with mickey.gif");
-
-# modifying the Tk::Photo to see if the Tk::Zinc -tile changes
-$photoMickey->read( Tk->findINC("demos/images/earth.gif") );
-&wait ("-tile of Tk::Zinc should display the earth VISUAL INSPECTION!"); sleep 1;
-# going back to the "real" mickey
-$photoMickey->read( Tk->findINC("demos/images/mickey.gif") );
-&wait ("-tile of Tk::Zinc should display mickey again VISUAL INSPECTION!"); sleep 1;
-
-$zinc->configure(-tile => "");
-if ($Tk::VERSION < 804) {
- is ($zinc->cget(-tile), "", "removing Tk::Zinc -tile");
-} else {
- is ($zinc->cget(-tile), undef, "removing Tk::Zinc -tile");
-}
-&wait ("-tile of Tk::Zinc with nothing");
-
-
-
-#### rectangle item
-my $rect1 = $zinc->add('rectangle', 1, [10,10,190,190], -filled => 1);
-
-
-$zinc->itemconfigure($rect1, -tile => $xpm);
-is ($zinc->itemcget($rect1, -tile), "QuitPB.xpm", "verifying rectangle -tile option value");
-&wait ("-tile of rectangle with QuitPB.xpm");
-
-$zinc->itemconfigure($rect1, -tile => $photoMickey);
-is ($zinc->itemcget($rect1, -tile), "mickey.gif", "verifying rectangle -tile option value");
-&wait ("-tile of rectangle with mickey");
-
-# modifying the Tk::Photo to see if the rectangle -tile changes
-$photoMickey->read( Tk->findINC("demos/images/earth.gif") );
-&wait ("-tile of rectangle should display the earth VISUAL INSPECTION!"); sleep 1;
-# going back to the "real" mickey
-$photoMickey->read( Tk->findINC("demos/images/mickey.gif") );
-&wait ("-tile of rectangle should display mickey again VISUAL INSPECTION!"); sleep 1;
-
-
-$zinc->itemconfigure($rect1, -tile => "");
-is ($zinc->itemcget($rect1, -tile), "", "removing rectangle -tile");
-&wait ("-tile of rectangle with nothing");
-
-TODO: {
- local $TODO = "because it makes Tk::Zinc dying" if 1;
-
- # the next line makes Tk::Zinc (v3.29x) dying... so I comment it out the 3 next lines
- # $zinc->itemconfigure($rect1, -fillpattern => $bitmap);
- # is ($zinc->itemcget($rect1, -fillpattern), $bitmap, "verifying rectangle -fillpattern option value as a Tk::Bitmap");
- # &wait ("displaying a rectangle with -fillpattern as a Tk::Bitmap");
-}
-
-$zinc->itemconfigure($rect1, -fillpattern => 'AlphaStipple3');
-is ($zinc->itemcget($rect1, -fillpattern), 'AlphaStipple3', "verifying rectangle -fillpattern option value");
-&wait ("-fillpattern of rectangle with 'AlphaStipple3'");
-
-$zinc->itemconfigure($rect1, -fillpattern => "");
-is ($zinc->itemcget($rect1, -fillpattern), "", "removing rectangle -fillpattern");
-&wait ("-fillpattern of rectangle with nothing");
-
-
-$zinc->itemconfigure($rect1, -filled => 0,-linepattern => 'AlphaStipple3', -linecolor => "red");
-is ($zinc->itemcget($rect1, -linepattern), 'AlphaStipple3', "verifying rectangle -linepattern option value");
-&wait ("-linepattern of rectangle with 'AlphaStipple3'");
-
-$zinc->itemconfigure($rect1, -linepattern => "");
-is ($zinc->itemcget($rect1, -linepattern), "", "removing rectangle -linepattern");
-&wait ("-linepattern of rectangle with nothing");
-
-$zinc->remove($rect1);
-
-##### icon item
-my $icon1 = $zinc->add('icon', 1, -position => [20,100], -image => $photoMickey);
-&wait ("displaying an icon");
-
-$zinc->remove($icon1);
-
-my $icon2 = $zinc->add('icon', 1, -position => [40,100]);
-
-SKIP: {
- skip "with Tk::Zinc < 3.295", 4 if ($Tk::Zinc::VERSION < 3.295);
-
- $zinc->itemconfigure($icon2, -image => $bitmap);
-
- &wait ("displaying an icon with -image as a Tk::Bitmap");
- is ($zinc->itemcget($icon2, -image), 'file.xbm', "verifying icon -image option value as file.xbm");
- $zinc->itemconfigure($icon2, -image => "");
-
- $zinc->itemconfigure($icon2, -image => '@'.Tk->findINC("openfile.xbm"));
- is ($zinc->itemcget($icon2, -image), '@'.Tk->findINC("openfile.xbm"),"verifying icon -image option value as @/path/openfile.xbm");
- &wait ("displaying an icon with -image as a \@filename.xbm");
-}
-$zinc->remove($icon2);
-
-my $icon3 = $zinc->add('icon', 1, -position => [60,100], -mask => '@'.Tk->findINC("openfolder.xbm"),
- -color => "red");
-is ($zinc->itemcget($icon3, -mask), '@'.Tk->findINC("openfolder.xbm"),"verifying icon -mask option value as \@/path/openfolder.xbm");
-&wait ("displaying an icon with -mask as a \@filename.xbm");
-
-$zinc->itemconfigure($icon3, -image => "");
-is ($zinc->itemcget($icon3, -image), "", "removing icon -image");
-
-TODO: {
- local $TODO = "because it makes Tk::Zinc dying" if 1;
-
- # the next line makes Tk::Zinc (v3.29x) dying... so I comment it out the 3 next lines
- # $zinc->itemconfigure($icon3, -mask => $bitmap);
- # is ($zinc->itemcget($icon3, -mask), $bitmap, "verifying icon -mask option value as a Tk::Bitmap");
- # &wait ("displaying an icon with -mask as a Tk::Bitmap");
-}
-
-$zinc->remove($icon3);
-
-# We should also test that changing the content of a Tk::Photo should change the display of an icon
-
-
-
-sub wait {
- $zinc->update;
- ok (1, $_[0]);
-
- my $delay = $ARGV[0];
- if (defined $delay) {
- $zinc->update;
- if ($delay =~ /^\d+$/) {
- sleep $delay;
- } else {
- sleep 1;
- }
- }
-
-}
-
-
-
-diag("############## Images test");
diff --git a/Perl/t/Import.t b/Perl/t/Import.t
deleted file mode 100644
index a051e29..0000000
--- a/Perl/t/Import.t
+++ /dev/null
@@ -1,31 +0,0 @@
-#!/usr/bin/perl -w
-
-#
-# $Id: Import.t,v 1.2 2004-04-02 12:01:49 mertz Exp $
-# Author: Christophe Mertz
-#
-
-# testing all the import
-
-BEGIN {
- if (!eval q{
-# use Test::More qw(no_plan);
- use Test::More tests => 6;
- 1;
- }) {
- print "# tests only work properly with installed Test::More module\n";
- print "1..1\n";
- print "ok 1\n";
- exit;
- }
-}
-
-require_ok( 'Tk::Zinc' );
-require_ok( 'Tk::Zinc::Debug' );
-require_ok( 'Tk::Zinc::Trace' );
-# require_ok( 'Tk::Zinc::TraceErrors' ); # incompatible with the previous one
-# we do not test the previous, as it should be equivalent!
-require_ok( 'Tk::Zinc::Graphics' );
-require_ok( 'Tk::Zinc::Logo' );
-require_ok( 'Tk::Zinc::Text' );
-diag("############## all imports");
diff --git a/Perl/t/PreviousKnownBugs.t b/Perl/t/PreviousKnownBugs.t
deleted file mode 100644
index 934cdf7..0000000
--- a/Perl/t/PreviousKnownBugs.t
+++ /dev/null
@@ -1,61 +0,0 @@
-#!/usr/bin/perl -w
-
-#
-# $Id: PreviousKnownBugs.t,v 1.3 2004-04-02 12:01:49 mertz Exp $
-# Author: Christophe Mertz
-#
-
-# testing all the import
-
-BEGIN {
- if (!eval q{
-# use Test::More qw(no_plan);
- 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;
- 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;
- }
-}
-
-#use Tk::Zinc;
-
-$mw = MainWindow->new();
-$zinc = $mw->Zinc(-width => 100, -height => 100);
-
-like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created");
-
-# following bug detected by A. Lemort
-my $curve = $zinc->add('curve', 1, [[0, 0], [0, 100, 'c'], [100,100, 'c'], [100, 0]]) ;
-$zinc->coords($curve, [[500,0], [500, 100], [600, 100], [600, 0]]);
-
-my @coords = $zinc->coords($curve,0);
-
-
-is_deeply([ @coords ],
- [ [500,0], [500, 100], [600, 100], [600, 0] ],
- "lemort bug 17 sept 2003 v3.2.94; testing correct value");
-
-
-
-diag("############## all known bugs");
diff --git a/Perl/t/Test/Builder.pm b/Perl/t/Test/Builder.pm
deleted file mode 100644
index 6f3edd8..0000000
--- a/Perl/t/Test/Builder.pm
+++ /dev/null
@@ -1,1408 +0,0 @@
-package Test::Builder;
-
-use 5.004;
-
-# $^C was only introduced in 5.005-ish. We do this to prevent
-# use of uninitialized value warnings in older perls.
-$^C ||= 0;
-
-use strict;
-use vars qw($VERSION $CLASS);
-$VERSION = '0.17';
-$CLASS = __PACKAGE__;
-
-my $IsVMS = $^O eq 'VMS';
-
-# Make Test::Builder thread-safe for ithreads.
-BEGIN {
- use Config;
- if( $] >= 5.008 && $Config{useithreads} ) {
- require threads;
- require threads::shared;
- threads::shared->import;
- }
- else {
- *share = sub { 0 };
- *lock = sub { 0 };
- }
-}
-
-use vars qw($Level);
-my($Test_Died) = 0;
-my($Have_Plan) = 0;
-my $Original_Pid = $$;
-my $Curr_Test = 0; share($Curr_Test);
-my @Test_Results = (); share(@Test_Results);
-my @Test_Details = (); share(@Test_Details);
-
-
-=head1 NAME
-
-Test::Builder - Backend for building test libraries
-
-=head1 SYNOPSIS
-
- package My::Test::Module;
- use Test::Builder;
- require Exporter;
- @ISA = qw(Exporter);
- @EXPORT = qw(ok);
-
- my $Test = Test::Builder->new;
- $Test->output('my_logfile');
-
- sub import {
- my($self) = shift;
- my $pack = caller;
-
- $Test->exported_to($pack);
- $Test->plan(@_);
-
- $self->export_to_level(1, $self, 'ok');
- }
-
- sub ok {
- my($test, $name) = @_;
-
- $Test->ok($test, $name);
- }
-
-
-=head1 DESCRIPTION
-
-Test::Simple and Test::More have proven to be popular testing modules,
-but they're not always flexible enough. Test::Builder provides the a
-building block upon which to write your own test libraries I<which can
-work together>.
-
-=head2 Construction
-
-=over 4
-
-=item B<new>
-
- my $Test = Test::Builder->new;
-
-Returns a Test::Builder object representing the current state of the
-test.
-
-Since you only run one test per program, there is B<one and only one>
-Test::Builder object. No matter how many times you call new(), you're
-getting the same object. (This is called a singleton).
-
-=cut
-
-my $Test;
-sub new {
- my($class) = shift;
- $Test ||= bless ['Move along, nothing to see here'], $class;
- return $Test;
-}
-
-=back
-
-=head2 Setting up tests
-
-These methods are for setting up tests and declaring how many there
-are. You usually only want to call one of these methods.
-
-=over 4
-
-=item B<exported_to>
-
- my $pack = $Test->exported_to;
- $Test->exported_to($pack);
-
-Tells Test::Builder what package you exported your functions to.
-This is important for getting TODO tests right.
-
-=cut
-
-my $Exported_To;
-sub exported_to {
- my($self, $pack) = @_;
-
- if( defined $pack ) {
- $Exported_To = $pack;
- }
- return $Exported_To;
-}
-
-=item B<plan>
-
- $Test->plan('no_plan');
- $Test->plan( skip_all => $reason );
- $Test->plan( tests => $num_tests );
-
-A convenient way to set up your tests. Call this and Test::Builder
-will print the appropriate headers and take the appropriate actions.
-
-If you call plan(), don't call any of the other methods below.
-
-=cut
-
-sub plan {
- my($self, $cmd, $arg) = @_;
-
- return unless $cmd;
-
- if( $Have_Plan ) {
- die sprintf "You tried to plan twice! Second plan at %s line %d\n",
- ($self->caller)[1,2];
- }
-
- if( $cmd eq 'no_plan' ) {
- $self->no_plan;
- }
- elsif( $cmd eq 'skip_all' ) {
- return $self->skip_all($arg);
- }
- elsif( $cmd eq 'tests' ) {
- if( $arg ) {
- return $self->expected_tests($arg);
- }
- elsif( !defined $arg ) {
- die "Got an undefined number of tests. Looks like you tried to ".
- "say how many tests you plan to run but made a mistake.\n";
- }
- elsif( !$arg ) {
- die "You said to run 0 tests! You've got to run something.\n";
- }
- }
- else {
- require Carp;
- my @args = grep { defined } ($cmd, $arg);
- Carp::croak("plan() doesn't understand @args");
- }
-
- return 1;
-}
-
-=item B<expected_tests>
-
- my $max = $Test->expected_tests;
- $Test->expected_tests($max);
-
-Gets/sets the # of tests we expect this test to run and prints out
-the appropriate headers.
-
-=cut
-
-my $Expected_Tests = 0;
-sub expected_tests {
- my($self, $max) = @_;
-
- if( defined $max ) {
- $Expected_Tests = $max;
- $Have_Plan = 1;
-
- $self->_print("1..$max\n") unless $self->no_header;
- }
- return $Expected_Tests;
-}
-
-
-=item B<no_plan>
-
- $Test->no_plan;
-
-Declares that this test will run an indeterminate # of tests.
-
-=cut
-
-my($No_Plan) = 0;
-sub no_plan {
- $No_Plan = 1;
- $Have_Plan = 1;
-}
-
-=item B<has_plan>
-
- $plan = $Test->has_plan
-
-Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
-
-=cut
-
-sub has_plan {
- return($Expected_Tests) if $Expected_Tests;
- return('no_plan') if $No_Plan;
- return(undef);
-};
-
-
-=item B<skip_all>
-
- $Test->skip_all;
- $Test->skip_all($reason);
-
-Skips all the tests, using the given $reason. Exits immediately with 0.
-
-=cut
-
-my $Skip_All = 0;
-sub skip_all {
- my($self, $reason) = @_;
-
- my $out = "1..0";
- $out .= " # Skip $reason" if $reason;
- $out .= "\n";
-
- $Skip_All = 1;
-
- $self->_print($out) unless $self->no_header;
- exit(0);
-}
-
-=back
-
-=head2 Running tests
-
-These actually run the tests, analogous to the functions in
-Test::More.
-
-$name is always optional.
-
-=over 4
-
-=item B<ok>
-
- $Test->ok($test, $name);
-
-Your basic test. Pass if $test is true, fail if $test is false. Just
-like Test::Simple's ok().
-
-=cut
-
-sub ok {
- my($self, $test, $name) = @_;
-
- # $test might contain an object which we don't want to accidentally
- # store, so we turn it into a boolean.
- $test = $test ? 1 : 0;
-
- unless( $Have_Plan ) {
- require Carp;
- Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
- }
-
- lock $Curr_Test;
- $Curr_Test++;
-
- $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
- You named your test '$name'. You shouldn't use numbers for your test names.
- Very confusing.
-ERR
-
- my($pack, $file, $line) = $self->caller;
-
- my $todo = $self->todo($pack);
-
- my $out;
- my $result = {};
- share($result);
-
- unless( $test ) {
- $out .= "not ";
- @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
- }
- else {
- @$result{ 'ok', 'actual_ok' } = ( 1, $test );
- }
-
- $out .= "ok";
- $out .= " $Curr_Test" if $self->use_numbers;
-
- if( defined $name ) {
- $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
- $out .= " - $name";
- $result->{name} = $name;
- }
- else {
- $result->{name} = '';
- }
-
- if( $todo ) {
- my $what_todo = $todo;
- $out .= " # TODO $what_todo";
- $result->{reason} = $what_todo;
- $result->{type} = 'todo';
- }
- else {
- $result->{reason} = '';
- $result->{type} = '';
- }
-
- $Test_Results[$Curr_Test-1] = $result;
- $out .= "\n";
-
- $self->_print($out);
-
- unless( $test ) {
- my $msg = $todo ? "Failed (TODO)" : "Failed";
- $self->diag(" $msg test ($file at line $line)\n");
- }
-
- return $test ? 1 : 0;
-}
-
-=item B<is_eq>
-
- $Test->is_eq($got, $expected, $name);
-
-Like Test::More's is(). Checks if $got eq $expected. This is the
-string version.
-
-=item B<is_num>
-
- $Test->is_num($got, $expected, $name);
-
-Like Test::More's is(). Checks if $got == $expected. This is the
-numeric version.
-
-=cut
-
-sub is_eq {
- my($self, $got, $expect, $name) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $expect ) {
- # undef only matches undef and nothing else
- my $test = !defined $got && !defined $expect;
-
- $self->ok($test, $name);
- $self->_is_diag($got, 'eq', $expect) unless $test;
- return $test;
- }
-
- return $self->cmp_ok($got, 'eq', $expect, $name);
-}
-
-sub is_num {
- my($self, $got, $expect, $name) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $expect ) {
- # undef only matches undef and nothing else
- my $test = !defined $got && !defined $expect;
-
- $self->ok($test, $name);
- $self->_is_diag($got, '==', $expect) unless $test;
- return $test;
- }
-
- return $self->cmp_ok($got, '==', $expect, $name);
-}
-
-sub _is_diag {
- my($self, $got, $type, $expect) = @_;
-
- foreach my $val (\$got, \$expect) {
- if( defined $$val ) {
- if( $type eq 'eq' ) {
- # quote and force string context
- $$val = "'$$val'"
- }
- else {
- # force numeric context
- $$val = $$val+0;
- }
- }
- else {
- $$val = 'undef';
- }
- }
-
- return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
- got: %s
- expected: %s
-DIAGNOSTIC
-
-}
-
-=item B<isnt_eq>
-
- $Test->isnt_eq($got, $dont_expect, $name);
-
-Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
-the string version.
-
-=item B<isnt_num>
-
- $Test->is_num($got, $dont_expect, $name);
-
-Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
-the numeric version.
-
-=cut
-
-sub isnt_eq {
- my($self, $got, $dont_expect, $name) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $dont_expect ) {
- # undef only matches undef and nothing else
- my $test = defined $got || defined $dont_expect;
-
- $self->ok($test, $name);
- $self->_cmp_diag('ne', $got, $dont_expect) unless $test;
- return $test;
- }
-
- return $self->cmp_ok($got, 'ne', $dont_expect, $name);
-}
-
-sub isnt_num {
- my($self, $got, $dont_expect, $name) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $dont_expect ) {
- # undef only matches undef and nothing else
- my $test = defined $got || defined $dont_expect;
-
- $self->ok($test, $name);
- $self->_cmp_diag('!=', $got, $dont_expect) unless $test;
- return $test;
- }
-
- return $self->cmp_ok($got, '!=', $dont_expect, $name);
-}
-
-
-=item B<like>
-
- $Test->like($this, qr/$regex/, $name);
- $Test->like($this, '/$regex/', $name);
-
-Like Test::More's like(). Checks if $this matches the given $regex.
-
-You'll want to avoid qr// if you want your tests to work before 5.005.
-
-=item B<unlike>
-
- $Test->unlike($this, qr/$regex/, $name);
- $Test->unlike($this, '/$regex/', $name);
-
-Like Test::More's unlike(). Checks if $this B<does not match> the
-given $regex.
-
-=cut
-
-sub like {
- my($self, $this, $regex, $name) = @_;
-
- local $Level = $Level + 1;
- $self->_regex_ok($this, $regex, '=~', $name);
-}
-
-sub unlike {
- my($self, $this, $regex, $name) = @_;
-
- local $Level = $Level + 1;
- $self->_regex_ok($this, $regex, '!~', $name);
-}
-
-=item B<maybe_regex>
-
- $Test->maybe_regex(qr/$regex/);
- $Test->maybe_regex('/$regex/');
-
-Convenience method for building testing functions that take regular
-expressions as arguments, but need to work before perl 5.005.
-
-Takes a quoted regular expression produced by qr//, or a string
-representing a regular expression.
-
-Returns a Perl value which may be used instead of the corresponding
-regular expression, or undef if it's argument is not recognised.
-
-For example, a version of like(), sans the useful diagnostic messages,
-could be written as:
-
- sub laconic_like {
- my ($self, $this, $regex, $name) = @_;
- my $usable_regex = $self->maybe_regex($regex);
- die "expecting regex, found '$regex'\n"
- unless $usable_regex;
- $self->ok($this =~ m/$usable_regex/, $name);
- }
-
-=cut
-
-
-sub maybe_regex {
- my ($self, $regex) = @_;
- my $usable_regex = undef;
- if( ref $regex eq 'Regexp' ) {
- $usable_regex = $regex;
- }
- # Check if it looks like '/foo/'
- elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
- $usable_regex = length $opts ? "(?$opts)$re" : $re;
- };
- return($usable_regex)
-};
-
-sub _regex_ok {
- my($self, $this, $regex, $cmp, $name) = @_;
-
- local $Level = $Level + 1;
-
- my $ok = 0;
- my $usable_regex = $self->maybe_regex($regex);
- unless (defined $usable_regex) {
- $ok = $self->ok( 0, $name );
- $self->diag(" '$regex' doesn't look much like a regex to me.");
- return $ok;
- }
-
- {
- local $^W = 0;
- my $test = $this =~ /$usable_regex/ ? 1 : 0;
- $test = !$test if $cmp eq '!~';
- $ok = $self->ok( $test, $name );
- }
-
- unless( $ok ) {
- $this = defined $this ? "'$this'" : 'undef';
- my $match = $cmp eq '=~' ? "doesn't match" : "matches";
- $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
- %s
- %13s '%s'
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-=item B<cmp_ok>
-
- $Test->cmp_ok($this, $type, $that, $name);
-
-Works just like Test::More's cmp_ok().
-
- $Test->cmp_ok($big_num, '!=', $other_big_num);
-
-=cut
-
-sub cmp_ok {
- my($self, $got, $type, $expect, $name) = @_;
-
- my $test;
- {
- local $^W = 0;
- local($@,$!); # don't interfere with $@
- # eval() sometimes resets $!
- $test = eval "\$got $type \$expect";
- }
- local $Level = $Level + 1;
- my $ok = $self->ok($test, $name);
-
- unless( $ok ) {
- if( $type =~ /^(eq|==)$/ ) {
- $self->_is_diag($got, $type, $expect);
- }
- else {
- $self->_cmp_diag($got, $type, $expect);
- }
- }
- return $ok;
-}
-
-sub _cmp_diag {
- my($self, $got, $type, $expect) = @_;
-
- $got = defined $got ? "'$got'" : 'undef';
- $expect = defined $expect ? "'$expect'" : 'undef';
- return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
- %s
- %s
- %s
-DIAGNOSTIC
-}
-
-=item B<BAILOUT>
-
- $Test->BAILOUT($reason);
-
-Indicates to the Test::Harness that things are going so badly all
-testing should terminate. This includes running any additional test
-scripts.
-
-It will exit with 255.
-
-=cut
-
-sub BAILOUT {
- my($self, $reason) = @_;
-
- $self->_print("Bail out! $reason");
- exit 255;
-}
-
-=item B<skip>
-
- $Test->skip;
- $Test->skip($why);
-
-Skips the current test, reporting $why.
-
-=cut
-
-sub skip {
- my($self, $why) = @_;
- $why ||= '';
-
- unless( $Have_Plan ) {
- require Carp;
- Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
- }
-
- lock($Curr_Test);
- $Curr_Test++;
-
- my %result;
- share(%result);
- %result = (
- 'ok' => 1,
- actual_ok => 1,
- name => '',
- type => 'skip',
- reason => $why,
- );
- $Test_Results[$Curr_Test-1] = \%result;
-
- my $out = "ok";
- $out .= " $Curr_Test" if $self->use_numbers;
- $out .= " # skip $why\n";
-
- $Test->_print($out);
-
- return 1;
-}
-
-
-=item B<todo_skip>
-
- $Test->todo_skip;
- $Test->todo_skip($why);
-
-Like skip(), only it will declare the test as failing and TODO. Similar
-to
-
- print "not ok $tnum # TODO $why\n";
-
-=cut
-
-sub todo_skip {
- my($self, $why) = @_;
- $why ||= '';
-
- unless( $Have_Plan ) {
- require Carp;
- Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
- }
-
- lock($Curr_Test);
- $Curr_Test++;
-
- my %result;
- share(%result);
- %result = (
- 'ok' => 1,
- actual_ok => 0,
- name => '',
- type => 'todo_skip',
- reason => $why,
- );
-
- $Test_Results[$Curr_Test-1] = \%result;
-
- my $out = "not ok";
- $out .= " $Curr_Test" if $self->use_numbers;
- $out .= " # TODO & SKIP $why\n";
-
- $Test->_print($out);
-
- return 1;
-}
-
-
-=begin _unimplemented
-
-=item B<skip_rest>
-
- $Test->skip_rest;
- $Test->skip_rest($reason);
-
-Like skip(), only it skips all the rest of the tests you plan to run
-and terminates the test.
-
-If you're running under no_plan, it skips once and terminates the
-test.
-
-=end _unimplemented
-
-=back
-
-
-=head2 Test style
-
-=over 4
-
-=item B<level>
-
- $Test->level($how_high);
-
-How far up the call stack should $Test look when reporting where the
-test failed.
-
-Defaults to 1.
-
-Setting $Test::Builder::Level overrides. This is typically useful
-localized:
-
- {
- local $Test::Builder::Level = 2;
- $Test->ok($test);
- }
-
-=cut
-
-sub level {
- my($self, $level) = @_;
-
- if( defined $level ) {
- $Level = $level;
- }
- return $Level;
-}
-
-$CLASS->level(1);
-
-
-=item B<use_numbers>
-
- $Test->use_numbers($on_or_off);
-
-Whether or not the test should output numbers. That is, this if true:
-
- ok 1
- ok 2
- ok 3
-
-or this if false
-
- ok
- ok
- ok
-
-Most useful when you can't depend on the test output order, such as
-when threads or forking is involved.
-
-Test::Harness will accept either, but avoid mixing the two styles.
-
-Defaults to on.
-
-=cut
-
-my $Use_Nums = 1;
-sub use_numbers {
- my($self, $use_nums) = @_;
-
- if( defined $use_nums ) {
- $Use_Nums = $use_nums;
- }
- return $Use_Nums;
-}
-
-=item B<no_header>
-
- $Test->no_header($no_header);
-
-If set to true, no "1..N" header will be printed.
-
-=item B<no_ending>
-
- $Test->no_ending($no_ending);
-
-Normally, Test::Builder does some extra diagnostics when the test
-ends. It also changes the exit code as described in Test::Simple.
-
-If this is true, none of that will be done.
-
-=cut
-
-my($No_Header, $No_Ending) = (0,0);
-sub no_header {
- my($self, $no_header) = @_;
-
- if( defined $no_header ) {
- $No_Header = $no_header;
- }
- return $No_Header;
-}
-
-sub no_ending {
- my($self, $no_ending) = @_;
-
- if( defined $no_ending ) {
- $No_Ending = $no_ending;
- }
- return $No_Ending;
-}
-
-
-=back
-
-=head2 Output
-
-Controlling where the test output goes.
-
-It's ok for your test to change where STDOUT and STDERR point to,
-Test::Builder's default output settings will not be affected.
-
-=over 4
-
-=item B<diag>
-
- $Test->diag(@msgs);
-
-Prints out the given $message. Normally, it uses the failure_output()
-handle, but if this is for a TODO test, the todo_output() handle is
-used.
-
-Output will be indented and marked with a # so as not to interfere
-with test output. A newline will be put on the end if there isn't one
-already.
-
-We encourage using this rather than calling print directly.
-
-Returns false. Why? Because diag() is often used in conjunction with
-a failing test (C<ok() || diag()>) it "passes through" the failure.
-
- return ok(...) || diag(...);
-
-=for blame transfer
-Mark Fowler <mark@twoshortplanks.com>
-
-=cut
-
-sub diag {
- my($self, @msgs) = @_;
- return unless @msgs;
-
- # Prevent printing headers when compiling (i.e. -c)
- return if $^C;
-
- # Escape each line with a #.
- foreach (@msgs) {
- $_ = 'undef' unless defined;
- s/^/# /gms;
- }
-
- push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
-
- local $Level = $Level + 1;
- my $fh = $self->todo ? $self->todo_output : $self->failure_output;
- local($\, $", $,) = (undef, ' ', '');
- print $fh @msgs;
-
- return 0;
-}
-
-=begin _private
-
-=item B<_print>
-
- $Test->_print(@msgs);
-
-Prints to the output() filehandle.
-
-=end _private
-
-=cut
-
-sub _print {
- my($self, @msgs) = @_;
-
- # Prevent printing headers when only compiling. Mostly for when
- # tests are deparsed with B::Deparse
- return if $^C;
-
- local($\, $", $,) = (undef, ' ', '');
- my $fh = $self->output;
-
- # Escape each line after the first with a # so we don't
- # confuse Test::Harness.
- foreach (@msgs) {
- s/\n(.)/\n# $1/sg;
- }
-
- push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
-
- print $fh @msgs;
-}
-
-
-=item B<output>
-
- $Test->output($fh);
- $Test->output($file);
-
-Where normal "ok/not ok" test output should go.
-
-Defaults to STDOUT.
-
-=item B<failure_output>
-
- $Test->failure_output($fh);
- $Test->failure_output($file);
-
-Where diagnostic output on test failures and diag() should go.
-
-Defaults to STDERR.
-
-=item B<todo_output>
-
- $Test->todo_output($fh);
- $Test->todo_output($file);
-
-Where diagnostics about todo test failures and diag() should go.
-
-Defaults to STDOUT.
-
-=cut
-
-my($Out_FH, $Fail_FH, $Todo_FH);
-sub output {
- my($self, $fh) = @_;
-
- if( defined $fh ) {
- $Out_FH = _new_fh($fh);
- }
- return $Out_FH;
-}
-
-sub failure_output {
- my($self, $fh) = @_;
-
- if( defined $fh ) {
- $Fail_FH = _new_fh($fh);
- }
- return $Fail_FH;
-}
-
-sub todo_output {
- my($self, $fh) = @_;
-
- if( defined $fh ) {
- $Todo_FH = _new_fh($fh);
- }
- return $Todo_FH;
-}
-
-sub _new_fh {
- my($file_or_fh) = shift;
-
- my $fh;
- unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
- $fh = do { local *FH };
- open $fh, ">$file_or_fh" or
- die "Can't open test output log $file_or_fh: $!";
- }
- else {
- $fh = $file_or_fh;
- }
-
- return $fh;
-}
-
-unless( $^C ) {
- # We dup STDOUT and STDERR so people can change them in their
- # test suites while still getting normal test output.
- open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
- open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
-
- # Set everything to unbuffered else plain prints to STDOUT will
- # come out in the wrong order from our own prints.
- _autoflush(\*TESTOUT);
- _autoflush(\*STDOUT);
- _autoflush(\*TESTERR);
- _autoflush(\*STDERR);
-
- $CLASS->output(\*TESTOUT);
- $CLASS->failure_output(\*TESTERR);
- $CLASS->todo_output(\*TESTOUT);
-}
-
-sub _autoflush {
- my($fh) = shift;
- my $old_fh = select $fh;
- $| = 1;
- select $old_fh;
-}
-
-
-=back
-
-
-=head2 Test Status and Info
-
-=over 4
-
-=item B<current_test>
-
- my $curr_test = $Test->current_test;
- $Test->current_test($num);
-
-Gets/sets the current test # we're on.
-
-You usually shouldn't have to set this.
-
-=cut
-
-sub current_test {
- my($self, $num) = @_;
-
- lock($Curr_Test);
- if( defined $num ) {
- unless( $Have_Plan ) {
- require Carp;
- Carp::croak("Can't change the current test number without a plan!");
- }
-
- $Curr_Test = $num;
- if( $num > @Test_Results ) {
- my $start = @Test_Results ? $#Test_Results + 1 : 0;
- for ($start..$num-1) {
- my %result;
- share(%result);
- %result = ( ok => 1,
- actual_ok => undef,
- reason => 'incrementing test number',
- type => 'unknown',
- name => undef
- );
- $Test_Results[$_] = \%result;
- }
- }
- }
- return $Curr_Test;
-}
-
-
-=item B<summary>
-
- my @tests = $Test->summary;
-
-A simple summary of the tests so far. True for pass, false for fail.
-This is a logical pass/fail, so todos are passes.
-
-Of course, test #1 is $tests[0], etc...
-
-=cut
-
-sub summary {
- my($self) = shift;
-
- return map { $_->{'ok'} } @Test_Results;
-}
-
-=item B<details>
-
- my @tests = $Test->details;
-
-Like summary(), but with a lot more detail.
-
- $tests[$test_num - 1] =
- { 'ok' => is the test considered a pass?
- actual_ok => did it literally say 'ok'?
- name => name of the test (if any)
- type => type of test (if any, see below).
- reason => reason for the above (if any)
- };
-
-'ok' is true if Test::Harness will consider the test to be a pass.
-
-'actual_ok' is a reflection of whether or not the test literally
-printed 'ok' or 'not ok'. This is for examining the result of 'todo'
-tests.
-
-'name' is the name of the test.
-
-'type' indicates if it was a special test. Normal tests have a type
-of ''. Type can be one of the following:
-
- skip see skip()
- todo see todo()
- todo_skip see todo_skip()
- unknown see below
-
-Sometimes the Test::Builder test counter is incremented without it
-printing any test output, for example, when current_test() is changed.
-In these cases, Test::Builder doesn't know the result of the test, so
-it's type is 'unkown'. These details for these tests are filled in.
-They are considered ok, but the name and actual_ok is left undef.
-
-For example "not ok 23 - hole count # TODO insufficient donuts" would
-result in this structure:
-
- $tests[22] = # 23 - 1, since arrays start from 0.
- { ok => 1, # logically, the test passed since it's todo
- actual_ok => 0, # in absolute terms, it failed
- name => 'hole count',
- type => 'todo',
- reason => 'insufficient donuts'
- };
-
-=cut
-
-sub details {
- return @Test_Results;
-}
-
-=item B<todo>
-
- my $todo_reason = $Test->todo;
- my $todo_reason = $Test->todo($pack);
-
-todo() looks for a $TODO variable in your tests. If set, all tests
-will be considered 'todo' (see Test::More and Test::Harness for
-details). Returns the reason (ie. the value of $TODO) if running as
-todo tests, false otherwise.
-
-todo() is pretty part about finding the right package to look for
-$TODO in. It uses the exported_to() package to find it. If that's
-not set, it's pretty good at guessing the right package to look at.
-
-Sometimes there is some confusion about where todo() should be looking
-for the $TODO variable. If you want to be sure, tell it explicitly
-what $pack to use.
-
-=cut
-
-sub todo {
- my($self, $pack) = @_;
-
- $pack = $pack || $self->exported_to || $self->caller(1);
-
- no strict 'refs';
- return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
- : 0;
-}
-
-=item B<caller>
-
- my $package = $Test->caller;
- my($pack, $file, $line) = $Test->caller;
- my($pack, $file, $line) = $Test->caller($height);
-
-Like the normal caller(), except it reports according to your level().
-
-=cut
-
-sub caller {
- my($self, $height) = @_;
- $height ||= 0;
-
- my @caller = CORE::caller($self->level + $height + 1);
- return wantarray ? @caller : $caller[0];
-}
-
-=back
-
-=cut
-
-=begin _private
-
-=over 4
-
-=item B<_sanity_check>
-
- _sanity_check();
-
-Runs a bunch of end of test sanity checks to make sure reality came
-through ok. If anything is wrong it will die with a fairly friendly
-error message.
-
-=cut
-
-#'#
-sub _sanity_check {
- _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!');
- _whoa(!$Have_Plan and $Curr_Test,
- 'Somehow your tests ran without a plan!');
- _whoa($Curr_Test != @Test_Results,
- 'Somehow you got a different number of results than tests ran!');
-}
-
-=item B<_whoa>
-
- _whoa($check, $description);
-
-A sanity check, similar to assert(). If the $check is true, something
-has gone horribly wrong. It will die with the given $description and
-a note to contact the author.
-
-=cut
-
-sub _whoa {
- my($check, $desc) = @_;
- if( $check ) {
- die <<WHOA;
-WHOA! $desc
-This should never happen! Please contact the author immediately!
-WHOA
- }
-}
-
-=item B<_my_exit>
-
- _my_exit($exit_num);
-
-Perl seems to have some trouble with exiting inside an END block. 5.005_03
-and 5.6.1 both seem to do odd things. Instead, this function edits $?
-directly. It should ONLY be called from inside an END block. It
-doesn't actually exit, that's your job.
-
-=cut
-
-sub _my_exit {
- $? = $_[0];
-
- return 1;
-}
-
-
-=back
-
-=end _private
-
-=cut
-
-$SIG{__DIE__} = sub {
- # We don't want to muck with death in an eval, but $^S isn't
- # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
- # with it. Instead, we use caller. This also means it runs under
- # 5.004!
- my $in_eval = 0;
- for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
- $in_eval = 1 if $sub =~ /^\(eval\)/;
- }
- $Test_Died = 1 unless $in_eval;
-};
-
-sub _ending {
- my $self = shift;
-
- _sanity_check();
-
- # Don't bother with an ending if this is a forked copy. Only the parent
- # should do the ending.
- do{ _my_exit($?) && return } if $Original_Pid != $$;
-
- # Bailout if plan() was never called. This is so
- # "require Test::Simple" doesn't puke.
- do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died;
-
- # Figure out if we passed or failed and print helpful messages.
- if( @Test_Results ) {
- # The plan? We have no plan.
- if( $No_Plan ) {
- $self->_print("1..$Curr_Test\n") unless $self->no_header;
- $Expected_Tests = $Curr_Test;
- }
-
- # 5.8.0 threads bug. Shared arrays will not be auto-extended
- # by a slice. Worse, we have to fill in every entry else
- # we'll get an "Invalid value for shared scalar" error
- for my $idx ($#Test_Results..$Expected_Tests-1) {
- my %empty_result = ();
- share(%empty_result);
- $Test_Results[$idx] = \%empty_result
- unless defined $Test_Results[$idx];
- }
-
- my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1];
- $num_failed += abs($Expected_Tests - @Test_Results);
-
- if( $Curr_Test < $Expected_Tests ) {
- $self->diag(<<"FAIL");
-Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
-FAIL
- }
- elsif( $Curr_Test > $Expected_Tests ) {
- my $num_extra = $Curr_Test - $Expected_Tests;
- $self->diag(<<"FAIL");
-Looks like you planned $Expected_Tests tests but ran $num_extra extra.
-FAIL
- }
- elsif ( $num_failed ) {
- $self->diag(<<"FAIL");
-Looks like you failed $num_failed tests of $Expected_Tests.
-FAIL
- }
-
- if( $Test_Died ) {
- $self->diag(<<"FAIL");
-Looks like your test died just after $Curr_Test.
-FAIL
-
- _my_exit( 255 ) && return;
- }
-
- _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return;
- }
- elsif ( $Skip_All ) {
- _my_exit( 0 ) && return;
- }
- elsif ( $Test_Died ) {
- $self->diag(<<'FAIL');
-Looks like your test died before it could output anything.
-FAIL
- }
- else {
- $self->diag("No tests run!\n");
- _my_exit( 255 ) && return;
- }
-}
-
-END {
- $Test->_ending if defined $Test and !$Test->no_ending;
-}
-
-=head1 THREADS
-
-In perl 5.8.0 and later, Test::Builder is thread-safe. The test
-number is shared amongst all threads. This means if one thread sets
-the test number using current_test() they will all be effected.
-
-=head1 EXAMPLES
-
-CPAN can provide the best examples. Test::Simple, Test::More,
-Test::Exception and Test::Differences all use Test::Builder.
-
-=head1 SEE ALSO
-
-Test::Simple, Test::More, Test::Harness
-
-=head1 AUTHORS
-
-Original code by chromatic, maintained by Michael G Schwern
-E<lt>schwern@pobox.comE<gt>
-
-=head1 COPYRIGHT
-
-Copyright 2002 by chromatic E<lt>chromatic@wgz.orgE<gt>,
- Michael G Schwern E<lt>schwern@pobox.comE<gt>.
-
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-See F<http://www.perl.com/perl/misc/Artistic.html>
-
-=cut
-
-1;
diff --git a/Perl/t/Test/Harness.pm b/Perl/t/Test/Harness.pm
deleted file mode 100644
index 0897455..0000000
--- a/Perl/t/Test/Harness.pm
+++ /dev/null
@@ -1,1168 +0,0 @@
-# -*- Mode: cperl; cperl-indent-level: 4 -*-
-# $Id$
-
-package Test::Harness;
-
-require 5.004;
-use Test::Harness::Straps;
-use Test::Harness::Assert;
-use Exporter;
-use Benchmark;
-use Config;
-use strict;
-
-use vars qw($VERSION $Verbose $Switches $Have_Devel_Corestack $Curtest
- $Columns $verbose $switches $ML $Strap
- @ISA @EXPORT @EXPORT_OK $Last_ML_Print
- );
-
-# Backwards compatibility for exportable variable names.
-*verbose = *Verbose;
-*switches = *Switches;
-
-$Have_Devel_Corestack = 0;
-
-$VERSION = '2.30';
-
-$ENV{HARNESS_ACTIVE} = 1;
-
-END {
- # For VMS.
- delete $ENV{HARNESS_ACTIVE};
-}
-
-# Some experimental versions of OS/2 build have broken $?
-my $Ignore_Exitcode = $ENV{HARNESS_IGNORE_EXITCODE};
-
-my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR};
-
-my $Ok_Slow = $ENV{HARNESS_OK_SLOW};
-
-$Strap = Test::Harness::Straps->new;
-
-@ISA = ('Exporter');
-@EXPORT = qw(&runtests);
-@EXPORT_OK = qw($verbose $switches);
-
-$Verbose = $ENV{HARNESS_VERBOSE} || 0;
-$Switches = "-w";
-$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
-$Columns--; # Some shells have trouble with a full line of text.
-
-
-=head1 NAME
-
-Test::Harness - run perl standard test scripts with statistics
-
-=head1 SYNOPSIS
-
- use Test::Harness;
-
- runtests(@test_files);
-
-=head1 DESCRIPTION
-
-B<STOP!> If all you want to do is write a test script, consider using
-Test::Simple. Otherwise, read on.
-
-(By using the Test module, you can write test scripts without
-knowing the exact output this module expects. However, if you need to
-know the specifics, read on!)
-
-Perl test scripts print to standard output C<"ok N"> for each single
-test, where C<N> is an increasing sequence of integers. The first line
-output by a standard test script is C<"1..M"> with C<M> being the
-number of tests that should be run within the test
-script. Test::Harness::runtests(@tests) runs all the testscripts
-named as arguments and checks standard output for the expected
-C<"ok N"> strings.
-
-After all tests have been performed, runtests() prints some
-performance statistics that are computed by the Benchmark module.
-
-=head2 The test script output
-
-The following explains how Test::Harness interprets the output of your
-test program.
-
-=over 4
-
-=item B<'1..M'>
-
-This header tells how many tests there will be. For example, C<1..10>
-means you plan on running 10 tests. This is a safeguard in case your
-test dies quietly in the middle of its run.
-
-It should be the first non-comment line output by your test program.
-
-In certain instances, you may not know how many tests you will
-ultimately be running. In this case, it is permitted for the 1..M
-header to appear as the B<last> line output by your test (again, it
-can be followed by further comments).
-
-Under B<no> circumstances should 1..M appear in the middle of your
-output or more than once.
-
-
-=item B<'ok', 'not ok'. Ok?>
-
-Any output from the testscript to standard error is ignored and
-bypassed, thus will be seen by the user. Lines written to standard
-output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
-runtests(). All other lines are discarded.
-
-C</^not ok/> indicates a failed test. C</^ok/> is a successful test.
-
-
-=item B<test numbers>
-
-Perl normally expects the 'ok' or 'not ok' to be followed by a test
-number. It is tolerated if the test numbers after 'ok' are
-omitted. In this case Test::Harness maintains temporarily its own
-counter until the script supplies test numbers again. So the following
-test script
-
- print <<END;
- 1..6
- not ok
- ok
- not ok
- ok
- ok
- END
-
-will generate
-
- FAILED tests 1, 3, 6
- Failed 3/6 tests, 50.00% okay
-
-=item B<test names>
-
-Anything after the test number but before the # is considered to be
-the name of the test.
-
- ok 42 this is the name of the test
-
-Currently, Test::Harness does nothing with this information.
-
-=item B<Skipping tests>
-
-If the standard output line contains the substring C< # Skip> (with
-variations in spacing and case) after C<ok> or C<ok NUMBER>, it is
-counted as a skipped test. If the whole testscript succeeds, the
-count of skipped tests is included in the generated output.
-C<Test::Harness> reports the text after C< # Skip\S*\s+> as a reason
-for skipping.
-
- ok 23 # skip Insufficient flogiston pressure.
-
-Similarly, one can include a similar explanation in a C<1..0> line
-emitted if the test script is skipped completely:
-
- 1..0 # Skipped: no leverage found
-
-=item B<Todo tests>
-
-If the standard output line contains the substring C< # TODO> after
-C<not ok> or C<not ok NUMBER>, it is counted as a todo test. The text
-afterwards is the thing that has to be done before this test will
-succeed.
-
- not ok 13 # TODO harness the power of the atom
-
-=begin _deprecated
-
-Alternatively, you can specify a list of what tests are todo as part
-of the test header.
-
- 1..23 todo 5 12 23
-
-This only works if the header appears at the beginning of the test.
-
-This style is B<deprecated>.
-
-=end _deprecated
-
-These tests represent a feature to be implemented or a bug to be fixed
-and act as something of an executable "thing to do" list. They are
-B<not> expected to succeed. Should a todo test begin succeeding,
-Test::Harness will report it as a bonus. This indicates that whatever
-you were supposed to do has been done and you should promote this to a
-normal test.
-
-=item B<Bail out!>
-
-As an emergency measure, a test script can decide that further tests
-are useless (e.g. missing dependencies) and testing should stop
-immediately. In that case the test script prints the magic words
-
- Bail out!
-
-to standard output. Any message after these words will be displayed by
-C<Test::Harness> as the reason why testing is stopped.
-
-=item B<Comments>
-
-Additional comments may be put into the testing output on their own
-lines. Comment lines should begin with a '#', Test::Harness will
-ignore them.
-
- ok 1
- # Life is good, the sun is shining, RAM is cheap.
- not ok 2
- # got 'Bush' expected 'Gore'
-
-=item B<Anything else>
-
-Any other output Test::Harness sees it will silently ignore B<BUT WE
-PLAN TO CHANGE THIS!> If you wish to place additional output in your
-test script, please use a comment.
-
-=back
-
-
-=head2 Taint mode
-
-Test::Harness will honor the C<-T> in the #! line on your test files. So
-if you begin a test with:
-
- #!perl -T
-
-the test will be run with taint mode on.
-
-
-=head2 Configuration variables.
-
-These variables can be used to configure the behavior of
-Test::Harness. They are exported on request.
-
-=over 4
-
-=item B<$Test::Harness::verbose>
-
-The global variable $Test::Harness::verbose is exportable and can be
-used to let runtests() display the standard output of the script
-without altering the behavior otherwise.
-
-=item B<$Test::Harness::switches>
-
-The global variable $Test::Harness::switches is exportable and can be
-used to set perl command line options used for running the test
-script(s). The default value is C<-w>.
-
-=back
-
-
-=head2 Failure
-
-It will happen, your tests will fail. After you mop up your ego, you
-can begin examining the summary report:
-
- t/base..............ok
- t/nonumbers.........ok
- t/ok................ok
- t/test-harness......ok
- t/waterloo..........dubious
- Test returned status 3 (wstat 768, 0x300)
- DIED. FAILED tests 1, 3, 5, 7, 9, 11, 13, 15, 17, 19
- Failed 10/20 tests, 50.00% okay
- Failed Test Stat Wstat Total Fail Failed List of Failed
- -----------------------------------------------------------------------
- t/waterloo.t 3 768 20 10 50.00% 1 3 5 7 9 11 13 15 17 19
- Failed 1/5 test scripts, 80.00% okay. 10/44 subtests failed, 77.27% okay.
-
-Everything passed but t/waterloo.t. It failed 10 of 20 tests and
-exited with non-zero status indicating something dubious happened.
-
-The columns in the summary report mean:
-
-=over 4
-
-=item B<Failed Test>
-
-The test file which failed.
-
-=item B<Stat>
-
-If the test exited with non-zero, this is its exit status.
-
-=item B<Wstat>
-
-The wait status of the test I<umm, I need a better explanation here>.
-
-=item B<Total>
-
-Total number of tests expected to run.
-
-=item B<Fail>
-
-Number which failed, either from "not ok" or because they never ran.
-
-=item B<Failed>
-
-Percentage of the total tests which failed.
-
-=item B<List of Failed>
-
-A list of the tests which failed. Successive failures may be
-abbreviated (ie. 15-20 to indicate that tests 15, 16, 17, 18, 19 and
-20 failed).
-
-=back
-
-
-=head2 Functions
-
-Test::Harness currently only has one function, here it is.
-
-=over 4
-
-=item B<runtests>
-
- my $allok = runtests(@test_files);
-
-This runs all the given @test_files and divines whether they passed
-or failed based on their output to STDOUT (details above). It prints
-out each individual test which failed along with a summary report and
-a how long it all took.
-
-It returns true if everything was ok. Otherwise it will die() with
-one of the messages in the DIAGNOSTICS section.
-
-=for _private
-
-This is just _run_all_tests() plus _show_results()
-
-=cut
-
-sub runtests {
- my(@tests) = @_;
-
- local ($\, $,);
-
- my($tot, $failedtests) = _run_all_tests(@tests);
- _show_results($tot, $failedtests);
-
- my $ok = _all_ok($tot);
-
- assert(($ok xor keys %$failedtests),
- q{ok status jives with $failedtests});
-
- return $ok;
-}
-
-=begin _private
-
-=item B<_all_ok>
-
- my $ok = _all_ok(\%tot);
-
-Tells you if this test run is overall successful or not.
-
-=cut
-
-sub _all_ok {
- my($tot) = shift;
-
- return $tot->{bad} == 0 && ($tot->{max} || $tot->{skipped}) ? 1 : 0;
-}
-
-=item B<_globdir>
-
- my @files = _globdir $dir;
-
-Returns all the files in a directory. This is shorthand for backwards
-compatibility on systems where glob() doesn't work right.
-
-=cut
-
-sub _globdir {
- opendir DIRH, shift;
- my @f = readdir DIRH;
- closedir DIRH;
-
- return @f;
-}
-
-=item B<_run_all_tests>
-
- my($total, $failed) = _run_all_tests(@test_files);
-
-Runs all the given @test_files (as runtests()) but does it quietly (no
-report). $total is a hash ref summary of all the tests run. Its keys
-and values are this:
-
- bonus Number of individual todo tests unexpectedly passed
- max Number of individual tests ran
- ok Number of individual tests passed
- sub_skipped Number of individual tests skipped
- todo Number of individual todo tests
-
- files Number of test files ran
- good Number of test files passed
- bad Number of test files failed
- tests Number of test files originally given
- skipped Number of test files skipped
-
-If $total->{bad} == 0 and $total->{max} > 0, you've got a successful
-test.
-
-$failed is a hash ref of all the test scripts which failed. Each key
-is the name of a test script, each value is another hash representing
-how that script failed. Its keys are these:
-
- name Name of the test which failed
- estat Script's exit value
- wstat Script's wait status
- max Number of individual tests
- failed Number which failed
- percent Percentage of tests which failed
- canon List of tests which failed (as string).
-
-Needless to say, $failed should be empty if everything passed.
-
-B<NOTE> Currently this function is still noisy. I'm working on it.
-
-=cut
-
-#'#
-sub _run_all_tests {
- my(@tests) = @_;
- local($|) = 1;
- my(%failedtests);
-
- # Test-wide totals.
- my(%tot) = (
- bonus => 0,
- max => 0,
- ok => 0,
- files => 0,
- bad => 0,
- good => 0,
- tests => scalar @tests,
- sub_skipped => 0,
- todo => 0,
- skipped => 0,
- bench => 0,
- );
-
- my @dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir;
- my $t_start = new Benchmark;
-
- my $width = _leader_width(@tests);
- foreach my $tfile (@tests) {
- $Last_ML_Print = 0; # so each test prints at least once
- my($leader, $ml) = _mk_leader($tfile, $width);
- local $ML = $ml;
- print $leader;
-
- $tot{files}++;
-
- $Strap->{_seen_header} = 0;
- my %results = $Strap->analyze_file($tfile) or
- do { warn "$Strap->{error}\n"; next };
-
- # state of the current test.
- my @failed = grep { !$results{details}[$_-1]{ok} }
- 1..@{$results{details}};
- my %test = (
- ok => $results{ok},
- 'next' => $Strap->{'next'},
- max => $results{max},
- failed => \@failed,
- bonus => $results{bonus},
- skipped => $results{skip},
- skip_reason => $results{skip_reason},
- skip_all => $Strap->{skip_all},
- ml => $ml,
- );
-
- $tot{bonus} += $results{bonus};
- $tot{max} += $results{max};
- $tot{ok} += $results{ok};
- $tot{todo} += $results{todo};
- $tot{sub_skipped} += $results{skip};
-
- my($estatus, $wstatus) = @results{qw(exit wait)};
-
- if ($results{passing}) {
- if ($test{max} and $test{skipped} + $test{bonus}) {
- my @msg;
- push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}")
- if $test{skipped};
- push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded")
- if $test{bonus};
- print "$test{ml}ok\n ".join(', ', @msg)."\n";
- } elsif ($test{max}) {
- print "$test{ml}ok\n";
- } elsif (defined $test{skip_all} and length $test{skip_all}) {
- print "skipped\n all skipped: $test{skip_all}\n";
- $tot{skipped}++;
- } else {
- print "skipped\n all skipped: no reason given\n";
- $tot{skipped}++;
- }
- $tot{good}++;
- }
- else {
- # List unrun tests as failures.
- if ($test{'next'} <= $test{max}) {
- push @{$test{failed}}, $test{'next'}..$test{max};
- }
- # List overruns as failures.
- else {
- my $details = $results{details};
- foreach my $overrun ($test{max}+1..@$details)
- {
- next unless ref $details->[$overrun-1];
- push @{$test{failed}}, $overrun
- }
- }
-
- if ($wstatus) {
- $failedtests{$tfile} = _dubious_return(\%test, \%tot,
- $estatus, $wstatus);
- $failedtests{$tfile}{name} = $tfile;
- }
- elsif($results{seen}) {
- if (@{$test{failed}} and $test{max}) {
- my ($txt, $canon) = canonfailed($test{max},$test{skipped},
- @{$test{failed}});
- print "$test{ml}$txt";
- $failedtests{$tfile} = { canon => $canon,
- max => $test{max},
- failed => scalar @{$test{failed}},
- name => $tfile,
- percent => 100*(scalar @{$test{failed}})/$test{max},
- estat => '',
- wstat => '',
- };
- } else {
- print "Don't know which tests failed: got $test{ok} ok, ".
- "expected $test{max}\n";
- $failedtests{$tfile} = { canon => '??',
- max => $test{max},
- failed => '??',
- name => $tfile,
- percent => undef,
- estat => '',
- wstat => '',
- };
- }
- $tot{bad}++;
- } else {
- print "FAILED before any test output arrived\n";
- $tot{bad}++;
- $failedtests{$tfile} = { canon => '??',
- max => '??',
- failed => '??',
- name => $tfile,
- percent => undef,
- estat => '',
- wstat => '',
- };
- }
- }
-
- if (defined $Files_In_Dir) {
- my @new_dir_files = _globdir $Files_In_Dir;
- if (@new_dir_files != @dir_files) {
- my %f;
- @f{@new_dir_files} = (1) x @new_dir_files;
- delete @f{@dir_files};
- my @f = sort keys %f;
- print "LEAKED FILES: @f\n";
- @dir_files = @new_dir_files;
- }
- }
- }
- $tot{bench} = timediff(new Benchmark, $t_start);
-
- $Strap->_restore_PERL5LIB;
-
- return(\%tot, \%failedtests);
-}
-
-=item B<_mk_leader>
-
- my($leader, $ml) = _mk_leader($test_file, $width);
-
-Generates the 't/foo........' $leader for the given $test_file as well
-as a similar version which will overwrite the current line (by use of
-\r and such). $ml may be empty if Test::Harness doesn't think you're
-on TTY.
-
-The $width is the width of the "yada/blah.." string.
-
-=cut
-
-sub _mk_leader {
- my($te, $width) = @_;
- chomp($te);
- $te =~ s/\.\w+$/./;
-
- if ($^O eq 'VMS') { $te =~ s/^.*\.t\./\[.t./s; }
- my $blank = (' ' x 77);
- my $leader = "$te" . '.' x ($width - length($te));
- my $ml = "";
-
- $ml = "\r$blank\r$leader"
- if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose;
-
- return($leader, $ml);
-}
-
-=item B<_leader_width>
-
- my($width) = _leader_width(@test_files);
-
-Calculates how wide the leader should be based on the length of the
-longest test name.
-
-=cut
-
-sub _leader_width {
- my $maxlen = 0;
- my $maxsuflen = 0;
- foreach (@_) {
- my $suf = /\.(\w+)$/ ? $1 : '';
- my $len = length;
- my $suflen = length $suf;
- $maxlen = $len if $len > $maxlen;
- $maxsuflen = $suflen if $suflen > $maxsuflen;
- }
- # + 3 : we want three dots between the test name and the "ok"
- return $maxlen + 3 - $maxsuflen;
-}
-
-
-sub _show_results {
- my($tot, $failedtests) = @_;
-
- my $pct;
- my $bonusmsg = _bonusmsg($tot);
-
- if (_all_ok($tot)) {
- print "All tests successful$bonusmsg.\n";
- } elsif (!$tot->{tests}){
- die "FAILED--no tests were run for some reason.\n";
- } elsif (!$tot->{max}) {
- my $blurb = $tot->{tests}==1 ? "script" : "scripts";
- die "FAILED--$tot->{tests} test $blurb could be run, ".
- "alas--no output ever seen\n";
- } else {
- $pct = sprintf("%.2f", $tot->{good} / $tot->{tests} * 100);
- my $percent_ok = 100*$tot->{ok}/$tot->{max};
- my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
- $tot->{max} - $tot->{ok}, $tot->{max},
- $percent_ok;
-
- my($fmt_top, $fmt) = _create_fmts($failedtests);
-
- # Now write to formats
- for my $script (sort keys %$failedtests) {
- $Curtest = $failedtests->{$script};
- write;
- }
- if ($tot->{bad}) {
- $bonusmsg =~ s/^,\s*//;
- print "$bonusmsg.\n" if $bonusmsg;
- die "Failed $tot->{bad}/$tot->{tests} test scripts, $pct% okay.".
- "$subpct\n";
- }
- }
-
- printf("Files=%d, Tests=%d, %s\n",
- $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop'));
-}
-
-
-my %Handlers = ();
-$Strap->{callback} = sub {
- my($self, $line, $type, $totals) = @_;
- print $line if $Verbose;
-
- my $meth = $Handlers{$type};
- $meth->($self, $line, $type, $totals) if $meth;
-};
-
-
-$Handlers{header} = sub {
- my($self, $line, $type, $totals) = @_;
-
- warn "Test header seen more than once!\n" if $self->{_seen_header};
-
- $self->{_seen_header}++;
-
- warn "1..M can only appear at the beginning or end of tests\n"
- if $totals->{seen} &&
- $totals->{max} < $totals->{seen};
-};
-
-$Handlers{test} = sub {
- my($self, $line, $type, $totals) = @_;
-
- my $curr = $totals->{seen};
- my $next = $self->{'next'};
- my $max = $totals->{max};
- my $detail = $totals->{details}[-1];
-
- if( $detail->{ok} ) {
- _print_ml_less("ok $curr/$max");
-
- if( $detail->{type} eq 'skip' ) {
- $totals->{skip_reason} = $detail->{reason}
- unless defined $totals->{skip_reason};
- $totals->{skip_reason} = 'various reasons'
- if $totals->{skip_reason} ne $detail->{reason};
- }
- }
- else {
- _print_ml("NOK $curr");
- }
-
- if( $curr > $next ) {
- print "Test output counter mismatch [test $curr]\n";
- }
- elsif( $curr < $next ) {
- print "Confused test output: test $curr answered after ".
- "test ", $next - 1, "\n";
- }
-
-};
-
-$Handlers{bailout} = sub {
- my($self, $line, $type, $totals) = @_;
-
- die "FAILED--Further testing stopped" .
- ($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n");
-};
-
-
-sub _print_ml {
- print join '', $ML, @_ if $ML;
-}
-
-
-# For slow connections, we save lots of bandwidth by printing only once
-# per second.
-sub _print_ml_less {
- if( !$Ok_Slow || $Last_ML_Print != time ) {
- _print_ml(@_);
- $Last_ML_Print = time;
- }
-}
-
-sub _bonusmsg {
- my($tot) = @_;
-
- my $bonusmsg = '';
- $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : '').
- " UNEXPECTEDLY SUCCEEDED)")
- if $tot->{bonus};
-
- if ($tot->{skipped}) {
- $bonusmsg .= ", $tot->{skipped} test"
- . ($tot->{skipped} != 1 ? 's' : '');
- if ($tot->{sub_skipped}) {
- $bonusmsg .= " and $tot->{sub_skipped} subtest"
- . ($tot->{sub_skipped} != 1 ? 's' : '');
- }
- $bonusmsg .= ' skipped';
- }
- elsif ($tot->{sub_skipped}) {
- $bonusmsg .= ", $tot->{sub_skipped} subtest"
- . ($tot->{sub_skipped} != 1 ? 's' : '')
- . " skipped";
- }
-
- return $bonusmsg;
-}
-
-# Test program go boom.
-sub _dubious_return {
- my($test, $tot, $estatus, $wstatus) = @_;
- my ($failed, $canon, $percent) = ('??', '??');
-
- printf "$test->{ml}dubious\n\tTest returned status $estatus ".
- "(wstat %d, 0x%x)\n",
- $wstatus,$wstatus;
- print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
-
- if (corestatus($wstatus)) { # until we have a wait module
- if ($Have_Devel_Corestack) {
- Devel::CoreStack::stack($^X);
- } else {
- print "\ttest program seems to have generated a core\n";
- }
- }
-
- $tot->{bad}++;
-
- if ($test->{max}) {
- if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) {
- print "\tafter all the subtests completed successfully\n";
- $percent = 0;
- $failed = 0; # But we do not set $canon!
- }
- else {
- push @{$test->{failed}}, $test->{'next'}..$test->{max};
- $failed = @{$test->{failed}};
- (my $txt, $canon) = canonfailed($test->{max},$test->{skipped},@{$test->{failed}});
- $percent = 100*(scalar @{$test->{failed}})/$test->{max};
- print "DIED. ",$txt;
- }
- }
-
- return { canon => $canon, max => $test->{max} || '??',
- failed => $failed,
- percent => $percent,
- estat => $estatus, wstat => $wstatus,
- };
-}
-
-
-sub _create_fmts {
- my($failedtests) = @_;
-
- my $failed_str = "Failed Test";
- my $middle_str = " Stat Wstat Total Fail Failed ";
- my $list_str = "List of Failed";
-
- # Figure out our longest name string for formatting purposes.
- my $max_namelen = length($failed_str);
- foreach my $script (keys %$failedtests) {
- my $namelen = length $failedtests->{$script}->{name};
- $max_namelen = $namelen if $namelen > $max_namelen;
- }
-
- my $list_len = $Columns - length($middle_str) - $max_namelen;
- if ($list_len < length($list_str)) {
- $list_len = length($list_str);
- $max_namelen = $Columns - length($middle_str) - $list_len;
- if ($max_namelen < length($failed_str)) {
- $max_namelen = length($failed_str);
- $Columns = $max_namelen + length($middle_str) + $list_len;
- }
- }
-
- my $fmt_top = "format STDOUT_TOP =\n"
- . sprintf("%-${max_namelen}s", $failed_str)
- . $middle_str
- . $list_str . "\n"
- . "-" x $Columns
- . "\n.\n";
-
- my $fmt = "format STDOUT =\n"
- . "@" . "<" x ($max_namelen - 1)
- . " @>> @>>>> @>>>> @>>> ^##.##% "
- . "^" . "<" x ($list_len - 1) . "\n"
- . '{ $Curtest->{name}, $Curtest->{estat},'
- . ' $Curtest->{wstat}, $Curtest->{max},'
- . ' $Curtest->{failed}, $Curtest->{percent},'
- . ' $Curtest->{canon}'
- . "\n}\n"
- . "~~" . " " x ($Columns - $list_len - 2) . "^"
- . "<" x ($list_len - 1) . "\n"
- . '$Curtest->{canon}'
- . "\n.\n";
-
- eval $fmt_top;
- die $@ if $@;
- eval $fmt;
- die $@ if $@;
-
- return($fmt_top, $fmt);
-}
-
-{
- my $tried_devel_corestack;
-
- sub corestatus {
- my($st) = @_;
-
- my $did_core;
- eval { # we may not have a WCOREDUMP
- local $^W = 0; # *.ph files are often *very* noisy
- require 'wait.ph';
- $did_core = WCOREDUMP($st);
- };
- if( $@ ) {
- $did_core = $st & 0200;
- }
-
- eval { require Devel::CoreStack; $Have_Devel_Corestack++ }
- unless $tried_devel_corestack++;
-
- return $did_core;
- }
-}
-
-sub canonfailed ($$@) {
- my($max,$skipped,@failed) = @_;
- my %seen;
- @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
- my $failed = @failed;
- my @result = ();
- my @canon = ();
- my $min;
- my $last = $min = shift @failed;
- my $canon;
- if (@failed) {
- for (@failed, $failed[-1]) { # don't forget the last one
- if ($_ > $last+1 || $_ == $last) {
- if ($min == $last) {
- push @canon, $last;
- } else {
- push @canon, "$min-$last";
- }
- $min = $_;
- }
- $last = $_;
- }
- local $" = ", ";
- push @result, "FAILED tests @canon\n";
- $canon = join ' ', @canon;
- } else {
- push @result, "FAILED test $last\n";
- $canon = $last;
- }
-
- push @result, "\tFailed $failed/$max tests, ";
- if ($max) {
- push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay";
- } else {
- push @result, "?% okay";
- }
- my $ender = 's' x ($skipped > 1);
- my $good = $max - $failed - $skipped;
- if ($skipped) {
- my $skipmsg = " (less $skipped skipped test$ender: $good okay, ";
- if ($max) {
- my $goodper = sprintf("%.2f",100*($good/$max));
- $skipmsg .= "$goodper%)";
- } else {
- $skipmsg .= "?%)";
- }
- push @result, $skipmsg;
- }
- push @result, "\n";
- my $txt = join "", @result;
- ($txt, $canon);
-}
-
-=end _private
-
-=back
-
-=cut
-
-
-1;
-__END__
-
-
-=head1 EXPORT
-
-C<&runtests> is exported by Test::Harness by default.
-
-C<$verbose> and C<$switches> are exported upon request.
-
-
-=head1 DIAGNOSTICS
-
-=over 4
-
-=item C<All tests successful.\nFiles=%d, Tests=%d, %s>
-
-If all tests are successful some statistics about the performance are
-printed.
-
-=item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
-
-For any single script that has failing subtests statistics like the
-above are printed.
-
-=item C<Test returned status %d (wstat %d)>
-
-Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8>
-and C<$?> are printed in a message similar to the above.
-
-=item C<Failed 1 test, %.2f%% okay. %s>
-
-=item C<Failed %d/%d tests, %.2f%% okay. %s>
-
-If not all tests were successful, the script dies with one of the
-above messages.
-
-=item C<FAILED--Further testing stopped: %s>
-
-If a single subtest decides that further testing will not make sense,
-the script dies with this message.
-
-=back
-
-=head1 ENVIRONMENT
-
-=over 4
-
-=item C<HARNESS_ACTIVE>
-
-Harness sets this before executing the individual tests. This allows
-the tests to determine if they are being executed through the harness
-or by any other means.
-
-=item C<HARNESS_COLUMNS>
-
-This value will be used for the width of the terminal. If it is not
-set then it will default to C<COLUMNS>. If this is not set, it will
-default to 80. Note that users of Bourne-sh based shells will need to
-C<export COLUMNS> for this module to use that variable.
-
-=item C<HARNESS_COMPILE_TEST>
-
-When true it will make harness attempt to compile the test using
-C<perlcc> before running it.
-
-B<NOTE> This currently only works when sitting in the perl source
-directory!
-
-=item C<HARNESS_FILELEAK_IN_DIR>
-
-When set to the name of a directory, harness will check after each
-test whether new files appeared in that directory, and report them as
-
- LEAKED FILES: scr.tmp 0 my.db
-
-If relative, directory name is with respect to the current directory at
-the moment runtests() was called. Putting absolute path into
-C<HARNESS_FILELEAK_IN_DIR> may give more predictable results.
-
-=item C<HARNESS_IGNORE_EXITCODE>
-
-Makes harness ignore the exit status of child processes when defined.
-
-=item C<HARNESS_NOTTY>
-
-When set to a true value, forces it to behave as though STDOUT were
-not a console. You may need to set this if you don't want harness to
-output more frequent progress messages using carriage returns. Some
-consoles may not handle carriage returns properly (which results in a
-somewhat messy output).
-
-=item C<HARNESS_OK_SLOW>
-
-If true, the C<ok> messages are printed out only every second.
-This reduces output and therefore may for example help testing
-over slow connections.
-
-=item C<HARNESS_PERL_SWITCHES>
-
-Its value will be prepended to the switches used to invoke perl on
-each test. For example, setting C<HARNESS_PERL_SWITCHES> to C<-W> will
-run all tests with all warnings enabled.
-
-=item C<HARNESS_VERBOSE>
-
-If true, Test::Harness will output the verbose results of running
-its tests. Setting $Test::Harness::verbose will override this.
-
-=back
-
-=head1 EXAMPLE
-
-Here's how Test::Harness tests itself
-
- $ cd ~/src/devel/Test-Harness
- $ perl -Mblib -e 'use Test::Harness qw(&runtests $verbose);
- $verbose=0; runtests @ARGV;' t/*.t
- Using /home/schwern/src/devel/Test-Harness/blib
- t/base..............ok
- t/nonumbers.........ok
- t/ok................ok
- t/test-harness......ok
- All tests successful.
- Files=4, Tests=24, 2 wallclock secs ( 0.61 cusr + 0.41 csys = 1.02 CPU)
-
-=head1 SEE ALSO
-
-L<Test> and L<Test::Simple> for writing test scripts, L<Benchmark> for
-the underlying timing routines, L<Devel::CoreStack> to generate core
-dumps from failed tests and L<Devel::Cover> for test coverage
-analysis.
-
-=head1 AUTHORS
-
-Either Tim Bunce or Andreas Koenig, we don't know. What we know for
-sure is, that it was inspired by Larry Wall's TEST script that came
-with perl distributions for ages. Numerous anonymous contributors
-exist. Andreas Koenig held the torch for many years, and then
-Michael G Schwern.
-
-Current maintainer is Andy Lester C<< <andy@petdance.com> >>.
-
-=head1 LICENSE
-
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-See L<http://www.perl.com/perl/misc/Artistic.html>
-
-=head1 TODO
-
-Provide a way of running tests quietly (ie. no printing) for automated
-validation of tests. This will probably take the form of a version
-of runtests() which rather than printing its output returns raw data
-on the state of the tests. (Partially done in Test::Harness::Straps)
-
-Document the format.
-
-Fix HARNESS_COMPILE_TEST without breaking its core usage.
-
-Figure a way to report test names in the failure summary.
-
-Rework the test summary so long test names are not truncated as badly.
-(Partially done with new skip test styles)
-
-Deal with VMS's "not \nok 4\n" mistake.
-
-Add option for coverage analysis.
-
-Trap STDERR.
-
-Implement Straps total_results()
-
-Remember exit code
-
-Completely redo the print summary code.
-
-Implement Straps callbacks. (experimentally implemented)
-
-Straps->analyze_file() not taint clean, don't know if it can be
-
-Fix that damned VMS nit.
-
-HARNESS_TODOFAIL to display TODO failures
-
-Add a test for verbose.
-
-Change internal list of test results to a hash.
-
-Fix stats display when there's an overrun.
-
-Fix so perls with spaces in the filename work.
-
-=for _private
-
-Keeping whittling away at _run_all_tests()
-
-=for _private
-
-Clean up how the summary is printed. Get rid of those damned formats.
-
-=head1 BUGS
-
-HARNESS_COMPILE_TEST currently assumes it's run from the Perl source
-directory.
-
-=cut
diff --git a/Perl/t/Test/Harness/Assert.pm b/Perl/t/Test/Harness/Assert.pm
deleted file mode 100644
index 3ee23e3..0000000
--- a/Perl/t/Test/Harness/Assert.pm
+++ /dev/null
@@ -1,68 +0,0 @@
-# $Id$
-
-package Test::Harness::Assert;
-
-use strict;
-require Exporter;
-use vars qw($VERSION @EXPORT @ISA);
-
-$VERSION = '0.01';
-
-@ISA = qw(Exporter);
-@EXPORT = qw(assert);
-
-
-=head1 NAME
-
-Test::Harness::Assert - simple assert
-
-=head1 SYNOPSIS
-
- ### FOR INTERNAL USE ONLY ###
-
- use Test::Harness::Assert;
-
- assert( EXPR, $name );
-
-=head1 DESCRIPTION
-
-A simple assert routine since we don't have Carp::Assert handy.
-
-B<For internal use by Test::Harness ONLY!>
-
-=head2 Functions
-
-=over 4
-
-=item B<assert>
-
- assert( EXPR, $name );
-
-If the expression is false the program aborts.
-
-=cut
-
-sub assert ($;$) {
- my($assert, $name) = @_;
-
- unless( $assert ) {
- require Carp;
- my $msg = 'Assert failed';
- $msg .= " - '$name'" if defined $name;
- $msg .= '!';
- Carp::croak($msg);
- }
-
-}
-
-=head1 AUTHOR
-
-Michael G Schwern E<lt>schwern@pobox.comE<gt>
-
-=head1 SEE ALSO
-
-L<Carp::Assert>
-
-=cut
-
-1;
diff --git a/Perl/t/Test/Harness/Iterator.pm b/Perl/t/Test/Harness/Iterator.pm
deleted file mode 100644
index 5e22793..0000000
--- a/Perl/t/Test/Harness/Iterator.pm
+++ /dev/null
@@ -1,61 +0,0 @@
-package Test::Harness::Iterator;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = 0.01;
-
-
-=head1 NAME
-
-Test::Harness::Iterator - Internal Test::Harness Iterator
-
-=head1 SYNOPSIS
-
- use Test::Harness::Iterator;
- use Test::Harness::Iterator;
- my $it = Test::Harness::Iterator->new(\*TEST);
- my $it = Test::Harness::Iterator->new(\@array);
-
- my $line = $it->next;
-
-
-=head1 DESCRIPTION
-
-B<FOR INTERNAL USE ONLY!>
-
-This is a simple iterator wrapper for arrays and filehandles.
-
-=cut
-
-sub new {
- my($proto, $thing) = @_;
-
- my $self = {};
- if( ref $thing eq 'GLOB' ) {
- bless $self, 'Test::Harness::Iterator::FH';
- $self->{fh} = $thing;
- }
- elsif( ref $thing eq 'ARRAY' ) {
- bless $self, 'Test::Harness::Iterator::ARRAY';
- $self->{idx} = 0;
- $self->{array} = $thing;
- }
- else {
- warn "Can't iterate with a ", ref $thing;
- }
-
- return $self;
-}
-
-package Test::Harness::Iterator::FH;
-sub next {
- my $fh = $_[0]->{fh};
- return scalar <$fh>;
-}
-
-
-package Test::Harness::Iterator::ARRAY;
-sub next {
- my $self = shift;
- return $self->{array}->[$self->{idx}++];
-}
diff --git a/Perl/t/Test/Harness/Straps.pm b/Perl/t/Test/Harness/Straps.pm
deleted file mode 100644
index 4d971b7..0000000
--- a/Perl/t/Test/Harness/Straps.pm
+++ /dev/null
@@ -1,667 +0,0 @@
-# -*- Mode: cperl; cperl-indent-level: 4 -*-
-# $Id$
-
-package Test::Harness::Straps;
-
-use strict;
-use vars qw($VERSION);
-use Config;
-$VERSION = '0.15';
-
-use Test::Harness::Assert;
-use Test::Harness::Iterator;
-
-# Flags used as return values from our methods. Just for internal
-# clarification.
-my $TRUE = (1==1);
-my $FALSE = !$TRUE;
-my $YES = $TRUE;
-my $NO = $FALSE;
-
-
-=head1 NAME
-
-Test::Harness::Straps - detailed analysis of test results
-
-=head1 SYNOPSIS
-
- use Test::Harness::Straps;
-
- my $strap = Test::Harness::Straps->new;
-
- # Various ways to interpret a test
- my %results = $strap->analyze($name, \@test_output);
- my %results = $strap->analyze_fh($name, $test_filehandle);
- my %results = $strap->analyze_file($test_file);
-
- # UNIMPLEMENTED
- my %total = $strap->total_results;
-
- # Altering the behavior of the strap UNIMPLEMENTED
- my $verbose_output = $strap->dump_verbose();
- $strap->dump_verbose_fh($output_filehandle);
-
-
-=head1 DESCRIPTION
-
-B<THIS IS ALPHA SOFTWARE> in that the interface is subject to change
-in incompatible ways. It is otherwise stable.
-
-Test::Harness is limited to printing out its results. This makes
-analysis of the test results difficult for anything but a human. To
-make it easier for programs to work with test results, we provide
-Test::Harness::Straps. Instead of printing the results, straps
-provide them as raw data. You can also configure how the tests are to
-be run.
-
-The interface is currently incomplete. I<Please> contact the author
-if you'd like a feature added or something change or just have
-comments.
-
-=head1 Construction
-
-=head2 C<new>
-
- my $strap = Test::Harness::Straps->new;
-
-Initialize a new strap.
-
-=cut
-
-sub new {
- my($proto) = shift;
- my($class) = ref $proto || $proto;
-
- my $self = bless {}, $class;
- $self->_init;
-
- return $self;
-}
-
-=head2 C<_init>
-
- $strap->_init;
-
-Initialize the internal state of a strap to make it ready for parsing.
-
-=cut
-
-sub _init {
- my($self) = shift;
-
- $self->{_is_vms} = $^O eq 'VMS';
- $self->{_is_win32} = $^O eq 'Win32';
-}
-
-=head1 Analysis
-
-=head2 C<analyze>
-
- my %results = $strap->analyze($name, \@test_output);
-
-Analyzes the output of a single test, assigning it the given C<$name>
-for use in the total report. Returns the C<%results> of the test.
-See L<Results>.
-
-C<@test_output> should be the raw output from the test, including
-newlines.
-
-=cut
-
-sub analyze {
- my($self, $name, $test_output) = @_;
-
- my $it = Test::Harness::Iterator->new($test_output);
- return $self->_analyze_iterator($name, $it);
-}
-
-
-sub _analyze_iterator {
- my($self, $name, $it) = @_;
-
- $self->_reset_file_state;
- $self->{file} = $name;
- my %totals = (
- max => 0,
- seen => 0,
-
- ok => 0,
- todo => 0,
- skip => 0,
- bonus => 0,
-
- details => []
- );
-
- # Set them up here so callbacks can have them.
- $self->{totals}{$name} = \%totals;
- while( defined(my $line = $it->next) ) {
- $self->_analyze_line($line, \%totals);
- last if $self->{saw_bailout};
- }
-
- $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all};
-
- my $passed = ($totals{max} == 0 && defined $totals{skip_all}) ||
- ($totals{max} && $totals{seen} &&
- $totals{max} == $totals{seen} &&
- $totals{max} == $totals{ok});
- $totals{passing} = $passed ? 1 : 0;
-
- return %totals;
-}
-
-
-sub _analyze_line {
- my($self, $line, $totals) = @_;
-
- my %result = ();
-
- $self->{line}++;
-
- my $type;
- if( $self->_is_header($line) ) {
- $type = 'header';
-
- $self->{saw_header}++;
-
- $totals->{max} += $self->{max};
- }
- elsif( $self->_is_test($line, \%result) ) {
- $type = 'test';
-
- $totals->{seen}++;
- $result{number} = $self->{'next'} unless $result{number};
-
- # sometimes the 'not ' and the 'ok' are on different lines,
- # happens often on VMS if you do:
- # print "not " unless $test;
- # print "ok $num\n";
- if( $self->{saw_lone_not} &&
- ($self->{lone_not_line} == $self->{line} - 1) )
- {
- $result{ok} = 0;
- }
-
- my $pass = $result{ok};
- $result{type} = 'todo' if $self->{todo}{$result{number}};
-
- if( $result{type} eq 'todo' ) {
- $totals->{todo}++;
- $pass = 1;
- $totals->{bonus}++ if $result{ok}
- }
- elsif( $result{type} eq 'skip' ) {
- $totals->{skip}++;
- $pass = 1;
- }
-
- $totals->{ok}++ if $pass;
-
- if( $result{number} > 100000 && $result{number} > $self->{max} ) {
- warn "Enormous test number seen [test $result{number}]\n";
- warn "Can't detailize, too big.\n";
- }
- else {
- $totals->{details}[$result{number} - 1] =
- {$self->_detailize($pass, \%result)};
- }
-
- # XXX handle counter mismatch
- }
- elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
- $type = 'bailout';
- $self->{saw_bailout} = 1;
- }
- else {
- $type = 'other';
- }
-
- $self->{callback}->($self, $line, $type, $totals) if $self->{callback};
-
- $self->{'next'} = $result{number} + 1 if $type eq 'test';
-}
-
-=head2 C<analyze_fh>
-
- my %results = $strap->analyze_fh($name, $test_filehandle);
-
-Like C<analyze>, but it reads from the given filehandle.
-
-=cut
-
-sub analyze_fh {
- my($self, $name, $fh) = @_;
-
- my $it = Test::Harness::Iterator->new($fh);
- $self->_analyze_iterator($name, $it);
-}
-
-=head2 C<analyze_file>
-
- my %results = $strap->analyze_file($test_file);
-
-Like C<analyze>, but it runs the given C<$test_file> and parses its
-results. It will also use that name for the total report.
-
-=cut
-
-sub analyze_file {
- my($self, $file) = @_;
-
- unless( -e $file ) {
- $self->{error} = "$file does not exist";
- return;
- }
-
- unless( -r $file ) {
- $self->{error} = "$file is not readable";
- return;
- }
-
- local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
-
- my $cmd = $self->{_is_vms} ? "MCR $^X" :
- $self->{_is_win32} ? Win32::GetShortPathName($^X)
- : $^X;
-
- my $switches = $self->_switches($file);
-
- # *sigh* this breaks under taint, but open -| is unportable.
- unless( open(FILE, "$cmd $switches $file|") ) {
- print "can't run $file. $!\n";
- return;
- }
-
- my %results = $self->analyze_fh($file, \*FILE);
- my $exit = close FILE;
- $results{'wait'} = $?;
- if( $? && $self->{_is_vms} ) {
- eval q{use vmsish "status"; $results{'exit'} = $?};
- }
- else {
- $results{'exit'} = _wait2exit($?);
- }
- $results{passing} = 0 unless $? == 0;
-
- $self->_restore_PERL5LIB();
-
- return %results;
-}
-
-
-eval { require POSIX; &POSIX::WEXITSTATUS(0) };
-if( $@ ) {
- *_wait2exit = sub { $_[0] >> 8 };
-}
-else {
- *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) }
-}
-
-
-=head2 C<_switches>
-
- my $switches = $self->_switches($file);
-
-Formats and returns the switches necessary to run the test.
-
-=cut
-
-sub _switches {
- my($self, $file) = @_;
-
- local *TEST;
- open(TEST, $file) or print "can't open $file. $!\n";
- my $first = <TEST>;
- my $s = $Test::Harness::Switches || '';
- $s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
- if exists $ENV{'HARNESS_PERL_SWITCHES'};
-
- if ($first =~ /^#!.*\bperl.*\s-\w*([Tt]+)/) {
- # When taint mode is on, PERL5LIB is ignored. So we need to put
- # all that on the command line as -Is.
- $s .= join " ", qq[ "-$1"], map {qq["-I$_"]} $self->_filtered_INC;
- }
- elsif ($^O eq 'MacOS') {
- # MacPerl's putenv is broken, so it will not see PERL5LIB.
- $s .= join " ", map {qq["-I$_"]} $self->_filtered_INC;
- }
-
- close(TEST) or print "can't close $file. $!\n";
-
- return $s;
-}
-
-
-=head2 C<_INC2PERL5LIB>
-
- local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
-
-Takes the current value of C<@INC> and turns it into something suitable
-for putting onto C<PERL5LIB>.
-
-=cut
-
-sub _INC2PERL5LIB {
- my($self) = shift;
-
- $self->{_old5lib} = $ENV{PERL5LIB};
-
- return join $Config{path_sep}, $self->_filtered_INC;
-}
-
-=head2 C<_filtered_INC>
-
- my @filtered_inc = $self->_filtered_INC;
-
-Shortens C<@INC> by removing redundant and unnecessary entries.
-Necessary for OSes with limited command line lengths, like VMS.
-
-=cut
-
-sub _filtered_INC {
- my($self, @inc) = @_;
- @inc = @INC unless @inc;
-
- # VMS has a 255-byte limit on the length of %ENV entries, so
- # toss the ones that involve perl_root, the install location
- # for VMS
- if( $self->{_is_vms} ) {
- @inc = grep !/perl_root/i, @inc;
- }
-
- return @inc;
-}
-
-
-=head2 C<_restore_PERL5LIB>
-
- $self->_restore_PERL5LIB;
-
-This restores the original value of the C<PERL5LIB> environment variable.
-Necessary on VMS, otherwise a no-op.
-
-=cut
-
-sub _restore_PERL5LIB {
- my($self) = shift;
-
- return unless $self->{_is_vms};
-
- if (defined $self->{_old5lib}) {
- $ENV{PERL5LIB} = $self->{_old5lib};
- }
-}
-
-=head1 Parsing
-
-Methods for identifying what sort of line you're looking at.
-
-=head2 C<_is_comment>
-
- my $is_comment = $strap->_is_comment($line, \$comment);
-
-Checks if the given line is a comment. If so, it will place it into
-C<$comment> (sans #).
-
-=cut
-
-sub _is_comment {
- my($self, $line, $comment) = @_;
-
- if( $line =~ /^\s*\#(.*)/ ) {
- $$comment = $1;
- return $YES;
- }
- else {
- return $NO;
- }
-}
-
-=head2 C<_is_header>
-
- my $is_header = $strap->_is_header($line);
-
-Checks if the given line is a header (1..M) line. If so, it places how
-many tests there will be in C<< $strap->{max} >>, a list of which tests
-are todo in C<< $strap->{todo} >> and if the whole test was skipped
-C<< $strap->{skip_all} >> contains the reason.
-
-=cut
-
-# Regex for parsing a header. Will be run with /x
-my $Extra_Header_Re = <<'REGEX';
- ^
- (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set
- (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason
-REGEX
-
-sub _is_header {
- my($self, $line) = @_;
-
- if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
- $self->{max} = $max;
- assert( $self->{max} >= 0, 'Max # of tests looks right' );
-
- if( defined $extra ) {
- my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
-
- $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
-
- if( $self->{max} == 0 ) {
- $reason = '' unless defined $skip and $skip =~ /^Skip/i;
- }
-
- $self->{skip_all} = $reason;
- }
-
- return $YES;
- }
- else {
- return $NO;
- }
-}
-
-=head2 C<_is_test>
-
- my $is_test = $strap->_is_test($line, \%test);
-
-Checks if the $line is a test report (ie. 'ok/not ok'). Reports the
-result back in C<%test> which will contain:
-
- ok did it succeed? This is the literal 'ok' or 'not ok'.
- name name of the test (if any)
- number test number (if any)
-
- type 'todo' or 'skip' (if any)
- reason why is it todo or skip? (if any)
-
-If will also catch lone 'not' lines, note it saw them
-C<< $strap->{saw_lone_not} >> and the line in C<< $strap->{lone_not_line} >>.
-
-=cut
-
-my $Report_Re = <<'REGEX';
- ^
- (not\ )? # failure?
- ok\b
- (?:\s+(\d+))? # optional test number
- \s*
- (.*) # and the rest
-REGEX
-
-my $Extra_Re = <<'REGEX';
- ^
- (.*?) (?:(?:[^\\]|^)# (.*))?
- $
-REGEX
-
-sub _is_test {
- my($self, $line, $test) = @_;
-
- # We pulverize the line down into pieces in three parts.
- if( my($not, $num, $extra) = $line =~ /$Report_Re/ox ) {
- my($name, $control) = split /(?:[^\\]|^)#/, $extra if $extra;
- my($type, $reason) = $control =~ /^\s*(\S+)(?:\s+(.*))?$/ if $control;
-
- $test->{number} = $num;
- $test->{ok} = $not ? 0 : 1;
- $test->{name} = $name;
-
- if( defined $type ) {
- $test->{type} = $type =~ /^TODO$/i ? 'todo' :
- $type =~ /^Skip/i ? 'skip' : 0;
- }
- else {
- $test->{type} = '';
- }
- $test->{reason} = $reason;
-
- return $YES;
- }
- else{
- # Sometimes the "not " and "ok" will be on seperate lines on VMS.
- # We catch this and remember we saw it.
- if( $line =~ /^not\s+$/ ) {
- $self->{saw_lone_not} = 1;
- $self->{lone_not_line} = $self->{line};
- }
-
- return $NO;
- }
-}
-
-=head2 C<_is_bail_out>
-
- my $is_bail_out = $strap->_is_bail_out($line, \$reason);
-
-Checks if the line is a "Bail out!". Places the reason for bailing
-(if any) in $reason.
-
-=cut
-
-sub _is_bail_out {
- my($self, $line, $reason) = @_;
-
- if( $line =~ /^Bail out!\s*(.*)/i ) {
- $$reason = $1 if $1;
- return $YES;
- }
- else {
- return $NO;
- }
-}
-
-=head2 C<_reset_file_state>
-
- $strap->_reset_file_state;
-
-Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
-etc. so it's ready to parse the next file.
-
-=cut
-
-sub _reset_file_state {
- my($self) = shift;
-
- delete @{$self}{qw(max skip_all todo)};
- $self->{line} = 0;
- $self->{saw_header} = 0;
- $self->{saw_bailout}= 0;
- $self->{saw_lone_not} = 0;
- $self->{lone_not_line} = 0;
- $self->{bailout_reason} = '';
- $self->{'next'} = 1;
-}
-
-=head1 Results
-
-The C<%results> returned from C<analyze()> contain the following
-information:
-
- passing true if the whole test is considered a pass
- (or skipped), false if its a failure
-
- exit the exit code of the test run, if from a file
- wait the wait code of the test run, if from a file
-
- max total tests which should have been run
- seen total tests actually seen
- skip_all if the whole test was skipped, this will
- contain the reason.
-
- ok number of tests which passed
- (including todo and skips)
-
- todo number of todo tests seen
- bonus number of todo tests which
- unexpectedly passed
-
- skip number of tests skipped
-
-So a successful test should have max == seen == ok.
-
-
-There is one final item, the details.
-
- details an array ref reporting the result of
- each test looks like this:
-
- $results{details}[$test_num - 1] =
- { ok => is the test considered ok?
- actual_ok => did it literally say 'ok'?
- name => name of the test (if any)
- type => 'skip' or 'todo' (if any)
- reason => reason for the above (if any)
- };
-
-Element 0 of the details is test #1. I tried it with element 1 being
-#1 and 0 being empty, this is less awkward.
-
-=head2 C<_detailize>
-
- my %details = $strap->_detailize($pass, \%test);
-
-Generates the details based on the last test line seen. C<$pass> is
-true if it was considered to be a passed test. C<%test> is the results
-of the test you're summarizing.
-
-=cut
-
-sub _detailize {
- my($self, $pass, $test) = @_;
-
- my %details = ( ok => $pass,
- actual_ok => $test->{ok}
- );
-
- assert( !(grep !defined $details{$_}, keys %details),
- 'test contains the ok and actual_ok info' );
-
- # We don't want these to be undef because they are often
- # checked and don't want the checker to have to deal with
- # uninitialized vars.
- foreach my $piece (qw(name type reason)) {
- $details{$piece} = defined $test->{$piece} ? $test->{$piece} : '';
- }
-
- return %details;
-}
-
-=head1 EXAMPLES
-
-See F<examples/mini_harness.plx> for an example of use.
-
-=head1 AUTHOR
-
-Michael G Schwern C<< <schwern@pobox.com> >>, currently maintained by
-Andy Lester C<< <andy@petdance.com> >>.
-
-=head1 SEE ALSO
-
-L<Test::Harness>
-
-=cut
-
-
-1;
diff --git a/Perl/t/Test/More.pm b/Perl/t/Test/More.pm
deleted file mode 100644
index 03f7552..0000000
--- a/Perl/t/Test/More.pm
+++ /dev/null
@@ -1,1248 +0,0 @@
-package Test::More;
-
-use 5.004;
-
-use strict;
-use Test::Builder;
-
-
-# Can't use Carp because it might cause use_ok() to accidentally succeed
-# even though the module being used forgot to use Carp. Yes, this
-# actually happened.
-sub _carp {
- my($file, $line) = (caller(1))[1,2];
- warn @_, " at $file line $line\n";
-}
-
-
-
-require Exporter;
-use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.47';
-@ISA = qw(Exporter);
-@EXPORT = qw(ok use_ok require_ok
- is isnt like unlike is_deeply
- cmp_ok
- skip todo todo_skip
- pass fail
- eq_array eq_hash eq_set
- $TODO
- plan
- can_ok isa_ok
- diag
- );
-
-my $Test = Test::Builder->new;
-
-
-# 5.004's Exporter doesn't have export_to_level.
-sub _export_to_level
-{
- my $pkg = shift;
- my $level = shift;
- (undef) = shift; # redundant arg
- my $callpkg = caller($level);
- $pkg->export($callpkg, @_);
-}
-
-
-=head1 NAME
-
-Test::More - yet another framework for writing test scripts
-
-=head1 SYNOPSIS
-
- use Test::More tests => $Num_Tests;
- # or
- use Test::More qw(no_plan);
- # or
- use Test::More skip_all => $reason;
-
- BEGIN { use_ok( 'Some::Module' ); }
- require_ok( 'Some::Module' );
-
- # Various ways to say "ok"
- ok($this eq $that, $test_name);
-
- is ($this, $that, $test_name);
- isnt($this, $that, $test_name);
-
- # Rather than print STDERR "# here's what went wrong\n"
- diag("here's what went wrong");
-
- like ($this, qr/that/, $test_name);
- unlike($this, qr/that/, $test_name);
-
- cmp_ok($this, '==', $that, $test_name);
-
- is_deeply($complex_structure1, $complex_structure2, $test_name);
-
- SKIP: {
- skip $why, $how_many unless $have_some_feature;
-
- ok( foo(), $test_name );
- is( foo(42), 23, $test_name );
- };
-
- TODO: {
- local $TODO = $why;
-
- ok( foo(), $test_name );
- is( foo(42), 23, $test_name );
- };
-
- can_ok($module, @methods);
- isa_ok($object, $class);
-
- pass($test_name);
- fail($test_name);
-
- # Utility comparison functions.
- eq_array(\@this, \@that);
- eq_hash(\%this, \%that);
- eq_set(\@this, \@that);
-
- # UNIMPLEMENTED!!!
- my @status = Test::More::status;
-
- # UNIMPLEMENTED!!!
- BAIL_OUT($why);
-
-
-=head1 DESCRIPTION
-
-B<STOP!> If you're just getting started writing tests, have a look at
-Test::Simple first. This is a drop in replacement for Test::Simple
-which you can switch to once you get the hang of basic testing.
-
-The purpose of this module is to provide a wide range of testing
-utilities. Various ways to say "ok" with better diagnostics,
-facilities to skip tests, test future features and compare complicated
-data structures. While you can do almost anything with a simple
-C<ok()> function, it doesn't provide good diagnostic output.
-
-
-=head2 I love it when a plan comes together
-
-Before anything else, you need a testing plan. This basically declares
-how many tests your script is going to run to protect against premature
-failure.
-
-The preferred way to do this is to declare a plan when you C<use Test::More>.
-
- use Test::More tests => $Num_Tests;
-
-There are rare cases when you will not know beforehand how many tests
-your script is going to run. In this case, you can declare that you
-have no plan. (Try to avoid using this as it weakens your test.)
-
- use Test::More qw(no_plan);
-
-In some cases, you'll want to completely skip an entire testing script.
-
- use Test::More skip_all => $skip_reason;
-
-Your script will declare a skip with the reason why you skipped and
-exit immediately with a zero (success). See L<Test::Harness> for
-details.
-
-If you want to control what functions Test::More will export, you
-have to use the 'import' option. For example, to import everything
-but 'fail', you'd do:
-
- use Test::More tests => 23, import => ['!fail'];
-
-Alternatively, you can use the plan() function. Useful for when you
-have to calculate the number of tests.
-
- use Test::More;
- plan tests => keys %Stuff * 3;
-
-or for deciding between running the tests at all:
-
- use Test::More;
- if( $^O eq 'MacOS' ) {
- plan skip_all => 'Test irrelevant on MacOS';
- }
- else {
- plan tests => 42;
- }
-
-=cut
-
-sub plan {
- my(@plan) = @_;
-
- my $caller = caller;
-
- $Test->exported_to($caller);
-
- my @imports = ();
- foreach my $idx (0..$#plan) {
- if( $plan[$idx] eq 'import' ) {
- my($tag, $imports) = splice @plan, $idx, 2;
- @imports = @$imports;
- last;
- }
- }
-
- $Test->plan(@plan);
-
- __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
-}
-
-sub import {
- my($class) = shift;
- goto &plan;
-}
-
-
-=head2 Test names
-
-By convention, each test is assigned a number in order. This is
-largely done automatically for you. However, it's often very useful to
-assign a name to each test. Which would you rather see:
-
- ok 4
- not ok 5
- ok 6
-
-or
-
- ok 4 - basic multi-variable
- not ok 5 - simple exponential
- ok 6 - force == mass * acceleration
-
-The later gives you some idea of what failed. It also makes it easier
-to find the test in your script, simply search for "simple
-exponential".
-
-All test functions take a name argument. It's optional, but highly
-suggested that you use it.
-
-
-=head2 I'm ok, you're not ok.
-
-The basic purpose of this module is to print out either "ok #" or "not
-ok #" depending on if a given test succeeded or failed. Everything
-else is just gravy.
-
-All of the following print "ok" or "not ok" depending on if the test
-succeeded or failed. They all also return true or false,
-respectively.
-
-=over 4
-
-=item B<ok>
-
- ok($this eq $that, $test_name);
-
-This simply evaluates any expression (C<$this eq $that> is just a
-simple example) and uses that to determine if the test succeeded or
-failed. A true expression passes, a false one fails. Very simple.
-
-For example:
-
- ok( $exp{9} == 81, 'simple exponential' );
- ok( Film->can('db_Main'), 'set_db()' );
- ok( $p->tests == 4, 'saw tests' );
- ok( !grep !defined $_, @items, 'items populated' );
-
-(Mnemonic: "This is ok.")
-
-$test_name is a very short description of the test that will be printed
-out. It makes it very easy to find a test in your script when it fails
-and gives others an idea of your intentions. $test_name is optional,
-but we B<very> strongly encourage its use.
-
-Should an ok() fail, it will produce some diagnostics:
-
- not ok 18 - sufficient mucus
- # Failed test 18 (foo.t at line 42)
-
-This is actually Test::Simple's ok() routine.
-
-=cut
-
-sub ok ($;$) {
- my($test, $name) = @_;
- $Test->ok($test, $name);
-}
-
-=item B<is>
-
-=item B<isnt>
-
- is ( $this, $that, $test_name );
- isnt( $this, $that, $test_name );
-
-Similar to ok(), is() and isnt() compare their two arguments
-with C<eq> and C<ne> respectively and use the result of that to
-determine if the test succeeded or failed. So these:
-
- # Is the ultimate answer 42?
- is( ultimate_answer(), 42, "Meaning of Life" );
-
- # $foo isn't empty
- isnt( $foo, '', "Got some foo" );
-
-are similar to these:
-
- ok( ultimate_answer() eq 42, "Meaning of Life" );
- ok( $foo ne '', "Got some foo" );
-
-(Mnemonic: "This is that." "This isn't that.")
-
-So why use these? They produce better diagnostics on failure. ok()
-cannot know what you are testing for (beyond the name), but is() and
-isnt() know what the test was and why it failed. For example this
-test:
-
- my $foo = 'waffle'; my $bar = 'yarblokos';
- is( $foo, $bar, 'Is foo the same as bar?' );
-
-Will produce something like this:
-
- not ok 17 - Is foo the same as bar?
- # Failed test (foo.t at line 139)
- # got: 'waffle'
- # expected: 'yarblokos'
-
-So you can figure out what went wrong without rerunning the test.
-
-You are encouraged to use is() and isnt() over ok() where possible,
-however do not be tempted to use them to find out if something is
-true or false!
-
- # XXX BAD! $pope->isa('Catholic') eq 1
- is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' );
-
-This does not check if C<$pope->isa('Catholic')> is true, it checks if
-it returns 1. Very different. Similar caveats exist for false and 0.
-In these cases, use ok().
-
- ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' );
-
-For those grammatical pedants out there, there's an C<isn't()>
-function which is an alias of isnt().
-
-=cut
-
-sub is ($$;$) {
- $Test->is_eq(@_);
-}
-
-sub isnt ($$;$) {
- $Test->isnt_eq(@_);
-}
-
-*isn't = \&isnt;
-
-
-=item B<like>
-
- like( $this, qr/that/, $test_name );
-
-Similar to ok(), like() matches $this against the regex C<qr/that/>.
-
-So this:
-
- like($this, qr/that/, 'this is like that');
-
-is similar to:
-
- ok( $this =~ /that/, 'this is like that');
-
-(Mnemonic "This is like that".)
-
-The second argument is a regular expression. It may be given as a
-regex reference (i.e. C<qr//>) or (for better compatibility with older
-perls) as a string that looks like a regex (alternative delimiters are
-currently not supported):
-
- like( $this, '/that/', 'this is like that' );
-
-Regex options may be placed on the end (C<'/that/i'>).
-
-Its advantages over ok() are similar to that of is() and isnt(). Better
-diagnostics on failure.
-
-=cut
-
-sub like ($$;$) {
- $Test->like(@_);
-}
-
-
-=item B<unlike>
-
- unlike( $this, qr/that/, $test_name );
-
-Works exactly as like(), only it checks if $this B<does not> match the
-given pattern.
-
-=cut
-
-sub unlike {
- $Test->unlike(@_);
-}
-
-
-=item B<cmp_ok>
-
- cmp_ok( $this, $op, $that, $test_name );
-
-Halfway between ok() and is() lies cmp_ok(). This allows you to
-compare two arguments using any binary perl operator.
-
- # ok( $this eq $that );
- cmp_ok( $this, 'eq', $that, 'this eq that' );
-
- # ok( $this == $that );
- cmp_ok( $this, '==', $that, 'this == that' );
-
- # ok( $this && $that );
- cmp_ok( $this, '&&', $that, 'this || that' );
- ...etc...
-
-Its advantage over ok() is when the test fails you'll know what $this
-and $that were:
-
- not ok 1
- # Failed test (foo.t at line 12)
- # '23'
- # &&
- # undef
-
-It's also useful in those cases where you are comparing numbers and
-is()'s use of C<eq> will interfere:
-
- cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
-
-=cut
-
-sub cmp_ok($$$;$) {
- $Test->cmp_ok(@_);
-}
-
-
-=item B<can_ok>
-
- can_ok($module, @methods);
- can_ok($object, @methods);
-
-Checks to make sure the $module or $object can do these @methods
-(works with functions, too).
-
- can_ok('Foo', qw(this that whatever));
-
-is almost exactly like saying:
-
- ok( Foo->can('this') &&
- Foo->can('that') &&
- Foo->can('whatever')
- );
-
-only without all the typing and with a better interface. Handy for
-quickly testing an interface.
-
-No matter how many @methods you check, a single can_ok() call counts
-as one test. If you desire otherwise, use:
-
- foreach my $meth (@methods) {
- can_ok('Foo', $meth);
- }
-
-=cut
-
-sub can_ok ($@) {
- my($proto, @methods) = @_;
- my $class = ref $proto || $proto;
-
- unless( @methods ) {
- my $ok = $Test->ok( 0, "$class->can(...)" );
- $Test->diag(' can_ok() called with no methods');
- return $ok;
- }
-
- my @nok = ();
- foreach my $method (@methods) {
- local($!, $@); # don't interfere with caller's $@
- # eval sometimes resets $!
- eval { $proto->can($method) } || push @nok, $method;
- }
-
- my $name;
- $name = @methods == 1 ? "$class->can('$methods[0]')"
- : "$class->can(...)";
-
- my $ok = $Test->ok( !@nok, $name );
-
- $Test->diag(map " $class->can('$_') failed\n", @nok);
-
- return $ok;
-}
-
-=item B<isa_ok>
-
- isa_ok($object, $class, $object_name);
- isa_ok($ref, $type, $ref_name);
-
-Checks to see if the given $object->isa($class). Also checks to make
-sure the object was defined in the first place. Handy for this sort
-of thing:
-
- my $obj = Some::Module->new;
- isa_ok( $obj, 'Some::Module' );
-
-where you'd otherwise have to write
-
- my $obj = Some::Module->new;
- ok( defined $obj && $obj->isa('Some::Module') );
-
-to safeguard against your test script blowing up.
-
-It works on references, too:
-
- isa_ok( $array_ref, 'ARRAY' );
-
-The diagnostics of this test normally just refer to 'the object'. If
-you'd like them to be more specific, you can supply an $object_name
-(for example 'Test customer').
-
-=cut
-
-sub isa_ok ($$;$) {
- my($object, $class, $obj_name) = @_;
-
- my $diag;
- $obj_name = 'The object' unless defined $obj_name;
- my $name = "$obj_name isa $class";
- if( !defined $object ) {
- $diag = "$obj_name isn't defined";
- }
- elsif( !ref $object ) {
- $diag = "$obj_name isn't a reference";
- }
- else {
- # We can't use UNIVERSAL::isa because we want to honor isa() overrides
- local($@, $!); # eval sometimes resets $!
- my $rslt = eval { $object->isa($class) };
- if( $@ ) {
- if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
- if( !UNIVERSAL::isa($object, $class) ) {
- my $ref = ref $object;
- $diag = "$obj_name isn't a '$class' it's a '$ref'";
- }
- } else {
- die <<WHOA;
-WHOA! I tried to call ->isa on your object and got some weird error.
-This should never happen. Please contact the author immediately.
-Here's the error.
-$@
-WHOA
- }
- }
- elsif( !$rslt ) {
- my $ref = ref $object;
- $diag = "$obj_name isn't a '$class' it's a '$ref'";
- }
- }
-
-
-
- my $ok;
- if( $diag ) {
- $ok = $Test->ok( 0, $name );
- $Test->diag(" $diag\n");
- }
- else {
- $ok = $Test->ok( 1, $name );
- }
-
- return $ok;
-}
-
-
-=item B<pass>
-
-=item B<fail>
-
- pass($test_name);
- fail($test_name);
-
-Sometimes you just want to say that the tests have passed. Usually
-the case is you've got some complicated condition that is difficult to
-wedge into an ok(). In this case, you can simply use pass() (to
-declare the test ok) or fail (for not ok). They are synonyms for
-ok(1) and ok(0).
-
-Use these very, very, very sparingly.
-
-=cut
-
-sub pass (;$) {
- $Test->ok(1, @_);
-}
-
-sub fail (;$) {
- $Test->ok(0, @_);
-}
-
-=back
-
-=head2 Diagnostics
-
-If you pick the right test function, you'll usually get a good idea of
-what went wrong when it failed. But sometimes it doesn't work out
-that way. So here we have ways for you to write your own diagnostic
-messages which are safer than just C<print STDERR>.
-
-=over 4
-
-=item B<diag>
-
- diag(@diagnostic_message);
-
-Prints a diagnostic message which is guaranteed not to interfere with
-test output. Handy for this sort of thing:
-
- ok( grep(/foo/, @users), "There's a foo user" ) or
- diag("Since there's no foo, check that /etc/bar is set up right");
-
-which would produce:
-
- not ok 42 - There's a foo user
- # Failed test (foo.t at line 52)
- # Since there's no foo, check that /etc/bar is set up right.
-
-You might remember C<ok() or diag()> with the mnemonic C<open() or
-die()>.
-
-B<NOTE> The exact formatting of the diagnostic output is still
-changing, but it is guaranteed that whatever you throw at it it won't
-interfere with the test.
-
-=cut
-
-sub diag {
- $Test->diag(@_);
-}
-
-
-=back
-
-=head2 Module tests
-
-You usually want to test if the module you're testing loads ok, rather
-than just vomiting if its load fails. For such purposes we have
-C<use_ok> and C<require_ok>.
-
-=over 4
-
-=item B<use_ok>
-
- BEGIN { use_ok($module); }
- BEGIN { use_ok($module, @imports); }
-
-These simply use the given $module and test to make sure the load
-happened ok. It's recommended that you run use_ok() inside a BEGIN
-block so its functions are exported at compile-time and prototypes are
-properly honored.
-
-If @imports are given, they are passed through to the use. So this:
-
- BEGIN { use_ok('Some::Module', qw(foo bar)) }
-
-is like doing this:
-
- use Some::Module qw(foo bar);
-
-don't try to do this:
-
- BEGIN {
- use_ok('Some::Module');
-
- ...some code that depends on the use...
- ...happening at compile time...
- }
-
-instead, you want:
-
- BEGIN { use_ok('Some::Module') }
- BEGIN { ...some code that depends on the use... }
-
-
-=cut
-
-sub use_ok ($;@) {
- my($module, @imports) = @_;
- @imports = () unless @imports;
-
- my $pack = caller;
-
- local($@,$!); # eval sometimes interferes with $!
- eval <<USE;
-package $pack;
-require $module;
-'$module'->import(\@imports);
-USE
-
- my $ok = $Test->ok( !$@, "use $module;" );
-
- unless( $ok ) {
- chomp $@;
- $Test->diag(<<DIAGNOSTIC);
- Tried to use '$module'.
- Error: $@
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-=item B<require_ok>
-
- require_ok($module);
-
-Like use_ok(), except it requires the $module.
-
-=cut
-
-sub require_ok ($) {
- my($module) = shift;
-
- my $pack = caller;
-
- local($!, $@); # eval sometimes interferes with $!
- eval <<REQUIRE;
-package $pack;
-require $module;
-REQUIRE
-
- my $ok = $Test->ok( !$@, "require $module;" );
-
- unless( $ok ) {
- chomp $@;
- $Test->diag(<<DIAGNOSTIC);
- Tried to require '$module'.
- Error: $@
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-=back
-
-=head2 Conditional tests
-
-Sometimes running a test under certain conditions will cause the
-test script to die. A certain function or method isn't implemented
-(such as fork() on MacOS), some resource isn't available (like a
-net connection) or a module isn't available. In these cases it's
-necessary to skip tests, or declare that they are supposed to fail
-but will work in the future (a todo test).
-
-For more details on the mechanics of skip and todo tests see
-L<Test::Harness>.
-
-The way Test::More handles this is with a named block. Basically, a
-block of tests which can be skipped over or made todo. It's best if I
-just show you...
-
-=over 4
-
-=item B<SKIP: BLOCK>
-
- SKIP: {
- skip $why, $how_many if $condition;
-
- ...normal testing code goes here...
- }
-
-This declares a block of tests that might be skipped, $how_many tests
-there are, $why and under what $condition to skip them. An example is
-the easiest way to illustrate:
-
- SKIP: {
- eval { require HTML::Lint };
-
- skip "HTML::Lint not installed", 2 if $@;
-
- my $lint = new HTML::Lint;
- isa_ok( $lint, "HTML::Lint" );
-
- $lint->parse( $html );
- is( $lint->errors, 0, "No errors found in HTML" );
- }
-
-If the user does not have HTML::Lint installed, the whole block of
-code I<won't be run at all>. Test::More will output special ok's
-which Test::Harness interprets as skipped, but passing, tests.
-It's important that $how_many accurately reflects the number of tests
-in the SKIP block so the # of tests run will match up with your plan.
-
-It's perfectly safe to nest SKIP blocks. Each SKIP block must have
-the label C<SKIP>, or Test::More can't work its magic.
-
-You don't skip tests which are failing because there's a bug in your
-program, or for which you don't yet have code written. For that you
-use TODO. Read on.
-
-=cut
-
-#'#
-sub skip {
- my($why, $how_many) = @_;
-
- unless( defined $how_many ) {
- # $how_many can only be avoided when no_plan is in use.
- _carp "skip() needs to know \$how_many tests are in the block"
- unless $Test::Builder::No_Plan;
- $how_many = 1;
- }
-
- for( 1..$how_many ) {
- $Test->skip($why);
- }
-
- local $^W = 0;
- last SKIP;
-}
-
-
-=item B<TODO: BLOCK>
-
- TODO: {
- local $TODO = $why if $condition;
-
- ...normal testing code goes here...
- }
-
-Declares a block of tests you expect to fail and $why. Perhaps it's
-because you haven't fixed a bug or haven't finished a new feature:
-
- TODO: {
- local $TODO = "URI::Geller not finished";
-
- my $card = "Eight of clubs";
- is( URI::Geller->your_card, $card, 'Is THIS your card?' );
-
- my $spoon;
- URI::Geller->bend_spoon;
- is( $spoon, 'bent', "Spoon bending, that's original" );
- }
-
-With a todo block, the tests inside are expected to fail. Test::More
-will run the tests normally, but print out special flags indicating
-they are "todo". Test::Harness will interpret failures as being ok.
-Should anything succeed, it will report it as an unexpected success.
-You then know the thing you had todo is done and can remove the
-TODO flag.
-
-The nice part about todo tests, as opposed to simply commenting out a
-block of tests, is it's like having a programmatic todo list. You know
-how much work is left to be done, you're aware of what bugs there are,
-and you'll know immediately when they're fixed.
-
-Once a todo test starts succeeding, simply move it outside the block.
-When the block is empty, delete it.
-
-
-=item B<todo_skip>
-
- TODO: {
- todo_skip $why, $how_many if $condition;
-
- ...normal testing code...
- }
-
-With todo tests, it's best to have the tests actually run. That way
-you'll know when they start passing. Sometimes this isn't possible.
-Often a failing test will cause the whole program to die or hang, even
-inside an C<eval BLOCK> with and using C<alarm>. In these extreme
-cases you have no choice but to skip over the broken tests entirely.
-
-The syntax and behavior is similar to a C<SKIP: BLOCK> except the
-tests will be marked as failing but todo. Test::Harness will
-interpret them as passing.
-
-=cut
-
-sub todo_skip {
- my($why, $how_many) = @_;
-
- unless( defined $how_many ) {
- # $how_many can only be avoided when no_plan is in use.
- _carp "todo_skip() needs to know \$how_many tests are in the block"
- unless $Test::Builder::No_Plan;
- $how_many = 1;
- }
-
- for( 1..$how_many ) {
- $Test->todo_skip($why);
- }
-
- local $^W = 0;
- last TODO;
-}
-
-=item When do I use SKIP vs. TODO?
-
-B<If it's something the user might not be able to do>, use SKIP.
-This includes optional modules that aren't installed, running under
-an OS that doesn't have some feature (like fork() or symlinks), or maybe
-you need an Internet connection and one isn't available.
-
-B<If it's something the programmer hasn't done yet>, use TODO. This
-is for any code you haven't written yet, or bugs you have yet to fix,
-but want to put tests in your testing script (always a good idea).
-
-
-=back
-
-=head2 Comparison functions
-
-Not everything is a simple eq check or regex. There are times you
-need to see if two arrays are equivalent, for instance. For these
-instances, Test::More provides a handful of useful functions.
-
-B<NOTE> These are NOT well-tested on circular references. Nor am I
-quite sure what will happen with filehandles.
-
-=over 4
-
-=item B<is_deeply>
-
- is_deeply( $this, $that, $test_name );
-
-Similar to is(), except that if $this and $that are hash or array
-references, it does a deep comparison walking each data structure to
-see if they are equivalent. If the two structures are different, it
-will display the place where they start differing.
-
-Barrie Slaymaker's Test::Differences module provides more in-depth
-functionality along these lines, and it plays well with Test::More.
-
-B<NOTE> Display of scalar refs is not quite 100%
-
-=cut
-
-use vars qw(@Data_Stack);
-my $DNE = bless [], 'Does::Not::Exist';
-sub is_deeply {
- my($this, $that, $name) = @_;
-
- my $ok;
- if( !ref $this || !ref $that ) {
- $ok = $Test->is_eq($this, $that, $name);
- }
- else {
- local @Data_Stack = ();
- if( _deep_check($this, $that) ) {
- $ok = $Test->ok(1, $name);
- }
- else {
- $ok = $Test->ok(0, $name);
- $ok = $Test->diag(_format_stack(@Data_Stack));
- }
- }
-
- return $ok;
-}
-
-sub _format_stack {
- my(@Stack) = @_;
-
- my $var = '$FOO';
- my $did_arrow = 0;
- foreach my $entry (@Stack) {
- my $type = $entry->{type} || '';
- my $idx = $entry->{'idx'};
- if( $type eq 'HASH' ) {
- $var .= "->" unless $did_arrow++;
- $var .= "{$idx}";
- }
- elsif( $type eq 'ARRAY' ) {
- $var .= "->" unless $did_arrow++;
- $var .= "[$idx]";
- }
- elsif( $type eq 'REF' ) {
- $var = "\${$var}";
- }
- }
-
- my @vals = @{$Stack[-1]{vals}}[0,1];
- my @vars = ();
- ($vars[0] = $var) =~ s/\$FOO/ \$got/;
- ($vars[1] = $var) =~ s/\$FOO/\$expected/;
-
- my $out = "Structures begin differing at:\n";
- foreach my $idx (0..$#vals) {
- my $val = $vals[$idx];
- $vals[$idx] = !defined $val ? 'undef' :
- $val eq $DNE ? "Does not exist"
- : "'$val'";
- }
-
- $out .= "$vars[0] = $vals[0]\n";
- $out .= "$vars[1] = $vals[1]\n";
-
- $out =~ s/^/ /msg;
- return $out;
-}
-
-
-=item B<eq_array>
-
- eq_array(\@this, \@that);
-
-Checks if two arrays are equivalent. This is a deep check, so
-multi-level structures are handled correctly.
-
-=cut
-
-#'#
-sub eq_array {
- my($a1, $a2) = @_;
- return 1 if $a1 eq $a2;
-
- my $ok = 1;
- my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
- for (0..$max) {
- my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
- my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
-
- push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
- $ok = _deep_check($e1,$e2);
- pop @Data_Stack if $ok;
-
- last unless $ok;
- }
- return $ok;
-}
-
-sub _deep_check {
- my($e1, $e2) = @_;
- my $ok = 0;
-
-# my $eq;
- {
- # Quiet uninitialized value warnings when comparing undefs.
- local $^W = 0;
-
- if( $e1 eq $e2 ) {
- $ok = 1;
- }
- else {
- if( UNIVERSAL::isa($e1, 'ARRAY') and
- UNIVERSAL::isa($e2, 'ARRAY') )
- {
- $ok = eq_array($e1, $e2);
- }
- elsif( UNIVERSAL::isa($e1, 'HASH') and
- UNIVERSAL::isa($e2, 'HASH') )
- {
- $ok = eq_hash($e1, $e2);
- }
- elsif( UNIVERSAL::isa($e1, 'REF') and
- UNIVERSAL::isa($e2, 'REF') )
- {
- push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
- $ok = _deep_check($$e1, $$e2);
- pop @Data_Stack if $ok;
- }
- elsif( UNIVERSAL::isa($e1, 'SCALAR') and
- UNIVERSAL::isa($e2, 'SCALAR') )
- {
- push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
- $ok = _deep_check($$e1, $$e2);
- }
- else {
- push @Data_Stack, { vals => [$e1, $e2] };
- $ok = 0;
- }
- }
- }
-
- return $ok;
-}
-
-
-=item B<eq_hash>
-
- eq_hash(\%this, \%that);
-
-Determines if the two hashes contain the same keys and values. This
-is a deep check.
-
-=cut
-
-sub eq_hash {
- my($a1, $a2) = @_;
- return 1 if $a1 eq $a2;
-
- my $ok = 1;
- my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
- foreach my $k (keys %$bigger) {
- my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
- my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
-
- push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
- $ok = _deep_check($e1, $e2);
- pop @Data_Stack if $ok;
-
- last unless $ok;
- }
-
- return $ok;
-}
-
-=item B<eq_set>
-
- eq_set(\@this, \@that);
-
-Similar to eq_array(), except the order of the elements is B<not>
-important. This is a deep check, but the irrelevancy of order only
-applies to the top level.
-
-B<NOTE> By historical accident, this is not a true set comparision.
-While the order of elements does not matter, duplicate elements do.
-
-=cut
-
-# We must make sure that references are treated neutrally. It really
-# doesn't matter how we sort them, as long as both arrays are sorted
-# with the same algorithm.
-sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b }
-
-sub eq_set {
- my($a1, $a2) = @_;
- return 0 unless @$a1 == @$a2;
-
- # There's faster ways to do this, but this is easiest.
- return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
-}
-
-=back
-
-
-=head2 Extending and Embedding Test::More
-
-Sometimes the Test::More interface isn't quite enough. Fortunately,
-Test::More is built on top of Test::Builder which provides a single,
-unified backend for any test library to use. This means two test
-libraries which both use Test::Builder B<can be used together in the
-same program>.
-
-If you simply want to do a little tweaking of how the tests behave,
-you can access the underlying Test::Builder object like so:
-
-=over 4
-
-=item B<builder>
-
- my $test_builder = Test::More->builder;
-
-Returns the Test::Builder object underlying Test::More for you to play
-with.
-
-=cut
-
-sub builder {
- return Test::Builder->new;
-}
-
-=back
-
-
-=head1 NOTES
-
-Test::More is B<explicitly> tested all the way back to perl 5.004.
-
-Test::More is thread-safe for perl 5.8.0 and up.
-
-=head1 BUGS and CAVEATS
-
-=over 4
-
-=item Making your own ok()
-
-If you are trying to extend Test::More, don't. Use Test::Builder
-instead.
-
-=item The eq_* family has some caveats.
-
-=item Test::Harness upgrades
-
-no_plan and todo depend on new Test::Harness features and fixes. If
-you're going to distribute tests that use no_plan or todo your
-end-users will have to upgrade Test::Harness to the latest one on
-CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness
-will work fine.
-
-If you simply depend on Test::More, it's own dependencies will cause a
-Test::Harness upgrade.
-
-=back
-
-
-=head1 HISTORY
-
-This is a case of convergent evolution with Joshua Pritikin's Test
-module. I was largely unaware of its existence when I'd first
-written my own ok() routines. This module exists because I can't
-figure out how to easily wedge test names into Test's interface (along
-with a few other problems).
-
-The goal here is to have a testing utility that's simple to learn,
-quick to use and difficult to trip yourself up with while still
-providing more flexibility than the existing Test.pm. As such, the
-names of the most common routines are kept tiny, special cases and
-magic side-effects are kept to a minimum. WYSIWYG.
-
-
-=head1 SEE ALSO
-
-L<Test::Simple> if all this confuses you and you just want to write
-some tests. You can upgrade to Test::More later (it's forward
-compatible).
-
-L<Test::Differences> for more ways to test complex data structures.
-And it plays well with Test::More.
-
-L<Test> is the old testing module. Its main benefit is that it has
-been distributed with Perl since 5.004_05.
-
-L<Test::Harness> for details on how your test results are interpreted
-by Perl.
-
-L<Test::Unit> describes a very featureful unit testing interface.
-
-L<Test::Inline> shows the idea of embedded testing.
-
-L<SelfTest> is another approach to embedded testing.
-
-
-=head1 AUTHORS
-
-Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
-from Joshua Pritikin's Test module and lots of help from Barrie
-Slaymaker, Tony Bowden, chromatic and the perl-qa gang.
-
-
-=head1 COPYRIGHT
-
-Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
-
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-See F<http://www.perl.com/perl/misc/Artistic.html>
-
-=cut
-
-1;
diff --git a/Perl/t/TestLog.pm b/Perl/t/TestLog.pm
deleted file mode 100644
index 6c84604..0000000
--- a/Perl/t/TestLog.pm
+++ /dev/null
@@ -1,306 +0,0 @@
-package TestLog;
-
-# $Id$
-# These test facilities has been developped by C. Mertz <mertz@cena.fr>
-
-use IO::Handle; # for autoflushing the logs
-use Carp;
-
-use Exporter;
-@ISA = qw(Exporter);
-
-use vars qw( $VERSION @ISA);
-($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/);
-@EXPORT = qw( openLog setZincLog log test_eval test_no_eval printableItem printableArray printableList
- equal_flat_arrays nequal_cplx_arrays);
-use strict;
-
-use constant ERROR => '--an error--';
-
-my $selected_loglevel;
-
-sub openLog {
- my ($outfile, $loglevel, $no_logfile) = @_;
-
- $selected_loglevel = $loglevel;
- if (defined $no_logfile && $no_logfile) {
- open LOG, "> /dev/null";
- }
- else {
- if ( open LOG, "$outfile.prev" ) {
- close LOG;
- unlink "$outfile.prev";
- }
- if ( open LOG, $outfile ) {
- close LOG;
- link $outfile, "$outfile.prev";
- unlink "$outfile";
- }
-
- open LOG,"> $outfile";
- autoflush LOG 1; # autoflush is important so that logs are up-to-date if Zinc crashes!
- }
-}
-
-
-
-### print log information to the logfile
-### if $level is <= than selected_loglevel (def = 0) then print log on the stdout
-### - a loglevel of -100 means an error to be logged with #### prefix
-### - a loglevel of -10 means an error in the test to be logged with ## prefix
-### - a loglevel of 0 means an message to be usually printed (and logged in any case)
-### - a loglevel greater than 1 is for trace only
-
-
-sub log {
- my ($loglevel, @strgs) = @_;
- if ($loglevel <= $selected_loglevel) {
- print "#### " if $loglevel == -100;
- print "## " if $loglevel == -10;
- print @strgs;
- }
- print LOG "#### " if $loglevel == -100;
- print LOG "## " if $loglevel == -10;
- print LOG @strgs;
-} # end log
-
-my $zinc;
-## to init the $zinc
-sub setZincLog {
- ($zinc)=@_;
-}
-
-
-my %method_with_tagOrId =
- ("anchorxy" => 1, "bbox" => 1, "bind" => 1, "chggroup" => 1,
- "clone" => 1, "contour" => 1, "coords"=> 1, "cursor" => 1,
- "dchars" => 1, "dtag" => 1, "focus" => 1, "gettags" => 1,
- "group" => 1, # blabla... to complete
- "itemcget" => 1, "itemconfigure" => 1, # blabla... to complete
- "remove" => 1,
- );
-
-### evaluate $zinc->$method(@args); and verifies that NO ERROR occurs
-### - a loglevel of -100 means an error to be logged with #### prefix
-### - a loglevel of -10 means an error in the test, to be logged with ##
-### - a loglevel of of 0 or greater is for trace only (usefull when an error occurs)
-sub test_eval {
- my ($loglevel, $method, @args) = @_;
-
- my @strs;
- my $start_index = 0;
- my $string2log = "\$zinc->$method (";
- if (scalar @args) {
- if ($method_with_tagOrId{$method} and $args[0] =~ /^\d+$/) {
- my $type = $zinc->type($args[0]);
- $string2log .= &printableItem($args[0]) . " (a". ucfirst($type) . ")";
- } else {
- $string2log .= &printableItem($args[0]) ;
- }
- $string2log .= ", " if $#args > 0 ;
- my $rest = &printableList(@args[1..$#args]);
- $rest =~ s/^\(//; ### suppressing the first ( char
- $string2log .= $rest;
- } else {
- $string2log .= ")";
- }
- if ($method eq 'itemcget' or $method eq 'get') {
- $string2log .= "; # := " ;
- } else {
- $string2log .= ";\n";
- }
- &log ($loglevel, $string2log);
-
- my (@res, $res);
- if (wantarray()) {
- @res = eval { $zinc->$method (@args) } ;
- if ($method eq 'itemcget' or $method eq 'get') {
- &log ($loglevel, printableList(@res) . "\n" );
- }
- } else {
- $res = eval { $zinc->$method (@args) } ;
- if ($method eq 'itemcget' or $method eq 'get') {
- &log ($loglevel, &printableItem($res) . "\n");
- }
- }
-
- if ($@) { # in case of error, logging!
- &log (-100, "Error while evaluating: $string2log;");
- &log (-100, $@);
- my $msgl = &Carp::longmess;
- my ($msg2) = $msgl =~ /.*?( at .*)/s ;
- &log (-100, "\t$msg2");
- return (ERROR);
- } else {
- if (wantarray()) {
- return @res;
- }
- else {
- return $res;
- }
- }
-} # end of test_eval
-
-### evaluate $zinc->$method(@args); and verifies that AN ERROR occurs
-### - a loglevel of -100 means an NO error to be loggued with #### prefix
-### - a loglevel of -10 means NO error in the test to be loggued with ## prefix
-### - a loglevel of of 0 or greater is for trace only if NO error occured
-sub test_no_eval {
- my ($reason, $loglevel, $method, @args) = @_;
-
- my @strs;
- my $start_index = 0;
- my $string2log = "\$zinc->$method (";
- if (scalar @args) {
- if ($method_with_tagOrId{$method} and $args[0] =~ /^\d+$/) {
- my $type = $zinc->type($args[0]);
- $string2log .= &printableItem($args[0]) . " (a". ucfirst($type) . ")";
- } else {
- $string2log .= &printableItem($args[0]) ;
- }
- $string2log .= ", " if $#args > 0 ;
- my $rest = &printableList(@args[1..$#args]);
- $rest =~ s/^\(//; ### suppressing the first ( char
- $string2log .= $rest;
- } else {
- $string2log .= ")";
- }
-
- eval { $zinc->$method (@args) } ;
-
- # in case of NO error, logging!
- if ($@) {
-# print "errormsg=$@";
- my ($error_msg) = $@ =~ /(.*)\s*at \/usr\//;
- $error_msg = $@ if !defined $error_msg ;
- &log ($loglevel, " # When $reason : $string2log;\n # the error msg is: $error_msg\n");
- } else {
- &log (-100, "An error SHOULD have occured while evaluating:\n####\t$string2log;\n####\tbecause $reason\n");
- }
-} # end of test_no_eval
-
-
-### return a printable string of something in a readable form
-sub printableItem {
- my ($value) = @_;
- my $ref = ref($value);
- if ($ref eq 'ARRAY') {
- return printableArray ( @{$value} );
- }
- elsif ($ref eq 'Tk::Photo') {
- return 'Tk::Photo("'. $value->cget(-file) . '")';
- }
- elsif ($ref eq '') { # scalar
- if (defined $value) {
- if ($value eq '') {
- return "''";
- } elsif ($value =~ /^-[a-zA-Z_]+$/) {
- ## for the -attribut
- return $value;
- } elsif ($value =~ /\s/
- or $value =~ /[a-zA-Z]/
- or $value =~ /^[\W]$/ ) {
- return "'$value'";
- } else {
- return $value;
- }
- }
- else {
- return "undef";
- }
- }
- else { # some class instance
- return $value;
- }
-} # end printableItem
-
-### to print an array of something
-sub printableArray {
- my (@values) = @_;
- if (! scalar @values) {
- return "[]";
- }
- else { # the array is not empty
- my $res = "[ ";
- while (@values) {
- my $value = shift @values;
- $res .= &printableItem($value);
- next unless (@values);
- if ($value =~ /^-\w+/) {
- $res .= " => ";
- } elsif (@_) {
- $res .= ", ";
- }
-
- }
- return ($res . " ]") ;
- }
-} # end printableArray
-
-sub printableList {
- my $res = "(";
- while (@_) {
- my $v = shift @_;
- $res .= &printableItem($v);
- if (defined $v and $v =~ /^-\w+/ and @_) {
- $res .= " => ";
- } elsif (@_) {
- $res .= ", ";
- }
- }
- return $res . ")";
-} # end printableList
-
-
-## return 1 if arrays of scalars have the same length and every items are eq
-sub equal_flat_arrays {
- my ($refArray1, $refArray2) = @_;
- my @array1 = @{$refArray1};
- my @array2 = @{$refArray2};
-
- return 0 if ($#array1 != $#array2);
-
- for my $i (0..$#array1) {
- return 0 if ($array1[$i] ne $array2[$i]);
- }
- return 1;
-} # equal_arrays
-
-
-## return 0 if arrays of anything are equal
-## return 'length' if their length are different
-## return xx if some elements are différents
-## arrays may be arrays of arrays of arrays ...
-sub nequal_cplx_arrays {
- my ($refArray1, $refArray2) = @_;
- my @array1 = @{$refArray1};
- my @array2 = @{$refArray2};
-
-# print "array1=", &printableArray(@array1), "\narray2=",&printableArray(@array2),"\n";
- return 'length' if ($#array1 != $#array2);
-
- for my $i (0..$#array1) {
- my $el1 = $array1[$i];
- my $el2 = $array2[$i];
-
- if (ref($el1)) {
-# print "REF el1=",ref($el1),"\n";
- if (!ref($el2)) {
- return "elts at index $i are different: $el1 != $el2\n";
- } elsif (ref($el2) ne ref($el1)) {
- return "elts at index $i are of different type: ".
- ref($el2), " ne ", ref($el1), "\n";
- } elsif (ref($el2) eq 'ARRAY') {
- if (my $res = &nequal_cplx_arrays ($el1,$el2)) {
- return "elts at index $i are different: $res";
- }
- }
- } elsif (ref($el2) or $el1 ne $el2) {
- return "elts at index $i are different $el1 != $el2\n";
- }
- }
- return 0;
-} # nequal_cplx_arrays
-
-
-1;
diff --git a/Perl/t/Text.t b/Perl/t/Text.t
deleted file mode 100644
index bd43a4b..0000000
--- a/Perl/t/Text.t
+++ /dev/null
@@ -1,58 +0,0 @@
-#!/usr/bin/perl -w
-
-#
-# $Id: Text.t,v 1.2 2004-04-02 12:01:49 mertz Exp $
-# Author: Christophe Mertz
-#
-
-# testing all the import
-
-BEGIN {
- if (!eval q{
-# use Test::More qw(no_plan);
- use Test::More tests => 5;
- 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;
- 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");
-
-# following a mail in zinc@tls.cena.fr (23 sept 2003) by A. Lemort
-# we verify that the -width attribute of text items is converted as an integer
-my $text = $zinc->add('text', 1, -position => [10,10], -text => "text");
-
-&ok ($zinc->itemconfigure($text, -width => 10.1) or 1, "setting width to 10.1");
-&is ($zinc->itemcget($text, -width), 10, "width attribute was converted to an integer");
-&ok ($zinc->itemconfigure($text, -width => 9.9) or 1, "setting width to 10.9");
-&is ($zinc->itemcget($text, -width), 9, "width attribute was converted to lower integer");
-
-
-
-diag("############## text items test");
diff --git a/Perl/t/Transformations.t b/Perl/t/Transformations.t
deleted file mode 100644
index e736837..0000000
--- a/Perl/t/Transformations.t
+++ /dev/null
@@ -1,304 +0,0 @@
-#!/usr/bin/perl -w
-
-#
-# $Id: Transformations.t,v 1.3 2004-04-02 12:03:34 mertz Exp $
-# Author: Christophe Mertz
-#
-
-# testing all the import
-
-BEGIN {
- if (!eval q{
-# use Test::More qw(no_plan);
- use Test::More tests => 21;
- 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;
- 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);
-my $coords = [ [10,10], [40, 40] ];
-
-like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created");
-
-my $g = $zinc->add('group',1);
-$zinc->scale($g,2,2);
-my $rect1 = $zinc->add('rectangle', $g, [10,10,40,40]);
-
-# todo : add a test for the to-come method to get a transform!
-
-is_deeply([ $zinc->coords($rect1) ],
- [ [10,10], [40, 40] ],
- "coords are not modified by the group transform!");
-
-is_deeply([
- $zinc->transform(1, $g, [100, 100, 300, 500] )
- ],
- [ 50, 50, 150, 250 ],
- "transform from window coordinates to group");
-
-is_deeply([
- $zinc->transform($g, 1, [$zinc->coords($rect1)] )
- ],
- [ [20,20], [80, 80] ],
- "transform to window coordinates");
-
-
-# question suggested by D. Etienne (30 sept 2003):
-# is it possible to get the window coordinate of a transformed item?
-# the answer is of course yes and it is verified here.
-my $rect2 = $zinc->add('rectangle', 1, [10,10,40,40]);
-
-# applying a transform to the rectangle:
-$zinc->scale($rect2, 2,2);
-
-# todo : add a test for the to-come method to get a transform!
-
-is_deeply([ $zinc->coords($rect1) ],
- [ [10,10], [40, 40] ],
- "coords are not modified by the item transform!");
-
-is_deeply([
- $zinc->transform(1, $rect2, [100, 100, 300, 500] )
- ],
- [ 50, 50, 150, 250 ],
- "transform window coordinates with same transform than rect2 ");
-is_deeply([
- $zinc->transform($rect2, 1, [$zinc->coords($rect2)] )
- ],
- [ [20,20], [80, 80] ],
- "transform rect2 coordinates to window coordinates, with group 1");
-
-is_deeply([
- $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] )
- ],
- [ [20,20], [80, 80] ],
- "transform rect2 coordinates to window coordinates with 'device'");
-
-$zinc->scale(1, 0.5, 0.5);
-
-is_deeply([
- $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] )
- ],
- [ [10,10], [40, 40] ],
- "transform rect2 coordinates to window coordinates with 'device'");
-
-# setting the top group transformation to the id, with a translation with tset
-$zinc->tset(1, 1,0, 0,1, -20,-10);
-is_deeply([
- $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] )
- ],
- [ [0,10], [60, 70] ],
- "rect2 window coordinates with 'device' after topgroup transfo setting");
-
-# restting top group transformation
-$zinc->treset(1);
-is_deeply([
- $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] )
- ],
- [ [20,20], [80, 80] ],
- "rect2 window coordinates with 'device' after topgroup treset");
-
-# resetting the rect2 trasnformation
-$zinc->treset($rect2);
-is_deeply([
- $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] )
- ],
- [ [10,10], [40, 40] ],
- "rect2 window coordinates with 'device' after rect2 treset");
-
-$zinc->treset($rect2);
-$zinc->skew($rect2, 10,00);
-$zinc->skew($rect2, -10,00);
-ok(&similarPoints ([
- $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] )
- ],
- [ [10, 10], [40, 40] ]),
- "rect2 window coordinates with 'device' after rect2 skew (back and forth)");
-
-
-$zinc->treset($rect2);
-$zinc->skew($rect2, -10,00);
-$zinc->skew($rect2, 10,00);
-ok(&similarPoints ([
- $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] )
- ],
- [ [10, 10], [40, 40] ]),
- "rect2 window coordinates with 'device' after rect2 skew (forth and back)");
-
-
-$zinc->treset($rect2);
-$zinc->translate($rect2, 34,43);
-$zinc->translate($rect2, 15,15, 'absolute'); # the previous relative translation will be overridden
-is_deeply([
- $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] )
- ],
- [ [25,25], [55, 55] ],
- "rect2 window coordinates with 'device' after rect2 absolute translation");
-
-if (0) {
-$zinc->treset($rect2);
-print "0 ", $zinc->tget($rect2, 'rotation'), "\n";
-$zinc->rotate($rect2, 3.14159);
-print "+3.14 ", $zinc->tget($rect2, 'rotation'), "\n";
-$zinc->rotate($rect2, -3.14159, 0);
-print "0 ", $zinc->tget($rect2, 'rotation'), "\n";
-$zinc->rotate($rect2, 180, 1);
-print "180 ", $zinc->tget($rect2, 'rotation'), "\n";
-$zinc->rotate($rect2, -3.14159, 100, 200);
-print "0 ", $zinc->tget($rect2, 'rotation'), "\n";
-$zinc->rotate($rect2, -3.14159, 0, 100, 200);
-print "3.14 ", $zinc->tget($rect2, 'rotation'), "\n";
-$zinc->rotate($rect2, 180, 1, 100, 200);
-print "0 ", $zinc->tget($rect2, 'rotation'), "\n";
-$zinc->rotate($rect2, 180, 1, 100, 200, 300);
-print "3.14 ", $zinc->tget($rect2, 'rotation'), "\n";
-$zinc->rotate($rect2, 180, 1, 100, 200, 300, 600);
-print $zinc->tget($rect2, 'rotation'), "\n";
-$zinc->rotate($rect2, 180, 1, 100, 200, 300, 600, 900);
-print $zinc->tget($rect2, 'rotation'), "\n";
-}
-
-$zinc->treset($rect2);
-$zinc->translate($rect2, 40,50);
-$zinc->scale($rect2, 2,3);
-$zinc->rotate($rect2, 3.1415/2);
-
-my ($m00, $m01, $m10, $m11, $m20, $m21) = $zinc->tget($rect2);
-#print "matrix: $m00, $m01, $m10, $m11, $m20, $m21\n";
-ok(&similarFlatArray ([$zinc->tget($rect2)],
- [0, 2, -3, 0, -150, 80],
- [0.001, 0.001, 0.001, 0.001, 1, 1]),
- "tget of rect2");
-
-my ($xTranslate, $yTranslate, $xScale, $yScale, $angle, $skew) = $zinc->tget($rect2, 'all');
-#print "matrix: $xTranslate, $yTranslate, $xScale, $yScale, $angle, $skew\n";
-ok(&similarFlatArray ([$zinc->tget($rect2,'all')],
- [-150, 80, 2, 3, 3.14159/2, 0 ],
- [1, 1, 0.001, 0.001, 0.001, 0.001]),
- "tget 'all' of rect2");
-
-
-($xTranslate, $yTranslate) = $zinc->tget($rect2, 'translation');
-#print "translate: $xTranslate, $yTranslate\n";
-ok(&similarFlatArray ([$zinc->tget($rect2,'translation')],
- [-150, 80],
- [1, 1 ]),
- "tget 'translation' of rect2");
-
-($xScale, $yScale) = $zinc->tget($rect2, 'scale');
-#print "scale: $xScale, $yScale\n";
-ok(&similarFlatArray ([$zinc->tget($rect2,'scale')],
- [2, 3, ],
- [0.001, 0.001]),
- "tget 'scale' of rect2");
-
-($m00, $m01, $m10, $m11, $m20, $m21) = $zinc->tget($rect2, 'rotation');
-ok(&similarFlatArray ([$zinc->tget($rect2,'rotation')],
- [3.14159/2],
- [0.001 ]),
- "tget 'rotation' of rect2");
-
-#$zinc->skew($rect2, 10,0);
-ok(&similarFlatArray ([$zinc->tget($rect2,'skew')],
- [0],
- [0.001 ]),
- "tget 'skew' of rect2");
-
-
-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("############## transformations test");
-
-
diff --git a/Perl/t/find.t b/Perl/t/find.t
deleted file mode 100644
index b30be97..0000000
--- a/Perl/t/find.t
+++ /dev/null
@@ -1,200 +0,0 @@
-#!/usr/bin/perl -w
-
-#
-# $Id: find.t,v 1.4 2004-09-01 09:00:44 mertz Exp $
-# Author: Christophe Mertz
-#
-
-# testing find methods
-
-# this script can be used with an optionnal argument, an integer giving
-# the delay in seconds during which the graphic updates will be displayed
-# this is usefull for visual inspection!
-
-BEGIN {
- if (!eval q{
-# use Test::More qw(no_plan);
- use Test::More tests => 22;
- 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;
- 1;
- }) {
- print "unable to load Tk::Zinc";
- print "1..1\n";
- print "ok 1\n";
- exit;
- }
- if (!eval q{
- $mw = 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;
- }
-}
-
-
-$zinc = $mw->Zinc(-render => 0,
- -width => 400, -height => 400)->pack;
-
-like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created");
-
-
-### creating rectangles:
-$g1 = $zinc->add('group',1, -tags => "gr1");
-$text = $zinc->add('text', $g1, -position => [-100,-100]);
-$g2 = $zinc->add('group',$g1, -tags => "gr2");
-
-$rect11 = $zinc->add('rectangle', $g2, [ 10,10,40,40]);
-$rect12 = $zinc->add('rectangle', $g2, [ 50,10,80,40]);
-$rect13 = $zinc->add('rectangle', $g2, [ 90,10,120,40]);
-$rect21 = $zinc->add('rectangle', $g2, [ 10,50,40,80]);
-$rect22 = $zinc->add('rectangle', $g2, [ 50,50,80,80], -tags => 'middle');
-$rect23 = $zinc->add('rectangle', $g2, [ 90,50,120,80]);
-$rect31 = $zinc->add('rectangle', $g2, [ 10,90,40,120]);
-$rect32 = $zinc->add('rectangle', $g2, [ 50,90,80,120]);
-$rect33 = $zinc->add('rectangle', $g2, [ 90,90,120,120]);
-$zinc->update;
-
-my @list;
-
-@list = $zinc->find('overlapping', 20,20,110,110, $g2);
-&ok (&eq_array (\@list ,
- [ $rect33, $rect32, $rect31, $rect23, $rect22, $rect21, $rect13, $rect12, $rect11, ]),
- "find overlapping all rectangles");
-
-@list = $zinc->find('enclosed', 20,20,110,110, $g2);
-&ok (&eq_array (\@list ,
- [ $rect22 ]),
- "find enclosed the middle rectangle");
-
-@list = $zinc->find('enclosed', 0,0,110,110, $g2);
-&ok (&eq_array (\@list ,
- [ $rect22 , $rect21, $rect12, $rect11 ]),
- "find enclosed the 4 left up rectangles");
-
-@list = $zinc->find('ancestor', $rect33);
-&ok (&eq_array (\@list ,
- [ $g2 , $g1, 1 ]),
- "find ancestor of one rectangle");
-
-@list = $zinc->find('withtag', ".gr1.");
-#print "@list\n";
-&ok (&eq_array (\@list ,
- [ $g2, $text, ]),
- "find direct descendant of group tagged gr1");
-
-@list = $zinc->find('withtag', ".gr1*");
-#print "@list\n";
-&is_deeply ( [ @list ] ,
- [ $g2, ($zinc->find('withtag', ".gr1.gr2*"), $text ) ],
- "find all descendant of group tagged gr1");
-
-&is_deeply ( [ ($zinc->find('withtag', ".gr1.gr2*")) ],
- [ ($zinc->find('withtag', "*gr2*")) ],
- "comparing full pathtag and reduced pathtag to a group");
-
-&is_deeply ( [ ($zinc->find('withtag', ".gr1.gr2.middle")) ],
- [ ($zinc->find('withtag', "*gr2.middle")) ],
- "comparing full pathtag and reduced pathtag to a rectangle");
-
-&is_deeply ( [ ($zinc->find('withtag', ".gr1.gr2.middle")) ],
- [ ($zinc->find('withtag', "*middle")) ],
- "comparing full pathtag and reduced pathtag to a rectangle");
-
-&is_deeply ( [ ($zinc->find('withtag', ".gr1.gr2.middle")) ],
- [ ($zinc->find('withtag', "middle")) ],
- "comparing full pathtag and reduced pathtag to a rectangle");
-
-&is_deeply ( [ ($zinc->find('withtype', "group")) ],
- [ $g1, $g2 ],
- "find with type 'group'");
-
-&is_deeply ( [ ($zinc->find('withtype', "group", ".$g1.")) ],
- [ $g2 ],
- "find with type 'group' starting from g1");
-
-&is_deeply ( [ ($zinc->find('withtype', "group", ".$g1.")) ],
- [ ($zinc->find('withtype', "group", ".$g1*")) ],
- "find with type 'group' starting from g1");
-
-&is_deeply ( [ ($zinc->find('withtype', "rectangle")) ],
- [ $rect33, $rect32, $rect31, $rect23, $rect22, $rect21, $rect13, $rect12, $rect11, ],
- "find with type 'rectangle'");
-&is_deeply ( [ ($zinc->find('withtype', "rectangle", ".$g1*")) ],
- [ ($zinc->find('withtype', "rectangle")) ],
- "find with type 'rectangle' starting from .g1*");
-
-
-## testing overlapping find with atomic group (for testig the bug
-## reported by D. Etienne the 11th June 04
-$zinc->itemconfigure($g2, -atomic => 1);
-@list = $zinc->find('overlapping', 20,20,110,110);
-print "overlapping17 (",join (',', @list),") \$g2=$g2\n";
-&ok (&eq_array (\@list ,
- [ $g2 ]),
- "find overlapping when group becomes atomic, without specifying starting group");
-
-@list = $zinc->find('overlapping', 20,20,110,110,1);
-print "overlapping18 (",join (',', @list),") \$g2=$g2\n";
-&ok (&eq_array (\@list ,
- [ $g2 ]),
- "find overlapping when group becomes atomic, starting from group 1");
-
-@list = $zinc->find('overlapping', 20,20,110,110,1,1);
-&ok (&eq_array (\@list ,
- [ $g2 ]),
- "find overlapping when group becomes atomic, recursively, starting from group 1");
-
-
-## testing enclosing find with atomic group
-@list = $zinc->find('enclosed', 0,0,200,200);
-print "enclosing20 (",join (',', @list),") \$g2=$g2\n";
-&ok (&eq_array (\@list ,
- [ $g2 ]),
- "find enclosed when group becomes atomic, without specifying starting group");
-
-@list = $zinc->find('enclosed', 0,0,200,200, 1);
-print "enclosing21 (",join (',', @list),") \$g2=$g2\n";
-&ok (&eq_array (\@list ,
- [ $g2 ]),
- "find enclosed when group becomes atomic, starting from group 1");
-
-@list = $zinc->find('enclosed', 0,2,200,200, 1,1);
-print "enclosing22 (",join (',', @list),") \$g2=$g2\n";
-&ok (&eq_array (\@list ,
- [ $g2 ]),
- "find enclosed when group becomes atomic, recursively, starting from group 1");
-
-# Tk::MainLoop;
-
-
-
-sub wait {
- $zinc->update;
- ok (1, $_[0]);
-
- my $delay = $ARGV[0];
- if (defined $delay) {
- $zinc->update;
- if ($delay =~ /^\d+$/) {
- sleep $delay;
- } else {
- sleep 1;
- }
- }
-
-}
-
-
-
-diag("############## Images test");
diff --git a/Perl/t/test-methods.pl b/Perl/t/test-methods.pl
deleted file mode 100644
index 9becf7e..0000000
--- a/Perl/t/test-methods.pl
+++ /dev/null
@@ -1,689 +0,0 @@
-#!/usr/bin/perl -w
-# $Id$
-# This non-regression test has been developped by C. Mertz <mertz@cena.fr>
-
-use Tk;
-use Tk::Zinc;
-use Getopt::Long;
-use TestLog;
-
-use strict;
-
-use constant ERROR => '--an error--';
-
-
-# the following list be coherent with the treatments done in the TEST section.
-my @testsList = (
- 1 => 'test_contour_and_coords (quick)',
- 2 => 'test_forbidden_operations_on_root_group (quick)',
- 3 => 'test_errors (quick)',
- 4 => 'test_bboxes (quick)',
- 5 => 'test_gradient_coding (quick)',
- );
-my %testsHash;
-{ my @tests = @testsList;
- while (@tests) {
- my $num = shift (@tests);
- my $comment = shift (@tests);
- $testsHash{ $num } = $comment;
- }
-}
-
-unshift (@INC, "/usr/lib/perl5/Tk"); # for getting Tk some images;
-
-# les variables positionnées en fonction des options de la ligne de commande
-my $opt_log = 0;
-my $opt_trace = "";
-my $opt_render = -1;
-my $opt_type = 0;
-my $outfile;
-my $opt_tests = "all";
-
-# on récupère les options
-Getopt::Long::Configure('pass_through');
-my $optstatus = GetOptions('log=i' => \$opt_log,
- 'out=s' => \$outfile,
- 'trace=s' => \$opt_trace,
- 'render:s' => \$opt_render,
- 'type=s' => \$opt_type,
- 'help' => \&usage,
- 'tests:s' => \$opt_tests,
- );
-
-# on teste la validité de l'option -render!
-if ($opt_render eq '') {
- print "-render option have no value!\n";
- &usage;
-}
-$opt_render = 1 if $opt_render == -1;
-unless ($opt_render==0 or $opt_render==1 or $opt_render==2) {
- print "-render option value must be 0, 1 or 2!\n";
- &usage;
-}
-
-
-$outfile = "methods-$Tk::Zinc::VERSION.log" if (!defined $outfile);
-
-&openLog($outfile, $opt_log);
-
-sub usage {
- my ($text) = @_;
- print $text,"\n" if (defined $text);
- print "test-methods [options]\n";
- print " A non-regression test suite for zinc.\n";
- print " Some exhaustive test of TkZinc methods. Of course everything is not tested yet\n";
- print " options are:\n";
- print " -help to print this short help\n";
- print " -log <n> trace level, defaulted to 0; higher level trace more infos\n";
- print " -out filename the log filename. defaulted to methods-<version><-rendering>.log\n";
- print " NB: the previous log file is always renamed with a .prev suffix\n";
- print " -render 0|1|2 to select the render option of TkZinc (defaulted to 1)\n";
- print " -trace <an_item_option> to better trace usage of an option\n";
- print " -type <a_zinc_item_type> to limits tests to this item type.\n";
- print " -tests to get the list of available tests.\n";
- print " -tests i,j,k... to define the list of tests to pass.\n";
- exit;
-}
-
-my $mw = MainWindow->new();
-
-&log (0, "testing Zinc-perl Version=" . $Tk::Zinc::VERSION . " - ", $mw->zinc(), "\n");
-
-## must be done after the LOG file is open
-my @tests = &parseTestsOpt($opt_tests);
-my %tests;
-foreach my $t (@tests) {$tests{$t} = $t }
-
-
-# The explanation displayed when running this demo
-my $label=$mw->Label(-text => "This is a non-regression test, testing
-some sets of methods!",
- -justify => 'left')->pack(-padx => 10, -pady => 10);
-
-
-# Creating the zinc widget
-my $zinc = $mw->Zinc(-width => 500, -height => 500,
- -font => "10x20", # usually fonts are sets in resources
- # but for this example it is set in the code!
- -borderwidth => 0, -relief => 'sunken',
- -render => $opt_render,
- )->pack;
-
-&setZincLog($zinc);
-
-sub test_gradient_coding {
- &log (0, "#---- Start of test_gradient_coding ----\n");
- my $log_level = 2 ;
- ### CM to be done!
-
- ### first testing legal gradient
- foreach (0..2) {
- my $i=0;
- foreach my $g ("red", "bLue","#ff00ff","rgb:12/34/56","CIEXYZ:1.2/0.9/3.4",
- "CIEuvY:0.5/.4/0.9", "CIExyY:.52/0.1/0.8", "CIELab:99.1/43./56.1",
- "CIELuv:88/-1/-2.1", "TekHVC:345/1.2/100",
- ) {
- ## first simple color, with different X legal coding
- &test_eval ($log_level, "gname", $g,"grad".$i);
- $i++;
- ## the same color with transparency
- my $transparency = ($i * 4) % 101;
- &test_eval ($log_level, "gname", "$g;$transparency","grad".$i);
- $i++;
- }
-
- ## different axial gradient without the gradient type at the beginning
- foreach my $g ("red|blue", "red |blue", "red | blue",
- "red|green|blue", "red |green|blue", "red |green |blue", "red | green|blue"
- , "red |green| blue", "red |green | blue", "red | green | blue") {
- ## first simple color, with different X legal coding
- &test_eval ($log_level, "gname", $g,"grad".$i);
- $i++;
- }
- ## different axial gradient with explicit gradient type at the beginning
- ## and different angle value!
- foreach my $angle qw(0 12 90 271 360) {
- foreach my $g ("=axial $angle |red|blue",
- "=axial $angle | red|blue",
- "=axial $angle | red |blue",
- "=axial $angle | red | blue",
- "=axial $angle | red|green|blue",
- "=axial $angle |red |green|blue",
- "=axial $angle |red |green |blue",
- "=axial $angle |red | green|blue",
- "red |green| blue",
- "red |green | blue",
- "red | green | blue",
- ) {
- ## first simple color, with different X legal coding
- &test_eval ($log_level, "gname", $g,"grad".$i);
- $i++;
- }
- }
- # and now deleting unused named gradient
- foreach my $j (0..$i-1) {
- &test_eval ($log_level, "gdelete", "grad".$j);
- }
- }
-
- ### and now testing illegal gradient
- my $i=-1;
- &test_no_eval ("X color name with blank inside",
- $log_level, "gname", "navy blue","grad".$i++);
- &test_no_eval ("bad gradient type",
- $log_level, "gname", "=badtype 1 |red|blue","grad".$i++);
- &test_no_eval ("axial gradient with excessive parameters",
- $log_level, "gname", "=axial 67 1 |red|blue","grad".$i++);
- &test_no_eval ("radial gradient with excessive parameters",
- $log_level, "gname", "=radial 30 32 1 |red|blue","grad".$i++);
- &test_no_eval ("path gradient with excessive parameters",
- $log_level, "gname", "=path 30 32 1 |red|blue","grad".$i++);
- ## testing bad types for gradient type
- # to be done
- foreach my $j (0..$i-1) {
- &test_eval ($log_level, "gdelete", "grad".$j);
- }
-
- &log (0, "#---- End of test_gradient_coding -----\n");
-} # end of test_gradient_coding
-
-## TkZinc bbox method doesn't return correct values for bbox. This test
-# function tries to find out in which cases these bbox are wrong
-sub test_bboxes {
- &log (0, "#---- Start of test_bboxes ----\n");
- &creating_items; # to know exactly which items exists at the beginning of this test
-
- # Rectangles
- &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400]),
- [100,200,300,400], "a simple rectangle");
- &bbox_must_be($zinc->add('rectangle', 1, [300,400,100,200]),
- [100,200,300,400], "a simple reversed rectangle");
-
- # Rectangles with linewidth = 2, 3, 4 and 5
- &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400], -linewidth =>2),
- [100,200,300,400], "a simple rectangle with linewidth of 2");
- &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400], -linewidth =>3),
- [100,200,300,400], "a simple rectangle with linewidth of 3");
- &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400], -linewidth =>4),
- [100,200,300,400], "a simple rectangle with linewidth of 4");
- &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400], -linewidth =>5),
- [100,200,300,400], "a simple rectangle with linewidth of 5");
-
- # Rectangular curves
- &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ],
- -linewidth =>0),
- [100,200,300,400], "a rectangular curve of linewidth => 0");
- &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ]),
- [100,200,300,400], "a rectangular curve of linewidth => 1");
- &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ],
- -linewidth => 2),
- [100,200,300,400], "a rectangular curve of linewidth => 2");
- &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ],
- -linewidth => 3),
- [100,200,300,400], "a rectangular curve of linewidth => 3");
- &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ],
- -linewidth => 5),
- [100,200,300,400], "a rectangular curve");
-
- # triangular curves (with a sharp angle)
- &bbox_must_be($zinc->add('curve', 1, [ [0,0], [100,0], [0,10] ]),
- [0,0,100,10], "a triangular curve of linewidth => 1)");
-
- # Arcs
- &bbox_must_be($zinc->add('arc', 1, [100,200,300,400]),
- [100,200,300,400], "an arc");
- &bbox_must_be($zinc->add('arc', 1, [100,200,300,400], -linewidth => 2),
- [100,200,300,400], "an arc of linewidth => 2");
- &bbox_must_be($zinc->add('arc', 1, [100,200,300,400], -linewidth => 3),
- [100,200,300,400], "an arc of linewidth => 3");
-
-
- &log (0, "#---- End of test_bboxes -----\n");
-} # end of test_bboxes
-
-sub bbox_must_be {
- my ($item, $bbox_ref, $explanation) = @_;
- my @computed_bbox=$zinc->bbox($item);
- my @theoritical_bbox = @{$bbox_ref};
- unless (&equal_flat_arrays (\@theoritical_bbox, \@computed_bbox)) {
- &log(-10, "bad bbox of $explanation:\n ## computed = ", &printableArray(\@computed_bbox),
- " theoritical = ", &printableArray(\@theoritical_bbox), "\n");
- }
-} # end of bbox_must_be
-
-
-sub test_contour_and_coords {
- &log (0, "#---- Start of test_contour_and_coords ----\n");
- my $log_level = 2 ;
-
- $zinc->add('rectangle', 1, [ [100,200], [400,300] ], -tags => ['rect1']);
- my $contour_rect = [ [100,200], [100,300], [400,300], [400,200] ];
- my $rev_contour_rect = [ [100,200], [400,200], [400,300], [100,300] ];
-
- $zinc->add('rectangle', 1, [ 100,200, 400,300 ], -tags => ['rect2']);
- &verify_coords_of_contour ('eq','rect1', 'rect2', 0);
- &verify_coords_of_contour_points ('eq','rect1', 'rect2', 0);
-
-
- $zinc->add('arc', 1, [ [100,200], [400,300] ], -tags => ['arc1']);
- $zinc->add('arc', 1, [ 100,200, 400,300 ], -tags => ['arc2']);
- &verify_coords_of_contour ('eq','arc1', 'arc2', 0);
- &verify_coords_of_contour_points ('eq','arc1', 'arc2', 0);
-
- my $contour1 = [ [100,200], [400,300,'c'], [500,100], [350,10, 'c'], [300,500,'c'], [50,100] ];
- my $contour2 = [ 100,200, 400,300, 500,100, 350,10, 300,500, 50,100 ];
- my $contour3 = [ [100,200], [400,300], [500,100], [350,10], [300,500], [50,100]];
- $zinc->add('curve', 1, $contour1, -tags => ['curve1']);
- $zinc->add('curve', 1, $contour2, -tags => ['curve2']);
- $zinc->add('curve', 1, $contour3, -tags => ['curve3']);
- &verify_coords_of_contour ('ne','curve1', 'curve2', 0);
- &verify_coords_of_contour_points ('ne','curve1', 'curve2', 0);
-
- &verify_coords_of_contour ('eq','curve2', 'curve3', 0);
- &verify_coords_of_contour_points ('ne','curve2', 'curve3', 0);
-
- ## testing contours
- $zinc->add('curve', 1, [], -tags => ['curve_contour_0']);
- $zinc->add('curve', 1, [], -tags => ['curve_contour_plus']);
- $zinc->add('curve', 1, [], -tags => ['curve_contour_minus']);
- $zinc->contour('curve_contour_0','add',0, $contour1);
- $zinc->contour('curve_contour_plus','add',+1, $contour1);
- $zinc->contour('curve_contour_minus','add',-1, $contour1);
- &verify_coords_of_contour ('eq','curve1', 'curve_contour_0', 0);
- &verify_coords_of_contour ('ne','curve_contour_plus', 'curve_contour_minus', 0);
- if (&nequal_cplx_arrays ($zinc->coords('curve_contour_0',0),
- $zinc->coords('curve_contour_minus',0))) {
- &verify_coords_of_contour ('eq','curve1', 'curve_contour_plus', 0);
- } else {
- &verify_coords_of_contour ('eq','curve1', 'curve_contour_minus', 0);
- }
- $zinc->add('curve', 1, [], -tags => ['curve_contour_minus_plus']);
- $zinc->contour('curve_contour_minus_plus','add',1,
- [$zinc->coords('curve_contour_minus',0)]);
- &verify_coords_of_contour ('eq','curve1', 'curve_contour_minus_plus', 0);
-
- ## the following curves are similar, because the first contour is
- ## always set counterclockwise
- $zinc->add('curve', 1, $contour_rect, -tags => ['curve_rect_coords']);
- $zinc->add('curve', 1, $rev_contour_rect, -tags => ['curve_rect_coords_reversed']);
- &verify_coords_of_contour ('ne','curve_rect_coords', 'curve_rect_coords_reversed', 0); # we should test they are reversed
-
- $zinc->add('curve', 1, [], -tags => ['curve_rect_0']);
- $zinc->add('curve', 1, [], -tags => ['curve_rect_plus']);
- $zinc->add('curve', 1, [], -tags => ['curve_rect_minus']);
-
- ## the following lines are errors: we cannot add an item as contour with flag 0
- &test_no_eval ("adding a contour from a rectangle with flag=0",
- $log_level, "contour", 'curve_rect_0','add',0, 'rect1');
- &test_no_eval ("adding a contour from an arc with flag=0",
- $log_level, "contour", 'curve_rect_0','add',0, 'arc1');
-
- $zinc->contour('curve_rect_plus','add',1, 'rect1');
- $zinc->contour('curve_rect_minus','add',-1, 'rect1');
- &verify_coords_of_contour ('ne','curve_rect_plus', 'curve_rect_minus', 0);
- &verify_coords_of_contour ('eq','curve_rect_coords', 'curve_rect_plus', 0);
- &verify_coords_of_contour ('eq','curve_rect_coords_reversed', 'curve_rect_minus', 0);
-
- $zinc->add('tabular',1, 2, -tags => ['tabular1']);
- $zinc->add('track',1, 2, -tags => ['track1']);
- $zinc->add('waypoint',1, 2, -tags => ['waypoint1']);
- $zinc->add('reticle',1, -tags => ['reticle1']);
-
- ## we test now the following errors: we cannot use a track, waypoint, reticle, map as a contour
- &test_eval ($log_level, "contour", 'curve_rect_0','add',1, 'tabular1');
- &test_no_eval ("using the contour of a track",
- $log_level, "contour", 'curve_rect_0','add',1, 'track1');
- &test_no_eval ("using the contour of a waypoint",
- $log_level, "contour", 'curve_rect_0','add',1, 'waypoint1');
- &test_no_eval ("using the contour of a reticle",
- $log_level, "contour", 'curve_rect_0','add',1, 'reticle1');
-
- ## we test now the following errors: we cannot add a contour to track, waypoint, rectangle...
- &test_no_eval ("adding a contour to a track",
- $log_level, "contour", 'track1','add',1, 'rect1');
- &test_no_eval ("adding a contour to a waypoint",
- $log_level, "contour", 'waypoint1','add',1, 'rect1');
- &test_no_eval ("adding a contour to a rectangle",
- $log_level, "contour", 'rect1','add',1, 'rect2');
-
- &test_no_eval ("adding a contour with a malformed list",
- $log_level, "contour", 'curve_rect_0','add',1, [1]);
- &test_no_eval ("adding a contour with a malformed list",
- $log_level, "contour", 'curve_rect_0','add',1, [1, 2, 3]);
- &test_no_eval ("adding a contour with a malformed list",
- $log_level, "contour", 'curve_rect_0','add',1, [1, 2, 'c']);
- &test_no_eval ("adding a contour with a malformed list",
- $log_level, "contour", 'curve_rect_0','add',1, [1, 2, [3, 4] ]);
- &test_no_eval ("adding a contour with a malformed list",
- $log_level, "contour", 'curve_rect_0','add',1, [1, 2, [3, 4], [5, 6] ]);
-
- # we should test here what happens when successive points are identical in a curve
-
- # we should test here what happens when the last point is identical to the first point in a curve
-
- &log (0, "#---- End of test_contour_and_coords -----\n");
-} # end of test_contour_and_coords
-
-
-
-sub test_forbidden_operations_on_root_group {
- &log (0, "#---- Start of test_forbidden_operations_on_root_group ----\n");
- my $log_level = 2 ;
-
- my @all_items = $zinc->find('withtag',".1*");
- print "Items before deleting 1: @all_items\n";
- &test_no_eval ("removing the root group",
- $log_level, "remove", 1); ## cannot delete root group
- @all_items = $zinc->find('withtag',".1*");
- print "Items after deleting 1: @all_items\n";
- $zinc->add('group', 1, -tags => "g2");
- # cannot chggroup root group:
- &test_no_eval ("changing the group of the root group",
- $log_level, "chggroup", 1,"g2");
- # cannot clone root group
- &test_no_eval ("cloning the root group",
- $log_level, "clone", 1);
-
- &log (0, "#---- End of test_forbidden_operations_on_root_group -----\n");
-} # end of test_forbidden_operations_on_root_group
-
-
-### tests all errors as defined in the refman
-sub test_errors {
- &log (0, "#---- Start of test_errors ----\n");
- my $log_level = 2 ;
-
- &creating_items;
-
- ## add method with bad argument
- # In a curve, it is an error to have more than two succcessive control points
- # or to start or finish a curve with a control point.
- &test_no_eval ("having more than two succcessive control points",
- $log_level, "add", 'curve', 1,
- [ [10,20], [30,40,'c'], [50,60,'c'], [70,80,'c'], [90,100] ]);
- &test_no_eval ("starting a curve with a control point",
- $log_level, "add", 'curve', 1,
- [ [30,40,'c'], [50,60], [70,80], [90,100] ]);
- &test_no_eval ("finishing a curve with a control point",
- $log_level, "add", 'curve', 1,
- [ [30,40,], [50,60,'c'], [70,80], [90,100,'c'] ]);
-
- # Text indices
- # sel.first Refers to the first character of the selection in the item.
- # If the selection is not in the item, this form returns an error.
- &test_no_eval ("refering to sel.first in a text item without selection",
- $log_level, "insert", 'text', 'sel.first', "string");
- # sel.last Refers to the last character of the selection in the item.
- # If the selection is not in the item, this form returns an error.
- &test_no_eval ("refering to sel.last in a text item without selection",
- $log_level, "insert", 'text', 'sel.last', "string");
-
- # If no item is named by tagOrId or if the item doesn t support anchors,
- # an error is raised.
- &test_no_eval ("refering no item by tagOrId with anchorxy",
- $log_level, "anchorxy", 'bad_tag', 'rectangle');
-
- # If the item doesn't support anchors, an error is raised.
- &test_no_eval ("refering item that does not support anchors",
- $log_level, "anchorxy", 'rectangle', 'ne');
-
- # If the item doesn't support anchors, an error is raised.
- &test_no_eval ("refering a bad anchor name",
- $log_level, "anchorxy", 'text', 'not_an_anchor');
-
-# If the command parameter is omitted, bind returns the command associated
-# with tagOrId and sequence or an error is raised if there is no such binding.
- &test_no_eval ("refering a non-existing bindind with bind",
- $log_level, "bind", 'text', 'badseq');
-
-# $zinc->contour(tagOrId, operatorAndFlag, coordListOrTagOrId);
- # An error is generated if items are not of a correct type or if the
- # coordinate list is malformed.
- # tested in &test_contour_and_coords
-
-# If no items are named by tagOrId, an error is raised.
- &test_no_eval ("refering a non-existing item with hasanchors",
- $log_level, "hasanchors", 'badtag');
-
-# If no items are named by tagOrId, an error is raised.
- &test_no_eval ("refering a non-existing item with hasfields",
- $log_level, "hasfields", 'badtag');
-
- # If no items are named by tagOrId, an error is raised.
- &test_no_eval ("refering a non-existing item with hastag",
- $log_level, "hastag", 'badtag', 'atag');
-
- # If field is given, it must be a valid field index for the item or
- # an error will be reported.
- &test_no_eval ("accessing a non existing track field",
- $log_level, "itemcget", 'track', 111, -text);
-
- # If the attribute is not available for the field or item type,
- # an error is reported.
- &test_no_eval ("accessing a non existing curve attribute",
- $log_level, "itemcget", 'curve', -bad_attribute);
- &test_no_eval ("accessing a non existing attribute of a track field",
- $log_level, "itemcget", 'track', 1, -bad_attribute);
-
- # If field is given, it must be a valid field index for the item or an
- # error will be reported.
- &test_no_eval ("modifying a non existing track field",
- $log_level, "itemconfigure", 'track', 111, -text => "foo");
- # If an attribute does not belong to the item or field, an error is reported:
- &test_no_eval ("modifying a non existing curve attribute",
- $log_level, "itemconfigure", 'curve', -bad_attribute => "foo");
- &test_no_eval ("modifying a non existing attribute of a track field",
- $log_level, "itemconfigure", 'track', 1, -bad_attribute => "foo");
-
-# If tagOrId doesn t name an item, an error is raised.
- &test_no_eval ("lowering a non-existing item with lower",
- $log_level, "lower", 'badtag', 'track');
-# If belowThis doesn t name an item, an error is raised.
- &test_no_eval ("lowering an existing below an non-existing item with lower",
- $log_level, "lower", 'track', 'badtag');
-
-# If no items are named by tagOrId, an error is raised.
- &test_no_eval ("refering a non-existing item with numparts",
- $log_level, "numparts", 'badtag');
-
-# If tagOrId describes neither a named transform nor an item, an error is raised.
- &test_no_eval ("refering a non-existing item with rotate",
- $log_level, "rotate", 'badtag', 180);
-# If tagOrId describes neither a named transform nor an item, an error is raised.
- &test_no_eval ("refering a non-existing item with scale",
- $log_level, "scale", 'badtag', 2,2);
-# If tagOrId describes neither a named transform nor an item, an error is raised.
- &test_no_eval ("refering a non-existing item with translate",
- $log_level, "translate", 'badtag', 200,200);
-
- # If the given name is not found among the named transforms, an error is raised.
- &test_no_eval ("refering a non-existing named transform item with tdelete",
- $log_level, "tdelete", 'badNamedTransform');
-
-# ->transform ??
-
- # If tagOrId describes neither a named transform nor an item, an error is raised.
- &test_no_eval ("refering a non-existing named transform or item with treset",
- $log_level, "treset", 'badNamedTransform');
-
- # If tagOrId doesn t describe any item or if the transform named tName
- # doesn't exist, an error is raised.
- &test_eval ($log_level, "tsave", "text", "namedTransfrom");
- &test_no_eval ("refering a non-existing item with trestore",
- $log_level, "trestore", 'badTag', 'namedTransform');
- &test_no_eval ("refering a non-existing named transform with trestore",
- $log_level, "trestore", 'track', 'badNamedTransform');
-
- # If tagOrId doesn t describe any item, an error is raised.
- &test_no_eval ("refering a non-existing item with tsave",
- $log_level, "tsave", 'badTag', 'otherNamedTransform');
-
- # If no items are named by tagOrId, an error is raised.
- &test_no_eval ("refering a non-existing item with type",
- $log_level, "type", 'badTag');
-
- &log (0, "#---- End of test_errors -----\n");
-} # end of test_errors
-
-sub creating_items {
- # first removing all remaining items
- foreach my $tag qw(group track waypoint tabular text icon reticle map
- rectangle arc curve triangles window) {
- $zinc->remove($tag);
- }
- # and then creating items
- $zinc->add('group', 1, -tags => ['group']);
- $zinc->add('track', 1, 5, -position => [100,200], -tags => ['track']);
- $zinc->add('waypoint', 1, 5, -position => [200,100], -tags => ['waypoint']);
- $zinc->add('tabular', 1, 5, -position => [100,20], -tags => ['tabular']);
- $zinc->add('text',1, -tags => ['text']);
- $zinc->add('icon', 1, -tags => ['icon']);
- $zinc->add('reticle', 1, -tags => ['reticle']);
- $zinc->add('map', 1, -tags => ['map']);
- $zinc->add('rectangle', 1, [400,400 , 450,220], -tags => ['rectangle']);
- $zinc->add('arc', 1, [10,10 , 50,50], -tags => ['arc']);
- $zinc->add('curve', 1, [30,0 , 150,10, 100,110, 10,100, 50,140], -tags => ['curve']);
- $zinc->add('triangles', 1, [200,200 , 300,200 , 300,300, 200,300],
- -colors => ["blue;50", "red;20", "green;80"], -tags => ['triangles']);
- $zinc->add('window', 1, -tags => ['window']);
- foreach my $tag qw(group track waypoint tabular text icon reticle map
- rectangle arc curve triangles window) {
-# my $contour = $zinc->contour($tag);
-# print "$tag := $contour\n";
- }
-
-} # end creating_items
-
-
-sub verify_coords_of_contour {
- my ($predicat, $id1, $id2, $contour) = @_;
- my @contour1 = $zinc->coords($id1,$contour);
- my @contour2 = $zinc->coords($id2,$contour);
-# print "contour1: ", &printableArray (@contour1), "\n";
-# print "contour2: ", &printableArray (@contour2), "\n";
- my $res = &nequal_cplx_arrays (\@contour1, \@contour2);
-# print "res=$res\n";
- if ($predicat eq 'eq') {
- if ($res) {
- &log(-100, "coords of $id1($contour) and $id2($contour) are not equal:\n\t".
- &printableArray(@contour1)."\n\t".&printableArray(@contour2)."\n");
- } else {
- &log(1, " # coords of $id1($contour) and $id2($contour) are OK ($predicat)\n");
- }
- } elsif ($predicat eq 'ne') {
- if (!$res) {
- &log(-10, "coords of $id1($contour) and $id2($contour) should not be equal\n");
- } else {
- &log(1, " # coords of $id1($contour) and $id2($contour) are OK ($predicat)\n");
- }
- } else {
- &log(-100, "unknown predicat: $predicat\n");
- }
-} # end of verify_coords_of_contour;
-
-
-sub verify_coords_of_contour_points {
- my ($predicat, $id1, $id2, $contour) = @_;
- my @contour1 = $zinc->coords($id1,$contour);
-
- my $nequal=0;
- for (my $i = 0; $i < $#contour1; $i++) {
- my @coords1 = $zinc->coords($id1,0,$i);
- my @coords2 = $zinc->coords($id2,0,$i);
- my $res = &equal_flat_arrays ( \@coords1, \@coords2 );
- if ($predicat eq 'eq') {
- if (!$res) {
- &log(-100, "coords of $id1($contour,$i) and $id2($contour,$i) are not equal:\n\t$res");
- }
- } elsif ($predicat eq 'ne') {
- if (!$res) {
- $nequal=$res;
- last;
- }
- } else {
- &log(-100, "unknown predicat: $predicat\n");
- }
- }
- if ($predicat eq 'neq' and !$nequal) {
- &log(-100, "coords of $id1($contour,i) and $id2($contour,i) should not be all equal\n");
- } else {
- &log(1, " # coords of $id1($contour,i) and $id2($contour,i) are OK ($predicat)\n");
- }
-} # end of verify_coords_of_contour_points;
-
-
-sub parseTestsOpt {
- my ($opt) = @_;
- my @tests;
- if ($opt eq '') {
- print "Availables tests are:\n";
- while (@testsList) {
- my $i = shift @testsList;
- my $comment = shift @testsList;
- print "\t$i => $comment\n";
- }
- exit;
- } elsif ( $opt eq 'all' ) { ## default!
- &log (0, " # all tests will be passed through\n");
- @tests = sort keys %testsHash;
- } elsif ( $opt =~ /^\d+(,\d+)*$/ ) {
- @tests = split (/,/ , $opt);
- my $testnumb = (scalar @testsList) / 2;
- foreach my $test (@tests) {
- die "tests num must not exceed $testnumb" if $test > $testnumb;
- }
- &log(0, "Test to be done:\n");
- foreach my $test (@tests) {
- &log(0, "\t # $test => " . $testsHash{$test} . "\n");
- }
- } else {
- print "bad -tests value. Must be a list of integer separated by ,\n";
- &usage;
- }
- return @tests;
-} # end of parseTestsOpt
-
-# ---------- TEST ------------------
-# the following code must be coherent with the tests list described
-# on the very beginning of this file (see @testsList definition)
-
-if ($tests{1}) {
- &test_contour_and_coords ();
-}
-
-if ($tests{2}) {
- &test_forbidden_operations_on_root_group ();
-}
-
-if ($tests{3}) {
- &test_errors;
-}
-
-if ($tests{4}) {
- &test_bboxes;
-}
-
-if ($tests{5}) {
- &test_gradient_coding;
-}
-
-### we should also test multicontour curves
-if ($tests{5}) {
-# &test_coords;
-}
-
-# #### &test_fonts; ## and specially big fonts with render = 1;
-# #### &test_path_tags;
-# #### &test_illegal_tags;
-
-# #### &test_illegal_call
-# for example:
-# calling a methode for an non-existing item
-# getting coords, contours, fields, etc... of non-existing index
-#
-# cloning, deleting topgroup
-#
-
-&log (0, "#---- End of test_method ----\n");
-
-#MainLoop();
diff --git a/Perl/t/test-no-crash.pl b/Perl/t/test-no-crash.pl
deleted file mode 100644
index f1e22a6..0000000
--- a/Perl/t/test-no-crash.pl
+++ /dev/null
@@ -1,880 +0,0 @@
-#!/usr/bin/perl -w
-# $Id$
-# This non-regression / memory leak test has been developped by Christophe Mertz <mertz@intuilab.com>
-
-use Tk;
-use Tk::Zinc;
-use Getopt::Long;
-use TestLog;
-
-use strict;
-
-use constant ERROR => '--an error--';
-
-
-# the following list be coherent with the treatments done in the TEST section.
-my @testsList = (
- 1 => 'test_mapitems (quick)',
- 2 => 'test_every_field_attributes (long)',
- 3 => 'test_attributes (medium)',
- 4 => 'test_cloning (quick)',
- 5 => 'test_coords (quick)',
- );
-my %testsHash;
-{ my @tests = @testsList;
- while (@tests) {
- my $num = shift (@tests);
- my $comment = shift (@tests);
- $testsHash{ $num } = $comment;
- }
-}
-
-# les variables positionnées en fonction des options de la ligne de commande
-my $opt_log = 0;
-my $opt_trace = "";
-my $opt_render = -1;
-my $opt_type = 0;
-my $outfile;
-my $opt_tests = "all";
-my $opt_memoryleak = 0;
-
-# on récupère les options
-Getopt::Long::Configure('pass_through');
-my $optstatus = GetOptions('log=i' => \$opt_log,
- 'out=s' => \$outfile,
- 'trace=s' => \$opt_trace,
- 'render:s' => \$opt_render,
- 'type=s' => \$opt_type,
- 'help' => \&usage,
- 'memoryleak' => \$opt_memoryleak,
- 'tests:s' => \$opt_tests,
- );
-
-# on teste la validité de l'option -render!
-if ($opt_render eq '') {
- print "-render option have no value!\n";
- &usage;
-}
-$opt_render = 1 if $opt_render == -1;
-unless ($opt_render==0 or $opt_render==1 or $opt_render==2) {
- print "-render option value must be 0, 1 or 2!\n";
- &usage;
-}
-
-
-$outfile = "no-crash-$Tk::Zinc::VERSION.log" if (!defined $outfile);
-
-## in case of memoryleak test, logs are not written in a file
-## and logs are limited to high level logs on the standard output
-## (only those with a loglevel <= -1000 will be written on stdout)
-my $nolog_file = 0;
-if ($opt_memoryleak) {
- $opt_log = -1000;
- my $nolog_file = 1;
-}
-
-
-
-
-&openLog($outfile, $opt_log, $nolog_file);
-
-sub usage {
- my ($text) = @_;
- print $text,"\n" if (defined $text);
- print "test-no-crash [options]\n";
- print " A non-regression test suite for zinc.\n";
- print " Some exhaustive test of zinc. Of course everything is not tested yet\n";
- print " options are:\n";
- print " -help to print this short help\n";
- print " -log <n> trace level, defaulted to 0; higher level trace more infos\n";
- print " -out filename the log filename. defaulted to no-crash.log\n";
- print " NB: the previous log file is always renamed with a .prev suffix\n";
- print " -memoryleak to try to detect some memoryleak between first iteration of the test \n";
- print " and the following iteration. This test NEVER finish automatically\n";
- print " it is up to the tester to stop the memoryleak test after\n";
- print " a significative number of iterations\n";
- print " -render 0|1|2 to select the render option of zinc (defaulted to 1)\n";
- print " -trace <an_item_option> to better trace usage of an option\n";
- print " -type <a_zinc_item_type> to limits tests to this item type.\n";
- print " -tests to get the list of available tests.\n";
- print " -tests i,j,k... to define the list of tests to pass.\n";
- exit;
-}
-
-my $mw = MainWindow->new();
-
-&log (-1000, "#testing Zinc-perl Version=" . $Tk::Zinc::VERSION . " - ", $mw->zinc(), "\n");
-
-## must be done after the LOG file is open:
-
-my @tests = &parseTestsOpt($opt_tests);
-my %tests;
-foreach my $t (@tests) {$tests{$t} = $t }
-
-
-# The explanation displayed when running this demo
-my $label=$mw->Label(-text => "This is a non-regression test, testing that
-zinc is not core-dumping! It can also be used for detecting memory leaks",
- -justify => 'left')->pack(-padx => 10, -pady => 10);
-
-
-# Creating the zinc widget
-my $zinc = $mw->Zinc(-width => 500, -height => 500,
- -trackmanagedhistorysize => 10,
- -font => "10x20", # usually fonts are sets in resources
- # but for this example it is set in the code!
- -borderwidth => 0, -relief => 'sunken',
- -render => $opt_render,
- )->pack;
-
-&setZincLog($zinc);
-
-
-my %itemtypes;
-my @itemtypes = qw(arc tabular track waypoint
- curve rectangle triangles
- group icon map reticle text window
- );
-
-if ($opt_type) { @itemtypes = ($opt_type); }
-
-foreach my $type (@itemtypes) { $itemtypes{$type}=1 }
-
-#### some global variables needed as attributes values
-my ($text1, $text2, $text3, $text4);
-my ($image1, $image2, $image3, $image4);
-
-&creating_items ("unused");
-&verifying_item_completion;
-
-sub creating_items {
- # first removing all remaining items
- foreach my $item (&test_eval (1, 'find', 'withtag', 'all')) {
- &test_eval (1, "remove", $item);
- }
-
-
- my $labelformat = "x82x60+0+0 x60a0^0^0 x32a0^0>1 a0a0>2>1 x32a0>3>1";
- # and then creating items
- &test_eval (1, "add", 'group', 1);
- &test_eval (1, "add", 'group', 1);
- &test_eval (1, "add", 'icon', 1);
- &test_eval (1, "add", 'map', 1);
- &test_eval (1, "add", 'map', 1);
- &test_eval (1, "add", 'reticle', 1);
- $text1 = &test_eval (1, "add", 'text', 1, -position => [300,120], -text => "hello world1");
- $text2 = &test_eval (1, "add", 'text', 1, -position => [350,170], -text => "hello world2");
- $text3 = &test_eval (1, "add", 'text', 1, -position => [400,220], -text => "hello world3");
- &test_eval (1, "add", 'window', 1);
-# &test_eval (1, "add", 'track', 1, 5, -position => [100,200]);
- &test_eval (1, "add", 'track', 1, 5, -position => [100,200], -labelformat => $labelformat);
- &test_eval (1, "add", 'waypoint', 1, 5, -position => [200,100], -labelformat => $labelformat);
- &test_eval (1, "add", 'tabular', 1, 5, -position => [100,20], -labelformat => $labelformat);
- &test_eval (1, "add", 'group', 1);
-
- &test_eval (1, "mapinfo", 'mapinfo1', 'create');
- &test_eval (1, "mapinfo", 'mapinfo2', 'create');
- &test_eval (1, "mapinfo", 'mapinfo3', 'create');
-
-#$zinc->itemconfigure ('tabular', -labelformat => "200x10");
-#$zinc->update;
-
-
-
- &test_eval (1, "add", 'arc', 1, [10,10 , 50,50]);
- &test_eval (1, "add", 'curve', 1, [30,0 , 150,10, 100,110, 10,100, 50,140]);
- &test_eval (1, "add", 'rectangle', 1, [400,400 , 450,220]);
- &test_eval (1, "add", 'triangles', 1, [200,200 , 300,200 , 300,300, 200,300],
- -colors => ["blue;50", "red;20", "green;80"]);
-
- # images are initialised ONLY ONCE! (to avoid memoryleaks)
- $image1 = $zinc->Photo(-file => Tk::findINC("Tk/icon.gif") ) unless $image1;
- $image2 = $zinc->Photo(-file => Tk::findINC("Tk/Xcamel.gif") ) unless $image2;
- $image3 = $zinc->Photo(-file => Tk::findINC("Tk/tranicon.gif") ) unless $image3;
- $image4 = $zinc->Photo(-file => Tk::findINC("Tk/anim.gif") ) unless $image4;
-
- &creating_datas; # some of the data are using items!
-} # end creating_items
-
-# verifies that we create an item of every existing type
-sub verifying_item_completion {
- my @all_types = $zinc->add(); ## this use of add is not documented yet XXX!
- my @all_items = $zinc->find ('withtag', 'all');
- my %created_item_types;
- foreach my $item (@all_items) {
- $created_item_types{$zinc->type($item)} = 1;
- }
- foreach my $type (@all_types) {
- if (defined $created_item_types{$type}) {
- delete $created_item_types{$type};
- }
- else {
- &log(-100, "item type \"type\" which exist in Zinc is not tested!\n");
- }
- }
- foreach my $type (sort keys %created_item_types) {
- &log(-100, "This tested item type \"$type\" is supposed not to exist in Zinc!\n");
- }
-}
-
-
-my %options;
-my %types;
-
-
-foreach my $itemType (@itemtypes) {
- my ($anItem) = $zinc->find('withtype', $itemType);
- if (!defined $anItem) { &log (-10, "no item $itemType\n"); next;};
- my @options = $zinc->itemconfigure($anItem);
- foreach my $elem (@options) {
- my ($optionName, $optionType, $readOnly, $empty, $optionValue) = @$elem;
- $options{$itemType}{$optionName} = [$optionType, $readOnly, $empty, $optionValue];
- $types{$optionType} = 1;
- }
-}
-
-my %fieldOptions;
-
-{
-my ($aTrack) = $zinc->find('withtype', 'track');
-if (!defined $aTrack) { &log (-10, "no item track\n") }
-else {
- my @fieldOptions = $zinc->itemconfigure($aTrack, 0);
- for my $elem (@fieldOptions) {
- my ($optionName, $optionType, $readOnly, $empty, $optionValue) = @$elem;
- $fieldOptions{$optionName} = [$optionType, $readOnly, $empty, $optionValue];
- $types{$optionType} = 1;
- }
-}
-}
-
-foreach my $type (sort keys %types) {
-# print "$type\n";
-}
-
-# a hash giving samples of valid data for attributes types
-my %typesValues;
-
-# the following hash associated to types valid value that should be all different from
-# default value and from value initiated when creating items (see up...)
-my %typesNonStandardValues;
-
-# a hash giving samples of NOT valid data for attributes types
-my %typesIllegalValues;
-
-sub creating_datas {
- return if defined $typesValues{'alignment'};
- %typesValues =
- ('alignment' => ['left', 'right', 'center'],
- 'alpha' => [0, 50, 100, 23],
- 'anchor' => ['n', 's', 'e', 'w', 'nw', 'ne', 'sw', 'se', 'center'],
- 'angle' => [0, 90, 180, 270, 360, 12, 93, 178, 272, 359],
- 'autoalignment' => ['lll', 'llr', 'llc', 'lrl', 'lrr', 'lrc', 'lcl', 'lcr', 'lcc',
- 'rll', 'rlr', 'rlc', 'rrl', 'rrr', 'rrc', 'rcl', 'rcr', 'rcc',
- 'cll', 'clr', 'clc', 'crl', 'crr', 'crc', 'ccl', 'ccr', 'ccc',
- '-',],
- 'boolean' => [0..1],
- 'bitmap' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], ####?!
- 'bitmaplist' => [['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], ['AlphaStipple0']], ##TBC
- 'capstyle' => ['butt', 'projecting', 'round'],
- 'gradient' => ['green', 'LemonChiffon', '#c84', '#4488cc', '#888ccc444', 'red'], ## TBC
- 'gradientlist' => [['green'], ['LemonChiffon'], ['#c84'], ['#4488cc'], ['#888ccc444'],
- ['red', 'green'], ['red', 'green', 'blue'],
- ['red;50', 'green;50', 'blue;50'],
- ['blue;0', 'green;50', 'red;90'],
- ], ## TBC
- 'dimension' => [0..5, 10, 50, 100, 0.0, 5.5, 100.5, 4.5], ## and floats ?!
- 'edgelist' => ['left', 'right', 'top', 'bottom', 'contour', 'oblique', 'counteroblique'], ## +combinations!
- 'filerule', => ['odd', 'negative','positive', 'abs_ge_eq2'],
- 'font' => ['10x20', '6x10', '6x12', '6x13'],
- 'image' => [$image1, $image2, $image3], ## TBC
- 'integer' => [-10000, -100, -1, 0, 1, 10, 10000], ## pour quoi?
- 'item' => [$text1, $text2],
- 'joinstyle' => ['bevel', 'miter', 'round'],
- 'labelformat' => ["200x10", ## BUG BUG
-# "200x100 x100x20+0+0 x100x20+0+20 x200x40+100+20"
- ],
- 'leaderanchors' => ["%10x30", "|0|0", "%40x20", "|1|1", "|100|100", "%67x21" ], ## TBC! non exchaustif!! BUG non conforme à la doc
- # illegal et fait planter: "%50"
- 'lineend' => [ [10,10,10], [10,100,10], [100,10,10], [10,10,100], [100,10,100] ],
- 'lineshape' => ['straight', 'rightlightning', 'leftlightning', 'rightcorner', 'leftcorner', 'doublerightcorner', 'doubleleftcorner'],
- 'linestyle' => ['dotted', 'simple', 'dashed', 'mixed', 'dotted'],
- 'mapinfo' => ['mapinfo1','mapinfo2','mapinfo3'], ## TBC
-# 'number' => [2.3, 1.0, 5.6, 2.1],
- 'point' => [ [0,0] , [10,10], [20,20], [30,30], [20,20], [0,0] , [10,10] ],
- 'priority' => [ 1, 10, 50, 1000, 10000 ], # positif ou nul
- 'relief' => ['flat', 'groove', 'raised', 'ridge', 'sunken',
- 'roundraised', 'roundsunken', 'roundgroove',
- 'roundridge', 'sunkenrule', 'raisedrule'],
- 'string' => ['teststring', 'short', 'veryverylongstring'],
- 'taglist' => [ [1], [1..2], ['a','b'], ['tag1','tag2','tag3']],
- 'unsignedint' => [ 0..5 , 10, 20, 30, 100 ],
- 'window' => [], ## TBC
- );
-
-# the following valid value associated to types should be all different from
-# default value and from value initiated when creating items (see up...)
- %typesNonStandardValues =
- ('alignment' => 'right',
- 'alpha' => 50,
- 'anchor' => 'w',
- 'angle' => 45,
- 'autoalignment' => 'llc',
- 'bitmap' => 'AlphaStipple14',
- 'bitmaplist' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'],
- 'capstyle' => 'butt',
- 'gradient' => 'LemonChiffon',
- 'gradientlist' => ['red;50', 'green;50', 'blue;50'],
- 'dimension' => 45,
- 'edgelist' => 'contour',
- 'font' => '6x10',
- 'fillrule' => 'nonzero',
- 'image' => $image4,
- 'integer' => 7,
- 'item' => $text3,
- 'joinstyle' => 'miter',
- 'labelformat' => "200x30", ## BUG BUG
- 'leaderanchors' => "%10x45", ## BUG BUG
- 'lineend' => [13,7,20],
- 'lineshape' => 'rightlightning',
- 'linestyle' => 'dotted',
- 'mapinfo' => 'mapinfo2', ## TBC
- 'number' => 7.6,
- 'point' => [100,100],
- 'priority' => 50,
- 'relief' => 'groove',
- 'string' => 'notsoshort',
- 'taglist' => ['tag1','tag11','tag111'],
- 'unsignedint' => 7, # 22, # 22 is to high for -visiblehistorysize and 5 is, the default value for reticle -period
- 'window' => undef, ### TBC
- );
-
- %typesIllegalValues =
- ('alpha' => [0..100],
- 'anchor' => ['n', 's', 'e', 'w'], ##TBC
- 'angle' => [0..360],
- 'boolean' => [0..1],
- 'capstyle' => [],
- 'dimension' => [0..100],
- 'font' => ['10x20', '6x10', '6x12', '6x13'],
- 'leaderanchors' => ["%50" ], ## TBC! non exchaustif!! BUG non
- 'relief' => ['flat', 'groove', 'raised', 'ridge', 'sunken',
- 'roundraised', 'roundsunken', 'roundgroove',
- 'roundridge', 'sunkenrule', 'raisedrule'],
- );
-}
-
-$mw->Button(-text => "Exit",
- -command => sub { exit },
- )->pack(-pady => 4);
-
-sub test_attributes {
- &log (-1000, "#---- Start of test_attributes ----\n");
- foreach my $type (@itemtypes) {
- my @items = $zinc->find('withtype', $type);
- &log (0, "#--------- Testing ", (1+$#items), " ",$type," attributes ----------------\n");
- if ($#items == -1) {
- &log (-100, "No such item: $type\n");
- next;
- }
- &log(0,"no such type '$type'\n"), next unless defined $options{$type};
-# print $options{$type}, "\t\t", %{$options{$type}}, "\n";
- my %theoptions = %{$options{$type}};
- foreach my $item (@items) {
- ## il faudrait tester les options selon un ordre défini à l'avance
- ## en passant par plusieurs occurences pour les options et en forçant
- ## certaines valeurs, par exemple les valeurs booléennees... (visible/sensible/filled)
- my @boolean_attributes;
- my %boolean_attributes;
- foreach my $option (sort keys %theoptions) {
- my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}};
- if ($optionType eq 'boolean') {
- next if $option eq -composerotation;
- next if $option eq -composescale;
- next if $option =~ /-\w+sensitive/ ; # to get rid of many track options!
- next if $option =~ /-filled\w+/ ; # to get rid of many track options!
- next if $option =~ /-speed\w+/ ; # to get rid of many track options!
- next if $option =~ /-\w+history/ ; # to get rid of many track options!
- push @boolean_attributes, $option;
- $boolean_attributes{$option}=1;
- }
- }
- &log (0, "# $type (id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n"));
- foreach my $i (0 .. (2**(1+$#boolean_attributes) -1) ) {
- my $format = "%0" . ($#{boolean_attributes} +1) . "b";
- my $binary = sprintf ($format,$i);
- &log (0, "# $i/", (2**(1+$#boolean_attributes)), " $binary\n");
- my @binary = split (//,$binary);
- foreach my $j (0 .. $#boolean_attributes) {
- &test_eval (0, "itemconfigure", $item, $boolean_attributes[$j] => $binary[$j] );
-# &log (0, "setting $type ($item) ", $boolean_attributes[$j], " to ", $binary[$j], "\n");
- }
- foreach my $option (sort keys %theoptions) {
- next if ($option eq -numfields); # BUG? makes the appli stop
- next if ($option eq "-clip" and $type = "group"); # BUG? This test cannot be random clipping item must belong to the group
- next if ($boolean_attributes{$option}); # skipping boolean attributes which are exhaustively tested
-
- my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}};
- my $typeValues = $typesValues{$optionType};
- if (!defined $typeValues) {&log (-100, "No values for type $optionType (option $option)\n");next;}
- my @values = @{$typeValues};
-
- if (!@values) {&log (-100, "No values for type $optionType (option $option)\n");next;}
-
-
- my $valueRef = ref ($values[0]);
- my $previous_val;
- my @previous_val;
-
- if ($valueRef eq '') {
- $previous_val = $zinc->itemcget($item, $option);
- }
- else {
- @previous_val = $zinc->itemcget($item, $option);
- }
- &log (1, "#** itemconfigure of $item ($type), $option => ",&printableList (@values),"\n");
- my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType ) ? 0 : 2 ;
- foreach my $value (@values) {
- &test_eval ($log_lev, "itemconfigure", $item, $option => $value);
- $zinc->update;
- $zinc->after(10);
- }
-
- if ($valueRef eq '') {
- &test_eval ($log_lev, "itemconfigure", $item, $option => $previous_val);
- }
- else {
- &test_eval ($log_lev, "itemconfigure", $item, $option => \@previous_val);
- }
-
- }
- }
- }
- }
- &log (0, "#---- End of test_attributes ----\n");
-} # end test_attributes
-
-
-# test2: configurer les fields des track / waypoint / tabular
-# jouer avec les labelformats
-
-# test3: tester toutes les fonctions aléatoirement selon les signatures
-
-
-# test4: tester qu'en clonant on obtient bien une copie de tous les attributs
-
-sub test_cloning {
- &log (-1000, "#---- Start of test_cloning ----\n");
- &creating_items;
- foreach my $type (@itemtypes) {
- my ($item) = $zinc->find('withtype', $type);
- &log (0, "#--------- Cloning and testing item ",$type," $item ----------------\n");
- if (!defined $item) { &log (-10, "No such item: $type\n"); next;};
- my $clone = &test_eval(1, "clone", $item);
-
- &log (0, "#---- Modifying the clone $clone\n");
- &test_a_clone ($type, $item, $clone);
- &test_enclosed_overlapping_closest($type, 'original', $item, $zinc->bbox ($item));
- &test_enclosed_overlapping_closest($type, 'clone', $clone, $zinc->bbox ($clone));
- &log (0, "#---- Modifying the original\n");
- &test_a_clone ($type, $clone, $item);
- &test_enclosed_overlapping_closest($type, 'original', $item, $zinc->bbox ($item));
- &test_enclosed_overlapping_closest($type, 'clone', $clone, $zinc->bbox ($clone));
- &log (0, "#---- Deleting the original\n");
- &test_eval (1, "remove", $item);
- &test_every_attributes_once($type,$clone);
- &log (0, "#---- Deleting the clone\n");
- &test_eval (1, "remove", $clone);
- }
- # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
- # tester le closest avec le centre de la bbox
-
- # faire la même chose que juste avant, mais en interchangeant clone et original
- # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
- # tester le closest avec le centre de la bbox
-
- # supprimer l'item original
-
- # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
- # tester le closest avec le centre de la bbox
-
- # modifier tous les attributs du clone
- # supprimer le clone
-
- # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
- # tester le closest avec le centre de la bbox
-
- &log (0, "#---- End of test_cloning ----\n");
-} # end test_cloning
-
-## teste le find enclosed / overlapping avec un rectangle un peu plus grand
-# que la bbox donnée en paramètre.
-# si $item est différent de '', vérifie que l'item est enclosed/overlapping
-## Vérifie aussi le fonctionnement ud closest pour le centre de la bbox
-sub test_enclosed_overlapping_closest {
- my ($type, $clone_or_original, $item, @bbox) = @_;
- if ($#bbox == -1) {
- &log(-100, "Undef bbox of a $type ($clone_or_original)\n");
- }
- else {
- @bbox = ( $bbox[0]-10, $bbox[1]-10, $bbox[2]+10, $bbox[3]+10 );
- my @items = &test_eval (1, "find", 'enclosed', @bbox);
- goto TESTOVERLAPPING if ($item eq '');
- foreach my $i (@items) {
- goto TESTOVERLAPPING if ($i eq $item); # the item is included!
- }
- &log(-100, "The $type ($clone_or_original) is not enclosed in its bbox!\n");
- TESTOVERLAPPING:
-# @items = $zinc->find ('overlapping', @bbox);
- @items = &test_eval (1, "find", 'overlapping', @bbox);
- goto TESTCLOSEST if ($item eq '');
- foreach my $i (@items) {
- goto TESTCLOSEST if ($i eq $item);
- }
- &log(-100, "The $type ($clone_or_original) is not overlapping its bbox!\n");
- TESTCLOSEST:
- my $x = ($bbox[0] + $bbox[2] )/2;
- my $y = ($bbox[1] + $bbox[3] )/2;
-# my $closest = $zinc->find ('closest', $x,$y);
- my $closest = &test_eval (1, "find", 'closest', $x,$y);
- }
-} # end test_enclosed_overlapping_closest
-
-sub test_a_clone {
- my ($type, $original, $clone) = @_;
- my %theoptions = %{$options{$type}};
- foreach my $option (sort keys %theoptions) {
- next if ($option eq -numfields); # BUG? makes the appli stop
- next if ($option eq "-clip" and $type = "group"); # BUG? This test cannot be random. Clipping item must belong to the group
- next if ($option eq '-connecteditem'); ## XXX this test should be corrected implemented,
- my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}};
- my $value = $typesNonStandardValues{$optionType};
- if ($optionType ne 'boolean' && !defined $value) {
- &log (-100, "No value for type $optionType (option $option)\n");
- next;
- }
-
- my $valueRef = ref ($value);
- my $previous_val;
- my @previous_val;
-
- # memoryzing previous value of the clone
- if ($valueRef eq '') {
- $previous_val = &test_eval (2, "itemcget", $clone, $option);
- }
- else {
- @previous_val = &test_eval (2, "itemcget", $clone, $option);
- }
-
- # in the case of boolean, we must always take the not value:
- if ($optionType eq 'boolean') { $value = !$previous_val }
-
- my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ;
- &test_eval ($log_lev, "itemconfigure", $clone, $option => $value);
- $zinc->update;
-
- if ($valueRef eq 'ARRAY') { # the value is a list
- my @original_value = &test_eval (2, "itemcget", $original, $option);
- my @clone_value = &test_eval (1, "itemcget", $clone, $option);
- if ( &equal_flat_arrays (\@original_value, \@clone_value) ) {
- &log (-100, "Modified cloned $type gets the same value for $option (type $optionType) ". &printableArray(@original_value) . "\n");
- }
- }
- else { # the value is either a scalar or a class instance
- my $original_value = &test_eval (2, "itemcget", $original, $option);
- my $clone_value = &test_eval (2, "itemcget", $clone, $option);
- if (defined $original_value && $original_value eq $clone_value) {
-# print "ORIGIN = ",$original_value, " $original_value CLONE = ",$clone_value,"\n";
- &log (-100, "Modified cloned $type gets the same value for $option (type $optionType) " .
- "(original=cloned: " . &printableItem($original_value) .
- "?=" . &printableItem($previous_val) .
- " :previous)\n");
- }
- }
-
- # setting back the previous value
- if ($valueRef eq '') {
- &test_eval (1, "itemconfigure", $clone, $option => $previous_val);
- }
- else {
- &test_eval (1, "itemconfigure", $clone, $option => \@previous_val);
- }
-
- }
-} # end test_a_clone
-
-sub test_every_attributes_once {
- my ($type, $item) = @_;
- my %theoptions = %{$options{$type}};
- foreach my $option (sort keys %theoptions) {
- next if ($option eq -numfields); # BUG? makes the appli stop
- next if ($option eq "-clip" and $type = "group"); # BUG? This test cannot be random. Clipping item must belong to the group
- next if ($option eq '-connecteditem'); ## XXX this test should be corrected implemented,
- my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}};
- my $value = $typesNonStandardValues{$optionType};
- if ($optionType ne 'boolean' && !defined $value) {
- &log (-100, "No value for type $optionType (option $option)\n");
- next;
- }
- # in the case of boolean, we must always take the not value:
- if ($optionType eq 'boolean') { $value = !$zinc->itemcget($item, $option) }
-
- my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ;
- &test_eval ($log_lev, "itemconfigure", $item, $option => $value);
- $zinc->update;
- }
-} # end test_every_attributes_once
-
-
-sub test_every_field_attributes {
- &log (-1000, "#---- Start of test_every_field_attributes ----\n");
- foreach my $type qw(waypoint track tabular) {
- next unless $itemtypes{$type};
- my %theoptions = %fieldOptions;
- my @items = $zinc->find('withtype', $type);
- &log (0, "#--------- Testing field attributes of ", (1+$#items), " ",$type,"(s) ----------------\n");
- if ($#items == -1) {
- &log (-100, "No such item: $type\n");
- next;
- }
- foreach my $item (@items) {
- ## il faudrait tester les options selon un ordre défini à l'avance
- ## en passant par plusieurs occurences pour les options et en forçant
- ## certaines valeurs, par exemple les valeurs booléennees... (visible/sensible/filled)
- my @boolean_attributes;
- my %boolean_attributes;
- foreach my $option (sort keys %theoptions) {
- my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}};
- if ($optionType eq 'boolean') {
-# next if $option =~ /-\w+sensitive/ ; # to get rid of many track options!
-# next if $option =~ /-filled\w+/ ; # to get rid of many track options!
-# next if $option =~ /-speed\w+/ ; # to get rid of many track options!
-# next if $option =~ /-\w+history/ ; # to get rid of many track options!
- push @boolean_attributes, $option;
- $boolean_attributes{$option}=1;
- }
- }
- &log (0, "# $type (id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n"));
- foreach my $i (0 .. (2**(1+$#boolean_attributes) -1) ) {
- my $format = "%0" . ($#{boolean_attributes} +1) . "b";
- my $binary = sprintf ($format,$i);
- &log (0, "# $i/", (2**(1+$#boolean_attributes)), " $binary\n");
- my @binary = split (//,$binary);
- foreach my $j (0 .. $#boolean_attributes) {
- &log (0, "# setting $type ($item) field 0..",$zinc->itemcget($item, -numfields)-1, " ", $boolean_attributes[$j], " to ", $binary[$j], "\n");
- foreach my $field (0 .. $zinc->itemcget($item, -numfields)-1 ) {
- &test_eval (1, "itemconfigure", $item, $field, $boolean_attributes[$j] => $binary[$j] );
- }
- }
- foreach my $field (0 .. $zinc->itemcget($item, -numfields)-1 ) {
- foreach my $option (sort keys %theoptions) {
- next if ($boolean_attributes{$option}); # skipping boolean attributes which are exhaustively tested
-
- my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}};
-
- my $typeValues = $typesValues{$optionType};
- if (!defined $typeValues) {&log (-100, "No values for type $optionType (option $option)\n");next;}
- my @values = @{$typeValues};
-
- if (!@values) {&log (-100, "No values for type $optionType (option $option)\n");next;}
-
-
- my $valueRef = ref ($values[0]);
- my $previous_val;
- my @previous_val;
-
- if ($valueRef eq '') {
- $previous_val = &test_eval (1, "itemcget", $item, $field, $option);
- }
- else {
- @previous_val = &test_eval (1, "itemcget", $item, $field, $option);
- }
- &log (1, "#** itemconfigure ($item ($type), $field, $option => ",&printableList (@values),"\n");
- foreach my $value (@values) {
- my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ;
- &test_eval ($log_lev, "itemconfigure", $item, $field, $option => $value);
- $zinc->update;
- $zinc->after(10);
- }
-
- if ($valueRef ne 'ARRAY') {
- &test_eval (1, "itemconfigure", $item, $field, $option => $previous_val);
- }
- else {
- &test_eval (1, "itemconfigure", $item, $field, $option => \@previous_val);
- }
-
- }}
- }
- }
- }
- &log (0, "#---- End of test_every_field_attributes ----\n");
-} # end test_every_field_attributes
-
-
-sub createMapInfo {
- my ($name, $N,$deltaN, $radius, $centerX,$centerY) = @_;
- &test_eval (1, "mapinfo", $name, 'create');
-
- my @lineTypes=(qw/simple dashed dotted mixed marked/),
- my $deltaAngle=6.283/$N;
- for (my $i = 0; $i < $N; $i++) {
- my $x1 = $centerX + $radius * sin($i * $deltaAngle);
- my $y1 = $centerY + $radius * cos($i * $deltaAngle);
- my $x2 = $centerX+ $radius * sin( ($i + $deltaN) * $deltaAngle);
- my $y2 = $centerY + $radius * cos( ($i + $deltaN)* $deltaAngle);
- my $linetype = $lineTypes[$i%5];
- $mw->mapinfo($name, 'add', 'line', $linetype, 1+$i%3, +$x1,$y1,$x2,$y2);
- }
-} # end of createMapInfo
-
-sub test_mapitems {
- my @mapinfoNames = @_;
- &log (-1000, "#---- Start of test_mapitems ----\n");
- my @maps = $zinc->find('withtype', 'map');
- my $counter=0;
- foreach my $map (@maps) {
- &test_eval (1, "itemconfigure", $map, -mapinfo => $mapinfoNames[$counter]);
- if ($counter == $#maps) { $counter=0 }
- $counter++;
- }
- &log (0, "#---- End of test_mapitems ----\n");
-} # end test_mapitems
-
-## testing the returned value of coords
-sub test_coords {
- &log (-1000, "#---- Start of test_coords ----\n");
- foreach my $it ($zinc->find('withtag','*')) {
- $zinc->remove($it);
- }
- ## creationg again items
- &creating_items;
- foreach my $type ($zinc->add()) {
- next if $type eq 'map'; ## map item does not support coords method
- my ($it) = $zinc->find('withtype',$type);
- my @coordsAll= &test_eval (1, "coords", $it);
- my $coordsAll = &printableArray(@coordsAll);
- &log (1, "=> $coordsAll\n");
- my @coordsContour= &test_eval (1, "coords", $it,0); # all items have 1 contour
- my $coordsContour = &printableArray(@coordsContour);
- &log (1,"=> $coordsContour\n");
- my @coordsPoint= &test_eval (1, "coords", $it,0,0); # all items have 1 contour with at least one point
- my $coordsPoint = &printableArray(@coordsPoint);
- &log (1,"=> $coordsPoint\n");
- }
- &log (0, "#---- End of test_coords ----\n");
-}
-
-sub parseTestsOpt {
- my ($opt) = @_;
- my @tests;
- if ($opt eq '') {
- print "Availables tests are:\n";
- while (@testsList) {
- my $i = shift @testsList;
- my $comment = shift @testsList;
- print "\t$i => $comment\n";
- }
- exit;
- } elsif ( $opt eq 'all' ) { ## default!
- &log (0, "# all tests will be passed through\n");
- @tests = sort keys %testsHash;
- } elsif ( $opt =~ /^\d+(,\d+)*$/ ) {
- @tests = split (/,/ , $opt);
- my $testnumb = (scalar @testsList) / 2;
- foreach my $test (@tests) {
- die "tests num must not exceed $testnumb" if $test > $testnumb;
- }
- &log(0, "# Tests to be done:\n");
- foreach my $test (@tests) {
- &log(0, "\t# $test => " . $testsHash{$test} . "\n");
- }
- } else {
- print "bad -tests value. Must be a list of integer separated by ,\n";
- &usage;
- }
- return @tests;
-} # end of parseTestsOpt
-
-
-
-# ---------- TEST ------------------
-# the following code must be coherent with the tests list described
-# on the very beginning of this file (see @testsList definition)
-
-&createMapInfo ('firstmap', 50, 20, 200, 200, 300);
-&createMapInfo ('secondmap', 12, 3, 200, 300, 50);
-
-sub theTest {
- if ($tests{1}) {
- &test_mapitems ('firstmap', 'secondmap'); # should be done before really testing map items attributes
- }
- # #### &test_labelcontent; # should be done before really testing track/waypoint/tabular items attributes
-
- if ($tests{2}) {
- &test_every_field_attributes;
- }
-
- if ($tests{3}) {
- &test_attributes; # on peut configurer tous les attributs
- }
-
- ### we SHOULD test that setting a bad type value ofr an option does not core dump zinc!
-
- if ($tests{4}) {
- &test_cloning; # we test that cloning items and modifiyng/removing them does not core dump
- }
-
- ### we should also test multicontour curves
- if ($tests{5}) {
- &test_coords;
- }
-
-# #### &test_fonts; ## and specially big fonts with render = 1;
-# #### &test_path_tags;
-# #### &test_illegal_tags;
-
-# #### &test_illegal_call
-# for example:
-# calling a method for an non-existing item
-# getting coords, contours, fields, etc... of non-existing index
-#
-# cloning, deleting topgroup
-#
-}
-
-sub getMemoryUsage {
- open (PROC, "/proc/$$/status");
- my ($totalMemory,$dataMemory);
- while (<PROC>) {
- if (/^VmSize:\s+(\d+)/) {
- $totalMemory = $1;
- }
- elsif (/^VmData:\s+(\d+)/) {
- $dataMemory = $1;
- last;
- }
- }
- close PROC;
- return ($totalMemory,$dataMemory);
-}
-
-
-
-if ($opt_memoryleak) {
- my $iteration = 0;
- while (1) {
- my ($total,$data) = &getMemoryUsage;
- ## get here the current memory state
- &log(-1000, "#---- MemoryState iteration=$iteration totalMemory=$total dataMemory=$data ----\n");
- $iteration++;
- &theTest;
- }
-} else {
- &theTest;
-}
-
-
-&log (0, "#---- End of test_no_crash ----\n");
-
-MainLoop();
diff --git a/Perl/t/testdoc.pl b/Perl/t/testdoc.pl
deleted file mode 100644
index 590774f..0000000
--- a/Perl/t/testdoc.pl
+++ /dev/null
@@ -1,274 +0,0 @@
-#!/usr/bin/perl -w
-# $Id$
-# This script verifies the conformity of the reference manual with
-# some types informations available inside ZincTk
-# It has been developped by C. Mertz <mertz@cena.fr>
-
-# limitations: this script makes some very strong assumptions
-# on the latex Zinc reference manual formating!
-# However if the formating changes, it should be
-# simple to modify the &scanDoc function!
-#
-# What this script currently does:
-# - verifies that all Zinc options are documented
-# - verifies that all items attributes (and their type) are documented
-# - verifies that all field attributes options (and their type) are documented
-# - verifies that all documented options and attributes really exists
-# - verifies that all documented types are refered to in the doc
-# It also checks that options, attributes and types are documented in alphabetical order
-# It is heavily based on meta information available directly from zinc
-#
-# How to use it:
-# testdoc.pl path_to_refman.tex
-
-use Tk;
-use Tk::Zinc;
-
-use strict;
-
-print "------- Testing conformity of refman.tex and meta-information from zinc Version $Tk::Zinc::VERSION\n";
-
-my $mw = MainWindow->new();
-
-# Creating the zinc widget
-# NB: this widget will not be displayed! It is only used for creating items
-# and getting some internal information about attributes/options and types.
-
-my $zinc = $mw->Zinc(-width => 1, -height => 1,);
-
-# Creating an instance of every item type
-my %itemtypes;
-
-# These Items have fields! So the number of fields must be given at creation time
-foreach my $type qw(tabular track waypoint) {
- $itemtypes{$type} = $zinc->add($type, 1, 1);
-}
-
-# These items needs no specific initial values
-foreach my $type qw(group icon map reticle text window) {
- $itemtypes{$type} = $zinc->add($type, 1);
-}
-
-# These items needs some coordinates at creation time
-# However curves usually needs more than 2 points.
-foreach my $type qw(arc curve rectangle) {
- $itemtypes{$type} = $zinc->add($type, 1, [0,0 , 1,1]);
-}
-# Triangles item needs at least 3 points for the coordinates
-foreach my $type qw(triangles) {
- $itemtypes{$type} = $zinc->add($type, 1, [0,0 , 1,1 , 2,2]);
-}
-
-
-my %zinc2doc; # a hash recording every discrepency between attribute/option
- # type between the doc and TkZinc
-my %documentedOptions;
-my %itemAttributeDoc;
-my %documentedTypes;
-my %usedTypes; # hash recording all refered types in the doc
-
-die "missing refman.tex path_name as unique argument to this script" unless defined $ARGV[0];
-
-
-&scanDoc ($ARGV[0]);
-
-sub scanDoc {
- my ($filename) = @_;
- open (DOC, $filename) or die "unable to open " . $filename . "\n";
- my $current_item = 0;
- my $prev_attribute = 0;
- my $prev_type = 0;
-
- while (<DOC>) {
- if ( /^\\attribute\{(\w+)\}\{(\w+)\}\{(\w+)\}/ ) {
- my $item = $1;
- my $attribute = $2;
- my $type = $3;
- $itemAttributeDoc{$item}{-$attribute} = $type;
- if ($item eq $current_item) {
- if ($attribute lt $prev_attribute) {
- print "W: attributes $prev_attribute and $attribute are not in alphabetical order for $item\n";
- }
- }
- else {
- $current_item = $item;
- $prev_attribute = $attribute;
- }
- }
- elsif ( /^\\option\{(\w+)\}\{(\w+)\}\{(\w+)\}/ ) {
- my $optionName = $1;
- my $databaseName = $2;
- my $databaseClass = $3;
- $documentedOptions{-$optionName} = $databaseClass;
- }
- elsif ( /^\\attrtype\{(\w+)\}/ ) {
- my $type = $1;
- $documentedTypes{$type} = $type;
- if ($type lt $prev_type) {
- print "W: type $prev_type and $type are not in alphabetical order\n";
- }
- $prev_type = $type;
- }
- }
-}
-
-sub testAllOptions {
- my @options = $zinc->configure();
- my %options;
- # we use this hashtable to check that all documented options
- # are matching all existing options in TkZinc
-
- for my $elem (@options) {
- my ($optionName, $optionDatabaseName, $optionClass, $default, $optionValue) = @$elem;
- $options{$optionName} = [$optionClass, $default, "", $optionValue];
- }
-
- foreach my $optionName (sort keys %options) {
- my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$optionName}};
- # $empty is for provision by Zinc
-
- if (!defined $documentedOptions{$optionName}) {
- print "E: $optionName ($optionType) of Zinc IS NOT DOCUMENTED!\n";
- $options{$optionName} = undef;
- next;
- }
- if ($documentedOptions{$optionName} ne $optionType) {
- print "W: $optionName has type $optionType inside ZincTk and type $documentedOptions{$optionName} inside Doc\n";
- $zinc2doc{$optionType}=$documentedOptions{$optionName};
- }
-# $attributes{$attributeName} = undef;
- $documentedOptions{$optionName} = undef;
- }
-
- foreach my $unexistingDocOpt (sort keys %documentedOptions) {
- if (defined $documentedOptions{$unexistingDocOpt}) {
- print "E: The Documented Option \"$unexistingDocOpt\" DOES NOT EXIST!\n";
- }
- }
-}
-
-sub testAllAttributes {
- my ($item) = @_;
-
- my %documentedAttributes = %{$itemAttributeDoc{$item}};
- my @attributes = $zinc->itemconfigure($itemtypes{$item});
-
- my %attributes;
- # we use this hashtable to check that all documented attributes
- # are matching all existing attributes in TkZinc
-
- # verifying that all referenced types are defined
- # and storing used types
- foreach my $attribute (sort keys %documentedAttributes) {
- my $type = $documentedAttributes{$attribute};
- $usedTypes{$type} = 1;
- print "E: type $type ($attribute of $item) is not documented\n" unless $documentedTypes{$type};
- }
-
- foreach my $elem (@attributes) {
- my ($attributeName, $attributeType, $readOnly, $empty, $attributeValue) = @$elem;
- $attributes{$attributeName} = [$attributeType, $readOnly, $empty, $attributeValue];
- }
-
- foreach my $attributeName (keys %attributes) {
- my ($attributeType, $readOnly, $empty, $attributeValue) = @{$attributes{$attributeName}};
- # $empty is for provision by Zinc
-
- if (!defined $documentedAttributes{$attributeName}) {
- print "E: $attributeName ($attributeType) of item $item IS NOT DOCUMENTED!\n";
- $attributes{$attributeName} = undef;
- next;
- }
-
- if ($documentedAttributes{$attributeName} ne $attributeType) {
- print "W: $attributeName has type $attributeType inside ZincTk and type $documentedAttributes{$attributeName} inside Doc\n";
- $zinc2doc{$attributeType}=$documentedAttributes{$attributeName};
- }
-# $attributes{$attributeName} = undef;
- $documentedAttributes{$attributeName} = undef;
- }
-
- foreach my $unexistingDocAttr (sort keys %documentedAttributes) {
- if (defined $documentedAttributes{$unexistingDocAttr}) {
- print "E: The Documented Attribute \"$unexistingDocAttr\" DOES NOT EXIST!\n";
- }
- }
-}
-
-
-sub testFieldAttributes {
- my %documentedAttributes = %{$itemAttributeDoc{"field"}};
- my @attributes = $zinc->itemconfigure($itemtypes{track},0);
-
- my %attributes;
- # we use this hashtable to check that all documented fields attributes
- # are matching all existing fields attributes in TkZinc
-
- # verifying that all referenced types are defined
- # and storing used types
- foreach my $attribute (sort keys %documentedAttributes) {
- my $type = $documentedAttributes{$attribute};
- $usedTypes{$type} = 1;
- print "E: type $type ($attribute of 'field') is not documented\n" unless $documentedTypes{$type};
- }
-
-
- foreach my $elem (@attributes) {
- my ($attributeName, $attributeType, $readOnly, $empty, $attributeValue) = @$elem;
- $attributes{$attributeName} = [$attributeType, $readOnly, $empty, $attributeValue];
- }
-
- foreach my $attributeName (keys %attributes) {
- my ($attributeType, $readOnly, $empty, $attributeValue) = @{$attributes{$attributeName}};
- # $empty is for provision by Zinc
-
- if (!defined $documentedAttributes{$attributeName}) {
- print "E: $attributeName ($attributeType) of field IS NOT DOCUMENTED!\n";
- $attributes{$attributeName} = undef;
- next;
- }
-
- if ($documentedAttributes{$attributeName} ne $attributeType) {
- print "W: $attributeName of field has type $attributeType inside ZincTk and type $documentedAttributes{$attributeName} inside Doc\n";
- $zinc2doc{$attributeType}=$documentedAttributes{$attributeName};
- }
- $documentedAttributes{$attributeName} = undef;
- }
-
- foreach my $unexistingDocAttr (sort keys %documentedAttributes) {
- if (defined $documentedAttributes{$unexistingDocAttr}) {
- print "E: The Documented Field Attribute \"$unexistingDocAttr\" DOES NOT EXIST!\n";
- }
- }
-}
-
-sub verifyingAllDefinedTypesAreUsed {
- foreach my $type (sort keys %documentedTypes) {
- print "W: documented type $type is never refered to in the doc\n" unless $usedTypes{$type};
- }
-}
-
-print "--- TkZinc Options -----------------------------------------\n";
-&testAllOptions;
-print "--- Field Attributes ---------------------------------------\n";
-
-&testFieldAttributes;
-
-foreach my $type (sort keys %itemtypes) {
- print "--- Item $type -------------------------------------------------\n";
- &testAllAttributes($type);
-}
-
-&verifyingAllDefinedTypesAreUsed;
-
-print "------- Summary of type discrepencies between Doc and Zinc --------\n";
-printf "%15s |%15s\n", "zinctype","doctype";
-foreach my $typezinc (sort keys %zinc2doc) {
- printf "%15s |%15s\n", $typezinc,$zinc2doc{$typezinc};
-}
-
-
-# MainLoop();
-
-
-1;
diff --git a/Perl/t/text.t b/Perl/t/text.t
deleted file mode 100644
index b8893db..0000000
--- a/Perl/t/text.t
+++ /dev/null
@@ -1,161 +0,0 @@
-#!/usr/bin/perl -w
-
-#
-# $Id: text.t,v 1.6 2004-05-07 13:53:00 mertz Exp $
-# Author: Christophe Mertz
-#
-
-# testing text item
-
-# this script can be used with an optionnal argument, an integer giving
-# the delay in seconds during which the graphic updates will be displayed
-# this is usefull for visual inspection!
-
-my $mw;
-BEGIN {
- if (!eval q{
-# use Test::More qw(no_plan);
- use Test::More tests => 69;
- 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;
- 1;
- }) {
- print "unable to load Tk::Zinc";
- print "1..1\n";
- print "ok 1\n";
- exit;
- }
- if (!eval q{
- $mw = 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;
- }
-}
-
-use strict;
-
-my $zinc = $mw->Zinc(-render => 1,
- -width => 400, -height => 1200)->pack;
-
-like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created");
-
-
-my $g1 = $zinc->add('group',1, -tags => "gr1");
-
-
-my $TEXT = "";
-
-my @families = $mw->fontFamilies;
-#print "families=@families\n";
-
-my $family="";
-if ( grep /^verdana$/i , @families) {
- $family = "verdana";
-# $family = "helvetica";
-} elsif ( grep /^helvetica$/i , @families) {
- $family = "helvetica";
-} elsif ( grep /^arial$/i , @families) {
- $family = "arial";
-}
-#print "family=$family\n";
-
-my $topLevel = $mw->Toplevel();
-$topLevel->title("testing all ascii glyphs of $family");
-
-my $zinc0 = $topLevel->Zinc(-render => 1,
- -width => 300,
- -height => 400,)->pack;
-like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc0 has been created");
-
-$zinc0->fontCreate("fonta", -family => $family, -size => -20, -weight => 'normal');
-
-
-foreach my $row (2..15) {
- my $string = "";
- foreach my $col (0..15) {
- $string .= chr($row*16+$col);
- }
- $zinc0->add('text', 1, -position => [10,$row*20-40],
- -text => $string, -font => 'fonta');
- $zinc0->update;
- &pass("adding text item n°$row with a $family font of size 20 and normal weight");
-}
-
-
-### creating text items with many different fonts:
-
-my $size = 8;
-my $y = 10 ;
-
-$zinc->fontCreate("font$size", -family => $family, -size => -$size, -weight => 'normal');
-
-
-### creating text items with many different fonts:
-$zinc->add('text', $g1, -position => [10,$y], -tags => ["txt$size"], -font => "font$size",
- -text => "$size pixels $family");
-$zinc->remove('txt8');
-$zinc->fontDelete("font$size");
-$zinc->fontCreate("font$size", -family => $family, -size => -$size, -weight => 'normal');
-$zinc->add('text', $g1, -position => [10,$y], -tags => ["txt$size"], -font => "font$size",
- -text => "$size pixels $family");
-
-
-
-
-
-foreach my $size (9..60) {
- $zinc->fontCreate("font$size", -family => $family, -size => -$size, -weight => 'normal');
- $zinc->add('text', $g1, -position => [10,$y], -tags => ["txt$size"], -font => "font$size",
- -text => "$size pixels $family");
- $zinc->update;
-
- # deleting both the font and the text item and recreating it 10 times
- foreach my $count (1..10) {
- $zinc->fontDelete("font$size");
- $zinc->remove('txt8');
- $zinc->fontCreate("font$size", -family => $family, -size => -$size, -weight => 'normal');
- $zinc->add('text', $g1, -position => [10,$y], -tags => ["txt$size"], -font => "font$size",
- -text => "$size pixels $family");
- $zinc->update;
- }
- &pass("creating and deleting 10 times a text item with a $family font of size $size");
- $y += $size;
-}
-
-
-&wait;
-
-## we should certainly test much much other things!
-
-
-
-sub wait {
- $zinc->update;
- ok (1, $_[0]);
-
- my $delay = $ARGV[0];
- if (defined $delay) {
- $zinc->update;
- if ($delay =~ /^\d+$/) {
- sleep $delay;
- } else {
- sleep 1;
- }
- }
-
-}
-
-
-
-diag("############## end of text test");
diff --git a/Perl/t/traceutils.t b/Perl/t/traceutils.t
deleted file mode 100644
index 0636037..0000000
--- a/Perl/t/traceutils.t
+++ /dev/null
@@ -1,89 +0,0 @@
-#!/usr/bin/perl -w
-
-#
-# $Id: traceutils.t,v 1.2 2004-05-07 16:53:43 mertz Exp $
-# Author: Christophe Mertz
-#
-
-# testing Tk::Zinc::TraceUtils utilities
-
-#use Tk::Zinc::TraceUtils;
-use strict;
-
-BEGIN {
- if (!eval q{
-# use Test::More qw(no_plan);
- use Test::More tests => 14;
- 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::TraceUtils;
- 1;
- }) {
- print "unable to load Tk::Zinc::TraceUtils";
- print "1..1\n";
- print "ok 1\n";
- exit;
- }
-}
-
-
-
-#### creating different images, bitmaps and pixmaps...
-
-my $arg;
-
-$arg = "1";
-is (&Item ($arg), $arg, "testing " . $arg);
-
-SKIP: {
- my $mw;
- skip "not able to create a MainWindow", 3 if !eval q{$mw = MainWindow->new()} ;
- require Tk::Font;
- my $font = $mw->fontCreate("testfont", -family => "Helvetica");
-
- like ($font, qr/^testfont/, "font creation");
- is (&Item ($font), "'testfont'", "testing " . "testfont"); # not so sure about this result!
- is (&List (-font => $font), "(-font => 'testfont')", "(-font => afont)");
-}
-
-$arg = "()";
-is (&List (eval $arg), $arg, "empty list: ". $arg);
-
-$arg = "(-option_without_value)";
-is (&List (eval $arg), $arg, $arg);
-
-$arg = "(1, 2, 3, 4)";
-is (&List (eval $arg), $arg, $arg);
-
-$arg = "(-1, -2, -3, -4)";
-is (&List (eval $arg), $arg, $arg);
-
-$arg = "(1.2, -2, .01, -1.2e+22, 1.02e+34)";
-
-is (&List (eval $arg), ($arg =~ s/\.01/0.01/ , $arg ), $arg);
-
-$arg = "('-1aa' => -2, '-a b', -1.2)";
-is (&List (eval $arg), $arg, $arg);
-
-$arg = "(-option => -2, -option2 => -1.2, -option3)";
-is (&List (eval $arg), $arg, $arg);
-
-$arg = "('icon', 1, -priority => 210, -visible => 1)";
-is (&List (eval $arg), $arg, $arg);
-
-$arg = "('text', 1, -font => '-adobe-helvetica-bold-r-normal-*-120-*-*-*-*-*-*')";
-is (&List (eval $arg), $arg, $arg);
-
-
-$arg = "-option, -2, -option2, -1.2, -option3";
-is (&Array (eval "(".$arg.")"), "[".$arg."]", "[".$arg."]");
-
-
-
-diag("############## Tk::Zinc::TraceUtils test");
generated by cgit v1.1 at 2024-06-26 17:11:28 +0000