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