File Coverage

blib/lib/assertions.pm

Criterion	Covered	Total	%
statement	50	61	81.9
branch	46	60	76.6
condition	12	12	100.0
subroutine	6	7	85.7
pod	2	2	100.0
total	116	142	81.6

package assertions;

our $VERSION = '0.03';

# use strict;
# use warnings;

my $hint=0x01000000;
my $seen_hint=0x02000000;

sub _syntax_error ($$) {
    my ($expr, $why)=@_;
    require Carp;
    Carp::croak("syntax error on assertion filter '$expr' ($why)");
}

sub _carp {
    require warnings;
    if (warnings::enabled('assertions')) {
	require Carp;
	Carp::carp(@_);
    }
}

sub _calc_expr {
    my $expr=shift;
    my @tokens=split / \s*
		       ( &&     # and
		       | \|\|   # or
		       | \(     # parents
		       | \) )
		       \s*
		       | \s+    # spaces out
		     /x, $expr;

    # print STDERR "tokens: -", join('-',@tokens), "-\n";

    my @now=1;
    my @op='start';

    for my $t (@tokens) {
	next if (!defined $t or $t eq '');

	if ($t eq '(') {
	    unshift @now, 1;
	    unshift @op, 'start';
	}
	else {
	    if ($t eq '||') {
		defined $op[0]
		    and _syntax_error $expr, 'consecutive operators';
		$op[0]='||';
	    }
	    elsif ($t eq '&&') {
		defined $op[0]
		    and _syntax_error $expr, 'consecutive operators';
		$op[0]='&&';
	    }
	    else {
		if ($t eq ')') {
		    @now==1 and
			_syntax_error $expr, 'unbalanced parens';
		    defined $op[0] and
			_syntax_error $expr, "key missing after operator '$op[0]'";

		    $t=shift @now;
		    shift @op;
		}
		elsif ($t eq '_') {
		    unless ($^H & $seen_hint) {
			_carp "assertion status '_' referenced but not previously defined";
		    }
		    $t=($^H & $hint) ? 1 : 0;
		}
		elsif ($t ne '0' and $t ne '1') {
		    $t = ( grep { ref $_ eq 'Regexp'
				      ? $t=~$_
				      : $_->check($t)
				} @{^ASSERTING} ) ? 1 : 0;
		}

		defined $op[0] or
		    _syntax_error $expr, 'operator expected';

		if ($op[0] eq 'start') {
		    $now[0]=$t;
		}
		elsif ($op[0] eq '||') {
		    $now[0]||=$t;
		}
		else {
		    $now[0]&&=$t;
		}
		undef $op[0];
	    }
	}
    }
    @now==1 or _syntax_error $expr, 'unbalanced parens';
    defined $op[0] and _syntax_error $expr, "expression ends on operator '$op[0]'";

    return $now[0];
}


sub import {
    # print STDERR "\@_=", join("|", @_), "\n";
    shift;
    @_=(scalar(caller)) unless @_;
    foreach my $expr (@_) {
	unless (_calc_expr $expr) {
	    # print STDERR "assertions deactived";
	    $^H &= ~$hint;
	    $^H |= $seen_hint;
	    return;
	}
    }
    # print STDERR "assertions actived";
    $^H |= $hint|$seen_hint;
}

sub unimport {
    @_ > 1
	and _carp($_[0]."->unimport arguments are being ignored");
    $^H &= ~$hint;
}

sub enabled {
    if (@_) {
	if ($_[0]) {
	    $^H |= $hint;
	}
	else {
	    $^H &= ~$hint;
	}
	$^H |= $seen_hint;
    }
    return $^H & $hint ? 1 : 0;
}

sub seen {
    if (@_) {
	if ($_[0]) {
	    $^H |= $seen_hint;
	}
	else {
	    $^H &= ~$seen_hint;
	}
    }
    return $^H & $seen_hint ? 1 : 0;
}

1;

__END__