r75495 - in /branches/upstream/libimager-perl/current: ./ T1/ TIFF/t/ lib/Imager/ t/
periapt-guest at users.alioth.debian.org
periapt-guest at users.alioth.debian.org
Sun Jun 12 13:06:59 UTC 2011
Author: periapt-guest
Date: Sun Jun 12 13:06:52 2011
New Revision: 75495
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=75495
Log:
[svn-upgrade] new version libimager-perl (0.83+dfsg)
Added:
branches/upstream/libimager-perl/current/T1/README
branches/upstream/libimager-perl/current/t/t62compose.t
Modified:
branches/upstream/libimager-perl/current/Changes
branches/upstream/libimager-perl/current/Imager.pm
branches/upstream/libimager-perl/current/Imager.xs
branches/upstream/libimager-perl/current/MANIFEST
branches/upstream/libimager-perl/current/MANIFEST.SKIP
branches/upstream/libimager-perl/current/META.yml
branches/upstream/libimager-perl/current/T1/T1.pm
branches/upstream/libimager-perl/current/TIFF/t/t10tiff.t
branches/upstream/libimager-perl/current/compose.im
branches/upstream/libimager-perl/current/draw.c
branches/upstream/libimager-perl/current/image.c
branches/upstream/libimager-perl/current/imager.h
branches/upstream/libimager-perl/current/lib/Imager/LargeSamples.pod
branches/upstream/libimager-perl/current/lib/Imager/Preprocess.pm
branches/upstream/libimager-perl/current/lib/Imager/Test.pm
Modified: branches/upstream/libimager-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/Changes?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/Changes (original)
+++ branches/upstream/libimager-perl/current/Changes Sun Jun 12 13:06:52 2011
@@ -1,4 +1,34 @@
Imager release history. Older releases can be found in Changes.old
+
+Imager 0.83 - 21 May 2011
+===========
+
+Bug fixes:
+
+ - diag() the error message on failure for some TIFF tests that are
+ failing on a Solaris smoker.
+ http://www.cpantesters.org/cpan/report/6396db1e-8090-11e0-9682-112b785ebe45
+
+Imager 0.82_01 - 17 May 2011
+==============
+
+Dev release, in case the compose tests are too sensitive.
+
+Bug fixes:
+
+ - Imager::Font::T1 incorrectly checked for absolute filename under
+ Win32. Thanks to kmx for the report and fix.
+ https://rt.cpan.org/Ticket/Display.html?id=67963
+
+ - compose() with the target, source or mask position off the top or
+ left of the target image didn't clip the source image correctly.
+ https://rt.cpan.org/Ticket/Display.html?id=67220
+
+ - compose() now returns a useful error message on a non-positive
+ opacity.
+
+ - compose.im now at 100% test coverage. (As opposed to, umm, much,
+ much less.)
Imager 0.82 - 14 Mar 2011
===========
Modified: branches/upstream/libimager-perl/current/Imager.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/Imager.pm?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/Imager.pm (original)
+++ branches/upstream/libimager-perl/current/Imager.pm Sun Jun 12 13:06:52 2011
@@ -146,7 +146,7 @@
BEGIN {
require Exporter;
@ISA = qw(Exporter);
- $VERSION = '0.82';
+ $VERSION = '0.83';
eval {
require XSLoader;
XSLoader::load(Imager => $VERSION);
@@ -2501,16 +2501,20 @@
defined $mask_top or $mask_top = $opts{mask_miny};
defined $mask_top or $mask_top = 0;
- i_compose_mask($self->{IMG}, $src->{IMG}, $opts{mask}{IMG},
+ unless (i_compose_mask($self->{IMG}, $src->{IMG}, $opts{mask}{IMG},
$left, $top, $src_left, $src_top,
$mask_left, $mask_top, $width, $height,
- $combine, $opts{opacity})
- or return;
+ $combine, $opts{opacity})) {
+ $self->_set_error(Imager->_error_as_msg);
+ return;
+ }
}
else {
- i_compose($self->{IMG}, $src->{IMG}, $left, $top, $src_left, $src_top,
- $width, $height, $combine, $opts{opacity})
- or return;
+ unless (i_compose($self->{IMG}, $src->{IMG}, $left, $top, $src_left, $src_top,
+ $width, $height, $combine, $opts{opacity})) {
+ $self->_set_error(Imager->_error_as_msg);
+ return;
+ }
}
return $self;
@@ -2681,7 +2685,12 @@
$color = i_color_new(255,255,255,255);
}
- i_box_filled($raw, $xmin, $ymin,$xmax, $ymax, $color);
+ if ($color->isa("Imager::Color")) {
+ i_box_filled($raw, $xmin, $ymin,$xmax, $ymax, $color);
+ }
+ else {
+ i_box_filledf($raw, $xmin, $ymin,$xmax, $ymax, $color);
+ }
}
elsif ($opts{fill}) {
unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
Modified: branches/upstream/libimager-perl/current/Imager.xs
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/Imager.xs?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/Imager.xs (original)
+++ branches/upstream/libimager-perl/current/Imager.xs Sun Jun 12 13:06:52 2011
@@ -20,6 +20,7 @@
#include "regmach.h"
#include "imextdef.h"
#include "imextpltypes.h"
+#include <float.h>
#if i_int_hlines_testing()
#include "imageri.h"
@@ -954,6 +955,8 @@
#define i_img_get_width(im) ((im)->xsize)
#define i_img_get_height(im) ((im)->ysize)
+#define i_img_epsilonf() (DBL_EPSILON * 4)
+
MODULE = Imager PACKAGE = Imager::Color PREFIX = ICL_
Imager::Color
@@ -1449,6 +1452,15 @@
int x2
int y2
Imager::Color val
+
+int
+i_box_filledf(im,x1,y1,x2,y2,val)
+ Imager::ImgRaw im
+ int x1
+ int y1
+ int x2
+ int y2
+ Imager::Color::Float val
void
i_box_cfill(im,x1,y1,x2,y2,fill)
@@ -2001,6 +2013,16 @@
i_img_diffd(im1,im2)
Imager::ImgRaw im1
Imager::ImgRaw im2
+
+int
+i_img_samef(im1, im2, epsilon = i_img_epsilonf(), what=NULL)
+ Imager::ImgRaw im1
+ Imager::ImgRaw im2
+ double epsilon
+ const char *what
+
+double
+i_img_epsilonf()
bool
_is_color_object(sv)
Modified: branches/upstream/libimager-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/MANIFEST?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/MANIFEST (original)
+++ branches/upstream/libimager-perl/current/MANIFEST Sun Jun 12 13:06:52 2011
@@ -306,6 +306,7 @@
t/t58trans2.t
t/t59assem.t
t/t61filters.t
+t/t62compose.t
t/t63combine.t Test combine() method
t/t64copyflip.t Test copy, flip, rotate, matrix_transform
t/t65crop.t
@@ -335,6 +336,7 @@
T1/imt1.c
T1/imt1.h
T1/Makefile.PL
+T1/README
T1/t/t10type1.t
T1/t/t20oo.t
T1/T1.pm
Modified: branches/upstream/libimager-perl/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/MANIFEST.SKIP?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/MANIFEST.SKIP (original)
+++ branches/upstream/libimager-perl/current/MANIFEST.SKIP Sun Jun 12 13:06:52 2011
@@ -78,6 +78,7 @@
^T1/T1\.c$
^.*/Changes$
+^.*/MANIFEST(\.SKIP)?$
^blib/
^Flines/Flines\.c$
^Imager\.c$
Modified: branches/upstream/libimager-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/META.yml?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/META.yml (original)
+++ branches/upstream/libimager-perl/current/META.yml Sun Jun 12 13:06:52 2011
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Imager
-version: 0.82
+version: 0.83
abstract: Perl extension for Generating 24 bit Images
author:
- Tony Cook <tony at imager.perl.org>, Arnar M. Hrafnkelsson
Added: branches/upstream/libimager-perl/current/T1/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/T1/README?rev=75495&op=file
==============================================================================
--- branches/upstream/libimager-perl/current/T1/README (added)
+++ branches/upstream/libimager-perl/current/T1/README Sun Jun 12 13:06:52 2011
@@ -1,0 +1,4 @@
+This module provides Type 1 font support for Imager via T1Lib.
+
+ http://imager.perl.org/
+ http://www.t1lib.org/
Modified: branches/upstream/libimager-perl/current/T1/T1.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/T1/T1.pm?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/T1/T1.pm (original)
+++ branches/upstream/libimager-perl/current/T1/T1.pm Sun Jun 12 13:06:52 2011
@@ -5,7 +5,7 @@
@ISA = qw(Imager::Font);
BEGIN {
- $VERSION = "1.011";
+ $VERSION = "1.012";
eval {
require XSLoader;
@@ -54,7 +54,7 @@
# we want to avoid T1Lib's file search mechanism
unless ($hsh{file} =~ m!^/!
|| $hsh{file} =~ m!^\.\/?/!
- || $^O =~ /^(MSWin32|cygwin)$/ && $hsh{file} =~ /^[a-z]:/) {
+ || $^O =~ /^(MSWin32|cygwin)$/ && $hsh{file} =~ /^[a-z]:/i) {
$hsh{file} = './' . $hsh{file};
}
@@ -65,7 +65,7 @@
}
unless ($hsh{afm} =~ m!^/!
|| $hsh{afm} =~ m!^\./!
- || $^O =~ /^(MSWin32|cygwin)$/ && $hsh{file} =~ /^[a-z]:/) {
+ || $^O =~ /^(MSWin32|cygwin)$/ && $hsh{file} =~ /^[a-z]:/i) {
$hsh{file} = './' . $hsh{file};
}
} else {
Modified: branches/upstream/libimager-perl/current/TIFF/t/t10tiff.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/TIFF/t/t10tiff.t?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/TIFF/t/t10tiff.t (original)
+++ branches/upstream/libimager-perl/current/TIFF/t/t10tiff.t Sun Jun 12 13:06:52 2011
@@ -309,17 +309,21 @@
# correctly on read
@imgs = map $ooim->copy(), 1..40;
$rc = Imager->write_multi({file=>'testout/t106_multi2.tif'}, @imgs);
-ok($rc, "writing 40 images to tiff");
+ok($rc, "writing 40 images to tiff")
+ or diag("writing 40 images: " . Imager->errstr);
@out = Imager->read_multi(file=>'testout/t106_multi2.tif');
-ok(@imgs == @out, "reading 40 images from tiff");
+ok(@imgs == @out, "reading 40 images from tiff")
+ or diag("reading 40 images:" . Imager->errstr);
# force some allocation activity - helps crash here if it's the problem
@out = @imgs = ();
# multi-image fax files
ok(Imager->write_multi({file=>'testout/t106_faxmulti.tiff', class=>'fax'},
- $oofim, $oofim), "write multi fax image");
+ $oofim, $oofim), "write multi fax image")
+ or diag("writing 40 fax pages: " . Imager->errstr);
@imgs = Imager->read_multi(file=>'testout/t106_faxmulti.tiff');
-ok(@imgs == 2, "reading multipage fax");
+ok(@imgs == 2, "reading multipage fax")
+ or diag("reading 40 fax pages: " . Imager->errstr);
ok(Imager::i_img_diff($imgs[0]{IMG}, $oofim->{IMG}) == 0,
"compare first fax image");
ok(Imager::i_img_diff($imgs[1]{IMG}, $oofim->{IMG}) == 0,
Modified: branches/upstream/libimager-perl/current/compose.im
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/compose.im?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/compose.im (original)
+++ branches/upstream/libimager-perl/current/compose.im Sun Jun 12 13:06:52 2011
@@ -15,6 +15,11 @@
i_fill_combine_f combinef_8;
i_fill_combinef_f combinef_double;
int channel_zero = 0;
+
+ mm_log((1, "i_compose_mask(out %p, src %p, mask %p, out(%d, %d), src(%d, %d),"
+ " mask(%d,%d), size(%d,%d), combine %d opacity %f\n", out, src,
+ mask, out_left, out_top, src_left, src_top, mask_left, mask_top, width,
+ height, combine, opacity));
i_clear_error();
if (out_left >= out->xsize
@@ -35,6 +40,8 @@
if (out_left < 0) {
width = out_left + width;
+ src_left -= out_left;
+ mask_left -= out_left;
out_left = 0;
}
if (out_left + width > out->xsize)
@@ -42,6 +49,8 @@
if (out_top < 0) {
height = out_top + height;
+ mask_top -= out_top;
+ src_top -= out_top;
out_top = 0;
}
if (out_top + height > out->ysize)
@@ -49,6 +58,8 @@
if (src_left < 0) {
width = src_left + width;
+ out_left -= src_left;
+ mask_left -= src_left;
src_left = 0;
}
if (src_left + width > src->xsize)
@@ -56,29 +67,42 @@
if (src_top < 0) {
height = src_top + height;
+ out_top -= src_top;
+ mask_top -= src_top;
src_top = 0;
}
if (src_top + height > src->ysize)
- height = src->ysize - src_left;
+ height = src->ysize - src_top;
if (mask_left < 0) {
width = mask_left + width;
+ out_left -= mask_left;
+ src_left -= mask_left;
mask_left = 0;
}
if (mask_left + width > mask->xsize)
width = mask->xsize - mask_left;
if (mask_top < 0) {
- height = mask->ysize + height;
+ height = mask_top + height;
+ src_top -= mask_top;
+ out_top -= mask_top;
mask_top = 0;
}
if (mask_top + height > mask->ysize)
- height = mask->xsize - mask_top;
+ height = mask->ysize - mask_top;
if (opacity > 1.0)
opacity = 1.0;
- else if (opacity <= 0)
- return 0;
+ else if (opacity <= 0) {
+ i_push_error(0, "opacity must be positive");
+ return 0;
+ }
+
+ mm_log((1, "after adjustments: (out(%d, %d), src(%d, %d),"
+ " mask(%d,%d), size(%d,%d)\n",
+ out_left, out_top, src_left, src_top, mask_left, mask_top, width,
+ height));
i_get_combine(combine, &combinef_8, &combinef_double);
@@ -128,6 +152,10 @@
i_fill_combine_f combinef_8;
i_fill_combinef_f combinef_double;
+ mm_log((1, "i_compose(out %p, src %p, out(%d, %d), src(%d, %d), size(%d,%d),"
+ " combine %d opacity %f\n", out, src, out_left, out_top,
+ src_left, src_top, width, height, combine, opacity));
+
i_clear_error();
if (out_left >= out->xsize
|| out_top >= out->ysize
@@ -143,6 +171,7 @@
if (out_left < 0) {
width = out_left + width;
+ src_left -= out_left;
out_left = 0;
}
if (out_left + width > out->xsize)
@@ -150,6 +179,7 @@
if (out_top < 0) {
height = out_top + height;
+ src_top -= out_top;
out_top = 0;
}
if (out_top + height > out->ysize)
@@ -157,6 +187,7 @@
if (src_left < 0) {
width = src_left + width;
+ out_left -= src_left;
src_left = 0;
}
if (src_left + width > src->xsize)
@@ -164,15 +195,18 @@
if (src_top < 0) {
height = src_top + height;
+ out_top -= src_top;
src_top = 0;
}
if (src_top + height > src->ysize)
- height = src->ysize - src_left;
+ height = src->ysize - src_top;
if (opacity > 1.0)
opacity = 1.0;
- else if (opacity <= 0)
- return 0;
+ else if (opacity <= 0) {
+ i_push_error(0, "opacity must be positive");
+ return 0;
+ }
i_get_combine(combine, &combinef_8, &combinef_double);
Modified: branches/upstream/libimager-perl/current/draw.c
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/draw.c?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/draw.c (original)
+++ branches/upstream/libimager-perl/current/draw.c Sun Jun 12 13:06:52 2011
@@ -1123,6 +1123,65 @@
}
/*
+=item i_box_filledf(im, x1, y1, x2, y2, color)
+
+=category Drawing
+=synopsis i_box_filledf(im, 0, 0, im->xsize-1, im->ysize-1, &fcolor);
+
+Fills the box from (x1,y1) to (x2,y2) inclusive with a floating point
+color.
+
+=cut
+*/
+
+int
+i_box_filledf(i_img *im,int x1,int y1,int x2,int y2, const i_fcolor *val) {
+ i_img_dim x, y, width;
+ i_palidx index;
+
+ mm_log((1,"i_box_filledf(im* 0x%x,x1 %d,y1 %d,x2 %d,y2 %d,val 0x%x)\n",im,x1,y1,x2,y2,val));
+
+ if (x1 > x2 || y1 > y2
+ || x2 < 0 || y2 < 0
+ || x1 >= im->xsize || y1 > im->ysize)
+ return 0;
+
+ if (x1 < 0)
+ x1 = 0;
+ if (x2 >= im->xsize)
+ x2 = im->xsize - 1;
+ if (y1 < 0)
+ y1 = 0;
+ if (y2 >= im->ysize)
+ y2 = im->ysize - 1;
+
+ width = x2 - x1 + 1;
+
+ if (im->bits <= 8) {
+ i_color c;
+ c.rgba.r = SampleFTo8(val->rgba.r);
+ c.rgba.g = SampleFTo8(val->rgba.g);
+ c.rgba.b = SampleFTo8(val->rgba.b);
+ c.rgba.a = SampleFTo8(val->rgba.a);
+
+ i_box_filled(im, x1, y1, x2, y2, &c);
+ }
+ else {
+ i_fcolor *line = mymalloc(sizeof(i_fcolor) * width);
+
+ for (x = 0; x < width; ++x)
+ line[x] = *val;
+
+ for (y = y1; y <= y2; ++y)
+ i_plinf(im, x1, x2+1, y, line);
+
+ myfree(line);
+ }
+
+ return 1;
+}
+
+/*
=item i_box_cfill(im, x1, y1, x2, y2, fill)
=category Drawing
Modified: branches/upstream/libimager-perl/current/image.c
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/image.c?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/image.c (original)
+++ branches/upstream/libimager-perl/current/image.c Sun Jun 12 13:06:52 2011
@@ -1165,7 +1165,7 @@
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));
+ mm_log((1,"i_img_diffd: xb=%d xy=%d chb=%d\n",xb,yb,chb));
tdiff=0;
for(y=0;y<yb;y++) for(x=0;x<xb;x++) {
@@ -1180,6 +1180,41 @@
mm_log((1,"i_img_diffd <- (%.2f)\n",tdiff));
return tdiff;
+}
+
+int
+i_img_samef(i_img *im1,i_img *im2, double epsilon, char const *what) {
+ int x,y,ch,xb,yb,chb;
+ i_fcolor val1,val2;
+
+ if (what == NULL)
+ what = "(null)";
+
+ mm_log((1,"i_img_samef(im1 0x%x,im2 0x%x, epsilon %g, what '%s')\n", im1, im2, epsilon, what));
+
+ 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_samef: xb=%d xy=%d chb=%d\n",xb,yb,chb));
+
+ 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];
+ if (fabs(sdiff) > epsilon) {
+ mm_log((1,"i_img_samef <- different %g @(%d,%d)\n", sdiff, x, y));
+ return 0;
+ }
+ }
+ }
+ }
+ mm_log((1,"i_img_samef <- same\n"));
+
+ return 1;
}
/* just a tiny demo of haar wavelets */
Modified: branches/upstream/libimager-perl/current/imager.h
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/imager.h?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/imager.h (original)
+++ branches/upstream/libimager-perl/current/imager.h Sun Jun 12 13:06:52 2011
@@ -164,6 +164,7 @@
void i_box (i_img *im,int x1,int y1,int x2,int y2,const i_color *val);
void i_box_filled (i_img *im,int x1,int y1,int x2,int y2,const i_color *val);
+int i_box_filledf (i_img *im,int x1,int y1,int x2,int y2,const i_fcolor *val);
void i_box_cfill(i_img *im, int x1, int y1, int x2, int y2, i_fill_t *fill);
void i_line (i_img *im,int x1,int y1,int x2,int y2,const i_color *val, int endp);
void i_line_aa (i_img *im,int x1,int y1,int x2,int y2,const i_color *val, int endp);
@@ -222,6 +223,7 @@
float i_img_diff (i_img *im1,i_img *im2);
double i_img_diffd(i_img *im1,i_img *im2);
+int i_img_samef(i_img *im1,i_img *im2, double epsilon, const char *what);
/* font routines */
Modified: branches/upstream/libimager-perl/current/lib/Imager/LargeSamples.pod
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/lib/Imager/LargeSamples.pod?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/lib/Imager/LargeSamples.pod (original)
+++ branches/upstream/libimager-perl/current/lib/Imager/LargeSamples.pod Sun Jun 12 13:06:52 2011
@@ -26,7 +26,7 @@
Method Support Notes
------ ------- -----
arc Partial [1]
- box Partial [1]
+ box Partial [2]
circle Partial [1]
convert Full
copy Full
@@ -63,6 +63,9 @@
[1] filling an area using the fill parameter works at the full depth
of the image, using filled => 1 and color works at 8-bits/sample
+
+[2] box() will fill the area at the supplied color, but outline at
+8-bits/sample.
=head1 File format large sample support
Modified: branches/upstream/libimager-perl/current/lib/Imager/Preprocess.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/lib/Imager/Preprocess.pm?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/lib/Imager/Preprocess.pm (original)
+++ branches/upstream/libimager-perl/current/lib/Imager/Preprocess.pm Sun Jun 12 13:06:52 2011
@@ -2,14 +2,22 @@
use strict;
require Exporter;
use vars qw(@ISA @EXPORT $VERSION);
+use Getopt::Long;
+use Text::ParseWords;
@EXPORT = qw(preprocess);
@ISA = qw(Exporter);
$VERSION = "1.000";
-
sub preprocess {
+ unshift @ARGV, grep /^-/, shellwords($ENV{IMAGER_PREPROCESS_OPTS})
+ if $ENV{IMAGER_PREPROCESS_OPTS};
+ my $skip_lines = 0;
+ GetOptions("l" => \$skip_lines)
+ or usage();
+ my $keep_lines = !$skip_lines;
+
my $src = shift @ARGV;
my $dest = shift @ARGV
or usage();
@@ -29,8 +37,8 @@
"#define IM_ROUND_8(x) ((int)((x)+0.5))\n",
"#define IM_ROUND_double(x) (x)\n",
"#define IM_LIMIT_8(x) ((x) < 0 ? 0 : (x) > 255 ? 255 : (x))\n",
- "#define IM_LIMIT_double(x) ((x) < 0.0 ? 0.0 : (x) > 1.0 ? 1.0 : (x))\n",
- "#line 1 \"$src\"\n";
+ "#define IM_LIMIT_double(x) ((x) < 0.0 ? 0.0 : (x) > 1.0 ? 1.0 : (x))\n";
+ push @out, "#line 1 \"$src\"\n" if $keep_lines;
while (defined(my $line = <SRC>)) {
if ($line =~ /^\#code\s+(\S.+)$/) {
$save_code
@@ -55,7 +63,7 @@
or do { warn "$src:$.:#/code without #code\n"; ++$failed; next; };
if ($cond) {
- push @out, "#line $cond_line \"$src\"\n";
+ push @out, "#line $cond_line \"$src\"\n" if $keep_lines;
push @out, " if ($cond) {\n";
}
push @out,
@@ -65,7 +73,7 @@
"#define IM_FILL_COMBINE(fill) ((fill)->combine)\n",
"#undef IM_FILL_FILLER\n",
"#define IM_FILL_FILLER(fill) ((fill)->f_fill_with_color)\n";
- push @out, "#line $code_line \"$src\"\n";
+ push @out, "#line $code_line \"$src\"\n" if $keep_lines;
push @out, byte_samples(@code);
push @out, " }\n", " else {\n"
if $cond;
@@ -75,11 +83,11 @@
"#define IM_FILL_COMBINE(fill) ((fill)->combinef)\n",
"#undef IM_FILL_FILLER\n",
"#define IM_FILL_FILLER(fill) ((fill)->f_fill_with_fcolor)\n";
- push @out, "#line $code_line \"$src\"\n";
+ push @out, "#line $code_line \"$src\"\n" if $keep_lines;
push @out, double_samples(@code);
push @out, " }\n"
if $cond;
- push @out, "#line ",$.+1," \"$src\"\n";
+ push @out, "#line ",$.+1," \"$src\"\n" if $keep_lines;
@code = ();
$save_code = 0;
}
@@ -163,6 +171,17 @@
@lines;
}
+sub usage {
+ die <<EOS;
+Usage: perl -MImager::Preprocess -epreprocess [-l] infile outfile
+ -l don't produce #line directives
+ infile - input file
+ outfile output file
+
+See perldoc Imager::Preprocess for details.
+EOS
+}
+
1;
__END__
@@ -180,7 +199,11 @@
... code using preprocessor types/values ...
#/code
- perl -MImager -epreprocess foo.im foo.c
+ # process and make #line directives
+ perl -MImager::Preprocess -epreprocess foo.im foo.c
+
+ # process and no #line directives
+ perl -MImager::Preprocess -epreprocess -l foo.im foo.c
=head1 DESCRIPTION
Modified: branches/upstream/libimager-perl/current/lib/Imager/Test.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/lib/Imager/Test.pm?rev=75495&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/lib/Imager/Test.pm (original)
+++ branches/upstream/libimager-perl/current/lib/Imager/Test.pm Sun Jun 12 13:06:52 2011
@@ -436,6 +436,11 @@
}
sub is_imaged($$$) {
+ my $epsilon = Imager::i_img_epsilonf();
+ if (@_ > 3) {
+ ($epsilon) = splice @_, 2, 1;
+ }
+
my ($left, $right, $comment) = @_;
{
@@ -447,17 +452,17 @@
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");
-
+ my $same = Imager::i_img_samef($left->{IMG}, $right->{IMG}, $epsilon, $comment);
+ if (!$same) {
+ $builder->ok(0, $comment);
+ $builder->diag("images different");
+
# 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);
+ my @lsamples = $left->getsamples(x => $x, y => $y, width => 1, type => "float");
+ my @rsamples = $right->getsamples(x => $x, y => $y, width => 1, type => "float");
if ("@lsamples" ne "@rsamples") {
$builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
last PIXELS;
@@ -732,8 +737,11 @@
=item is_imaged($im, $im2, $comment)
+=item is_imaged($im, $im2, $epsilon, $comment)
+
Tests if the two images have the same content at the double/sample
-level.
+level. C<$epsilon> defaults to the platform DBL_EPSILON multiplied by
+four.
=item is_image_similar($im1, $im2, $maxdiff, $comment)
Added: branches/upstream/libimager-perl/current/t/t62compose.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/t/t62compose.t?rev=75495&op=file
==============================================================================
--- branches/upstream/libimager-perl/current/t/t62compose.t (added)
+++ branches/upstream/libimager-perl/current/t/t62compose.t Sun Jun 12 13:06:52 2011
@@ -1,0 +1,254 @@
+#!perl -w
+use strict;
+use Imager qw(:handy);
+use Test::More tests => 114;
+use Imager::Test qw(is_image is_imaged);
+
+-d "testout" or mkdir "testout";
+
+Imager::init_log("testout/t62compose.log", 1);
+
+my @files;
+
+my %types =
+ (
+ double =>
+ {
+ blue => NCF(0, 0, 1),
+ red => NCF(1, 0, 0),
+ green2 => NCF(0, 1, 0, 0.5),
+ green2_on_blue => NCF(0, 0.5, 0.5),
+ red3_on_blue => NCF(1/3, 0, 2/3),
+ green6_on_blue => NCF(0, 1/6, 5/6),
+ red2_on_blue => NCF(0.5, 0, 0.5),
+ green4_on_blue => NCF(0, 0.25, 0.75),
+ gray100 => NCF(1.0, 0, 0),
+ gray50 => NCF(0.5, 0, 0),
+ is_image => \&is_imaged,
+ },
+ 8 =>
+ {
+ blue => NC(0, 0, 255),
+ red => NC(255, 0, 0),
+ green2 => NC(0, 255, 0, 128),
+ green2_on_blue => NC(0, 128, 127),
+ red3_on_blue => NC(85, 0, 170),
+ green6_on_blue => NC(0, 42, 213),
+ red2_on_blue => NC(128, 0, 127),
+ green4_on_blue => NC(0, 64, 191),
+ gray100 => NC(255, 0, 0),
+ gray50 => NC(128, 0, 0),
+ is_image => \&is_image,
+ },
+ );
+
+for my $type_id (sort keys %types) {
+ my $type = $types{$type_id};
+ my $blue = $type->{blue};
+ my $red = $type->{red};
+ my $green2 = $type->{green2};
+ my $green2_on_blue = $type->{green2_on_blue};
+ my $red3_on_blue = $type->{red3_on_blue};
+ my $green6_on_blue = $type->{green6_on_blue};
+ my $red2_on_blue = $type->{red2_on_blue};
+ my $green4_on_blue = $type->{green4_on_blue};
+ my $gray100 = $type->{gray100};
+ my $gray50 = $type->{gray50};
+ my $is_image = $type->{is_image};
+
+ print "# type $type_id\n";
+ my $targ = Imager->new(xsize => 100, ysize => 100, bits => $type_id);
+ $targ->box(color => $blue, filled => 1);
+ is($targ->type, "direct", "check target image type");
+ is($targ->bits, $type_id, "check target bits");
+
+ my $src = Imager->new(xsize => 40, ysize => 40, channels => 4, bits => $type_id);
+ $src->box(filled => 1, color => $red, xmax => 19, ymax => 19);
+ $src->box(filled => 1, xmin => 20, color => $green2);
+ save_to($src, "${type_id}_src");
+
+ my $mask_ones = Imager->new(channels => 1, xsize => 40, ysize => 40, bits => $type_id);
+ $mask_ones->box(filled => 1, color => NC(255, 255, 255));
+
+
+ # mask or full mask, should be the same
+ for my $mask_info ([ "nomask" ], [ "fullmask", mask => $mask_ones ]) {
+ my ($mask_type, @mask_extras) = @$mask_info;
+ print "# $mask_type\n";
+ {
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin=> 5, ymin => 10, xmax => 24, ymax => 29);
+ $cmp->box(filled => 1, color => $green2_on_blue,
+ xmin => 25, ymin => 10, xmax => 44, ymax => 49);
+ {
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 5, ty => 10, @mask_extras),
+ "$mask_type - simple compose");
+ $is_image->($work, $cmp, "check match");
+ save_to($work, "${type_id}_${mask_type}_simple");
+ }
+ { # >1 opacity
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 5, ty => 10, opacity => 2.0, @mask_extras),
+ "$mask_type - compose with opacity > 1.0 acts like opacity=1.0");
+ $is_image->($work, $cmp, "check match");
+ }
+ { # 0 opacity is a failure
+ my $work = $targ->copy;
+ ok(!$work->compose(src => $src, tx => 5, ty => 10, opacity => 0.0, @mask_extras),
+ "$mask_type - compose with opacity = 0 is an error");
+ is($work->errstr, "opacity must be positive", "check message");
+ }
+ }
+ { # compose at 1/3
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 7, ty => 33, opacity => 1/3, @mask_extras),
+ "$mask_type - simple compose at 1/3");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red3_on_blue,
+ xmin => 7, ymin => 33, xmax => 26, ymax => 52);
+ $cmp->box(filled => 1, color => $green6_on_blue,
+ xmin => 27, ymin => 33, xmax => 46, ymax => 72);
+ $is_image->($work, $cmp, "check match");
+ }
+ { # targ off top left
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => -5, ty => -3, @mask_extras),
+ "$mask_type - compose off top left");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin=> 0, ymin => 0, xmax => 14, ymax => 16);
+ $cmp->box(filled => 1, color => $green2_on_blue,
+ xmin => 15, ymin => 0, xmax => 34, ymax => 36);
+ $is_image->($work, $cmp, "check match");
+ }
+ { # targ off bottom right
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 65, ty => 67, @mask_extras),
+ "$mask_type - targ off bottom right");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin=> 65, ymin => 67, xmax => 84, ymax => 86);
+ $cmp->box(filled => 1, color => $green2_on_blue,
+ xmin => 85, ymin => 67, xmax => 99, ymax => 99);
+ $is_image->($work, $cmp, "check match");
+ }
+ { # src off top left
+ my $work = $targ->copy;
+ my @more_mask_extras;
+ if (@mask_extras) {
+ push @more_mask_extras,
+ (
+ mask_left => -5,
+ mask_top => -15,
+ );
+ }
+ ok($work->compose(src => $src, tx => 10, ty => 20,
+ src_left => -5, src_top => -15,
+ @mask_extras, @more_mask_extras),
+ "$mask_type - source off top left");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin=> 15, ymin => 35, xmax => 34, ymax => 54);
+ $cmp->box(filled => 1, color => $green2_on_blue,
+ xmin => 35, ymin => 35, xmax => 54, ymax => 74);
+ $is_image->($work, $cmp, "check match");
+ }
+ {
+ # src off bottom right
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 10, ty => 20,
+ src_left => 10, src_top => 15,
+ width => 40, height => 40, @mask_extras),
+ "$mask_type - source off bottom right");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin=> 10, ymin => 20, xmax => 19, ymax => 24);
+ $cmp->box(filled => 1, color => $green2_on_blue,
+ xmin => 20, ymin => 20, xmax => 39, ymax => 44);
+ $is_image->($work, $cmp, "check match");
+ }
+ {
+ # simply out of bounds
+ my $work = $targ->copy;
+ ok(!$work->compose(src => $src, tx => 100, @mask_extras),
+ "$mask_type - off the right of the target");
+ $is_image->($work, $targ, "no changes");
+ ok(!$work->compose(src => $src, ty => 100, @mask_extras),
+ "$mask_type - off the bottom of the target");
+ $is_image->($work, $targ, "no changes");
+ ok(!$work->compose(src => $src, tx => -40, @mask_extras),
+ "$mask_type - off the left of the target");
+ $is_image->($work, $targ, "no changes");
+ ok(!$work->compose(src => $src, ty => -40, @mask_extras),
+ "$mask_type - off the top of the target");
+ $is_image->($work, $targ, "no changes");
+ }
+ }
+
+ # masked tests
+ my $mask = Imager->new(xsize => 40, ysize => 40, channels => 1, bits => $type_id);
+ $mask->box(filled => 1, xmax => 19, color => $gray100);
+ $mask->box(filled => 1, xmin => 20, ymax => 14, xmax => 34,
+ color => $gray50);
+ is($mask->bits, $type_id, "check mask bits");
+ {
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 5, ty => 7,
+ mask => $mask),
+ "simple draw masked");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin => 5, ymin => 7, xmax => 24, ymax => 26);
+ $cmp->box(filled => 1, color => $green4_on_blue,
+ xmin => 25, ymin => 7, xmax => 39, ymax => 21);
+ $is_image->($work, $cmp, "check match");
+ save_to($work, "${type_id}_simp_masked");
+ save_to($work, "${type_id}_simp_masked_cmp");
+ }
+ {
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 5, ty => 7,
+ mask_left => 5, mask_top => 2,
+ mask => $mask),
+ "draw with mask offset");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin => 5, ymin => 7, xmax => 19, ymax => 26);
+ $cmp->box(filled => 1, color => $red2_on_blue,
+ xmin => 20, ymin => 7, xmax => 24, ymax => 19);
+ $cmp->box(filled => 1, color => $green4_on_blue,
+ xmin => 25, ymin => 7, xmax => 34, ymax => 19);
+ $is_image->($work, $cmp, "check match");
+ }
+ {
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 5, ty => 7,
+ mask_left => -3, mask_top => -2,
+ mask => $mask),
+ "draw with negative mask offsets");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin => 8, ymin => 9, xmax => 24, ymax => 26);
+ $cmp->box(filled => 1, color => $green2_on_blue,
+ xmin => 25, ymin => 9, xmax => 27, ymax => 46);
+ $cmp->box(filled => 1, color => $green4_on_blue,
+ xmin => 28, ymin => 9, xmax => 42, ymax => 23);
+ $is_image->($work, $cmp, "check match");
+ }
+}
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink @files;
+}
+
+sub save_to {
+ my ($im, $name) = @_;
+
+ my $type = $ENV{IMAGER_SAVE_TYPE} || "ppm";
+ $name = "testout/t62_$name.$type";
+ $im->write(file => $name,
+ pnm_write_wide_data => 1);
+ push @files, $name;
+}
More information about the Pkg-perl-cvs-commits
mailing list