BEGIN {
if
(!
$Config
{
'useithreads'
}) {
print
(
"1..0 # SKIP Perl not compiled with 'useithreads'\n"
);
exit
(0);
}
}
sub
ok {
my
(
$id
,
$ok
,
$name
) =
@_
;
if
(
$ok
) {
print
(
"ok $id - $name\n"
);
}
else
{
print
(
"not ok $id - $name\n"
);
printf
(
"# Failed test at line %d\n"
, (
caller
)[2]);
}
return
(
$ok
);
}
BEGIN {
$| = 1;
print
(
"1..21\n"
);
};
ok(1, 1,
'Loaded'
);
my
$foo
;
my
$bar
=
"foo"
;
share(
$foo
);
eval
{
$foo
= \
$bar
; };
ok(2,
my
$temp1
= $@ =~/^Invalid\b.
*shared
scalar
/,
"Wrong error message"
);
share(
$bar
);
$foo
= \
$bar
;
ok(3,
$temp1
=
$foo
=~/SCALAR/,
"Check that is a ref"
);
ok(4,
$$foo
eq
"foo"
,
"Check that it points to the correct value"
);
$bar
=
"yeah"
;
ok(5,
$$foo
eq
"yeah"
,
"Check that assignment works"
);
$$foo
=
"yeah2"
;
ok(6,
$$foo
eq
"yeah2"
,
"Check that deref assignment works"
);
threads->create(
sub
{
$bar
=
"yeah3"
})->
join
();
ok(7,
$$foo
eq
"yeah3"
,
"Check that other thread assignment works"
);
threads->create(
sub
{
$foo
=
"artur"
})->
join
();
ok(8,
$foo
eq
"artur"
,
"Check that uncopupling the ref works"
);
my
$baz
;
share(
$baz
);
$baz
=
"original"
;
$bar
= \
$baz
;
$foo
= \
$bar
;
ok(9,$
$$foo
eq
'original'
,
"Check reference chain"
);
my
(
$t1
,
$t2
);
share(
$t1
);
share(
$t2
);
$t2
=
"text"
;
$t1
= \
$t2
;
threads->create(
sub
{
$t1
=
"bar"
})->
join
();
ok(10,
$t1
eq
'bar'
,
"Check that assign to a ROK works"
);
ok(11, is_shared(
$foo
),
"Check for sharing"
);
{
my
$x
: shared;
my
$y
: shared;
my
$z
: shared;
$x
= \
$y
;
$y
= \
$z
;
$z
= \
$x
;
ok(12,
ref
(
$x
) eq
'REF'
,
'$x ref type'
);
ok(13,
ref
(
$y
) eq
'REF'
,
'$y ref type'
);
ok(14,
ref
(
$z
) eq
'REF'
,
'$z ref type'
);
my
@q
:shared = (
$x
);
ok(15,
ref
(
$q
[0]) eq
'REF'
,
'$q[0] ref type'
);
my
$w
=
$q
[0];
ok(16,
ref
(
$w
) eq
'REF'
,
'$w ref type'
);
ok(17,
ref
(
$$w
) eq
'REF'
,
'$$w ref type'
);
ok(18,
ref
($
$$w
) eq
'REF'
,
'$$$w ref type'
);
ok(19,
ref
($$
$$w
) eq
'REF'
,
'$$$$w ref type'
);
ok(20, is_shared(
$x
) == is_shared(
$w
),
'_id($x) == _id($w)'
);
ok(21, is_shared(
$w
) == is_shared($$
$$w
),
'_id($w) == _id($$$$w)'
);
}
exit
(0);