view release on metacpan or  search on metacpan

lib/Aspect/Pointcut/Call.pm  view on Meta::CPAN

package Aspect::Pointcut::Call;

use strict;
use Carp             ();
use Params::Util     ();
use Aspect::Pointcut ();

our $VERSION = '1.04';
our @ISA     = 'Aspect::Pointcut';

use constant ORIGINAL     => 0;
use constant COMPILE_CODE => 1;
use constant RUNTIME_CODE => 2;
use constant COMPILE_EVAL => 3;
use constant RUNTIME_EVAL => 4;





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

# The constructor stores three values.
# $self->[0] is the original specification provided to the constructor
# $self->[1] is a function form of the condition that has a sub name passed
#            in and returns true if matching or false if not.
# $self->[2] is a function form of the condition that has the sub name set as
#            the topic variable.
# $self->[3] is a function form of the condition that has the join point object
#            set as the topic variable.
# $self->[4] is either a string Perl fragment that can be eval'ed with $_ set
#            as the sub name, or a function that can be called with $_ set as
#            the sub name.
# $self->[5] is either a string Perl fragment that can be eval'ed with $_ set
#            as the join point variable, or a function that can be called with
#            $_ set as the join point variable.
# All of 1-5 return true of the condition matches, or false if not.
sub new {
	my $class = shift;
	my $spec  = shift;
	if ( Params::Util::_STRING($spec) ) {
		my $string = '"' . quotemeta($spec) . '"';
		return bless [
			$spec,
			eval "sub () { \$_[0] eq $string }",
			eval "sub () { \$_ eq $string }",
			eval "sub () { \$Aspect::POINT->{sub_name} eq $string }",
			"\$_ eq $string",
			"\$Aspect::POINT->{sub_name} eq $string",
		], $class;
	}
	if ( Params::Util::_CODELIKE($spec) ) {
		return bless [
			$spec,
			$spec,
			sub { $spec->($_) },
			sub { $spec->($Aspect::POINT->{sub_name}) },
			sub { $spec->($_) },
			sub { $spec->($Aspect::POINT->{sub_name}) },
		], $class;
	}
	if ( Params::Util::_REGEX($spec) ) {
		# Special case serialisation of regexs
		# In Perl 5.13.6 the format of a serialised regex changed
		# incompatibly. Worse, the optimisation trick that worked
		# before no longer works after, as there are now modifiers
		# that are ONLY value inside and can't be moved to the end.
		# So we first serialise to a form that will be valid code
		# under the new system, and then do the replace that will
		# only match (and only be valid) under the old system.
		my $regex = "/$spec/";
		$regex =~ s|^/\(\?([xism]*)-[xism]*:(.*)\)/\z|/$2/$1|s;
		return bless [
			$spec,
			eval "sub () { \$_[0] =~ $regex }",
			eval "sub () { $regex }",
			eval "sub () { \$Aspect::POINT->{sub_name} =~ $regex }",
			$regex,
			"\$Aspect::POINT->{sub_name} =~ $regex",
		], $class;
	}
	Carp::croak("Invalid function call specification");
}





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

sub match_runtime {
	return 0;
}