#!/usr/bin/perl -w

BEGIN {
   $| = 1;
   print "Content-type: text/plain\n\n";
}

open STDERR, ">&STDOUT";

use CGI;
use Safe;
use BSD::Resource;

$SIG{XCPU} = sub { die 'Out of CPU time'; };
$SIG{__WARN__} = sub { print "\nWarning: $_[0]"; };
$SIG{__DIE__} = sub { die "\nError: $_[0]"; };

# set aside 128K (determined experimentally)
# for for emergency memory pool
$^M = 0x00 x (1 << 17);

# the extra second is needed for cleanup after SIGXCPU
setrlimit(RLIMIT_CPU, 1, 2);

# less than 7MB soft limit fails on OUTBUF open
setrlimit(RLIMIT_AS, 1024*1024*7, RLIM_INFINITY);

# set CGI limits
$CGI::POST_MAX = 1024*100; # in bytes
$CGI::DISABLE_UPLOADS = 1;

my $query = new CGI;
die "GET too large" if $query->cgi_error();

open LOG, ">>/home/uckelman/dice.nomic.net/state/roll.log"
   or die "Can't write to log";
my $now = gmtime;
print LOG "\n", $now, ' ', $query->remote_host(), ' ', $query->param('req');

my $input = $query->param('req');
die 'No input' if !defined($input);

# choose a random namespace name; odds of guessing are 1 in 8.16e35
my @ichar = ('a'..'z','A'..'Z','_',0..9);
my $ns = $ichar[int rand(53)];
for (my $i = 0; $i < 19; ++$i) {
   $ns .= $ichar[int rand(63)];
}

# set up the sandbox
my $sandbox = new Safe($ns);

$sandbox->permit_only(
   ':base_core',
   ':base_mem',
   ':base_loop',
   ':base_math',
   'print',
   'prtf',        # printf
   'sprintf',
   'padany',      # for variables
   'sort',
   'gv',          # for ()-less function evaluation
   '!rand',
   '!srand',
   '!method',
   '!method_named',
);

#$sandbox->permit(Opcode::full_opset);

@r = ();    # stop the used-once warning
$sandbox->share(qw(@r d D pick choose shuffle sum
                   prod max min uniq count nsort));

# parse input
my $outbuf = '';
my $code;
#my $input = join '', <STDIN>;

# FIXME: make it possible to guard {{ and }}
while (($code) = $input =~ /{{(.*?)}}/s) {
   print $`;
   $input = $';

   if ($code !~ /;|}/s) {
      # autoprint simple expressions
      $code = "print join(' ', $code)";
   }

# FIXME: don't replace d,D in strings, function names, labels
   # replace d,D with real expressions
   $code =~ s/(\d*)(d|D)(\d+)/sprintf '%s(%d,%d)', $2, $1 ? $1 : 1, $3/eg;

   # capture prints in sandbox
   open(OUTBUF, '>', \$outbuf) or die "Can't open OUTBUF: $!";
   select OUTBUF;

   {
      local $SIG{__DIE__} = {};  # handle code errors later
      $sandbox->reval($code);
   }

   select STDOUT;
   close OUTBUF;
   print $outbuf;
   push @r, $outbuf;
   die $@ if $@;  # handle code errors now
}
print $input;  # trailing text

# display @r
#print "\n";
#for (my $i = 0; $i < scalar @r; ++$i) {
#   print "$i: $r[$i]\n";
#}

sub d($$) {
   my ($i, $s) = @_;
   my $r = 0;
   while ($i--) {
      $r += int rand($s) + 1;
   }
   return $r;
}

sub D($$) {
   my ($i, $s) = @_;
   my @r;
   while ($i--) {
      push @r, int rand($s) + 1;
   }
   return @r;
}

sub pick(@) { return @_[int rand @_]; }

sub choose($@) {
   my $i = shift;
   my @c;
   while ($i--) {
      push @c, splice @_, int rand @_, 1;
   }
   return @c;
}

sub shuffle(@) {
   # Fisher-Yates shuffle, Perl Cookbook 4.17
   my $i;
   for ($i = @_; --$i; ) {
      my $j = int rand($i+1);
      next if $i == $j;
      @_[$i,$j] = @_[$j,$i];
   }
   return @_;
}

sub sum(@) {
   my $sigma = 0;
   foreach (@_) { $sigma += $_; }
   return $sigma;
}

sub prod(@) {
   my $pi = 0;
   foreach (@_) { $pi *= $_; }
   return $pi;
}

sub max(@) {
   my $sup = $_[0];
   foreach (@_) { $sup = $_ if $_ > $sup; }
   return $sup;
}

sub min(@) {
   my $inf = $_[0];
   foreach (@_) { $inf = $_ if $_ < $inf; }
   return $inf;
}

sub uniq(@) {
   # Perl Cookbook 4.6
   my %seen;
   return grep { ! $seen{$_} ++ } @_;
}

sub count(@) { return scalar @_; }

# FIXME: would like this to be sort instead
sub nsort(@) { return sort { $a <=> $b } @_; }

# http://coding.derkeiler.com/Archive/Perl/comp.lang.perl.modules/2004-05/0102.html
