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