prevent double frees when Imager is loaded when threads are created

diff --git a/Changes b/Changes
index ebb0e267fb43128493ff474cdc41b03225b5eb24..45a802de808cd5af70158f50680920d0b72f3882 100644 (file)
--- a/Changes
+++ b/Changes
@@ -16,6 +16,11 @@ Bug fixes:
  - 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
 ===========
 

diff --git a/Imager.pm b/Imager.pm
index 7bab122ba24a4d87ce3d729359898ab4da9bbcdf..a628713530690ec08bfe85d064d95cb9266b2d56 100644 (file)
--- a/Imager.pm
+++ b/Imager.pm
@@ -323,12 +323,18 @@ BEGIN {
                  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 @@ BEGIN {
                    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 @@ sub Inline {
   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 @@ watermark - L<Imager::Filters/watermark>
 
 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.

diff --git a/Imager.xs b/Imager.xs
index f6733ed68dbbd8541def9bf5d7dfca64de901ec8..080be4e5365617f0c71e535639a34a4108e9d7e5 100644 (file)
--- a/Imager.xs
+++ b/Imager.xs
@@ -873,6 +873,8 @@ i_int_hlines_DESTROY(i_int_hlines *hlines) {
   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;
@@ -1233,6 +1235,13 @@ void
 i_io_DESTROY(ig)
         Imager::IO     ig
 
+int
+i_io_CLONE_SKIP(...)
+    CODE:
+       RETVAL = 1;
+    OUTPUT:
+       RETVAL
+
 MODULE = Imager                PACKAGE = Imager
 
 PROTOTYPES: ENABLE
@@ -2075,6 +2084,13 @@ void
 TT_DESTROY(handle)
      Imager::Font::TT   handle
 
+int
+TT_CLONE_SKIP(...)
+    CODE:
+        RETVAL = 1;
+    OUTPUT:
+        RETVAL
+
 
 MODULE = Imager         PACKAGE = Imager
 
@@ -4454,6 +4470,13 @@ void
 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
@@ -4788,6 +4811,13 @@ void
 IFILL_DESTROY(fill)
         Imager::FillHandle fill
 
+int
+IFILL_CLONE_SKIP(...)
+    CODE:
+        RETVAL = 1;
+    OUTPUT:
+        RETVAL
+
 MODULE = Imager         PACKAGE = Imager
 
 Imager::FillHandle
@@ -4913,6 +4943,10 @@ SV *
 i_int_hlines_dump(hlines)
        Imager::Internal::Hlines hlines
 
+int
+i_int_hlines_CLONE_SKIP(cls)
+       SV *cls
+
 #endif
 
 BOOT:

diff --git a/lib/Imager/Color.pm b/lib/Imager/Color.pm
index 0d2d19fafec0055b93e11471e040a64e23a2bc13..b22f29fba30c8d7e91829fe19405f20d4c44d3e3 100644 (file)
--- a/lib/Imager/Color.pm
+++ b/lib/Imager/Color.pm
@@ -363,6 +363,8 @@ sub equals {
   return 1;
 }
 
+sub CLONE_SKIP { 1 }
+
 1;
 
 __END__

diff --git a/lib/Imager/Color/Float.pm b/lib/Imager/Color/Float.pm
index f13c98bedfbbf1fbd087aa03f9e73da7996a2c96..01d15bafd37862c6491390bcfe4848d3b9bfa5e3 100644 (file)
--- a/lib/Imager/Color/Float.pm
+++ b/lib/Imager/Color/Float.pm
@@ -36,6 +36,8 @@ sub set {
   return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : ();
 }
 
+sub CLONE_SKIP { 1 }
+
 1;
 
 __END__

diff --git a/t/t99thread.t b/t/t99thread.t
new file mode 100644 (file)
index 0000000..b9ddbec
--- /dev/null
+++ b/t/t99thread.t
@@ -0,0 +1,70 @@
+#!perl
+use strict;
+use Imager;
+use Imager::Color::Float;
+use Imager::Fill;
+use threads;
+use Config;
+use Test::More;
+
+$Config{useithreads}
+  or plan skip_all => "can't test Imager's lack of threads support with no 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");
+