#!perl use strict; use Imager; use Imager::Color::Float; use Imager::Fill; use Config; my $loaded_threads; BEGIN { if ($Config{useithreads} && $] > 5.008007) { $loaded_threads = eval { require threads; threads->import; 1; }; } } use Test::More; $Config{useithreads} or plan skip_all => "can't test Imager's threads support with no threads"; $] > 5.008007 or plan skip_all => "require a perl with CLONE_SKIP to test Imager's threads support"; $loaded_threads or plan skip_all => "couldn't load threads"; $INC{"Devel/Cover.pm"} and plan skip_all => "threads and Devel::Cover don't get along"; # https://rt.cpan.org/Ticket/Display.html?id=65812 # https://github.com/schwern/test-more/issues/labels/Test-Builder2#issue/100 $Test::More::VERSION =~ /^2\.00_/ and plan skip_all => "threads are hosed in 2.00_06 and presumably all 2.00_*"; plan tests => 13; my $thread = threads->create(sub { 1; }); ok($thread->join, "join first thread"); # these are all, or contain, XS allocated objects, if we don't 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 become unblessed"); ok(!$im->_valid_image, "image no longer considered valid"); is($im->errstr, "images do not cross threads", "check error message"); 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");