X-Git-Url: http://git.imager.perl.org/imager.git/blobdiff_plain/c5f447ac492bae9abe29c8776013885c78c3b1f8..2b92bccfc18b589443ee70d83be1ed72c17db9a9:/lib/Imager/Test.pm diff --git a/lib/Imager/Test.pm b/lib/Imager/Test.pm index e2e27560..1c3837af 100644 --- a/lib/Imager/Test.pm +++ b/lib/Imager/Test.pm @@ -1,8 +1,14 @@ package Imager::Test; use strict; +use Test::More; use Test::Builder; require Exporter; -use vars qw(@ISA @EXPORT_OK); +use vars qw(@ISA @EXPORT_OK $VERSION); +use Carp qw(croak carp); +use Config; + +$VERSION = "1.003"; + @ISA = qw(Exporter); @EXPORT_OK = qw( @@ -11,19 +17,31 @@ use vars qw(@ISA @EXPORT_OK); test_image_16 test_image test_image_double + test_image_mono + test_image_gray + test_image_gray_16 + test_image_named is_color1 is_color3 is_color4 is_color_close3 + is_fcolor1 + is_fcolor3 is_fcolor4 color_cmp is_image - is_image_similar + is_imaged + is_image_similar + isnt_image image_bounds_checks mask_tests test_colorf_gpix test_color_gpix - test_colorf_glin); + test_colorf_glin + can_test_threads + std_font_tests + std_font_test_count + ); sub diff_text_with_nul { my ($desc, $text1, $text2, @params) = @_; @@ -62,7 +80,7 @@ sub is_color3($$$$$) { my ($cr, $cg, $cb) = $color->rgba; unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) { - $builder->diag(<diag(<diag(<new; + + unless (defined $color) { + $builder->ok(0, $comment); + $builder->diag("color is undef"); + return; + } + unless ($color->can('rgba')) { + $builder->ok(0, $comment); + $builder->diag("color is not a color object"); + return; + } + + my ($cgrey) = $color->rgba; + unless ($builder->ok(abs($cgrey - $grey) <= $mindiff, $comment)) { + print <new; + + unless (defined $color) { + $builder->ok(0, $comment); + $builder->diag("color is undef"); + return; + } + unless ($color->can('rgba')) { + $builder->ok(0, $comment); + $builder->diag("color is not a color object"); + return; + } + + my ($cr, $cg, $cb) = $color->rgba; + unless ($builder->ok(abs($cr - $red) <= $mindiff + && abs($cg - $green) <= $mindiff + && abs($cb - $blue) <= $mindiff, $comment)) { + $builder->diag(<new(0, 0, 255, 255); my $red = Imager::Color->new(255, 0, 0, 255); my $img = Imager->new(xsize => 150, ysize => 150, bits => 16); - $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]); - $img->box(filled => 1, color => $blue, box => [ 20, 25, 80, 125 ]); + $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]); + $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]); $img->arc(x => 75, y => 75, r => 30, color => $red); $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]); @@ -253,16 +345,75 @@ sub test_image_double { my $blue = Imager::Color->new(0, 0, 255, 255); my $red = Imager::Color->new(255, 0, 0, 255); my $img = Imager->new(xsize => 150, ysize => 150, bits => 'double'); - $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]); - $img->box(filled => 1, color => $blue, box => [ 20, 25, 80, 125 ]); + $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]); + $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]); $img->arc(x => 75, y => 75, r => 30, color => $red); $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]); $img; } -sub is_image_similar($$$$) { - my ($left, $right, $limit, $comment) = @_; +sub test_image_gray { + my $g50 = Imager::Color->new(128, 128, 128); + my $g30 = Imager::Color->new(76, 76, 76); + my $g70 = Imager::Color->new(178, 178, 178); + my $img = Imager->new(xsize => 150, ysize => 150, channels => 1); + $img->box(filled => 1, color => $g50, box => [ 70, 24, 130, 124 ]); + $img->box(filled => 1, color => $g30, box => [ 20, 26, 80, 126 ]); + $img->arc(x => 75, y => 75, r => 30, color => $g70); + $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]); + + return $img; +} + +sub test_image_gray_16 { + my $g50 = Imager::Color->new(128, 128, 128); + my $g30 = Imager::Color->new(76, 76, 76); + my $g70 = Imager::Color->new(178, 178, 178); + my $img = Imager->new(xsize => 150, ysize => 150, channels => 1, bits => 16); + $img->box(filled => 1, color => $g50, box => [ 70, 24, 130, 124 ]); + $img->box(filled => 1, color => $g30, box => [ 20, 26, 80, 126 ]); + $img->arc(x => 75, y => 75, r => 30, color => $g70); + $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]); + + return $img; +} + +sub test_image_mono { + require Imager::Fill; + my $fh = Imager::Fill->new(hatch => 'check1x1'); + my $img = Imager->new(xsize => 150, ysize => 150, type => "paletted"); + my $black = Imager::Color->new(0, 0, 0); + my $white = Imager::Color->new(255, 255, 255); + $img->addcolors(colors => [ $black, $white ]); + $img->box(fill => $fh, box => [ 70, 24, 130, 124 ]); + $img->box(filled => 1, color => $white, box => [ 20, 26, 80, 126 ]); + $img->arc(x => 75, y => 75, r => 30, color => $black, aa => 0); + + return $img; +} + +my %name_to_sub = + ( + basic => \&test_image, + basic16 => \&test_image_16, + basic_double => \&test_image_double, + gray => \&test_image_gray, + gray16 => \&test_image_gray_16, + mono => \&test_image_mono, + ); + +sub test_image_named { + my $name = shift + or croak("No name supplied to test_image_named()"); + my $sub = $name_to_sub{$name} + or croak("Unknown name $name supplied to test_image_named()"); + + return $sub->(); +} + +sub _low_image_diff_check { + my ($left, $right, $comment) = @_; my $builder = Test::Builder->new; @@ -304,6 +455,22 @@ sub is_image_similar($$$$) { . $right->getchannels); return; } + + return 1; +} + +sub is_image_similar($$$$) { + my ($left, $right, $limit, $comment) = @_; + + { + local $Test::Builder::Level = $Test::Builder::Level + 1; + + _low_image_diff_check($left, $right, $comment) + or return; + } + + my $builder = Test::Builder->new; + my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG}); if ($diff > $limit) { $builder->ok(0, $comment); @@ -338,6 +505,57 @@ sub is_image($$$) { return is_image_similar($left, $right, 0, $comment); } +sub is_imaged($$$;$) { + my $epsilon = Imager::i_img_epsilonf(); + if (@_ > 3) { + ($epsilon) = splice @_, 2, 1; + } + + my ($left, $right, $comment) = @_; + + { + local $Test::Builder::Level = $Test::Builder::Level + 1; + + _low_image_diff_check($left, $right, $comment) + or return; + } + + my $builder = Test::Builder->new; + + my $same = Imager::i_img_samef($left->{IMG}, $right->{IMG}, $epsilon, $comment); + if (!$same) { + $builder->ok(0, $comment); + $builder->diag("images different"); + + # find the first mismatch + PIXELS: + for my $y (0 .. $left->getheight()-1) { + for my $x (0.. $left->getwidth()-1) { + my @lsamples = $left->getsamples(x => $x, y => $y, width => 1, type => "float"); + my @rsamples = $right->getsamples(x => $x, y => $y, width => 1, type => "float"); + if ("@lsamples" ne "@rsamples") { + $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples"); + last PIXELS; + } + } + } + + return; + } + + return $builder->ok(1, $comment); +} + +sub isnt_image { + my ($left, $right, $comment) = @_; + + my $builder = Test::Builder->new; + + my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG}); + + return $builder->ok($diff, "$comment"); +} + sub image_bounds_checks { my $im = shift; @@ -354,14 +572,22 @@ sub image_bounds_checks { my $black = Imager::Color->new(0, 0, 0); require Imager::Color::Float; my $blackf = Imager::Color::Float->new(0, 0, 0); - $builder->ok(!$im->setpixel(x => -1, y => 0, color => $black), 'bounds check set (-1, 0)'); - $builder->ok(!$im->setpixel(x => 10, y => 0, color => $black), 'bounds check set (10, 0)'); - $builder->ok(!$im->setpixel(x => 0, y => -1, color => $black), 'bounds check set (0, -1)'); - $builder->ok(!$im->setpixel(x => 0, y => 10, color => $black), 'bounds check set (0, 10)'); - $builder->ok(!$im->setpixel(x => -1, y => 0, color => $blackf), 'bounds check set (-1, 0) float'); - $builder->ok(!$im->setpixel(x => 10, y => 0, color => $blackf), 'bounds check set (10, 0) float'); - $builder->ok(!$im->setpixel(x => 0, y => -1, color => $blackf), 'bounds check set (0, -1) float'); - $builder->ok(!$im->setpixel(x => 0, y => 10, color => $blackf), 'bounds check set (0, 10) float'); + $builder->ok($im->setpixel(x => -1, y => 0, color => $black) == 0, + 'bounds check set (-1, 0)'); + $builder->ok($im->setpixel(x => 10, y => 0, color => $black) == 0, + 'bounds check set (10, 0)'); + $builder->ok($im->setpixel(x => 0, y => -1, color => $black) == 0, + 'bounds check set (0, -1)'); + $builder->ok($im->setpixel(x => 0, y => 10, color => $black) == 0, + 'bounds check set (0, 10)'); + $builder->ok($im->setpixel(x => -1, y => 0, color => $blackf) == 0, + 'bounds check set (-1, 0) float'); + $builder->ok($im->setpixel(x => 10, y => 0, color => $blackf) == 0, + 'bounds check set (10, 0) float'); + $builder->ok($im->setpixel(x => 0, y => -1, color => $blackf) == 0, + 'bounds check set (0, -1) float'); + $builder->ok($im->setpixel(x => 0, y => 10, color => $blackf) == 0, + 'bounds check set (0, 10) float'); } sub test_colorf_gpix { @@ -516,6 +742,158 @@ sub mask_tests { } +sub std_font_test_count { + return 21; +} + +sub std_font_tests { + my ($opts) = @_; + + my $font = $opts->{font} + or carp "Missing font parameter"; + + my $name_font = $opts->{glyph_name_font} || $font; + + my $has_chars = $opts->{has_chars} || [ 1, '', 1 ]; + + my $glyph_names = $opts->{glyph_names} || [ "A", undef, "A" ]; + + SKIP: + { # check magic is handled correctly + # https://rt.cpan.org/Ticket/Display.html?id=83438 + skip("no native UTF8 support in this version of perl", 11) + unless $] >= 5.006; + skip("overloading handling of magic is broken in this version of perl", 11) + unless $] >= 5.008; + Imager->log("utf8 magic tests\n"); + my $over = bless {}, "Imager::Test::OverUtf8"; + my $text = "A".chr(0x2010)."A"; + my $white = Imager::Color->new("#FFF"); + my $base_draw = Imager->new(xsize => 80, ysize => 20); + ok($base_draw->string(font => $font, + text => $text, + x => 2, + y => 18, + size => 15, + color => $white, + aa => 1), + "magic: make a base image"); + my $test_draw = Imager->new(xsize => 80, ysize => 20); + ok($test_draw->string(font => $font, + text => $over, + x => 2, + y => 18, + size => 15, + color => $white, + aa => 1), + "magic: draw with overload"); + is_image($base_draw, $test_draw, "check they match"); + if ($opts->{files}) { + $test_draw->write(file => "testout/utf8tdr.ppm"); + $base_draw->write(file => "testout/utf8bdr.ppm"); + } + + my $base_cp = Imager->new(xsize => 80, ysize => 20); + $base_cp->box(filled => 1, color => "#808080"); + my $test_cp = $base_cp->copy; + ok($base_cp->string(font => $font, + text => $text, + y => 2, + y => 18, + size => 16, + channel => 2, + aa => 1), + "magic: make a base image (channel)"); + Imager->log("magic: draw to channel with overload\n"); + ok($test_cp->string(font => $font, + text => $over, + y => 2, + y => 18, + size => 16, + channel => 2, + aa => 1), + "magic: draw with overload (channel)"); + is_image($test_cp, $base_cp, "check they match"); + if ($opts->{files}) { + $test_cp->write(file => "testout/utf8tcp.ppm"); + $base_cp->write(file => "testout/utf8bcp.ppm"); + } + + SKIP: + { + Imager->log("magic: has_chars\n"); + $font->can("has_chars") + or skip "No has_chars aupport", 2; + is_deeply([ $font->has_chars(string => $text) ], $has_chars, + "magic: has_chars with normal utf8 text"); + is_deeply([ $font->has_chars(string => $over) ], $has_chars, + "magic: has_chars with magic utf8 text"); + } + + Imager->log("magic: bounding_box\n"); + my @base_bb = $font->bounding_box(string => $text, size => 30); + is_deeply([ $font->bounding_box(string => $over, size => 30) ], + \@base_bb, + "check bounding box magic"); + + SKIP: + { + $font->can_glyph_names + or skip "No glyph_names", 2; + Imager->log("magic: glyph_names\n"); + my @text_names = $name_font->glyph_names(string => $text, reliable_only => 0); + is_deeply(\@text_names, $glyph_names, + "magic: glyph_names with normal utf8 text"); + my @over_names = $name_font->glyph_names(string => $over, reliable_only => 0); + is_deeply(\@over_names, $glyph_names, + "magic: glyph_names with magic utf8 text"); + } + } + + { # invalid UTF8 handling at the OO level + my $im = Imager->new(xsize => 80, ysize => 20); + my $bad_utf8 = pack("C", 0xC0); + Imager->_set_error(""); + ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1, + y => 18, x => 2), + "drawing invalid utf8 should fail"); + is($im->errstr, "invalid UTF8 character", "check error message"); + Imager->_set_error(""); + ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1, + y => 18, x => 2, channel => 1), + "drawing invalid utf8 should fail (channel)"); + is($im->errstr, "invalid UTF8 character", "check error message"); + Imager->_set_error(""); + ok(!$font->bounding_box(string => $bad_utf8, size => 30, utf8 => 1), + "bounding_box() bad utf8 should fail"); + is(Imager->errstr, "invalid UTF8 character", "check error message"); + SKIP: + { + $font->can_glyph_names + or skip "No glyph_names support", 2; + Imager->_set_error(""); + is_deeply([ $font->glyph_names(string => $bad_utf8, utf8 => 1) ], + [ ], + "glyph_names returns empty list for bad string"); + is(Imager->errstr, "invalid UTF8 character", "check error message"); + } + SKIP: + { + $font->can("has_chars") + or skip "No has_chars support", 2; + Imager->_set_error(""); + is_deeply([ $font->has_chars(string => $bad_utf8, utf8 => 1) ], + [ ], + "has_chars returns empty list for bad string"); + is(Imager->errstr, "invalid UTF8 character", "check error message"); + } + } +} + +package Imager::Test::OverUtf8; +use overload '""' => sub { "A".chr(0x2010)."A" }; + + 1; __END__ @@ -540,11 +918,44 @@ No functions are exported by default. =head1 FUNCTIONS +=head2 Test functions + +=for stopwords OO + =over -=item is_color3($color, $red, $blue, $green, $comment) +=item is_color1($color, $grey, $comment) + +Tests if the first channel of $color matches $grey. + +=item is_color3($color, $red, $green, $blue, $comment) + +Tests if $color matches the given ($red, $green, $blue) + +=item is_color4($color, $red, $green, $blue, $alpha, $comment) + +Tests if $color matches the given ($red, $green, $blue, $alpha) + +=item is_fcolor1($fcolor, $grey, $comment) + +=item is_fcolor1($fcolor, $grey, $epsilon, $comment) + +Tests if $fcolor's first channel is within $epsilon of ($grey). For +the first form $epsilon is taken as 0.001. + +=item is_fcolor3($fcolor, $red, $green, $blue, $comment) + +=item is_fcolor3($fcolor, $red, $green, $blue, $epsilon, $comment) + +Tests if $fcolor's channels are within $epsilon of ($red, $green, +$blue). For the first form $epsilon is taken as 0.001. -Tests is $color matches the given ($red, $blue, $green) +=item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $comment) + +=item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $epsilon, $comment) + +Tests if $fcolor's channels are within $epsilon of ($red, $green, +$blue, $alpha). For the first form $epsilon is taken as 0.001. =item is_image($im1, $im2, $comment) @@ -554,6 +965,14 @@ each pixel. The color comparison is done at 8-bits per pixel. The color representation such as direct vs paletted, bits per sample are not checked. Equivalent to is_image_similar($im1, $im2, 0, $comment). +=item is_imaged($im, $im2, $comment) + +=item is_imaged($im, $im2, $epsilon, $comment) + +Tests if the two images have the same content at the double/sample +level. C<$epsilon> defaults to the platform DBL_EPSILON multiplied by +four. + =item is_image_similar($im1, $im2, $maxdiff, $comment) Tests if the 2 images have similar content. Both images must be @@ -563,58 +982,119 @@ less than or equal to I<$maxdiff> for the test to pass. The color comparison is done at 8-bits per pixel. The color representation such as direct vs paletted, bits per sample are not checked. -=item test_image_raw() +=item isnt_image($im1, $im2, $comment) -Returns a 150x150x3 Imager::ImgRaw test image. +Tests that the two images are different. For regressions tests where +something (like text output of "0") produced no change, but should +have produced a change. -=item test_image() +=item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment) -Returns a 150x150x3 8-bit/sample OO test image. +Retrieves the pixel ($x,$y) from the low-level image $im and compares +it to the floating point color $expected, with a tolerance of epsilon. -=item test_image_16() +=item test_color_gpix($im, $x, $y, $expected, $comment) -Returns a 150x150x3 16-bit/sample OO test image. +Retrieves the pixel ($x,$y) from the low-level image $im and compares +it to the floating point color $expected. -=item test_image_double() +=item test_colorf_glin($im, $x, $y, $pels, $comment) + +Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the +low level image $im and compares them against @$pels. + +=item is_color_close3($color, $red, $green, $blue, $tolerance, $comment) + +Tests if $color's first three channels are within $tolerance of ($red, +$green, $blue). + +=back + +=head2 Test suite functions + +Functions that perform one or more tests, typically used to test +various parts of Imager's implementation. + +=over + +=item image_bounds_checks($im) -Returns a 150x150x3 double/sample OO test image. +Attempts to write to various pixel positions outside the edge of the +image to ensure that it fails in those locations. + +Any new image type should pass these tests. Does 16 separate tests. + +=item mask_tests($im, $epsilon) + +Perform a standard set of mask tests on the OO image $im. Does 24 +separate tests. =item diff_text_with_nul($test_name, $text1, $text2, @options) Creates 2 test images and writes $text1 to the first image and $text2 -to the second image with the string() method. Each call adds 3 ok/not -ok to the output of the test script. +to the second image with the string() method. Each call adds 3 +C/C to the output of the test script. Extra options that should be supplied include the font and either a color or channel parameter. This was explicitly created for regression tests on #21770. -=item image_bounds_checks($im) +=item std_font_tests({ font => $font }) -Attempts to write to various pixel positions outside the edge of the -image to ensure that it fails in those locations. +Perform standard font interface tests. -Any new image type should pass these tests. Does 16 separate tests. +=item std_font_test_count() -=item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment) +The number of tests performed by std_font_tests(). -Retrieves the pixel ($x,$y) from the low-level image $im and compares -it to the floating point color $expected, with a tolerance of epsilon. +=back -=item test_color_gpix($im, $x, $y, $expected, $comment) +=head2 Helper functions -Retrieves the pixel ($x,$y) from the low-level image $im and compares -it to the floating point color $expected. +=over -=item test_colorf_glin($im, $x, $y, $pels, $comment) +=item test_image_raw() -Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the -low level image $im and compares them against @$pels. +Returns a 150x150x3 Imager::ImgRaw test image. -=item mask_tests($im, $epsilon) +=item test_image() + +Returns a 150x150x3 8-bit/sample OO test image. Name: C. + +=item test_image_16() + +Returns a 150x150x3 16-bit/sample OO test image. Name: C + +=item test_image_double() + +Returns a 150x150x3 double/sample OO test image. Name: C. + +=item test_image_gray() + +Returns a 150x150 single channel OO test image. Name: C. + +=item test_image_gray_16() + +Returns a 150x150 16-bit/sample single channel OO test image. Name: +C. + +=item test_image_mono() + +Returns a 150x150 bilevel image that passes the is_bilevel() test. +Name: C. + +=item test_image_named($name) + +Return one of the other test images above based on name. + +=item color_cmp($c1, $c2) + +Performs an ordering of 3-channel colors (like <=>). + +=item colorf_cmp($c1, $c2) -Perform a standard set of mask tests on the OO image $im. +Performs an ordering of 3-channel floating point colors (like <=>). =back