t/250-draw/100-fill.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 165;
   4
   5 use Imager ':handy';
   6 use Imager::Fill;
   7 use Imager::Color::Float;
   8 use Imager::Test qw(is_image is_color4 is_fcolor4 is_color3);
   9 use Config;
  10
  11 -d "testout" or mkdir "testout";
  12
  13 Imager::init_log("testout/t20fill.log", 1);
  14
  15 my $blue = NC(0,0,255);
  16 my $red = NC(255, 0, 0);
  17 my $redf = Imager::Color::Float->new(1, 0, 0);
  18 my $bluef = Imager::Color::Float->new(0, 0, 1);
  19 my $rsolid = Imager::i_new_fill_solid($blue, 0);
  20 ok($rsolid, "building solid fill");
  21 my $raw1 = Imager::ImgRaw::new(100, 100, 3);
  22 # use the normal filled box
  23 Imager::i_box_filled($raw1, 0, 0, 99, 99, $blue);
  24 my $raw2 = Imager::ImgRaw::new(100, 100, 3);
  25 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rsolid);
  26 ok(1, "drawing with solid fill");
  27 my $diff = Imager::i_img_diff($raw1, $raw2);
  28 ok($diff == 0, "solid fill doesn't match");
  29 Imager::i_box_filled($raw1, 0, 0, 99, 99, $red);
  30 my $rsolid2 = Imager::i_new_fill_solidf($redf, 0);
  31 ok($rsolid2, "creating float solid fill");
  32 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rsolid2);
  33 $diff = Imager::i_img_diff($raw1, $raw2);
  34 ok($diff == 0, "float solid fill doesn't match");
  35
  36 # ok solid still works, let's try a hatch
  37 # hash1 is a 2x2 checkerboard
  38 my $rhatcha = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 0, 0);
  39 my $rhatchb = Imager::i_new_fill_hatch($blue, $red, 0, 1, undef, 2, 0);
  40 ok($rhatcha && $rhatchb, "can't build hatched fill");
  41
  42 # the offset should make these match
  43 Imager::i_box_cfill($raw1, 0, 0, 99, 99, $rhatcha);
  44 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
  45 ok(1, "filling with hatch");
  46 $diff = Imager::i_img_diff($raw1, $raw2);
  47 ok($diff == 0, "hatch images different");
  48 $rhatchb = Imager::i_new_fill_hatch($blue, $red, 0, 1, undef, 4, 6);
  49 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
  50 $diff = Imager::i_img_diff($raw1, $raw2);
  51 ok($diff == 0, "hatch images different");
  52
  53 # I guess I was tired when I originally did this - make sure it keeps
  54 # acting the way it's meant to
  55 # I had originally expected these to match with the red and blue swapped
  56 $rhatchb = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 2, 2);
  57 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
  58 $diff = Imager::i_img_diff($raw1, $raw2);
  59 ok($diff == 0, "hatch images different");
  60
  61 # this shouldn't match
  62 $rhatchb = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 1, 1);
  63 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
  64 $diff = Imager::i_img_diff($raw1, $raw2);
  65 ok($diff, "hatch images the same!");
  66
  67 # custom hatch
  68 # the inverse of the 2x2 checkerboard
  69 my $hatch = pack("C8", 0x33, 0x33, 0xCC, 0xCC, 0x33, 0x33, 0xCC, 0xCC);
  70 my $rcustom = Imager::i_new_fill_hatch($blue, $red, 0, 0, $hatch, 0, 0);
  71 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rcustom);
  72 $diff = Imager::i_img_diff($raw1, $raw2);
  73 ok(!$diff, "custom hatch mismatch");
  74
  75 {
  76   # basic test of floating color hatch fills
  77   # this will exercise the code that the gcc shipped with OS X 10.4
  78   # forgets to generate
  79   # the float version is called iff we're working with a non-8-bit image
  80   # i_new_fill_hatchf() makes the same object as i_new_fill_hatch() but
  81   # we test the other construction code path here
  82   my $fraw1 = Imager::i_img_double_new(100, 100, 3);
  83   my $fhatch1 = Imager::i_new_fill_hatchf($redf, $bluef, 0, 1, undef, 0, 0);
  84   ok($fraw1, "making double image 1");
  85   ok($fhatch1, "making float hatch 1");
  86   Imager::i_box_cfill($fraw1, 0, 0, 99, 99, $fhatch1);
  87   my $fraw2 = Imager::i_img_double_new(100, 100, 3);
  88   my $fhatch2 = Imager::i_new_fill_hatchf($bluef, $redf, 0, 1, undef, 0, 2);
  89   ok($fraw2, "making double image 2");
  90   ok($fhatch2, "making float hatch 2");
  91   Imager::i_box_cfill($fraw2, 0, 0, 99, 99, $fhatch2);
  92
  93   $diff = Imager::i_img_diff($fraw1, $fraw2);
  94   ok(!$diff, "float custom hatch mismatch");
  95   save($fraw1, "testout/t20hatchf1.ppm");
  96   save($fraw2, "testout/t20hatchf2.ppm");
  97 }
  98
  99 # test the oo interface
 100 my $im1 = Imager->new(xsize=>100, ysize=>100);
 101 my $im2 = Imager->new(xsize=>100, ysize=>100);
 102
 103 my $solid = Imager::Fill->new(solid=>'#FF0000');
 104 ok($solid, "creating oo solid fill");
 105 ok($solid->{fill}, "bad oo solid fill");
 106 $im1->box(fill=>$solid);
 107 $im2->box(filled=>1, color=>$red);
 108 $diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
 109 ok(!$diff, "oo solid fill");
 110
 111 my $hatcha = Imager::Fill->new(hatch=>'check2x2');
 112 my $hatchb = Imager::Fill->new(hatch=>'check2x2', dx=>2);
 113 $im1->box(fill=>$hatcha);
 114 $im2->box(fill=>$hatchb);
 115 # should be different
 116 $diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
 117 ok($diff, "offset checks the same!");
 118 $hatchb = Imager::Fill->new(hatch=>'check2x2', dx=>2, dy=>2);
 119 $im2->box(fill=>$hatchb);
 120 $diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
 121 ok(!$diff, "offset into similar check should be the same");
 122
 123 # test dymanic build of fill
 124 $im2->box(fill=>{hatch=>'check2x2', dx=>2, fg=>NC(255,255,255),
 125                  bg=>NC(0,0,0)});
 126 $diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
 127 ok(!$diff, "offset and flipped should be the same");
 128
 129 # a simple demo
 130 my $im = Imager->new(xsize=>200, ysize=>200);
 131
 132 $im->box(xmin=>10, ymin=>10, xmax=>190, ymax=>190,
 133          fill=>{ hatch=>'check4x4',
 134                  fg=>NC(128, 0, 0),
 135                  bg=>NC(128, 64, 0) })
 136   or print "# ",$im->errstr,"\n";
 137 $im->arc(r=>80, d1=>45, d2=>75,
 138            fill=>{ hatch=>'stipple2',
 139                    combine=>1,
 140                    fg=>[ 0, 0, 0, 255 ],
 141                    bg=>{ rgba=>[255,255,255,160] } })
 142   or print "# ",$im->errstr,"\n";
 143 $im->arc(r=>80, d1=>75, d2=>135,
 144          fill=>{ fountain=>'radial', xa=>100, ya=>100, xb=>20, yb=>100 })
 145   or print "# ",$im->errstr,"\n";
 146 $im->write(file=>'testout/t20_sample.ppm');
 147
 148 # flood fill tests
 149 my $rffimg = Imager::ImgRaw::new(100, 100, 3);
 150 # build a H
 151 Imager::i_box_filled($rffimg, 10, 10, 20, 90, $blue);
 152 Imager::i_box_filled($rffimg, 80, 10, 90, 90, $blue);
 153 Imager::i_box_filled($rffimg, 20, 45, 80, 55, $blue);
 154 my $black = Imager::Color->new(0, 0, 0);
 155 Imager::i_flood_fill($rffimg, 15, 15, $red);
 156 my $rffcmp = Imager::ImgRaw::new(100, 100, 3);
 157 # build a H
 158 Imager::i_box_filled($rffcmp, 10, 10, 20, 90, $red);
 159 Imager::i_box_filled($rffcmp, 80, 10, 90, 90, $red);
 160 Imager::i_box_filled($rffcmp, 20, 45, 80, 55, $red);
 161 $diff = Imager::i_img_diff($rffimg, $rffcmp);
 162 ok(!$diff, "flood fill difference");
 163
 164 my $ffim = Imager->new(xsize=>100, ysize=>100);
 165 my $yellow = Imager::Color->new(255, 255, 0);
 166 $ffim->box(xmin=>10, ymin=>10, xmax=>20, ymax=>90, color=>$blue, filled=>1);
 167 $ffim->box(xmin=>20, ymin=>45, xmax=>80, ymax=>55, color=>$blue, filled=>1);
 168 $ffim->box(xmin=>80, ymin=>10, xmax=>90, ymax=>90, color=>$blue, filled=>1);
 169 ok($ffim->flood_fill('x'=>50, 'y'=>50, color=>$red), "flood fill");
 170 $diff = Imager::i_img_diff($rffcmp, $ffim->{IMG});
 171 ok(!$diff, "oo flood fill difference");
 172 $ffim->flood_fill('x'=>50, 'y'=>50,
 173                   fill=> {
 174                           hatch => 'check2x2',
 175                           fg => '0000FF',
 176                          });
 177 #                  fill=>{
 178 #                         fountain=>'radial',
 179 #                         xa=>50, ya=>50,
 180 #                         xb=>10, yb=>10,
 181 #                        });
 182 $ffim->write(file=>'testout/t20_ooflood.ppm');
 183
 184 my $copy = $ffim->copy;
 185 ok($ffim->flood_fill('x' => 50, 'y' => 50,
 186                      color => $red, border => '000000'),
 187    "border solid flood fill");
 188 is(Imager::i_img_diff($ffim->{IMG}, $rffcmp), 0, "compare");
 189 ok($ffim->flood_fill('x' => 50, 'y' => 50,
 190                      fill => { hatch => 'check2x2', fg => '0000FF', },
 191                      border => '000000'),
 192    "border cfill fill");
 193 is(Imager::i_img_diff($ffim->{IMG}, $copy->{IMG}), 0,
 194    "compare");
 195
 196 # test combining modes
 197 my $fill = NC(192, 128, 128, 128);
 198 my $target = NC(64, 32, 64);
 199 my $trans_target = NC(64, 32, 64, 128);
 200 my %comb_tests =
 201   (
 202    none=>
 203    {
 204     opaque => $fill,
 205     trans => $fill,
 206    },
 207    normal=>
 208    {
 209     opaque => NC(128, 80, 96),
 210     trans => NC(150, 96, 107, 191),
 211    },
 212    multiply =>
 213    {
 214     opaque => NC(56, 24, 48),
 215     trans => NC(101, 58, 74, 192),
 216    },
 217    dissolve =>
 218    {
 219     opaque => [ $target, NC(192, 128, 128, 255) ],
 220     trans => [ $trans_target, NC(192, 128, 128, 255) ],
 221    },
 222    add =>
 223    {
 224     opaque => NC(159, 96, 128),
 225     trans => NC(128, 80, 96, 255),
 226    },
 227    subtract =>
 228    {
 229     opaque => NC(0, 0, 0),
 230     trans => NC(0, 0, 0, 255),
 231    },
 232    diff =>
 233    {
 234     opaque => NC(96, 64, 64),
 235     trans => NC(127, 85, 85, 192),
 236    },
 237    lighten =>
 238    {
 239     opaque => NC(128, 80, 96),
 240     trans => NC(149, 95, 106, 192),
 241    },
 242    darken =>
 243    {
 244     opaque => $target,
 245     trans => NC(106, 63, 85, 192),
 246    },
 247    # the following results are based on the results of the tests and
 248    # are suspect for that reason (and were broken at one point <sigh>)
 249    # but trying to work them out manually just makes my head hurt - TC
 250    hue =>
 251    {
 252     opaque => NC(64, 32, 47),
 253     trans => NC(64, 32, 42, 128),
 254    },
 255    saturation =>
 256    {
 257     opaque => NC(63, 37, 64),
 258     trans => NC(64, 39, 64, 128),
 259    },
 260    value =>
 261    {
 262     opaque => NC(127, 64, 128),
 263     trans => NC(149, 75, 150, 128),
 264    },
 265    color =>
 266    {
 267     opaque => NC(64, 37, 52),
 268     trans => NC(64, 39, 50, 128),
 269    },
 270   );
 271
 272 for my $comb (Imager::Fill->combines) {
 273   my $test = $comb_tests{$comb};
 274   my $fillobj = Imager::Fill->new(solid=>$fill, combine=>$comb);
 275
 276   for my $bits (qw(8 double)) {
 277     {
 278       my $targim = Imager->new(xsize=>4, ysize=>4, bits => $bits);
 279       $targim->box(filled=>1, color=>$target);
 280       $targim->box(fill=>$fillobj);
 281       my $c = Imager::i_get_pixel($targim->{IMG}, 1, 1);
 282       my $allowed = $test->{opaque};
 283       $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
 284       ok(scalar grep(color_close($_, $c), @$allowed),
 285          "opaque '$comb' $bits bits")
 286         or print "# got:",join(",", $c->rgba),"  allowed: ",
 287           join("|", map { join(",", $_->rgba) } @$allowed),"\n";
 288     }
 289
 290     {
 291       # make sure the alpha path in the combine function produces the same
 292       # or at least as sane a result as the non-alpha path
 293       my $targim = Imager->new(xsize=>4, ysize=>4, channels => 4, bits => $bits);
 294       $targim->box(filled=>1, color=>$target);
 295       $targim->box(fill=>$fillobj);
 296       my $c = Imager::i_get_pixel($targim->{IMG}, 1, 1);
 297       my $allowed = $test->{opaque};
 298       $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
 299       ok(scalar grep(color_close4($_, $c), @$allowed),
 300          "opaque '$comb' 4-channel $bits bits")
 301         or print "# got:",join(",", $c->rgba),"  allowed: ",
 302           join("|", map { join(",", $_->rgba) } @$allowed),"\n";
 303     }
 304
 305     {
 306       my $transim = Imager->new(xsize => 4, ysize => 4, channels => 4, bits => $bits);
 307       $transim->box(filled=>1, color=>$trans_target);
 308       $transim->box(fill => $fillobj);
 309       my $c = $transim->getpixel(x => 1, 'y' => 1);
 310       my $allowed = $test->{trans};
 311       $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
 312       ok(scalar grep(color_close4($_, $c), @$allowed),
 313          "translucent '$comb' $bits bits")
 314         or print "# got:",join(",", $c->rgba),"  allowed: ",
 315           join("|", map { join(",", $_->rgba) } @$allowed),"\n";
 316     }
 317   }
 318 }
 319
 320 ok($ffim->arc(r=>45, color=>$blue, aa=>1), "aa circle");
 321 $ffim->write(file=>"testout/t20_aacircle.ppm");
 322
 323 # image based fills
 324 my $green = NC(0, 255, 0);
 325 my $fillim = Imager->new(xsize=>40, ysize=>40, channels=>4);
 326 $fillim->box(filled=>1, xmin=>5, ymin=>5, xmax=>35, ymax=>35,
 327              color=>NC(0, 0, 255, 128));
 328 $fillim->arc(filled=>1, r=>10, color=>$green, aa=>1);
 329 my $ooim = Imager->new(xsize=>150, ysize=>150);
 330 $ooim->box(filled=>1, color=>$green, xmin=>70, ymin=>25, xmax=>130, ymax=>125);
 331 $ooim->box(filled=>1, color=>$blue, xmin=>20, ymin=>25, xmax=>80, ymax=>125);
 332 $ooim->arc(r=>30, color=>$red, aa=>1);
 333
 334 my $oocopy = $ooim->copy();
 335 ok($oocopy->arc(fill=>{image=>$fillim,
 336                        combine=>'normal',
 337                        xoff=>5}, r=>40),
 338    "image based fill");
 339 $oocopy->write(file=>'testout/t20_image.ppm');
 340
 341 # a more complex version
 342 use Imager::Matrix2d ':handy';
 343 $oocopy = $ooim->copy;
 344 ok($oocopy->arc(fill=>{
 345                        image=>$fillim,
 346                        combine=>'normal',
 347                        matrix=>m2d_rotate(degrees=>30),
 348                        xoff=>5
 349                        }, r=>40),
 350    "transformed image based fill");
 351 $oocopy->write(file=>'testout/t20_image_xform.ppm');
 352
 353 ok(!$oocopy->arc(fill=>{ hatch=>"not really a hatch" }, r=>20),
 354    "error handling of automatic fill conversion");
 355 ok($oocopy->errstr =~ /Unknown hatch type/,
 356    "error message for automatic fill conversion");
 357
 358 # previous box fills to float images, or using the fountain fill
 359 # got into a loop here
 360
 361 SKIP:
 362 {
 363   skip("can't test without alarm()", 1) unless $Config{d_alarm};
 364   skip("Your signals are misconfigured", 1) unless exists $SIG{ALRM};
 365   local $SIG{ALRM} = sub { die; };
 366
 367   eval {
 368     alarm(2);
 369     ok($ooim->box(xmin=>20, ymin=>20, xmax=>80, ymax=>40,
 370                   fill=>{ fountain=>'linear', xa=>20, ya=>20, xb=>80,
 371                           yb=>20 }), "linear box fill");
 372     alarm 0;
 373   };
 374   $@ and ok(0, "linear box fill $@");
 375 }
 376
 377 # test that passing in a non-array ref returns an error
 378 {
 379   my $fill = Imager::Fill->new(fountain=>'linear',
 380                                xa => 20, ya=>20, xb=>20, yb=>40,
 381                                segments=>"invalid");
 382   ok(!$fill, "passing invalid segments produces an error");
 383   cmp_ok(Imager->errstr, '=~', 'array reference',
 384          "check the error message");
 385 }
 386
 387 # test that colors in segments are converted
 388 {
 389   my @segs =
 390     (
 391      [ 0.0, 0.5, 1.0, '000000', '#FFF', 0, 0 ],
 392     );
 393   my $fill = Imager::Fill->new(fountain=>'linear',
 394                                xa => 0, ya=>20, xb=>49, yb=>20,
 395                                segments=>\@segs);
 396   ok($fill, "check that color names are converted")
 397     or print "# ",Imager->errstr,"\n";
 398   my $im = Imager->new(xsize=>50, ysize=>50);
 399   $im->box(fill=>$fill);
 400   my $left = $im->getpixel('x'=>0, 'y'=>20);
 401   ok(color_close($left, Imager::Color->new(0,0,0)),
 402      "check black converted correctly");
 403   my $right = $im->getpixel('x'=>49, 'y'=>20);
 404   ok(color_close($right, Imager::Color->new(255,255,255)),
 405      "check white converted correctly");
 406
 407   # check that invalid colors handled correctly
 408
 409   my @segs2 =
 410     (
 411      [ 0.0, 0.5, 1.0, '000000', 'FxFxFx', 0, 0 ],
 412     );
 413   my $fill2 = Imager::Fill->new(fountain=>'linear',
 414                                xa => 0, ya=>20, xb=>49, yb=>20,
 415                                segments=>\@segs2);
 416   ok(!$fill2, "check handling of invalid color names");
 417   cmp_ok(Imager->errstr, '=~', 'No color named', "check error message");
 418 }
 419
 420 { # RT #35278
 421   # hatch fills on a grey scale image don't adapt colors
 422   for my $bits (8, 'double') {
 423     my $im_g = Imager->new(xsize => 10, ysize => 10, channels => 1, bits => $bits);
 424     $im_g->box(filled => 1, color => 'FFFFFF');
 425     my $fill = Imager::Fill->new
 426       (
 427        combine => 'normal',
 428        hatch => 'weave',
 429        fg => '000000',
 430        bg => 'FFFFFF'
 431       );
 432     $im_g->box(fill => $fill);
 433     my $im_c = Imager->new(xsize => 10, ysize => 10, channels => 3, bits => $bits);
 434     $im_c->box(filled => 1, color => 'FFFFFF');
 435     $im_c->box(fill => $fill);
 436     my $im_cg = $im_g->convert(preset => 'rgb');
 437     is_image($im_c, $im_cg, "check hatch is the same between color and greyscale (bits $bits)");
 438
 439     # check the same for image fills
 440     my $grey_fill = Imager::Fill->new
 441       (
 442        image => $im_g,
 443        combine => 'normal'
 444       );
 445     my $im_cfg = Imager->new(xsize => 20, ysize => 20, bits => $bits);
 446     $im_cfg->box(filled => 1, color => '808080');
 447     $im_cfg->box(fill => $grey_fill);
 448     my $rgb_fill = Imager::Fill->new
 449       (
 450        image => $im_cg,
 451        combine => 'normal'
 452       );
 453     my $im_cfc = Imager->new(xsize => 20, ysize => 20, bits => $bits);
 454     $im_cfc->box(filled => 1, color => '808080');
 455     $im_cfc->box(fill => $rgb_fill);
 456     is_image($im_cfg, $im_cfc, "check filling from grey image matches filling from rgb (bits = $bits)");
 457
 458     my $im_gfg = Imager->new(xsize => 20, ysize => 20, channels => 1, bits => $bits);
 459     $im_gfg->box(filled => 1, color => '808080');
 460     $im_gfg->box(fill => $grey_fill);
 461     my $im_gfg_c = $im_gfg->convert(preset => 'rgb');
 462     is_image($im_gfg_c, $im_cfg, "check grey filled with grey against base (bits = $bits)");
 463
 464     my $im_gfc = Imager->new(xsize => 20, ysize => 20, channels => 1, bits => $bits);
 465     $im_gfc->box(filled => 1, color => '808080');
 466     $im_gfc->box(fill => $rgb_fill);
 467     my $im_gfc_c = $im_gfc->convert(preset => 'rgb');
 468     is_image($im_gfc_c, $im_cfg, "check grey filled with color against base (bits = $bits)");
 469   }
 470 }
 471
 472 { # alpha modifying fills
 473   { # 8-bit/sample
 474     my $base_img = Imager->new(xsize => 4, ysize => 2, channels => 4);
 475     $base_img->setscanline
 476       (
 477        x => 0,
 478        y => 0,
 479        pixels =>
 480        [
 481         map Imager::Color->new($_),
 482         qw/FF000020 00FF0080 00008040 FFFF00FF/,
 483        ],
 484       );
 485     $base_img->setscanline
 486       (
 487        x => 0,
 488        y => 1,
 489        pixels =>
 490        [
 491         map Imager::Color->new($_),
 492         qw/FFFF00FF FF000000 00FF0080 00008040/
 493        ]
 494       );
 495     my $base_fill = Imager::Fill->new
 496       (
 497        image => $base_img,
 498        combine => "normal",
 499       );
 500     ok($base_fill, "make the base image fill");
 501     my $fill50 = Imager::Fill->new(type => "opacity", opacity => 0.5, other => $base_fill)
 502       or print "# ", Imager->errstr, "\n";
 503     ok($fill50, "make 50% alpha translation fill");
 504
 505     { # 4 channel image
 506       my $out = Imager->new(xsize => 10, ysize => 10, channels => 4);
 507       $out->box(fill => $fill50);
 508       is_color4($out->getpixel(x => 0, y => 0),
 509                 255, 0, 0, 16, "check alpha output");
 510       is_color4($out->getpixel(x => 2, y => 1),
 511                 0, 255, 0, 64, "check alpha output");
 512       $out->box(filled => 1, color => "000000");
 513       is_color4($out->getpixel(x => 0, y => 0),
 514                 0, 0, 0, 255, "check after clear");
 515       $out->box(fill => $fill50);
 516       is_color4($out->getpixel(x => 4, y => 2),
 517                 16, 0, 0, 255, "check drawn against background");
 518       is_color4($out->getpixel(x => 6, y => 3),
 519                 0, 64, 0, 255, "check drawn against background");
 520     }
 521     { # 3 channel image
 522       my $out = Imager->new(xsize => 10, ysize => 10, channels => 3);
 523       $out->box(fill => $fill50);
 524       is_color3($out->getpixel(x => 0, y => 0),
 525                 16, 0, 0, "check alpha output");
 526       is_color3($out->getpixel(x => 2, y => 1),
 527                 0, 64, 0, "check alpha output");
 528       is_color3($out->getpixel(x => 0, y => 1),
 529                 128, 128, 0, "check alpha output");
 530     }
 531   }
 532   { # double/sample
 533     use Imager::Color::Float;
 534     my $base_img = Imager->new(xsize => 4, ysize => 2, channels => 4, bits => "double");
 535     $base_img->setscanline
 536       (
 537        x => 0,
 538        y => 0,
 539        pixels =>
 540        [
 541         map Imager::Color::Float->new(@$_),
 542         [ 1, 0, 0, 0.125 ],
 543         [ 0, 1, 0, 0.5 ],
 544         [ 0, 0, 0.5, 0.25 ],
 545         [ 1, 1, 0, 1 ],
 546        ],
 547       );
 548     $base_img->setscanline
 549       (
 550        x => 0,
 551        y => 1,
 552        pixels =>
 553        [
 554         map Imager::Color::Float->new(@$_),
 555         [ 1, 1, 0, 1 ],
 556         [ 1, 0, 0, 0 ],
 557         [ 0, 1, 0, 0.5 ],
 558         [ 0, 0, 0.5, 0.25 ],
 559        ]
 560       );
 561     my $base_fill = Imager::Fill->new
 562       (
 563        image => $base_img,
 564        combine => "normal",
 565       );
 566     ok($base_fill, "make the base image fill");
 567     my $fill50 = Imager::Fill->new(type => "opacity", opacity => 0.5, other => $base_fill)
 568       or print "# ", Imager->errstr, "\n";
 569     ok($fill50, "make 50% alpha translation fill");
 570     my $out = Imager->new(xsize => 10, ysize => 10, channels => 4, bits => "double");
 571     $out->box(fill => $fill50);
 572     is_fcolor4($out->getpixel(x => 0, y => 0, type => "float"),
 573               1, 0, 0, 0.0625, "check alpha output at 0,0");
 574     is_fcolor4($out->getpixel(x => 2, y => 1, type => "float"),
 575               0, 1, 0, 0.25, "check alpha output at 2,1");
 576     $out->box(filled => 1, color => "000000");
 577     is_fcolor4($out->getpixel(x => 0, y => 0, type => "float"),
 578               0, 0, 0, 1, "check after clear");
 579     $out->box(fill => $fill50);
 580     is_fcolor4($out->getpixel(x => 4, y => 2, type => "float"),
 581               0.0625, 0, 0, 1, "check drawn against background at 4,2");
 582     is_fcolor4($out->getpixel(x => 6, y => 3, type => "float"),
 583               0, 0.25, 0, 1, "check drawn against background at 6,3");
 584   }
 585   ok(!Imager::Fill->new(type => "opacity"),
 586      "should fail to make an opacity fill with no other fill object");
 587   is(Imager->errstr, "'other' parameter required to create opacity fill",
 588      "check error message");
 589   ok(!Imager::Fill->new(type => "opacity", other => "xx"),
 590      "should fail to make an opacity fill with a bad other parameter");
 591   is(Imager->errstr, "'other' parameter must be an Imager::Fill object to create an opacity fill",
 592          "check error message");
 593
 594   # check auto conversion of hashes
 595   ok(Imager::Fill->new(type => "opacity", other => { solid => "FF0000" }),
 596      "check we auto-create fills")
 597     or print "# ", Imager->errstr, "\n";
 598
 599   {
 600     # fill with combine none was modifying the wrong channel for a
 601     # no-alpha target image
 602     my $fill = Imager::Fill->new(solid => "#FFF", combine => "none");
 603     my $fill2 = Imager::Fill->new
 604       (
 605        type => "opacity",
 606        opacity => 0.5,
 607        other => $fill
 608       );
 609     my $im = Imager->new(xsize => 1, ysize => 1);
 610     ok($im->box(fill => $fill2), "fill with replacement opacity fill");
 611     is_color3($im->getpixel(x => 0, y => 0), 255, 255, 255,
 612               "check for correct colour");
 613   }
 614
 615   {
 616     require Imager::Fountain;
 617     my $fount = Imager::Fountain->new;
 618     $fount->add(c1 => "FFFFFF"); # simple white to black
 619     # base fill is a fountain
 620     my $base_fill = Imager::Fill->new
 621       (
 622        fountain => "linear",
 623        segments => $fount,
 624        xa => 0,
 625        ya => 0,
 626        xb => 100,
 627        yb => 100,
 628       );
 629     ok($base_fill, "made fountain fill base");
 630     my $op_fill = Imager::Fill->new
 631       (
 632        type => "opacity",
 633        other => $base_fill,
 634        opacity => 0.5,
 635       );
 636     ok($op_fill, "made opacity fountain fill");
 637     my $im = Imager->new(xsize => 100, ysize => 100);
 638     ok($im->box(fill => $op_fill), "draw with it");
 639   }
 640 }
 641
 642 { # RT 71309
 643   my $fount = Imager::Fountain->simple(colors => [ '#804041', '#804041' ],
 644                                        positions => [ 0, 1 ]);
 645   my $im = Imager->new(xsize => 40, ysize => 40);
 646   $im->box(filled => 1, color => '#804040');
 647   my $fill = Imager::Fill->new
 648     (
 649      combine => 0,
 650      fountain => "linear",
 651      segments => $fount,
 652      xa => 0, ya => 0,
 653      xb => 40, yb => 40,
 654     );
 655   $im->polygon(fill => $fill,
 656                points =>
 657                [
 658                 [ 0, 0 ],
 659                 [ 40, 20 ],
 660                 [ 20, 40 ],
 661                ]
 662               );
 663   # the bug magnified the differences between the source and destination
 664   # color, blending between the background and fill colors here only allows
 665   # for those 2 colors in the result.
 666   # with the bug extra colors appeared along the edge of the polygon.
 667   is($im->getcolorcount, 2, "only original and fill color");
 668 }
 669
 670 SKIP:
 671 {
 672   # the wrong image dimension was used for adjusting vs yoff,
 673   # producing uncovered parts of the output image
 674   my $tx = Imager->new(xsize => 30, ysize => 20);
 675   ok($tx, "create texture image")
 676     or diag "create texture image", Imager->errstr;
 677   $tx or skip "no texture image", 7;
 678   ok($tx->box(filled => 1, color => "ff0000"), "fill texture image")
 679     or diag "fill texture image", $tx->errstr;
 680   my $cmp = Imager->new(xsize => 100, ysize => 100);
 681   ok($cmp, "create comparison image")
 682     or diag "create comparison image: ", Imager->errstr;
 683   $cmp or skip "no comparison image", 5;
 684   ok($cmp->box(filled => 1, color => "FF0000"), "fill compare image")
 685     or diag "fill compare image: ", $cmp->errstr;
 686   my $im = Imager->new(xsize => 100, ysize => 100);
 687   ok($im, "make test image")
 688     or diag "make test image: ", Imager->errstr;
 689   $im or skip "no test image", 3;
 690   my $fill = Imager::Fill->new(image => $tx, yoff => 10);
 691   ok($fill, "make xoff=10 image fill")
 692     or diag "make fill: ", Imager->errstr;
 693   $fill or skip "no fill", 2;
 694   ok($im->box(fill => $fill), "fill test image")
 695     or diag "fill test image: ", $im->errstr;
 696   is_image($im, $cmp, "check test image");
 697 }
 698
 699 sub color_close {
 700   my ($c1, $c2) = @_;
 701
 702   my @c1 = $c1->rgba;
 703   my @c2 = $c2->rgba;
 704
 705   for my $i (0..2) {
 706     if (abs($c1[$i]-$c2[$i]) > 2) {
 707       return 0;
 708     }
 709   }
 710   return 1;
 711 }
 712
 713 sub color_close4 {
 714   my ($c1, $c2) = @_;
 715
 716   my @c1 = $c1->rgba;
 717   my @c2 = $c2->rgba;
 718
 719   for my $i (0..3) {
 720     if (abs($c1[$i]-$c2[$i]) > 2) {
 721       return 0;
 722     }
 723   }
 724   return 1;
 725 }
 726
 727 # for use during testing
 728 sub save {
 729   my ($im, $name) = @_;
 730
 731   open FH, "> $name" or die "Cannot create $name: $!";
 732   binmode FH;
 733   my $io = Imager::io_new_fd(fileno(FH));
 734   Imager::i_writeppm_wiol($im, $io) or die "Cannot save to $name";
 735   undef $io;
 736   close FH;
 737 }