ext/threads/t/problems.t

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