#========================================================================
#
# Badger::Logic
#
# DESCRIPTION
#   Simple parser and evaluator for boolean logic expressions, e.g.
#   'purple or orange', 'animal and (eats_nuts or eats_berries)'
#
# AUTHOR
#   Andy Wardley   <abw@wardley.org>
#
#========================================================================

package Badger::Logic;

use Badger::Class
    version   => 0.01,
    debug     => 0,
    base      => 'Badger::Base',
    as_text   => 'text',
    constants => 'HASH',
    constant  => {
        LOGIC => 'Badger::Logic',
    },
    exports   => {
        any   => 'LOGIC Logic',
    },
    messages  => {
        no_text   => 'No text expression specified.',
        no_rhs    => 'Missing expression following "%s"',
        bad_text  => 'Unexpected text in expression: %s',
        parse     => 'Could not parse logic expression: %s',
        no_rparen => 'Missing ")" at end of nested expression',
    };

our $NODE = {
    'item' => 'Badger::Logic::Item',
    'not'  => 'Badger::Logic::Not',
    'and'  => 'Badger::Logic::And',
    'or'   => 'Badger::Logic::Or',
};

*test = \&evaluate;


sub Logic {
    return @_
        ? LOGIC->new(@_)
        : LOGIC;
}

sub new {
    my $class = shift;
    my $text  = shift;
    return $class->error_msg('no_text')
        unless defined $text;
    bless {
        text => ref $text ? $text : \$text,
    }, $class;
}

sub evaluate {
    my $self = shift;
    my $args = @_ && ref $_[0] eq HASH ? shift : { @_ };
    $self->tree->evaluate($args);
}

sub tree {
    my $self = shift;
    return $self->{ tree }
       ||= $self->parse($self->{ text });
}

sub text {
    ${ shift->{ text } };
}

sub tree_text {
    shift->tree->text;
}

sub parse {
    my $self = shift;
    my $text = shift;
    my $tref = ref $text ? $text : \$text;
    $self->debug("parse($$tref)\n") if DEBUG;
    my $expr = $self->parse_expr($tref)
        || return $self->error_msg( parse => $$tref );
    $self->debug("expr: ", $expr->text) if DEBUG;
    if ($$tref =~ / \G \s* (.+) $/cigsx) {
        return $self->error_msg( bad_text => $1 );
    }
    return $expr;
}

sub parse_expr {
    my $self = shift;
    my $text = shift;
    my $left = $self->parse_unary($text) || return;

    $self->debug("got unary: ", $left->text) if DEBUG;

    if ($$text =~ / \G \s+ (and|or) \s+ /cigx) {
        my $op = $1;
        $self->debug("binary op: $op\n") if $DEBUG;
        my $right = $self->parse_expr($text)
            || return $self->error_msg( no_rhs => $op );
        return $NODE->{ lc $op }->new( $left, $right );
    }
    elsif ($$text =~ / \G \s* \( /cgx) {
        my $expr = $self->parse_expr($text)
            || return $self->error_msg( no_rhs => '(' );
        $$text =~ / \G \s* \) /cgx
            || return $self->error_msg('no_rparen');

        return $self->error_msg( bad_text => $1 );
    }

    return $left;
}

sub parse_unary {
    my $self = shift;
    my $text = shift;

    if ($$text =~ / \G \s* (not) \s+ /cigx) {
        my $op = $1;
        $self->debug("unary op: $op\n") if $DEBUG;
        my $right = $self->parse_term($text)
            || return $self->error_msg( no_rhs => $op );
        return $NODE->{ lc $op }->new($right);
    }
    return $self->parse_term($text)
        || $self->decline('Not a unary expression');
}

sub parse_term {
    my $self = shift;
    my $text = shift;

    if ($$text =~ / \G \s* (\w+) /cigx) {
        $self->debug("item: $1\n") if $DEBUG;
        return $NODE->{ item }->new($1);
    }
    elsif ($$text =~ / \G \s* (['"]) ((?:\\?.)*?) \1 /cigx) {
        $self->debug("string: $2\n") if $DEBUG;
        return $NODE->{ item }->new($2);
    }
    elsif ($$text =~ / \G \s* \( /cgx) {
        my $expr = $self->parse_expr($text)
            || return $self->error_msg( no_rhs => '(' );
        $$text =~ / \G \s* \) /cgx
            || return $self->error_msg('no_rparen');
        return $expr;
    }

    return $self->decline('Not a term');
}


#=======================================================================
# node types
#=======================================================================

package Badger::Logic::Expr;
use base 'Badger::Base';

sub new {
    my $class = shift;
    bless [ @_ ], $class;
}

package Badger::Logic::Item;
use base 'Badger::Logic::Expr';

sub evaluate {
    my $self = shift;
    my $args = @_ && ref $_[0] eq 'HASH' ? shift : { @_ };
    return $args->{ $self->[0] };
}

sub text {
    $_[0]->[0];
}

package Badger::Logic::Not;
use base 'Badger::Logic::Expr';

sub evaluate {
    my $self = shift;
    return $self->[0]->evaluate(@_) ? 0 : 1;
}

sub text {
    my $self = shift;
    '(not ' . $self->[0]->text . ')';
}

package Badger::Logic::And;
use base 'Badger::Logic::Expr';

sub evaluate {
    my $self = shift;
    return $self->[0]->evaluate(@_)
        && $self->[1]->evaluate(@_);
}

sub text {
    my $self = shift;
    '(' . $self->[0]->text . ' and ' . $self->[1]->text . ')';
}

package Badger::Logic::Or;
use base 'Badger::Logic::Expr';

use Badger::Debug ':all';
sub evaluate {
    my $self = shift;
    return $self->[0]->evaluate(@_)
        || $self->[1]->evaluate(@_);
}

sub text {
    my $self = shift;
    '(' . $self->[0]->text . ' or ' . $self->[1]->text . ')';
}

1;
__END__

=head1 NAME

Badger::Logic - parse and evaluate simple logical expressions

=head1 SYNOPSIS

    use Badger::Logic 'Logic';

    my $logic  = Logic('animal and (eats_nuts or eats_berries)');
    my $values = {
        animal    => 1,
        eats_nuts => 1,
    }

    if ($logic->test($values)) {
        print "This is an animal that eats nuts or berries\n";
    }

=head1 DESCRIPTION

This module implements a simple parser and evaluator for boolean logic
expressions.  It evolved from a piece of code that I originally wrote to
handle role-based authentication in web applications.

=head1 EXPORTABLE SUBROUTINES

=head2 LOGIC

This is a shortcut alias to C<Badger::Logic>.

    use Badger::Logic 'LOGIC';

    my $logic = LOGIC->new($expr);      # same as Badger::Logic->new($expr);

=head2 Logic()

This subroutine returns the name of the C<Badger::Logic> class when called
without arguments. Thus it can be used as an alias for C<Badger::Logic>
as per L<LOGIC>.

    use Badger::Logic 'Logic';

    my $logic = Logic->new($expr);      # same as Badger::Logic->new($expr);

When called with arguments, it creates a new C<Badger::Logic> object.

    my $logic = Logic($expr);           # same as Badger::Logic->new($expr);

=head1 METHODS

=head2 new($expr)

Constructor method to create a new C<Badger::Logic> object from an expression.

    my $logic = Badger::Logic->new('animal and (cat or dog)');

=head2 evaluate($values) / test($values)

Method to evaluate the expression.  A reference to a hash array should be
passed containing the values that the expression can test.

    my $values = {
        animal => 1,
        cat    => 1,
    };

    if ($logic->evaluate($values)) {
        print "This animal is a cat or a dog\n";
    }

=head2 tree()

Returns a reference to the root of a tree of C<Badger::Logic::Node> objects
that represent the parsed expression.

=head2 text()

Returns a text representation of the logic expression.

=head1 INTERNAL METHODS

=head2 parse($text)

Main method to parse a logical expression.  This calls L<parse_expr()> and
then checks that all of the text has been successfully parsed.  It returns
a reference to a C<Badger::Logic::Node> object.

=head2 parse_expr($text)

Method to parse a binary expression.

=head2 parse_unary($text)

Method to parse a unary expression.

=head2 parse_term($text)

Method to parse a single term in a logical expression.

=head1 AUTHOR

Andy Wardley L<http://wardley.org>

=head1 COPYRIGHT

Copyright (C) 2007-2009 Andy Wardley.  All Rights Reserved.

This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# vim: expandtab shiftwidth=4: