t/850-thread/010-base.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 threads support with no threads";
  22 $] > 5.008007
  23   or plan skip_all => "require a perl with CLONE_SKIP to test Imager's 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 => 13;
  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 handle
  41 # CLONE requests, or provide a CLONE_SKIP, we'll probably see a
  42 # double-free, one from the thread, and the other from the main line
  43 # of control.
  44 #
  45 # So make one of each
  46
  47 my $im = Imager->new(xsize => 10, ysize => 10);
  48 my $c = Imager::Color->new(0, 0, 0); # make some sort of color
  49 ok($c, "made the color");
  50 my $cf = Imager::Color::Float->new(0, 0, 0);
  51 ok($cf, "made the float color");
  52 my $hl;
  53 SKIP:
  54 {
  55   Imager::Internal::Hlines::testing()
  56       or skip "no hlines visible to test", 1;
  57   $hl = Imager::Internal::Hlines::new(0, 100, 0, 100);
  58   ok($hl, "made the hlines");
  59 }
  60 my $io = Imager::io_new_bufchain();
  61 ok($io, "made the io");
  62 my $tt;
  63 SKIP:
  64 {
  65   $Imager::formats{tt}
  66     or skip("No TT font support", 1);
  67   $tt = Imager::Font->new(type => "tt", file => "fontfiles/dodge.ttf");
  68   ok($tt, "made the font");
  69 }
  70 my $ft2;
  71 SKIP:
  72 {
  73   $Imager::formats{ft2}
  74     or skip "No FT2 support", 1;
  75   $ft2 = Imager::Font->new(type => "ft2", file => "fontfiles/dodge.ttf");
  76   ok($ft2, "made ft2 font");
  77 }
  78 my $fill = Imager::Fill->new(solid => $c);
  79 ok($fill, "made the fill");
  80
  81 my $t2 = threads->create
  82   (
  83    sub {
  84      ok(!UNIVERSAL::isa($im->{IMG}, "Imager::ImgRaw"),
  85         "the low level image object should become unblessed");
  86      ok(!$im->_valid_image, "image no longer considered valid");
  87      is($im->errstr, "images do not cross threads",
  88         "check error message");
  89      1;
  90    }
  91   );
  92 ok($t2->join, "join second thread");
  93 #print STDERR $im->{IMG}, "\n";
  94 ok(UNIVERSAL::isa($im->{IMG}, "Imager::ImgRaw"),
  95    "but the object should be fine in the main thread");
  96