#!/usr/bin/perl
use
ok
"Context::Handle"
=>
"context_sensitive"
;
sub
SomeClass::foo {
"object"
};
my
@array
= (
qw/this is an array/
);
my
%hash
= (
qw/this is a hash/
);
sub
complex {
if
( want(
"SCALAR"
) ) {
if
( want(
"REF"
) ) {
if
( want(
"ARRAY"
) ) {
return
\
@array
;
}
elsif
( want(
"HASH"
) ) {
return
\
%hash
;
}
elsif
( want(
"OBJECT"
) ) {
return
bless
{},
"SomeClass"
;
}
elsif
( want(
"CODE"
) ) {
return
sub
{
"code"
}
}
else
{
return
\
"scalar ref"
;
}
}
elsif
( want(
"BOOL"
) ) {
return
undef
;
}
else
{
return
"scalar"
;
}
}
elsif
( want(
"LIST"
) ) {
return
qw/this is a list/
;
}
elsif
( want(
"VOID"
) ) {
return
;
}
else
{
die
"unknown context"
}
}
sub
noop_wrap {
complex();
}
sub
is_wrapped {
my
$rv
= context_sensitive { complex() };
local
$Test::Builder::Level
= 2;
isa_ok(
$rv
->rv_container,
"Context::Handle::RV::$_[0]"
) or
warn
Dumper(
$rv
);
$rv
->
return
;
fail(
"this should not be reached"
);
}
{
my
$scalar
= complex();
is(
$scalar
,
"scalar"
,
"scalar yields scalar"
);
}
{
my
$scalar
= is_wrapped(
"Scalar"
);
is(
$scalar
,
"scalar"
,
"wrapped scalar yields scalar"
);
}
foreach
my
$sub
( \
&complex
, \
&noop_wrap
,
sub
{ is_wrapped(
"Scalar"
) } ) {
my
$scalar
=
$sub
->();
is(
$scalar
,
"scalar"
,
"correct value in context"
);
}
foreach
my
$sub
( \
&complex
, \
&noop_wrap
,
sub
{ is_wrapped(
"RefScalar"
) } ) {
my
$scalar
= ${
$sub
->() };
is(
$scalar
,
"scalar ref"
,
"correct value in scalar deref context"
);
}
my
$i
;
foreach
my
$sub
( \
&complex
, \
&noop_wrap
,
sub
{ is_wrapped(
"RefArray"
) } ) {
my
$scalar
=
$sub
->()->[3];
is(
$scalar
,
"array"
,
"correct value in array deref context"
);
$sub
->()->[2] = ++
$i
;
is(
$sub
->()->[2],
$i
,
"array ref is mutable"
);
}
foreach
my
$sub
( \
&complex
, \
&noop_wrap
,
sub
{ is_wrapped(
"RefHash"
) } ) {
my
$scalar
=
$sub
->()->{a};
is(
$scalar
,
"hash"
,
"correct value in hash deref context"
);
$sub
->()->{this} = ++
$i
;
is(
$sub
->()->{this},
$i
,
"array ref is mutable"
);
}
foreach
my
$sub
( \
&complex
, \
&noop_wrap
,
sub
{ is_wrapped(
"Bool"
) } ) {
my
$bool
;
if
(
$sub
->() ) {
$bool
=
"true"
;
}
else
{
$bool
=
"false"
;
}
is(
$bool
,
"false"
,
"correct value in bool context"
);
}
foreach
my
$sub
( \
&complex
, \
&noop_wrap
,
sub
{ is_wrapped(
"RefObject"
) } ) {
is(
$sub
->()->foo,
"object"
,
"correct value in object deref context"
);
}
foreach
my
$sub
( \
&complex
, \
&noop_wrap
,
sub
{ is_wrapped(
"RefCode"
) } ) {
is(
$sub
->()->(),
"code"
,
"correct value in code deref context"
);
}
is_wrapped(
"Void"
);
{
my
$hash_val
= ${ is_wrapped(
"RefScalar"
) };
is(
$hash_val
,
"scalar ref"
,
"wrapped rv ok"
);
}
{
my
$hash_val
= complex()->{a};
is(
$hash_val
,
"hash"
,
"hash value extracted"
);
}
{
my
$hash_val
= is_wrapped(
"RefHash"
)->{a};
is(
$hash_val
,
"hash"
,
"wrapped rv ok"
);
}