r50633 - in /branches/upstream/libaspect-perl/current: ./ lib/ lib/Aspect/ lib/Aspect/Advice/ lib/Aspect/Library/ lib/Aspect/Library/Listenable/ lib/Aspect/Pointcut/ t/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Sun Jan 10 15:32:25 UTC 2010
Author: jawnsy-guest
Date: Sun Jan 10 15:31:58 2010
New Revision: 50633
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=50633
Log:
[svn-upgrade] Integrating new upstream version, libaspect-perl (0.34)
Added:
branches/upstream/libaspect-perl/current/lib/Aspect/Advice/AfterReturning.pm
branches/upstream/libaspect-perl/current/t/25_advice_after_returning.t
Modified:
branches/upstream/libaspect-perl/current/Changes
branches/upstream/libaspect-perl/current/MANIFEST
branches/upstream/libaspect-perl/current/META.yml
branches/upstream/libaspect-perl/current/README
branches/upstream/libaspect-perl/current/lib/Aspect.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Advice.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Advice/After.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Around.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Before.pm
branches/upstream/libaspect-perl/current/lib/Aspect/AdviceContext.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Library/Listenable.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Library/Listenable/Event.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Library/Singleton.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Library/Wormhole.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Modular.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/AndOp.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Call.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Cflow.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/NotOp.pm
branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/OrOp.pm
Modified: branches/upstream/libaspect-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/Changes?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/Changes (original)
+++ branches/upstream/libaspect-perl/current/Changes Sun Jan 10 15:31:58 2010
@@ -1,4 +1,8 @@
Revision history for Perl extension Aspect
+
+0.34 Sun 10 Jan 2010 - Adam Kennedy
+ - Adding Aspect::Advice::AfterReturning before we implement exception
+ support in the main ::After advice.
0.33 Fri 8 Jan 2010 - Adam Kennedy
- Added Test::NoWarnings to all of the tests
Modified: branches/upstream/libaspect-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/MANIFEST?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/MANIFEST (original)
+++ branches/upstream/libaspect-perl/current/MANIFEST Sun Jan 10 15:31:58 2010
@@ -18,6 +18,7 @@
lib/Aspect.pm
lib/Aspect/Advice.pm
lib/Aspect/Advice/After.pm
+lib/Aspect/Advice/AfterReturning.pm
lib/Aspect/Advice/Around.pm
lib/Aspect/Advice/Before.pm
lib/Aspect/AdviceContext.pm
@@ -45,6 +46,7 @@
t/22_advice_around.t
t/23_advice_before.t
t/24_advice_after.t
+t/25_advice_after_returning.t
t/31_feature_caller.t
t/32_feature_wantarray.t
t/33_feature_exception.t
Modified: branches/upstream/libaspect-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/META.yml?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/META.yml (original)
+++ branches/upstream/libaspect-perl/current/META.yml Sun Jan 10 15:31:58 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.33
+version: 0.34
Modified: branches/upstream/libaspect-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/README?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/README (original)
+++ branches/upstream/libaspect-perl/current/README Sun Jan 10 15:31:58 2010
@@ -48,7 +48,9 @@
if ( $context->self->customer_name eq 'Adam Kennedy' ) {
$context->return_value('One meeeelion dollars');
} else {
+ # Take a dollar off everyone else
$context->run_original;
+ $context->return_value( $context->return_value - 1 );
}
} call 'Bank::Account::balance';
Modified: branches/upstream/libaspect-perl/current/lib/Aspect.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect.pm Sun Jan 10 15:31:58 2010
@@ -15,23 +15,24 @@
# So we'll do the best we can here, and then in the future we might
# want to consider switching to "use Sub::UpLevel ':aggressive';"
# -- ADAMK
-use Sub::Uplevel ();
-use Exporter ();
-use Aspect::Advice ();
-use Aspect::AdviceContext ();
-use Aspect::Advice::Before ();
-use Aspect::Advice::After ();
-use Aspect::Advice::Around ();
-use Aspect::Pointcut ();
-use Aspect::Pointcut::Call ();
-use Aspect::Pointcut::Cflow ();
-use Aspect::Pointcut::AndOp ();
-use Aspect::Pointcut::OrOp ();
-use Aspect::Pointcut::NotOp ();
-
-our $VERSION = '0.33';
+use Sub::Uplevel ();
+use Exporter ();
+use Aspect::Advice ();
+use Aspect::AdviceContext ();
+use Aspect::Advice::Around ();
+use Aspect::Advice::Before ();
+use Aspect::Advice::After ();
+use Aspect::Advice::AfterReturning ();
+use Aspect::Pointcut ();
+use Aspect::Pointcut::Call ();
+use Aspect::Pointcut::Cflow ();
+use Aspect::Pointcut::AndOp ();
+use Aspect::Pointcut::OrOp ();
+use Aspect::Pointcut::NotOp ();
+
+our $VERSION = '0.34';
our @ISA = 'Exporter';
-our @EXPORT = qw{ aspect around before after call cflow };
+our @EXPORT = qw{ aspect around before after after_returning call cflow };
# Internal data storage
my @FOREVER = ();
@@ -74,6 +75,14 @@
sub after (&$) {
Aspect::Advice::After->new(
+ code => $_[0],
+ pointcut => $_[1],
+ lexical => defined wantarray,
+ );
+}
+
+sub after_returning (&$) {
+ Aspect::Advice::AfterReturning->new(
code => $_[0],
pointcut => $_[1],
lexical => defined wantarray,
@@ -163,7 +172,9 @@
if ( $context->self->customer_name eq 'Adam Kennedy' ) {
$context->return_value('One meeeelion dollars');
} else {
+ # Take a dollar off everyone else
$context->run_original;
+ $context->return_value( $context->return_value - 1 );
}
} call 'Bank::Account::balance';
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Advice.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Advice.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Advice.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Advice.pm Sun Jan 10 15:31:58 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '0.33';
+our $VERSION = '0.34';
sub new {
my $class = shift;
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Advice/After.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Advice/After.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Advice/After.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Advice/After.pm Sun Jan 10 15:31:58 2010
@@ -11,7 +11,7 @@
use Aspect::Advice ();
use Aspect::AdviceContext ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
our @ISA = 'Aspect::Advice';
# NOTE: To simplify debugging of the generated code, all injected string
Added: branches/upstream/libaspect-perl/current/lib/Aspect/Advice/AfterReturning.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Advice/AfterReturning.pm?rev=50633&op=file
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Advice/AfterReturning.pm (added)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Advice/AfterReturning.pm Sun Jan 10 15:31:58 2010
@@ -1,0 +1,160 @@
+package Aspect::Advice::AfterReturning;
+
+use strict;
+use warnings;
+
+# Added by eilara as hack around caller() core dump
+# 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.34';
+our @ISA = 'Aspect::Advice';
+
+# NOTE: To simplify debugging of the generated code, all injected string
+# fragments will be defined in $UPPERCASE, and all lexical variables to be
+# accessed via the closure will be in $lowercase.
+sub _install {
+ my $self = shift;
+ my $pointcut = $self->pointcut;
+ my $code = $self->code;
+ my $lexical = $self->lexical;
+
+ # Get the curried version of the pointcut we will use for the
+ # runtime checks instead of the original.
+ # Because $MATCH_RUN is used in boolean conditionals, if there
+ # is nothing to do the compiler will optimise away the code entirely.
+ my $curried = $pointcut->curry_run;
+ my $MATCH_RUN = $curried ? '$curried->match_run($name, $runtime)' : 1;
+
+ # When an aspect falls out of scope, we don't attempt to remove
+ # the generated hook code, because it might (for reasons potentially
+ # outside our control) have been recursively hooked several times
+ # by both Aspect and other modules.
+ # Instead, we store an "out of scope" flag that is used to shortcut
+ # past the hook as quickely as possible.
+ # This flag is shared between all the generated hooks for each
+ # installed Aspect.
+ # If the advice is going to last lexical then we don't need to
+ # check or use the $out_of_scope variable.
+ my $out_of_scope = undef;
+ my $MATCH_DISABLED = $lexical ? '$out_of_scope' : '0';
+
+ # Find all pointcuts that are statically matched
+ # wrap the method with advice code and install the wrapper
+ foreach my $name ( $pointcut->match_all ) {
+ my $NAME = $name; # For completeness
+
+ no strict 'refs';
+ my $original = *$name{CODE};
+ unless ( $original ) {
+ Carp::croak("Can't wrap non-existent subroutine ", $name);
+ }
+
+ # Any way to set prototypes other than eval?
+ my $PROTOTYPE = prototype($original);
+ $PROTOTYPE = defined($PROTOTYPE) ? "($PROTOTYPE)" : '';
+
+ # Generate the new function
+ no warnings 'redefine';
+ eval <<"END_PERL"; die $@ if $@;
+ *$NAME = sub $PROTOTYPE {
+ # Is this a lexically scoped hook that has finished
+ goto &\$original if $MATCH_DISABLED;
+
+ my \$runtime = {};
+ my \$wantarray = wantarray;
+ if ( \$wantarray ) {
+ my \$return = [
+ Sub::Uplevel::uplevel(
+ 1, \$original, \@_,
+ )
+ ];
+ return \@\$return unless $MATCH_RUN;
+
+ # Create the context
+ my \$context = Aspect::AdviceContext->new(
+ type => 'after_returning',
+ pointcut => \$pointcut,
+ sub_name => \$name,
+ wantarray => \$wantarray,
+ params => \\\@_,
+ return_value => \$return,
+ original => \$original,
+ \%\$runtime,
+ );
+
+ # Execute the advice code
+ () = &\$code(\$context);
+
+ # Get the (potentially) modified return value
+ \$return = \$context->return_value;
+ if ( ref \$return eq 'ARRAY' ) {
+ return \@\$return;
+ } else {
+ return ( \$return );
+ }
+ }
+
+ if ( defined \$wantarray ) {
+ my \$return = Sub::Uplevel::uplevel(
+ 1, \$original, \@_,
+ );
+ return \$return unless $MATCH_RUN;
+
+ # Create the context
+ my \$context = Aspect::AdviceContext->new(
+ type => 'after_returning',
+ pointcut => \$pointcut,
+ sub_name => \$name,
+ wantarray => \$wantarray,
+ params => \\\@_,
+ return_value => \$return,
+ original => \$original,
+ \%\$runtime,
+ );
+
+ # Execute the advice code
+ my \$dummy = &\$code(\$context);
+ return \$context->return_value;
+
+ } else {
+ Sub::Uplevel::uplevel(
+ 1, \$original, \@_,
+ );
+ return unless $MATCH_RUN;
+
+ # Create the context
+ my \$context = Aspect::AdviceContext->new(
+ type => 'after_returning',
+ pointcut => \$pointcut,
+ sub_name => \$name,
+ wantarray => \$wantarray,
+ params => \\\@_,
+ return_value => undef,
+ original => \$original,
+ \%\$runtime,
+ );
+
+ # Execute the advice code
+ &\$code(\$context);
+ return;
+ }
+ };
+END_PERL
+ }
+
+ # If this will run lexical we don't need a descoping hook
+ return unless $lexical;
+
+ # Return the lexical descoping hook.
+ # This MUST be stored and run at DESTROY-time by the
+ # parent object calling _install. This is less bullet-proof
+ # than the DESTROY-time self-executing blessed coderef
+ return sub { $out_of_scope = 1 };
+}
+
+1;
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Around.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Around.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Around.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Around.pm Sun Jan 10 15:31:58 2010
@@ -11,7 +11,7 @@
use Aspect::Advice ();
use Aspect::AdviceContext ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
our @ISA = 'Aspect::Advice';
sub _install {
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Before.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Before.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Before.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Before.pm Sun Jan 10 15:31:58 2010
@@ -10,7 +10,7 @@
use Aspect::Advice ();
use Aspect::AdviceContext ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
our @ISA = 'Aspect::Advice';
sub _install {
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/AdviceContext.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/AdviceContext.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/AdviceContext.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/AdviceContext.pm Sun Jan 10 15:31:58 2010
@@ -5,7 +5,7 @@
use Carp ();
use Sub::Uplevel ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Library/Listenable.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Library/Listenable.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Library/Listenable.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Library/Listenable.pm Sun Jan 10 15:31:58 2010
@@ -12,7 +12,7 @@
use Aspect::Advice::Before ();
use Aspect::Library::Listenable::Event ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
our @ISA = qw{ Aspect::Modular Exporter };
our @EXPORT = qw{ add_listener remove_listener };
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Library/Listenable/Event.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Library/Listenable/Event.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Library/Listenable/Event.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Library/Listenable/Event.pm Sun Jan 10 15:31:58 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '0.33';
+our $VERSION = '0.34';
sub new {
my $class = shift;
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Library/Singleton.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Library/Singleton.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Library/Singleton.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Library/Singleton.pm Sun Jan 10 15:31:58 2010
@@ -6,7 +6,7 @@
use Aspect::Advice::Before ();
use Aspect::Pointcut::Call ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
our @ISA = 'Aspect::Modular';
my %CACHE = ();
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Library/Wormhole.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Library/Wormhole.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Library/Wormhole.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Library/Wormhole.pm Sun Jan 10 15:31:58 2010
@@ -8,7 +8,7 @@
use Aspect::Pointcut::Cflow ();
use Aspect::Pointcut::AndOp ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
our @ISA = 'Aspect::Modular';
sub get_advice {
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Modular.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Modular.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Modular.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Modular.pm Sun Jan 10 15:31:58 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '0.33';
+our $VERSION = '0.34';
sub new {
my $class = shift;
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut.pm Sun Jan 10 15:31:58 2010
@@ -7,7 +7,7 @@
use Aspect::Pointcut::AndOp ();
use Aspect::Pointcut::NotOp ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
use overload (
# Keep traditional boolification and stringification
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/AndOp.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/AndOp.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/AndOp.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/AndOp.pm Sun Jan 10 15:31:58 2010
@@ -4,7 +4,7 @@
use warnings;
use Aspect::Pointcut ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
our @ISA = 'Aspect::Pointcut';
sub new {
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Call.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Call.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Call.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Call.pm Sun Jan 10 15:31:58 2010
@@ -5,7 +5,7 @@
use Carp;
use Aspect::Pointcut ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
our @ISA = 'Aspect::Pointcut';
sub new {
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Cflow.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Cflow.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Cflow.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Cflow.pm Sun Jan 10 15:31:58 2010
@@ -6,7 +6,7 @@
use Aspect::Pointcut ();
use Aspect::AdviceContext ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
our @ISA = 'Aspect::Pointcut';
sub new {
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/NotOp.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/NotOp.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/NotOp.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/NotOp.pm Sun Jan 10 15:31:58 2010
@@ -4,7 +4,7 @@
use warnings;
use Aspect::Pointcut ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
our @ISA = 'Aspect::Pointcut';
sub new {
Modified: branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/OrOp.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/OrOp.pm?rev=50633&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/OrOp.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/OrOp.pm Sun Jan 10 15:31:58 2010
@@ -4,7 +4,7 @@
use warnings;
use Aspect::Pointcut ();
-our $VERSION = '0.33';
+our $VERSION = '0.34';
our @ISA = 'Aspect::Pointcut';
sub new {
Added: branches/upstream/libaspect-perl/current/t/25_advice_after_returning.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/t/25_advice_after_returning.t?rev=50633&op=file
==============================================================================
--- branches/upstream/libaspect-perl/current/t/25_advice_after_returning.t (added)
+++ branches/upstream/libaspect-perl/current/t/25_advice_after_returning.t Sun Jan 10 15:31:58 2010
@@ -1,0 +1,360 @@
+#!/usr/bin/perl
+
+use strict;
+BEGIN {
+ $| = 1;
+ $^W = 1;
+}
+
+use Test::More tests => 57;
+use Test::NoWarnings;
+use Test::Exception;
+use Aspect;
+
+# 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 = after_returning {
+ # It's oh so quiet...
+ } call 'My::One::foo';
+ is( $object->foo, 'foo', 'Null case does not change anything' );
+ is( $foo, 2, '->foo is called' );
+}
+
+# ... and uninstalls properly
+is( $object->foo, 'foo', 'foo uninstalled' );
+is( $foo, 3, '->foo is called' );
+
+# Check that return_value works as expected and does not pass through
+SCOPE: {
+ my $aspect = after_returning {
+ shift->return_value('bar')
+ } call "My::One::foo";
+ is( $object->foo, 'bar', 'after_returning changing return_value' );
+ is( $foo, 4, '->foo is called' );
+}
+
+# ... and uninstalls properly
+is( $object->foo, 'foo', 'foo uninstalled' );
+is( $foo, 5, '->foo is called' );
+
+# Check that proceed fails as expected (reading)
+SCOPE: {
+ my $aspect = after_returning {
+ 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 called' );
+}
+
+# Check that proceed fails as expected (writing)
+SCOPE: {
+ my $aspect = after_returning {
+ shift->proceed(0);
+ } call "My::One::foo";
+ throws_ok(
+ sub { $object->foo },
+ qr/meaningless/,
+ 'Throws correct error when process is written to',
+ );
+ is( $foo, 7, '->foo is called' );
+}
+
+# ... and uninstalls properly
+is( $object->foo, 'foo', 'foo uninstalled' );
+is( $foo, 8, '->foo is called' );
+
+# Check that params works as expected and does pass through
+SCOPE: {
+ my $aspect = after_returning {
+ my $p = shift->params;
+ splice @$p, 1, 1, $p->[1] + 1;
+ } call qr/My::One::inc/;
+ is( $object->inc(2), 3, 'after_returning advice changing params does nothing' );
+ 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 = after_returning {
+ $_[0]->return_value( $_[0]->return_value + 1 );
+ } call qr/My::One::inc/;
+ my $aspect2 = after_returning {
+ $_[0]->return_value( $_[0]->return_value + 1 );
+ } call qr/My::One::inc/;
+ my $aspect3 = after_returning {
+ $_[0]->return_value( $_[0]->return_value + 1 );
+ } call qr/My::One::inc/;
+ is( $object->inc(2), 6, 'after_returning 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
+after_returning {
+ shift->return_value('forever');
+} call 'My::One::inc';
+is( $object->inc(1), 'forever', '->inc hooked forever' );
+is( $inc, 5, '->inc is 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, 10, '->foo is called for both ->bar and ->foo' );
+
+SCOPE: {
+ my $advice = after_returning {
+ 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, 11, '->foo is not called' );
+ is( $object->foo, 'foo', 'foo called out of the cflow' );
+ is( $foo, 12, '->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, 14, '->foo is called for both' );
+
+
+
+
+
+######################################################################
+# Prototype Support
+
+sub main::no_proto { shift }
+sub main::with_proto ($) { shift }
+
+# Control case
+SCOPE: {
+ my $advice = after_returning {
+ 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 = after_returning {
+ 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 $AFTER = 0;
+
+SCOPE: {
+ # Set up the Aspect
+ my $aspect = after_returning { $AFTER++ } call 'My::Three::bar';
+ isa_ok( $aspect, 'Aspect::Advice' );
+ isa_ok( $aspect, 'Aspect::Advice::AfterReturning' );
+ is( $AFTER, 0, '$AFTER 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( $AFTER, 1, '$AFTER 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->after_returning;
+ my $dummy = Foo->after_returning;
+ Foo->after_returning;
+}
+
+SCOPE: {
+ my $aspect = after_returning {
+ 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';
+ }
+ } call 'Foo::after_returning';
+
+ # During the aspects
+ () = Foo->after_returning;
+ my $dummy = Foo->after_returning;
+ Foo->after_returning;
+}
+
+# After the aspects
+SCOPE: {
+ () = Foo->after_returning;
+ my $dummy = Foo->after_returning;
+ Foo->after_returning;
+}
+
+# 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 after_returning',
+);
+
+SCOPE: {
+ package Foo;
+
+ sub after_returning {
+ if ( wantarray ) {
+ push @CONTEXT, 'array';
+ } elsif ( defined wantarray ) {
+ push @CONTEXT, 'scalar';
+ } else {
+ push @CONTEXT, 'void';
+ }
+ }
+}
+
+
+
+
+
+######################################################################
+# 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;
+}
+
More information about the Pkg-perl-cvs-commits
mailing list