#!/usr/local/bin/perl -w
my
@custom_inc
;
BEGIN {
if
(
$ENV
{PERL_CORE}) {
chdir
't'
if
-d
't'
;
@custom_inc
=
@INC
=
'../lib'
;
}
elsif
(!
grep
/blib/,
@INC
) {
chdir
't'
if
-d
't'
;
unshift
@INC
, (
@custom_inc
= (
'../blib/lib'
,
'../blib/arch'
));
}
}
BEGIN {
delete
$ENV
{THREADS_DEBUG}}
diag(
<<EOD );
These tests check shared_clone functionality.
EOD
BEGIN {
no
warnings
'redefine'
;
if
($] < 5.008001) {
import
forks::shared::global_filter
'Test::Builder'
;
*Test::Builder::share
= \
&threads::shared::share
;
*Test::Builder::lock
= \
&threads::shared::lock
;
Test::Builder->new->
reset
;
}
}
{
no
warnings
'redefine'
;
my
$_sanity_check_old
= \
&Test::Builder::_sanity_check
;
*Test::Builder::_sanity_check
=
sub
{
my
$self
=
$_
[0];
if
(
$self
->{Original_Pid} != $$ ) {
return
;
}
$_sanity_check_old
->(
@_
);
};
}
{
my
$x
= shared_clone(14);
ok(
$x
== 14,
'number'
);
$x
= shared_clone(
'test'
);
ok(
$x
eq
'test'
,
'string'
);
}
{
my
%hsh
= (
'foo'
=> 2);
eval
{
my
$x
= shared_clone(
%hsh
);
};
ok($@ =~ /Usage:/,
'1 arg'
);
threads->create(
sub
{})->
join
();
}
{
my
$x
=
'test'
;
my
$foo
:shared = shared_clone(
$x
);
ok(
$foo
eq
'test'
,
'cloned string'
);
$foo
= shared_clone(\
$x
);
ok(
$$foo
eq
'test'
,
'cloned scalar ref'
);
threads->create(
sub
{
ok(
$$foo
eq
'test'
,
'cloned scalar ref in thread'
);
})->
join
();
}
{
my
$foo
:shared;
$foo
= shared_clone(\
$foo
);
ok(
ref
(
$foo
) eq
'REF'
,
'Circular ref typ'
);
ok(is_shared(
$foo
) == is_shared(
$$foo
),
'Circular ref'
);
threads->create(
sub
{
ok(is_shared(
$foo
) == is_shared(
$$foo
),
'Circular ref in thread'
);
my
(
$x
,
$y
,
$z
);
$x
= \
$y
;
$y
= \
$z
;
$z
= \
$x
;
$foo
= shared_clone(
$x
);
})->
join
();
is_shared(
$$foo
);
is_shared($$$
$$foo
);
ok(is_shared(
$$foo
) == is_shared($$$
$$foo
),
'Cloned circular refs from thread'
);
}
{
my
@ary
= (
qw/foo bar baz/
);
my
$ary
= shared_clone(\
@ary
);
ok(
$ary
->[1] eq
'bar'
,
'Cloned array'
);
$ary
->[1] = 99;
ok(
$ary
->[1] == 99,
'Clone mod'
);
ok(
$ary
[1] eq
'bar'
,
'Original array'
);
threads->create(
sub
{
ok(
$ary
->[1] == 99,
'Clone mod in thread'
);
$ary
[1] =
'bork'
;
$ary
->[1] =
'thread'
;
})->
join
();
ok(
$ary
->[1] eq
'thread'
,
'Clone mod from thread'
);
ok(
$ary
[1] eq
'bar'
,
'Original array'
);
}
{
my
$hsh
:shared = shared_clone({
'foo'
=> [
qw/foo bar baz/
]});
ok(is_shared(
$hsh
),
'Shared hash ref'
);
ok(is_shared(
$hsh
->{
'foo'
}),
'Shared hash ref elem'
);
ok(
$$hsh
{
'foo'
}[1] eq
'bar'
,
'Cloned structure'
);
}
{
my
$obj
= \
do
{
my
$bork
= 99; };
bless
(
$obj
,
'Bork'
);
Internals::SvREADONLY(
$$obj
, 1)
if
($] >= 5.008003);
my
$bork
= shared_clone(
$obj
);
ok(
$$bork
== 99,
'cloned scalar ref object'
);
ok(($] < 5.008003) || Internals::SvREADONLY(
$$bork
),
'read-only'
);
ok(
ref
(
$bork
) eq
'Bork'
,
'Object class'
);
threads->create(
sub
{
ok(
$$bork
== 99,
'cloned scalar ref object in thread'
);
ok(($] < 5.008003) || Internals::SvREADONLY(
$$bork
),
'read-only'
);
ok(
ref
(
$bork
) eq
'Bork'
,
'Object class'
);
})->
join
();
}
{
my
$scalar
=
'zip'
;
my
$obj
= {
'ary'
=> [ 1,
'foo'
, [ 86 ], {
'bar'
=> [
'baz'
] } ],
'ref'
=> \
$scalar
,
};
$obj
->{
'self'
} =
$obj
;
bless
(
$obj
,
'Foo'
);
my
$copy
:shared;
threads->create(
sub
{
$copy
= shared_clone(
$obj
);
ok(${
$copy
->{
'ref'
}} eq
'zip'
,
'Obj ref in thread'
);
ok(is_shared(
$copy
) == is_shared(
$copy
->{
'self'
}),
'Circular ref in cloned obj'
);
ok(is_shared(
$copy
->{
'ary'
}->[2]),
'Shared element in cloned obj'
);
})->
join
();
ok(
ref
(
$copy
) eq
'Foo'
,
'Obj cloned by thread'
);
ok(${
$copy
->{
'ref'
}} eq
'zip'
,
'Obj ref in thread'
);
ok(is_shared(
$copy
) == is_shared(
$copy
->{
'self'
}),
'Circular ref in cloned obj'
);
ok(
$copy
->{
'ary'
}->[3]->{
'bar'
}->[0] eq
'baz'
,
'Deeply cloned'
);
ok(
ref
(
$copy
) eq
'Foo'
,
'Cloned object class'
);
}
1;