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