ext/threads/t/problems.t

   1 use strict;
   2 use warnings;
   3
   4 BEGIN {
   5     if ($ENV{'PERL_CORE'}){
   6         chdir 't';
   7         unshift @INC, '../lib';
   8     }
   9     use Config;
  10     if (! $Config{'useithreads'}) {
  11         print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
  12         exit(0);
  13     }
  14 }
  15
  16 use ExtUtils::testlib;
  17
  18 use threads;
  19
  20 BEGIN {
  21     eval {
  22         require threads::shared;
  23         import threads::shared;
  24     };
  25     if ($@ || ! $threads::shared::threads_shared) {
  26         print("1..0 # Skip: threads::shared not available\n");
  27         exit(0);
  28     }
  29
  30     $| = 1;
  31     if ($] == 5.008) {
  32         print("1..11\n");   ### Number of tests that will be run ###
  33     } else {
  34         print("1..15\n");   ### Number of tests that will be run ###
  35     }
  36 };
  37
  38 print("ok 1 - Loaded\n");
  39
  40 ### Start of Testing ###
  41
  42 no warnings 'deprecated';       # Suppress warnings related to :unique
  43
  44 use Hash::Util 'lock_keys';
  45
  46 my $test :shared = 2;
  47
  48 # Note that we can't use Test::More here, as we would need to call is()
  49 # from within the DESTROY() function at global destruction time, and
  50 # parts of Test::* may have already been freed by then
  51 sub is($$$)
  52 {
  53     my ($got, $want, $desc) = @_;
  54     lock($test);
  55     if ($got ne $want) {
  56         print("# EXPECTED: $want\n");
  57         print("# GOT:      $got\n");
  58         print("not ");
  59     }
  60     print("ok $test - $desc\n");
  61     $test++;
  62 }
  63
  64
  65 # This tests for too much destruction which was caused by cloning stashes
  66 # on join which led to double the dataspace under 5.8.0
  67 if ($] != 5.008)
  68 {
  69     sub Foo::DESTROY
  70     {
  71         my $self = shift;
  72         my ($package, $file, $line) = caller;
  73         is(threads->tid(), $self->{tid}, "In destroy[$self->{tid}] it should be correct too" );
  74     }
  75
  76     my $foo = bless {tid => 0}, 'Foo';
  77     my $bar = threads->create(sub {
  78         is(threads->tid(), 1, "And tid be 1 here");
  79         $foo->{tid} = 1;
  80         return ($foo);
  81     })->join();
  82     $bar->{tid} = 0;
  83 }
  84
  85
  86 # This tests whether we can call Config::myconfig after threads have been
  87 # started (interpreter cloned).  5.8.1 and 5.8.2 contained a bug that would
  88 # disallow that to be done because an attempt was made to change a variable
  89 # with the :unique attribute.
  90
  91 {
  92     lock($test);
  93     if ($] == 5.008 || $] >= 5.008003) {
  94         threads->create( sub {1} )->join;
  95         my $not = eval { Config::myconfig() } ? '' : 'not ';
  96         print "${not}ok $test - Are we able to call Config::myconfig after clone\n";
  97     } else {
  98         print "ok $test # Skip Are we able to call Config::myconfig after clone\n";
  99     }
 100     $test++;
 101 }
 102
 103
 104 # bugid 24383 - :unique hashes weren't being made readonly on interpreter
 105 # clone; check that they are.
 106
 107 our $unique_scalar : unique;
 108 our @unique_array : unique;
 109 our %unique_hash : unique;
 110 threads->create(sub {
 111         lock($test);
 112         my $TODO = ":unique needs to be re-implemented in a non-broken way";
 113         eval { $unique_scalar = 1 };
 114         print $@ =~ /read-only/
 115           ? '' : 'not ', "ok $test # TODO $TODO - unique_scalar\n";
 116         $test++;
 117         eval { $unique_array[0] = 1 };
 118         print $@ =~ /read-only/
 119           ? '' : 'not ', "ok $test # TODO $TODO - unique_array\n";
 120         $test++;
 121         if ($] >= 5.008003 && $^O ne 'MSWin32') {
 122             eval { $unique_hash{abc} = 1 };
 123             print $@ =~ /disallowed/
 124               ? '' : 'not ', "ok $test # TODO $TODO - unique_hash\n";
 125         } else {
 126             print("ok $test # Skip $TODO - unique_hash\n");
 127         }
 128         $test++;
 129     })->join;
 130
 131 # bugid #24940 :unique should fail on my and sub declarations
 132
 133 for my $decl ('my $x : unique', 'sub foo : unique') {
 134     {
 135         lock($test);
 136         if ($] >= 5.008005) {
 137             eval $decl;
 138             print $@ =~ /^The 'unique' attribute may only be applied to 'our' variables/
 139                     ? '' : 'not ', "ok $test - $decl\n";
 140         } else {
 141             print("ok $test # Skip $decl\n");
 142         }
 143         $test++;
 144     }
 145 }
 146
 147
 148 # Returing a closure from a thread caused problems. If the last index in
 149 # the anon sub's pad wasn't for a lexical, then a core dump could occur.
 150 # Otherwise, there might be leaked scalars.
 151
 152 # XXX DAPM 9-Jan-04 - backed this out for now - returning a closure from a
 153 # thread seems to crash win32
 154
 155 # sub f {
 156 #     my $x = "foo";
 157 #     sub { $x."bar" };
 158 # }
 159 #
 160 # my $string = threads->create(\&f)->join->();
 161 # print $string eq 'foobar' ?  '' : 'not ', "ok $test - returning closure\n";
 162 # $test++;
 163
 164
 165 # Nothing is checking that total keys gets cloned correctly.
 166
 167 my %h = (1,2,3,4);
 168 is(keys(%h), 2, "keys correct in parent");
 169
 170 my $child = threads->create(sub { return (scalar(keys(%h))); })->join;
 171 is($child, 2, "keys correct in child");
 172
 173 lock_keys(%h);
 174 delete($h{1});
 175
 176 is(keys(%h), 1, "keys correct in parent with restricted hash");
 177
 178 $child = threads->create(sub { return (scalar(keys(%h))); })->join;
 179 is($child, 1, "keys correct in child with restricted hash");
 180
 181 # EOF