[SPOILER] Solution for QotW #25 (RPN calculator)

My solution is pretty similar to mjcarman's except I used my dispatch
table to point most of the unary and binary functions at the
subroutines "unary" and "binary".

This was a fun one!

#/usr/bin/perl
=pod

For my implemenation of the RPN calculator, I use a dispatch table %functions
that maps the operators to their operations.  This allows me to point all the
binary operators to  the subroutine "binary", which simply reads in the
operator, pops the top two stack elements, and pushes 'eval "$elem1 $op
$elem2"' back onto the stack.  Likewise, most of the unary operators
(the ones with perl implementations!) were pointned to the "unary" sub.

To distinguish between operators and numbers, I match each input item
on /^$RE{num}{real}$/ (from Regexp::Common).  Numbers are pushed onto the
stack, and items that aren't operators or numbers are directed to the 'error'
function in the dispatch table.

By processing the @ARGV array, this implementation allows an additional
command-line usage of this form:
    kester@duck 96: rpn 3 4 - 2 3 '*' +
    0: 5
    >
    kester@duck 97:
(A bit clunky with the stack number '0:' and the null '>' prompt, but
you don't have to type 'q' to exit).

=cut

use warnings;
use strict;
use Regexp::Common;

our @stack;
our %functions = (
    clear => \&{ sub{@stack=()}  },
    drop  => \&{ sub{pop @stack} },
    swap  => \&{ sub{my $x=pop @stack;my $y=pop @stack;push_def($x,$y) } },
    dup   => \&{ sub{my $x=pop @stack;push_def($x,$x)}   },
    roll  => \&{ sub{unshift_def(pop @stack)} },
    abs   => \&unary,
    sqrt  => \&unary,
    cos   => \&unary,
    sin   => \&unary,
    '+'   => \&binary,
    '-'   => \&binary,
    '*'   => \&binary,
    '/'   => \&binary,
    '%'   => \&binary,
    '**'  => \&binary,
    'q'   => \&{ sub{exit} },
    error => \&{ sub {warn "@_ is not a valid entry\n"} },
);

{
    do {process ( @ARGV ); print "\n"; exit} if @ARGV;
    print "Welcome to RPN\n> ";
    process ( $_ ) while <>;
}

sub unshift_def { unshift @stack, grep { defined } @_; }
sub push_def    {    push @stack, grep { defined } @_; }

sub print_stack {
    print scalar @stack-$_-1, ": $stack[$_]\n" foreach 0..scalar @stack - 1;
    print '> ';
}

sub process {
    foreach ( map {chomp;$_} map {split} @_ ) {
          /^$RE{num}{real}$/     ?  push ( @stack, $_ )
        : exists $functions{$_}  ? $functions{$_}->($_)
        : $functions{error}->($_);
    }
    print_stack ();
}

sub binary {
    my ($op,$x,$y) = ( shift, pop @stack, pop @stack );
    do {print "underflow, skipping $op"; return } if !defined $x;
    do {print "underflow, skipping $op"; push @stack,$x; return} if !defined $y;
    push_def ( eval "$y $op $x" ); # y then x for div and %
}

sub unary {
    my ($op,$x) = ( shift, pop @stack );
    do {print "underflow, skipping $op"; return} if !defined $x;
    push_def ( eval "$op($x)" );
}