From e6a05dbef707dc10e546ef8fef8fc2a8b7d805bf Mon Sep 17 00:00:00 2001 From: cvs2svn Date: Mon, 24 Jan 2005 15:46:33 +0000 Subject: This commit was manufactured by cvs2svn to create branch 'POSTSCRIPT'. --- Perl/t/.cvsignore | 2 - Perl/t/AnimatedGradient.t | 175 ----- Perl/t/Bbox.t | 242 ------- Perl/t/Coords.t | 151 ----- Perl/t/Images.t | 212 ------ Perl/t/Import.t | 31 - Perl/t/PreviousKnownBugs.t | 61 -- Perl/t/Test/Builder.pm | 1408 --------------------------------------- Perl/t/Test/Harness.pm | 1168 -------------------------------- Perl/t/Test/Harness/Assert.pm | 68 -- Perl/t/Test/Harness/Iterator.pm | 61 -- Perl/t/Test/Harness/Straps.pm | 667 ------------------- Perl/t/Test/More.pm | 1248 ---------------------------------- Perl/t/TestLog.pm | 306 --------- Perl/t/Text.t | 58 -- Perl/t/Transformations.t | 304 --------- Perl/t/find.t | 200 ------ Perl/t/test-methods.pl | 689 ------------------- Perl/t/test-no-crash.pl | 880 ------------------------ Perl/t/testdoc.pl | 274 -------- Perl/t/text.t | 161 ----- Perl/t/traceutils.t | 89 --- 22 files changed, 8455 deletions(-) delete mode 100644 Perl/t/.cvsignore delete mode 100644 Perl/t/AnimatedGradient.t delete mode 100644 Perl/t/Bbox.t delete mode 100644 Perl/t/Coords.t delete mode 100644 Perl/t/Images.t delete mode 100644 Perl/t/Import.t delete mode 100644 Perl/t/PreviousKnownBugs.t delete mode 100644 Perl/t/Test/Builder.pm delete mode 100644 Perl/t/Test/Harness.pm delete mode 100644 Perl/t/Test/Harness/Assert.pm delete mode 100644 Perl/t/Test/Harness/Iterator.pm delete mode 100644 Perl/t/Test/Harness/Straps.pm delete mode 100644 Perl/t/Test/More.pm delete mode 100644 Perl/t/TestLog.pm delete mode 100644 Perl/t/Text.t delete mode 100644 Perl/t/Transformations.t delete mode 100644 Perl/t/find.t delete mode 100644 Perl/t/test-methods.pl delete mode 100644 Perl/t/test-no-crash.pl delete mode 100644 Perl/t/testdoc.pl delete mode 100644 Perl/t/text.t delete mode 100644 Perl/t/traceutils.t (limited to 'Perl/t') 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. - -=head2 Construction - -=over 4 - -=item B - - 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 -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 - - 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 - - $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 - - 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 - - $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 - - $plan = $Test->has_plan - -Find out whether a plan has been defined. $plan is either C (no plan has been set), C (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 - - $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 - - $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(<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 - - $Test->is_eq($got, $expected, $name); - -Like Test::More's is(). Checks if $got eq $expected. This is the -string version. - -=item B - - $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 < - - $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 - - $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 - - $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 - - $Test->unlike($this, qr/$regex/, $name); - $Test->unlike($this, '/$regex/', $name); - -Like Test::More's unlike(). Checks if $this B 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 - - $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 < - - $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 < - - $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 - - $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 - - $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 - - $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 - - $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 - - $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 - - $Test->no_header($no_header); - -If set to true, no "1..N" header will be printed. - -=item B - - $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 - - $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) it "passes through" the failure. - - return ok(...) || diag(...); - -=for blame transfer -Mark Fowler - -=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 - - $Test->output($fh); - $Test->output($file); - -Where normal "ok/not ok" test output should go. - -Defaults to STDOUT. - -=item B - - $Test->failure_output($fh); - $Test->failure_output($file); - -Where diagnostic output on test failures and diag() should go. - -Defaults to STDERR. - -=item B - - $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 - - 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 - - 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
- - 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 - - 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 - - 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 < - - _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 -Eschwern@pobox.comE - -=head1 COPYRIGHT - -Copyright 2002 by chromatic Echromatic@wgz.orgE, - Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=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 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 is an increasing sequence of integers. The first line -output by a standard test script is C<"1..M"> with C 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 line output by your test (again, it -can be followed by further comments). - -Under B 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 are interpreted as feedback for -runtests(). All other lines are discarded. - -C indicates a failed test. C is a successful test. - - -=item B - -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 < - -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 - -If the standard output line contains the substring C< # Skip> (with -variations in spacing and case) after C or C, it is -counted as a skipped test. If the whole testscript succeeds, the -count of skipped tests is included in the generated output. -C 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 - -If the standard output line contains the substring C< # TODO> after -C or C, 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. - -=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 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 - -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 as the reason why testing is stopped. - -=item B - -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 - -Any other output Test::Harness sees it will silently ignore B 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 - -The test file which failed. - -=item B - -If the test exited with non-zero, this is its exit status. - -=item B - -The wait status of the test I. - -=item B - -Total number of tests expected to run. - -=item B - -Number which failed, either from "not ok" or because they never ran. - -=item B - -Percentage of the total tests which failed. - -=item B - -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 - - 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 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 - -If all tests are successful some statistics about the performance are -printed. - -=item C - -For any single script that has failing subtests statistics like the -above are printed. - -=item C - -Scripts that return a non-zero exit status, both C<$? EE 8> -and C<$?> are printed in a message similar to the above. - -=item C - -=item C - -If not all tests were successful, the script dies with one of the -above messages. - -=item C - -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 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 - -This value will be used for the width of the terminal. If it is not -set then it will default to C. If this is not set, it will -default to 80. Note that users of Bourne-sh based shells will need to -C for this module to use that variable. - -=item C - -When true it will make harness attempt to compile the test using -C before running it. - -B This currently only works when sitting in the perl source -directory! - -=item C - -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 may give more predictable results. - -=item C - -Makes harness ignore the exit status of child processes when defined. - -=item C - -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 - -If true, the C messages are printed out only every second. -This reduces output and therefore may for example help testing -over slow connections. - -=item C - -Its value will be prepended to the switches used to invoke perl on -each test. For example, setting C to C<-W> will -run all tests with all warnings enabled. - -=item C - -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 and L for writing test scripts, L for -the underlying timing routines, L to generate core -dumps from failed tests and L 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<< >>. - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See L - -=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 - -=head2 Functions - -=over 4 - -=item B - - 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 Eschwern@pobox.comE - -=head1 SEE ALSO - -L - -=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 - -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 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 contact the author -if you'd like a feature added or something change or just have -comments. - -=head1 Construction - -=head2 C - - 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 - - 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. - -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 - - my %results = $strap->analyze_fh($name, $test_filehandle); - -Like C, 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 - - my %results = $strap->analyze_file($test_file); - -Like C, 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 = ; - 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. - -=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 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 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 for an example of use. - -=head1 AUTHOR - -Michael G Schwern C<< >>, currently maintained by -Andy Lester C<< >>. - -=head1 SEE ALSO - -L - -=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 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 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 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 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($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 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 - -=item B - - is ( $this, $that, $test_name ); - isnt( $this, $that, $test_name ); - -Similar to ok(), is() and isnt() compare their two arguments -with C and C 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 -function which is an alias of isnt(). - -=cut - -sub is ($$;$) { - $Test->is_eq(@_); -} - -sub isnt ($$;$) { - $Test->isnt_eq(@_); -} - -*isn't = \&isnt; - - -=item B - - like( $this, qr/that/, $test_name ); - -Similar to ok(), like() matches $this against the regex C. - -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) 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( $this, qr/that/, $test_name ); - -Works exactly as like(), only it checks if $this B match the -given pattern. - -=cut - -sub unlike { - $Test->unlike(@_); -} - - -=item B - - 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 will interfere: - - cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); - -=cut - -sub cmp_ok($$$;$) { - $Test->cmp_ok(@_); -} - - -=item B - - 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($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 <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 - -=item B - - 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. - -=over 4 - -=item B - - 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 with the mnemonic C. - -B 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 and C. - -=over 4 - -=item B - - 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 <import(\@imports); -USE - - my $ok = $Test->ok( !$@, "use $module;" ); - - unless( $ok ) { - chomp $@; - $Test->diag(< - - 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 <ok( !$@, "require $module;" ); - - unless( $ok ) { - chomp $@; - $Test->diag(<. - -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: { - 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. 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, 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: { - 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: { - 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 with and using C. 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 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, 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, 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 These are NOT well-tested on circular references. Nor am I -quite sure what will happen with filehandles. - -=over 4 - -=item B - - 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 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(\@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(\%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(\@this, \@that); - -Similar to eq_array(), except the order of the elements is B -important. This is a deep check, but the irrelevancy of order only -applies to the top level. - -B 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. - -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 - - 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 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 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 for more ways to test complex data structures. -And it plays well with Test::More. - -L is the old testing module. Its main benefit is that it has -been distributed with Perl since 5.004_05. - -L for details on how your test results are interpreted -by Perl. - -L describes a very featureful unit testing interface. - -L shows the idea of embedded testing. - -L is another approach to embedded testing. - - -=head1 AUTHORS - -Michael G Schwern Eschwern@pobox.comE 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 Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=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 - -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 - -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 trace level, defaulted to 0; higher level trace more infos\n"; - print " -out filename the log filename. defaulted to methods-<-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 to better trace usage of an option\n"; - print " -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 - -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 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 to better trace usage of an option\n"; - print " -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 () { - 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 - -# 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 () { - 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"); -- cgit v1.1