File Coverage

blib/lib/Aspect/Pointcut/Cflow.pm

Criterion	Covered	Total	%
statement	50	51	98.0
branch	11	12	91.6
condition			n/a
subroutine	15	15	100.0
pod	4	5	80.0
total	80	83	96.3

package Aspect::Pointcut::Cflow;

use strict;
use warnings;
use Carp                   ();
use Params::Util           ();
use Aspect::Pointcut       ();
use Aspect::Pointcut::Call ();
use Aspect::Point::Static  ();

our $VERSION = '0.97_06';
our @ISA     = 'Aspect::Pointcut';

use constant KEY  => 0;
use constant SPEC => 2;





######################################################################
# Constructor Methods

sub new {
	my $class = shift;

	# Check and default the cflow key
	my $key = @_ > 1 ? shift : 'enclosing';
	unless ( Params::Util::_IDENTIFIER($key) ) {
		Carp::croak('Invalid runtime context key');
	}

	# Generate it via call
	my $call = Aspect::Pointcut::Call->new(shift);
	return bless [ $key, @$call ], $class;
}





######################################################################
# Weaving Methods

# The cflow pointcut is currently of no value at weave time, because it is
# actually implemented as something closer to cflowbelow.
sub curry_weave {
	return;
}

# The cflow pointcuts do not curry at all.
# So they don't need to clone, and can be used directly.
sub curry_runtime {
	return $_[0];
}





######################################################################
# Runtime Methods

sub compile_runtime {
	my $self = shift;
	return sub {
		my $level   = 2;
		my $caller  = undef;
		while ( my $cc = caller_info($level++) ) {
			next unless $self->[SPEC]->( $cc->{sub_name} );
			$caller = $cc;
			last;
		}
		return 0 unless $caller;
		my $context = bless {
			sub_name => $caller->{sub_name},
			pointcut => $_->{pointcut},
			args     => $caller->{args},
		}, 'Aspect::Point::Static';
		$_->{$self->[KEY]} = $context;
		return 1;
	};
}

sub caller_info {
	my $level = shift;

	package DB;

	my %call_info;
	@call_info{ qw(
		calling_package
		sub_name
		has_params
	) } = (CORE::caller($level))[0, 3, 4];

	return defined $call_info{calling_package}
		? {
			%call_info,
			args => [
				$call_info{has_params} ? @DB::args : ()
			],
		} : 0;
}

1;

__END__