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

Here's my solution. It accepts positive integers in hex, octal, or
binary, and any real value in decimal (they can be signed.) It
implements all the optional features except the display modes (bin,
dec, oct, hex) -- I have code that handles real values in other bases,
but I'm not happy with it yet. I might submit another version later.

It uses eval a lot, checking for errors, and relaying them to the user
(stripping the text about where the error occurred through a signal
handler.)

When an error ocurrs, it leaves the stack as it was before the error. 

I was working on my terseness problem here... I even commented a
regexp. (And I spared you the perl -np version with the huge BEGIN
block.)

#!/usr/bin/perl

use strict;
use warnings;

$SIG{__WARN__} = sub {
  my $warning = shift;
  chomp $warning;
  $warning =~ s/ at .*line \d+\.$//g;
  print STDERR $warning, "\n";
};

sub REQUIRED_OPERANDS { 0 };
sub COMMAND { 1 };

my @stack;

my %cmd = (swap => [2, sub { ($stack[0], $stack[1]) = ($stack[1],
$stack[0]) } ],
           dup => [1, sub { unshift @stack, $stack[0] }],
           clear => [0, sub { @stack = () }],
           drop => [1, sub { shift @stack }],
           atan2 => [2, sub { binop(@_, 'prefix') }],
           roll => [0, sub { do_roll(@_); }],
           rolld => [0, sub { do_roll(@_, 'd') }],
          );

my @binop_list = qw(+ - * / % ** | ^);
@cmd{@binop_list} = ([2, \&binop]) x @binop_list;

my @unop_list = qw(abs int cos sin exp log sqrt ~);
@cmd{@unop_list} = ([1, \&unop ]) x @unop_list;

sub do_roll {
  my ($cmd, $d) = @_;
  if ($stack[0]=~ /\D/) {
    warn "$cmd requires an integer greater than zero";
  } else {
    my $n = shift @stack;
    if ($n >= @stack) {
      stack_underflow("$n $cmd", $n+1);
    } else {
      @stack[0..$n] = defined $d ?
        (@stack[1..$n], $stack[0]) :
          ($stack[$n], @stack[0..$n-1]);
    }
  }
}

sub binop {
  my ($operator, $prefix) = @_;
  my ($operand2, $operand1) = splice @stack, 0, 2;
  my $result = defined $prefix ?
    eval "$operator $operand1, $operand2" :
      eval "$operand1 $operator $operand2";
  if ($@) {
    warn $@;
    unshift @stack, $operand2, $operand1;
  } else {
    unshift @stack, $result;
  }
}

sub unop {
  my $operator = shift;
  my $operand = shift @stack;
  my $result = eval "$operator $operand";
  if ($@) {
    warn $@;
    unshift @stack, $operand;
  } else {
    unshift @stack, $result;
  }
}

sub stack_underflow {
  my ($cmd, $needed) = @_;
  warn join '', "Stack underflow for $cmd ($needed entr", ($needed > 1
? 'ies' : 'y'), " required)";
}

INPUT: for (;;) {
  print "$_: $stack[$_]\n"  for (reverse 0..$#stack);
  print "> ";
  my $input = <>;
  print "\n" and exit unless defined $input;
  my @tokens = split /\s+/, lc $input;
 TOKEN:  for my $token (@tokens) {
    if ($token =~ /^       # start at the beginning
        (?:                # open grouping for number match
         0[0-7]* |         # Octal or 0, or
         0b[01]+ |         # Binary, or
         0x[\da-f]+ |      # Hex, or
         (?:               # subgrouping for decimal numbers
          [-+]?            # optional sign
          (?:              # subgrouping for two cases:
           \.\d+ |         # decimal followed by numerals, or
           [1-9]\d*        # numerals, starting non-zero
           (?:\.(?:\d+)?)? # followed optionally by a decimal, which
might be followed by more numerals
          )
         )
        )
        $/x                # go to the end
       ) {
      unshift @stack, eval "$token";
      next TOKEN;
    }
    unless (exists $cmd{$token}) {
      warn "Unrecognized entry $token\n";
      next INPUT;
    }
    unless (@stack >= $cmd{$token}->[REQUIRED_OPERANDS]) {
      stack_underflow($token, $cmd{$token}->[REQUIRED_OPERANDS]);
      next INPUT;
    }
    $cmd{$token}->[COMMAND]->($token);
  }
}