#!/usr/bin/perl
# This test checks that caller continues to work as expected in code that has
# been Aspect-hooked.
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
use Test::More tests => 52;
use Test::NoWarnings;
use Aspect;
######################################################################
# Check for before advice
SCOPE: {
my @CALLER = ();
my $POINTS = 0;
my $EXPECTED = 0;
# Set up the Aspect
before { $POINTS++ } call 'Bar1::bar'; # Single
before { $POINTS++ } call 'Foo1::two'; # Multiple
before { $POINTS++ } call 'Foo1::three' & wantlist; # Nonmatched hook
is( $POINTS, 0, '$POINTS is false' );
is( scalar(@CALLER), 0, '@CALLER is empty' );
# Call methods above the wrapped method
my @EXPECTED = ( one => 1, two => 3, three => 4 );
while ( @EXPECTED ) {
my $method = shift @EXPECTED;
my $points = shift @EXPECTED;
my $result = Foo1->$method();
is( $result, 'value', "->$method is ok" );
is( $POINTS, $points, '$POINTS is correct' );
is( scalar(@CALLER), 2, '@CALLER is full' );
is( $CALLER[0]->[0], 'Foo1', 'First caller is Foo1' );
is( $CALLER[1]->[0], 'main', 'Second caller is main' );
}
# Test package
package Foo1;
sub one {
Bar1->bar;
}
sub two {
Bar1->bar;
}
sub three {
Bar1->bar;
}
package Bar1;
sub bar {
@CALLER = (
[ caller(0) ],
[ caller(1) ],
);
return 'value';
}
}
######################################################################
# Check for after advice
SCOPE: {
my @CALLER = ();
my $POINTS = 0;
my $EXPECTED = 0;
# Set up the Aspect
after { $POINTS++ } call 'Bar2::bar'; # Single
after { $POINTS++ } call 'Foo2::two'; # Multiple
after { $POINTS++ } call 'Foo2::three' & wantlist; # Nonmatched hook
is( $POINTS, 0, '$POINTS is false' );
is( scalar(@CALLER), 0, '@CALLER is empty' );
# Call methods above the wrapped method
my @EXPECTED = ( one => 1, two => 3, three => 4 );
while ( @EXPECTED ) {
my $method = shift @EXPECTED;
my $points = shift @EXPECTED;
my $result = Foo2->$method();
is( $result, 'value', "->$method is ok" );
is( $POINTS, $points, '$POINTS is correct' );
is( scalar(@CALLER), 2, '@CALLER is full' );
is( $CALLER[0]->[0], 'Foo2', 'First caller is Foo2' );
is( $CALLER[1]->[0], 'main', 'Second caller is main' );
}
# Test package
package Foo2;
sub one {
Bar2->bar;
}
sub two {
Bar2->bar;
}
sub three {
Bar2->bar;
}
package Bar2;
sub bar {
@CALLER = (
[ caller(0) ],
[ caller(1) ],
);
return 'value';
}
}
######################################################################
# Check for around advice
SCOPE: {
my @CALLER = ();
my $POINTS = 0;
my $EXPECTED = 0;
# Set up the Aspect
around { $POINTS++; $_->proceed } call 'Bar3::bar'; # Single
around { $POINTS++; $_->proceed } call 'Foo3::two'; # Multiple
around { $POINTS++; $_->proceed } call 'Foo3::three' & wantlist; # Nonmatched hook
is( $POINTS, 0, '$POINTS is false' );
is( scalar(@CALLER), 0, '@CALLER is empty' );
# Call methods above the wrapped method
my @EXPECTED = ( one => 1, two => 3, three => 4 );
while ( @EXPECTED ) {
my $method = shift @EXPECTED;
my $points = shift @EXPECTED;
my $result = Foo3->$method();
is( $result, 'value', "->$method is ok" );
is( $POINTS, $points, '$POINTS is correct' );
is( scalar(@CALLER), 2, '@CALLER is full' );
is( $CALLER[0]->[0], 'Foo3', 'First caller is Foo3' );
is( $CALLER[1]->[0], 'main', 'Second caller is main' );
}
# Test package
package Foo3;
sub one {
Bar3->bar;
}
sub two {
Bar3->bar;
}
sub three {
Bar3->bar;
}
package Bar3;
sub bar {
@CALLER = (
[ caller(0) ],
[ caller(1) ],
);
return 'value';
}
}