[SPOILER] Re: Perl 'Expert' Quiz-of-the-Week #24 (Module dependency evaluation)

Just read MJD's posting about Randy's dissapointment on solutions.  So, 
I thought I'd send mine even though it's not complete.  However, I've 
enjoyed working on this and if Randy likes the way this solution is 
going, I'd also be willing to continue to complete it.

I've done a few projects which needed small parsers and just ended up 
doing them by hand.  I thought I could do this the same way but had been 
itching to use a 'real' parser.  I thought this would be a good 
opportunity to learn one and choose to try out Parse::RecDescent.

The nice thing about using RecDescent is that you don't actually need 
Parse::RecDescent after you've generated the parser code from the 
grammar.  In other words, this solution wouldn't require 
Parse::RecDescent to run when distributed.

I only had limited time to work on this so my first few were spent 
figuring out how to use RecDescent and whether I wanted RecDescent to do 
all the work or just generate a tree which I could later walkt and 
evaluate.  I choose the tree.

The tree which is created is comprised of terminal nodes which are 
package names or version numbers.  The non-terminal nodes are operators, 
either boolean operators, module comparison operators or a special 
'exists' operator.

When walking the tree, the 'exists' and 'comparison' operators call the 
Versions->from_module() to determine if a module dependency is met. 
They return a special 'pkg' object whose boolean value indicates whether 
or not the dependency is met and whose string value describes the 
dependency (pkg==ver, pkg>ver, pkg, etc...)  The boolean operators 
simply do their boolean thing on the 'pkg' objects and return the 
result.  In the end, you have a 'pkg' object which is the met or unmet 
dependency.  If the pkg object's boolean value is false, it's string 
value is the name of the unmet dependency.

The one bug with this right now is short circuiting.  It currently 
shorts circuits if the first module dependency in an AND/XOR expression 
fails.  I think this can be easily changed by evaluating the truth of 
all operands for AND/XOR operators and returning a list of the untrue 
ones instead of a single value.

I still need to complete the grammar to include xor, not and parenthesis 
and macros.

A packaged version with Makefile.PL and sample tests is available at:

http://www.chelsea.net/~mprewitt/Prereq/PrereqExpr-2004928.tar.gz

Here's grammar:

startrule: expr 'EOF'

expr: disjunction
     | conjunction
     | classdef

disjunction: <leftop: conjunction '||' conjunction>
{
     my $node;
     $node->{op} = 'or';
     $node->{operands} = $item[1];
     $return = $node;
}

conjunction: <leftop: classdef '&&' classdef>
{
     my $node;
     $node->{op} = 'and';
     $node->{operands} = $item[1];
     $return = $node;
}


classdef:
     pkg compare version
     {
         my $node;
         $node->{op} = $item{compare};
         $node->{operands} = [ $item{pkg}, $item{version} ];
         $return = $node;
     }
     | pkg
     {
         my $node;
         $node->{op} = "exists";
         $node->{operands} = $item{pkg};
         $return = $node;
     }

version: /\S+/

compare: />=/ | /<=/ | /==/ | />/ | /</

pkg: /\w+(?:\:\:\w+)*/


Here's a Prereq::Expr module with the 'eval' method which takes a 
requires string like:

q[
          ( DBD::Pg > 1.1 && DateTime::Format::Pg )
            ||
          ( DBD::mysql <= 1.2 && DateTime::Format::mysql )
]


#
# $Id: Expr.pm,v 1.2 2004/09/25 23:31:50 mprewitt Exp mprewitt $
#
package Prereq::Expr;
use strict;
use vars qw( $VERSION );
use Parse::RecDescent;
use Carp;
use Versions;

$VERSION = qw( $Revision: 1.2 $)[1];


my $parser;

# Returns a string which says which modules/versions are missing
sub eval {
     my $requires = shift;

     my $parsed = $parser->startrule("$requires EOF")
       || return carp "Syntax error in requires";
     my $result = eval_tree($parsed);
     return $result ? '' : "$result";
}

sub eval_tree {
     my $tree = shift;
     my $op = $tree->{op};
     my $operands = $tree->{operands};
     if ($op eq 'and') {
         my $return = eval_tree(shift @{$tree->{operands}});
         foreach (@{$tree->{operands}}) {
             $return &&= eval_tree($_);
         }
         return $return;
     } elsif ($op eq 'or') {
         my $return = eval_tree(shift @{$tree->{operands}});
         foreach (@{$tree->{operands}}) {
             $return ||= eval_tree($_);
         }
         return $return;
     } elsif ($op eq 'exists') {
         return Prereq::Expr::pkg->new(Versions->from_module( 
$tree->{operands} ), $tree->{operands});
     } elsif ($op eq '==' || $op eq '>=' || $op eq '<=' || $op eq '>' || 
$op eq '<') {
         my $pkg = $tree->{operands}->[0];
         my $ver = $tree->{operands}->[1];
         return Prereq::Expr::pkg->new(
             eval "Versions->from_module( '$pkg' ) $op $ver",
             "$pkg$op$ver");
     } else {
         warn "Unknown operator: $op";
         return;
     }
}

{
     open GRAMMAR_FILE, "Grammar.pm" or die;
     local $/;
     my $grammar = <GRAMMAR_FILE>;
     Parse::RecDescent->Precompile( $grammar, 'PrereqParser' )
       || die "Unable to create parser from grammar";
     $parser = new Parse::RecDescent( $grammar )
       || die "Unable to create parser from grammar";;
}

package Prereq::Expr::pkg;
use overload (
     '""'   => sub { $_[0]->{name} },
     'bool' => sub { $_[0]->{truth} }
     );

sub new {
     my $type = shift;
     my $self = bless {}, $type;
     $self->{truth} = shift;
     $self->{name} = shift;
     return $self;
}

1;