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