add CVE for the security issue
[imager.git] / lib / Imager / Test.pm
CommitLineData
9a6ab99c
TC
1package Imager::Test;
2use strict;
3use Test::Builder;
4require Exporter;
5use vars qw(@ISA @EXPORT_OK);
6@ISA = qw(Exporter);
bd8052a6
TC
7@EXPORT_OK = qw(diff_text_with_nul
8 test_image_raw test_image_16 test_image test_image_double
6e4af7d4 9 is_color3 is_color1 is_color4 is_color_close3
b3aa972f
TC
10 is_fcolor4
11 is_image is_image_similar
bd8052a6
TC
12 image_bounds_checks mask_tests
13 test_colorf_gpix test_color_gpix test_colorf_glin);
9a6ab99c
TC
14
15sub diff_text_with_nul {
16 my ($desc, $text1, $text2, @params) = @_;
17
18 my $builder = Test::Builder->new;
19
20 print "# $desc\n";
21 my $imbase = Imager->new(xsize => 100, ysize => 100);
22 my $imcopy = Imager->new(xsize => 100, ysize => 100);
23
24 $builder->ok($imbase->string(x => 5, 'y' => 50, size => 20,
25 string => $text1,
26 @params), "$desc - draw text1");
27 $builder->ok($imcopy->string(x => 5, 'y' => 50, size => 20,
28 string => $text2,
29 @params), "$desc - draw text2");
30 $builder->isnt_num(Imager::i_img_diff($imbase->{IMG}, $imcopy->{IMG}), 0,
31 "$desc - check result different");
32}
33
9c106321
TC
34sub is_color3($$$$$) {
35 my ($color, $red, $green, $blue, $comment) = @_;
36
37 my $builder = Test::Builder->new;
38
39 unless (defined $color) {
40 $builder->ok(0, $comment);
41 $builder->diag("color is undef");
42 return;
43 }
44 unless ($color->can('rgba')) {
45 $builder->ok(0, $comment);
46 $builder->diag("color is not a color object");
47 return;
48 }
49
50 my ($cr, $cg, $cb) = $color->rgba;
51 unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) {
52 $builder->diag(<<END_DIAG);
53Color mismatch:
54 Red: $red vs $cr
55Green: $green vs $cg
56 Blue: $blue vs $cb
57END_DIAG
58 return;
59 }
60
61 return 1;
62}
63
6e4af7d4
TC
64sub is_color_close3($$$$$$) {
65 my ($color, $red, $green, $blue, $tolerance, $comment) = @_;
66
67 my $builder = Test::Builder->new;
68
69 unless (defined $color) {
70 $builder->ok(0, $comment);
71 $builder->diag("color is undef");
72 return;
73 }
74 unless ($color->can('rgba')) {
75 $builder->ok(0, $comment);
76 $builder->diag("color is not a color object");
77 return;
78 }
79
80 my ($cr, $cg, $cb) = $color->rgba;
81 unless ($builder->ok(abs($cr - $red) <= $tolerance
82 && abs($cg - $green) <= $tolerance
83 && abs($cb - $blue) <= $tolerance, $comment)) {
84 $builder->diag(<<END_DIAG);
85Color out of tolerance ($tolerance):
86 Red: expected $red vs received $cr
87Green: expected $green vs received $cg
88 Blue: expected $blue vs received $cb
89END_DIAG
90 return;
91 }
92
93 return 1;
94}
95
b3aa972f
TC
96sub is_color4($$$$$$) {
97 my ($color, $red, $green, $blue, $alpha, $comment) = @_;
98
99 my $builder = Test::Builder->new;
100
101 unless (defined $color) {
102 $builder->ok(0, $comment);
103 $builder->diag("color is undef");
104 return;
105 }
106 unless ($color->can('rgba')) {
107 $builder->ok(0, $comment);
108 $builder->diag("color is not a color object");
109 return;
110 }
111
112 my ($cr, $cg, $cb, $ca) = $color->rgba;
113 unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue
114 && $ca == $alpha, $comment)) {
115 $builder->diag(<<END_DIAG);
116Color mismatch:
117 Red: $red vs $cr
118Green: $green vs $cg
119 Blue: $blue vs $cb
120Alpha: $alpha vs $ca
121END_DIAG
122 return;
123 }
124
125 return 1;
126}
127
128sub is_fcolor4($$$$$$;$) {
129 my ($color, $red, $green, $blue, $alpha, $comment_or_diff, $comment_or_undef) = @_;
130 my ($comment, $mindiff);
131 if (defined $comment_or_undef) {
132 ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
133 }
134 else {
135 ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
136 }
137
138 my $builder = Test::Builder->new;
139
140 unless (defined $color) {
141 $builder->ok(0, $comment);
142 $builder->diag("color is undef");
143 return;
144 }
145 unless ($color->can('rgba')) {
146 $builder->ok(0, $comment);
147 $builder->diag("color is not a color object");
148 return;
149 }
150
151 my ($cr, $cg, $cb, $ca) = $color->rgba;
152 unless ($builder->ok(abs($cr - $red) <= $mindiff
153 && abs($cg - $green) <= $mindiff
154 && abs($cb - $blue) <= $mindiff
155 && abs($ca - $alpha) <= $mindiff, $comment)) {
156 $builder->diag(<<END_DIAG);
157Color mismatch:
158 Red: $red vs $cr
159Green: $green vs $cg
160 Blue: $blue vs $cb
161Alpha: $alpha vs $ca
162END_DIAG
163 return;
164 }
165
166 return 1;
167}
168
9c106321
TC
169sub is_color1($$$) {
170 my ($color, $grey, $comment) = @_;
171
172 my $builder = Test::Builder->new;
173
174 unless (defined $color) {
175 $builder->ok(0, $comment);
176 $builder->diag("color is undef");
177 return;
178 }
179 unless ($color->can('rgba')) {
180 $builder->ok(0, $comment);
181 $builder->diag("color is not a color object");
182 return;
183 }
184
185 my ($cgrey) = $color->rgba;
186 unless ($builder->ok($cgrey == $grey, $comment)) {
187 $builder->diag(<<END_DIAG);
188Color mismatch:
189 Grey: $grey vs $cgrey
190END_DIAG
191 return;
192 }
193
194 return 1;
195}
196
197sub test_image_raw {
198 my $green=Imager::i_color_new(0,255,0,255);
199 my $blue=Imager::i_color_new(0,0,255,255);
200 my $red=Imager::i_color_new(255,0,0,255);
201
202 my $img=Imager::ImgRaw::new(150,150,3);
203
204 Imager::i_box_filled($img,70,25,130,125,$green);
205 Imager::i_box_filled($img,20,25,80,125,$blue);
206 Imager::i_arc($img,75,75,30,0,361,$red);
207 Imager::i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
208
209 $img;
210}
211
167660cd
TC
212sub test_image {
213 my $green = Imager::Color->new(0, 255, 0, 255);
214 my $blue = Imager::Color->new(0, 0, 255, 255);
215 my $red = Imager::Color->new(255, 0, 0, 255);
216 my $img = Imager->new(xsize => 150, ysize => 150);
d5477d3d
TC
217 $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
218 $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]);
167660cd
TC
219 $img->arc(x => 75, y => 75, r => 30, color => $red);
220 $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
221
222 $img;
223}
224
9c106321
TC
225sub test_image_16 {
226 my $green = Imager::Color->new(0, 255, 0, 255);
227 my $blue = Imager::Color->new(0, 0, 255, 255);
228 my $red = Imager::Color->new(255, 0, 0, 255);
229 my $img = Imager->new(xsize => 150, ysize => 150, bits => 16);
230 $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]);
231 $img->box(filled => 1, color => $blue, box => [ 20, 25, 80, 125 ]);
232 $img->arc(x => 75, y => 75, r => 30, color => $red);
233 $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
234
235 $img;
236}
237
bd8052a6
TC
238sub test_image_double {
239 my $green = Imager::Color->new(0, 255, 0, 255);
240 my $blue = Imager::Color->new(0, 0, 255, 255);
241 my $red = Imager::Color->new(255, 0, 0, 255);
242 my $img = Imager->new(xsize => 150, ysize => 150, bits => 'double');
243 $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]);
244 $img->box(filled => 1, color => $blue, box => [ 20, 25, 80, 125 ]);
245 $img->arc(x => 75, y => 75, r => 30, color => $red);
246 $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
247
248 $img;
249}
250
167660cd
TC
251sub is_image_similar($$$$) {
252 my ($left, $right, $limit, $comment) = @_;
9c106321
TC
253
254 my $builder = Test::Builder->new;
255
256 unless (defined $left) {
257 $builder->ok(0, $comment);
258 $builder->diag("left is undef");
259 return;
260 }
261 unless (defined $right) {
262 $builder->ok(0, $comment);
263 $builder->diag("right is undef");
264 return;
265 }
266 unless ($left->{IMG}) {
267 $builder->ok(0, $comment);
268 $builder->diag("left image has no low level object");
269 return;
270 }
271 unless ($right->{IMG}) {
272 $builder->ok(0, $comment);
273 $builder->diag("right image has no low level object");
274 return;
275 }
276 unless ($left->getwidth == $right->getwidth) {
277 $builder->ok(0, $comment);
278 $builder->diag("left width " . $left->getwidth . " vs right width "
279 . $right->getwidth);
280 return;
281 }
282 unless ($left->getheight == $right->getheight) {
283 $builder->ok(0, $comment);
284 $builder->diag("left height " . $left->getheight . " vs right height "
285 . $right->getheight);
286 return;
287 }
288 unless ($left->getchannels == $right->getchannels) {
289 $builder->ok(0, $comment);
290 $builder->diag("left channels " . $left->getchannels . " vs right channels "
291 . $right->getchannels);
292 return;
293 }
294 my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
167660cd 295 if ($diff > $limit) {
9c106321 296 $builder->ok(0, $comment);
167660cd 297 $builder->diag("image data difference > $limit - $diff");
bd8052a6
TC
298
299 if ($limit == 0) {
300 # find the first mismatch
301 CHECK:
302 for my $y (0 .. $left->getheight()-1) {
303 for my $x (0.. $left->getwidth()-1) {
304 my @lsamples = $left->getsamples(x => $x, y => $y, width => 1);
305 my @rsamples = $right->getsamples(x => $x, y => $y, width => 1);
306 if ("@lsamples" ne "@rsamples") {
307 $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
308 last CHECK;
309 }
310 }
311 }
312 }
313
9c106321
TC
314 return;
315 }
316
317 return $builder->ok(1, $comment);
318}
319
167660cd
TC
320sub is_image($$$) {
321 my ($left, $right, $comment) = @_;
322
323 local $Test::Builder::Level = $Test::Builder::Level + 1;
324
325 return is_image_similar($left, $right, 0, $comment);
326}
327
837a4b43
TC
328sub image_bounds_checks {
329 my $im = shift;
330
331 my $builder = Test::Builder->new;
332
333 $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0)');
334 $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0)');
335 $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1)');
336 $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10)');
337 $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0) float');
338 $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0) float');
339 $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1) float');
340 $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10) float');
341 my $black = Imager::Color->new(0, 0, 0);
342 require Imager::Color::Float;
343 my $blackf = Imager::Color::Float->new(0, 0, 0);
344 $builder->ok(!$im->setpixel(x => -1, y => 0, color => $black), 'bounds check set (-1, 0)');
345 $builder->ok(!$im->setpixel(x => 10, y => 0, color => $black), 'bounds check set (10, 0)');
346 $builder->ok(!$im->setpixel(x => 0, y => -1, color => $black), 'bounds check set (0, -1)');
347 $builder->ok(!$im->setpixel(x => 0, y => 10, color => $black), 'bounds check set (0, 10)');
348 $builder->ok(!$im->setpixel(x => -1, y => 0, color => $blackf), 'bounds check set (-1, 0) float');
349 $builder->ok(!$im->setpixel(x => 10, y => 0, color => $blackf), 'bounds check set (10, 0) float');
350 $builder->ok(!$im->setpixel(x => 0, y => -1, color => $blackf), 'bounds check set (0, -1) float');
351 $builder->ok(!$im->setpixel(x => 0, y => 10, color => $blackf), 'bounds check set (0, 10) float');
352}
167660cd 353
bd8052a6
TC
354sub test_colorf_gpix {
355 my ($im, $x, $y, $expected, $epsilon, $comment) = @_;
356
357 my $builder = Test::Builder->new;
358
359 defined $comment or $comment = '';
360
361 my $c = Imager::i_gpixf($im, $x, $y);
362 unless ($c) {
363 $builder->ok(0, "$comment - retrieve color at ($x,$y)");
364 return;
365 }
366 unless ($builder->ok(_colorf_cmp($c, $expected, $epsilon) == 0,
367 "$comment - got right color ($x, $y)")) {
368 print "# got: (", join(",", ($c->rgba)[0,1,2]), ")\n";
369 print "# expected: (", join(",", ($expected->rgba)[0,1,2]), ")\n";
370 return;
371 }
372 1;
373}
374
375sub test_color_gpix {
376 my ($im, $x, $y, $expected, $comment) = @_;
377
378 my $builder = Test::Builder->new;
379
380 defined $comment or $comment = '';
381 my $c = Imager::i_get_pixel($im, $x, $y);
382 unless ($c) {
383 $builder->ok(0, "$comment - retrieve color at ($x,$y)");
384 return;
385 }
386 unless ($builder->ok(_color_cmp($c, $expected) == 0,
387 "got right color ($x, $y)")) {
388 print "# got: (", join(",", ($c->rgba)[0,1,2]), ")\n";
389 print "# expected: (", join(",", ($expected->rgba)[0,1,2]), ")\n";
390 return;
391 }
392
393 return 1;
394}
395
396sub test_colorf_glin {
397 my ($im, $x, $y, $pels, $comment) = @_;
398
399 my $builder = Test::Builder->new;
400
401 my @got = Imager::i_glinf($im, $x, $x+@$pels, $y);
402 @got == @$pels
403 or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved");
404
405 return $builder->ok(!grep(_colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got),
406 "$comment - check colors ($x, $y)");
407}
408
409sub _colorf_cmp {
410 my ($c1, $c2, $epsilon) = @_;
411
412 defined $epsilon or $epsilon = 0;
413
414 my @s1 = $c1->rgba;
415 my @s2 = $c2->rgba;
416
417 # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
418 return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0]
419 || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1]
420 || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
421}
422
423sub _color_cmp {
424 my ($c1, $c2) = @_;
425
426 my @s1 = $c1->rgba;
427 my @s2 = $c2->rgba;
428
429 return $s1[0] <=> $s2[0]
430 || $s1[1] <=> $s2[1]
431 || $s1[2] <=> $s2[2];
432}
433
434# these test the action of the channel mask on the image supplied
435# which should be an OO image.
436sub mask_tests {
437 my ($im, $epsilon) = @_;
438
439 my $builder = Test::Builder->new;
440
441 defined $epsilon or $epsilon = 0;
442
443 # we want to check all four of ppix() and plin(), ppix() and plinf()
444 # basic test procedure:
445 # first using default/all 1s mask, set to white
446 # make sure we got white
447 # set mask to skip a channel, set to grey
448 # make sure only the right channels set
449
450 print "# channel mask tests\n";
451 # 8-bit color tests
452 my $white = Imager::NC(255, 255, 255);
453 my $grey = Imager::NC(128, 128, 128);
454 my $white_grey = Imager::NC(128, 255, 128);
455
456 print "# with ppix\n";
457 $builder->ok($im->setmask(mask=>~0), "set to default mask");
458 $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels");
459 test_color_gpix($im->{IMG}, 0, 0, $white, "ppix");
460 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
461 $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2");
462 test_color_gpix($im->{IMG}, 0, 0, $white_grey, "ppix masked");
463
464 print "# with plin\n";
465 $builder->ok($im->setmask(mask=>~0), "set to default mask");
466 $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]),
467 "set to white all channels");
468 test_color_gpix($im->{IMG}, 0, 1, $white, "plin");
469 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
470 $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]),
471 "set to grey, no channel 2");
472 test_color_gpix($im->{IMG}, 0, 1, $white_grey, "plin masked");
473
474 # float color tests
475 my $whitef = Imager::NCF(1.0, 1.0, 1.0);
476 my $greyf = Imager::NCF(0.5, 0.5, 0.5);
477 my $white_greyf = Imager::NCF(0.5, 1.0, 0.5);
478
479 print "# with ppixf\n";
480 $builder->ok($im->setmask(mask=>~0), "set to default mask");
481 $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels");
482 test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon, "ppixf");
483 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
484 $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2");
485 test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon, "ppixf masked");
486
487 print "# with plinf\n";
488 $builder->ok($im->setmask(mask=>~0), "set to default mask");
489 $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]),
490 "set to white all channels");
491 test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon, "plinf");
492 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
493 $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]),
494 "set to grey, no channel 2");
495 test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon, "plinf masked");
496
497}
498
9a6ab99c
TC
4991;
500
501__END__
502
503=head1 NAME
504
505Imager::Test - common functions used in testing Imager
506
507=head1 SYNOPSIS
508
509 use Imager::Test 'diff_text_with_nul';
510 diff_text_with_nul($test_name, $text1, $text2, @string_options);
511
512=head1 DESCRIPTION
513
514This is a repository of functions used in testing Imager.
515
516Some functions will only be useful in testing Imager itself, while
517others should be useful in testing modules that use Imager.
518
519No functions are exported by default.
520
521=head1 FUNCTIONS
522
523=over
524
9c106321
TC
525=item is_color3($color, $red, $blue, $green, $comment)
526
527Tests is $color matches the given ($red, $blue, $green)
528
ae12796a
TC
529=item is_image($im1, $im2, $comment)
530
531Tests if the 2 images have the same content. Both images must be
532defined, have the same width, height, channels and the same color in
533each pixel. The color comparison is done at 8-bits per pixel. The
534color representation such as direct vs paletted, bits per sample are
2fac3132
TC
535not checked. Equivalent to is_image_similar($im1, $im2, 0, $comment).
536
537=item is_image_similar($im1, $im2, $maxdiff, $comment)
538
539Tests if the 2 images have similar content. Both images must be
540defined, have the same width, height and channels. The cum of the
541squares of the differences of each sample are calculated and must be
542less than or equal to I<$maxdiff> for the test to pass. The color
543comparison is done at 8-bits per pixel. The color representation such
544as direct vs paletted, bits per sample are not checked.
ae12796a 545
9c106321
TC
546=item test_image_raw()
547
548Returns a 150x150x3 Imager::ImgRaw test image.
549
d5477d3d
TC
550=item test_image()
551
552Returns a 150x150x3 8-bit/sample OO test image.
553
9c106321
TC
554=item test_image_16()
555
556Returns a 150x150x3 16-bit/sample OO test image.
557
bd8052a6
TC
558=item test_image_double()
559
560Returns a 150x150x3 double/sample OO test image.
561
9c106321 562=item diff_text_with_nul($test_name, $text1, $text2, @options)
9a6ab99c
TC
563
564Creates 2 test images and writes $text1 to the first image and $text2
565to the second image with the string() method. Each call adds 3 ok/not
566ok to the output of the test script.
567
568Extra options that should be supplied include the font and either a
569color or channel parameter.
570
571This was explicitly created for regression tests on #21770.
572
2fac3132
TC
573=item image_bounds_checks($im)
574
575Attempts to write to various pixel positions outside the edge of the
576image to ensure that it fails in those locations.
577
578Any new image type should pass these tests. Does 16 separate tests.
579
bd8052a6
TC
580=item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
581
582Retrieves the pixel ($x,$y) from the low-level image $im and compares
583it to the floating point color $expected, with a tolerance of epsilon.
584
585=item test_color_gpix($im, $x, $y, $expected, $comment)
586
587Retrieves the pixel ($x,$y) from the low-level image $im and compares
588it to the floating point color $expected.
589
590=item test_colorf_glin($im, $x, $y, $pels, $comment)
591
592Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
593low level image $im and compares them against @$pels.
594
595=item mask_tests($im, $epsilon)
596
597Perform a standard set of mask tests on the OO image $im.
598
9a6ab99c
TC
599=back
600
601=head1 AUTHOR
602
603Tony Cook <tony@develop-help.com>
604
605=cut