some Changes updates
[imager.git] / lib / Imager / Test.pm
CommitLineData
9a6ab99c
TC
1package Imager::Test;
2use strict;
76ae98a6 3use Test::More;
9a6ab99c
TC
4use Test::Builder;
5require Exporter;
5715f7c3 6use vars qw(@ISA @EXPORT_OK $VERSION);
76ae98a6 7use Carp qw(croak carp);
ac594e50 8use Config;
5715f7c3 9
76ae98a6 10$VERSION = "1.001";
5715f7c3 11
9a6ab99c 12@ISA = qw(Exporter);
8927ff88
TC
13@EXPORT_OK =
14 qw(
15 diff_text_with_nul
16 test_image_raw
17 test_image_16
18 test_image
19 test_image_double
a7e32beb
TC
20 test_image_mono
21 test_image_gray
22 test_image_gray_16
23 test_image_named
8927ff88
TC
24 is_color1
25 is_color3
26 is_color4
27 is_color_close3
62869327 28 is_fcolor1
0aae8858 29 is_fcolor3
8927ff88
TC
30 is_fcolor4
31 color_cmp
32 is_image
e41cfe8f 33 is_imaged
5cfde30f
TC
34 is_image_similar
35 isnt_image
8927ff88
TC
36 image_bounds_checks
37 mask_tests
38 test_colorf_gpix
39 test_color_gpix
ac594e50
TC
40 test_colorf_glin
41 can_test_threads
76ae98a6
TC
42 std_font_tests
43 std_font_test_count
ac594e50 44 );
9a6ab99c
TC
45
46sub diff_text_with_nul {
47 my ($desc, $text1, $text2, @params) = @_;
48
49 my $builder = Test::Builder->new;
50
51 print "# $desc\n";
52 my $imbase = Imager->new(xsize => 100, ysize => 100);
53 my $imcopy = Imager->new(xsize => 100, ysize => 100);
54
55 $builder->ok($imbase->string(x => 5, 'y' => 50, size => 20,
56 string => $text1,
57 @params), "$desc - draw text1");
58 $builder->ok($imcopy->string(x => 5, 'y' => 50, size => 20,
59 string => $text2,
60 @params), "$desc - draw text2");
61 $builder->isnt_num(Imager::i_img_diff($imbase->{IMG}, $imcopy->{IMG}), 0,
62 "$desc - check result different");
63}
64
9c106321
TC
65sub is_color3($$$$$) {
66 my ($color, $red, $green, $blue, $comment) = @_;
67
68 my $builder = Test::Builder->new;
69
70 unless (defined $color) {
71 $builder->ok(0, $comment);
72 $builder->diag("color is undef");
73 return;
74 }
75 unless ($color->can('rgba')) {
76 $builder->ok(0, $comment);
77 $builder->diag("color is not a color object");
78 return;
79 }
80
81 my ($cr, $cg, $cb) = $color->rgba;
82 unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) {
62869327 83 print <<END_DIAG;
9c106321
TC
84Color mismatch:
85 Red: $red vs $cr
86Green: $green vs $cg
87 Blue: $blue vs $cb
88END_DIAG
89 return;
90 }
91
92 return 1;
93}
94
6e4af7d4
TC
95sub is_color_close3($$$$$$) {
96 my ($color, $red, $green, $blue, $tolerance, $comment) = @_;
97
98 my $builder = Test::Builder->new;
99
100 unless (defined $color) {
101 $builder->ok(0, $comment);
102 $builder->diag("color is undef");
103 return;
104 }
105 unless ($color->can('rgba')) {
106 $builder->ok(0, $comment);
107 $builder->diag("color is not a color object");
108 return;
109 }
110
111 my ($cr, $cg, $cb) = $color->rgba;
112 unless ($builder->ok(abs($cr - $red) <= $tolerance
113 && abs($cg - $green) <= $tolerance
114 && abs($cb - $blue) <= $tolerance, $comment)) {
115 $builder->diag(<<END_DIAG);
116Color out of tolerance ($tolerance):
117 Red: expected $red vs received $cr
118Green: expected $green vs received $cg
119 Blue: expected $blue vs received $cb
120END_DIAG
121 return;
122 }
123
124 return 1;
125}
126
b3aa972f
TC
127sub is_color4($$$$$$) {
128 my ($color, $red, $green, $blue, $alpha, $comment) = @_;
129
130 my $builder = Test::Builder->new;
131
132 unless (defined $color) {
133 $builder->ok(0, $comment);
134 $builder->diag("color is undef");
135 return;
136 }
137 unless ($color->can('rgba')) {
138 $builder->ok(0, $comment);
139 $builder->diag("color is not a color object");
140 return;
141 }
142
143 my ($cr, $cg, $cb, $ca) = $color->rgba;
144 unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue
145 && $ca == $alpha, $comment)) {
146 $builder->diag(<<END_DIAG);
147Color mismatch:
52f2b10a
TC
148 Red: $cr vs $red
149Green: $cg vs $green
150 Blue: $cb vs $blue
151Alpha: $ca vs $alpha
b3aa972f
TC
152END_DIAG
153 return;
154 }
155
156 return 1;
157}
158
159sub is_fcolor4($$$$$$;$) {
160 my ($color, $red, $green, $blue, $alpha, $comment_or_diff, $comment_or_undef) = @_;
161 my ($comment, $mindiff);
162 if (defined $comment_or_undef) {
163 ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
164 }
165 else {
166 ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
167 }
168
169 my $builder = Test::Builder->new;
170
171 unless (defined $color) {
172 $builder->ok(0, $comment);
173 $builder->diag("color is undef");
174 return;
175 }
176 unless ($color->can('rgba')) {
177 $builder->ok(0, $comment);
178 $builder->diag("color is not a color object");
179 return;
180 }
181
182 my ($cr, $cg, $cb, $ca) = $color->rgba;
183 unless ($builder->ok(abs($cr - $red) <= $mindiff
184 && abs($cg - $green) <= $mindiff
185 && abs($cb - $blue) <= $mindiff
186 && abs($ca - $alpha) <= $mindiff, $comment)) {
187 $builder->diag(<<END_DIAG);
188Color mismatch:
52f2b10a
TC
189 Red: $cr vs $red
190Green: $cg vs $green
191 Blue: $cb vs $blue
192Alpha: $ca vs $alpha
b3aa972f
TC
193END_DIAG
194 return;
195 }
196
197 return 1;
198}
199
62869327
TC
200sub is_fcolor1($$$;$) {
201 my ($color, $grey, $comment_or_diff, $comment_or_undef) = @_;
202 my ($comment, $mindiff);
203 if (defined $comment_or_undef) {
204 ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
205 }
206 else {
207 ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
208 }
209
210 my $builder = Test::Builder->new;
211
212 unless (defined $color) {
213 $builder->ok(0, $comment);
214 $builder->diag("color is undef");
215 return;
216 }
217 unless ($color->can('rgba')) {
218 $builder->ok(0, $comment);
219 $builder->diag("color is not a color object");
220 return;
221 }
222
223 my ($cgrey) = $color->rgba;
224 unless ($builder->ok(abs($cgrey - $grey) <= $mindiff, $comment)) {
225 print <<END_DIAG;
226Color mismatch:
227 Gray: $cgrey vs $grey
228END_DIAG
229 return;
230 }
231
232 return 1;
233}
234
0aae8858
TC
235sub is_fcolor3($$$$$;$) {
236 my ($color, $red, $green, $blue, $comment_or_diff, $comment_or_undef) = @_;
237 my ($comment, $mindiff);
238 if (defined $comment_or_undef) {
239 ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
240 }
241 else {
242 ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
243 }
244
245 my $builder = Test::Builder->new;
246
247 unless (defined $color) {
248 $builder->ok(0, $comment);
249 $builder->diag("color is undef");
250 return;
251 }
252 unless ($color->can('rgba')) {
253 $builder->ok(0, $comment);
254 $builder->diag("color is not a color object");
255 return;
256 }
257
258 my ($cr, $cg, $cb) = $color->rgba;
259 unless ($builder->ok(abs($cr - $red) <= $mindiff
260 && abs($cg - $green) <= $mindiff
261 && abs($cb - $blue) <= $mindiff, $comment)) {
262 $builder->diag(<<END_DIAG);
263Color mismatch:
264 Red: $cr vs $red
265Green: $cg vs $green
266 Blue: $cb vs $blue
267END_DIAG
268 return;
269 }
270
271 return 1;
272}
273
9c106321
TC
274sub is_color1($$$) {
275 my ($color, $grey, $comment) = @_;
276
277 my $builder = Test::Builder->new;
278
279 unless (defined $color) {
280 $builder->ok(0, $comment);
281 $builder->diag("color is undef");
282 return;
283 }
284 unless ($color->can('rgba')) {
285 $builder->ok(0, $comment);
286 $builder->diag("color is not a color object");
287 return;
288 }
289
290 my ($cgrey) = $color->rgba;
291 unless ($builder->ok($cgrey == $grey, $comment)) {
292 $builder->diag(<<END_DIAG);
293Color mismatch:
294 Grey: $grey vs $cgrey
295END_DIAG
296 return;
297 }
298
299 return 1;
300}
301
302sub test_image_raw {
303 my $green=Imager::i_color_new(0,255,0,255);
304 my $blue=Imager::i_color_new(0,0,255,255);
305 my $red=Imager::i_color_new(255,0,0,255);
306
307 my $img=Imager::ImgRaw::new(150,150,3);
308
309 Imager::i_box_filled($img,70,25,130,125,$green);
310 Imager::i_box_filled($img,20,25,80,125,$blue);
311 Imager::i_arc($img,75,75,30,0,361,$red);
312 Imager::i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
313
314 $img;
315}
316
167660cd
TC
317sub test_image {
318 my $green = Imager::Color->new(0, 255, 0, 255);
319 my $blue = Imager::Color->new(0, 0, 255, 255);
320 my $red = Imager::Color->new(255, 0, 0, 255);
321 my $img = Imager->new(xsize => 150, ysize => 150);
d5477d3d
TC
322 $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
323 $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]);
167660cd
TC
324 $img->arc(x => 75, y => 75, r => 30, color => $red);
325 $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
326
327 $img;
328}
329
9c106321
TC
330sub test_image_16 {
331 my $green = Imager::Color->new(0, 255, 0, 255);
332 my $blue = Imager::Color->new(0, 0, 255, 255);
333 my $red = Imager::Color->new(255, 0, 0, 255);
334 my $img = Imager->new(xsize => 150, ysize => 150, bits => 16);
a7e32beb
TC
335 $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
336 $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]);
9c106321
TC
337 $img->arc(x => 75, y => 75, r => 30, color => $red);
338 $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
339
340 $img;
341}
342
bd8052a6
TC
343sub test_image_double {
344 my $green = Imager::Color->new(0, 255, 0, 255);
345 my $blue = Imager::Color->new(0, 0, 255, 255);
346 my $red = Imager::Color->new(255, 0, 0, 255);
347 my $img = Imager->new(xsize => 150, ysize => 150, bits => 'double');
a7e32beb
TC
348 $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
349 $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]);
bd8052a6
TC
350 $img->arc(x => 75, y => 75, r => 30, color => $red);
351 $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
352
353 $img;
354}
355
a7e32beb
TC
356sub test_image_gray {
357 my $g50 = Imager::Color->new(128, 128, 128);
358 my $g30 = Imager::Color->new(76, 76, 76);
359 my $g70 = Imager::Color->new(178, 178, 178);
360 my $img = Imager->new(xsize => 150, ysize => 150, channels => 1);
361 $img->box(filled => 1, color => $g50, box => [ 70, 24, 130, 124 ]);
362 $img->box(filled => 1, color => $g30, box => [ 20, 26, 80, 126 ]);
363 $img->arc(x => 75, y => 75, r => 30, color => $g70);
364 $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
365
366 return $img;
367}
368
369sub test_image_gray_16 {
370 my $g50 = Imager::Color->new(128, 128, 128);
371 my $g30 = Imager::Color->new(76, 76, 76);
372 my $g70 = Imager::Color->new(178, 178, 178);
373 my $img = Imager->new(xsize => 150, ysize => 150, channels => 1, bits => 16);
374 $img->box(filled => 1, color => $g50, box => [ 70, 24, 130, 124 ]);
375 $img->box(filled => 1, color => $g30, box => [ 20, 26, 80, 126 ]);
376 $img->arc(x => 75, y => 75, r => 30, color => $g70);
377 $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
378
379 return $img;
380}
381
382sub test_image_mono {
383 require Imager::Fill;
384 my $fh = Imager::Fill->new(hatch => 'check1x1');
385 my $img = Imager->new(xsize => 150, ysize => 150, type => "paletted");
386 my $black = Imager::Color->new(0, 0, 0);
387 my $white = Imager::Color->new(255, 255, 255);
388 $img->addcolors(colors => [ $black, $white ]);
389 $img->box(fill => $fh, box => [ 70, 24, 130, 124 ]);
390 $img->box(filled => 1, color => $white, box => [ 20, 26, 80, 126 ]);
391 $img->arc(x => 75, y => 75, r => 30, color => $black, aa => 0);
392
393 return $img;
394}
395
396my %name_to_sub =
397 (
398 basic => \&test_image,
399 basic16 => \&test_image_16,
400 basic_double => \&test_image_double,
401 gray => \&test_image_gray,
402 gray16 => \&test_image_gray_16,
403 mono => \&test_image_mono,
404 );
405
406sub test_image_named {
407 my $name = shift
408 or croak("No name supplied to test_image_named()");
409 my $sub = $name_to_sub{$name}
410 or croak("Unknown name $name supplied to test_image_named()");
411
412 return $sub->();
413}
414
e41cfe8f
TC
415sub _low_image_diff_check {
416 my ($left, $right, $comment) = @_;
9c106321
TC
417
418 my $builder = Test::Builder->new;
419
420 unless (defined $left) {
421 $builder->ok(0, $comment);
422 $builder->diag("left is undef");
423 return;
424 }
425 unless (defined $right) {
426 $builder->ok(0, $comment);
427 $builder->diag("right is undef");
428 return;
429 }
430 unless ($left->{IMG}) {
431 $builder->ok(0, $comment);
432 $builder->diag("left image has no low level object");
433 return;
434 }
435 unless ($right->{IMG}) {
436 $builder->ok(0, $comment);
437 $builder->diag("right image has no low level object");
438 return;
439 }
440 unless ($left->getwidth == $right->getwidth) {
441 $builder->ok(0, $comment);
442 $builder->diag("left width " . $left->getwidth . " vs right width "
443 . $right->getwidth);
444 return;
445 }
446 unless ($left->getheight == $right->getheight) {
447 $builder->ok(0, $comment);
448 $builder->diag("left height " . $left->getheight . " vs right height "
449 . $right->getheight);
450 return;
451 }
452 unless ($left->getchannels == $right->getchannels) {
453 $builder->ok(0, $comment);
454 $builder->diag("left channels " . $left->getchannels . " vs right channels "
455 . $right->getchannels);
456 return;
457 }
e41cfe8f
TC
458
459 return 1;
460}
461
462sub is_image_similar($$$$) {
463 my ($left, $right, $limit, $comment) = @_;
464
465 {
466 local $Test::Builder::Level = $Test::Builder::Level + 1;
467
468 _low_image_diff_check($left, $right, $comment)
469 or return;
470 }
471
472 my $builder = Test::Builder->new;
473
9c106321 474 my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
167660cd 475 if ($diff > $limit) {
9c106321 476 $builder->ok(0, $comment);
167660cd 477 $builder->diag("image data difference > $limit - $diff");
bd8052a6
TC
478
479 if ($limit == 0) {
480 # find the first mismatch
c5f447ac 481 PIXELS:
bd8052a6
TC
482 for my $y (0 .. $left->getheight()-1) {
483 for my $x (0.. $left->getwidth()-1) {
484 my @lsamples = $left->getsamples(x => $x, y => $y, width => 1);
485 my @rsamples = $right->getsamples(x => $x, y => $y, width => 1);
486 if ("@lsamples" ne "@rsamples") {
487 $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
c5f447ac 488 last PIXELS;
bd8052a6
TC
489 }
490 }
491 }
492 }
493
9c106321
TC
494 return;
495 }
496
497 return $builder->ok(1, $comment);
498}
499
167660cd
TC
500sub is_image($$$) {
501 my ($left, $right, $comment) = @_;
502
503 local $Test::Builder::Level = $Test::Builder::Level + 1;
504
505 return is_image_similar($left, $right, 0, $comment);
506}
507
360e674e 508sub is_imaged($$$;$) {
4498c8bd
TC
509 my $epsilon = Imager::i_img_epsilonf();
510 if (@_ > 3) {
511 ($epsilon) = splice @_, 2, 1;
512 }
513
e41cfe8f
TC
514 my ($left, $right, $comment) = @_;
515
516 {
517 local $Test::Builder::Level = $Test::Builder::Level + 1;
518
519 _low_image_diff_check($left, $right, $comment)
520 or return;
521 }
522
523 my $builder = Test::Builder->new;
524
4498c8bd
TC
525 my $same = Imager::i_img_samef($left->{IMG}, $right->{IMG}, $epsilon, $comment);
526 if (!$same) {
e41cfe8f 527 $builder->ok(0, $comment);
4498c8bd
TC
528 $builder->diag("images different");
529
e41cfe8f
TC
530 # find the first mismatch
531 PIXELS:
532 for my $y (0 .. $left->getheight()-1) {
533 for my $x (0.. $left->getwidth()-1) {
4498c8bd
TC
534 my @lsamples = $left->getsamples(x => $x, y => $y, width => 1, type => "float");
535 my @rsamples = $right->getsamples(x => $x, y => $y, width => 1, type => "float");
e41cfe8f
TC
536 if ("@lsamples" ne "@rsamples") {
537 $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
538 last PIXELS;
539 }
540 }
541 }
542
543 return;
544 }
545
546 return $builder->ok(1, $comment);
547}
548
5cfde30f
TC
549sub isnt_image {
550 my ($left, $right, $comment) = @_;
551
552 my $builder = Test::Builder->new;
553
554 my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
555
556 return $builder->ok($diff, "$comment");
557}
558
837a4b43
TC
559sub image_bounds_checks {
560 my $im = shift;
561
562 my $builder = Test::Builder->new;
563
564 $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0)');
565 $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0)');
566 $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1)');
567 $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10)');
568 $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0) float');
569 $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0) float');
570 $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1) float');
571 $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10) float');
572 my $black = Imager::Color->new(0, 0, 0);
573 require Imager::Color::Float;
574 my $blackf = Imager::Color::Float->new(0, 0, 0);
575 $builder->ok(!$im->setpixel(x => -1, y => 0, color => $black), 'bounds check set (-1, 0)');
576 $builder->ok(!$im->setpixel(x => 10, y => 0, color => $black), 'bounds check set (10, 0)');
577 $builder->ok(!$im->setpixel(x => 0, y => -1, color => $black), 'bounds check set (0, -1)');
578 $builder->ok(!$im->setpixel(x => 0, y => 10, color => $black), 'bounds check set (0, 10)');
579 $builder->ok(!$im->setpixel(x => -1, y => 0, color => $blackf), 'bounds check set (-1, 0) float');
580 $builder->ok(!$im->setpixel(x => 10, y => 0, color => $blackf), 'bounds check set (10, 0) float');
581 $builder->ok(!$im->setpixel(x => 0, y => -1, color => $blackf), 'bounds check set (0, -1) float');
582 $builder->ok(!$im->setpixel(x => 0, y => 10, color => $blackf), 'bounds check set (0, 10) float');
583}
167660cd 584
bd8052a6
TC
585sub test_colorf_gpix {
586 my ($im, $x, $y, $expected, $epsilon, $comment) = @_;
587
588 my $builder = Test::Builder->new;
589
590 defined $comment or $comment = '';
591
592 my $c = Imager::i_gpixf($im, $x, $y);
593 unless ($c) {
594 $builder->ok(0, "$comment - retrieve color at ($x,$y)");
595 return;
596 }
8927ff88 597 unless ($builder->ok(colorf_cmp($c, $expected, $epsilon) == 0,
bd8052a6 598 "$comment - got right color ($x, $y)")) {
8927ff88
TC
599 my @c = $c->rgba;
600 my @exp = $expected->rgba;
601 $builder->diag(<<EOS);
602# got: ($c[0], $c[1], $c[2])
603# expected: ($exp[0], $exp[1], $exp[2])
604EOS
bd8052a6
TC
605 }
606 1;
607}
608
609sub test_color_gpix {
610 my ($im, $x, $y, $expected, $comment) = @_;
611
612 my $builder = Test::Builder->new;
613
614 defined $comment or $comment = '';
615 my $c = Imager::i_get_pixel($im, $x, $y);
616 unless ($c) {
617 $builder->ok(0, "$comment - retrieve color at ($x,$y)");
618 return;
619 }
8927ff88 620 unless ($builder->ok(color_cmp($c, $expected) == 0,
bd8052a6 621 "got right color ($x, $y)")) {
8927ff88
TC
622 my @c = $c->rgba;
623 my @exp = $expected->rgba;
624 $builder->diag(<<EOS);
625# got: ($c[0], $c[1], $c[2])
626# expected: ($exp[0], $exp[1], $exp[2])
627EOS
bd8052a6
TC
628 return;
629 }
630
631 return 1;
632}
633
634sub test_colorf_glin {
635 my ($im, $x, $y, $pels, $comment) = @_;
636
637 my $builder = Test::Builder->new;
638
639 my @got = Imager::i_glinf($im, $x, $x+@$pels, $y);
640 @got == @$pels
641 or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved");
642
8927ff88 643 return $builder->ok(!grep(colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got),
bd8052a6
TC
644 "$comment - check colors ($x, $y)");
645}
646
8927ff88 647sub colorf_cmp {
bd8052a6
TC
648 my ($c1, $c2, $epsilon) = @_;
649
650 defined $epsilon or $epsilon = 0;
651
652 my @s1 = $c1->rgba;
653 my @s2 = $c2->rgba;
654
655 # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
656 return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0]
657 || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1]
658 || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
659}
660
8927ff88 661sub color_cmp {
bd8052a6
TC
662 my ($c1, $c2) = @_;
663
664 my @s1 = $c1->rgba;
665 my @s2 = $c2->rgba;
666
667 return $s1[0] <=> $s2[0]
668 || $s1[1] <=> $s2[1]
669 || $s1[2] <=> $s2[2];
670}
671
672# these test the action of the channel mask on the image supplied
673# which should be an OO image.
674sub mask_tests {
675 my ($im, $epsilon) = @_;
676
677 my $builder = Test::Builder->new;
678
679 defined $epsilon or $epsilon = 0;
680
681 # we want to check all four of ppix() and plin(), ppix() and plinf()
682 # basic test procedure:
683 # first using default/all 1s mask, set to white
684 # make sure we got white
685 # set mask to skip a channel, set to grey
686 # make sure only the right channels set
687
688 print "# channel mask tests\n";
689 # 8-bit color tests
690 my $white = Imager::NC(255, 255, 255);
691 my $grey = Imager::NC(128, 128, 128);
692 my $white_grey = Imager::NC(128, 255, 128);
693
694 print "# with ppix\n";
695 $builder->ok($im->setmask(mask=>~0), "set to default mask");
696 $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels");
697 test_color_gpix($im->{IMG}, 0, 0, $white, "ppix");
698 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
699 $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2");
700 test_color_gpix($im->{IMG}, 0, 0, $white_grey, "ppix masked");
701
702 print "# with plin\n";
703 $builder->ok($im->setmask(mask=>~0), "set to default mask");
704 $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]),
705 "set to white all channels");
706 test_color_gpix($im->{IMG}, 0, 1, $white, "plin");
707 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
708 $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]),
709 "set to grey, no channel 2");
710 test_color_gpix($im->{IMG}, 0, 1, $white_grey, "plin masked");
711
712 # float color tests
713 my $whitef = Imager::NCF(1.0, 1.0, 1.0);
714 my $greyf = Imager::NCF(0.5, 0.5, 0.5);
715 my $white_greyf = Imager::NCF(0.5, 1.0, 0.5);
716
717 print "# with ppixf\n";
718 $builder->ok($im->setmask(mask=>~0), "set to default mask");
719 $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels");
720 test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon, "ppixf");
721 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
722 $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2");
723 test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon, "ppixf masked");
724
725 print "# with plinf\n";
726 $builder->ok($im->setmask(mask=>~0), "set to default mask");
727 $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]),
728 "set to white all channels");
729 test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon, "plinf");
730 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
731 $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]),
732 "set to grey, no channel 2");
733 test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon, "plinf masked");
734
735}
736
76ae98a6
TC
737sub std_font_test_count {
738 return 21;
739}
740
741sub std_font_tests {
742 my ($opts) = @_;
743
744 my $font = $opts->{font}
745 or carp "Missing font parameter";
746
747 my $name_font = $opts->{glyph_name_font} || $font;
748
749 my $has_chars = $opts->{has_chars} || [ 1, '', 1 ];
750
751 my $glyph_names = $opts->{glyph_names} || [ "A", undef, "A" ];
752
753 SKIP:
754 { # check magic is handled correctly
755 # https://rt.cpan.org/Ticket/Display.html?id=83438
756 skip("no native UTF8 support in this version of perl", 10)
757 unless $] >= 5.006;
758 Imager->log("utf8 magic tests\n");
759 my $over = bless {}, "Imager::Test::OverUtf8";
760 my $text = "A".chr(0x2010)."A";
761 my $white = Imager::Color->new("#FFF");
762 my $base_draw = Imager->new(xsize => 80, ysize => 20);
763 ok($base_draw->string(font => $font,
764 text => $text,
765 x => 2,
766 y => 18,
767 size => 15,
768 color => $white,
769 aa => 1),
770 "magic: make a base image");
771 my $test_draw = Imager->new(xsize => 80, ysize => 20);
772 ok($test_draw->string(font => $font,
773 text => $over,
774 x => 2,
775 y => 18,
776 size => 15,
777 color => $white,
778 aa => 1),
779 "magic: draw with overload");
780 is_image($base_draw, $test_draw, "check they match");
781 if ($opts->{files}) {
782 $test_draw->write(file => "testout/utf8tdr.ppm");
783 $base_draw->write(file => "testout/utf8bdr.ppm");
784 }
785
786 my $base_cp = Imager->new(xsize => 80, ysize => 20);
787 $base_cp->box(filled => 1, color => "#808080");
788 my $test_cp = $base_cp->copy;
789 ok($base_cp->string(font => $font,
790 text => $text,
791 y => 2,
792 y => 18,
793 size => 16,
794 channel => 2,
795 aa => 1),
796 "magic: make a base image (channel)");
797 Imager->log("magic: draw to channel with overload\n");
798 ok($test_cp->string(font => $font,
799 text => $over,
800 y => 2,
801 y => 18,
802 size => 16,
803 channel => 2,
804 aa => 1),
805 "magic: draw with overload (channel)");
806 is_image($test_cp, $base_cp, "check they match");
807 if ($opts->{files}) {
808 $test_cp->write(file => "testout/utf8tcp.ppm");
809 $base_cp->write(file => "testout/utf8bcp.ppm");
810 }
811
812 Imager->log("magic: has_chars");
813 is_deeply([ $font->has_chars(string => $text) ], $has_chars,
814 "magic: has_chars with normal utf8 text");
815 is_deeply([ $font->has_chars(string => $over) ], $has_chars,
816 "magic: has_chars with magic utf8 text");
817
818 Imager->log("magic: bounding_box\n");
819 my @base_bb = $font->bounding_box(string => $text, size => 30);
820 is_deeply([ $font->bounding_box(string => $over, size => 30) ],
821 \@base_bb,
822 "check bounding box magic");
823
824 SKIP:
825 {
826 $font->can_glyph_names
827 or skip "No glyph_names", 2;
828 Imager->log("magic: glyph_names\n");
829 my @text_names = $name_font->glyph_names(string => $text, reliable_only => 0);
830 is_deeply(\@text_names, $glyph_names,
831 "magic: glyph_names with normal utf8 text");
832 my @over_names = $name_font->glyph_names(string => $over, reliable_only => 0);
833 is_deeply(\@over_names, $glyph_names,
834 "magic: glyph_names with magic utf8 text");
835 }
836 }
837
838 { # invalid UTF8 handling at the OO level
839 my $im = Imager->new(xsize => 80, ysize => 20);
840 my $bad_utf8 = pack("C", 0xC0);
841 Imager->_set_error("");
842 ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1,
843 y => 18, x => 2),
844 "drawing invalid utf8 should fail");
845 is($im->errstr, "invalid UTF8 character", "check error message");
846 Imager->_set_error("");
847 ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1,
848 y => 18, x => 2, channel => 1),
849 "drawing invalid utf8 should fail (channel)");
850 is($im->errstr, "invalid UTF8 character", "check error message");
851 Imager->_set_error("");
852 ok(!$font->bounding_box(string => $bad_utf8, size => 30, utf8 => 1),
853 "bounding_box() bad utf8 should fail");
854 is(Imager->errstr, "invalid UTF8 character", "check error message");
855 Imager->_set_error("");
856 is_deeply([ $font->glyph_names(string => $bad_utf8, utf8 => 1) ],
857 [ ],
858 "glyph_names returns empty list for bad string");
859 is(Imager->errstr, "invalid UTF8 character", "check error message");
860 Imager->_set_error("");
861 is_deeply([ $font->has_chars(string => $bad_utf8, utf8 => 1) ],
862 [ ],
863 "has_chars returns empty list for bad string");
864 is(Imager->errstr, "invalid UTF8 character", "check error message");
865 }
866}
867
868package Imager::Test::OverUtf8;
869use overload '""' => sub { "A".chr(0x2010)."A" };
870
871
9a6ab99c
TC
8721;
873
874__END__
875
876=head1 NAME
877
878Imager::Test - common functions used in testing Imager
879
880=head1 SYNOPSIS
881
882 use Imager::Test 'diff_text_with_nul';
883 diff_text_with_nul($test_name, $text1, $text2, @string_options);
884
885=head1 DESCRIPTION
886
887This is a repository of functions used in testing Imager.
888
889Some functions will only be useful in testing Imager itself, while
890others should be useful in testing modules that use Imager.
891
892No functions are exported by default.
893
894=head1 FUNCTIONS
895
0aae8858
TC
896=head2 Test functions
897
5715f7c3
TC
898=for stopwords OO
899
9a6ab99c
TC
900=over
901
0aae8858
TC
902=item is_color1($color, $grey, $comment)
903
904Tests if the first channel of $color matches $grey.
905
906=item is_color3($color, $red, $green, $blue, $comment)
907
908Tests if $color matches the given ($red, $green, $blue)
909
910=item is_color4($color, $red, $green, $blue, $alpha, $comment)
911
912Tests if $color matches the given ($red, $green, $blue, $alpha)
9c106321 913
62869327
TC
914=item is_fcolor1($fcolor, $grey, $comment)
915
916=item is_fcolor1($fcolor, $grey, $epsilon, $comment)
917
918Tests if $fcolor's first channel is within $epsilon of ($grey). For
919the first form $epsilon is taken as 0.001.
920
0aae8858
TC
921=item is_fcolor3($fcolor, $red, $green, $blue, $comment)
922
923=item is_fcolor3($fcolor, $red, $green, $blue, $epsilon, $comment)
924
925Tests if $fcolor's channels are within $epsilon of ($red, $green,
926$blue). For the first form $epsilon is taken as 0.001.
927
928=item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $comment)
929
930=item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $epsilon, $comment)
931
932Tests if $fcolor's channels are within $epsilon of ($red, $green,
933$blue, $alpha). For the first form $epsilon is taken as 0.001.
9c106321 934
ae12796a
TC
935=item is_image($im1, $im2, $comment)
936
937Tests if the 2 images have the same content. Both images must be
938defined, have the same width, height, channels and the same color in
939each pixel. The color comparison is done at 8-bits per pixel. The
940color representation such as direct vs paletted, bits per sample are
2fac3132
TC
941not checked. Equivalent to is_image_similar($im1, $im2, 0, $comment).
942
e41cfe8f
TC
943=item is_imaged($im, $im2, $comment)
944
4498c8bd
TC
945=item is_imaged($im, $im2, $epsilon, $comment)
946
e41cfe8f 947Tests if the two images have the same content at the double/sample
4498c8bd
TC
948level. C<$epsilon> defaults to the platform DBL_EPSILON multiplied by
949four.
e41cfe8f 950
2fac3132
TC
951=item is_image_similar($im1, $im2, $maxdiff, $comment)
952
953Tests if the 2 images have similar content. Both images must be
954defined, have the same width, height and channels. The cum of the
955squares of the differences of each sample are calculated and must be
956less than or equal to I<$maxdiff> for the test to pass. The color
957comparison is done at 8-bits per pixel. The color representation such
958as direct vs paletted, bits per sample are not checked.
ae12796a 959
0aae8858 960=item isnt_image($im1, $im2, $comment)
9c106321 961
0aae8858
TC
962Tests that the two images are different. For regressions tests where
963something (like text output of "0") produced no change, but should
964have produced a change.
9c106321 965
0aae8858 966=item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
d5477d3d 967
0aae8858
TC
968Retrieves the pixel ($x,$y) from the low-level image $im and compares
969it to the floating point color $expected, with a tolerance of epsilon.
d5477d3d 970
0aae8858 971=item test_color_gpix($im, $x, $y, $expected, $comment)
9c106321 972
0aae8858
TC
973Retrieves the pixel ($x,$y) from the low-level image $im and compares
974it to the floating point color $expected.
9c106321 975
0aae8858 976=item test_colorf_glin($im, $x, $y, $pels, $comment)
bd8052a6 977
0aae8858
TC
978Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
979low level image $im and compares them against @$pels.
980
981=item is_color_close3($color, $red, $green, $blue, $tolerance, $comment)
982
983Tests if $color's first three channels are within $tolerance of ($red,
984$green, $blue).
985
986=back
987
988=head2 Test suite functions
989
990Functions that perform one or more tests, typically used to test
991various parts of Imager's implementation.
992
993=over
994
995=item image_bounds_checks($im)
996
997Attempts to write to various pixel positions outside the edge of the
998image to ensure that it fails in those locations.
999
1000Any new image type should pass these tests. Does 16 separate tests.
1001
1002=item mask_tests($im, $epsilon)
1003
1004Perform a standard set of mask tests on the OO image $im. Does 24
1005separate tests.
bd8052a6 1006
9c106321 1007=item diff_text_with_nul($test_name, $text1, $text2, @options)
9a6ab99c
TC
1008
1009Creates 2 test images and writes $text1 to the first image and $text2
5715f7c3
TC
1010to the second image with the string() method. Each call adds 3
1011C<ok>/C<not ok> to the output of the test script.
9a6ab99c
TC
1012
1013Extra options that should be supplied include the font and either a
1014color or channel parameter.
1015
1016This was explicitly created for regression tests on #21770.
1017
76ae98a6
TC
1018=item std_font_tests({ font => $font })
1019
1020Perform standard font interface tests.
1021
1022=item std_font_test_count()
1023
1024The number of tests performed by std_font_tests().
1025
0aae8858 1026=back
2fac3132 1027
0aae8858 1028=head2 Helper functions
2fac3132 1029
0aae8858 1030=over
2fac3132 1031
0aae8858 1032=item test_image_raw()
bd8052a6 1033
0aae8858 1034Returns a 150x150x3 Imager::ImgRaw test image.
bd8052a6 1035
0aae8858 1036=item test_image()
bd8052a6 1037
ca6c0621 1038Returns a 150x150x3 8-bit/sample OO test image. Name: C<basic>.
bd8052a6 1039
0aae8858 1040=item test_image_16()
bd8052a6 1041
ca6c0621 1042Returns a 150x150x3 16-bit/sample OO test image. Name: C<basic16>
bd8052a6 1043
0aae8858
TC
1044=item test_image_double()
1045
ca6c0621
TC
1046Returns a 150x150x3 double/sample OO test image. Name: C<basic_double>.
1047
1048=item test_image_gray()
1049
1050Returns a 150x150 single channel OO test image. Name: C<gray>.
1051
1052=item test_image_gray_16()
1053
1054Returns a 150x150 16-bit/sample single channel OO test image. Name:
1055C<gray16>.
1056
1057=item test_image_mono()
1058
1059Returns a 150x150 bilevel image that passes the is_bilevel() test.
1060Name: C<mono>.
1061
1062=item test_image_named($name)
1063
1064Return one of the other test images above based on name.
0aae8858
TC
1065
1066=item color_cmp($c1, $c2)
1067
1068Performs an ordering of 3-channel colors (like <=>).
1069
1070=item colorf_cmp($c1, $c2)
bd8052a6 1071
0aae8858 1072Performs an ordering of 3-channel floating point colors (like <=>).
bd8052a6 1073
9a6ab99c
TC
1074=back
1075
1076=head1 AUTHOR
1077
1078Tony Cook <tony@develop-help.com>
1079
1080=cut