implement standard font tests for Imager::Font::W32
[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
405c8105
TC
812 SKIP:
813 {
814 Imager->log("magic: has_chars\n");
815 $font->can("has_chars")
816 or skip "No has_chars aupport", 2;
817 is_deeply([ $font->has_chars(string => $text) ], $has_chars,
818 "magic: has_chars with normal utf8 text");
819 is_deeply([ $font->has_chars(string => $over) ], $has_chars,
820 "magic: has_chars with magic utf8 text");
821 }
76ae98a6
TC
822
823 Imager->log("magic: bounding_box\n");
824 my @base_bb = $font->bounding_box(string => $text, size => 30);
825 is_deeply([ $font->bounding_box(string => $over, size => 30) ],
826 \@base_bb,
827 "check bounding box magic");
828
829 SKIP:
830 {
831 $font->can_glyph_names
832 or skip "No glyph_names", 2;
833 Imager->log("magic: glyph_names\n");
834 my @text_names = $name_font->glyph_names(string => $text, reliable_only => 0);
835 is_deeply(\@text_names, $glyph_names,
836 "magic: glyph_names with normal utf8 text");
837 my @over_names = $name_font->glyph_names(string => $over, reliable_only => 0);
838 is_deeply(\@over_names, $glyph_names,
839 "magic: glyph_names with magic utf8 text");
840 }
841 }
842
843 { # invalid UTF8 handling at the OO level
844 my $im = Imager->new(xsize => 80, ysize => 20);
845 my $bad_utf8 = pack("C", 0xC0);
846 Imager->_set_error("");
847 ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1,
848 y => 18, x => 2),
849 "drawing invalid utf8 should fail");
850 is($im->errstr, "invalid UTF8 character", "check error message");
851 Imager->_set_error("");
852 ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1,
853 y => 18, x => 2, channel => 1),
854 "drawing invalid utf8 should fail (channel)");
855 is($im->errstr, "invalid UTF8 character", "check error message");
856 Imager->_set_error("");
857 ok(!$font->bounding_box(string => $bad_utf8, size => 30, utf8 => 1),
858 "bounding_box() bad utf8 should fail");
859 is(Imager->errstr, "invalid UTF8 character", "check error message");
405c8105
TC
860 SKIP:
861 {
862 $font->can_glyph_names
863 or skip "No glyph_names support", 2;
864 Imager->_set_error("");
865 is_deeply([ $font->glyph_names(string => $bad_utf8, utf8 => 1) ],
866 [ ],
867 "glyph_names returns empty list for bad string");
868 is(Imager->errstr, "invalid UTF8 character", "check error message");
869 }
870 SKIP:
871 {
872 $font->can("has_chars")
873 or skip "No has_chars support", 2;
874 Imager->_set_error("");
875 is_deeply([ $font->has_chars(string => $bad_utf8, utf8 => 1) ],
876 [ ],
877 "has_chars returns empty list for bad string");
878 is(Imager->errstr, "invalid UTF8 character", "check error message");
879 }
76ae98a6
TC
880 }
881}
882
883package Imager::Test::OverUtf8;
884use overload '""' => sub { "A".chr(0x2010)."A" };
885
886
9a6ab99c
TC
8871;
888
889__END__
890
891=head1 NAME
892
893Imager::Test - common functions used in testing Imager
894
895=head1 SYNOPSIS
896
897 use Imager::Test 'diff_text_with_nul';
898 diff_text_with_nul($test_name, $text1, $text2, @string_options);
899
900=head1 DESCRIPTION
901
902This is a repository of functions used in testing Imager.
903
904Some functions will only be useful in testing Imager itself, while
905others should be useful in testing modules that use Imager.
906
907No functions are exported by default.
908
909=head1 FUNCTIONS
910
0aae8858
TC
911=head2 Test functions
912
5715f7c3
TC
913=for stopwords OO
914
9a6ab99c
TC
915=over
916
0aae8858
TC
917=item is_color1($color, $grey, $comment)
918
919Tests if the first channel of $color matches $grey.
920
921=item is_color3($color, $red, $green, $blue, $comment)
922
923Tests if $color matches the given ($red, $green, $blue)
924
925=item is_color4($color, $red, $green, $blue, $alpha, $comment)
926
927Tests if $color matches the given ($red, $green, $blue, $alpha)
9c106321 928
62869327
TC
929=item is_fcolor1($fcolor, $grey, $comment)
930
931=item is_fcolor1($fcolor, $grey, $epsilon, $comment)
932
933Tests if $fcolor's first channel is within $epsilon of ($grey). For
934the first form $epsilon is taken as 0.001.
935
0aae8858
TC
936=item is_fcolor3($fcolor, $red, $green, $blue, $comment)
937
938=item is_fcolor3($fcolor, $red, $green, $blue, $epsilon, $comment)
939
940Tests if $fcolor's channels are within $epsilon of ($red, $green,
941$blue). For the first form $epsilon is taken as 0.001.
942
943=item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $comment)
944
945=item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $epsilon, $comment)
946
947Tests if $fcolor's channels are within $epsilon of ($red, $green,
948$blue, $alpha). For the first form $epsilon is taken as 0.001.
9c106321 949
ae12796a
TC
950=item is_image($im1, $im2, $comment)
951
952Tests if the 2 images have the same content. Both images must be
953defined, have the same width, height, channels and the same color in
954each pixel. The color comparison is done at 8-bits per pixel. The
955color representation such as direct vs paletted, bits per sample are
2fac3132
TC
956not checked. Equivalent to is_image_similar($im1, $im2, 0, $comment).
957
e41cfe8f
TC
958=item is_imaged($im, $im2, $comment)
959
4498c8bd
TC
960=item is_imaged($im, $im2, $epsilon, $comment)
961
e41cfe8f 962Tests if the two images have the same content at the double/sample
4498c8bd
TC
963level. C<$epsilon> defaults to the platform DBL_EPSILON multiplied by
964four.
e41cfe8f 965
2fac3132
TC
966=item is_image_similar($im1, $im2, $maxdiff, $comment)
967
968Tests if the 2 images have similar content. Both images must be
969defined, have the same width, height and channels. The cum of the
970squares of the differences of each sample are calculated and must be
971less than or equal to I<$maxdiff> for the test to pass. The color
972comparison is done at 8-bits per pixel. The color representation such
973as direct vs paletted, bits per sample are not checked.
ae12796a 974
0aae8858 975=item isnt_image($im1, $im2, $comment)
9c106321 976
0aae8858
TC
977Tests that the two images are different. For regressions tests where
978something (like text output of "0") produced no change, but should
979have produced a change.
9c106321 980
0aae8858 981=item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
d5477d3d 982
0aae8858
TC
983Retrieves the pixel ($x,$y) from the low-level image $im and compares
984it to the floating point color $expected, with a tolerance of epsilon.
d5477d3d 985
0aae8858 986=item test_color_gpix($im, $x, $y, $expected, $comment)
9c106321 987
0aae8858
TC
988Retrieves the pixel ($x,$y) from the low-level image $im and compares
989it to the floating point color $expected.
9c106321 990
0aae8858 991=item test_colorf_glin($im, $x, $y, $pels, $comment)
bd8052a6 992
0aae8858
TC
993Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
994low level image $im and compares them against @$pels.
995
996=item is_color_close3($color, $red, $green, $blue, $tolerance, $comment)
997
998Tests if $color's first three channels are within $tolerance of ($red,
999$green, $blue).
1000
1001=back
1002
1003=head2 Test suite functions
1004
1005Functions that perform one or more tests, typically used to test
1006various parts of Imager's implementation.
1007
1008=over
1009
1010=item image_bounds_checks($im)
1011
1012Attempts to write to various pixel positions outside the edge of the
1013image to ensure that it fails in those locations.
1014
1015Any new image type should pass these tests. Does 16 separate tests.
1016
1017=item mask_tests($im, $epsilon)
1018
1019Perform a standard set of mask tests on the OO image $im. Does 24
1020separate tests.
bd8052a6 1021
9c106321 1022=item diff_text_with_nul($test_name, $text1, $text2, @options)
9a6ab99c
TC
1023
1024Creates 2 test images and writes $text1 to the first image and $text2
5715f7c3
TC
1025to the second image with the string() method. Each call adds 3
1026C<ok>/C<not ok> to the output of the test script.
9a6ab99c
TC
1027
1028Extra options that should be supplied include the font and either a
1029color or channel parameter.
1030
1031This was explicitly created for regression tests on #21770.
1032
76ae98a6
TC
1033=item std_font_tests({ font => $font })
1034
1035Perform standard font interface tests.
1036
1037=item std_font_test_count()
1038
1039The number of tests performed by std_font_tests().
1040
0aae8858 1041=back
2fac3132 1042
0aae8858 1043=head2 Helper functions
2fac3132 1044
0aae8858 1045=over
2fac3132 1046
0aae8858 1047=item test_image_raw()
bd8052a6 1048
0aae8858 1049Returns a 150x150x3 Imager::ImgRaw test image.
bd8052a6 1050
0aae8858 1051=item test_image()
bd8052a6 1052
ca6c0621 1053Returns a 150x150x3 8-bit/sample OO test image. Name: C<basic>.
bd8052a6 1054
0aae8858 1055=item test_image_16()
bd8052a6 1056
ca6c0621 1057Returns a 150x150x3 16-bit/sample OO test image. Name: C<basic16>
bd8052a6 1058
0aae8858
TC
1059=item test_image_double()
1060
ca6c0621
TC
1061Returns a 150x150x3 double/sample OO test image. Name: C<basic_double>.
1062
1063=item test_image_gray()
1064
1065Returns a 150x150 single channel OO test image. Name: C<gray>.
1066
1067=item test_image_gray_16()
1068
1069Returns a 150x150 16-bit/sample single channel OO test image. Name:
1070C<gray16>.
1071
1072=item test_image_mono()
1073
1074Returns a 150x150 bilevel image that passes the is_bilevel() test.
1075Name: C<mono>.
1076
1077=item test_image_named($name)
1078
1079Return one of the other test images above based on name.
0aae8858
TC
1080
1081=item color_cmp($c1, $c2)
1082
1083Performs an ordering of 3-channel colors (like <=>).
1084
1085=item colorf_cmp($c1, $c2)
bd8052a6 1086
0aae8858 1087Performs an ordering of 3-channel floating point colors (like <=>).
bd8052a6 1088
9a6ab99c
TC
1089=back
1090
1091=head1 AUTHOR
1092
1093Tony Cook <tony@develop-help.com>
1094
1095=cut