use strict;
use warnings FATAL => 'all';
use Test::More;

use constant {
    TOK_NUM    => 1,
    TOK_MULOP  => 2,
    TOK_ADDOP  => 3,
    TOK_PAREN  => 4,
    TOK_END    => 9,
};

my ( $expr, $type, $tok ); # Globals. Yuk.

#expr   ::= factor ( ADDOP factor )*
#factor ::= term   ( MULOP term   )*
#term   ::= '(' expr ')' | '-' expr | number

my @tests = (
    '3 + 4', '3 - 4', '3 / 4', '3 * 4',
    '1 + 2 * 3', '2 * 3 + 1', '2 + 3 + 4', '2 - 3 - 4', '2 * 3 * 4', '
+2 / 3 / 4',
    '(1 + 2) * 3', '2 * (3 + 1)', '(2 + 3)', '2 - (3)',
    '-2', '1+-2', '1 + (-2 * -3)',
    '1.2 + 2.4', '1.2 * -1.4',
);

plan tests => scalar @tests;

for my $test ( @tests ) {
    my $exp = eval $test;
    is evaluate( $test ), $exp, "can do $test";
}

sub evaluate {
    $expr = $_[0];
    next_token();
    return expr();
}

sub expr {
    my $val = factor();
    while ( $type eq TOK_ADDOP ) {
        if ( $tok eq '+' ) {
            next_token();
            $val += factor();
        }
        elsif ( $tok eq '-' ) {
            next_token();
            $val -= factor();
        }
    }
    return $val;
}

sub factor {
    my $val = term();
    while ( $type eq TOK_MULOP ) {
        if ( $tok eq '*' ) {
            next_token();
            $val *= term();
        }
        elsif ( $tok eq '/' ) {
            next_token();
            $val /= term();
        }
    }
    return $val;
}

sub term {
    if ( $tok eq '(' ) {
        next_token();
        my $val = expr();
        die "missing )"
          unless $tok eq ')';
        next_token();
        return $val;
    }
    elsif ( $tok eq '-' ) {
        next_token();
        return - term();
    }

    die "syntax error at $expr"
      unless $type eq TOK_NUM;
    my $number = $tok;
    next_token();
    return $number;
}

sub next_token {
    my %toktab = (
        qr{^\s*(\d+(\.\d+)?)}   => TOK_NUM,
        qr{^\s*([-+])}          => TOK_ADDOP,
        qr{^\s*([*/])}          => TOK_MULOP,
        qr{^\s*([()])}          => TOK_PAREN,
    );

    $type = TOK_END;
    for my $re ( keys %toktab ) {
        ( $type, $tok ) = ( $toktab{$re}, $1 ) and last
          if $expr =~ s/$re//;
    }
}
[download]