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