1use strict;
2use warnings;
3
4BEGIN {
5    use Config;
6    if (! $Config{'useithreads'}) {
7        print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
8        exit(0);
9    }
10}
11
12use ExtUtils::testlib;
13
14use threads;
15
16BEGIN {
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..6\n");    ### Number of tests that will be run ###
25    } else {
26        print("1..10\n");   ### Number of tests that will be run ###
27    }
28};
29
30print("ok 1 - Loaded\n");
31
32use Hash::Util 'lock_keys';
33
34my $test :shared = 2;
35
36# Note that we can't use Test::More here, as we would need to call is()
37# from within the DESTROY() function at global destruction time, and
38# parts of Test::* may have already been freed by then
39sub is($$$)
40{
41    my ($got, $want, $desc) = @_;
42    lock($test);
43    if ($got ne $want) {
44        print("# EXPECTED: $want\n");
45        print("# GOT:      $got\n");
46        print("not ");
47    }
48    print("ok $test - $desc\n");
49    $test++;
50}
51
52
53# This tests for too much destruction which was caused by cloning stashes
54# on join which led to double the dataspace under 5.8.0
55if ($] != 5.008)
56{
57    sub Foo::DESTROY
58    {
59        my $self = shift;
60        my ($package, $file, $line) = caller;
61        is(threads->tid(), $self->{tid}, "In destroy[$self->{tid}] it should be correct too" );
62    }
63
64    my $foo = bless {tid => 0}, 'Foo';
65    my $bar = threads->create(sub {
66        is(threads->tid(), 1, "And tid be 1 here");
67        $foo->{tid} = 1;
68        return ($foo);
69    })->join();
70    $bar->{tid} = 0;
71}
72
73
74# This tests whether we can call Config::myconfig after threads have been
75# started (interpreter cloned).  5.8.1 and 5.8.2 contained a bug that would
76# disallow that to be done because an attempt was made to change a variable
77# with the :unique attribute.
78
79{
80    lock($test);
81    if ($] == 5.008 || $] >= 5.008003) {
82        threads->create( sub {1} )->join;
83        my $not = eval { Config::myconfig() } ? '' : 'not ';
84        print "${not}ok $test - Are we able to call Config::myconfig after clone\n";
85    } else {
86        print "ok $test # SKIP Are we able to call Config::myconfig after clone\n";
87    }
88    $test++;
89}
90
91
92# Returning a closure from a thread caused problems. If the last index in
93# the anon sub's pad wasn't for a lexical, then a core dump could occur.
94# Otherwise, there might be leaked scalars.
95
96# XXX DAPM 9-Jan-04 - backed this out for now - returning a closure from a
97# thread seems to crash win32
98
99# sub f {
100#     my $x = "foo";
101#     sub { $x."bar" };
102# }
103# 
104# my $string = threads->create(\&f)->join->();
105# print $string eq 'foobar' ?  '' : 'not ', "ok $test - returning closure\n";
106# $test++;
107
108
109# Nothing is checking that total keys gets cloned correctly.
110
111my %h = (1,2,3,4);
112is(keys(%h), 2, "keys correct in parent");
113
114my $child = threads->create(sub { return (scalar(keys(%h))); })->join;
115is($child, 2, "keys correct in child");
116
117lock_keys(%h);
118delete($h{1});
119
120is(keys(%h), 1, "keys correct in parent with restricted hash");
121
122$child = threads->create(sub { return (scalar(keys(%h))); })->join;
123is($child, 1, "keys correct in child with restricted hash");
124
125exit(0);
126
127# EOF
128