Import Upstream version 0.928
This commit is contained in:
denghao
commit
57ba26f170
|
|
@ -0,0 +1,2 @@
|
|||
.build
|
||||
Sub-Install-*
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
Revision history for Sub-Install
|
||||
|
||||
{{$NEXT}}
|
||||
|
||||
0.928 2014-06-26 18:57:27-04:00 America/New_York
|
||||
- cope with subroutines with spaces in their names when catching
|
||||
warnings
|
||||
- don't assume that the source sub isn't blessed in tests (!)
|
||||
|
||||
0.927 2013-10-15 22:46:38 America/New_York
|
||||
rebuild using Dist::Zilla, update links to repo, metadata, etc.
|
||||
|
||||
typo fixes, thanks David Steinbrunner
|
||||
|
||||
0.926 2012-02-26
|
||||
cope with terminal dots from new Carp
|
||||
|
||||
0.925 2009-01-16
|
||||
add repo loc to metadata
|
||||
|
||||
0.924 2006-11-13
|
||||
packaging improvements
|
||||
|
||||
0.922 2006-07-21
|
||||
fix filename-matching in output tests for win32 (20617, thanks Jerry
|
||||
Gay!) (Couldn't reproduce this one. Argh!)
|
||||
|
||||
0.921 2006-07-16
|
||||
fix filename-matching in output tests for win32 (20484, thanks Alex
|
||||
Chorny!)
|
||||
|
||||
0.92 2006-05-11
|
||||
allow other users to build exporters like our tiny one (&exporter)
|
||||
rename _CALLABLE to _CODELIKE to keep up with Params::Util
|
||||
|
||||
0.91 2006-04-30
|
||||
use _CALLABLE to determine callability of code, not ref
|
||||
|
||||
0.90 2006-04-15
|
||||
rewrite warning handling:
|
||||
reinstall suppresses fewer warnings: only sub redefinition
|
||||
relevant warnings warn from caller (like Carp)
|
||||
YOUR CODE MAY BREAK:
|
||||
the test/code and documentation differed on install_installers
|
||||
the code has been changed to match the documentation
|
||||
|
||||
0.03 2005-11-22 19:00
|
||||
install_installers to make Sub::Installer history
|
||||
|
||||
0.02 2005-11-22 11:26
|
||||
improved detection of sub names via B
|
||||
100% coverage
|
||||
|
||||
0.01 2005-11-21 22:28
|
||||
the first version
|
||||
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
name = Sub-Install
|
||||
author = Ricardo SIGNES <rjbs@cpan.org>
|
||||
license = Perl_5
|
||||
copyright_holder = Ricardo SIGNES
|
||||
copyright_year = 2005
|
||||
|
||||
[@RJBS]
|
||||
|
|
@ -0,0 +1,300 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
package Sub::Install;
|
||||
# ABSTRACT: install subroutines into packages easily
|
||||
|
||||
use Carp;
|
||||
use Scalar::Util ();
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Sub::Install;
|
||||
|
||||
Sub::Install::install_sub({
|
||||
code => sub { ... },
|
||||
into => $package,
|
||||
as => $subname
|
||||
});
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module makes it easy to install subroutines into packages without the
|
||||
unsightly mess of C<no strict> or typeglobs lying about where just anyone can
|
||||
see them.
|
||||
|
||||
=func install_sub
|
||||
|
||||
Sub::Install::install_sub({
|
||||
code => \&subroutine,
|
||||
into => "Finance::Shady",
|
||||
as => 'launder',
|
||||
});
|
||||
|
||||
This routine installs a given code reference into a package as a normal
|
||||
subroutine. The above is equivalent to:
|
||||
|
||||
no strict 'refs';
|
||||
*{"Finance::Shady" . '::' . "launder"} = \&subroutine;
|
||||
|
||||
If C<into> is not given, the sub is installed into the calling package.
|
||||
|
||||
If C<code> is not a code reference, it is looked for as an existing sub in the
|
||||
package named in the C<from> parameter. If C<from> is not given, it will look
|
||||
in the calling package.
|
||||
|
||||
If C<as> is not given, and if C<code> is a name, C<as> will default to C<code>.
|
||||
If C<as> is not given, but if C<code> is a code ref, Sub::Install will try to
|
||||
find the name of the given code ref and use that as C<as>.
|
||||
|
||||
That means that this code:
|
||||
|
||||
Sub::Install::install_sub({
|
||||
code => 'twitch',
|
||||
from => 'Person::InPain',
|
||||
into => 'Person::Teenager',
|
||||
as => 'dance',
|
||||
});
|
||||
|
||||
is the same as:
|
||||
|
||||
package Person::Teenager;
|
||||
|
||||
Sub::Install::install_sub({
|
||||
code => Person::InPain->can('twitch'),
|
||||
as => 'dance',
|
||||
});
|
||||
|
||||
=func reinstall_sub
|
||||
|
||||
This routine behaves exactly like C<L</install_sub>>, but does not emit a
|
||||
warning if warnings are on and the destination is already defined.
|
||||
|
||||
=cut
|
||||
|
||||
sub _name_of_code {
|
||||
my ($code) = @_;
|
||||
require B;
|
||||
my $name = B::svref_2object($code)->GV->NAME;
|
||||
return $name unless $name =~ /\A__ANON__/;
|
||||
return;
|
||||
}
|
||||
|
||||
# See also Params::Util, to which this code was donated.
|
||||
sub _CODELIKE {
|
||||
(Scalar::Util::reftype($_[0])||'') eq 'CODE'
|
||||
|| Scalar::Util::blessed($_[0])
|
||||
&& (overload::Method($_[0],'&{}') ? $_[0] : undef);
|
||||
}
|
||||
|
||||
# do the heavy lifting
|
||||
sub _build_public_installer {
|
||||
my ($installer) = @_;
|
||||
|
||||
sub {
|
||||
my ($arg) = @_;
|
||||
my ($calling_pkg) = caller(0);
|
||||
|
||||
# I'd rather use ||= but I'm whoring for Devel::Cover.
|
||||
for (qw(into from)) { $arg->{$_} = $calling_pkg unless $arg->{$_} }
|
||||
|
||||
# This is the only absolutely required argument, in many cases.
|
||||
Carp::croak "named argument 'code' is not optional" unless $arg->{code};
|
||||
|
||||
if (_CODELIKE($arg->{code})) {
|
||||
$arg->{as} ||= _name_of_code($arg->{code});
|
||||
} else {
|
||||
Carp::croak
|
||||
"couldn't find subroutine named $arg->{code} in package $arg->{from}"
|
||||
unless my $code = $arg->{from}->can($arg->{code});
|
||||
|
||||
$arg->{as} = $arg->{code} unless $arg->{as};
|
||||
$arg->{code} = $code;
|
||||
}
|
||||
|
||||
Carp::croak "couldn't determine name under which to install subroutine"
|
||||
unless $arg->{as};
|
||||
|
||||
$installer->(@$arg{qw(into as code) });
|
||||
}
|
||||
}
|
||||
|
||||
# do the ugly work
|
||||
|
||||
my $_misc_warn_re;
|
||||
my $_redef_warn_re;
|
||||
BEGIN {
|
||||
$_misc_warn_re = qr/
|
||||
Prototype\ mismatch:\ sub\ .+? |
|
||||
Constant subroutine .+? redefined
|
||||
/x;
|
||||
$_redef_warn_re = qr/Subroutine\ .+?\ redefined/x;
|
||||
}
|
||||
|
||||
my $eow_re;
|
||||
BEGIN { $eow_re = qr/ at .+? line \d+\.\Z/ };
|
||||
|
||||
sub _do_with_warn {
|
||||
my ($arg) = @_;
|
||||
my $code = delete $arg->{code};
|
||||
my $wants_code = sub {
|
||||
my $code = shift;
|
||||
sub {
|
||||
my $warn = $SIG{__WARN__} ? $SIG{__WARN__} : sub { warn @_ }; ## no critic
|
||||
local $SIG{__WARN__} = sub {
|
||||
my ($error) = @_;
|
||||
for (@{ $arg->{suppress} }) {
|
||||
return if $error =~ $_;
|
||||
}
|
||||
for (@{ $arg->{croak} }) {
|
||||
if (my ($base_error) = $error =~ /\A($_) $eow_re/x) {
|
||||
Carp::croak $base_error;
|
||||
}
|
||||
}
|
||||
for (@{ $arg->{carp} }) {
|
||||
if (my ($base_error) = $error =~ /\A($_) $eow_re/x) {
|
||||
return $warn->(Carp::shortmess $base_error);
|
||||
}
|
||||
}
|
||||
($arg->{default} || $warn)->($error);
|
||||
};
|
||||
$code->(@_);
|
||||
};
|
||||
};
|
||||
return $wants_code->($code) if $code;
|
||||
return $wants_code;
|
||||
}
|
||||
|
||||
sub _installer {
|
||||
sub {
|
||||
my ($pkg, $name, $code) = @_;
|
||||
no strict 'refs'; ## no critic ProhibitNoStrict
|
||||
*{"$pkg\::$name"} = $code;
|
||||
return $code;
|
||||
}
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
*_ignore_warnings = _do_with_warn({
|
||||
carp => [ $_misc_warn_re, $_redef_warn_re ]
|
||||
});
|
||||
|
||||
*install_sub = _build_public_installer(_ignore_warnings(_installer));
|
||||
|
||||
*_carp_warnings = _do_with_warn({
|
||||
carp => [ $_misc_warn_re ],
|
||||
suppress => [ $_redef_warn_re ],
|
||||
});
|
||||
|
||||
*reinstall_sub = _build_public_installer(_carp_warnings(_installer));
|
||||
|
||||
*_install_fatal = _do_with_warn({
|
||||
code => _installer,
|
||||
croak => [ $_redef_warn_re ],
|
||||
});
|
||||
}
|
||||
|
||||
=func install_installers
|
||||
|
||||
This routine is provided to allow Sub::Install compatibility with
|
||||
Sub::Installer. It installs C<install_sub> and C<reinstall_sub> methods into
|
||||
the package named by its argument.
|
||||
|
||||
Sub::Install::install_installers('Code::Builder'); # just for us, please
|
||||
Code::Builder->install_sub({ name => $code_ref });
|
||||
|
||||
Sub::Install::install_installers('UNIVERSAL'); # feeling lucky, punk?
|
||||
Anything::At::All->install_sub({ name => $code_ref });
|
||||
|
||||
The installed installers are similar, but not identical, to those provided by
|
||||
Sub::Installer. They accept a single hash as an argument. The key/value pairs
|
||||
are used as the C<as> and C<code> parameters to the C<install_sub> routine
|
||||
detailed above. The package name on which the method is called is used as the
|
||||
C<into> parameter.
|
||||
|
||||
Unlike Sub::Installer's C<install_sub> will not eval strings into code, but
|
||||
will look for named code in the calling package.
|
||||
|
||||
=cut
|
||||
|
||||
sub install_installers {
|
||||
my ($into) = @_;
|
||||
|
||||
for my $method (qw(install_sub reinstall_sub)) {
|
||||
my $code = sub {
|
||||
my ($package, $subs) = @_;
|
||||
my ($caller) = caller(0);
|
||||
my $return;
|
||||
for (my ($name, $sub) = %$subs) {
|
||||
$return = Sub::Install->can($method)->({
|
||||
code => $sub,
|
||||
from => $caller,
|
||||
into => $package,
|
||||
as => $name
|
||||
});
|
||||
}
|
||||
return $return;
|
||||
};
|
||||
install_sub({ code => $code, into => $into, as => $method });
|
||||
}
|
||||
}
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
Sub::Install exports C<install_sub> and C<reinstall_sub> only if they are
|
||||
requested.
|
||||
|
||||
=head2 exporter
|
||||
|
||||
Sub::Install has a never-exported subroutine called C<exporter>, which is used
|
||||
to implement its C<import> routine. It takes a hashref of named arguments,
|
||||
only one of which is currently recognize: C<exports>. This must be an arrayref
|
||||
of subroutines to offer for export.
|
||||
|
||||
This routine is mainly for Sub::Install's own consumption. Instead, consider
|
||||
L<Sub::Exporter>.
|
||||
|
||||
=cut
|
||||
|
||||
sub exporter {
|
||||
my ($arg) = @_;
|
||||
|
||||
my %is_exported = map { $_ => undef } @{ $arg->{exports} };
|
||||
|
||||
sub {
|
||||
my $class = shift;
|
||||
my $target = caller;
|
||||
for (@_) {
|
||||
Carp::croak "'$_' is not exported by $class" if !exists $is_exported{$_};
|
||||
install_sub({ code => $_, from => $class, into => $target });
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
BEGIN { *import = exporter({ exports => [ qw(install_sub reinstall_sub) ] }); }
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over
|
||||
|
||||
=item L<Sub::Installer>
|
||||
|
||||
This module is (obviously) a reaction to Damian Conway's Sub::Installer, which
|
||||
does the same thing, but does it by getting its greasy fingers all over
|
||||
UNIVERSAL. I was really happy about the idea of making the installation of
|
||||
coderefs less ugly, but I couldn't bring myself to replace the ugliness of
|
||||
typeglobs and loosened strictures with the ugliness of UNIVERSAL methods.
|
||||
|
||||
=item L<Sub::Exporter>
|
||||
|
||||
This is a complete Exporter.pm replacement, built atop Sub::Install.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXTRA CREDITS
|
||||
|
||||
Several of the tests are adapted from tests that shipped with Damian Conway's
|
||||
Sub-Installer distribution.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
use Sub::Install;
|
||||
Sub::Install::install_installers('UNIVERSAL');
|
||||
|
||||
# This test, from here on out, is the verbatim "install.t" test from
|
||||
# Sub::Installer 0.0.2
|
||||
|
||||
use Test::More 'no_plan';
|
||||
use Scalar::Util qw/reftype/;
|
||||
use warnings;
|
||||
|
||||
# Install a sub in a package...
|
||||
|
||||
my $sub_ref = main->install_sub({ ok1 => \&ok });
|
||||
|
||||
is reftype $sub_ref, 'CODE' => 'install returns code ref';
|
||||
|
||||
is_deeply \&ok, $sub_ref => 'install returns correct code ref';
|
||||
|
||||
ok1(1 => 'installed sub runs');
|
||||
|
||||
|
||||
# Install the same sub in the same package...
|
||||
|
||||
$SIG{__WARN__} = sub { ok 1 => 'warned as expected' if $_[0] =~ /redefined/ };
|
||||
|
||||
|
||||
$sub_ref = main->install_sub({ ok1 => \&is });
|
||||
|
||||
is reftype $sub_ref, 'CODE' => 'install2 returns code ref';
|
||||
|
||||
is_deeply \&is, $sub_ref => 'install2 returns correct code ref';
|
||||
|
||||
ok1(1,1 => 'installed sub reruns');
|
||||
|
||||
# Install in another package...
|
||||
|
||||
$sub_ref = Other->install_sub({ ok2 => \&ok });
|
||||
|
||||
is reftype $sub_ref, 'CODE' => 'install2 returns code ref';
|
||||
|
||||
is_deeply \&ok, $sub_ref => 'install2 returns correct code ref';
|
||||
|
||||
ok1(1,1 => 'installed sub reruns');
|
||||
|
||||
package Other;
|
||||
|
||||
ok2(1 => 'remotely installed sub runs');
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
use Sub::Install;
|
||||
Sub::Install::install_installers('UNIVERSAL');
|
||||
|
||||
# This test, from here on out, is the verbatim "reinstall.t" test from
|
||||
# Sub::Installer 0.0.2
|
||||
|
||||
use Test::More 'no_plan';
|
||||
use Scalar::Util qw/reftype/;
|
||||
use warnings;
|
||||
|
||||
# Install a sub in a package...
|
||||
|
||||
my $sub_ref = main->reinstall_sub({ ok1 => \&ok });
|
||||
|
||||
is reftype $sub_ref, 'CODE' => 'reinstall returns code ref';
|
||||
|
||||
is_deeply \&ok, $sub_ref => 'reinstall returns correct code ref';
|
||||
|
||||
ok1(1 => 'reinstalled sub runs');
|
||||
|
||||
|
||||
# Install the same sub in the same package...
|
||||
|
||||
$SIG{__WARN__} = sub { ok 0 => "warned unexpected: @_" if $_[0] =~ /redefined/ };
|
||||
|
||||
$sub_ref = main->reinstall_sub({ ok1 => \&is });
|
||||
|
||||
is reftype $sub_ref, 'CODE' => 'reinstall2 returns code ref';
|
||||
|
||||
is_deeply \&is, $sub_ref => 'reinstall2 returns correct code ref';
|
||||
|
||||
ok1(1,1 => 'reinstalled sub reruns');
|
||||
|
||||
# Install in another package...
|
||||
|
||||
$sub_ref = Other->reinstall_sub({ ok2 => \&ok });
|
||||
|
||||
is reftype $sub_ref, 'CODE' => 'reinstall2 returns code ref';
|
||||
|
||||
is_deeply \&ok, $sub_ref => 'reinstall2 returns correct code ref';
|
||||
|
||||
ok1(1,1 => 'reinstalled sub reruns');
|
||||
|
||||
package Other;
|
||||
|
||||
ok2(1 => 'remotely reinstalled sub runs');
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
use Sub::Install qw(install_sub);
|
||||
use Test::More 'no_plan';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub source_method {
|
||||
my ($package) = @_;
|
||||
return $package;
|
||||
}
|
||||
|
||||
{ # install named method and let the name be the same
|
||||
install_sub({ code => "source_method", into => "By::Name" });
|
||||
|
||||
is(
|
||||
By::Name->source_method,
|
||||
'By::Name',
|
||||
"method installed by name"
|
||||
);
|
||||
}
|
||||
|
||||
{ # install via a coderef and let name be looked up
|
||||
install_sub({ code => \&source_method, into => "By::Ref" });
|
||||
|
||||
is(
|
||||
By::Ref->source_method,
|
||||
'By::Ref',
|
||||
"method installed by ref, without name"
|
||||
);
|
||||
}
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
use Sub::Install;
|
||||
use Test::More tests => 4;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
BEGIN { use_ok('Sub::Install'); }
|
||||
|
||||
package Bar;
|
||||
{ no warnings 'once';
|
||||
*import = Sub::Install::exporter { exports => [ qw(foo) ] };
|
||||
}
|
||||
sub foo { return 10; }
|
||||
|
||||
package main;
|
||||
|
||||
eval { Bar->import('bar'); };
|
||||
like($@, qr/'bar' is not exported/, "exception on bad import");
|
||||
|
||||
eval { foo(); };
|
||||
like($@, qr/Undefined subroutine/, "foo isn't imported yet");
|
||||
|
||||
Bar->import(qw(foo));
|
||||
is(foo(), 10, "foo imported from Bar OK");
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
use Sub::Install;
|
||||
use Test::More 'no_plan';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
BEGIN { use_ok("Sub::Install"); }
|
||||
|
||||
my $code = sub { return 'FOO' };
|
||||
|
||||
bless $code, "Sub::Install::Bogus";
|
||||
|
||||
Sub::Install::install_sub({
|
||||
code => $code,
|
||||
as => 'code',
|
||||
});
|
||||
|
||||
is(code(), "FOO", "installed sub is OK");
|
||||
|
||||
|
|
@ -0,0 +1,113 @@
|
|||
use Sub::Install;
|
||||
use Test::More tests => 17;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# These tests largely copied from Damian Conway's Sub::Installer tests.
|
||||
|
||||
{ # Install a sub in a package...
|
||||
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",
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
{ # Install the same sub in the same package...
|
||||
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};
|
||||
# pass("warned as expected: $_[0]") if $_[0] =~ /redefined/;
|
||||
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)');
|
||||
}
|
||||
|
||||
{ # Install in another package...
|
||||
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');
|
||||
|
||||
package Other;
|
||||
ok1(1, 'remotely installed sub runs properly');
|
||||
}
|
||||
|
||||
{ # cross-package installation
|
||||
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',
|
||||
);
|
||||
}
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
use Sub::Install qw(install_sub);
|
||||
use Test::More 'no_plan';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
{ # you have to install /something/!
|
||||
eval { install_sub({ into => "Doesn't::Matter" }); };
|
||||
|
||||
like($@, qr/code.+not optional/, "you must supply something to install");
|
||||
}
|
||||
|
||||
{ # you can't just make names up and expect Sub::Install to know what you mean
|
||||
eval { install_sub({ code => 'none_such', into => 'Whatever' }); };
|
||||
|
||||
like($@, qr/couldn't find subroutine/, "error on unfound sub name");
|
||||
}
|
||||
|
||||
{ # can't install anonymous subs without a name
|
||||
eval { install_sub({ code => sub { return 1; } }); };
|
||||
|
||||
like($@, qr/couldn't determine name/, "anon subs need names to install");
|
||||
}
|
||||
|
|
@ -0,0 +1,89 @@
|
|||
use Sub::Install qw(reinstall_sub);
|
||||
use Test::More tests => 15;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# These tests largely copied from Damian Conway's Sub::Installer tests.
|
||||
|
||||
{ # Install a sub in a package...
|
||||
|
||||
my $sub_ref = reinstall_sub({ code => \&ok, as => 'ok1' });
|
||||
|
||||
isa_ok($sub_ref, 'CODE', 'return value of first install_sub');
|
||||
|
||||
is_deeply($sub_ref, \&Test::More::ok, 'it returned the right coderef');
|
||||
|
||||
$sub_ref->(1, 'returned code ref runs');
|
||||
ok1(1, "reinstalled 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::reinstall_sub({ code => \&ok, as => 'tmp_ok' });
|
||||
|
||||
my $expected_warning = <<'END_WARNING';
|
||||
Prototype mismatch: sub main::tmp_ok ($;$) vs ($$;$) at t/reinstall.t line 32
|
||||
END_WARNING
|
||||
|
||||
my $stderr = Test::Output::stderr_from(
|
||||
sub { Sub::Install::reinstall_sub({ code => \&is, as => 'tmp_ok' }) }
|
||||
);
|
||||
|
||||
$stderr =~ s!\\!/!g;
|
||||
$stderr =~ s!\.$!!g;
|
||||
is(
|
||||
$stderr,
|
||||
$expected_warning,
|
||||
"got expected warning",
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
{ # Install the same sub in the same package...
|
||||
my $proto = 0;
|
||||
|
||||
local $SIG{__WARN__} = sub {
|
||||
return ($proto = 1) if $_[0] =~ m{Prototype mismatch.+t.reinstall\.t};
|
||||
die "unexpected warning: @_";
|
||||
};
|
||||
|
||||
my $sub_ref = reinstall_sub({ code => \&is, as => 'ok1' });
|
||||
|
||||
ok($proto, 'correct warning went to $SIG{__WARN__}');
|
||||
|
||||
isa_ok($sub_ref, 'CODE', 'return value of second install_sub');
|
||||
|
||||
is_deeply($sub_ref, \&Test::More::is, 'it returned the right coderef');
|
||||
|
||||
$sub_ref->(1, 1, 'returned code ref runs');
|
||||
ok1(1,1, 'reinstalled sub reruns');
|
||||
}
|
||||
|
||||
{ # Install in another package...
|
||||
my $new_code = sub { ok(1, "remotely installed sub runs") };
|
||||
|
||||
my $sub_ref = reinstall_sub({
|
||||
code => $new_code,
|
||||
into => 'Other',
|
||||
as => 'ok1',
|
||||
});
|
||||
|
||||
isa_ok($sub_ref, 'CODE', 'return value of third install_sub');
|
||||
|
||||
is_deeply($sub_ref, $new_code, 'it returned the right coderef');
|
||||
|
||||
ok1(1,1, 'reinstalled sub reruns');
|
||||
|
||||
package Other;
|
||||
ok1();
|
||||
}
|
||||
|
||||
eval {
|
||||
my $arg = { code => sub {}, into => 'Other', as => 'ok1' };
|
||||
Sub::Install::_build_public_installer(\&Sub::Install::_install_fatal)->($arg);
|
||||
};
|
||||
|
||||
like($@, qr/redefine/, "(experimental fatal installer should croak)");
|
||||
Loading…
Reference in New Issue