#!/usr/bin/perl

use strict;
use warnings;

my $expr = Expr->new( q[
    (File::Spec > 0.80 || Cwd) && {OSNAME} == 'linux'
] );

print $expr->eval() ? 'true' : 'false';
print "\n";

############################################################

package Expr;

use strict;
use warnings;

sub new {
    my $class = shift;
    my $expr  = shift;

    my $lexer = Expr::Lexer->new( $expr );
    $lexer->eval();

    my $self = {
        lexer => $lexer,
    };
    return bless( $self, $class );
}

sub eval {
    my $self = shift;
    my $expr = $self->parse();
    return $expr->eval();
}

sub parse {
    my $self = shift;

    my %op_precedence = (
        RELOP => 20,
        LOP   => 10,
    );

    my( @term_stack, @op_stack );

    while ( my($token, $ttype) = $self->{lexer}->next() ) {
	if ( $ttype eq 'NAME' ) {
	    my $expr = Expr::Symbol::Name->new( $token );
	    push( @term_stack, $expr );
	} elsif ( $ttype eq 'VARIABLE' ) {
	    my $expr = Expr::Symbol::Variable->new( $token );
	    push( @term_stack, $expr );
	} elsif ( $ttype eq 'STRING' ) {
	    my $expr = Expr::Literal::String->new( $token );
	    push( @term_stack, $expr );
	} elsif ( $ttype eq 'NUMBER' ) {
	    my $expr = Expr::Literal::Number->new( $token );
	    push( @term_stack, $expr );
	} elsif ( $ttype eq 'RELOP' || $ttype eq 'LOP' ) {
	    if ( @op_stack ) {
		my $prev_prec = $op_precedence{$op_stack[-1]->[1]};
		my $curr_prec = $op_precedence{$ttype};
		if ( $prev_prec == $curr_prec ) {
		    $self->reduce( \@term_stack, \@op_stack );
		    push( @op_stack, [ $token, $ttype ] );
		} elsif ( $prev_prec > $curr_prec ) {
		    $self->reduce( \@term_stack, \@op_stack ) while @op_stack;
		    push( @op_stack, [ $token, $ttype ] );
		} else {
		    push( @op_stack, [ $token, $ttype ] );
		}
	    } else {
		push( @op_stack, [ $token, $ttype ] );
	    }
	} elsif ( $ttype eq 'EOF' ) {
	    $self->reduce( \@term_stack, \@op_stack ) while @op_stack;
	} elsif ( $ttype eq 'BEGIN_GROUP' ) {
	    my $expr = $self->parse();
	    push( @term_stack, $expr );
	} elsif ( $ttype eq 'END_GROUP'   ) {
	    $self->reduce( \@term_stack, \@op_stack ) while @op_stack;
	    return pop( @term_stack );
	} else {
	    die "Unexpected token type: $ttype\n";
	}
    }

    return pop( @term_stack );
}

sub reduce {
    my $self = shift;
    my $term_stack = shift;
    my $op_stack   = shift;

    my $op  = pop( @$op_stack )->[0];
    my $rhs = pop( @$term_stack );
    my $lhs = pop( @$term_stack );

    my $expr = Expr::BinaryOp->new( $lhs, $op, $rhs );
    push( @$term_stack, $expr );
}

1;


############################################################

package Expr::Lexer;

use strict;
use warnings;

sub new {
    my $class = shift;
    my $expr  = shift;
    $expr =~ s/^\s+//;
    $expr =~ s/\s+$//;

    my $self = {
        expr   => $expr,
        tokens => [],
    };
    return bless( $self, $class );
}

sub eval {
    my $self = shift;

    my @token_desc = (
        { re    => qr/(\()/,
          ttype => 'BEGIN_GROUP',
        },
        { re    => qr/(\))/,
          ttype => 'END_GROUP',
        },
        { re    => qr/(>=)/,
	  ttype => 'RELOP',
        },
        { re    => qr/(>)/,
	  ttype => 'RELOP',
        },
        { re    => qr/(<=)/,
          ttype => 'RELOP',
        },
        { re    => qr/(<)/,
          ttype => 'RELOP',
        },
        { re    => qr/(==)/,
          ttype => 'RELOP',
        },
        { re    => qr/(!=)/,
          ttype => 'RELOP',
        },
        { re    => qr/(&&)/,
          ttype => 'LOP',
        },
        { re    => qr/(\|\|)/,
          ttype => 'LOP',
        },
        { re    => qr/(\^\^)/,
          ttype => 'LOP',
        },
        { re    => qr/([[:alpha:]]\w+(?:::\w+)*(?=\W|$))/,
          ttype => 'NAME',
        },
        { re    => qr/{(\w+)}/,
          ttype => 'VARIABLE',
        },
        { re    => qr/(\d+(?:\.\d+)*|\d+\.|\.\d+)/,
          ttype => 'NUMBER',
        },
        { re    => qr/'([^']*)'/,
          ttype => 'STRING',
        },
        { re    => qr/"([^"]*)"/,
          ttype => 'STRING',
        },
    );

    my $text = $self->{expr};
    while (length( $text )) {
	foreach my $token ( @token_desc ) {
	    if ( $text =~ /^$token->{re}/ ) {
		push( @{$self->{tokens}}, [ $1, $token->{ttype} ] );
		$text =~ s/^$token->{re}\s*//;
	    }
	}
    }
    push( @{$self->{tokens}}, [ 'EOF', 'EOF' ] );
}

sub next {
    my $self = shift;
    return @{$self->{tokens}} ? @{shift( @{$self->{tokens}} )} : ();
}

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

1;


############################################################

package Expr::BinaryOp;

use strict;
use warnings;

sub new {
    my $class = shift;
    my $self = {
        lhs => shift,
        op  => shift,
        rhs => shift,
    };
    return bless( $self, $class );
}

sub eval {
    my $self = shift;
    my $lhs = $self->{lhs}; my $lval = $lhs->eval();
    my $rhs = $self->{rhs}; my $rval = $rhs->eval();
    my $op  = $self->{op};

    # strings
    if ( $op eq '==' ) {
	$op = 'eq' if $lhs->isa( 'Expr::Literal::String' ) ||
	              $rhs->isa( 'Expr::Literal::String' );
    } elsif ( $op eq '!=' ) {
	$op = 'ne' if $lhs->isa( 'Expr::Literal::String' ) ||
	              $rhs->isa( 'Expr::Literal::String' );
    }

    if ( $op eq '^^' ) { # special case
	return ($lval || $rval) && !($lval && $rval);
    } else {
	my $result;
	eval "\$result = \$lval $op \$rval";
	return $result;
    }
}

1;


############################################################

package Expr::Symbol;

sub new {
    my $class  = shift;
    my $symbol = shift;
    return bless( \$symbol, $class );
}

sub eval { die "Not implemented.\n" }

1;


############################################################

package Expr::Symbol::Variable;

use base qw(Expr::Symbol);

use strict;
use warnings;

sub eval {
    my $self = shift;
    my $symtab = Expr::SymbolTable->instance();
    return $symtab->lookup( $$self );
}

1;


############################################################

package Expr::Symbol::Name;

use base qw(Expr::Symbol);

use strict;
use warnings;

sub eval {
    my $self = shift;
    require Versions;
    my $vers;
    eval { $vers = Versions->from_module( $$self ) };
    return $vers ? $vers : 0;
}

1;


############################################################

package Expr::Literal;

use strict;
use warnings;

sub new {
    my $class  = shift;
    my $symbol = shift;
    return bless( \$symbol, $class );
}

sub eval {
    my $self = shift;
    return $$self;
}

1;

############################################################

package Expr::Literal::String;
use base qw(Expr::Literal);

1;


############################################################

package Expr::Literal::Number;
use base qw(Expr::Literal);

1;


############################################################

package Expr::SymbolTable;

use strict;
use warnings;

my $singleton;

sub instance {
    my $class = shift;

    return $singleton if defined( $singleton );

    my $self = {
        OSNAME   => $^O,
    };

    $singleton = bless( $self, $class );
    return $singleton;
}

sub lookup {
    my $self = shift;
    my $name = shift;
    return $self->{$name};
}

sub set {
    my $self = shift;
    my $name = shift;
    my $value = shift;
    return $self->{$name} = $value;
}

sub unset {
    my $self = shift;
    my $name = shift;
    return delete $self->{$name};
}

1;