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 $INC{"Devel/Cover.pm"}
  28   and plan skip_all => "threads and Devel::Cover don't get along";
  29
  30 plan tests => 11;
  31
  32 my $thread = threads->create(sub { 1; });
  33 ok($thread->join, "join first thread");
  34
  35 # these are all, or contain, XS allocated objects, if we don't
  36 # probably handle CLONE requests, or provide a CLONE_SKIP, we'll
  37 # probably see a double-free, one from the thread, and the other from
  38 # the main line of control.
  39 # So make one of each
  40
  41 my $im = Imager->new(xsize => 10, ysize => 10);
  42 my $c = Imager::Color->new(0, 0, 0); # make some sort of color
  43 ok($c, "made the color");
  44 my $cf = Imager::Color::Float->new(0, 0, 0);
  45 ok($cf, "made the float color");
  46 my $hl;
  47 SKIP:
  48 {
  49   Imager::Internal::Hlines::testing()
  50       or skip "no hlines visible to test", 1;
  51   $hl = Imager::Internal::Hlines::new(0, 100, 0, 100);
  52   ok($hl, "made the hlines");
  53 }
  54 my $io = Imager::io_new_bufchain();
  55 ok($io, "made the io");
  56 my $tt;
  57 SKIP:
  58 {
  59   $Imager::formats{tt}
  60     or skip("No TT font support", 1);
  61   $tt = Imager::Font->new(type => "tt", file => "fontfiles/dodge.ttf");
  62   ok($tt, "made the font");
  63 }
  64 my $ft2;
  65 SKIP:
  66 {
  67   $Imager::formats{ft2}
  68     or skip "No FT2 support", 1;
  69   $ft2 = Imager::Font->new(type => "ft2", file => "fontfiles/dodge.ttf");
  70   ok($ft2, "made ft2 font");
  71 }
  72 my $fill = Imager::Fill->new(solid => $c);
  73 ok($fill, "made the fill");
  74
  75 my $t2 = threads->create
  76   (
  77    sub {
  78      ok(!UNIVERSAL::isa($im->{IMG}, "Imager::ImgRaw"),
  79         "the low level image object should be undef");
  80      1;
  81    }
  82   );
  83 ok($t2->join, "join second thread");
  84 #print STDERR $im->{IMG}, "\n";
  85 ok(UNIVERSAL::isa($im->{IMG}, "Imager::ImgRaw"),
  86    "but the object should be fine in the main thread");
  87