r2686 - in /packages/libsub-install-perl: ./ branches/
branches/upstream/
branches/upstream/current/ branches/upstream/current/lib/
branches/upstream/current/lib/Sub/ branches/upstream/current/t/ tags/
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Sat May 6 13:37:31 UTC 2006
Author: eloy
Date: Sat May 6 13:37:30 2006
New Revision: 2686
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=2686
Log:
[svn-inject] Installing original source of libsub-install-perl
Added:
packages/libsub-install-perl/
packages/libsub-install-perl/branches/
packages/libsub-install-perl/branches/upstream/
packages/libsub-install-perl/branches/upstream/current/
packages/libsub-install-perl/branches/upstream/current/Changes
packages/libsub-install-perl/branches/upstream/current/MANIFEST
packages/libsub-install-perl/branches/upstream/current/META.yml
packages/libsub-install-perl/branches/upstream/current/Makefile.PL
packages/libsub-install-perl/branches/upstream/current/README
packages/libsub-install-perl/branches/upstream/current/lib/
packages/libsub-install-perl/branches/upstream/current/lib/Sub/
packages/libsub-install-perl/branches/upstream/current/lib/Sub/Install.pm
packages/libsub-install-perl/branches/upstream/current/t/
packages/libsub-install-perl/branches/upstream/current/t/00-load.t
packages/libsub-install-perl/branches/upstream/current/t/SI_install.t
packages/libsub-install-perl/branches/upstream/current/t/SI_reinstall.t
packages/libsub-install-perl/branches/upstream/current/t/auto_as.t
packages/libsub-install-perl/branches/upstream/current/t/inst-blessed.t
packages/libsub-install-perl/branches/upstream/current/t/install.t
packages/libsub-install-perl/branches/upstream/current/t/misc_errors.t
packages/libsub-install-perl/branches/upstream/current/t/pod-coverage.t
packages/libsub-install-perl/branches/upstream/current/t/pod.t
packages/libsub-install-perl/branches/upstream/current/t/reinstall.t
packages/libsub-install-perl/tags/
Added: packages/libsub-install-perl/branches/upstream/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/Changes?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/Changes (added)
+++ packages/libsub-install-perl/branches/upstream/current/Changes Sat May 6 13:37:30 2006
@@ -1,0 +1,23 @@
+Revision history for Sub-Install
+
+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
+
Added: packages/libsub-install-perl/branches/upstream/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/MANIFEST?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/MANIFEST (added)
+++ packages/libsub-install-perl/branches/upstream/current/MANIFEST Sat May 6 13:37:30 2006
@@ -1,0 +1,16 @@
+Changes
+lib/Sub/Install.pm
+Makefile.PL
+MANIFEST
+README
+t/00-load.t
+t/auto_as.t
+t/install.t
+t/inst-blessed.t
+t/misc_errors.t
+t/pod-coverage.t
+t/pod.t
+t/reinstall.t
+t/SI_install.t
+t/SI_reinstall.t
+META.yml Module meta-data (added by MakeMaker)
Added: packages/libsub-install-perl/branches/upstream/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/META.yml?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/META.yml (added)
+++ packages/libsub-install-perl/branches/upstream/current/META.yml Sat May 6 13:37:30 2006
@@ -1,0 +1,12 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Sub-Install
+version: 0.91
+version_from: lib/Sub/Install.pm
+installdirs: site
+requires:
+ Scalar::Util: 0
+ Test::More: 0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.30
Added: packages/libsub-install-perl/branches/upstream/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/Makefile.PL?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/Makefile.PL (added)
+++ packages/libsub-install-perl/branches/upstream/current/Makefile.PL Sat May 6 13:37:30 2006
@@ -1,0 +1,17 @@
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'Sub::Install',
+ AUTHOR => 'Ricardo Signes <rjbs at cpan.org>',
+ VERSION_FROM => 'lib/Sub/Install.pm',
+ ABSTRACT_FROM => 'lib/Sub/Install.pm',
+ PL_FILES => {},
+ PREREQ_PM => {
+ 'Scalar::Util' => 0,
+ 'Test::More' => 0,
+ },
+ dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+ clean => { FILES => 'Sub-Install-* cover_db' },
+);
Added: packages/libsub-install-perl/branches/upstream/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/README?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/README (added)
+++ packages/libsub-install-perl/branches/upstream/current/README Sat May 6 13:37:30 2006
@@ -1,0 +1,6 @@
+Sub-Install
+
+This module provides a simple routine for installing code into packages without
+looking at typeglobs or thinking about warnings or strictures.
+
+It also doesn't muddy up UNIVERSAL.
Added: packages/libsub-install-perl/branches/upstream/current/lib/Sub/Install.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/lib/Sub/Install.pm?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/lib/Sub/Install.pm (added)
+++ packages/libsub-install-perl/branches/upstream/current/lib/Sub/Install.pm Sat May 6 13:37:30 2006
@@ -1,0 +1,316 @@
+package Sub::Install;
+
+use warnings;
+use strict;
+
+use Carp qw(croak);
+use Scalar::Util ();
+
+=head1 NAME
+
+Sub::Install - install subroutines into packages easily
+
+=head1 VERSION
+
+version 0.91
+
+ $Id: /my/rjbs/subinst/trunk/lib/Sub/Install.pm 16622 2005-11-23T00:17:55.304991Z rjbs $
+
+=cut
+
+our $VERSION = '0.91';
+
+=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
+unslightly mess of C<no strict> or typeglobs lying about where just anyone can
+see them.
+
+=head1 FUNCTIONS
+
+=head2 C< 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',
+ });
+
+=head2 C< 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;
+}
+
+sub _CALLABLE {
+ (Scalar::Util::reftype($_[0])||'') eq 'CODE' or Scalar::Util::blessed($_[0])
+ and 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.
+ croak "named argument 'code' is not optional" unless $arg->{code};
+
+ if (_CALLABLE($arg->{code})) {
+ $arg->{as} ||= _name_of_code($arg->{code});
+ } else {
+ 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;
+ }
+
+ 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 \S+ redefined
+ /x;
+ $_redef_warn_re = qr/Subroutine\ \S+\ 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 @_ };
+ 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);
+ last;
+ }
+ }
+ ($arg->{default} || $warn)->($error);
+ };
+ $code->(@_);
+ };
+ };
+ return $wants_code->($code) if $code;
+ return $wants_code;
+}
+
+sub _installer {
+ sub {
+ my ($pkg, $name, $code) = @_;
+ no strict 'refs';
+ *{"$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 ],
+ });
+}
+
+=head2 C< 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.
+
+=cut
+
+my @EXPORT_OK;
+BEGIN { @EXPORT_OK = qw(install_sub reinstall_sub); }
+
+sub import {
+ my $class = shift;
+ my %todo = map { $_ => 1 } @_;
+ my ($target) = caller(0);
+
+ # eating my own dogfood
+ install_sub({ code => $_, into => $target }) for grep {$todo{$_}} @EXPORT_OK;
+}
+
+=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 AUTHOR
+
+Ricardo Signes, C<< <rjbs at cpan.org> >>
+
+Several of the tests are adapted from tests that shipped with Damian Conway's
+Sub-Installer distribution.
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-sub-install at rt.cpan.org>,
+or through the web interface at L<http://rt.cpan.org>. I will be notified, and
+then you'll automatically be notified of progress on your bug as I make
+changes.
+
+=head1 COPYRIGHT
+
+Copyright 2005-2006 Ricardo Signes, All Rights Reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
Added: packages/libsub-install-perl/branches/upstream/current/t/00-load.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/t/00-load.t?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/t/00-load.t (added)
+++ packages/libsub-install-perl/branches/upstream/current/t/00-load.t Sat May 6 13:37:30 2006
@@ -1,0 +1,7 @@
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok('Sub::Install');
+}
+
+diag( "Testing Sub::Install $Sub::Install::VERSION" );
Added: packages/libsub-install-perl/branches/upstream/current/t/SI_install.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/t/SI_install.t?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/t/SI_install.t (added)
+++ packages/libsub-install-perl/branches/upstream/current/t/SI_install.t Sat May 6 13:37:30 2006
@@ -1,0 +1,46 @@
+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 warnings;
+
+# Install a sub in a package...
+
+my $sub_ref = main->install_sub({ ok1 => \&ok });
+
+is ref $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 ref $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 ref $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');
Added: packages/libsub-install-perl/branches/upstream/current/t/SI_reinstall.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/t/SI_reinstall.t?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/t/SI_reinstall.t (added)
+++ packages/libsub-install-perl/branches/upstream/current/t/SI_reinstall.t Sat May 6 13:37:30 2006
@@ -1,0 +1,45 @@
+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 warnings;
+
+# Install a sub in a package...
+
+my $sub_ref = main->reinstall_sub({ ok1 => \&ok });
+
+is ref $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 ref $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 ref $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');
Added: packages/libsub-install-perl/branches/upstream/current/t/auto_as.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/t/auto_as.t?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/t/auto_as.t (added)
+++ packages/libsub-install-perl/branches/upstream/current/t/auto_as.t Sat May 6 13:37:30 2006
@@ -1,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"
+ );
+}
Added: packages/libsub-install-perl/branches/upstream/current/t/inst-blessed.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/t/inst-blessed.t?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/t/inst-blessed.t (added)
+++ packages/libsub-install-perl/branches/upstream/current/t/inst-blessed.t Sat May 6 13:37:30 2006
@@ -1,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");
+
Added: packages/libsub-install-perl/branches/upstream/current/t/install.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/t/install.t?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/t/install.t (added)
+++ packages/libsub-install-perl/branches/upstream/current/t/install.t Sat May 6 13:37:30 2006
@@ -1,0 +1,106 @@
+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
+
+ stderr_is(
+ sub { Sub::Install::install_sub({ code => \&is, as => 'tmp_ok' }) },
+ $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',
+ );
+}
Added: packages/libsub-install-perl/branches/upstream/current/t/misc_errors.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/t/misc_errors.t?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/t/misc_errors.t (added)
+++ packages/libsub-install-perl/branches/upstream/current/t/misc_errors.t Sat May 6 13:37:30 2006
@@ -1,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");
+}
Added: packages/libsub-install-perl/branches/upstream/current/t/pod-coverage.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/t/pod-coverage.t?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/t/pod-coverage.t (added)
+++ packages/libsub-install-perl/branches/upstream/current/t/pod-coverage.t Sat May 6 13:37:30 2006
@@ -1,0 +1,5 @@
+use Test::More;
+eval "use Test::Pod::Coverage 1.06";
+plan skip_all => "Test::Pod::Coverage 1.06 required for testing POD coverage"
+ if $@;
+all_pod_coverage_ok();
Added: packages/libsub-install-perl/branches/upstream/current/t/pod.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/t/pod.t?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/t/pod.t (added)
+++ packages/libsub-install-perl/branches/upstream/current/t/pod.t Sat May 6 13:37:30 2006
@@ -1,0 +1,5 @@
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD"
+ if $@;
+all_pod_files_ok();
Added: packages/libsub-install-perl/branches/upstream/current/t/reinstall.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsub-install-perl/branches/upstream/current/t/reinstall.t?rev=2686&op=file
==============================================================================
--- packages/libsub-install-perl/branches/upstream/current/t/reinstall.t (added)
+++ packages/libsub-install-perl/branches/upstream/current/t/reinstall.t Sat May 6 13:37:30 2006
@@ -1,0 +1,83 @@
+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
+
+ stderr_is(
+ sub { Sub::Install::reinstall_sub({ code => \&is, as => 'tmp_ok' }) },
+ $expected_warning,
+ "correct warnings went out STDERR",
+ );
+ }
+}
+
+{ # 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)");
More information about the Pkg-perl-cvs-commits
mailing list