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(
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) = @_;
my ($cr, $cg, $cb) = $color->rgba;
unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) {
- $builder->diag(<<END_DIAG);
+ print <<END_DIAG;
Color mismatch:
Red: $red vs $cr
Green: $green vs $cg
return 1;
}
+sub is_fcolor1($$$;$) {
+ my ($color, $grey, $comment_or_diff, $comment_or_undef) = @_;
+ my ($comment, $mindiff);
+ if (defined $comment_or_undef) {
+ ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
+ }
+ else {
+ ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
+ }
+
+ my $builder = Test::Builder->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 <<END_DIAG;
+Color mismatch:
+ Gray: $cgrey vs $grey
+END_DIAG
+ return;
+ }
+
+ return 1;
+}
+
+sub is_fcolor3($$$$$;$) {
+ my ($color, $red, $green, $blue, $comment_or_diff, $comment_or_undef) = @_;
+ my ($comment, $mindiff);
+ if (defined $comment_or_undef) {
+ ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
+ }
+ else {
+ ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
+ }
+
+ my $builder = Test::Builder->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(<<END_DIAG);
+Color mismatch:
+ Red: $cr vs $red
+Green: $cg vs $green
+ Blue: $cb vs $blue
+END_DIAG
+ return;
+ }
+
+ return 1;
+}
+
sub is_color1($$$) {
my ($color, $grey, $comment) = @_;
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 => 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 ]);
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;
. $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);
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;
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 {
}
+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__
=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.
+
+=item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $comment)
+
+=item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $epsilon, $comment)
-Tests is $color matches the given ($red, $blue, $green)
+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)
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
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
-Returns a 150x150x3 double/sample OO test image.
+=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)
+
+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<ok>/C<not ok> 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<basic>.
+
+=item test_image_16()
+
+Returns a 150x150x3 16-bit/sample OO test image. Name: C<basic16>
+
+=item test_image_double()
+
+Returns a 150x150x3 double/sample OO test image. Name: C<basic_double>.
+
+=item test_image_gray()
+
+Returns a 150x150 single channel OO test image. Name: C<gray>.
+
+=item test_image_gray_16()
+
+Returns a 150x150 16-bit/sample single channel OO test image. Name:
+C<gray16>.
+
+=item test_image_mono()
+
+Returns a 150x150 bilevel image that passes the is_bilevel() test.
+Name: C<mono>.
+
+=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
projects / imager.git / blobdiff