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