r48512 - in /branches/upstream/libimager-perl/current: ./ lib/Imager/ lib/Imager/Color/ t/

jawnsy-guest at users.alioth.debian.org jawnsy-guest at users.alioth.debian.org
Thu Dec 10 02:07:06 UTC 2009


Author: jawnsy-guest
Date: Thu Dec 10 02:06:43 2009
New Revision: 48512

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=48512
Log:
[svn-upgrade] Integrating new upstream version, libimager-perl (0.72)

Added:
    branches/upstream/libimager-perl/current/flip.im
    branches/upstream/libimager-perl/current/t/t99thread.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/META.yml
    branches/upstream/libimager-perl/current/Makefile.PL
    branches/upstream/libimager-perl/current/fills.c
    branches/upstream/libimager-perl/current/image.c
    branches/upstream/libimager-perl/current/imager.h
    branches/upstream/libimager-perl/current/lib/Imager/Color.pm
    branches/upstream/libimager-perl/current/lib/Imager/Color/Float.pm
    branches/upstream/libimager-perl/current/lib/Imager/Draw.pod
    branches/upstream/libimager-perl/current/lib/Imager/Font.pm
    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
    branches/upstream/libimager-perl/current/lib/Imager/Transformations.pod
    branches/upstream/libimager-perl/current/t/t64copyflip.t

Modified: branches/upstream/libimager-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/Changes?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/Changes (original)
+++ branches/upstream/libimager-perl/current/Changes Thu Dec 10 02:06:43 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: branches/upstream/libimager-perl/current/Imager.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/Imager.pm?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/Imager.pm (original)
+++ branches/upstream/libimager-perl/current/Imager.pm Thu Dec 10 02:06:43 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: branches/upstream/libimager-perl/current/Imager.xs
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/Imager.xs?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/Imager.xs (original)
+++ branches/upstream/libimager-perl/current/Imager.xs Thu Dec 10 02:06:43 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: branches/upstream/libimager-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/MANIFEST?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/MANIFEST (original)
+++ branches/upstream/libimager-perl/current/MANIFEST Thu Dec 10 02:06:43 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: branches/upstream/libimager-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/META.yml?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/META.yml (original)
+++ branches/upstream/libimager-perl/current/META.yml Thu Dec 10 02:06:43 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: branches/upstream/libimager-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/Makefile.PL?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/Makefile.PL (original)
+++ branches/upstream/libimager-perl/current/Makefile.PL Thu Dec 10 02:06:43 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: branches/upstream/libimager-perl/current/fills.c
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/fills.c?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/fills.c (original)
+++ branches/upstream/libimager-perl/current/fills.c Thu Dec 10 02:06:43 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;
   

Added: branches/upstream/libimager-perl/current/flip.im
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/flip.im?rev=48512&op=file
==============================================================================
--- branches/upstream/libimager-perl/current/flip.im (added)
+++ branches/upstream/libimager-perl/current/flip.im Thu Dec 10 02:06:43 2009
@@ -1,0 +1,192 @@
+#include "imager.h"
+
+static void flip_h(i_img *im);
+static void flip_v(i_img *im);
+static void flip_hv(i_img *im);
+
+#define XAXIS 0
+#define YAXIS 1
+#define XYAXIS 2
+
+/*
+=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) {
+  i_clear_error();
+
+  mm_log((1, "i_flipxy(im %p, direction %d)\n", im, direction ));
+
+  if (!im)
+    return 0;
+
+  switch (direction) {
+  case XAXIS: /* Horizontal flip */
+    flip_h(im);
+    break;
+
+  case YAXIS: /* Vertical flip */
+    flip_v(im);
+    break;
+
+  case XYAXIS: /* Horizontal and Vertical flip */
+    flip_hv(im);
+    break;
+
+  default:
+    mm_log((1, "i_flipxy: direction is invalid\n" ));
+    i_push_errorf(0, "direction %d invalid", direction);
+    return 0;
+
+  }
+  return 1;
+}
+
+static void
+flip_row_pal(i_palidx *row, i_img_dim width) {
+  i_palidx tmp;
+  i_palidx *leftp = row;
+  i_palidx *rightp = row + width - 1;
+  
+  while (leftp < rightp) {
+    tmp = *leftp;
+    *leftp = *rightp;
+    *rightp = tmp;
+    ++leftp;
+    --rightp;
+  }
+}
+
+#code
+
+static void
+IM_SUFFIX(flip_row)(IM_COLOR *row, i_img_dim width) {
+  IM_COLOR tmp;
+  IM_COLOR *leftp = row;
+  IM_COLOR *rightp = row + width - 1;
+  
+  while (leftp < rightp) {
+    tmp = *leftp;
+    *leftp = *rightp;
+    *rightp = tmp;
+    ++leftp;
+    --rightp;
+  }
+}
+
+#/code
+
+static void
+flip_h(i_img *im) {
+  int y;
+  if (im->type == i_palette_type) {
+    i_palidx *line = mymalloc(im->xsize * sizeof(i_palidx));
+    for (y = 0; y < im->ysize; ++y) {
+      i_gpal(im, 0, im->xsize, y, line);
+      flip_row_pal(line, im->xsize);
+      i_ppal(im, 0, im->xsize, y, line);
+    }
+    myfree(line);
+  }
+  else {
+#code im->bits == i_8_bits
+    IM_COLOR *line = mymalloc(im->xsize * sizeof(IM_COLOR));
+    for (y = 0; y < im->ysize; ++y) {
+      IM_GLIN(im, 0, im->xsize, y, line);
+      IM_SUFFIX(flip_row)(line, im->xsize);
+      IM_PLIN(im, 0, im->xsize, y, line);
+    }
+    myfree(line);
+#/code
+  }
+}
+
+static void
+flip_v(i_img *im) {
+  int topy = 0;
+  int boty = im->ysize - 1;
+  if (im->type == i_palette_type) {
+    i_palidx *top_line = mymalloc(im->xsize * sizeof(i_palidx));
+    i_palidx *bot_line = mymalloc(im->xsize * sizeof(i_palidx));
+    while (topy < boty) {
+      i_gpal(im, 0, im->xsize, topy, top_line);
+      i_gpal(im, 0, im->xsize, boty, bot_line);
+      i_ppal(im, 0, im->xsize, topy, bot_line);
+      i_ppal(im, 0, im->xsize, boty, top_line);
+      ++topy;
+      --boty;
+    }
+    myfree(bot_line);
+    myfree(top_line);
+  }
+  else {
+#code im->bits == i_8_bits
+    IM_COLOR *top_line = mymalloc(im->xsize * sizeof(IM_COLOR));
+    IM_COLOR *bot_line = mymalloc(im->xsize * sizeof(IM_COLOR));
+    while (topy < boty) {
+      IM_GLIN(im, 0, im->xsize, topy, top_line);
+      IM_GLIN(im, 0, im->xsize, boty, bot_line);
+      IM_PLIN(im, 0, im->xsize, topy, bot_line);
+      IM_PLIN(im, 0, im->xsize, boty, top_line);
+      ++topy;
+      --boty;
+    }
+    myfree(top_line);
+    myfree(bot_line);
+#/code 
+  }
+}
+
+static void
+flip_hv(i_img *im) {
+  int topy = 0;
+  int boty = im->ysize - 1;
+  if (im->type == i_palette_type) {
+    i_palidx *top_line = mymalloc(im->xsize * sizeof(i_palidx));
+    i_palidx *bot_line = mymalloc(im->xsize * sizeof(i_palidx));
+    while (topy < boty) {
+      i_gpal(im, 0, im->xsize, topy, top_line);
+      i_gpal(im, 0, im->xsize, boty, bot_line);
+      flip_row_pal(top_line, im->xsize);
+      flip_row_pal(bot_line, im->xsize);
+      i_ppal(im, 0, im->xsize, topy, bot_line);
+      i_ppal(im, 0, im->xsize, boty, top_line);
+      ++topy;
+      --boty;
+    }
+    myfree(bot_line);
+    myfree(top_line);
+  }
+  else {
+#code im->bits == i_8_bits
+    IM_COLOR *top_line = mymalloc(im->xsize * sizeof(IM_COLOR));
+    IM_COLOR *bot_line = mymalloc(im->xsize * sizeof(IM_COLOR));
+    while (topy < boty) {
+      IM_GLIN(im, 0, im->xsize, topy, top_line);
+      IM_GLIN(im, 0, im->xsize, boty, bot_line);
+      IM_SUFFIX(flip_row)(top_line, im->xsize);
+      IM_SUFFIX(flip_row)(bot_line, im->xsize);
+      IM_PLIN(im, 0, im->xsize, topy, bot_line);
+      IM_PLIN(im, 0, im->xsize, boty, top_line);
+      ++topy;
+      --boty;
+    }
+    if (topy == boty) {
+      IM_GLIN(im, 0, im->xsize, topy, top_line);
+      IM_SUFFIX(flip_row)(top_line, im->xsize);
+      IM_PLIN(im, 0, im->xsize, topy, top_line);
+    }
+    myfree(top_line);
+    myfree(bot_line);
+#/code 
+  }
+}

Modified: branches/upstream/libimager-perl/current/image.c
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/image.c?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/image.c (original)
+++ branches/upstream/libimager-perl/current/image.c Thu Dec 10 02:06:43 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: branches/upstream/libimager-perl/current/imager.h
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/imager.h?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/imager.h (original)
+++ branches/upstream/libimager-perl/current/imager.h Thu Dec 10 02:06:43 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: branches/upstream/libimager-perl/current/lib/Imager/Color.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/lib/Imager/Color.pm?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/lib/Imager/Color.pm (original)
+++ branches/upstream/libimager-perl/current/lib/Imager/Color.pm Thu Dec 10 02:06:43 2009
@@ -363,6 +363,8 @@
   return 1;
 }
 
+sub CLONE_SKIP { 1 }
+
 1;
 
 __END__

Modified: branches/upstream/libimager-perl/current/lib/Imager/Color/Float.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/lib/Imager/Color/Float.pm?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/lib/Imager/Color/Float.pm (original)
+++ branches/upstream/libimager-perl/current/lib/Imager/Color/Float.pm Thu Dec 10 02:06:43 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: branches/upstream/libimager-perl/current/lib/Imager/Draw.pod
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/lib/Imager/Draw.pod?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/lib/Imager/Draw.pod (original)
+++ branches/upstream/libimager-perl/current/lib/Imager/Draw.pod Thu Dec 10 02:06:43 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: branches/upstream/libimager-perl/current/lib/Imager/Font.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/lib/Imager/Font.pm?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/lib/Imager/Font.pm (original)
+++ branches/upstream/libimager-perl/current/lib/Imager/Font.pm Thu Dec 10 02:06:43 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: 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=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/lib/Imager/LargeSamples.pod (original)
+++ branches/upstream/libimager-perl/current/lib/Imager/LargeSamples.pod Thu Dec 10 02:06:43 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: 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=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/lib/Imager/Preprocess.pm (original)
+++ branches/upstream/libimager-perl/current/lib/Imager/Preprocess.pm Thu Dec 10 02:06:43 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: 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=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/lib/Imager/Test.pm (original)
+++ branches/upstream/libimager-perl/current/lib/Imager/Test.pm Thu Dec 10 02:06:43 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: branches/upstream/libimager-perl/current/lib/Imager/Transformations.pod
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/lib/Imager/Transformations.pod?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/lib/Imager/Transformations.pod (original)
+++ branches/upstream/libimager-perl/current/lib/Imager/Transformations.pod Thu Dec 10 02:06:43 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: branches/upstream/libimager-perl/current/t/t64copyflip.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/t/t64copyflip.t?rev=48512&op=diff
==============================================================================
--- branches/upstream/libimager-perl/current/t/t64copyflip.t (original)
+++ branches/upstream/libimager-perl/current/t/t64copyflip.t Thu Dec 10 02:06:43 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);

Added: branches/upstream/libimager-perl/current/t/t99thread.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libimager-perl/current/t/t99thread.t?rev=48512&op=file
==============================================================================
--- branches/upstream/libimager-perl/current/t/t99thread.t (added)
+++ branches/upstream/libimager-perl/current/t/t99thread.t Thu Dec 10 02:06:43 2009
@@ -1,0 +1,84 @@
+#!perl
+use strict;
+use Imager;
+use Imager::Color::Float;
+use Imager::Fill;
+use Config;
+my $loaded_threads;
+BEGIN {
+  if ($Config{useithreads} && $] > 5.008007) {
+    $loaded_threads =
+      eval {
+	require threads;
+	threads->import;
+	1;
+      };
+  }
+}
+use Test::More;
+
+$Config{useithreads}
+  or plan skip_all => "can't test Imager's lack of threads support with no threads";
+$] > 5.008007
+  or plan skip_all => "require a perl with CLONE_SKIP to test Imager's lack of threads support";
+$loaded_threads
+  or plan skip_all => "couldn't load threads";
+
+plan tests => 11;
+
+my $thread = threads->create(sub { 1; });
+ok($thread->join, "join first thread");
+
+# these are all, or contain, XS allocated objects, if we don't
+# probably handle CLONE requests, or provide a CLONE_SKIP, we'll
+# probably see a double-free, one from the thread, and the other from
+# the main line of control.
+# So make one of each
+
+my $im = Imager->new(xsize => 10, ysize => 10);
+my $c = Imager::Color->new(0, 0, 0); # make some sort of color
+ok($c, "made the color");
+my $cf = Imager::Color::Float->new(0, 0, 0);
+ok($cf, "made the float color");
+my $hl;
+SKIP:
+{
+  Imager::Internal::Hlines::testing()
+      or skip "no hlines visible to test", 1;
+  $hl = Imager::Internal::Hlines::new(0, 100, 0, 100);
+  ok($hl, "made the hlines");
+}
+my $io = Imager::io_new_bufchain();
+ok($io, "made the io");
+my $tt;
+SKIP:
+{
+  $Imager::formats{tt}
+    or skip("No TT font support", 1);
+  $tt = Imager::Font->new(type => "tt", file => "fontfiles/dodge.ttf");
+  ok($tt, "made the font");
+}
+my $ft2;
+SKIP:
+{
+  $Imager::formats{ft2}
+    or skip "No FT2 support", 1;
+  $ft2 = Imager::Font->new(type => "ft2", file => "fontfiles/dodge.ttf");
+  ok($ft2, "made ft2 font");
+}
+my $fill = Imager::Fill->new(solid => $c);
+ok($fill, "made the fill");
+
+my $t2 = threads->create
+  (
+   sub {
+     ok(!UNIVERSAL::isa($im->{IMG}, "Imager::ImgRaw"),
+	"the low level image object should be undef");
+     1;
+   }
+  );
+ok($t2->join, "join second thread");
+#print STDERR $im->{IMG}, "\n";
+ok(UNIVERSAL::isa($im->{IMG}, "Imager::ImgRaw"),
+   "but the object should be fine in the main thread");
+




More information about the Pkg-perl-cvs-commits mailing list