r50508 - in /trunk/libaspect-perl: ./ debian/ lib/ lib/Aspect/ lib/Aspect/Advice/ lib/Aspect/Library/ lib/Aspect/Library/Listenable/ lib/Aspect/Pointcut/ t/ xt/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Fri Jan 8 14:29:48 UTC 2010
Author: jawnsy-guest
Date: Fri Jan 8 14:29:40 2010
New Revision: 50508
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=50508
Log:
New upstream release
Added:
trunk/libaspect-perl/t/21_advice_around.t
- copied unchanged from r50506, branches/upstream/libaspect-perl/current/t/21_advice_around.t
trunk/libaspect-perl/t/23_advice_before.t
- copied unchanged from r50506, branches/upstream/libaspect-perl/current/t/23_advice_before.t
trunk/libaspect-perl/t/24_advice_after.t
- copied unchanged from r50506, branches/upstream/libaspect-perl/current/t/24_advice_after.t
Removed:
trunk/libaspect-perl/t/21_advice.t
trunk/libaspect-perl/xt/kwalitee.t
trunk/libaspect-perl/xt/perl_critic.t
trunk/libaspect-perl/xt/perlcriticrc
trunk/libaspect-perl/xt/pod_coverage.t
Modified:
trunk/libaspect-perl/Changes
trunk/libaspect-perl/MANIFEST
trunk/libaspect-perl/META.yml
trunk/libaspect-perl/debian/changelog
trunk/libaspect-perl/lib/Aspect.pm
trunk/libaspect-perl/lib/Aspect/Advice.pm
trunk/libaspect-perl/lib/Aspect/Advice/After.pm
trunk/libaspect-perl/lib/Aspect/Advice/Around.pm
trunk/libaspect-perl/lib/Aspect/Advice/Before.pm
trunk/libaspect-perl/lib/Aspect/AdviceContext.pm
trunk/libaspect-perl/lib/Aspect/Library/Listenable.pm
trunk/libaspect-perl/lib/Aspect/Library/Listenable/Event.pm
trunk/libaspect-perl/lib/Aspect/Library/Singleton.pm
trunk/libaspect-perl/lib/Aspect/Library/Wormhole.pm
trunk/libaspect-perl/lib/Aspect/Modular.pm
trunk/libaspect-perl/lib/Aspect/Pointcut.pm
trunk/libaspect-perl/lib/Aspect/Pointcut/AndOp.pm
trunk/libaspect-perl/lib/Aspect/Pointcut/Call.pm
trunk/libaspect-perl/lib/Aspect/Pointcut/Cflow.pm
trunk/libaspect-perl/lib/Aspect/Pointcut/NotOp.pm
trunk/libaspect-perl/lib/Aspect/Pointcut/OrOp.pm
trunk/libaspect-perl/t/01_compile.t
trunk/libaspect-perl/t/02_advice_context.t
trunk/libaspect-perl/t/11_pointcut_call.t
trunk/libaspect-perl/t/22_advice_around.t
trunk/libaspect-perl/t/33_feature_exception.t
trunk/libaspect-perl/t/listenable.t
trunk/libaspect-perl/t/singleton.t
trunk/libaspect-perl/t/wormhole.t
Modified: trunk/libaspect-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/Changes?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/Changes (original)
+++ trunk/libaspect-perl/Changes Fri Jan 8 14:29:40 2010
@@ -1,4 +1,15 @@
Revision history for Perl extension Aspect
+
+0.33 Fri 8 Jan 2010 - Adam Kennedy
+ - Added Test::NoWarnings to all of the tests
+ - Refactoring advice testing into one test per advice type
+ - Testing now covers more combinations of cases, including for around()
+ - Fixed bug in return values for listwise before () calls
+ - Calls to run_original for advice called in void context now
+ correctly runs the underlying hooked method in void context as well.
+ - When called in after() or around() advice, proceed will throw an
+ exception.
+ - Removed some of the author tests I don't care about as much.
0.32 Thu 7 Jan 2010 - Adam Kennedy
- The actual term "forever" is meaningless. Reversed the flag to
Modified: trunk/libaspect-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/MANIFEST?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/MANIFEST (original)
+++ trunk/libaspect-perl/MANIFEST Fri Jan 8 14:29:40 2010
@@ -41,8 +41,10 @@
t/02_advice_context.t
t/11_pointcut_call.t
t/12_pointcut_cflow.t
-t/21_advice.t
+t/21_advice_around.t
t/22_advice_around.t
+t/23_advice_before.t
+t/24_advice_after.t
t/31_feature_caller.t
t/32_feature_wantarray.t
t/33_feature_exception.t
@@ -55,11 +57,7 @@
t/singleton.t
t/wormhole.t
xt/compile.t
-xt/kwalitee.t
-xt/perl_critic.t
-xt/perlcriticrc
xt/pod.t
-xt/pod_coverage.t
xt/podspell.t
xt/portability_files.t
xt/synopsis.t
Modified: trunk/libaspect-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/META.yml?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/META.yml (original)
+++ trunk/libaspect-perl/META.yml Fri Jan 8 14:29:40 2010
@@ -32,4 +32,4 @@
ChangeLog: http://fisheye2.atlassian.com/changelog/cpan/trunk/Aspect
license: http://dev.perl.org/licenses/
repository: http://svn.ali.as/cpan/trunk/Aspect
-version: 0.32
+version: 0.33
Modified: trunk/libaspect-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/debian/changelog?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/debian/changelog (original)
+++ trunk/libaspect-perl/debian/changelog Fri Jan 8 14:29:40 2010
@@ -1,3 +1,9 @@
+libaspect-perl (0.33-1) UNRELEASED; urgency=low
+
+ * New upstream release
+
+ -- Jonathan Yu <jawnsy at cpan.org> Fri, 08 Jan 2010 09:30:22 -0500
+
libaspect-perl (0.32-1) unstable; urgency=low
[ Jonathan Yu ]
Modified: trunk/libaspect-perl/lib/Aspect.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect.pm (original)
+++ trunk/libaspect-perl/lib/Aspect.pm Fri Jan 8 14:29:40 2010
@@ -29,7 +29,7 @@
use Aspect::Pointcut::OrOp ();
use Aspect::Pointcut::NotOp ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our @ISA = 'Exporter';
our @EXPORT = qw{ aspect around before after call cflow };
Modified: trunk/libaspect-perl/lib/Aspect/Advice.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Advice.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Advice.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Advice.pm Fri Jan 8 14:29:40 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '0.32';
+our $VERSION = '0.33';
sub new {
my $class = shift;
Modified: trunk/libaspect-perl/lib/Aspect/Advice/After.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Advice/After.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Advice/After.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Advice/After.pm Fri Jan 8 14:29:40 2010
@@ -11,7 +11,7 @@
use Aspect::Advice ();
use Aspect::AdviceContext ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our @ISA = 'Aspect::Advice';
# NOTE: To simplify debugging of the generated code, all injected string
Modified: trunk/libaspect-perl/lib/Aspect/Advice/Around.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Advice/Around.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Advice/Around.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Advice/Around.pm Fri Jan 8 14:29:40 2010
@@ -7,10 +7,11 @@
# NOTE: Now we've switched to Sub::Uplevel can this be removed? --ADAMK
use Carp::Heavy ();
use Carp ();
+use Sub::Uplevel ();
use Aspect::Advice ();
use Aspect::AdviceContext ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our @ISA = 'Aspect::Advice';
sub _install {
@@ -81,7 +82,9 @@
# Array context needs some special return handling
if ( \$wantarray ) {
# Run the advice code
- () = &\$code(\$context);
+ () = Sub::Uplevel::uplevel(
+ 1, \$code, \$context,
+ );
# Don't run the original
my \$rv = \$context->return_value;
@@ -95,9 +98,13 @@
# Scalar and void have the same return handling.
# Just run the advice code differently.
if ( defined \$wantarray ) {
- my \$dummy = &\$code(\$context);
+ my \$dummy = Sub::Uplevel::uplevel(
+ 1, \$code, \$context,
+ );
} else {
- &\$code(\$context);
+ Sub::Uplevel::uplevel(
+ 1, \$code, \$context,
+ );
}
return \$context->return_value;
Modified: trunk/libaspect-perl/lib/Aspect/Advice/Before.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Advice/Before.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Advice/Before.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Advice/Before.pm Fri Jan 8 14:29:40 2010
@@ -10,7 +10,7 @@
use Aspect::Advice ();
use Aspect::AdviceContext ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our @ISA = 'Aspect::Advice';
sub _install {
@@ -75,6 +75,7 @@
params => \\\@_,
return_value => \$wantarray ? [ ] : undef,
original => \$original,
+ proceed => 1,
\%\$runtime,
);
@@ -90,7 +91,7 @@
# Don't run the original
my \$rv = \$context->return_value;
- if ( \$rv eq 'ARRAY' ) {
+ if ( ref \$rv eq 'ARRAY' ) {
return \@\$rv;
} else {
return ( \$rv );
Modified: trunk/libaspect-perl/lib/Aspect/AdviceContext.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/AdviceContext.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/AdviceContext.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/AdviceContext.pm Fri Jan 8 14:29:40 2010
@@ -2,9 +2,10 @@
use strict;
use warnings;
-use Carp ();
-
-our $VERSION = '0.32';
+use Carp ();
+use Sub::Uplevel ();
+
+our $VERSION = '0.33';
@@ -15,11 +16,7 @@
sub new {
my $class = shift;
- my $self = bless { @_, proceed => 1 }, $class;
- unless ( $self->{sub_name} ) {
- Carp::croak("Cannot create Aspect::AdviceContext without sub_name");
- }
- return $self;
+ bless { @_ }, $class;
}
sub sub_name {
@@ -31,8 +28,10 @@
}
sub proceed {
- $_[0]->{proceed} = $_[1] if @_ > 1;
- $_[0]->{proceed};
+ unless ( defined $_[0]->{proceed} ) {
+ Carp::croak("The use of 'proceed' is meaningless in this advice");
+ }
+ @_ > 1 ? $_[0]->{proceed} = $_[1] : $_[0]->{proceed};
}
sub params_ref {
@@ -84,16 +83,29 @@
}
sub run_original {
- my $self = shift;
- my $original = $self->original;
- my @params = $self->params;
- my $return_value;
- if ( CORE::wantarray ) {
- $return_value = [ $original->(@params) ];
+ my $self = shift;
+ if ( $self->{wantarray} ) {
+ my $rv = [ Sub::Uplevel::uplevel(
+ 2,
+ $self->original,
+ $self->params,
+ ) ];
+ return $self->return_value($rv);
+ } elsif ( defined $self->{wantarray} ) {
+ my $rv = Sub::Uplevel::uplevel(
+ 2,
+ $self->original,
+ $self->params,
+ );
+ return $self->return_value($rv);
} else {
- $return_value = $original->(@params);
+ Sub::Uplevel::uplevel(
+ 2,
+ $self->original,
+ $self->params,
+ );
+ return;
}
- return $self->return_value($return_value);
}
sub return_value {
Modified: trunk/libaspect-perl/lib/Aspect/Library/Listenable.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Library/Listenable.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Library/Listenable.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Library/Listenable.pm Fri Jan 8 14:29:40 2010
@@ -12,7 +12,7 @@
use Aspect::Advice::Before ();
use Aspect::Library::Listenable::Event ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our @ISA = qw{ Aspect::Modular Exporter };
our @EXPORT = qw{ add_listener remove_listener };
Modified: trunk/libaspect-perl/lib/Aspect/Library/Listenable/Event.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Library/Listenable/Event.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Library/Listenable/Event.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Library/Listenable/Event.pm Fri Jan 8 14:29:40 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '0.32';
+our $VERSION = '0.33';
sub new {
my $class = shift;
Modified: trunk/libaspect-perl/lib/Aspect/Library/Singleton.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Library/Singleton.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Library/Singleton.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Library/Singleton.pm Fri Jan 8 14:29:40 2010
@@ -6,7 +6,7 @@
use Aspect::Advice::Before ();
use Aspect::Pointcut::Call ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our @ISA = 'Aspect::Modular';
my %CACHE = ();
Modified: trunk/libaspect-perl/lib/Aspect/Library/Wormhole.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Library/Wormhole.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Library/Wormhole.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Library/Wormhole.pm Fri Jan 8 14:29:40 2010
@@ -8,7 +8,7 @@
use Aspect::Pointcut::Cflow ();
use Aspect::Pointcut::AndOp ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our @ISA = 'Aspect::Modular';
sub get_advice {
Modified: trunk/libaspect-perl/lib/Aspect/Modular.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Modular.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Modular.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Modular.pm Fri Jan 8 14:29:40 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '0.32';
+our $VERSION = '0.33';
sub new {
my $class = shift;
Modified: trunk/libaspect-perl/lib/Aspect/Pointcut.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Pointcut.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Pointcut.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Pointcut.pm Fri Jan 8 14:29:40 2010
@@ -7,7 +7,7 @@
use Aspect::Pointcut::AndOp ();
use Aspect::Pointcut::NotOp ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
use overload (
# Keep traditional boolification and stringification
Modified: trunk/libaspect-perl/lib/Aspect/Pointcut/AndOp.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Pointcut/AndOp.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Pointcut/AndOp.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Pointcut/AndOp.pm Fri Jan 8 14:29:40 2010
@@ -4,7 +4,7 @@
use warnings;
use Aspect::Pointcut ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our @ISA = 'Aspect::Pointcut';
sub new {
Modified: trunk/libaspect-perl/lib/Aspect/Pointcut/Call.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Pointcut/Call.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Pointcut/Call.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Pointcut/Call.pm Fri Jan 8 14:29:40 2010
@@ -5,7 +5,7 @@
use Carp;
use Aspect::Pointcut ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our @ISA = 'Aspect::Pointcut';
sub new {
Modified: trunk/libaspect-perl/lib/Aspect/Pointcut/Cflow.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Pointcut/Cflow.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Pointcut/Cflow.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Pointcut/Cflow.pm Fri Jan 8 14:29:40 2010
@@ -6,7 +6,7 @@
use Aspect::Pointcut ();
use Aspect::AdviceContext ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our @ISA = 'Aspect::Pointcut';
sub new {
Modified: trunk/libaspect-perl/lib/Aspect/Pointcut/NotOp.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Pointcut/NotOp.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Pointcut/NotOp.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Pointcut/NotOp.pm Fri Jan 8 14:29:40 2010
@@ -4,7 +4,7 @@
use warnings;
use Aspect::Pointcut ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our @ISA = 'Aspect::Pointcut';
sub new {
Modified: trunk/libaspect-perl/lib/Aspect/Pointcut/OrOp.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/lib/Aspect/Pointcut/OrOp.pm?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/lib/Aspect/Pointcut/OrOp.pm (original)
+++ trunk/libaspect-perl/lib/Aspect/Pointcut/OrOp.pm Fri Jan 8 14:29:40 2010
@@ -4,7 +4,7 @@
use warnings;
use Aspect::Pointcut ();
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our @ISA = 'Aspect::Pointcut';
sub new {
Modified: trunk/libaspect-perl/t/01_compile.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/t/01_compile.t?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/t/01_compile.t (original)
+++ trunk/libaspect-perl/t/01_compile.t Fri Jan 8 14:29:40 2010
@@ -6,7 +6,8 @@
$^W = 1;
}
-use Test::More tests => 4;
+use Test::More tests => 5;
+use Test::NoWarnings;
use_ok( 'Aspect' );
use_ok( 'Aspect::Library::Listenable' );
Modified: trunk/libaspect-perl/t/02_advice_context.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/t/02_advice_context.t?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/t/02_advice_context.t (original)
+++ trunk/libaspect-perl/t/02_advice_context.t Fri Jan 8 14:29:40 2010
@@ -6,7 +6,8 @@
$^W = 1;
}
-use Test::More tests => 13;
+use Test::More tests => 14;
+use Test::NoWarnings;
use Aspect::AdviceContext;
my $runtime_context = { foo => 'FOO' };
Modified: trunk/libaspect-perl/t/11_pointcut_call.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/t/11_pointcut_call.t?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/t/11_pointcut_call.t (original)
+++ trunk/libaspect-perl/t/11_pointcut_call.t Fri Jan 8 14:29:40 2010
@@ -6,7 +6,8 @@
$^W = 1;
}
-use Test::More tests => 12;
+use Test::More tests => 13;
+use Test::NoWarnings;
use Aspect;
my $good = 'SomePackage::some_method';
Modified: trunk/libaspect-perl/t/22_advice_around.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/t/22_advice_around.t?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/t/22_advice_around.t (original)
+++ trunk/libaspect-perl/t/22_advice_around.t Fri Jan 8 14:29:40 2010
@@ -6,112 +6,391 @@
$^W = 1;
}
-use Test::More tests => 25;
+use Test::More tests => 64;
+use Test::NoWarnings;
+use Test::Exception;
use Aspect;
-my $around = 0;
-my $foo = 0;
-my $bar = 0;
-my $baz = 0;
-
-CLASS: {
+# Lexicals to track call counts in the support class
+my $new = 0;
+my $foo = 0;
+my $bar = 0;
+my $inc = 0;
+
+# Create the test object
+my $object = My::One->new;
+isa_ok( $object, 'My::One' );
+is( $new, 1, '->new 1' );
+
+
+
+
+
+######################################################################
+# Basic Usage
+
+# Do the methods act as normal
+is( $object->foo, 'foo', 'foo not yet installed' );
+is( $object->inc(2), 3, 'inc not yet installed' );
+is( $foo, 1, '->foo is called' );
+is( $inc, 1, '->inc is called' );
+
+# Check that the null case does nothing
+SCOPE: {
+ my $aspect = around {
+ # It's oh so quiet...
+ } call 'My::One::foo';
+ is( scalar($object->foo), undef, 'Scalar null case returns undef' );
+ is_deeply( [ $object->foo ], [ ], 'Listwise null case returns ()' );
+ is( $foo, 1, '->foo is not called' );
+}
+
+# ... and uninstalls properly
+is( $object->foo, 'foo', 'foo uninstalled' );
+is( $foo, 2, '->foo is called' );
+
+# Check that the null pass-through case works properly
+SCOPE: {
+ my $aspect = around {
+ shift->run_original;
+ } call 'My::One::foo';
+ is( $object->foo, 'foo', 'Pass-through null case returns normally' );
+ is( $foo, 3, '->foo is called' );
+}
+
+# ... and uninstalls properly
+is( $object->foo, 'foo', 'foo uninstalled' );
+is( $foo, 4, '->foo is called' );
+
+# Check that shortcutting return_value works and does not pass through
+SCOPE: {
+ my $aspect = around {
+ shift->return_value('bar')
+ } call "My::One::foo";
+ is( $object->foo, 'bar', 'around changing return_value' );
+ is( $foo, 4, '->foo is not called' );
+}
+
+# Check that return_value is changable after pass-through
+SCOPE: {
+ my $aspect = around {
+ my $c = shift;
+ $c->run_original;
+ $c->return_value( $c->return_value . 'bar' );
+ } call "My::One::foo";
+ is( $object->foo, 'foobar', 'around changing return_value' );
+ is( $foo, 5, '->foo is called' );
+}
+
+# ... and uninstalls properly
+is( $object->foo, 'foo', 'foo uninstalled' );
+is( $foo, 6, '->foo is called' );
+
+# Check that proceed fails as expected (reading)
+SCOPE: {
+ my $aspect = around {
+ shift->proceed;
+ } call "My::One::foo";
+ throws_ok(
+ sub { $object->foo },
+ qr/meaningless/,
+ 'Throws correct error when process is read from',
+ );
+ is( $foo, 6, '->foo is not called' );
+}
+
+# Check that proceed fails as expected (writing)
+SCOPE: {
+ my $aspect = around {
+ shift->proceed(0);
+ } call "My::One::foo";
+ throws_ok(
+ sub { $object->foo },
+ qr/meaningless/,
+ 'Throws correct error when process is written to',
+ );
+ is( $foo, 6, '->foo is not called' );
+}
+
+# ... and uninstalls properly
+is( $object->foo, 'foo', 'foo uninstalled ok' );
+is( $foo, 7, '->foo is called' );
+
+# Check that params works as expected and does pass through
+SCOPE: {
+ my $aspect = around {
+ my $p = $_[0]->params;
+ splice @$p, 1, 1, $p->[1] + 1;
+ $_[0]->run_original;
+ } call qr/My::One::inc/;
+ is( $object->inc(2), 4, 'around advice changing params' );
+ is( $inc, 2, '->inc is called' );
+}
+
+# Check that we can rehook the same function.
+# Check that we can run several simultaneous hooks.
+SCOPE: {
+ my $aspect1 = around {
+ my $p = $_[0]->params;
+ splice @$p, 1, 1, $p->[1] + 1;
+ $_[0]->run_original;
+ } call qr/My::One::inc/;
+ my $aspect2 = around {
+ my $p = $_[0]->params;
+ splice @$p, 1, 1, $p->[1] + 1;
+ $_[0]->run_original;
+ } call qr/My::One::inc/;
+ my $aspect3 = around {
+ my $p = $_[0]->params;
+ splice @$p, 1, 1, $p->[1] + 1;
+ $_[0]->run_original;
+ } call qr/My::One::inc/;
+ is( $object->inc(2), 6, 'around advice changing params' );
+ is( $inc, 3, '->inc is called' );
+}
+
+# Were the hooks removed cleanly?
+is( $object->inc(3), 4, 'inc uninstalled' );
+is( $inc, 4, '->inc is called' );
+
+# Check the introduction of a permanent hook
+around {
+ shift->return_value('forever');
+} call 'My::One::inc';
+is( $object->inc, 'forever', '->inc hooked forever' );
+is( $inc, 4, '->inc not called' );
+
+
+
+
+
+######################################################################
+# Usage with Cflow
+
+# Check before hook installation
+is( $object->bar, 'foo', 'bar cflow not yet installed' );
+is( $object->foo, 'foo', 'foo cflow not yet installed' );
+is( $bar, 1, '->bar is called' );
+is( $foo, 9, '->foo is called for both ->bar and ->foo' );
+
+SCOPE: {
+ my $advice = around {
+ my $c = shift;
+ $c->return_value($c->my_key->self);
+ } call "My::One::foo"
+ & cflow my_key => "My::One::bar";
+
+ # ->foo is hooked when called via ->bar, but not directly
+ is( $object->bar, $object, 'foo cflow installed' );
+ is( $bar, 2, '->bar is called' );
+ is( $foo, 9, '->foo is not called' );
+ is( $object->foo, 'foo', 'foo called out of the cflow' );
+ is( $foo, 10, '->foo is called' );
+}
+
+# Confirm original behaviour on uninstallation
+is( $object->bar, 'foo', 'bar cflow uninstalled' );
+is( $object->foo, 'foo', 'foo cflow uninstalled' );
+is( $bar, 3, '->bar is called' );
+is( $foo, 12, '->foo is called for both' );
+
+
+
+
+
+######################################################################
+# Prototype Support
+
+sub main::no_proto { shift }
+sub main::with_proto ($) { shift }
+
+# Control case
+SCOPE: {
+ my $advice = around {
+ shift->return_value('wrapped')
+ } call 'main::no_proto';
+ is( main::no_proto('foo'), 'wrapped', 'No prototype' );
+}
+
+# Confirm correct parameter error before hooking
+SCOPE: {
+ local $@;
+ eval 'main::with_proto(1, 2)';
+ like( $@, qr/Too many arguments/, 'prototypes are obeyed' );
+}
+
+# Confirm correct parameter error during hooking
+SCOPE: {
+ my $advice = around {
+ shift->return_value('wrapped');
+ } call 'main::with_proto';
+ is( main::with_proto('foo'), 'wrapped', 'With prototype' );
+
+ local $@;
+ eval 'main::with_proto(1, 2)';
+ like( $@, qr/Too many arguments/, 'prototypes are obeyed' );
+}
+
+# Confirm correct parameter error after hooking
+SCOPE: {
+ local $@;
+ eval 'main::with_proto(1, 2)';
+ like( $@, qr/Too many arguments/, 'prototypes are obeyed' );
+}
+
+
+
+
+
+######################################################################
+# Caller Correctness
+
+my @CALLER = ();
+my $AROUND = 0;
+
+SCOPE: {
+ # Set up the Aspect
+ my $aspect = around {
+ $AROUND++;
+ $_[0]->run_original;
+ } call 'My::Three::bar';
+ isa_ok( $aspect, 'Aspect::Advice' );
+ isa_ok( $aspect, 'Aspect::Advice::Around' );
+ is( $AROUND, 0, '$AROUND is false' );
+ is( scalar(@CALLER), 0, '@CALLER is empty' );
+
+ # Call a method above the wrapped method
+ my $rv = My::Two->foo;
+ is( $rv, 'value', '->foo is ok' );
+ is( $AROUND, 1, '$AROUND is true' );
+ is( scalar(@CALLER), 2, '@CALLER is full' );
+ is( $CALLER[0]->[0], 'My::Two', 'First caller is My::Two' );
+ is( $CALLER[1]->[0], 'main', 'Second caller is main' );
+}
+
+SCOPE: {
+ package My::Two;
+
+ sub foo {
+ My::Three->bar;
+ }
+
+ package My::Three;
+
+ sub bar {
+ @CALLER = (
+ [ caller(0) ],
+ [ caller(1) ],
+ );
+ return 'value';
+ }
+}
+
+
+
+
+
+######################################################################
+# Wantarray Support
+
+my @CONTEXT = ();
+
+# Before the aspects
+SCOPE: {
+ () = Foo->around;
+ my $dummy = Foo->around;
+ Foo->around;
+}
+
+SCOPE: {
+ my $aspect = around {
+ if ( $_[0]->wantarray ) {
+ push @CONTEXT, 'ARRAY';
+ } elsif ( defined $_[0]->wantarray ) {
+ push @CONTEXT, 'SCALAR';
+ } else {
+ push @CONTEXT, 'VOID';
+ }
+ if ( wantarray ) {
+ push @CONTEXT, 'ARRAY';
+ } elsif ( defined wantarray ) {
+ push @CONTEXT, 'SCALAR';
+ } else {
+ push @CONTEXT, 'VOID';
+ }
+ $_[0]->run_original;
+ } call 'Foo::around';
+
+ # During the aspects
+ () = Foo->around;
+ my $dummy = Foo->around;
+ Foo->around;
+}
+
+# After the aspects
+SCOPE: {
+ () = Foo->around;
+ my $dummy = Foo->around;
+ Foo->around;
+}
+
+# Check the results in aggregate
+is_deeply(
+ \@CONTEXT,
+ [ qw{
+ array
+ scalar
+ void
+ ARRAY ARRAY array
+ SCALAR SCALAR scalar
+ VOID VOID void
+ array
+ scalar
+ void
+ } ],
+ 'All wantarray contexts worked as expected for around',
+);
+
+SCOPE: {
package Foo;
- sub new { bless {}, $_[0] }
-
- sub foo {
- $foo++;
- return 'foo';
+ sub around {
+ if ( wantarray ) {
+ push @CONTEXT, 'array';
+ } elsif ( defined wantarray ) {
+ push @CONTEXT, 'scalar';
+ } else {
+ push @CONTEXT, 'void';
+ }
}
-
- sub bar {
- $bar++;
- return 'bar';
- }
-
- sub baz {
- $baz++;
- return 'baz';
- }
-
- 1;
-}
-
-# Check that a simple null case (not passing through)
-# does not run the function
-SCOPE: {
- my $aspect = around { $around++ } call 'Foo::foo';
- isa_ok( $aspect, 'Aspect::Advice::Around' );
-
- my $object = Foo->new;
- isa_ok( $object, 'Foo' );
-
- # Check return values in all three contexts
- my @rv = $object->foo;
- my $rv = $object->foo;
- $object->foo;
- is_deeply( \@rv, [ ], 'Listwise null around returns null list' );
- is( $rv, undef, 'Scalar null around returns undef' );
- is( $around, 3, 'Three calls were made to the advice' );
- is( $foo, 0, 'No calls were made to the underlying method' );
-}
-
-# Check that the aspect hooks are correctly removed
-SCOPE: {
- my $rv = Foo->new->foo;
- is( $rv, 'foo', 'Method now returns correctly' );
- is( $around, 3, 'No additional calls made to the advice' );
- is( $foo, 1, 'Calls were correctly restored to the underlying method' );
-}
-
-# Check we can run the original method ourself.
-# Check that around aspects in void context last forever.
-SCOPE: {
- around {
- $around += 2;
- my $rv = $_[0]->original->();
- $_[0]->return_value($rv);
- } call 'Foo::bar';
-
- my $object = Foo->new;
- isa_ok( $object, 'Foo' );
-
- my $rv = $object->bar;
- is( $rv, 'bar', 'Got return value from the underlying call' );
- is( $bar, 1, 'Underlying method was called once' );
- is( $around, 5, 'Advice code was called once' );
-}
-
-# Check the hook remains in place
-SCOPE: {
- my $rv = Foo->new->bar;
- is( $rv, 'bar', 'Method now returns correctly' );
- is( $around, 7, 'No additional calls made to the advice' );
- is( $bar, 2, 'Calls are correctly kept with the Aspect' );
-}
-
-# Check the simplest case of ->run_original method works.
-# Check nesting of aspect hooks (particularly expired ones).
-# Check complex nested pointcuts with the around method.
-SCOPE: {
- my $pointcut = call( qr/^Foo::\w+$/) & ! call( 'Foo::new' );
- around {
- $around += 3;
- $_[0]->run_original;
- } $pointcut;
-
- my $object = Foo->new;
- isa_ok( $object, 'Foo' );
- is( $around, 7, 'Constructor was not hooked in constructor' );
-
- my $rv1 = $object->foo;
- my $rv2 = $object->bar;
- my $rv3 = $object->baz;
- is( $rv1, 'foo', 'Nested disabled around works' );
- is( $rv2, 'bar', 'Nested active around works' );
- is( $rv3, 'baz', 'Ordinary ->run_original works' );
- is( $foo, 2, '->foo was called once' );
- is( $bar, 3, '->bar was called once' );
- is( $baz, 1, '->baz was called once' );
- is( $around, 18, 'Advice code was called three times' );
-}
+}
+
+
+
+
+
+######################################################################
+# Support Classes
+
+package My::One;
+
+sub new {
+ $new++;
+ bless {}, shift;
+}
+
+sub foo {
+ $foo++;
+ return 'foo';
+}
+
+sub bar {
+ $bar++;
+ return shift->foo;
+}
+
+sub inc {
+ $inc++;
+ return $_[1] + 1;
+}
+
Modified: trunk/libaspect-perl/t/33_feature_exception.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/t/33_feature_exception.t?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/t/33_feature_exception.t (original)
+++ trunk/libaspect-perl/t/33_feature_exception.t Fri Jan 8 14:29:40 2010
@@ -10,7 +10,8 @@
}
use Test::More skip_all => 'Exceptions are not implemented yet';
-use Test::More tests => 4;
+use Test::More tests => 5;
+use Test::NoWarnings;
use Aspect;
# Test package containing methods that work or don't
Modified: trunk/libaspect-perl/t/listenable.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/t/listenable.t?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/t/listenable.t (original)
+++ trunk/libaspect-perl/t/listenable.t Fri Jan 8 14:29:40 2010
@@ -6,7 +6,8 @@
$^W = 1;
}
-use Test::More tests => 23;
+use Test::More tests => 24;
+use Test::NoWarnings;
use Test::Exception;
use Aspect;
use Aspect::Library::Listenable;
Modified: trunk/libaspect-perl/t/singleton.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/t/singleton.t?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/t/singleton.t (original)
+++ trunk/libaspect-perl/t/singleton.t Fri Jan 8 14:29:40 2010
@@ -6,7 +6,8 @@
$^W = 1;
}
-use Test::More tests => 2;
+use Test::More tests => 3;
+use Test::NoWarnings;
use Aspect;
# Convert Foo into a singleton class
Modified: trunk/libaspect-perl/t/wormhole.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libaspect-perl/t/wormhole.t?rev=50508&op=diff
==============================================================================
--- trunk/libaspect-perl/t/wormhole.t (original)
+++ trunk/libaspect-perl/t/wormhole.t Fri Jan 8 14:29:40 2010
@@ -1,8 +1,13 @@
#!/usr/bin/perl
use strict;
-use warnings;
-use Test::More tests => 2;
+BEGIN {
+ $| = 1;
+ $^W = 1;
+}
+
+use Test::More tests => 3;
+use Test::NoWarnings;
use Aspect;
# Do a lexical and make sure it produces lexical advice
More information about the Pkg-perl-cvs-commits
mailing list