Imager
view release on metacpan or search on metacpan
t/100-base/010-introvert.t view on Meta::CPAN
if (color_cmp($cols[$i], $exp[$i])) {
$good = 0;
last;
}
}
ok($good, "all colors in palette as expected");
is($impal2->colorcount, 3, "and colorcount returns 3");
is($impal2->maxcolors, 256, "maxcolors as expected");
is($impal2->findcolor(color=>$blue), 1, "findcolors found blue");
ok($impal2->setcolors(start=>0, colors=>[ $blue, $red ]),
"we can setcolors");
# make an rgb version
my $imrgb2 = $impal2->to_rgb8()
or diag($impal2->errstr);
is($imrgb2->type, 'direct', "converted is direct");
# and back again, specifying the palette
my @colors = ( $red, $blue, $green );
my $impal3 = $imrgb2->to_paletted(colors=>\@colors,
make_colors=>'none',
translate=>'closest');
ok($impal3, "got a paletted image from conversion");
dump_colors(@colors);
print "# in image\n";
dump_colors($impal3->getcolors);
is($impal3->colorcount, 3, "new image has expected color table size");
is($impal3->type, 'paletted', "and is paletted");
}
{
my $im = Imager->new;
ok($im, "make empty image");
ok(!$im->to_rgb8, "convert to rgb8");
is($im->errstr, "to_rgb8: empty input image", "check message");
is($im->bits, undef, "can't call bits on an empty image");
is($im->errstr, "bits: empty input image", "check message");
is($im->type, undef, "can't call type on an empty image");
is($im->errstr, "type: empty input image", "check message");
is($im->virtual, undef, "can't call virtual on an empty image");
is($im->errstr, "virtual: empty input image", "check message");
is($im->is_bilevel, undef, "can't call virtual on an empty image");
is($im->errstr, "is_bilevel: empty input image", "check message");
ok(!$im->getscanline(y => 0), "can't call getscanline on an empty image");
is($im->errstr, "getscanline: empty input image", "check message");
ok(!$im->setscanline(y => 0, pixels => [ $red, $blue ]),
"can't call setscanline on an empty image");
is($im->errstr, "setscanline: empty input image", "check message");
ok(!$im->getsamples(y => 0), "can't call getsamples on an empty image");
is($im->errstr, "getsamples: empty input image", "check message");
is($im->getwidth, undef, "can't get width of empty image");
is($im->errstr, "getwidth: empty input image", "check message");
is($im->getheight, undef, "can't get height of empty image");
is($im->errstr, "getheight: empty input image", "check message");
is($im->getchannels, undef, "can't get channels of empty image");
is($im->errstr, "getchannels: empty input image", "check message");
is($im->getmask, undef, "can't get mask of empty image");
is($im->errstr, "getmask: empty input image", "check message");
{
no if $] >= 5.014, warnings => 'Imager::channelmask';
is($im->setmask, undef, "can't set mask of empty image");
is($im->errstr, "setmask: empty input image", "check message");
}
is($im->colorchannels, undef, "can't get colorchannels of empty image");
is($im->errstr, "colorchannels: empty input image", "check message");
is($im->alphachannel, undef, "can't get alphachannel of empty image");
is($im->errstr, "alphachannel: empty input image", "check message");
is($im->colormodel, undef, "can't get colormodel of empty image");
is($im->errstr, "colormodel: empty input image", "check message");
}
{ # basic checks, 8-bit direct images
my $im = Imager->new(xsize => 2, ysize => 3);
ok($im, 'create 8-bit direct image');
is($im->bits, 8, '8 bits');
ok(!$im->virtual, 'not virtual');
is($im->type, 'direct', 'direct image');
ok(!$im->is_bilevel, 'not mono');
}
ok(!Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"0 height error message check");
ok(!Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"0 width error message check");
ok(!Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"-ve width error message check");
ok(!Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"-ve height error message check");
ok(!Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
"-ve width/height error message check");
ok(!Imager->new(xsize=>1, ysize=>1, channels=>0),
"fail to create a zero channel image");
cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
"out of range channel message check");
ok(!Imager->new(xsize=>1, ysize=>1, channels=>5),
"fail to create a five channel image");
cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
"out of range channel message check");
{
# https://rt.cpan.org/Ticket/Display.html?id=8213
# check for handling of memory allocation of very large images
# only test this on 32-bit machines - on a 64-bit machine it may
# result in trying to allocate 4Gb of memory, which is unfriendly at
# least and may result in running out of memory, causing a different
# type of exit
SKIP:
{
use Config;
skip("don't want to allocate 4Gb", 8) unless $Config{ptrsize} == 4;
my $uint_range = 256 ** $Config{intsize};
print "# range $uint_range\n";
my $dim1 = int(sqrt($uint_range))+1;
my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1);
t/100-base/010-introvert.t view on Meta::CPAN
(0,0,0,0) x 4,
(0, 255, 0, 255),
(0, 0, 255, 255),
(0, 0, 0, 0) x 4,
);
is(Imager::i_plin($im, 0, 2, pack("C*", @scalar_plin)),
10, "i_plin - pass in a scalar");
is_deeply(\@scalar_plin,
[ map $_->rgba , Imager::i_glin($im, 0, 10, 2) ],
"check i_plin scalar wrote to the image");
my @plinf_colors = # Note: only 9 pixels
(
($f_blue) x 4,
$f_red,
($f_black) x 3,
$f_black
);
is(Imager::i_plinf($im, 0, 3, @plinf_colors), 9,
"i_plinf - list");
is_deeply([ map $_->rgba, Imager::i_glinf($im, 0, 9, 3) ],
[ map $_->rgba, @plinf_colors ],
"check colors were written");
my @scalar_plinf =
(
( 1.0, 1.0, 0, 1.0 ) x 3,
( 0, 1.0, 1.0, 1.0 ) x 2,
( 0, 0, 0, 0 ),
( 1.0, 0, 1.0, 1.0 ),
);
is(Imager::i_plinf($im, 2, 4, pack("d*", @scalar_plinf)),
7, "i_plinf - scalar");
is_deeply(\@scalar_plinf,
[ map $_->rgba, Imager::i_glinf($im, 2, 9, 4) ],
"check colors were written");
is_deeply([ Imager::i_gsamp($im, 0, 10, 0, [ 0, 3 ]) ],
[ (0, 0) x 5, (255, 255), (0, 0) x 4 ],
"i_gsamp list context");
is("0000" x 5 . "FFFF" . "0000" x 4,
uc unpack("H*", Imager::i_gsamp($im, 0, 10, 0, [ 0, 3 ])),
"i_gsamp scalar context");
is_deeply([ Imager::i_gsampf($im, 2, 9, 4, [ 0, 2, 3 ]) ],
[ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
(1.0, 1.0, 1.0) ], "i_gsampf - list context");
is_deeply([ unpack("d*", Imager::i_gsampf($im, 2, 9, 4, [ 0, 2, 3 ])) ],
[ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
(1.0, 1.0, 1.0) ], "i_gsampf - scalar context");
print "# end low-level scan-line function tests\n";
}
my $psamp_outside_error = "Image position outside of image";
{ # psamp
print "# psamp\n";
my $imraw = Imager::ImgRaw::new(10, 20, 3);
{
is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
"i_psamp def channels, 3 samples");
is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
"check color written");
Imager::i_img_setmask($imraw, 5);
is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
"i_psamp def channels, 3 samples, masked");
is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
"check color written");
is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
"i_psamp channels listed, 3 samples, masked");
is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
"check color written");
Imager::i_img_setmask($imraw, ~0);
is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
"i_psamp channels [0, 1], 4 samples");
is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
"check first color written");
is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
"check second color written");
is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
"write a full row");
is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
[ (128, 63, 32) x 10 ],
"check full row");
is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
[ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
is(Imager::i_psamp($imraw, 4, 6, undef, [ 0 .. 18 ], 1), 18,
"psamp with offset");
is_deeply([ Imager::i_gsamp($imraw, 0, 10, 6, undef) ],
[ (0) x 12, 1 .. 18 ],
"check result");
is(Imager::i_psamp($imraw, 4, 11, undef, [ 0 .. 18 ], 1, 3), 9,
"psamp with offset and width");
is_deeply([ Imager::i_gsamp($imraw, 0, 10, 11, undef) ],
[ (0) x 12, 1 .. 9, (0) x 9 ],
"check result");
}
{ # errors we catch
is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
is(_get_error(), "No channel 3 in this image",
"check error message");
is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
is(_get_error(), "No channel -1 in this image",
"check error message");
is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
"negative y");
is(_get_error(), $psamp_outside_error,
"check error message");
is(Imager::i_psamp($imraw, 0, 20, undef, [ 0, 0, 0 ]), undef,
"y overflow");
is(_get_error(), $psamp_outside_error,
"check error message");
is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
"negative x");
is(_get_error(), $psamp_outside_error,
"check error message");
is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
"x overflow");
is(_get_error(), $psamp_outside_error,
"check error message");
}
{ # test the im_sample_list typemap
ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], undef); 1 },
"pass undef as the sample list");
like($@, qr/data must be a scalar or an arrayref/,
"check message");
ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], { a => 1 }); 1 },
"hashref as the sample list");
like($@, qr/data must be a scalar or an arrayref/,
"check message");
ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], []); 1 },
"empty sample list");
like($@, qr/i_psamp: no samples provided in data/,
"check message");
ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], ""); 1 },
"empty scalar sample list");
like($@, qr/i_psamp: no samples provided in data/,
"check message");
# not the typemap
is(Imager::i_psamp($imraw, 0, 8, undef, [ (0) x 3 ], -1), undef,
"negative offset");
is(_get_error(), "offset must be non-negative",
"check message");
is(Imager::i_psamp($imraw, 0, 8, undef, [ (0) x 3 ], 4), undef,
"too high offset");
is(_get_error(), "offset greater than number of samples supplied",
"check message");
}
print "# end psamp tests\n";
}
{ # psampf
print "# psampf\n";
my $imraw = Imager::ImgRaw::new(10, 20, 3);
{
is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
"i_psampf def channels, 3 samples");
is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
"check color written");
Imager::i_img_setmask($imraw, 5);
is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
"i_psampf def channels, 3 samples, masked");
is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
"check color written");
is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
"i_psampf channels listed, 3 samples, masked");
is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
"check color written");
Imager::i_img_setmask($imraw, ~0);
is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
"i_psampf channels [0, 1], 4 samples");
is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
"check first color written");
is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
"check second color written");
is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
"write a full row");
is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
[ (128, 64, 32) x 10 ],
"check full row");
is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
[ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
is(Imager::i_psampf($imraw, 4, 6, undef, [ map $_/254.9, 0 .. 18 ], 1), 18,
"psampf with offset");
is_deeply([ Imager::i_gsamp($imraw, 0, 10, 6, undef) ],
[ (0) x 12, 1 .. 18 ],
"check result");
is(Imager::i_psampf($imraw, 4, 11, undef, [ map $_/254.9, 0 .. 18 ], 1, 3), 9,
"psampf with offset and width");
is_deeply([ Imager::i_gsamp($imraw, 0, 10, 11, undef) ],
[ (0) x 12, 1 .. 9, (0) x 9 ],
"check result");
}
{ # errors we catch
is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
is(_get_error(), "No channel 3 in this image",
"check error message");
is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
is(_get_error(), "No channel -1 in this image",
"check error message");
is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
"negative y");
is(_get_error(), $psamp_outside_error,
"check error message");
is(Imager::i_psampf($imraw, 0, 20, undef, [ 0, 0, 0 ]), undef,
"y overflow");
is(_get_error(), $psamp_outside_error,
"check error message");
is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
"negative x");
is(_get_error(), $psamp_outside_error,
"check error message");
is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
"x overflow");
is(_get_error(), $psamp_outside_error,
"check error message");
}
{ # test the im_fsample_list typemap
ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], undef); 1 },
"pass undef as the sample list");
like($@, qr/data must be a scalar or an arrayref/,
"check message");
ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], { a => 1 }); 1 },
"hashref as the sample list");
like($@, qr/data must be a scalar or an arrayref/,
"check message");
t/100-base/010-introvert.t view on Meta::CPAN
SKIP:
{
skip "No detailed warning registration before 5.014", 1
if $] < 5.014;
# warnings should be enabled
my @warn;
local $SIG{__WARN__} = sub { push @warn, "@_"; };
my $im = Imager->new(xsize => 1, ysize => 1);
$im->settag(code => 10, value => 10);
is(scalar @warn, 1, "settag with code warns");
like($warn[0], qr/settag: code parameter is deprecated/,
"check message for settag");
@warn = ();
{
no if $] >= 5.014, warnings => 'Imager::tagcodes';
$im->settag(code => 10, value => 10);
}
is(scalar @warn, 0, "settag with code with warning disabled doesn't warn");
@warn = ();
$im->addtag(code => 11, value => 11);
is(scalar @warn, 1, "addtag with code warns");
like($warn[0], qr/addtag: code parameter is deprecated/,
"check message for addtag");
@warn = ();
{
no if $] >= 5.014, warnings => 'Imager::tagcodes';
$im->addtag(code => 12, value => 12);
}
is(scalar @warn, 0, "addtag with code with warning disabled doesn't warn");
{
my @tag_tests =
(
[ intmax => INT_MAX + 0 ],
[ uintmax => UINT_MAX + 0 ],
[ intmin => INT_MIN + 0 ],
[ intmaxp1 => 1+INT_MAX ],
[ uintmaxp1 => 1+UINT_MAX ],
[ neg1 => -1 ],
[ zero => 0 ],
[ zerozero => "00" ],
[ zeroone => "01" ],
[ negzero => "-0" ],
[ negzone => "-01" ],
[ arabone => "\x{661}", "no unicode yet" ],
);
for my $test (@tag_tests) {
my ($name, $val, $todo) = @$test;
ok($im->addtag(name => $name, value => $val),
"add $name = $val");
my $got = $im->tags(name => $name);
local $TODO = $todo;
is($got, $val, "$name added correctly");
}
}
# setmask
@warn = ();
$im->setmask(mask => 0xFF);
is(scalar @warn, 1, "warned on setmask");
like($warn[0], qr/setmask: image channel masks are deprecated/,
"check setmask warning message");
@warn = ();
{
no if $] >= 5.014, warnings => 'Imager::channelmask';
$im->setmask(mask => 0xFF);
}
is(scalar @warn, 0, "setmask with warning disabled doesn't warn");
}
{
my @tests =
(
[ "gray", 1, undef ],
[ "graya", 1, 1 ],
[ "rgb", 3, undef ],
[ "rgba", 3, 3 ],
);
for my $test (@tests) {
my ($model, $color_channels, $alpha) = @$test;
my $im = Imager->new(model => $model, xsize => 10, ysize => 10)
or die "Cannot create $model image:", Imager->errstr;
ok($im, "make a $model image via model");
is($im->colormodel, $model, "check colormodel is $model");
is($im->alphachannel, $alpha, "check alphachannel");
is($im->colorchannels, $color_channels, "check colorchannels");
}
}
done_testing();
Imager->close_log();
unless ($ENV{IMAGER_KEEP_FILES}) {
unlink "testout/t01introvert.log";
}
sub check_add {
my ($im, $color, $expected) = @_;
my $index = Imager::i_addcolors($im, $color);
ok($index, "got index");
print "# $index\n";
is(0+$index, $expected, "index matched expected");
my ($new) = Imager::i_getcolors($im, $index);
ok($new, "got the color");
ok(color_cmp($new, $color) == 0, "color matched what was added");
$index;
}
# sub array_ncmp {
# my ($a1, $a2) = @_;
# my $len = @$a1 < @$a2 ? @$a1 : @$a2;
# for my $i (0..$len-1) {
# my $diff = $a1->[$i] <=> $a2->[$i]
# and return $diff;
# }
# return @$a1 <=> @$a2;
# }
sub dump_colors {
for my $col (@_) {
print "# ", map(sprintf("%02X", $_), ($col->rgba)[0..2]),"\n";
}
}
sub _get_error {
my @errors = Imager::i_errors();
( run in 1.864 second using v1.01-cache-2.11-cpan-ceb78f64989 )