{
my
$sub_ref
= Sub::Install::install_sub({
code
=> \
&ok
,
as
=>
'ok1'
});
isa_ok(
$sub_ref
,
'CODE'
,
'return value of first install_sub'
);
is_deeply(
$sub_ref
, \
&ok
,
'it returns the correct code ref'
);
ok1(1,
'installed sub runs'
);
}
{
my
$to_avail
=
eval
"use Test::Output; 1"
;
SKIP: {
skip
"can't run this test without Test::Output"
, 1
unless
$to_avail
;
Sub::Install::install_sub({
code
=> \
&ok
,
as
=>
'tmp_ok'
});
my
$expected_warning
=
<<'END_WARNING';
Subroutine main::tmp_ok redefined at t/install.t line 31
Prototype mismatch: sub main::tmp_ok ($;$) vs ($$;$) at t/install.t line 31
END_WARNING
my
$stderr
= Test::Output::stderr_from(
sub
{ Sub::Install::install_sub({
code
=> \
&is
,
as
=>
'tmp_ok'
}) }
);
$stderr
=~ s!\.$!!gm;
$stderr
=~ s!\\!/!g;
is(
$stderr
,
$expected_warning
,
"got expected warning"
,
);
}
}
{
my
$redef
= 0;
my
$proto
= 0;
local
$SIG
{__WARN__} =
sub
{
return
(
$redef
= 1)
if
$_
[0] =~ m{Subroutine \S+ redef.+t.install\.t};
return
(
$proto
= 1)
if
$_
[0] =~ m{Prototype mismatch.+t.install\.t};
die
"unexpected warning: @_"
;
};
my
$sub_ref
= Sub::Install::install_sub({
code
=> \
&is
,
as
=>
'ok1'
});
ok(
$redef
,
'correct redefinition warning went to $SIG{__WARN__}'
);
ok(
$proto
,
'correct prototype warning went to $SIG{__WARN__}'
);
isa_ok(
$sub_ref
,
'CODE'
,
'return value of second install_sub'
);
is_deeply(
$sub_ref
, \
&is
,
'install2 returns correct code ref'
);
ok1(1,1,
'installed sub runs (with new arguments)'
);
}
{
my
$sub_ref
= Sub::Install::install_sub({
code
=> \
&ok
,
into
=>
'Other'
,
as
=>
'ok1'
});
isa_ok(
$sub_ref
,
'CODE'
,
'return value of third install_sub'
);
is_deeply(
$sub_ref
, \
&ok
,
'it returns the correct code ref'
);
ok1(1,1,
'sub previously installed into main still runs properly'
);
ok1(1,
'remotely installed sub runs properly'
);
}
{
sub
Other::Another::foo {
return
$_
[0] }
my
$sub_ref
= Sub::Install::install_sub({
code
=>
'foo'
,
from
=>
'Other::Another'
,
into
=>
'Other::YetAnother'
,
as
=>
'return_lhs'
});
isa_ok(
$sub_ref
,
'CODE'
,
'return value of fourth install_sub'
);
is_deeply(
$sub_ref
,
\
&Other::Another::foo
,
'it returns the correct code ref'
);
is(
Other::Another->foo,
'Other::Another'
,
'the original code does what we want'
,
);
is(
Other::YetAnother->return_lhs,
'Other::YetAnother'
,
'and the installed code works, too'
,
);
}