r48517 - in /trunk/libimager-perl: ./ debian/ lib/Imager/ lib/Imager/Color/ t/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Thu Dec 10 02:08:47 UTC 2009
Author: jawnsy-guest
Date: Thu Dec 10 02:08:40 2009
New Revision: 48517
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=48517
Log:
New upstream release
Added:
trunk/libimager-perl/flip.im
- copied unchanged from r48514, branches/upstream/libimager-perl/current/flip.im
trunk/libimager-perl/t/t99thread.t
- copied unchanged from r48514, branches/upstream/libimager-perl/current/t/t99thread.t
Modified:
trunk/libimager-perl/Changes
trunk/libimager-perl/Imager.pm
trunk/libimager-perl/Imager.xs
trunk/libimager-perl/MANIFEST
trunk/libimager-perl/META.yml
trunk/libimager-perl/Makefile.PL
trunk/libimager-perl/debian/changelog
trunk/libimager-perl/fills.c
trunk/libimager-perl/image.c
trunk/libimager-perl/imager.h
trunk/libimager-perl/lib/Imager/Color.pm
trunk/libimager-perl/lib/Imager/Color/Float.pm
trunk/libimager-perl/lib/Imager/Draw.pod
trunk/libimager-perl/lib/Imager/Font.pm
trunk/libimager-perl/lib/Imager/LargeSamples.pod
trunk/libimager-perl/lib/Imager/Preprocess.pm
trunk/libimager-perl/lib/Imager/Test.pm
trunk/libimager-perl/lib/Imager/Transformations.pod
trunk/libimager-perl/t/t64copyflip.t
Modified: trunk/libimager-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/Changes?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/Changes (original)
+++ trunk/libimager-perl/Changes Thu Dec 10 02:08:40 2009
@@ -1,4 +1,43 @@
Imager release history. Older releases can be found in Changes.old
+
+Imager 0.72
+===========
+
+Bump version from release, since 0.71_03 is stable with CPAN testers.
+
+Imager 0.71_03 - 5 Dec 2009
+==============
+
+ - further adjust the threads test so it only performs the tests on
+ perls where it's expected to work, and only if the threads module
+ can be loaded.
+
+Imager 0.71_02 - 1 Dec 2009
+==============
+
+ - adjust the way we load the threads module for the threads test so
+ it works with non-threaded perls
+
+Imager 0.71_01 - 30 Nov 2009
+===========
+
+Bug fixes:
+
+ - use scanline oriented operations to flip images instead of pixel
+ operations
+ https://rt.cpan.org/Ticket/Display.html?id=39278
+
+ - use double/sample operations to flip large sample images instead of
+ 8-bit sample operations.
+ https://rt.cpan.org/Ticket/Display.html?id=39280
+
+ - fix POD nits
+ https://rt.cpan.org/Ticket/Display.html?id=51874
+
+ - prevent double-frees when someone creates Imager objects and then
+ creates a thread. Note: this just handles some simple cases,
+ Imager doesn't support perl threads, and isn't likely to.
+ https://rt.cpan.org/Ticket/Display.html?id=52268
Imager 0.71 - 16 Nov 2009
===========
Modified: trunk/libimager-perl/Imager.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/Imager.pm?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/Imager.pm (original)
+++ trunk/libimager-perl/Imager.pm Thu Dec 10 02:08:40 2009
@@ -173,7 +173,7 @@
BEGIN {
require Exporter;
@ISA = qw(Exporter);
- $VERSION = '0.71';
+ $VERSION = '0.72';
eval {
require XSLoader;
XSLoader::load(Imager => $VERSION);
@@ -323,12 +323,18 @@
cd => 1.0,
cs => 40,
n => 1.3,
- Ia => Imager::Color->new(rgb=>[0,0,0]),
- Il => Imager::Color->new(rgb=>[255,255,255]),
- Is => Imager::Color->new(rgb=>[255,255,255]),
+ Ia => [0,0,0],
+ Il => [255,255,255],
+ Is => [255,255,255],
},
callsub => sub {
my %hsh = @_;
+ for my $cname (qw/Ia Il Is/) {
+ my $old = $hsh{$cname};
+ my $new_color = _color($old)
+ or die $Imager::ERRSTR, "\n";
+ $hsh{$cname} = $new_color;
+ }
i_bumpmap_complex($hsh{image}, $hsh{bump}{IMG}, $hsh{channel},
$hsh{tx}, $hsh{ty}, $hsh{Lx}, $hsh{Ly}, $hsh{Lz},
$hsh{cd}, $hsh{cs}, $hsh{n}, $hsh{Ia}, $hsh{Il},
@@ -394,8 +400,8 @@
super_sample => 0, ssample_param => 4,
segments=>[
[ 0, 0.5, 1,
- Imager::Color->new(0,0,0),
- Imager::Color->new(255, 255, 255),
+ [0,0,0],
+ [255, 255, 255],
0, 0,
],
],
@@ -3878,6 +3884,9 @@
return Imager::ExtUtils->inline_config;
}
+# threads shouldn't try to close raw Imager objects
+sub Imager::ImgRaw::CLONE_SKIP { 1 }
+
1;
__END__
# Below is the stub of documentation for your module. You better edit it!
@@ -4441,6 +4450,15 @@
writing an image to a file - L<Imager::Files>
+=head1 THREADS
+
+Imager doesn't support perl threads.
+
+Imager has limited code to prevent double frees if you create images,
+colors etc, and then create a thread, but has no code to prevent two
+threads entering Imager's error handling code, and none is likely to
+be added.
+
=head1 SUPPORT
The best place to get help with Imager is the mailing list.
Modified: trunk/libimager-perl/Imager.xs
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/Imager.xs?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/Imager.xs (original)
+++ trunk/libimager-perl/Imager.xs Thu Dec 10 02:08:40 2009
@@ -873,6 +873,8 @@
myfree(hlines);
}
+#define i_int_hlines_CLONE_SKIP(cls) 1
+
static int seg_compare(const void *vleft, const void *vright) {
const i_int_hline_seg *left = vleft;
const i_int_hline_seg *right = vright;
@@ -1232,6 +1234,13 @@
void
i_io_DESTROY(ig)
Imager::IO ig
+
+int
+i_io_CLONE_SKIP(...)
+ CODE:
+ RETVAL = 1;
+ OUTPUT:
+ RETVAL
MODULE = Imager PACKAGE = Imager
@@ -1868,7 +1877,10 @@
Imager::ImgRaw im1
Imager::ImgRaw im2
-
+double
+i_img_diffd(im1,im2)
+ Imager::ImgRaw im1
+ Imager::ImgRaw im2
undef_int
i_init_fonts(t1log=0)
@@ -2071,6 +2083,13 @@
void
TT_DESTROY(handle)
Imager::Font::TT handle
+
+int
+TT_CLONE_SKIP(...)
+ CODE:
+ RETVAL = 1;
+ OUTPUT:
+ RETVAL
MODULE = Imager PACKAGE = Imager
@@ -4451,6 +4470,13 @@
FT2_DESTROY(font)
Imager::Font::FT2 font
+int
+FT2_CLONE_SKIP(...)
+ CODE:
+ RETVAL = 1;
+ OUTPUT:
+ RETVAL
+
MODULE = Imager PACKAGE = Imager::Font::FreeType2
Imager::Font::FT2
@@ -4785,6 +4811,13 @@
IFILL_DESTROY(fill)
Imager::FillHandle fill
+int
+IFILL_CLONE_SKIP(...)
+ CODE:
+ RETVAL = 1;
+ OUTPUT:
+ RETVAL
+
MODULE = Imager PACKAGE = Imager
Imager::FillHandle
@@ -4910,6 +4943,10 @@
i_int_hlines_dump(hlines)
Imager::Internal::Hlines hlines
+int
+i_int_hlines_CLONE_SKIP(cls)
+ SV *cls
+
#endif
BOOT:
Modified: trunk/libimager-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/MANIFEST?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/MANIFEST (original)
+++ trunk/libimager-perl/MANIFEST Thu Dec 10 02:08:40 2009
@@ -105,6 +105,7 @@
fills.c Generic fills
filterlist.perl
filters.im
+flip.im
font.c
fontfiles/ExistenceTest.afm please edit ExistenceTest.sfd in CVS
fontfiles/ExistenceTest.pfb to change these files, edited and
@@ -280,6 +281,7 @@
t/t92samples.t
t/t93podcover.t POD Coverage tests
t/t94kwalitee.t Various "kwalitee" tests
+t/t99thread.t Test wrt to perl threads
t/tr18561.t Regression tests
t/tr18561b.t
tags.c
Modified: trunk/libimager-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/META.yml?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/META.yml (original)
+++ trunk/libimager-perl/META.yml Thu Dec 10 02:08:40 2009
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Imager
-version: 0.71
+version: 0.72
abstract: Perl extension for Generating 24 bit Images
author:
- Tony Cook <tony at imager.perl.org>, Arnar M. Hrafnkelsson
Modified: trunk/libimager-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/Makefile.PL?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/Makefile.PL (original)
+++ trunk/libimager-perl/Makefile.PL Thu Dec 10 02:08:40 2009
@@ -168,7 +168,7 @@
regmach.o trans2.o quant.o error.o convert.o
map.o tags.o palimg.o maskimg.o img16.o rotate.o
bmp.o tga.o color.o fills.o imgdouble.o limits.o hlines.o
- imext.o scale.o rubthru.o render.o paste.o compose.o);
+ imext.o scale.o rubthru.o render.o paste.o compose.o flip.o);
my %opts=(
'NAME' => 'Imager',
Modified: trunk/libimager-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/debian/changelog?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/debian/changelog (original)
+++ trunk/libimager-perl/debian/changelog Thu Dec 10 02:08:40 2009
@@ -1,3 +1,9 @@
+libimager-perl (0.72-1) UNRELEASED; urgency=low
+
+ * New upstream release
+
+ -- Jonathan Yu <jawnsy at cpan.org> Wed, 09 Dec 2009 17:59:13 -0500
+
libimager-perl (0.71-1) unstable; urgency=low
[ Jonathan Yu ]
Modified: trunk/libimager-perl/fills.c
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/fills.c?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/fills.c (original)
+++ trunk/libimager-perl/fills.c Thu Dec 10 02:08:40 2009
@@ -956,7 +956,7 @@
static void
fill_opacityf(i_fill_t *fill, int x, int y, int width, int channels,
i_fcolor *data) {
- struct i_fill_opacity_t *f = (struct i_fill_alpha_t *)fill;
+ struct i_fill_opacity_t *f = (struct i_fill_opacity_t *)fill;
int alpha_chan = channels-1; /* channels is always 2 or 4 */
i_fcolor *datap = data;
Modified: trunk/libimager-perl/image.c
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/image.c?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/image.c (original)
+++ trunk/libimager-perl/image.c Thu Dec 10 02:08:40 2009
@@ -708,114 +708,6 @@
return im;
}
-
-/*
-=item i_flipxy(im, axis)
-
-Flips the image inplace around the axis specified.
-Returns 0 if parameters are invalid.
-
- im - Image pointer
- axis - 0 = x, 1 = y, 2 = both
-
-=cut
-*/
-
-undef_int
-i_flipxy(i_img *im, int direction) {
- int x, x2, y, y2, xm, ym;
- int xs = im->xsize;
- int ys = im->ysize;
-
- mm_log((1, "i_flipxy(im %p, direction %d)\n", im, direction ));
-
- if (!im) return 0;
-
- switch (direction) {
- case XAXIS: /* Horizontal flip */
- xm = xs/2;
- ym = ys;
- for(y=0; y<ym; y++) {
- x2 = xs-1;
- for(x=0; x<xm; x++) {
- i_color val1, val2;
- i_gpix(im, x, y, &val1);
- i_gpix(im, x2, y, &val2);
- i_ppix(im, x, y, &val2);
- i_ppix(im, x2, y, &val1);
- x2--;
- }
- }
- break;
- case YAXIS: /* Vertical flip */
- xm = xs;
- ym = ys/2;
- y2 = ys-1;
- for(y=0; y<ym; y++) {
- for(x=0; x<xm; x++) {
- i_color val1, val2;
- i_gpix(im, x, y, &val1);
- i_gpix(im, x, y2, &val2);
- i_ppix(im, x, y, &val2);
- i_ppix(im, x, y2, &val1);
- }
- y2--;
- }
- break;
- case XYAXIS: /* Horizontal and Vertical flip */
- xm = xs/2;
- ym = ys/2;
- y2 = ys-1;
- for(y=0; y<ym; y++) {
- x2 = xs-1;
- for(x=0; x<xm; x++) {
- i_color val1, val2;
- i_gpix(im, x, y, &val1);
- i_gpix(im, x2, y2, &val2);
- i_ppix(im, x, y, &val2);
- i_ppix(im, x2, y2, &val1);
-
- i_gpix(im, x2, y, &val1);
- i_gpix(im, x, y2, &val2);
- i_ppix(im, x2, y, &val2);
- i_ppix(im, x, y2, &val1);
- x2--;
- }
- y2--;
- }
- if (xm*2 != xs) { /* odd number of column */
- mm_log((1, "i_flipxy: odd number of columns\n"));
- x = xm;
- y2 = ys-1;
- for(y=0; y<ym; y++) {
- i_color val1, val2;
- i_gpix(im, x, y, &val1);
- i_gpix(im, x, y2, &val2);
- i_ppix(im, x, y, &val2);
- i_ppix(im, x, y2, &val1);
- y2--;
- }
- }
- if (ym*2 != ys) { /* odd number of rows */
- mm_log((1, "i_flipxy: odd number of rows\n"));
- y = ym;
- x2 = xs-1;
- for(x=0; x<xm; x++) {
- i_color val1, val2;
- i_gpix(im, x, y, &val1);
- i_gpix(im, x2, y, &val2);
- i_ppix(im, x, y, &val2);
- i_ppix(im, x2, y, &val1);
- x2--;
- }
- }
- break;
- default:
- mm_log((1, "i_flipxy: direction is invalid\n" ));
- return 0;
- }
- return 1;
-}
@@ -1159,6 +1051,7 @@
=cut
*/
+
float
i_img_diff(i_img *im1,i_img *im2) {
int x,y,ch,xb,yb,chb;
@@ -1181,6 +1074,50 @@
for(ch=0;ch<chb;ch++) tdiff+=(val1.channel[ch]-val2.channel[ch])*(val1.channel[ch]-val2.channel[ch]);
}
mm_log((1,"i_img_diff <- (%.2f)\n",tdiff));
+ return tdiff;
+}
+
+/*
+=item i_img_diffd(im1, im2)
+
+Calculates the sum of the squares of the differences between
+correspoding channels in two images.
+
+If the images are not the same size then only the common area is
+compared, hence even if images are different sizes this function
+can return zero.
+
+This is like i_img_diff() but looks at floating point samples instead.
+
+=cut
+*/
+
+double
+i_img_diffd(i_img *im1,i_img *im2) {
+ int x,y,ch,xb,yb,chb;
+ double tdiff;
+ i_fcolor val1,val2;
+
+ mm_log((1,"i_img_diffd(im1 0x%x,im2 0x%x)\n",im1,im2));
+
+ xb=(im1->xsize<im2->xsize)?im1->xsize:im2->xsize;
+ yb=(im1->ysize<im2->ysize)?im1->ysize:im2->ysize;
+ chb=(im1->channels<im2->channels)?im1->channels:im2->channels;
+
+ mm_log((1,"i_img_diff: xb=%d xy=%d chb=%d\n",xb,yb,chb));
+
+ tdiff=0;
+ for(y=0;y<yb;y++) for(x=0;x<xb;x++) {
+ i_gpixf(im1,x,y,&val1);
+ i_gpixf(im2,x,y,&val2);
+
+ for(ch=0;ch<chb;ch++) {
+ double sdiff = val1.channel[ch]-val2.channel[ch];
+ tdiff += sdiff * sdiff;
+ }
+ }
+ mm_log((1,"i_img_diffd <- (%.2f)\n",tdiff));
+
return tdiff;
}
Modified: trunk/libimager-perl/imager.h
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/imager.h?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/imager.h (original)
+++ trunk/libimager-perl/imager.h Thu Dec 10 02:08:40 2009
@@ -214,6 +214,7 @@
extern void i_map(i_img *im, unsigned char (*maps)[256], unsigned int mask);
float i_img_diff (i_img *im1,i_img *im2);
+double i_img_diffd(i_img *im1,i_img *im2);
/* font routines */
Modified: trunk/libimager-perl/lib/Imager/Color.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/lib/Imager/Color.pm?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/lib/Imager/Color.pm (original)
+++ trunk/libimager-perl/lib/Imager/Color.pm Thu Dec 10 02:08:40 2009
@@ -363,6 +363,8 @@
return 1;
}
+sub CLONE_SKIP { 1 }
+
1;
__END__
Modified: trunk/libimager-perl/lib/Imager/Color/Float.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/lib/Imager/Color/Float.pm?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/lib/Imager/Color/Float.pm (original)
+++ trunk/libimager-perl/lib/Imager/Color/Float.pm Thu Dec 10 02:08:40 2009
@@ -35,6 +35,8 @@
my @arg = _pspec(@_);
return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : ();
}
+
+sub CLONE_SKIP { 1 }
1;
Modified: trunk/libimager-perl/lib/Imager/Draw.pod
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/lib/Imager/Draw.pod?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/lib/Imager/Draw.pod (original)
+++ trunk/libimager-perl/lib/Imager/Draw.pod Thu Dec 10 02:08:40 2009
@@ -927,7 +927,7 @@
=item *
channels - a reference to an array of channels to return, where 0 is
-the first channel. Default: C< [ 0 .. $self->getchannels()-1 ] >
+the first channel. Default: C<< [ 0 .. $self->getchannels()-1 ] >>
=item *
@@ -1013,7 +1013,7 @@
=item *
channels - a reference to an array of channels to return, where 0 is
-the first channel. Default: C< [ 0 .. $self->getchannels()-1 ] >
+the first channel. Default: C<< [ 0 .. $self->getchannels()-1 ] >>
=item *
@@ -1160,6 +1160,6 @@
=head1 REVISION
-$Revision: 1465 $
+$Revision: 1667 $
=cut
Modified: trunk/libimager-perl/lib/Imager/Font.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/lib/Imager/Font.pm?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/lib/Imager/Font.pm (original)
+++ trunk/libimager-perl/lib/Imager/Font.pm Thu Dec 10 02:08:40 2009
@@ -412,7 +412,7 @@
suitcase or a .dfont file.
If any of the C<color>, C<size> or C<aa> parameters are omitted when
-calling C<Imager::Font->new()> the they take the following values:
+calling C<< Imager::Font->new() >> the they take the following values:
color => Imager::Color->new(255, 0, 0, 0); # this default should be changed
size => 15
@@ -987,7 +987,7 @@
=head1 REVISION
-$Revision: 1604 $
+$Revision: 1667 $
=head1 SEE ALSO
Modified: trunk/libimager-perl/lib/Imager/LargeSamples.pod
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/lib/Imager/LargeSamples.pod?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/lib/Imager/LargeSamples.pod (original)
+++ trunk/libimager-perl/lib/Imager/LargeSamples.pod Thu Dec 10 02:08:40 2009
@@ -33,7 +33,7 @@
crop Full
difference Full
filter Partial Depends on the filter.
- flip None
+ flip Full
flood_fill Partial [1]
getpixel Full
getsamples Full
Modified: trunk/libimager-perl/lib/Imager/Preprocess.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/lib/Imager/Preprocess.pm?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/lib/Imager/Preprocess.pm (original)
+++ trunk/libimager-perl/lib/Imager/Preprocess.pm Thu Dec 10 02:08:40 2009
@@ -48,7 +48,7 @@
$code_line = $. + 1;
$save_code = 1;
}
- elsif ($line =~ /^\#\/code$/) {
+ elsif ($line =~ /^\#\/code\s*$/) {
$save_code
or do { warn "$src:$.:#/code without #code\n"; ++$failed; next; };
Modified: trunk/libimager-perl/lib/Imager/Test.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/lib/Imager/Test.pm?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/lib/Imager/Test.pm (original)
+++ trunk/libimager-perl/lib/Imager/Test.pm Thu Dec 10 02:08:40 2009
@@ -18,7 +18,9 @@
is_fcolor4
color_cmp
is_image
- is_image_similar
+ is_imaged
+ is_image_similar
+ isnt_image
image_bounds_checks
mask_tests
test_colorf_gpix
@@ -261,49 +263,65 @@
$img;
}
+sub _low_image_diff_check {
+ my ($left, $right, $comment) = @_;
+
+ my $builder = Test::Builder->new;
+
+ unless (defined $left) {
+ $builder->ok(0, $comment);
+ $builder->diag("left is undef");
+ return;
+ }
+ unless (defined $right) {
+ $builder->ok(0, $comment);
+ $builder->diag("right is undef");
+ return;
+ }
+ unless ($left->{IMG}) {
+ $builder->ok(0, $comment);
+ $builder->diag("left image has no low level object");
+ return;
+ }
+ unless ($right->{IMG}) {
+ $builder->ok(0, $comment);
+ $builder->diag("right image has no low level object");
+ return;
+ }
+ unless ($left->getwidth == $right->getwidth) {
+ $builder->ok(0, $comment);
+ $builder->diag("left width " . $left->getwidth . " vs right width "
+ . $right->getwidth);
+ return;
+ }
+ unless ($left->getheight == $right->getheight) {
+ $builder->ok(0, $comment);
+ $builder->diag("left height " . $left->getheight . " vs right height "
+ . $right->getheight);
+ return;
+ }
+ unless ($left->getchannels == $right->getchannels) {
+ $builder->ok(0, $comment);
+ $builder->diag("left channels " . $left->getchannels . " vs right channels "
+ . $right->getchannels);
+ return;
+ }
+
+ return 1;
+}
+
sub is_image_similar($$$$) {
my ($left, $right, $limit, $comment) = @_;
- my $builder = Test::Builder->new;
-
- unless (defined $left) {
- $builder->ok(0, $comment);
- $builder->diag("left is undef");
- return;
- }
- unless (defined $right) {
- $builder->ok(0, $comment);
- $builder->diag("right is undef");
- return;
- }
- unless ($left->{IMG}) {
- $builder->ok(0, $comment);
- $builder->diag("left image has no low level object");
- return;
- }
- unless ($right->{IMG}) {
- $builder->ok(0, $comment);
- $builder->diag("right image has no low level object");
- return;
- }
- unless ($left->getwidth == $right->getwidth) {
- $builder->ok(0, $comment);
- $builder->diag("left width " . $left->getwidth . " vs right width "
- . $right->getwidth);
- return;
- }
- unless ($left->getheight == $right->getheight) {
- $builder->ok(0, $comment);
- $builder->diag("left height " . $left->getheight . " vs right height "
- . $right->getheight);
- return;
- }
- unless ($left->getchannels == $right->getchannels) {
- $builder->ok(0, $comment);
- $builder->diag("left channels " . $left->getchannels . " vs right channels "
- . $right->getchannels);
- return;
- }
+ {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ _low_image_diff_check($left, $right, $comment)
+ or return;
+ }
+
+ my $builder = Test::Builder->new;
+
my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
if ($diff > $limit) {
$builder->ok(0, $comment);
@@ -336,6 +354,52 @@
local $Test::Builder::Level = $Test::Builder::Level + 1;
return is_image_similar($left, $right, 0, $comment);
+}
+
+sub is_imaged($$$) {
+ my ($left, $right, $comment) = @_;
+
+ {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ _low_image_diff_check($left, $right, $comment)
+ or return;
+ }
+
+ my $builder = Test::Builder->new;
+
+ my $diff = Imager::i_img_diffd($left->{IMG}, $right->{IMG});
+ if ($diff > 0) {
+ $builder->ok(0, $comment);
+ $builder->diag("image data difference: $diff");
+
+ # find the first mismatch
+ PIXELS:
+ for my $y (0 .. $left->getheight()-1) {
+ for my $x (0.. $left->getwidth()-1) {
+ my @lsamples = $left->getsamples(x => $x, y => $y, width => 1);
+ my @rsamples = $right->getsamples(x => $x, y => $y, width => 1);
+ if ("@lsamples" ne "@rsamples") {
+ $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
+ last PIXELS;
+ }
+ }
+ }
+
+ return;
+ }
+
+ return $builder->ok(1, $comment);
+}
+
+sub isnt_image {
+ my ($left, $right, $comment) = @_;
+
+ my $builder = Test::Builder->new;
+
+ my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
+
+ return $builder->ok($diff, "$comment");
}
sub image_bounds_checks {
@@ -554,6 +618,11 @@
color representation such as direct vs paletted, bits per sample are
not checked. Equivalent to is_image_similar($im1, $im2, 0, $comment).
+=item is_imaged($im, $im2, $comment)
+
+Tests if the two images have the same content at the double/sample
+level.
+
=item is_image_similar($im1, $im2, $maxdiff, $comment)
Tests if the 2 images have similar content. Both images must be
Modified: trunk/libimager-perl/lib/Imager/Transformations.pod
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/lib/Imager/Transformations.pod?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/lib/Imager/Transformations.pod (original)
+++ trunk/libimager-perl/lib/Imager/Transformations.pod Thu Dec 10 02:08:40 2009
@@ -570,7 +570,7 @@
the source is treated as if composed onto a black background.
If the source image is color and the target is grayscale, the the
-source is treated as if run through C< convert(preset=>'gray') >.
+source is treated as if run through C<< convert(preset=>'gray') >>.
=item rubthrough
@@ -925,6 +925,6 @@
=head1 REVISION
-$Revision: 1431 $
+$Revision: 1667 $
=cut
Modified: trunk/libimager-perl/t/t64copyflip.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libimager-perl/t/t64copyflip.t?rev=48517&op=diff
==============================================================================
--- trunk/libimager-perl/t/t64copyflip.t (original)
+++ trunk/libimager-perl/t/t64copyflip.t Thu Dec 10 02:08:40 2009
@@ -1,8 +1,8 @@
#!perl -w
use strict;
-use Test::More tests => 65;
+use Test::More tests => 77;
use Imager;
-use Imager::Test qw(is_color3);
+use Imager::Test qw(is_color3 is_image is_imaged test_image_double test_image isnt_image);
#$Imager::DEBUG=1;
@@ -17,27 +17,45 @@
# test if ->copy() works
my $diff = Imager::i_img_diff($img->{IMG}, $nimg->{IMG});
-is($diff, 0, "copy matches source");
-
+is_image($img, $nimg, "copy matches source");
# test if ->flip(dir=>'h')->flip(dir=>'h') doesn't alter the image
-
$nimg->flip(dir=>"h")->flip(dir=>"h");
-$diff = Imager::i_img_diff($img->{IMG}, $nimg->{IMG});
-is($diff, 0, "double horiz flipped matches original");
+is_image($nimg, $img, "double horiz flipped matches original");
# test if ->flip(dir=>'v')->flip(dir=>'v') doesn't alter the image
-
$nimg->flip(dir=>"v")->flip(dir=>"v");
-$diff = Imager::i_img_diff($img->{IMG}, $nimg->{IMG});
-is($diff, 0, "double vertically flipped image matches original");
+is_image($nimg, $img, "double vertically flipped image matches original");
# test if ->flip(dir=>'h')->flip(dir=>'v') is same as ->flip(dir=>'hv')
-
$nimg->flip(dir=>"v")->flip(dir=>"h")->flip(dir=>"hv");;
-$diff = Imager::i_img_diff($img->{IMG}, $nimg->{IMG});
-is($diff, 0, "check flip with hv matches flip v then flip h");
+is_image($img, $nimg, "check flip with hv matches flip v then flip h");
+
+{
+ my $imsrc = test_image_double;
+ my $imcp = $imsrc->copy;
+ is_imaged($imsrc, $imcp, "copy double image");
+ $imcp->flip(dir=>"v")->flip(dir=>"v");
+ is_imaged($imsrc, $imcp, "flip v twice");
+ $imcp->flip(dir=>"h")->flip(dir=>"h");
+ is_imaged($imsrc, $imcp, "flip h twice");
+ $imcp->flip(dir=>"h")->flip(dir=>"v")->flip(dir=>"hv");
+ is_imaged($imsrc, $imcp, "flip h,v,hv twice");
+}
+
+{
+ my $impal = test_image()->to_paletted;
+ my $imcp = $impal->copy;
+ is($impal->type, "paletted", "check paletted test image is");
+ is($imcp->type, "paletted", "check copy test image is paletted");
+ ok($impal->flip(dir => "h"), "flip paletted h");
+ isnt_image($impal, $imcp, "check it changed");
+ ok($impal->flip(dir => "v"), "flip paletted v");
+ ok($impal->flip(dir => "hv"), "flip paletted hv");
+ is_image($impal, $imcp, "should be back to original image");
+ is($impal->type, "paletted", "and still paletted");
+}
rot_test($img, 90, 4);
rot_test($img, 180, 2);
More information about the Pkg-perl-cvs-commits
mailing list