dist/threads/t/problems.t

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