File Coverage

blib/lib/YAML/Logic.pm

Criterion	Covered	Total	%
statement	98	105	93.3
branch	41	50	82.0
condition	11	15	73.3
subroutine	12	13	92.3
pod	0	6	0.0
total	162	189	85.7

###########################################
package YAML::Logic;
###########################################

use strict;
use warnings;
use Log::Log4perl qw(:easy);
use Template;
use Data::Dumper;
use Safe;

our $VERSION = "0.06";
our %OPS = map { $_ => 1 }
    qw(eq ne lt gt < > <= >= == =~ like);

###########################################
sub new {
###########################################
    my($class, %options) = @_;

    my $self = {
        safe => Safe->new(),
        template => Template->new(),
        error => "",
        %options,
    };

    $self->{safe}->permit();

    bless $self, $class;
}

###########################################
sub interpolate {
###########################################
    my($self, $input, $vars) = @_;

    if(ref($input) eq "HASH") {
          # When working on the original, we got weird memory errors
          # in perl5.8, so just copy the hash.
        my %dupe = %$input;
        my @keyvals = ();
        for my $entry (each %dupe) {
            push @keyvals, $self->interpolate( $entry, $vars );
        }
        return { @keyvals };
    }

    my $out;
    $input =~ s/(?:\$\{([\w.]+)})/[%- $1 %]/gx;
    $input =~ s/(?:\$([\w.]+))  /[%- $1 %]/gx;

    $self->{template}->process( \$input, $vars, \$out ) or
        LOGDIE $self->{template}->error();

    return $out;
}

###########################################
sub evaluate {
###########################################
    my($self, $data, $vars, $not_glob, $boolean_or) = @_;

    $not_glob   = 0 unless defined $not_glob;
    $boolean_or = 0 unless defined $boolean_or;

    DEBUG sub { "evaluate: " .
                Dumper( $data ) . "\n" .
                Dumper( $vars ) . "\n" .
                "not_glob=$not_glob " .
                "boolean_or=$boolean_or " .
                ""
          };

    if( ref($data) eq "ARRAY" ) {
        my @data = @$data; # make a copy, so splice() doesn't destroy
                           # the original.
        while( my($field, $value) = splice @data, 0, 2 ) {
            my $res;

            my $not;

            if(! defined $field) {
                LOGDIE "Rule variable not defined (value=$value)",
                       "(maybe YAML rule: !\$var without quotes?";
            }

            if($field =~ s/^!//) {
                $not = !$not_glob;
            }

            if($field eq "or") {
                $res = $self->evaluate($value, $vars, $not, 1);
            } elsif( $field eq "and") {
                $res = $self->evaluate($value, $vars, $not);
            } else {
                $field = $self->interpolate($field, $vars);
                $value = $self->interpolate($value, $vars);

                if(ref($value) eq "") {
                    $res = $self->evaluate_single( $field, $value, "eq", $not );
                } elsif(ref($value) eq "HASH") {
                    my($op)  = keys   %$value;
                    ($value) = values %$value;
                    $res = $self->evaluate_single( $field, $value, $op, $not );
                }
            }

            if($boolean_or and $res) {
                # It's a boolean OR, so all it takes is one true result
                my $rc = 1;
                DEBUG "evaluate: rc=$rc";
                return $rc;
            } elsif(!$boolean_or and !$res) {
                # It's a boolean AND, so all it takes is one false result
                my $rc = 0;
                DEBUG "evaluate: rc=$rc";
                return $rc;
            }
        }
    } else {
        LOGDIE "Unknown type: $data";
    }

      # Return 1 if all ANDed conditions succeeded, and 0 if all
      # ORed conditions failed.
    my $rc = 1;
    $rc = 0 if $boolean_or;
    DEBUG "evaluate: rc=$rc";
    return $rc;
}

###########################################
sub evaluate_single {
###########################################
    my($self, $field, $value, $op, $not) = @_;

    $op = lc $op ;
    $op = '=~' if $op eq "like";

    $self->error("");

    if(! exists $OPS{ $op }) {
        LOGDIE "Unknown op: $op";
    }

    $field = '"' . esc($field) . '"';
    my $cmd;

    if($op eq "=~") {
        if($value =~ /\?\{/) {
            LOGDIE "Trapped ?{ in regex.";
        }
        $value =~ s#(\\\\|/)#\\$1#g;
          # If we ever get something like \\/, slap another backslash
          # onto the "/" to mask it.
        $value =~ s#(\\+)/# (length($1) % 2) ? "$1/" : "$1\\/"#ge;
        $value = qr($value);
        $cmd = "$field =~ /$value/";
    } else {
        $value = '"' . esc($value) . '"';
        $cmd = "$field $op $value";
    }

    INFO "Test: $cmd";
    my $res = $self->{safe}->reval($cmd);

    if($@) {
        LOGDIE "Evaling [$cmd] failed: $@";
    }

    if(!$res and !$not or
        $res  and $not) {
        $res = "" if !defined $res;
        $self->error("Test [$cmd] returned [$res]");
    }

    return ($not ? (!$res) : $res);
}

###########################################
sub error {
###########################################
    my($self, $error) = @_;

    if(defined $error) {
        $self->{error} = $error;
    }

    return $self->{error};
}

###############################################
sub esc {
###############################################
    my($str, $metas) = @_;

    $str =~ s/([\\"])/\\$1/g;

    if(defined $metas) {
        $metas =~ s/\]/\\]/g;
        $str =~ s/([$metas])/\\$1/g;
    }

    return $str;
}

1;

__END__