and set make_colors to 'none', quant_translate() would segfault.
This was because it was making the reasonable assumption that
you'd have colors to map to. quant_translate() now checks there
is at least one color and return NULL if there isn't.
- i_img_to_pal() now does error checking of the value returned by
quant_translate().
- Imager::to_paletted() now checks for success/failure of
i_img_to_pal() correctly and does appropriate error handling.
- i_writegif_low() did no error checking on the result of
quant_translate(), it now does
- we now test that trying to write a GIF image with no palette
allowable by the quant options is a failure.
- Imager::write() was doing nothing with the result of the call
to i_writegif_gen(), in particular it wasn't returning () on
failure.
- added tests for paletted image handling and the methods
specific to those images
- the XS for i_setcolors() was missing the OUTPUT clause for
RETVAL, and hence wasn't returning failure on failure.
- supplying a sufficiently small scaling value could make the
scale() method return an image with zero height or width.
- the void context warning for scale() now includes the callers
filename/line (instead of the default of Imager.pm line 15xx)
- Imager->new will now return undef if the dimensions or number of
channels specified for an image are out of range. An error
message can be retrieved with Imager->errstr.
Thanks to Elthek on rhizo for reporting this and help in
tracking it down.
- added a bunch of tests for reading pnm files.
+ - previously, if you supplied to_paletted and empty color map
+ and set make_colors to 'none', quant_translate() would segfault.
+ This was because it was making the reasonable assumption that
+ you'd have colors to map to. quant_translate() now checks there
+ is at least one color and return NULL if there isn't.
+ - i_img_to_pal() now does error checking of the value returned by
+ quant_translate().
+ - Imager::to_paletted() now checks for success/failure of
+ i_img_to_pal() correctly and does appropriate error handling.
+ - i_writegif_low() did no error checking on the result of
+ quant_translate(), it now does
+ - we now test that trying to write a GIF image with no palette
+ allowable by the quant options is a failure.
+ - Imager::write() was doing nothing with the result of the call
+ to i_writegif_gen(), in particular it wasn't returning () on
+ failure.
+ - added tests for paletted image handling and the methods
+ specific to those images
+ - the XS for i_setcolors() was missing the OUTPUT clause for
+ RETVAL, and hence wasn't returning failure on failure.
+ - supplying a sufficiently small scaling value could make the
+ scale() method return an image with zero height or width.
+ - the void context warning for scale() now includes the callers
+ filename/line (instead of the default of Imager.pm line 15xx)
+ - Imager->new will now return undef if the dimensions or number of
+ channels specified for an image are out of range. An error
+ message can be retrieved with Imager->errstr.
=================================================================
$self->{ERRSTR}=undef; #
$self->{DEBUG}=$DEBUG;
$self->{DEBUG} && print "Initialized Imager\n";
- if ($hsh{xsize} && $hsh{ysize}) { $self->img_set(%hsh); }
+ if (defined $hsh{xsize} && defined $hsh{ysize}) {
+ unless ($self->img_set(%hsh)) {
+ $Imager::ERRSTR = $self->{ERRSTR};
+ return;
+ }
+ }
return $self;
}
$self->{IMG}=Imager::ImgRaw::new($hsh{'xsize'}, $hsh{'ysize'},
$hsh{'channels'});
}
+
+ unless ($self->{IMG}) {
+ $self->{ERRSTR} = Imager->_error_as_msg();
+ return;
+ }
+
+ $self;
}
# created a masked version of the current image
#print "Type ", i_img_type($result->{IMG}), "\n";
- $result->{IMG} or undef $result;
-
- return $result;
+ if ($result->{IMG}) {
+ return $result;
+ }
+ else {
+ $self->{ERRSTR} = $self->_error_as_msg;
+ return;
+ }
}
# convert a paletted (or any image) to an 8-bit/channel RGB images
$input{make_colors} = 'webmap'; # ignored
$input{translate} = 'giflib';
}
- $rc = i_writegif_wiol($IO, \%input, $self->{IMG});
+ if (!i_writegif_wiol($IO, \%input, $self->{IMG})) {
+ $self->{ERRSTR} = $self->_error_as_msg;
+ return;
+ }
}
if (exists $input{'data'}) {
my $tmp = Imager->new();
unless (defined wantarray) {
- warn "scale() called in void context - scale() returns the scaled image";
+ my @caller = caller;
+ warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
return;
}
ST(0) = sv_2mortal(newSViv(index));
}
-int
+undef_int
i_setcolors(im, index, ...)
Imager::ImgRaw im
int index
}
RETVAL = i_setcolors(im, index, colors, items-2);
myfree(colors);
+ OUTPUT:
+ RETVAL
void
i_getcolors(im, index, ...)
t/t020masked.t
t/t021sixteen.t
t/t022double.t Test double/sample images
+t/t023palette.t Test paletted images
t/t05error.t
t/t07iolayer.t
t/t101jpeg.t
testimg/gimpgrad A GIMP gradient file
testimg/junk.ppm
testimg/loccmap.gif
-testimg/maxval.ppm
+testimg/maxval.ppm For ppm file maxval handling
testimg/maxval_0.ppm
testimg/maxval_256.ppm
testimg/maxval_4095_asc.ppm
result = quant_paletted(quant, imgs[0]);
else
result = quant_translate(quant, imgs[0]);
+ if (!result) {
+ i_mempool_destroy(&mp);
+ quant->mc_colors = orig_colors;
+ EGifCloseFile(gf);
+ return 0;
+ }
if (want_trans) {
quant_transparent(quant, result, imgs[0], quant->mc_count);
trans_index = quant->mc_count;
quant_makemap(quant, imgs+imgn, 1);
result = quant_translate(quant, imgs[imgn]);
}
+ if (!result) {
+ i_mempool_destroy(&mp);
+ quant->mc_colors = orig_colors;
+ EGifCloseFile(gf);
+ mm_log((1, "error in quant_translate()"));
+ return 0;
+ }
if (want_trans) {
quant_transparent(quant, result, imgs[imgn], quant->mc_count);
trans_index = quant->mc_count;
i_img *
i_img_empty_ch(i_img *im,int x,int y,int ch) {
mm_log((1,"i_img_empty_ch(*im %p, x %d, y %d, ch %d)\n", im, x, y, ch));
+
+ if (x < 1 || y < 1) {
+ i_push_error(0, "Image sizes must be positive");
+ return NULL;
+ }
+ if (ch < 1 || ch > MAXCHANNELS) {
+ i_push_errorf(0, "channels must be between 1 and %d", MAXCHANNELS);
+ return NULL;
+ }
+
if (im == NULL)
if ( (im=mymalloc(sizeof(i_img))) == NULL)
m_fatal(2,"malloc() error\n");
if (Axis == XAXIS) {
hsize = (int)(0.5 + im->xsize * Value);
+ if (hsize < 1) {
+ hsize = 1;
+ Value = 1 / im->xsize;
+ }
vsize = im->ysize;
jEnd = hsize;
hsize = im->xsize;
vsize = (int)(0.5 + im->ysize * Value);
+ if (vsize < 1) {
+ vsize = 1;
+ Value = 1 / im->ysize;
+ }
+
jEnd = vsize;
iEnd = hsize;
}
mm_log((1,"i_scale_nn(im 0x%x,scx %.2f,scy %.2f)\n",im,scx,scy));
nxsize = (int) ((float) im->xsize * scx);
+ if (nxsize < 1) {
+ nxsize = 1;
+ scx = 1 / im->xsize;
+ }
nysize = (int) ((float) im->ysize * scy);
+ if (nysize < 1) {
+ nysize = 1;
+ scy = 1 / im->ysize;
+ }
new_img=i_img_empty_ch(NULL,nxsize,nysize,im->channels);
*/
i_img *i_img_16_new_low(i_img *im, int x, int y, int ch) {
mm_log((1,"i_img_16_new(x %d, y %d, ch %d)\n", x, y, ch));
+
+ if (x < 1 || y < 1) {
+ i_push_error(0, "Image sizes must be positive");
+ return NULL;
+ }
+ if (ch < 1 || ch > MAXCHANNELS) {
+ i_push_errorf(0, "channels must be between 1 and %d", MAXCHANNELS);
+ return NULL;
+ }
*im = IIM_base_16bit_direct;
i_tags_new(&im->tags);
i_img *i_img_16_new(int x, int y, int ch) {
i_img *im;
+
+ i_clear_error();
im = mymalloc(sizeof(i_img));
if (im) {
*/
i_img *i_img_double_new_low(i_img *im, int x, int y, int ch) {
mm_log((1,"i_img_double_new(x %d, y %d, ch %d)\n", x, y, ch));
+
+ if (x < 1 || y < 1) {
+ i_push_error(0, "Image sizes must be positive");
+ return NULL;
+ }
+ if (ch < 1 || ch > MAXCHANNELS) {
+ i_push_errorf(0, "channels must be between 1 and %d", MAXCHANNELS);
+ return NULL;
+ }
*im = IIM_base_double_direct;
i_tags_new(&im->tags);
i_img *i_img_double_new(int x, int y, int ch) {
i_img *im;
+ i_clear_error();
+
im = mymalloc(sizeof(i_img));
if (im) {
if (!i_img_double_new_low(im, x, y, ch)) {
$img->setcolors(start=>$start, colors=>\@colors);
Once you have colors in the palette you can overwrite them with the
-C<setcolors()> method: C<sercolors()> returns true on success.
+C<setcolors()> method: C<setcolors()> returns true on success.
=item getcolors
return NULL;
}
if (channels < 1 || channels > MAXCHANNELS) {
- i_push_errorf(0, "Channels must be postive and <= %d", MAXCHANNELS);
+ i_push_errorf(0, "Channels must be positive and <= %d", MAXCHANNELS);
return NULL;
}
i_img *i_img_to_pal(i_img *src, i_quantize *quant) {
i_palidx *result;
i_img *im;
-
- im = i_img_pal_new(src->xsize, src->ysize, src->channels, quant->mc_size);
+ i_clear_error();
+
quant_makemap(quant, &src, 1);
result = quant_translate(quant, src);
- /* copy things over */
- memcpy(im->idata, result, im->bytes);
- PALEXT(im)->count = quant->mc_count;
- memcpy(PALEXT(im)->pal, quant->mc_colors, sizeof(i_color) * quant->mc_count);
+ if (result) {
- myfree(result);
+ im = i_img_pal_new(src->xsize, src->ysize, src->channels, quant->mc_size);
- return im;
+ /* copy things over */
+ memcpy(im->idata, result, im->bytes);
+ PALEXT(im)->count = quant->mc_count;
+ memcpy(PALEXT(im)->pal, quant->mc_colors, sizeof(i_color) * quant->mc_count);
+
+ myfree(result);
+
+ return im;
+ }
+ else {
+ return NULL;
+ }
}
/*
i_palidx *result;
mm_log((1, "quant_translate(quant %p, img %p)\n", quant, img));
+ /* there must be at least one color in the paletted (though even that
+ isn't very useful */
+ if (quant->mc_count == 0) {
+ i_push_error(0, "no colors available for translation");
+ return NULL;
+ }
+
result = mymalloc(img->xsize * img->ysize);
switch (quant->translate) {
if (imgs[imgn]->channels > 2) {
chan_count = 3;
for (x = 0; x < imgs[imgn]->xsize; ++x) {
- printf("bumped entry %d\n", MED_CUT_INDEX(line[x]));
++colors[MED_CUT_INDEX(line[x])].count;
}
}
use strict;
my $loaded;
-BEGIN { $| = 1; print "1..71\n"; }
+BEGIN { $| = 1; print "1..85\n"; }
END {print "not ok 1\n" unless $loaded;}
use Imager qw(:handy :all);
$loaded = 1;
print "ok 1\n";
+require "t/testtools.pl";
+
init_log("testout/t01introvert.log",1);
my $im_g = Imager::ImgRaw::new(100, 101, 1);
print "ok 71\n";
}
+my $num = 72;
+okn($num++, !Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "0 height error message check");
+okn($num++, !Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "0 width error message check");
+okn($num++, !Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "-ve width error message check");
+okn($num++, !Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "-ve height error message check");
+okn($num++, !Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "-ve width/height error message check");
+
+okn($num++, !Imager->new(xsize=>1, ysize=>1, channels=>0),
+ "fail to create a zero channel image");
+matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
+ "out of range channel message check");
+okn($num++, !Imager->new(xsize=>1, ysize=>1, channels=>5),
+ "fail to create a five channel image");
+matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
+ "out of range channel message check");
+
+
sub check_add {
my ($base, $im, $color, $expected) = @_;
my $index = Imager::i_addcolors($im, $color)
#!perl -w
use strict;
-BEGIN { $| = 1; print "1..29\n"; }
+BEGIN { $| = 1; print "1..43\n"; }
my $loaded;
END {print "not ok 1\n" unless $loaded;}
use Imager qw(:all :handy);
$loaded = 1;
print "ok 1\n";
init_log("testout/t021sixteen.log", 1);
+require "t/testtools.pl";
use Imager::Color::Float;
$oo16img->bits == 16 or print "not ";
print "ok 29\n";
+my $num = 30;
+# make sure of error handling
+okn($num++, !Imager->new(xsize=>0, ysize=>1, bits=>16),
+ "fail to create a 0 pixel wide image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "and correct error message");
+
+okn($num++, !Imager->new(xsize=>1, ysize=>0, bits=>16),
+ "fail to create a 0 pixel high image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "and correct error message");
+
+okn($num++, !Imager->new(xsize=>-1, ysize=>1, bits=>16),
+ "fail to create a negative width image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "and correct error message");
+
+okn($num++, !Imager->new(xsize=>1, ysize=>-1, bits=>16),
+ "fail to create a negative height image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "and correct error message");
+
+okn($num++, !Imager->new(xsize=>-1, ysize=>-1, bits=>16),
+ "fail to create a negative width/height image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "and correct error message");
+
+okn($num++, !Imager->new(xsize=>1, ysize=>1, bits=>16, channels=>0),
+ "fail to create a zero channel image");
+matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
+ "and correct error message");
+okn($num++, !Imager->new(xsize=>1, ysize=>1, bits=>16, channels=>5),
+ "fail to create a five channel image");
+matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
+ "and correct error message");
sub NCF {
return Imager::Color::Float->new(@_);
#!perl -w
use strict;
-BEGIN { $| = 1; print "1..30\n"; }
+BEGIN { $| = 1; print "1..42\n"; }
my $loaded;
END {print "not ok 1\n" unless $loaded;}
use Imager qw(:all :handy);
#use Data::Dumper;
$loaded = 1;
print "ok 1\n";
+
+require "t/testtools.pl";
+
init_log("testout/t022double.log", 1);
use Imager::Color::Float;
my $oocopy = $ooimg->copy;
ok(30, $oocopy->bits eq 'double', "oo copy didn't give double image");
+my $num = 31;
+okn($num++, !Imager->new(xsize=>0, ysize=>1, bits=>'double'),
+ "fail making 0 width image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "and correct message");
+okn($num++, !Imager->new(xsize=>1, ysize=>0, bits=>'double'),
+ "fail making 0 height image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "and correct message");
+okn($num++, !Imager->new(xsize=>-1, ysize=>1, bits=>'double'),
+ "fail making -ve width image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "and correct message");
+okn($num++, !Imager->new(xsize=>1, ysize=>-1, bits=>'double'),
+ "fail making -ve height image");
+matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
+ "and correct message");
+okn($num++, !Imager->new(xsize=>1, ysize=>1, bits=>'double', channels=>0),
+ "fail making 0 channel image");
+matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
+ "and correct message");
+okn($num++, !Imager->new(xsize=>1, ysize=>1, bits=>'double', channels=>5),
+ "fail making 5 channel image");
+matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
+ "and correct message");
+
sub NCF {
return Imager::Color::Float->new(@_);
}
--- /dev/null
+#!perl -w
+# some of this is tested in t01introvert.t too
+use strict;
+my $loaded;
+BEGIN {
+ require "t/testtools.pl";
+ $| = 1; print "1..49\n";
+}
+END { okx(0, "loading") unless $loaded; }
+use Imager;
+$loaded = 1;
+
+okx(1, "Loaded");
+
+my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
+
+okx($img, "paletted image created");
+
+okx($img->type eq 'paletted', "got a paletted image");
+
+my $black = Imager::Color->new(0,0,0);
+my $red = Imager::Color->new(255,0,0);
+my $green = Imager::Color->new(0,255,0);
+my $blue = Imager::Color->new(0,0,255);
+
+my $white = Imager::Color->new(255,255,255);
+
+# add some color
+my $blacki = $img->addcolors(colors=>[ $black, $red, $green, $blue ]);
+
+print "# blacki $blacki\n";
+okx(defined $blacki && $blacki == 0, "we got the first color");
+
+okx($img->colorcount() == 4, "should have 4 colors");
+my ($redi, $greeni, $bluei) = 1..3;
+
+my @all = $img->getcolors;
+okx(@all == 4, "all colors is 4");
+coloreq($all[0], $black, "first black");
+coloreq($all[1], $red, "then red");
+coloreq($all[2], $green, "then green");
+coloreq($all[3], $blue, "and finally blue");
+
+# keep this as an assignment, checking for scalar context
+# we don't want the last color, otherwise if the behaviour changes to
+# get all up to the last (count defaulting to size-index) we'd get a
+# false positive
+my $one_color = $img->getcolors(start=>$redi);
+okx($one_color->isa('Imager::Color'), "check scalar context");
+coloreq($one_color, $red, "and that it's what we want");
+
+# make sure we can find colors
+okx(!defined($img->findcolor(color=>$white)),
+ "shouldn't be able to find white");
+okx($img->findcolor(color=>$black) == $blacki, "find black");
+okx($img->findcolor(color=>$red) == $redi, "find red");
+okx($img->findcolor(color=>$green) == $greeni, "find green");
+okx($img->findcolor(color=>$blue) == $bluei, "find blue");
+
+# various failure tests for setcolors
+okx(!defined($img->setcolors(start=>-1, colors=>[$white])),
+ "expect failure: low index");
+okx(!defined($img->setcolors(start=>1, colors=>[])),
+ "expect failure: no colors");
+okx(!defined($img->setcolors(start=>5, colors=>[$white])),
+ "expect failure: high index");
+
+# set the green index to white
+okx($img->setcolors(start => $greeni, colors => [$white]),
+ "set a color");
+# and check it
+coloreq(scalar($img->getcolors(start=>$greeni)), $white,
+ "make sure it was set");
+okx($img->findcolor(color=>$white) == $greeni, "and that we can find it");
+okx(!defined($img->findcolor(color=>$green)), "and can't find the old color");
+
+# write a few colors
+okx(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
+ "save multiple");
+coloreq(scalar($img->getcolors(start=>$redi)), $green, "first of multiple");
+coloreq(scalar($img->getcolors(start=>$greeni)), $red, "second of multiple");
+
+# put it back
+$img->setcolors(start=>$red, colors=>[$red, $green]);
+
+# draw on the image, make sure it stays paletted when it should
+okx($img->box(color=>$red, filled=>1), "fill with red");
+okx($img->type eq 'paletted', "paletted after fill");
+okx($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
+ xmax=>40, ymax=>40), "green box");
+okx($img->type eq 'paletted', 'still paletted after box');
+# an AA line will almost certainly convert the image to RGB, don't use
+# an AA line here
+okx($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
+ "draw a line");
+okx($img->type eq 'paletted', 'still paletted after line');
+
+# draw with white - should convert to direct
+okx($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20,
+ xmax=>30, ymax=>30), "white box");
+okx($img->type eq 'direct', "now it should be direct");
+
+# various attempted to make a paletted image from our now direct image
+my $palimg = $img->to_paletted;
+okx($palimg, "we got an image");
+# they should be the same pixel for pixel
+okx(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
+
+# strange case: no color picking, and no colors
+# this was causing a segmentation fault
+$palimg = $img->to_paletted(colors=>[ ], make_colors=>'none');
+okx(!defined $palimg, "to paletted with an empty palette is an error");
+print "# ",$img->errstr,"\n";
+okx(scalar($img->errstr =~ /no colors available for translation/),
+ "and got the correct msg");
+
+okx(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'),
+ "fail on -ve height");
+matchx(Imager->errstr, qr/Image sizes must be positive/,
+ "and correct error message");
+okx(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'),
+ "fail on -ve width");
+matchx(Imager->errstr, qr/Image sizes must be positive/,
+ "and correct error message");
+okx(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'),
+ "fail on -ve width/height");
+matchx(Imager->errstr, qr/Image sizes must be positive/,
+ "and correct error message");
+
+okx(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
+ "fail on 0 channels");
+matchx(Imager->errstr, qr/Channels must be positive and <= 4/,
+ "and correct error message");
+okx(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
+ "fail on 5 channels");
+matchx(Imager->errstr, qr/Channels must be positive and <= 4/,
+ "and correct error message");
+
+sub coloreq {
+ my ($left, $right, $comment) = @_;
+
+ my ($rl, $gl, $bl, $al) = $left->rgba;
+ my ($rr, $gr, $br, $ar) = $right->rgba;
+
+ print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
+ okx($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
+ $comment);
+}
+
#!perl -w
use strict;
$|=1;
-print "1..60\n";
+print "1..61\n";
use Imager qw(:all);
require "t/testtools.pl";
i_box_filled($timg, 2, 2, 18, 18, $trans);
if (!i_has_format("gif")) {
- skipn(1, 60, "no gif support");
+ skipn(1, 61, "no gif support");
} else {
open(FH,">testout/t105.gif") || die "Cannot open testout/t105.gif\n";
binmode(FH);
++$num;
}
}
+
+ # try to write an image with no colors - should error
+ ok($num++, !$ooim->write(file=>"testout/t105nocolors.gif",
+ make_colors=>'none',
+ colors=>[], gifquant=>'gen'),
+ "write with no colors");
+
+ # try to write multiple with no colors, with separate maps
+ # I don't see a way to test this, since we don't have a mechanism
+ # to give the second image different quant options, we can't trigger
+ # a failure just for the second image
}
sub ok ($$$) {
+#!perl -w
+use strict;
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
+my $loaded;
-BEGIN { $| = 1; print "1..7\n"; }
+BEGIN { $| = 1; print "1..12\n"; }
END {print "not ok 1\n" unless $loaded;}
use Imager qw(:all);
$loaded = 1;
+require "t/testtools.pl";
+
Imager::init('log'=>'testout/t40scale.log');
print "ok 1\n";
-$img=Imager->new();
+my $img=Imager->new();
-$img->open(file=>'testimg/scale.ppm',type=>'pnm') or print "failed: ",$scaleimg->{ERRSTR},"\n";
+$img->open(file=>'testimg/scale.ppm',type=>'pnm') or print "failed: ",$img->{ERRSTR},"\n";
print "ok 2\n";
-$scaleimg=$img->scale(scalefactor=>0.25) or print "failed: ",$scaleimg->{ERRSTR},"\n";
+my $scaleimg=$img->scale(scalefactor=>0.25) or print "failed: ",$img->{ERRSTR},"\n";
print "ok 3\n";
$scaleimg->write(file=>'testout/t40scale1.ppm',type=>'pnm') or print "failed: ",$scaleimg->{ERRSTR},"\n";
$scaleimg->write(file=>'testout/t40scale2.ppm',type=>'pnm') or print "failed: ",$scaleimg->{ERRSTR},"\n";
print "ok 6\n";
-# check for a warning when scale() is called in void context
-my $warning;
-local $SIG{__WARN__} =
- sub {
- $warning = "@_";
- my $printed = $warning;
- $printed =~ s/\n$//;
- $printed =~ s/\n/\n\#/g;
- print "# ",$printed, "\n";
- };
-$img->scale(scalefactor=>0.25);
-print $warning =~ /void/ ? "ok 7\n" : "not ok 7\n";
+{
+ # check for a warning when scale() is called in void context
+ my $warning;
+ local $SIG{__WARN__} =
+ sub {
+ $warning = "@_";
+ my $printed = $warning;
+ $printed =~ s/\n$//;
+ $printed =~ s/\n/\n\#/g;
+ print "# ",$printed, "\n";
+ };
+ $img->scale(scalefactor=>0.25);
+ print $warning =~ /void/ ? "ok 7\n" : "not ok 7\n";
+ print $warning =~ /t40scale\.t/ ? "ok 8\n" : "not ok 8\n";
+}
+{ # https://rt.cpan.org/Ticket/Display.html?id=7467
+ # segfault in Imager 0.43
+ # make sure scale() doesn't let us make an image zero pixels high or wide
+ # it does this by making the given axis as least 1 pixel high
+ my $out = $img->scale(scalefactor=>0.00001);
+ print $out->getwidth == 1 ? "ok 9\n" : "not ok 9\n";
+ print $out->getheight == 1 ? "ok 10\n" : "not ok 10\n";
+ $out = $img->scale(scalefactor=>0.00001, qtype => 'preview');
+ print $out->getwidth == 1 ? "ok 11\n" : "not ok 11\n";
+ print $out->getheight == 1 ? "ok 12\n" : "not ok 12\n";
+}
}
}
+sub matchn($$$$) {
+ my ($num, $str, $re, $comment) = @_;
+
+ my $match = $str =~ $re;
+ okn($num, $match, $comment);
+ unless ($match) {
+ $str =~ s/\\/\\\\/g;
+ $str =~ s/[^\x20-\x7E]/"\\x".sprintf("%02X", ord($1))/ge;
+ print "# The string '$str'\n";
+ print "# did not match '$re'\n";
+ }
+ return $match;
+}
+
+sub matchx($$$) {
+ my ($str, $re, $comment) = @_;
+
+ matchn($TESTNUM++, $str, $re, $comment);
+}
+
1;
projects / imager.git / commitdiff