r50709 - in /branches/upstream/libaspect-perl/current: ./ lib/ lib/Aspect/ lib/Aspect/Advice/ lib/Aspect/Library/ lib/Aspect/Library/Listenable/ lib/Aspect/Pointcut/ t/
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Mon Jan 11 17:14:42 UTC 2010
Author: gregoa
Date: Mon Jan 11 17:14:28 2010
New Revision: 50709
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=50709
Log:
[svn-upgrade] Integrating new upstream version, libaspect-perl (0.35)
Added:
branches/upstream/libaspect-perl/current/lib/Aspect/Advice/AfterThrowing.pm
branches/upstream/libaspect-perl/current/t/26_advice_after_throwing.t
Removed:
branches/upstream/libaspect-perl/current/t/33_feature_exception.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/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/AfterReturning.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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/Changes (original)
+++ branches/upstream/libaspect-perl/current/Changes Mon Jan 11 17:14:28 2010
@@ -1,4 +1,7 @@
Revision history for Perl extension Aspect
+
+0.35 Mon 11 Jan 2010 - Adam Kennedy
+ - Adding initial support for exceptions, with after_throwing
0.34 Sun 10 Jan 2010 - Adam Kennedy
- Adding Aspect::Advice::AfterReturning before we implement exception
Modified: branches/upstream/libaspect-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/MANIFEST?rev=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/MANIFEST (original)
+++ branches/upstream/libaspect-perl/current/MANIFEST Mon Jan 11 17:14:28 2010
@@ -19,6 +19,7 @@
lib/Aspect/Advice.pm
lib/Aspect/Advice/After.pm
lib/Aspect/Advice/AfterReturning.pm
+lib/Aspect/Advice/AfterThrowing.pm
lib/Aspect/Advice/Around.pm
lib/Aspect/Advice/Before.pm
lib/Aspect/AdviceContext.pm
@@ -47,9 +48,9 @@
t/23_advice_before.t
t/24_advice_after.t
t/25_advice_after_returning.t
+t/26_advice_after_throwing.t
t/31_feature_caller.t
t/32_feature_wantarray.t
-t/33_feature_exception.t
t/97_meta.t
t/98_pod.t
t/99_pmv.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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/META.yml (original)
+++ branches/upstream/libaspect-perl/current/META.yml Mon Jan 11 17:14:28 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.34
+version: 0.35
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect.pm Mon Jan 11 17:14:28 2010
@@ -23,6 +23,7 @@
use Aspect::Advice::Before ();
use Aspect::Advice::After ();
use Aspect::Advice::AfterReturning ();
+use Aspect::Advice::AfterThrowing ();
use Aspect::Pointcut ();
use Aspect::Pointcut::Call ();
use Aspect::Pointcut::Cflow ();
@@ -30,9 +31,18 @@
use Aspect::Pointcut::OrOp ();
use Aspect::Pointcut::NotOp ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
our @ISA = 'Exporter';
-our @EXPORT = qw{ aspect around before after after_returning call cflow };
+our @EXPORT = qw{
+ aspect
+ around
+ before
+ after
+ after_returning
+ after_throwing
+ call
+ cflow
+};
# Internal data storage
my @FOREVER = ();
@@ -83,6 +93,14 @@
sub after_returning (&$) {
Aspect::Advice::AfterReturning->new(
+ code => $_[0],
+ pointcut => $_[1],
+ lexical => defined wantarray,
+ );
+}
+
+sub after_throwing (&$) {
+ Aspect::Advice::AfterThrowing->new(
code => $_[0],
pointcut => $_[1],
lexical => defined wantarray,
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Advice.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Advice.pm Mon Jan 11 17:14:28 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Advice/After.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Advice/After.pm Mon Jan 11 17:14:28 2010
@@ -11,7 +11,7 @@
use Aspect::Advice ();
use Aspect::AdviceContext ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
our @ISA = 'Aspect::Advice';
# NOTE: To simplify debugging of the generated code, all injected string
Modified: 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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Advice/AfterReturning.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Advice/AfterReturning.pm Mon Jan 11 17:14:28 2010
@@ -11,7 +11,7 @@
use Aspect::Advice ();
use Aspect::AdviceContext ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
our @ISA = 'Aspect::Advice';
# NOTE: To simplify debugging of the generated code, all injected string
Added: branches/upstream/libaspect-perl/current/lib/Aspect/Advice/AfterThrowing.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/lib/Aspect/Advice/AfterThrowing.pm?rev=50709&op=file
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Advice/AfterThrowing.pm (added)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Advice/AfterThrowing.pm Mon Jan 11 17:14:28 2010
@@ -1,0 +1,193 @@
+package Aspect::Advice::AfterThrowing;
+
+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.35';
+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 \$wantarray = wantarray;
+ if ( \$wantarray ) {
+ my \$return = eval { [
+ Sub::Uplevel::uplevel(
+ 2, \$original, \@_,
+ )
+ ] };
+ return \@\$return unless \$\@;
+
+ my \$runtime = {
+ return_value => \$return,
+ exception => \$\@,
+ };
+ die \$runtime->{exception} unless $MATCH_RUN;
+
+ # Create the context
+ my \$context = Aspect::AdviceContext->new(
+ type => 'after_throwing',
+ pointcut => \$pointcut,
+ sub_name => \$name,
+ wantarray => \$wantarray,
+ params => \\\@_,
+ original => \$original,
+ \%\$runtime,
+ );
+
+ # Execute the advice code
+ () = &\$code(\$context);
+
+ # Throw the same (or modified) exception
+ my \$exception = \$context->exception;
+ die \$exception if \$exception;
+
+ # 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 = eval {
+ Sub::Uplevel::uplevel(
+ 2, \$original, \@_,
+ )
+ };
+ return \$return unless \$\@;
+
+ my \$runtime = {
+ return_value => \$return,
+ exception => \$\@,
+ };
+ die \$runtime->{exception} unless $MATCH_RUN;
+
+ # Create the context
+ my \$context = Aspect::AdviceContext->new(
+ type => 'after_throwing',
+ pointcut => \$pointcut,
+ sub_name => \$name,
+ wantarray => \$wantarray,
+ params => \\\@_,
+ original => \$original,
+ \%\$runtime,
+ );
+
+ # Execute the advice code
+ my \$dummy = &\$code(\$context);
+
+ # Throw the same (or modified) exception
+ my \$exception = \$context->exception;
+ die \$exception if \$exception;
+
+ # Return the potentially-modified return value
+ return \$context->return_value;
+
+ } else {
+ eval {
+ Sub::Uplevel::uplevel(
+ 2, \$original, \@_,
+ )
+ };
+ return unless \$\@;
+
+ my \$runtime = {
+ return_value => undef,
+ exception => \$\@,
+ };
+ die \$runtime->{exception} unless $MATCH_RUN;
+
+ # Create the context
+ my \$context = Aspect::AdviceContext->new(
+ type => 'after_throwing',
+ pointcut => \$pointcut,
+ sub_name => \$name,
+ wantarray => \$wantarray,
+ params => \\\@_,
+ original => \$original,
+ \%\$runtime,
+ );
+
+ # Execute the advice code
+ &\$code(\$context);
+
+ # Throw the same (or modified) exception
+ my \$exception = \$context->exception;
+ die \$exception if \$exception;
+
+ 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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Around.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Around.pm Mon Jan 11 17:14:28 2010
@@ -11,7 +11,7 @@
use Aspect::Advice ();
use Aspect::AdviceContext ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Before.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Advice/Before.pm Mon Jan 11 17:14:28 2010
@@ -10,7 +10,7 @@
use Aspect::Advice ();
use Aspect::AdviceContext ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/AdviceContext.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/AdviceContext.pm Mon Jan 11 17:14:28 2010
@@ -5,7 +5,7 @@
use Carp ();
use Sub::Uplevel ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
@@ -109,15 +109,27 @@
}
sub return_value {
- my ($self, $value) = @_;
- if ( @_ > 1 ) {
- $self->{return_value} = $value;
+ my $self = shift;
+ if ( @_ ) {
+ $self->{return_value} = shift;
+ if ( defined $self->{exception} ) {
+ $self->{exception} = '';
+ }
$self->{proceed} = 0;
}
my $return_value = $self->get_value('return_value');
return (CORE::wantarray && ref $return_value eq 'ARRAY')
? @$return_value
: $return_value;
+}
+
+sub exception {
+ my $self = shift;
+ if ( @_ ) {
+ $self->{exception} = shift;
+ $self->{proceed} = 0;
+ }
+ return $self->get_value('exception');
}
sub get_value {
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Library/Listenable.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Library/Listenable.pm Mon Jan 11 17:14:28 2010
@@ -12,7 +12,7 @@
use Aspect::Advice::Before ();
use Aspect::Library::Listenable::Event ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&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 Mon Jan 11 17:14:28 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Library/Singleton.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Library/Singleton.pm Mon Jan 11 17:14:28 2010
@@ -6,7 +6,7 @@
use Aspect::Advice::Before ();
use Aspect::Pointcut::Call ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Library/Wormhole.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Library/Wormhole.pm Mon Jan 11 17:14:28 2010
@@ -8,7 +8,7 @@
use Aspect::Pointcut::Cflow ();
use Aspect::Pointcut::AndOp ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Modular.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Modular.pm Mon Jan 11 17:14:28 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut.pm Mon Jan 11 17:14:28 2010
@@ -7,7 +7,7 @@
use Aspect::Pointcut::AndOp ();
use Aspect::Pointcut::NotOp ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/AndOp.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/AndOp.pm Mon Jan 11 17:14:28 2010
@@ -4,7 +4,7 @@
use warnings;
use Aspect::Pointcut ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Call.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Call.pm Mon Jan 11 17:14:28 2010
@@ -5,7 +5,7 @@
use Carp;
use Aspect::Pointcut ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Cflow.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/Cflow.pm Mon Jan 11 17:14:28 2010
@@ -6,7 +6,7 @@
use Aspect::Pointcut ();
use Aspect::AdviceContext ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/NotOp.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/NotOp.pm Mon Jan 11 17:14:28 2010
@@ -4,7 +4,7 @@
use warnings;
use Aspect::Pointcut ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
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=50709&op=diff
==============================================================================
--- branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/OrOp.pm (original)
+++ branches/upstream/libaspect-perl/current/lib/Aspect/Pointcut/OrOp.pm Mon Jan 11 17:14:28 2010
@@ -4,7 +4,7 @@
use warnings;
use Aspect::Pointcut ();
-our $VERSION = '0.34';
+our $VERSION = '0.35';
our @ISA = 'Aspect::Pointcut';
sub new {
Added: branches/upstream/libaspect-perl/current/t/26_advice_after_throwing.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libaspect-perl/current/t/26_advice_after_throwing.t?rev=50709&op=file
==============================================================================
--- branches/upstream/libaspect-perl/current/t/26_advice_after_throwing.t (added)
+++ branches/upstream/libaspect-perl/current/t/26_advice_after_throwing.t Mon Jan 11 17:14:28 2010
@@ -1,0 +1,431 @@
+#!/usr/bin/perl
+
+use strict;
+BEGIN {
+ $| = 1;
+ $^W = 1;
+}
+
+use Test::More tests => 73;
+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;
+my $boom = 0;
+my $bang = 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' );
+eval { $object->boom };
+my $error = $@;
+my $qerror = quotemeta $error;
+my $qrerror = qr/^$qerror\z/;
+is( $foo, 1, '->foo is called' );
+is( $inc, 1, '->inc is called' );
+is( $boom, 1, '->boom is called' );
+
+# Check that the null case does nothing
+SCOPE: {
+ my $aspect = after_throwing {
+ # It's oh so quiet...
+ } call qr/^My::One::(?:foo|boom)$/;
+ is( $object->foo, 'foo', 'Null case does not change anything' );
+ throws_ok(
+ sub { $object->boom },
+ $qrerror,
+ 'Null case does not trap exceptions',
+ );
+ is( $foo, 2, '->foo is called' );
+ is( $boom, 2, '->boom is called' );
+}
+
+# ... and uninstalls properly
+is( $object->foo, 'foo', 'foo uninstalled' );
+throws_ok( sub { $object->boom }, $qrerror, 'boom uninstalled' );
+is( $foo, 3, '->foo is called' );
+is( $boom, 3, '->boom is called' );
+
+# Check that return_value works as expected and does not pass through
+SCOPE: {
+ my $aspect = after_throwing {
+ shift->return_value('bar')
+ } call qr/^My::One::(?:foo|boom)$/;
+ is(
+ $object->foo => 'foo',
+ 'after_throwing does not change return_value',
+ );
+ is(
+ $object->boom => 'bar',
+ 'after_throwing changes return_value for exception',
+ );
+ is( $foo, 4, '->foo is called' );
+ is( $boom, 4, '->boom is called' );
+}
+
+# ... and uninstalls properly
+is( $object->foo, 'foo', 'foo uninstalled' );
+throws_ok( sub { $object->boom }, $qrerror, 'boom uninstalled' );
+is( $foo, 5, '->foo is called' );
+is( $boom, 5, '->boom is called' );
+
+# Check that proceed fails as expected (reading)
+SCOPE: {
+ my $aspect = after_throwing {
+ shift->proceed;
+ } call "My::One::boom";
+ throws_ok(
+ sub { $object->boom },
+ qr/meaningless/,
+ 'Throws correct error when process is read from',
+ );
+ is( $boom, 6, '->boom is called' );
+}
+
+# Check that proceed fails as expected (writing)
+SCOPE: {
+ my $aspect = after_throwing {
+ shift->proceed(0);
+ } call "My::One::boom";
+ throws_ok(
+ sub { $object->boom },
+ qr/meaningless/,
+ 'Throws correct error when process is written to',
+ );
+ is( $boom, 7, '->boom is called' );
+}
+
+# ... and uninstalls properly
+throws_ok( sub { $object->boom }, $qrerror, 'boom uninstalled' );
+is( $boom, 8, '->boom is called' );
+
+# Check that we can rehook the same function.
+# Check that we can run several simultaneous hooks.
+SCOPE: {
+ my $aspect1 = after_throwing {
+ $_[0]->exception( 'one ' . $_[0]->exception );
+ } call qr/My::One::boom/;
+ my $aspect2 = after_throwing {
+ $_[0]->exception( 'two ' . $_[0]->exception );
+ } call qr/My::One::boom/;
+ my $aspect3 = after_throwing {
+ $_[0]->exception( 'three ' . $_[0]->exception );
+ } call qr/My::One::boom/;
+ throws_ok(
+ sub { $object->boom },
+ qr/^three two one $qerror$/,
+ 'boom multi-wrapped',
+ );
+ is( $boom, 9, '->boom is called' );
+}
+
+# ... and uninstalls properly
+throws_ok( sub { $object->boom }, $qrerror, 'boom uninstalled' );
+is( $boom, 10, '->boom is called' );
+
+# Check the introduction of a permanent hook.
+# Check alteration of the exception.
+SCOPE: {
+ after_throwing {
+ shift->exception('blah');
+ } call 'My::One::boom';
+}
+throws_ok( sub { $object->boom }, qr/blah/, 'boom permanently hooked' );
+is( $boom, 11, '->boom is called' );
+
+
+
+
+
+######################################################################
+# Usage with Cflow
+
+# Check before hook installation
+throws_ok( sub { $object->boom }, qr/blah/, 'boom cflow is not installed' );
+throws_ok( sub { $object->bang }, qr/blah/, 'bang cflow is not installed' );
+is( $bang, 1, '->bang is called' );
+is( $boom, 13, '->boom is called for both' );
+
+SCOPE: {
+ my $advice = after_throwing {
+ my $c = shift;
+ $c->return_value($c->my_key->self);
+ } call "My::One::boom"
+ & cflow my_key => "My::One::bang";
+
+ # ->boom is hooked when called via ->bang, but not directly
+ is( $object->bang, $object, 'boom cflow installed' );
+ is( $bang, 2, '->bang is called' );
+ is( $boom, 14, '->boom is called' );
+ throws_ok(
+ sub { $object->boom },
+ qr/blah/,
+ 'boom called out of the cflow',
+ );
+ is( $boom, 15, '->boom is called' );
+}
+
+# Confirm original behaviour on uninstallation
+throws_ok( sub { $object->boom }, qr/blah/, 'boom cflow is not installed' );
+throws_ok( sub { $object->bang }, qr/blah/, 'bang cflow is not installed' );
+is( $bang, 3, '->bang is called' );
+is( $boom, 17, '->boom is called for both' );
+
+
+
+
+
+######################################################################
+# Prototype Support
+
+sub main::no_proto { die shift }
+sub main::with_proto ($) { die shift }
+
+# Control case
+SCOPE: {
+ my $advice = after_throwing {
+ 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_throwing {
+ 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_throwing { $AFTER++ } call 'My::Three::bar';
+ isa_ok( $aspect, 'Aspect::Advice' );
+ isa_ok( $aspect, 'Aspect::Advice::AfterThrowing' );
+ is( $AFTER, 0, '$AFTER is false' );
+ is( scalar(@CALLER), 0, '@CALLER is empty' );
+
+ # Call a method above the wrapped method
+ throws_ok( sub { My::Two->foo }, qr/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) ],
+ );
+ die 'value';
+ }
+}
+
+
+
+
+
+######################################################################
+# Wantarray Support
+
+my @CONTEXT = ();
+
+# Before the aspects
+SCOPE: {
+ throws_ok(
+ sub { () = Foo->after_throwing },
+ qr/bang/,
+ 'after_throwing before throws ok',
+ );
+ throws_ok(
+ sub { my $dummy = Foo->after_throwing },
+ qr/bang/,
+ 'after_throwing before throws ok',
+ );
+ throws_ok(
+ sub { Foo->after_throwing },
+ qr/bang/,
+ 'after_throwing before throws ok',
+ );
+}
+
+SCOPE: {
+ my $aspect = after_throwing {
+ 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_throwing';
+
+ # During the aspects
+ throws_ok(
+ sub { () = Foo->after_throwing },
+ qr/bang/,
+ 'after_throwing before throws ok',
+ );
+ throws_ok(
+ sub { my $dummy = Foo->after_throwing },
+ qr/bang/,
+ 'after_throwing before throws ok',
+ );
+ throws_ok(
+ sub { Foo->after_throwing },
+ qr/bang/,
+ 'after_throwing before throws ok',
+ );
+}
+
+# After the aspects
+SCOPE: {
+ throws_ok(
+ sub { () = Foo->after_throwing },
+ qr/bang/,
+ 'after_throwing before throws ok',
+ );
+ throws_ok(
+ sub { my $dummy = Foo->after_throwing },
+ qr/bang/,
+ 'after_throwing before throws ok',
+ );
+ throws_ok(
+ sub { Foo->after_throwing },
+ qr/bang/,
+ 'after_throwing before throws ok',
+ );
+}
+
+# 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_throwing',
+);
+
+SCOPE: {
+ package Foo;
+
+ sub after_throwing {
+ if ( wantarray ) {
+ push @CONTEXT, 'array';
+ } elsif ( defined wantarray ) {
+ push @CONTEXT, 'scalar';
+ } else {
+ push @CONTEXT, 'void';
+ }
+ die 'bang';
+ }
+}
+
+
+
+
+
+######################################################################
+# 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;
+}
+
+sub boom {
+ $boom++;
+ die $_[1] || 'explosion';
+}
+
+sub bang {
+ $bang++;
+ return shift->boom;
+}
More information about the Pkg-perl-cvs-commits
mailing list