t/t20fill.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 156;
   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   local $SIG{ALRM} = sub { die; };
 365
 366   eval {
 367     alarm(2);
 368     ok($ooim->box(xmin=>20, ymin=>20, xmax=>80, ymax=>40,
 369                   fill=>{ fountain=>'linear', xa=>20, ya=>20, xb=>80,
 370                           yb=>20 }), "linear box fill");
 371     alarm 0;
 372   };
 373   $@ and ok(0, "linear box fill $@");
 374 }
 375
 376 # test that passing in a non-array ref returns an error
 377 {
 378   my $fill = Imager::Fill->new(fountain=>'linear',
 379                                xa => 20, ya=>20, xb=>20, yb=>40,
 380                                segments=>"invalid");
 381   ok(!$fill, "passing invalid segments produces an error");
 382   cmp_ok(Imager->errstr, '=~', 'array reference',
 383          "check the error message");
 384 }
 385
 386 # test that colors in segments are converted
 387 {
 388   my @segs =
 389     (
 390      [ 0.0, 0.5, 1.0, '000000', '#FFF', 0, 0 ],
 391     );
 392   my $fill = Imager::Fill->new(fountain=>'linear',
 393                                xa => 0, ya=>20, xb=>49, yb=>20,
 394                                segments=>\@segs);
 395   ok($fill, "check that color names are converted")
 396     or print "# ",Imager->errstr,"\n";
 397   my $im = Imager->new(xsize=>50, ysize=>50);
 398   $im->box(fill=>$fill);
 399   my $left = $im->getpixel('x'=>0, 'y'=>20);
 400   ok(color_close($left, Imager::Color->new(0,0,0)),
 401      "check black converted correctly");
 402   my $right = $im->getpixel('x'=>49, 'y'=>20);
 403   ok(color_close($right, Imager::Color->new(255,255,255)),
 404      "check white converted correctly");
 405
 406   # check that invalid colors handled correctly
 407
 408   my @segs2 =
 409     (
 410      [ 0.0, 0.5, 1.0, '000000', 'FxFxFx', 0, 0 ],
 411     );
 412   my $fill2 = Imager::Fill->new(fountain=>'linear',
 413                                xa => 0, ya=>20, xb=>49, yb=>20,
 414                                segments=>\@segs2);
 415   ok(!$fill2, "check handling of invalid color names");
 416   cmp_ok(Imager->errstr, '=~', 'No color named', "check error message");
 417 }
 418
 419 { # RT #35278
 420   # hatch fills on a grey scale image don't adapt colors
 421   for my $bits (8, 'double') {
 422     my $im_g = Imager->new(xsize => 10, ysize => 10, channels => 1, bits => $bits);
 423     $im_g->box(filled => 1, color => 'FFFFFF');
 424     my $fill = Imager::Fill->new
 425       (
 426        combine => 'normal',
 427        hatch => 'weave',
 428        fg => '000000',
 429        bg => 'FFFFFF'
 430       );
 431     $im_g->box(fill => $fill);
 432     my $im_c = Imager->new(xsize => 10, ysize => 10, channels => 3, bits => $bits);
 433     $im_c->box(filled => 1, color => 'FFFFFF');
 434     $im_c->box(fill => $fill);
 435     my $im_cg = $im_g->convert(preset => 'rgb');
 436     is_image($im_c, $im_cg, "check hatch is the same between color and greyscale (bits $bits)");
 437
 438     # check the same for image fills
 439     my $grey_fill = Imager::Fill->new
 440       (
 441        image => $im_g,
 442        combine => 'normal'
 443       );
 444     my $im_cfg = Imager->new(xsize => 20, ysize => 20, bits => $bits);
 445     $im_cfg->box(filled => 1, color => '808080');
 446     $im_cfg->box(fill => $grey_fill);
 447     my $rgb_fill = Imager::Fill->new
 448       (
 449        image => $im_cg,
 450        combine => 'normal'
 451       );
 452     my $im_cfc = Imager->new(xsize => 20, ysize => 20, bits => $bits);
 453     $im_cfc->box(filled => 1, color => '808080');
 454     $im_cfc->box(fill => $rgb_fill);
 455     is_image($im_cfg, $im_cfc, "check filling from grey image matches filling from rgb (bits = $bits)");
 456
 457     my $im_gfg = Imager->new(xsize => 20, ysize => 20, channels => 1, bits => $bits);
 458     $im_gfg->box(filled => 1, color => '808080');
 459     $im_gfg->box(fill => $grey_fill);
 460     my $im_gfg_c = $im_gfg->convert(preset => 'rgb');
 461     is_image($im_gfg_c, $im_cfg, "check grey filled with grey against base (bits = $bits)");
 462
 463     my $im_gfc = Imager->new(xsize => 20, ysize => 20, channels => 1, bits => $bits);
 464     $im_gfc->box(filled => 1, color => '808080');
 465     $im_gfc->box(fill => $rgb_fill);
 466     my $im_gfc_c = $im_gfc->convert(preset => 'rgb');
 467     is_image($im_gfc_c, $im_cfg, "check grey filled with color against base (bits = $bits)");
 468   }
 469 }
 470
 471 { # alpha modifying fills
 472   { # 8-bit/sample
 473     my $base_img = Imager->new(xsize => 4, ysize => 2, channels => 4);
 474     $base_img->setscanline
 475       (
 476        x => 0,
 477        y => 0,
 478        pixels =>
 479        [
 480         map Imager::Color->new($_),
 481         qw/FF000020 00FF0080 00008040 FFFF00FF/,
 482        ],
 483       );
 484     $base_img->setscanline
 485       (
 486        x => 0,
 487        y => 1,
 488        pixels =>
 489        [
 490         map Imager::Color->new($_),
 491         qw/FFFF00FF FF000000 00FF0080 00008040/
 492        ]
 493       );
 494     my $base_fill = Imager::Fill->new
 495       (
 496        image => $base_img,
 497        combine => "normal",
 498       );
 499     ok($base_fill, "make the base image fill");
 500     my $fill50 = Imager::Fill->new(type => "opacity", opacity => 0.5, other => $base_fill)
 501       or print "# ", Imager->errstr, "\n";
 502     ok($fill50, "make 50% alpha translation fill");
 503
 504     { # 4 channel image
 505       my $out = Imager->new(xsize => 10, ysize => 10, channels => 4);
 506       $out->box(fill => $fill50);
 507       is_color4($out->getpixel(x => 0, y => 0),
 508                 255, 0, 0, 16, "check alpha output");
 509       is_color4($out->getpixel(x => 2, y => 1),
 510                 0, 255, 0, 64, "check alpha output");
 511       $out->box(filled => 1, color => "000000");
 512       is_color4($out->getpixel(x => 0, y => 0),
 513                 0, 0, 0, 255, "check after clear");
 514       $out->box(fill => $fill50);
 515       is_color4($out->getpixel(x => 4, y => 2),
 516                 16, 0, 0, 255, "check drawn against background");
 517       is_color4($out->getpixel(x => 6, y => 3),
 518                 0, 64, 0, 255, "check drawn against background");
 519     }
 520     { # 3 channel image
 521       my $out = Imager->new(xsize => 10, ysize => 10, channels => 3);
 522       $out->box(fill => $fill50);
 523       is_color3($out->getpixel(x => 0, y => 0),
 524                 16, 0, 0, "check alpha output");
 525       is_color3($out->getpixel(x => 2, y => 1),
 526                 0, 64, 0, "check alpha output");
 527       is_color3($out->getpixel(x => 0, y => 1),
 528                 128, 128, 0, "check alpha output");
 529     }
 530   }
 531   { # double/sample
 532     use Imager::Color::Float;
 533     my $base_img = Imager->new(xsize => 4, ysize => 2, channels => 4, bits => "double");
 534     $base_img->setscanline
 535       (
 536        x => 0,
 537        y => 0,
 538        pixels =>
 539        [
 540         map Imager::Color::Float->new(@$_),
 541         [ 1, 0, 0, 0.125 ],
 542         [ 0, 1, 0, 0.5 ],
 543         [ 0, 0, 0.5, 0.25 ],
 544         [ 1, 1, 0, 1 ],
 545        ],
 546       );
 547     $base_img->setscanline
 548       (
 549        x => 0,
 550        y => 1,
 551        pixels =>
 552        [
 553         map Imager::Color::Float->new(@$_),
 554         [ 1, 1, 0, 1 ],
 555         [ 1, 0, 0, 0 ],
 556         [ 0, 1, 0, 0.5 ],
 557         [ 0, 0, 0.5, 0.25 ],
 558        ]
 559       );
 560     my $base_fill = Imager::Fill->new
 561       (
 562        image => $base_img,
 563        combine => "normal",
 564       );
 565     ok($base_fill, "make the base image fill");
 566     my $fill50 = Imager::Fill->new(type => "opacity", opacity => 0.5, other => $base_fill)
 567       or print "# ", Imager->errstr, "\n";
 568     ok($fill50, "make 50% alpha translation fill");
 569     my $out = Imager->new(xsize => 10, ysize => 10, channels => 4, bits => "double");
 570     $out->box(fill => $fill50);
 571     is_fcolor4($out->getpixel(x => 0, y => 0, type => "float"),
 572               1, 0, 0, 0.0625, "check alpha output at 0,0");
 573     is_fcolor4($out->getpixel(x => 2, y => 1, type => "float"),
 574               0, 1, 0, 0.25, "check alpha output at 2,1");
 575     $out->box(filled => 1, color => "000000");
 576     is_fcolor4($out->getpixel(x => 0, y => 0, type => "float"),
 577               0, 0, 0, 1, "check after clear");
 578     $out->box(fill => $fill50);
 579     is_fcolor4($out->getpixel(x => 4, y => 2, type => "float"),
 580               0.0625, 0, 0, 1, "check drawn against background at 4,2");
 581     is_fcolor4($out->getpixel(x => 6, y => 3, type => "float"),
 582               0, 0.25, 0, 1, "check drawn against background at 6,3");
 583   }
 584   ok(!Imager::Fill->new(type => "opacity"),
 585      "should fail to make an opacity fill with no other fill object");
 586   is(Imager->errstr, "'other' parameter required to create opacity fill",
 587      "check error message");
 588   ok(!Imager::Fill->new(type => "opacity", other => "xx"),
 589      "should fail to make an opacity fill with a bad other parameter");
 590   is(Imager->errstr, "'other' parameter must be an Imager::Fill object to create an opacity fill",
 591          "check error message");
 592
 593   # check auto conversion of hashes
 594   ok(Imager::Fill->new(type => "opacity", other => { solid => "FF0000" }),
 595      "check we auto-create fills")
 596     or print "# ", Imager->errstr, "\n";
 597
 598   {
 599     # fill with combine none was modifying the wrong channel for a
 600     # no-alpha target image
 601     my $fill = Imager::Fill->new(solid => "#FFF", combine => "none");
 602     my $fill2 = Imager::Fill->new
 603       (
 604        type => "opacity",
 605        opacity => 0.5,
 606        other => $fill
 607       );
 608     my $im = Imager->new(xsize => 1, ysize => 1);
 609     ok($im->box(fill => $fill2), "fill with replacement opacity fill");
 610     is_color3($im->getpixel(x => 0, y => 0), 255, 255, 255,
 611               "check for correct colour");
 612   }
 613
 614   {
 615     require Imager::Fountain;
 616     my $fount = Imager::Fountain->new;
 617     $fount->add(c1 => "FFFFFF"); # simple white to black
 618     # base fill is a fountain
 619     my $base_fill = Imager::Fill->new
 620       (
 621        fountain => "linear",
 622        segments => $fount,
 623        xa => 0,
 624        ya => 0,
 625        xb => 100,
 626        yb => 100,
 627       );
 628     ok($base_fill, "made fountain fill base");
 629     my $op_fill = Imager::Fill->new
 630       (
 631        type => "opacity",
 632        other => $base_fill,
 633        opacity => 0.5,
 634       );
 635     ok($op_fill, "made opacity fountain fill");
 636     my $im = Imager->new(xsize => 100, ysize => 100);
 637     ok($im->box(fill => $op_fill), "draw with it");
 638   }
 639 }
 640
 641 sub color_close {
 642   my ($c1, $c2) = @_;
 643
 644   my @c1 = $c1->rgba;
 645   my @c2 = $c2->rgba;
 646
 647   for my $i (0..2) {
 648     if (abs($c1[$i]-$c2[$i]) > 2) {
 649       return 0;
 650     }
 651   }
 652   return 1;
 653 }
 654
 655 sub color_close4 {
 656   my ($c1, $c2) = @_;
 657
 658   my @c1 = $c1->rgba;
 659   my @c2 = $c2->rgba;
 660
 661   for my $i (0..3) {
 662     if (abs($c1[$i]-$c2[$i]) > 2) {
 663       return 0;
 664     }
 665   }
 666   return 1;
 667 }
 668
 669 # for use during testing
 670 sub save {
 671   my ($im, $name) = @_;
 672
 673   open FH, "> $name" or die "Cannot create $name: $!";
 674   binmode FH;
 675   my $io = Imager::io_new_fd(fileno(FH));
 676   Imager::i_writeppm_wiol($im, $io) or die "Cannot save to $name";
 677   undef $io;
 678   close FH;
 679 }