r55222 - in /branches/upstream/libsub-override-perl: ./ current/ current/lib/ current/lib/Sub/ current/t/
ansgar-guest at users.alioth.debian.org
ansgar-guest at users.alioth.debian.org
Thu Apr 1 11:24:52 UTC 2010
Author: ansgar-guest
Date: Thu Apr 1 11:24:39 2010
New Revision: 55222
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=55222
Log:
[svn-inject] Installing original source of libsub-override-perl
Added:
branches/upstream/libsub-override-perl/
branches/upstream/libsub-override-perl/current/
branches/upstream/libsub-override-perl/current/Changes
branches/upstream/libsub-override-perl/current/MANIFEST
branches/upstream/libsub-override-perl/current/META.yml
branches/upstream/libsub-override-perl/current/Makefile.PL
branches/upstream/libsub-override-perl/current/README
branches/upstream/libsub-override-perl/current/lib/
branches/upstream/libsub-override-perl/current/lib/Sub/
branches/upstream/libsub-override-perl/current/lib/Sub/Override.pm
branches/upstream/libsub-override-perl/current/t/
branches/upstream/libsub-override-perl/current/t/10override.t
branches/upstream/libsub-override-perl/current/t/pod-coverage.t
branches/upstream/libsub-override-perl/current/t/pod.t
Added: branches/upstream/libsub-override-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsub-override-perl/current/Changes?rev=55222&op=file
==============================================================================
--- branches/upstream/libsub-override-perl/current/Changes (added)
+++ branches/upstream/libsub-override-perl/current/Changes Thu Apr 1 11:24:39 2010
@@ -1,0 +1,29 @@
+Revision history for Perl extension Sub::Override.
+
+0.08 Wed Sep 21 2005
+ Remembered to update Changes file. Grr. I really need a
+ "lint" script which can check to see if I've forgotten
+ stupid things.
+
+0.07 Wed Sep 21 2005
+ Added dependency on Sub::Uplevel even though I don't use
+ it. Tests keep failing for folks because of it.
+ Added pod tests.
+ Added "override" as a synonym for "replace".
+
+0.06 Fri Dec 3 2003
+ - Ensure that restore() always restores the sub to its
+ original state. This allows a subroutine to be safely
+ overridden multiple times.
+
+0.05 Tue Aug 24 2004
+ - Removed accidental dependency on Data::Dumper::Simple
+
+0.04 Mon Aug 23 2004
+ - Fixed bug where explicitly restoring subs whose names were
+ not fully qualified would fail.
+
+0.01 Mon May 24 09:44:31 2004
+ - original version; created by h2xs 1.23 with options
+ -AX -n Sub::Override
+
Added: branches/upstream/libsub-override-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsub-override-perl/current/MANIFEST?rev=55222&op=file
==============================================================================
--- branches/upstream/libsub-override-perl/current/MANIFEST (added)
+++ branches/upstream/libsub-override-perl/current/MANIFEST Thu Apr 1 11:24:39 2010
@@ -1,0 +1,9 @@
+Changes
+lib/Sub/Override.pm
+Makefile.PL
+MANIFEST
+META.yml Module meta-data (added by MakeMaker)
+README
+t/10override.t
+t/pod-coverage.t
+t/pod.t
Added: branches/upstream/libsub-override-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsub-override-perl/current/META.yml?rev=55222&op=file
==============================================================================
--- branches/upstream/libsub-override-perl/current/META.yml (added)
+++ branches/upstream/libsub-override-perl/current/META.yml Thu Apr 1 11:24:39 2010
@@ -1,0 +1,13 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Sub-Override
+version: 0.08
+version_from: lib/Sub/Override.pm
+installdirs: site
+requires:
+ Sub::Uplevel: 0
+ Test::Exception: 0.21
+ Test::More: 0.47
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: branches/upstream/libsub-override-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsub-override-perl/current/Makefile.PL?rev=55222&op=file
==============================================================================
--- branches/upstream/libsub-override-perl/current/Makefile.PL (added)
+++ branches/upstream/libsub-override-perl/current/Makefile.PL Thu Apr 1 11:24:39 2010
@@ -1,0 +1,18 @@
+use 5.006;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ NAME => 'Sub::Override',
+ VERSION_FROM => 'lib/Sub/Override.pm', # finds $VERSION
+ PREREQ_PM => {
+ 'Test::More' => .47,
+ 'Test::Exception' => .21,
+ 'Sub::Uplevel' => 0, # because I'm sick of bogus test failures
+ },
+ ($] >= 5.005 ?
+ (ABSTRACT_FROM => 'lib/Sub/Override.pm',
+ AUTHOR => 'Curtis Poe <eop_divo_sitruc at yahoo.com>') : ()),
+);
+
+# reverse the email name to get my email address
Added: branches/upstream/libsub-override-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsub-override-perl/current/README?rev=55222&op=file
==============================================================================
--- branches/upstream/libsub-override-perl/current/README (added)
+++ branches/upstream/libsub-override-perl/current/README Thu Apr 1 11:24:39 2010
@@ -1,0 +1,27 @@
+Sub-Override version 0.01
+=========================
+
+INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+ None
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2004 by Curtis Poe
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.2 or,
+at your option, any later version of Perl 5 you may have available.
+
+
Added: branches/upstream/libsub-override-perl/current/lib/Sub/Override.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsub-override-perl/current/lib/Sub/Override.pm?rev=55222&op=file
==============================================================================
--- branches/upstream/libsub-override-perl/current/lib/Sub/Override.pm (added)
+++ branches/upstream/libsub-override-perl/current/lib/Sub/Override.pm Thu Apr 1 11:24:39 2010
@@ -1,0 +1,302 @@
+package Sub::Override;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.08';
+
+my $_croak = sub {
+ local *__ANON__ = '__ANON__croak';
+ my ( $proto, $message ) = @_;
+ require Carp;
+ Carp::croak($message);
+};
+
+my $_validate_code_slot = sub {
+ local *__ANON__ = '__ANON__validate_code_slot';
+ my ( $self, $code_slot ) = @_;
+ no strict 'refs';
+ unless ( defined *{$code_slot}{CODE} ) {
+ $self->$_croak("Cannot replace non-existent sub ($code_slot)");
+ }
+ return $self;
+};
+
+my $_validate_sub_ref = sub {
+ local *__ANON__ = '__ANON__validate_sub_ref';
+ my ( $self, $sub_ref ) = @_;
+ unless ( 'CODE' eq ref $sub_ref ) {
+ $self->$_croak("($sub_ref) must be a code reference");
+ }
+ return $self;
+};
+
+my $_normalize_sub_name = sub {
+ local *__ANON__ = '__ANON__normalize_sub_name';
+ my ( $self, $subname ) = @_;
+ if ( ( $subname || '' ) =~ /^\w+$/ ) { # || "" for suppressing test warnings
+ my $package = do {
+ my $call_level = 0;
+ my $this_package;
+ while ( !$this_package || __PACKAGE__ eq $this_package ) {
+ ($this_package) = caller($call_level);
+ $call_level++;
+ }
+ $this_package;
+ };
+ $subname = "${package}::$subname";
+ }
+ return $subname;
+};
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ $self->replace(@_) if @_;
+ return $self;
+}
+
+# because override() was a better name and this is what it should have been
+# called.
+*override = *replace{CODE};
+
+sub replace {
+ my ( $self, $sub_to_replace, $new_sub ) = @_;
+ $sub_to_replace = $self->$_normalize_sub_name($sub_to_replace);
+ $self->$_validate_code_slot($sub_to_replace)->$_validate_sub_ref($new_sub);
+ {
+ no strict 'refs';
+ $self->{$sub_to_replace} ||= *$sub_to_replace{CODE};
+ no warnings 'redefine';
+ *$sub_to_replace = $new_sub;
+ }
+ return $self;
+}
+
+sub restore {
+ my ( $self, $name_of_sub ) = @_;
+ $name_of_sub = $self->$_normalize_sub_name($name_of_sub);
+ if ( !$name_of_sub && 1 == keys %$self ) {
+ ($name_of_sub) = keys %$self;
+ }
+ $self->$_croak(
+ sprintf 'You must provide the name of a sub to restore: (%s)' => join
+ ', ' => sort keys %$self )
+ unless $name_of_sub;
+ $self->$_croak("Cannot restore a sub that was not replaced ($name_of_sub)")
+ unless exists $self->{$name_of_sub};
+ no strict 'refs';
+ no warnings 'redefine';
+ *$name_of_sub = delete $self->{$name_of_sub};
+ return $self;
+}
+
+sub DESTROY {
+ my $self = shift;
+ no strict 'refs';
+ no warnings 'redefine';
+ while ( my ( $sub_name, $sub_ref ) = each %$self ) {
+ *$sub_name = $sub_ref;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Sub::Override - Perl extension for easily overriding subroutines
+
+=head1 SYNOPSIS
+
+ use Sub::Override;
+
+ sub foo { 'original sub' };
+ print foo(); # prints 'original sub'
+
+ my $override = Sub::Override->new( foo => sub { 'overridden sub' } );
+ print foo(); # prints 'overridden sub'
+ $override->restore;
+ print foo(); # prints 'original sub'
+
+=head1 DESCRIPTION
+
+=head2 The Problem
+
+Sometimes subroutines need to be overridden. In fact, your author does this
+constantly for tests. Particularly when testing, using a Mock Object can be
+overkill when all you want to do is override one tiny, little function.
+
+Overriding a subroutine is often done with syntax similar to the following.
+
+ {
+ local *Some::sub = sub {'some behavior'};
+ # do something
+ }
+ # original subroutine behavior restored
+
+This has a few problems.
+
+ {
+ local *Get::some_feild = { 'some behavior' };
+ # do something
+ }
+
+In the above example, not only have we probably mispelled the subroutine name,
+but even if their had been a subroutine with that name, we haven't overridden
+it. These two bugs can be subtle to detect.
+
+Further, if we're attempting to localize the effect by placing this code in a
+block, the entire construct is cumbersome.
+
+Hook::LexWrap also allows us to override sub behavior, but I can never remember
+the exact syntax.
+
+=head2 An easier way to replace subroutines
+
+Instead, C<Sub::Override> allows the programmer to simply name the sub to
+replace and to supply a sub to replace it with.
+
+ my $override = Sub::Override->new('Some::sub', sub {'new data'});
+
+ # which is equivalent to:
+ my $override = Sub::Override->new;
+ $override->replace('Some::sub', sub { 'new data' });
+
+You can replace multiple subroutines, if needed:
+
+ $override->replace('Some::sub1', sub { 'new data1' });
+ $override->replace('Some::sub2', sub { 'new data2' });
+ $override->replace('Some::sub3', sub { 'new data3' });
+
+If replacing the subroutine succeeds, the object is returned. This allows the
+programmer to chain the calls, if this style of programming is preferred:
+
+ $override->replace('Some::sub1', sub { 'new data1' })
+ ->replace('Some::sub2', sub { 'new data2' })
+ ->replace('Some::sub3', sub { 'new data3' });
+
+A subroutine may be replaced as many times as desired. This is most useful
+when testing how code behaves with multiple conditions.
+
+ $override->replace('Some::thing', sub { 0 });
+ is($object->foo, 'wibble', 'wibble is returned if Some::thing is false');
+
+ $override->replace('Some::thing', sub { 1 });
+ is($object->foo, 'puppies', 'puppies are returned if Some::thing is true');
+
+=head2 Restoring subroutines
+
+If the object falls out of scope, the original subs are restored. However, if
+you need to restore a subroutine early, just use the restore method:
+
+ my $override = Sub::Override->new('Some::sub', sub {'new data'});
+ # do stuff
+ $override->restore;
+
+Which is somewhat equivalent to:
+
+ {
+ my $override = Sub::Override->new('Some::sub', sub {'new data'});
+ # do stuff
+ }
+
+If you have override more than one subroutine with an override object, you
+will have to explicitly name the subroutine you wish to restore:
+
+ $override->restore('This::sub');
+
+Note C<restore()> will always restore the original behavior of the subroutine
+no matter how many times you have overridden it.
+
+=head2 Which package is the subroutine in?
+
+Ordinarily, you want to fully qualify the subroutine by including the package
+name. However, failure to fully qualify the subroutine name will assume the
+current package.
+
+ package Foo;
+ use Sub::Override;
+ sub foo { 23 };
+ my $override = Sub::Override->new( foo => sub { 42 } ); # assumes Foo::foo
+ print foo(); # prints 42
+ $override->restore;
+ print foo(); # prints 23
+
+=head1 METHODS
+
+=head2 new
+
+ my $sub = Sub::Override->new;
+ my $sub = Sub::Override->new($sub_name, $sub_ref);
+
+Creates a new C<Sub::Override> instance. Optionally, you may override a
+subroutine while creating a new object.
+
+=head2 replace
+
+ $sub->replace($sub_name, $sub_body);
+
+Temporarily replaces a subroutine with another subroutine. Returns the
+instance, so chaining the method is allowed:
+
+ $sub->replace($sub_name, $sub_body)
+ ->replace($another_sub, $another_body);
+
+This method will C<croak> is the subroutine to be replaced does not exist.
+
+=head2 override
+
+ my $sub = Sub::Override->new;
+ $sub->override($sub_name, $sub_body);
+
+C<override> is an alternate name for C<replace>. They are the same method.
+
+=cut
+
+=head2 restore
+
+ $sub->restore($sub_name);
+
+Restores the previous behavior of the subroutine. This will happen
+automatically if the C<Sub::Override> object falls out of scope.
+
+=cut
+
+=head1 EXPORT
+
+None by default.
+
+=head1 BUGS
+
+Probably. Tell me about 'em.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item *
+Hook::LexWrap -- can also override subs, but with different capabilities
+
+=item *
+Test::MockObject -- use this if you need to alter an entire class
+
+=back
+
+=head1 AUTHOR
+
+Curtis "Ovid" Poe, C<< <ovid [at] cpan [dot] org> >>
+
+Reverse the name to email me.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2004-2005 by Curtis "Ovid" Poe
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.2 or,
+at your option, any later version of Perl 5 you may have available.
+
+
+=cut
Added: branches/upstream/libsub-override-perl/current/t/10override.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsub-override-perl/current/t/10override.t?rev=55222&op=file
==============================================================================
--- branches/upstream/libsub-override-perl/current/t/10override.t (added)
+++ branches/upstream/libsub-override-perl/current/t/10override.t Thu Apr 1 11:24:39 2010
@@ -1,0 +1,114 @@
+#!/usr/local/bin/perl -w
+use strict;
+#use Test::More 'no_plan';
+use Test::More tests => 28;
+use Test::Exception;
+
+my $CLASS;
+
+{
+ package Foo;
+
+ sub bar {
+ return 'original value';
+ }
+
+ sub baz {
+ return 'original baz value';
+ }
+}
+
+BEGIN {
+ chdir 't' if -d 't';
+ use lib '../lib';
+ $CLASS = 'Sub::Override';
+ use_ok($CLASS) || die;
+}
+
+can_ok($CLASS, 'new');
+
+my $override = $CLASS->new;
+isa_ok($override, $CLASS, '... and the object it returns');
+
+can_ok($override, 'replace');
+
+throws_ok { $override->replace('No::Such::Sub', '') }
+ qr/^\QCannot replace non-existent sub (No::Such::Sub)\E/,
+ "... and we can't replace a sub which doesn't exist";
+
+throws_ok { $override->replace('Foo::bar', 'not a subref') }
+ qr/\(not a subref\) must be a code reference/,
+ '... and only a code reference may replace a subroutine';
+
+ok($override->replace('Foo::bar', sub { 'new subroutine' }),
+ '... and replacing a subroutine should succeed');
+is(Foo::bar(), 'new subroutine',
+ '... and the subroutine should exhibit the new behavior');
+
+ok($override->replace('Foo::bar' => sub { 'new subroutine 2' }),
+ '... and we should be able to replace a sub more than once');
+is(Foo::bar(), 'new subroutine 2',
+ '... and still have the sub exhibit the new behavior');
+
+can_ok($override, 'override');
+ok($override->override('Foo::bar' => sub { 'new subroutine 3' }),
+ '... and it should also replace a subroutine');
+is(Foo::bar(), 'new subroutine 3',
+ '... and act just like replace()');
+
+can_ok($override, 'restore');
+
+throws_ok { $override->restore('Did::Not::Override') }
+ qr/^\QCannot restore a sub that was not replaced (Did::Not::Override)/,
+ '... and it should fail if the subroutine had not been replaced';
+
+$override->restore('Foo::bar');
+is(Foo::bar(), 'original value',
+ '... and the subroutine should exhibit the original behavior');
+
+throws_ok { $override->restore('Foo::bar') }
+ qr/^\QCannot restore a sub that was not replaced (Foo::bar)/,
+ '... but we should not be able to restore it twice';
+
+{
+ my $new_override = $CLASS->new;
+ ok($new_override->replace('Foo::bar', sub { 'lexical value' }),
+ 'A new override object should be able to replace a subroutine');
+
+ is(Foo::bar(), 'lexical value',
+ '... and the subroutine should exhibit the new behavior');
+}
+is(Foo::bar(), 'original value',
+ '... but should revert to the original behavior when the object falls out of scope');
+
+{
+ my $new_override = $CLASS->new('Foo::bar', sub { 'lexical value' });
+ ok($new_override, 'We should be able to override a sub from the constructor');
+
+ is(Foo::bar(), 'lexical value',
+ '... and the subroutine should exhibit the new behavior');
+ ok($new_override->restore,
+ '... and we do not need an argument to restore if only one sub is overridden');
+ is(Foo::bar(), 'original value',
+ '... and the subroutine should exhibit its original behavior');
+ $new_override->replace('Foo::bar', sub {});
+ $new_override->replace('Foo::baz', sub {});
+ throws_ok { $new_override->restore }
+ qr/You must provide the name of a sub to restore: \(Foo::bar, Foo::baz\)/,
+ '... but we must explicitly provide the sub name if more than one was replaced';
+}
+
+{
+ package Temp;
+ sub foo { 23 }
+ sub bar { 42 }
+
+ my $override = Sub::Override->new('foo', sub { 42 });
+ $override->replace('bar', sub { 'barbar' });
+ main::is(foo(), 42, 'Not fully qualifying a sub name will assume the current package');
+ $override->restore('foo');
+ main::is(foo(), 23, '... and we should be able to restore said sub');
+
+ $override->restore('Temp::bar');
+ main::is(bar(), 42, '... even if we use a full qualified sub name');
+}
Added: branches/upstream/libsub-override-perl/current/t/pod-coverage.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsub-override-perl/current/t/pod-coverage.t?rev=55222&op=file
==============================================================================
--- branches/upstream/libsub-override-perl/current/t/pod-coverage.t (added)
+++ branches/upstream/libsub-override-perl/current/t/pod-coverage.t Thu Apr 1 11:24:39 2010
@@ -1,0 +1,7 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+all_pod_coverage_ok();
+
Added: branches/upstream/libsub-override-perl/current/t/pod.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsub-override-perl/current/t/pod.t?rev=55222&op=file
==============================================================================
--- branches/upstream/libsub-override-perl/current/t/pod.t (added)
+++ branches/upstream/libsub-override-perl/current/t/pod.t Thu Apr 1 11:24:39 2010
@@ -1,0 +1,6 @@
+#!perl -T
+
+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();
More information about the Pkg-perl-cvs-commits
mailing list