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     unless ($Config{'useithreads'}) {
  11         print "1..0 # Skip: no 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 # Note that we can't use  Test::More here, as we would need to
  38 # call is() from within the DESTROY() function at global destruction time,
  39 # and parts of Test::* may have already been freed by then
  40
  41 my $test : shared = 2;
  42
  43 sub is($$$) {
  44     my ($got, $want, $desc) = @_;
  45     lock($test);
  46     unless ($got eq $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 #
  57 # This tests for too much destruction
  58 # which was caused by cloning stashes
  59 # on join which led to double the dataspace
  60 #
  61 #########################
  62 if ($] != 5.008)
  63 {
  64     sub Foo::DESTROY {
  65         my $self = shift;
  66         my ($package, $file, $line) = caller;
  67         is(threads->tid(),$self->{tid},
  68                 "In destroy[$self->{tid}] it should be correct too" )
  69     }
  70     my $foo;
  71     $foo = bless {tid => 0}, 'Foo';
  72     my $bar = threads->create(sub {
  73         is(threads->tid(),1, "And tid be 1 here");
  74         $foo->{tid} = 1;
  75         return $foo;
  76     })->join();
  77     $bar->{tid} = 0;
  78 }
  79
  80 #
  81 # This tests whether we can call Config::myconfig after threads have been
  82 # started (interpreter cloned).  5.8.1 and 5.8.2 contained a bug that would
  83 # disallow that too be done, because an attempt was made to change a variable
  84 # with the : unique attribute.
  85 #
  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 # bugid 24383 - :unique hashes weren't being made readonly on interpreter
 100 # clone; check that they are.
 101
 102 our $unique_scalar : unique;
 103 our @unique_array : unique;
 104 our %unique_hash : unique;
 105 threads->create(
 106     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     }
 126 )->join;
 127
 128 # bugid #24940 :unique should fail on my and sub declarations
 129
 130 for my $decl ('my $x : unique', 'sub foo : unique') {
 131     {
 132         lock($test);
 133         if ($] >= 5.008005) {
 134             eval $decl;
 135             print $@ =~ /^The 'unique' attribute may only be applied to 'our' variables/
 136                     ? '' : 'not ', "ok $test - $decl\n";
 137         } else {
 138             print("ok $test # Skip $decl\n");
 139         }
 140         $test++;
 141     }
 142 }
 143
 144
 145 # Returing a closure from a thread caused problems. If the last index in
 146 # the anon sub's pad wasn't for a lexical, then a core dump could occur.
 147 # Otherwise, there might be leaked scalars.
 148
 149 # XXX DAPM 9-Jan-04 - backed this out for now - returning a closure from a
 150 # thread seems to crash win32
 151
 152 # sub f {
 153 #     my $x = "foo";
 154 #     sub { $x."bar" };
 155 # }
 156 #
 157 # my $string = threads->create(\&f)->join->();
 158 # print $string eq 'foobar' ?  '' : 'not ', "ok $test - returning closure\n";
 159 # $test++;
 160
 161
 162 # Nothing is checking that total keys gets cloned correctly.
 163
 164 my %h = (1,2,3,4);
 165 is (keys %h, 2, "keys correct in parent");
 166
 167 my $child = threads->create(sub { return scalar keys %h })->join;
 168 is ($child, 2, "keys correct in child");
 169
 170 lock_keys (%h);
 171 delete $h{1};
 172
 173 is (keys %h, 1, "keys correct in parent with restricted hash");
 174
 175 $child = threads->create(sub { return scalar keys %h })->join;
 176 is ($child, 1, "keys correct in child with restricted hash");
 177
 178 1;