perleval.pl

#!/usr/local/bin/perl
#
# $Id: perleval.pl,v 0.3 2009/03/10 12:53:50 dankogai Exp dankogai $
#
use strict;
use warnings;
use CGI;
use CGI::Carp qw/fatalsToBrowser/;
use Safe;
use JSON::XS;
use IPC::Open3;

my $perl = '/usr/local/bin/perl';
my @args = qw/-M-ops=:subprocess,:ownprocess,:filesys_write/;  # what a relief!
my $ttl  = 1;                                   # long enough?
my $q    = CGI->new;
my $c    = $q->param('c') or die nocallback($q);
my $stdin  = $q->param('s') or finish( $q, $c, { error => "no code" } );
my $stdout = '';
my $pid;

eval {
    local ( $SIG{ALRM} ) = sub { die "timeout reached.\n" };
    alarm $ttl;
    $pid = open3( my ( $wfh, $rfh, $efh ), $perl, @args ); # $efh unussed
    local ( $SIG{CHLD} ) = sub { waitpid( $pid, 0 ) };
    print $wfh $stdin and close $wfh;
    local $/;
    $stdout = <$rfh>;
    close $rfh;
    alarm 0;
};
kill 9 => $pid;
finish(
    $q, $c,
    $@
    ? { error => $@ }
    : {
        source => $stdin,
        result => $stdout,
    }
);

sub nocallback {
    print $q->header( -status => 500 ), "no callback\n";
    exit;
}

sub finish {
    my ( $q, $c, $j ) = @_;
    my $jx = JSON::XS->new->canonical;
    print $q->header( -type => 'application/x-javascript; charset=utf-8' ),
      "$c(", $jx->encode($j), ");\n";
    exit;
}