]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - TestThreads.pm
f3ebc5d0960f33062af66395fec7c143e9fe0a88
[perl/modules/Variable-Magic.git] / TestThreads.pm
1 package Variable::Magic::TestThreads;
2
3 use strict;
4 use warnings;
5
6 use Config qw<%Config>;
7
8 use Variable::Magic qw<VMG_THREADSAFE>;
9
10 sub skipall {
11  my ($msg) = @_;
12  require Test::More;
13  Test::More::plan(skip_all => $msg);
14 }
15
16 sub diag {
17  require Test::More;
18  Test::More::diag($_) for @_;
19 }
20
21 sub import {
22  shift;
23
24  skipall 'This Variable::Magic isn\'t thread safe' unless VMG_THREADSAFE;
25
26  my $force = $ENV{PERL_VARIABLE_MAGIC_TEST_THREADS} ? 1 : !1;
27  skipall 'This perl wasn\'t built to support threads'
28                                                     unless $Config{useithreads};
29  skipall 'perl 5.13.4 required to test thread safety'
30                                              unless $force or "$]" >= 5.013_004;
31
32  my $t_v = $force ? '0' : '1.67';
33  my $has_threads =  do {
34   local $@;
35   eval "use threads $t_v; 1";
36  };
37  skipall "threads $t_v required to test thread safety" unless $has_threads;
38
39  my $ts_v = $force ? '0' : '1.14';
40  my $has_threads_shared =  do {
41   local $@;
42   eval "use threads::shared $ts_v; 1";
43  };
44  skipall "threads::shared $ts_v required to test thread safety"
45                                                      unless $has_threads_shared;
46
47  defined and diag "Using threads $_"         for $threads::VERSION;
48  defined and diag "Using threads::shared $_" for $threads::shared::VERSION;
49
50  my %exports = (
51   spawn => \&spawn,
52  );
53
54  my $pkg = caller;
55  while (my ($name, $code) = each %exports) {
56   no strict 'refs';
57   *{$pkg.'::'.$name} = $code;
58  }
59 }
60
61 sub spawn {
62  local $@;
63  my @diag;
64  my $thread = eval {
65   local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" };
66   threads->create(@_);
67  };
68  push @diag, "Thread creation error: $@" if $@;
69  diag(@diag) if @diag;
70  return $thread ? $thread : ();
71 }
72
73 1;