view release on metacpan or  search on metacpan

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

package Aspect::Pointcut::Or;

use strict;
use Aspect::Pointcut::Logic ();

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





######################################################################
# Constructor

sub new {
	my $class = shift;
	my @parts = @_;

	# Validate the pointcut subexpressions
	foreach my $part ( @parts ) {
		next if Params::Util::_INSTANCE($part, 'Aspect::Pointcut');
		Carp::croak("Attempted to apply pointcut logic to non-pointcut '$part'");
	}

	# Collapse nested or statements at constructor time so we don't have
	# to do so multiple times later on during currying.
	while ( scalar grep { $_->isa('Aspect::Pointcut::Or') } @parts ) {
		@parts = map {
			$_->isa('Aspect::Pointcut::Or') ? @$_ : $_
		} @parts;
	}

	$class->SUPER::new(@parts);
}





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

sub compile_weave {
	my $self     = shift;
	my @children = map { $_->compile_weave } @$self;

	# Collapse string conditions together,
	# and further collapse code conditions together.
	my @string = ();
	my @code   = ();
	foreach my $child ( @children ) {
		# Short-cut if we contain any purely runtime pointcuts
		unless ( ref $child ) {
			return 1 if $child eq 1;
			push @string, $child;
			next;
		}
		if ( @string ) {
			my $group = join ' or ', map { "( $_ )" } @string;
			push @code, eval "sub () { $group }";
			@string = ();
		}
		push @code, $child;
	}

	if ( @string ) {
		my $group = join ' or ', map { "( $_ )" } @string;
		unless ( @code ) {
			# This is the only thing we have
			return $group;
		}
		push @code, eval "sub () { $group }";
	}

	# Join the groups
	return sub {
		foreach my $child ( @code ) {
			return 0 unless $child->();
		}
		return 1;
	};

}

sub compile_runtime {
	my $self     = shift;
	my @children = map { $_->compile_runtime } @$self;

	# Collapse string conditions together,
	# and further collapse code conditions together.
	my @string = ();
	my @code   = ();
	foreach my $child ( @children ) {