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..14\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     unless ($got eq $want) {
  46         print "# EXPECTED: $want\n";
  47         print "# GOT:      $got\n";
  48         print "not ";
  49     }
  50     print "ok $test - $desc\n";
  51     $test++;
  52 }
  53
  54
  55 #
  56 # This tests for too much destruction
  57 # which was caused by cloning stashes
  58 # on join which led to double the dataspace
  59 #
  60 #########################
  61
  62 {
  63     sub Foo::DESTROY {
  64         my $self = shift;
  65         my ($package, $file, $line) = caller;
  66         is(threads->tid(),$self->{tid},
  67                 "In destroy[$self->{tid}] it should be correct too" )
  68     }
  69     my $foo;
  70     $foo = bless {tid => 0}, 'Foo';
  71     my $bar = threads->create(sub {
  72         is(threads->tid(),1, "And tid be 1 here");
  73         $foo->{tid} = 1;
  74         return $foo;
  75     })->join();
  76     $bar->{tid} = 0;
  77 }
  78
  79 #
  80 # This tests whether we can call Config::myconfig after threads have been
  81 # started (interpreter cloned).  5.8.1 and 5.8.2 contained a bug that would
  82 # disallow that too be done, because an attempt was made to change a variable
  83 # with the : unique attribute.
  84 #
  85 #########################
  86
  87 if ($] == 5.008 || $] >= 5.008003) {
  88     threads->create( sub {1} )->join;
  89     my $not = eval { Config::myconfig() } ? '' : 'not ';
  90     print "${not}ok $test - Are we able to call Config::myconfig after clone\n";
  91 } else {
  92     print "ok $test # Skip Are we able to call Config::myconfig after clone\n";
  93 }
  94 $test++;
  95
  96 # bugid 24383 - :unique hashes weren't being made readonly on interpreter
  97 # clone; check that they are.
  98
  99 our $unique_scalar : unique;
 100 our @unique_array : unique;
 101 our %unique_hash : unique;
 102 threads->create(
 103     sub {
 104         my $TODO = ":unique needs to be re-implemented in a non-broken way";
 105         eval { $unique_scalar = 1 };
 106         print $@ =~ /read-only/
 107           ? '' : 'not ', "ok $test # TODO $TODO unique_scalar\n";
 108         $test++;
 109         eval { $unique_array[0] = 1 };
 110         print $@ =~ /read-only/
 111           ? '' : 'not ', "ok $test # TODO $TODO - unique_array\n";
 112         $test++;
 113         if ($] >= 5.008003 && $^O ne 'MSWin32') {
 114             eval { $unique_hash{abc} = 1 };
 115             print $@ =~ /disallowed/
 116               ? '' : 'not ', "ok $test # TODO $TODO - unique_hash\n";
 117         } else {
 118             print("ok $test # Skip $TODO - unique_hash\n");
 119         }
 120         $test++;
 121     }
 122 )->join;
 123
 124 # bugid #24940 :unique should fail on my and sub declarations
 125
 126 for my $decl ('my $x : unique', 'sub foo : unique') {
 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 # Returing a closure from a thread caused problems. If the last index in
 139 # the anon sub's pad wasn't for a lexical, then a core dump could occur.
 140 # Otherwise, there might be leaked scalars.
 141
 142 # XXX DAPM 9-Jan-04 - backed this out for now - returning a closure from a
 143 # thread seems to crash win32
 144
 145 # sub f {
 146 #     my $x = "foo";
 147 #     sub { $x."bar" };
 148 # }
 149 #
 150 # my $string = threads->create(\&f)->join->();
 151 # print $string eq 'foobar' ?  '' : 'not ', "ok $test - returning closure\n";
 152 # $test++;
 153
 154
 155 # Nothing is checking that total keys gets cloned correctly.
 156
 157 my %h = (1,2,3,4);
 158 is (keys %h, 2, "keys correct in parent");
 159
 160 my $child = threads->create(sub { return scalar keys %h })->join;
 161 is ($child, 2, "keys correct in child");
 162
 163 lock_keys (%h);
 164 delete $h{1};
 165
 166 is (keys %h, 1, "keys correct in parent with restricted hash");
 167
 168 $child = threads->create(sub { return scalar keys %h })->join;
 169 is ($child, 1, "keys correct in child with restricted hash");
 170
 171 1;