lib/Imager/Test.pm

   1 package Imager::Test;
   2 use strict;
   3 use Test::More;
   4 use Test::Builder;
   5 require Exporter;
   6 use vars qw(@ISA @EXPORT_OK $VERSION);
   7 use Carp qw(croak carp);
   8 use Config;
   9
  10 $VERSION = "1.002";
  11
  12 @ISA = qw(Exporter);
  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
  20      test_image_mono
  21      test_image_gray
  22      test_image_gray_16
  23      test_image_named
  24      is_color1
  25      is_color3
  26      is_color4
  27      is_color_close3
  28      is_fcolor1
  29      is_fcolor3
  30      is_fcolor4
  31      color_cmp
  32      is_image
  33      is_imaged
  34      is_image_similar
  35      isnt_image
  36      image_bounds_checks
  37      mask_tests
  38      test_colorf_gpix
  39      test_color_gpix
  40      test_colorf_glin
  41      can_test_threads
  42      std_font_tests
  43      std_font_test_count
  44      );
  45
  46 sub 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
  65 sub 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)) {
  83     print <<END_DIAG;
  84 Color mismatch:
  85   Red: $red vs $cr
  86 Green: $green vs $cg
  87  Blue: $blue vs $cb
  88 END_DIAG
  89     return;
  90   }
  91
  92   return 1;
  93 }
  94
  95 sub 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);
 116 Color out of tolerance ($tolerance):
 117   Red: expected $red vs received $cr
 118 Green: expected $green vs received $cg
 119  Blue: expected $blue vs received $cb
 120 END_DIAG
 121     return;
 122   }
 123
 124   return 1;
 125 }
 126
 127 sub 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);
 147 Color mismatch:
 148   Red: $cr vs $red
 149 Green: $cg vs $green
 150  Blue: $cb vs $blue
 151 Alpha: $ca vs $alpha
 152 END_DIAG
 153     return;
 154   }
 155
 156   return 1;
 157 }
 158
 159 sub 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);
 188 Color mismatch:
 189   Red: $cr vs $red
 190 Green: $cg vs $green
 191  Blue: $cb vs $blue
 192 Alpha: $ca vs $alpha
 193 END_DIAG
 194     return;
 195   }
 196
 197   return 1;
 198 }
 199
 200 sub 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;
 226 Color mismatch:
 227   Gray: $cgrey vs $grey
 228 END_DIAG
 229     return;
 230   }
 231
 232   return 1;
 233 }
 234
 235 sub 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);
 263 Color mismatch:
 264   Red: $cr vs $red
 265 Green: $cg vs $green
 266  Blue: $cb vs $blue
 267 END_DIAG
 268     return;
 269   }
 270
 271   return 1;
 272 }
 273
 274 sub 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);
 293 Color mismatch:
 294   Grey: $grey vs $cgrey
 295 END_DIAG
 296     return;
 297   }
 298
 299   return 1;
 300 }
 301
 302 sub 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
 317 sub 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);
 322   $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
 323   $img->box(filled => 1, color => $blue,  box => [ 20, 26, 80, 126 ]);
 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
 330 sub 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);
 335   $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
 336   $img->box(filled => 1, color => $blue,  box => [ 20, 26, 80, 126 ]);
 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
 343 sub 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');
 348   $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
 349   $img->box(filled => 1, color => $blue,  box => [ 20, 26, 80, 126 ]);
 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
 356 sub 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
 369 sub 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
 382 sub 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
 396 my %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
 406 sub 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
 415 sub _low_image_diff_check {
 416   my ($left, $right, $comment) = @_;
 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   }
 458
 459   return 1;
 460 }
 461
 462 sub 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
 474   my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
 475   if ($diff > $limit) {
 476     $builder->ok(0, $comment);
 477     $builder->diag("image data difference > $limit - $diff");
 478
 479     if ($limit == 0) {
 480       # find the first mismatch
 481       PIXELS:
 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");
 488             last PIXELS;
 489           }
 490         }
 491       }
 492     }
 493
 494     return;
 495   }
 496
 497   return $builder->ok(1, $comment);
 498 }
 499
 500 sub 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
 508 sub is_imaged($$$;$) {
 509   my $epsilon = Imager::i_img_epsilonf();
 510   if (@_ > 3) {
 511     ($epsilon) = splice @_, 2, 1;
 512   }
 513
 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
 525   my $same = Imager::i_img_samef($left->{IMG}, $right->{IMG}, $epsilon, $comment);
 526   if (!$same) {
 527     $builder->ok(0, $comment);
 528     $builder->diag("images different");
 529
 530     # find the first mismatch
 531   PIXELS:
 532     for my $y (0 .. $left->getheight()-1) {
 533       for my $x (0.. $left->getwidth()-1) {
 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");
 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
 549 sub 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
 559 sub 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 }
 584
 585 sub 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   }
 597   unless ($builder->ok(colorf_cmp($c, $expected, $epsilon) == 0,
 598              "$comment - got right color ($x, $y)")) {
 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])
 604 EOS
 605   }
 606   1;
 607 }
 608
 609 sub 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   }
 620   unless ($builder->ok(color_cmp($c, $expected) == 0,
 621      "got right color ($x, $y)")) {
 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])
 627 EOS
 628     return;
 629   }
 630
 631   return 1;
 632 }
 633
 634 sub 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
 643   return $builder->ok(!grep(colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got),
 644      "$comment - check colors ($x, $y)");
 645 }
 646
 647 sub colorf_cmp {
 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
 661 sub color_cmp {
 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.
 674 sub 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
 737 sub std_font_test_count {
 738   return 21;
 739 }
 740
 741 sub 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", 11)
 757       unless $] >= 5.006;
 758     skip("overloading handling of magic is broken in this version of perl", 11)
 759       unless $] >= 5.008;
 760     Imager->log("utf8 magic tests\n");
 761     my $over = bless {}, "Imager::Test::OverUtf8";
 762     my $text = "A".chr(0x2010)."A";
 763     my $white = Imager::Color->new("#FFF");
 764     my $base_draw = Imager->new(xsize => 80, ysize => 20);
 765     ok($base_draw->string(font => $font,
 766                           text => $text,
 767                           x => 2,
 768                           y => 18,
 769                           size => 15,
 770                           color => $white,
 771                           aa => 1),
 772        "magic: make a base image");
 773     my $test_draw = Imager->new(xsize => 80, ysize => 20);
 774     ok($test_draw->string(font => $font,
 775                           text => $over,
 776                           x => 2,
 777                           y => 18,
 778                           size => 15,
 779                           color => $white,
 780                           aa => 1),
 781        "magic: draw with overload");
 782     is_image($base_draw, $test_draw, "check they match");
 783     if ($opts->{files}) {
 784       $test_draw->write(file => "testout/utf8tdr.ppm");
 785       $base_draw->write(file => "testout/utf8bdr.ppm");
 786     }
 787
 788     my $base_cp = Imager->new(xsize => 80, ysize => 20);
 789     $base_cp->box(filled => 1, color => "#808080");
 790     my $test_cp = $base_cp->copy;
 791     ok($base_cp->string(font => $font,
 792                         text => $text,
 793                         y => 2,
 794                         y => 18,
 795                         size => 16,
 796                         channel => 2,
 797                         aa => 1),
 798        "magic: make a base image (channel)");
 799     Imager->log("magic: draw to channel with overload\n");
 800     ok($test_cp->string(font => $font,
 801                         text => $over,
 802                         y => 2,
 803                         y => 18,
 804                         size => 16,
 805                         channel => 2,
 806                         aa => 1),
 807        "magic: draw with overload (channel)");
 808     is_image($test_cp, $base_cp, "check they match");
 809     if ($opts->{files}) {
 810       $test_cp->write(file => "testout/utf8tcp.ppm");
 811       $base_cp->write(file => "testout/utf8bcp.ppm");
 812     }
 813
 814   SKIP:
 815     {
 816       Imager->log("magic: has_chars\n");
 817       $font->can("has_chars")
 818         or skip "No has_chars aupport", 2;
 819       is_deeply([ $font->has_chars(string => $text) ], $has_chars,
 820                 "magic: has_chars with normal utf8 text");
 821       is_deeply([ $font->has_chars(string => $over) ], $has_chars,
 822                 "magic: has_chars with magic utf8 text");
 823     }
 824
 825     Imager->log("magic: bounding_box\n");
 826     my @base_bb = $font->bounding_box(string => $text, size => 30);
 827     is_deeply([ $font->bounding_box(string => $over, size => 30) ],
 828               \@base_bb,
 829               "check bounding box magic");
 830
 831   SKIP:
 832     {
 833       $font->can_glyph_names
 834         or skip "No glyph_names", 2;
 835       Imager->log("magic: glyph_names\n");
 836       my @text_names = $name_font->glyph_names(string => $text, reliable_only => 0);
 837       is_deeply(\@text_names, $glyph_names,
 838                 "magic: glyph_names with normal utf8 text");
 839       my @over_names = $name_font->glyph_names(string => $over, reliable_only => 0);
 840       is_deeply(\@over_names, $glyph_names,
 841                 "magic: glyph_names with magic utf8 text");
 842     }
 843   }
 844
 845   { # invalid UTF8 handling at the OO level
 846     my $im = Imager->new(xsize => 80, ysize => 20);
 847     my $bad_utf8 = pack("C", 0xC0);
 848     Imager->_set_error("");
 849     ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1,
 850                     y => 18, x => 2),
 851        "drawing invalid utf8 should fail");
 852     is($im->errstr, "invalid UTF8 character", "check error message");
 853     Imager->_set_error("");
 854     ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1,
 855                     y => 18, x => 2, channel => 1),
 856        "drawing invalid utf8 should fail (channel)");
 857     is($im->errstr, "invalid UTF8 character", "check error message");
 858     Imager->_set_error("");
 859     ok(!$font->bounding_box(string => $bad_utf8, size => 30, utf8 => 1),
 860        "bounding_box() bad utf8 should fail");
 861     is(Imager->errstr, "invalid UTF8 character", "check error message");
 862   SKIP:
 863     {
 864       $font->can_glyph_names
 865         or skip "No glyph_names support", 2;
 866       Imager->_set_error("");
 867       is_deeply([ $font->glyph_names(string => $bad_utf8, utf8 => 1) ],
 868                 [ ],
 869                 "glyph_names returns empty list for bad string");
 870       is(Imager->errstr, "invalid UTF8 character", "check error message");
 871     }
 872   SKIP:
 873     {
 874       $font->can("has_chars")
 875         or skip "No has_chars support", 2;
 876       Imager->_set_error("");
 877       is_deeply([ $font->has_chars(string => $bad_utf8, utf8 => 1) ],
 878                 [ ],
 879                 "has_chars returns empty list for bad string");
 880       is(Imager->errstr, "invalid UTF8 character", "check error message");
 881     }
 882   }
 883 }
 884
 885 package Imager::Test::OverUtf8;
 886 use overload '""' => sub { "A".chr(0x2010)."A" };
 887
 888
 889 1;
 890
 891 __END__
 892
 893 =head1 NAME
 894
 895 Imager::Test - common functions used in testing Imager
 896
 897 =head1 SYNOPSIS
 898
 899   use Imager::Test 'diff_text_with_nul';
 900   diff_text_with_nul($test_name, $text1, $text2, @string_options);
 901
 902 =head1 DESCRIPTION
 903
 904 This is a repository of functions used in testing Imager.
 905
 906 Some functions will only be useful in testing Imager itself, while
 907 others should be useful in testing modules that use Imager.
 908
 909 No functions are exported by default.
 910
 911 =head1 FUNCTIONS
 912
 913 =head2 Test functions
 914
 915 =for stopwords OO
 916
 917 =over
 918
 919 =item is_color1($color, $grey, $comment)
 920
 921 Tests if the first channel of $color matches $grey.
 922
 923 =item is_color3($color, $red, $green, $blue, $comment)
 924
 925 Tests if $color matches the given ($red, $green, $blue)
 926
 927 =item is_color4($color, $red, $green, $blue, $alpha, $comment)
 928
 929 Tests if $color matches the given ($red, $green, $blue, $alpha)
 930
 931 =item is_fcolor1($fcolor, $grey, $comment)
 932
 933 =item is_fcolor1($fcolor, $grey, $epsilon, $comment)
 934
 935 Tests if $fcolor's first channel is within $epsilon of ($grey).  For
 936 the first form $epsilon is taken as 0.001.
 937
 938 =item is_fcolor3($fcolor, $red, $green, $blue, $comment)
 939
 940 =item is_fcolor3($fcolor, $red, $green, $blue, $epsilon, $comment)
 941
 942 Tests if $fcolor's channels are within $epsilon of ($red, $green,
 943 $blue).  For the first form $epsilon is taken as 0.001.
 944
 945 =item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $comment)
 946
 947 =item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $epsilon, $comment)
 948
 949 Tests if $fcolor's channels are within $epsilon of ($red, $green,
 950 $blue, $alpha).  For the first form $epsilon is taken as 0.001.
 951
 952 =item is_image($im1, $im2, $comment)
 953
 954 Tests if the 2 images have the same content.  Both images must be
 955 defined, have the same width, height, channels and the same color in
 956 each pixel.  The color comparison is done at 8-bits per pixel.  The
 957 color representation such as direct vs paletted, bits per sample are
 958 not checked.  Equivalent to is_image_similar($im1, $im2, 0, $comment).
 959
 960 =item is_imaged($im, $im2, $comment)
 961
 962 =item is_imaged($im, $im2, $epsilon, $comment)
 963
 964 Tests if the two images have the same content at the double/sample
 965 level.  C<$epsilon> defaults to the platform DBL_EPSILON multiplied by
 966 four.
 967
 968 =item is_image_similar($im1, $im2, $maxdiff, $comment)
 969
 970 Tests if the 2 images have similar content.  Both images must be
 971 defined, have the same width, height and channels.  The cum of the
 972 squares of the differences of each sample are calculated and must be
 973 less than or equal to I<$maxdiff> for the test to pass.  The color
 974 comparison is done at 8-bits per pixel.  The color representation such
 975 as direct vs paletted, bits per sample are not checked.
 976
 977 =item isnt_image($im1, $im2, $comment)
 978
 979 Tests that the two images are different.  For regressions tests where
 980 something (like text output of "0") produced no change, but should
 981 have produced a change.
 982
 983 =item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
 984
 985 Retrieves the pixel ($x,$y) from the low-level image $im and compares
 986 it to the floating point color $expected, with a tolerance of epsilon.
 987
 988 =item test_color_gpix($im, $x, $y, $expected, $comment)
 989
 990 Retrieves the pixel ($x,$y) from the low-level image $im and compares
 991 it to the floating point color $expected.
 992
 993 =item test_colorf_glin($im, $x, $y, $pels, $comment)
 994
 995 Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
 996 low level image $im and compares them against @$pels.
 997
 998 =item is_color_close3($color, $red, $green, $blue, $tolerance, $comment)
 999
1000 Tests if $color's first three channels are within $tolerance of ($red,
1001 $green, $blue).
1002
1003 =back
1004
1005 =head2 Test suite functions
1006
1007 Functions that perform one or more tests, typically used to test
1008 various parts of Imager's implementation.
1009
1010 =over
1011
1012 =item image_bounds_checks($im)
1013
1014 Attempts to write to various pixel positions outside the edge of the
1015 image to ensure that it fails in those locations.
1016
1017 Any new image type should pass these tests.  Does 16 separate tests.
1018
1019 =item mask_tests($im, $epsilon)
1020
1021 Perform a standard set of mask tests on the OO image $im.  Does 24
1022 separate tests.
1023
1024 =item diff_text_with_nul($test_name, $text1, $text2, @options)
1025
1026 Creates 2 test images and writes $text1 to the first image and $text2
1027 to the second image with the string() method.  Each call adds 3
1028 C<ok>/C<not ok> to the output of the test script.
1029
1030 Extra options that should be supplied include the font and either a
1031 color or channel parameter.
1032
1033 This was explicitly created for regression tests on #21770.
1034
1035 =item std_font_tests({ font => $font })
1036
1037 Perform standard font interface tests.
1038
1039 =item std_font_test_count()
1040
1041 The number of tests performed by std_font_tests().
1042
1043 =back
1044
1045 =head2 Helper functions
1046
1047 =over
1048
1049 =item test_image_raw()
1050
1051 Returns a 150x150x3 Imager::ImgRaw test image.
1052
1053 =item test_image()
1054
1055 Returns a 150x150x3 8-bit/sample OO test image. Name: C<basic>.
1056
1057 =item test_image_16()
1058
1059 Returns a 150x150x3 16-bit/sample OO test image. Name: C<basic16>
1060
1061 =item test_image_double()
1062
1063 Returns a 150x150x3 double/sample OO test image. Name: C<basic_double>.
1064
1065 =item test_image_gray()
1066
1067 Returns a 150x150 single channel OO test image. Name: C<gray>.
1068
1069 =item test_image_gray_16()
1070
1071 Returns a 150x150 16-bit/sample single channel OO test image. Name:
1072 C<gray16>.
1073
1074 =item test_image_mono()
1075
1076 Returns a 150x150 bilevel image that passes the is_bilevel() test.
1077 Name: C<mono>.
1078
1079 =item test_image_named($name)
1080
1081 Return one of the other test images above based on name.
1082
1083 =item color_cmp($c1, $c2)
1084
1085 Performs an ordering of 3-channel colors (like <=>).
1086
1087 =item colorf_cmp($c1, $c2)
1088
1089 Performs an ordering of 3-channel floating point colors (like <=>).
1090
1091 =back
1092
1093 =head1 AUTHOR
1094
1095 Tony Cook <tony@develop-help.com>
1096
1097 =cut