t/t99thread.t

   1 #!perl
   2 use strict;
   3 use Imager;
   4 use Imager::Color::Float;
   5 use Imager::Fill;
   6 use Config;
   7 my $loaded_threads;
   8 BEGIN {
   9   if ($Config{useithreads} && $] > 5.008007) {
  10     $loaded_threads =
  11       eval {
  12         require threads;
  13         threads->import;
  14         1;
  15       };
  16   }
  17 }
  18 use Test::More;
  19
  20 $Config{useithreads}
  21   or plan skip_all => "can't test Imager's lack of threads support with no threads";
  22 $] > 5.008007
  23   or plan skip_all => "require a perl with CLONE_SKIP to test Imager's lack of threads support";
  24 $loaded_threads
  25   or plan skip_all => "couldn't load threads";
  26
  27 plan tests => 11;
  28
  29 my $thread = threads->create(sub { 1; });
  30 ok($thread->join, "join first thread");
  31
  32 # these are all, or contain, XS allocated objects, if we don't
  33 # probably handle CLONE requests, or provide a CLONE_SKIP, we'll
  34 # probably see a double-free, one from the thread, and the other from
  35 # the main line of control.
  36 # So make one of each
  37
  38 my $im = Imager->new(xsize => 10, ysize => 10);
  39 my $c = Imager::Color->new(0, 0, 0); # make some sort of color
  40 ok($c, "made the color");
  41 my $cf = Imager::Color::Float->new(0, 0, 0);
  42 ok($cf, "made the float color");
  43 my $hl;
  44 SKIP:
  45 {
  46   Imager::Internal::Hlines::testing()
  47       or skip "no hlines visible to test", 1;
  48   $hl = Imager::Internal::Hlines::new(0, 100, 0, 100);
  49   ok($hl, "made the hlines");
  50 }
  51 my $io = Imager::io_new_bufchain();
  52 ok($io, "made the io");
  53 my $tt;
  54 SKIP:
  55 {
  56   $Imager::formats{tt}
  57     or skip("No TT font support", 1);
  58   $tt = Imager::Font->new(type => "tt", file => "fontfiles/dodge.ttf");
  59   ok($tt, "made the font");
  60 }
  61 my $ft2;
  62 SKIP:
  63 {
  64   $Imager::formats{ft2}
  65     or skip "No FT2 support", 1;
  66   $ft2 = Imager::Font->new(type => "ft2", file => "fontfiles/dodge.ttf");
  67   ok($ft2, "made ft2 font");
  68 }
  69 my $fill = Imager::Fill->new(solid => $c);
  70 ok($fill, "made the fill");
  71
  72 my $t2 = threads->create
  73   (
  74    sub {
  75      ok(!UNIVERSAL::isa($im->{IMG}, "Imager::ImgRaw"),
  76         "the low level image object should be undef");
  77      1;
  78    }
  79   );
  80 ok($t2->join, "join second thread");
  81 #print STDERR $im->{IMG}, "\n";
  82 ok(UNIVERSAL::isa($im->{IMG}, "Imager::ImgRaw"),
  83    "but the object should be fine in the main thread");
  84