mirror of https://github.com/pragma-/pbot.git
compiler_vm: make guest debugging output less verbose
This commit is contained in:
Pragmatic Software
parent
f0dbf8c33a
commit
46fdd01ccd
|
|
@ -11,6 +11,7 @@ use English;
|
|||
use Encode;
|
||||
use File::Basename;
|
||||
use JSON::XS;
|
||||
use Data::Dumper;
|
||||
|
||||
my $USERNAME = 'vm'; # variable for easier string interpolation
|
||||
|
||||
|
|
@ -22,12 +23,12 @@ use constant {
|
|||
OUTPUT => '/dev/stdout',
|
||||
};
|
||||
|
||||
my $USE_LOCAL = $ENV{'CC_LOCAL'} // 0;
|
||||
|
||||
use lib MOD_DIR;
|
||||
|
||||
my %languages;
|
||||
|
||||
my $USE_LOCAL = $ENV{'CC_LOCAL'};
|
||||
|
||||
sub load_modules {
|
||||
my @files = glob MOD_DIR . "/*.pm";
|
||||
foreach my $mod (@files){
|
||||
|
|
@ -42,7 +43,7 @@ sub load_modules {
|
|||
sub run_server {
|
||||
my ($input, $output, $heartbeat);
|
||||
|
||||
if(not defined $USE_LOCAL or $USE_LOCAL == 0) {
|
||||
if (not $USE_LOCAL) {
|
||||
# set serial to 115200 baud instead of 9600
|
||||
system('stty -F ' . SERIAL . ' 115200');
|
||||
|
||||
|
|
@ -65,15 +66,14 @@ sub run_server {
|
|||
my $pid = fork;
|
||||
die "Fork failed: $!" if not defined $pid;
|
||||
|
||||
if($pid == 0) {
|
||||
my $buffer = "";
|
||||
my $length = 4096;
|
||||
if ($pid == 0) {
|
||||
my $buffer = '';
|
||||
my $line;
|
||||
my $total_read = 0;
|
||||
|
||||
while (1) {
|
||||
print "Waiting for input...\n";
|
||||
my $ret = sysread($input, my $buf, $length);
|
||||
my $ret = sysread($input, my $buf, 16384);
|
||||
|
||||
if (not defined $ret) {
|
||||
print "Error reading: $!\n";
|
||||
|
|
@ -83,7 +83,7 @@ sub run_server {
|
|||
$total_read += $ret;
|
||||
|
||||
if ($ret == 0) {
|
||||
print "input ded?\n";
|
||||
print "Input closed; exiting...\n";
|
||||
print "got buffer [$buffer]\n";
|
||||
exit;
|
||||
}
|
||||
|
|
@ -92,30 +92,26 @@ sub run_server {
|
|||
print "read $ret bytes [$total_read so far] [$buf]\n";
|
||||
$buffer.= $buf;
|
||||
|
||||
if ($buffer =~ s/\s*:end:\s*$//m) {
|
||||
$line = $buffer;
|
||||
$buffer = "";
|
||||
$total_read = 0;
|
||||
} else {
|
||||
next;
|
||||
}
|
||||
next if $buffer !~ s/\s*:end:\s*$//m;
|
||||
|
||||
$line = $buffer;
|
||||
chomp $line;
|
||||
|
||||
$buffer = '';
|
||||
$total_read = 0;
|
||||
|
||||
$line = encode('UTF-8', $line);
|
||||
|
||||
print "-" x 40, "\n";
|
||||
print "Got [$line]\n";
|
||||
|
||||
$line = encode('UTF-8', $line);
|
||||
my $compile_in = decode_json($line);
|
||||
|
||||
$compile_in->{arguments} //= '';
|
||||
$compile_in->{input} //= '';
|
||||
|
||||
print "Attempting compile [$compile_in->{lang}] ...\n";
|
||||
|
||||
use Data::Dumper;
|
||||
print Dumper $compile_in;
|
||||
|
||||
$compile_in->{arguments} //= '';
|
||||
$compile_in->{input} //= '';
|
||||
|
||||
my $pid = fork;
|
||||
|
||||
if (not defined $pid) {
|
||||
|
|
@ -125,6 +121,7 @@ sub run_server {
|
|||
|
||||
if ($pid == 0) {
|
||||
my ($uid, $gid, $home) = (getpwnam $USERNAME)[2, 3, 7];
|
||||
|
||||
if (not $uid and not $gid) {
|
||||
print "Could not find user $USERNAME: $!\n";
|
||||
exit;
|
||||
|
|
@ -153,15 +150,19 @@ sub run_server {
|
|||
$EGID = "$gid $gid";
|
||||
$EUID = $UID = $uid;
|
||||
|
||||
chdir("/home/$USERNAME");
|
||||
|
||||
my $result = interpret(%$compile_in);
|
||||
|
||||
$GID = 0;
|
||||
$UID = 0;
|
||||
|
||||
my $compile_out = { result => $result };
|
||||
|
||||
my $json = encode_json($compile_out);
|
||||
|
||||
print "Done compiling; result: [$result] [$json]\n";
|
||||
print "Done compiling: $json\n";
|
||||
|
||||
print $output "result:$json\n";
|
||||
print $output "result:end\n";
|
||||
|
||||
|
|
@ -175,9 +176,12 @@ sub run_server {
|
|||
exit;
|
||||
} else {
|
||||
waitpid $pid, 0;
|
||||
|
||||
# kill any left-over processes started by $USERNAME
|
||||
system("pkill -u $USERNAME");
|
||||
}
|
||||
|
||||
if(not defined $USE_LOCAL or $USE_LOCAL == 0) {
|
||||
if (not $USE_LOCAL) {
|
||||
print "=" x 40, "\n";
|
||||
next;
|
||||
} else {
|
||||
|
|
@ -201,18 +205,12 @@ sub interpret {
|
|||
|
||||
$h{lang} = '_default' if not exists $languages{$h{lang}};
|
||||
|
||||
chdir("/home/$USERNAME");
|
||||
|
||||
my $mod = $h{lang}->new(%h);
|
||||
|
||||
$mod->preprocess;
|
||||
|
||||
# print "after preprocess: ", Dumper $mod, "\n";
|
||||
|
||||
$mod->postprocess if not $mod->{error} and not $mod->{done};
|
||||
|
||||
# print "after postprocess: ", Dumper $mod, "\n";
|
||||
|
||||
if (exists $mod->{no_output} or not length $mod->{output}) {
|
||||
if ($h{factoid}) {
|
||||
$mod->{output} = "";
|
||||
|
|
|
|||
|
|
@ -12,10 +12,8 @@ use parent '_default';
|
|||
sub preprocess {
|
||||
my $self = shift;
|
||||
|
||||
my $input = $self->{input};
|
||||
$input = "" if not defined $input;
|
||||
my $input = $self->{input} // '';
|
||||
|
||||
print "writing input [$input]\n";
|
||||
open(my $fh, '>', '.input');
|
||||
print $fh "$input\n";
|
||||
close $fh;
|
||||
|
|
|
|||
|
|
@ -9,85 +9,91 @@ use warnings;
|
|||
use strict;
|
||||
|
||||
use IPC::Run qw/run timeout/;
|
||||
|
||||
use Data::Dumper;
|
||||
|
||||
$Data::Dumper::Terse = 1;
|
||||
$Data::Dumper::Sortkeys = 1;
|
||||
$Data::Dumper::Useqq = 1;
|
||||
|
||||
sub new {
|
||||
my ($class, %conf) = @_;
|
||||
my $self = bless {}, $class;
|
||||
my ($class, %conf) = @_;
|
||||
my $self = bless {}, $class;
|
||||
|
||||
$self->{debug} = $conf{debug} // 0;
|
||||
$self->{sourcefile} = $conf{sourcefile};
|
||||
$self->{execfile} = $conf{execfile};
|
||||
$self->{code} = $conf{code};
|
||||
$self->{cmdline} = $conf{cmdline};
|
||||
$self->{input} = $conf{input};
|
||||
$self->{date} = $conf{date};
|
||||
$self->{arguments} = $conf{arguments};
|
||||
$self->{factoid} = $conf{factoid};
|
||||
$self->{'persist-key'} = $conf{'persist-key'};
|
||||
$self->{debug} = $conf{debug} // 0;
|
||||
$self->{sourcefile} = $conf{sourcefile};
|
||||
$self->{execfile} = $conf{execfile};
|
||||
$self->{code} = $conf{code};
|
||||
$self->{cmdline} = $conf{cmdline};
|
||||
$self->{input} = $conf{input};
|
||||
$self->{date} = $conf{date};
|
||||
$self->{arguments} = $conf{arguments};
|
||||
$self->{factoid} = $conf{factoid};
|
||||
$self->{'persist-key'} = $conf{'persist-key'};
|
||||
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
my ($self, %conf) = @_;
|
||||
}
|
||||
|
||||
sub preprocess {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
open(my $fh, '>', $self->{sourcefile}) or die $!;
|
||||
binmode($fh, ':utf8');
|
||||
print $fh $self->{code} . "\n";
|
||||
close $fh;
|
||||
open(my $fh, '>', $self->{sourcefile}) or die $!;
|
||||
binmode($fh, ':utf8');
|
||||
print $fh $self->{code} . "\n";
|
||||
close $fh;
|
||||
|
||||
print "Executing [$self->{cmdline}] with args [$self->{arguments}]\n";
|
||||
my $quoted_args = '';
|
||||
|
||||
my @args = $self->split_line($self->{arguments}, strip_quotes => 1, preserve_escapes => 0);
|
||||
if (length $self->{arguments}) {
|
||||
my @args = $self->split_line($self->{arguments}, strip_quotes => 1, preserve_escapes => 0);
|
||||
|
||||
my $quoted_args = '';
|
||||
foreach my $arg (@args) {
|
||||
$arg =~ s/'/'"'"'/g;
|
||||
$quoted_args .= "'$arg' ";
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $arg (@args) {
|
||||
$arg =~ s/'/'"'"'/g;
|
||||
$quoted_args .= "'$arg' ";
|
||||
}
|
||||
$self->{input} = "ulimit -f 2000; ulimit -t 8; ulimit -u 200; $self->{cmdline} $quoted_args";
|
||||
|
||||
$self->{input} = "ulimit -f 2000; ulimit -t 8; ulimit -u 200; $self->{cmdline} $quoted_args";
|
||||
my ($retval, $stdout, $stderr) = $self->execute(60, $self->{input}, '/bin/sh');
|
||||
|
||||
my ($retval, $stdout, $stderr) = $self->execute(60, $self->{input}, '/bin/sh');
|
||||
|
||||
$self->{output} = $stderr;
|
||||
$self->{output} .= ' ' if length $self->{output};
|
||||
$self->{output} .= $stdout;
|
||||
$self->{error} = $retval;
|
||||
$self->{output} = $stderr;
|
||||
$self->{output} .= ' ' if length $self->{output};
|
||||
$self->{output} .= $stdout;
|
||||
$self->{error} = $retval;
|
||||
}
|
||||
|
||||
sub postprocess {
|
||||
my $self = shift;
|
||||
}
|
||||
sub postprocess {}
|
||||
|
||||
sub execute {
|
||||
my ($self, $timeout, $stdin, @cmdline) = @_;
|
||||
my ($self, $timeout, $stdin, @cmdline) = @_;
|
||||
|
||||
$stdin //= '';
|
||||
print "execute($timeout) [$stdin] ", Dumper \@cmdline, "\n";
|
||||
$stdin //= '';
|
||||
|
||||
print "execute ($timeout) [$stdin] @cmdline\n";
|
||||
|
||||
my ($exitval, $stdout, $stderr) = eval {
|
||||
my ($stdout, $stderr);
|
||||
run \@cmdline, \$stdin, \$stdout, \$stderr, timeout($timeout);
|
||||
my $exitval = $? >> 8;
|
||||
return ($exitval, $stdout, $stderr);
|
||||
};
|
||||
|
||||
if (my $exception = $@) {
|
||||
$exception = "[Timed-out]" if $exception =~ m/timeout on timer/;
|
||||
($exitval, $stdout, $stderr) = (-1, '', $exception);
|
||||
}
|
||||
|
||||
$Data::Dumper::Indent = 0;
|
||||
print "exitval $exitval stderr [", Dumper($stderr), "] stdout [", Dumper($stdout), "]\n";
|
||||
$Data::Dumper::Indent = 1;
|
||||
|
||||
my ($exitval, $stdout, $stderr) = eval {
|
||||
my ($stdout, $stderr);
|
||||
run \@cmdline, \$stdin, \$stdout, \$stderr, timeout($timeout);
|
||||
my $exitval = $? >> 8;
|
||||
return ($exitval, $stdout, $stderr);
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
my $error = $@;
|
||||
$error = "[Timed-out]" if $error =~ m/timeout on timer/;
|
||||
($exitval, $stdout, $stderr) = (-1, '', $error);
|
||||
}
|
||||
|
||||
print "exitval $exitval stdout [$stdout]\nstderr [$stderr]\n";
|
||||
return ($exitval, $stdout, $stderr);
|
||||
}
|
||||
|
||||
# splits line into quoted arguments while preserving quotes.
|
||||
|
|
@ -96,111 +102,111 @@ sub execute {
|
|||
# handles unbalanced quotes gracefully by treating them as
|
||||
# part of the argument they were found within.
|
||||
sub split_line {
|
||||
my ($self, $line, %opts) = @_;
|
||||
my ($self, $line, %opts) = @_;
|
||||
|
||||
my %default_opts = (
|
||||
strip_quotes => 0,
|
||||
keep_spaces => 0,
|
||||
preserve_escapes => 1,
|
||||
);
|
||||
my %default_opts = (
|
||||
strip_quotes => 0,
|
||||
keep_spaces => 0,
|
||||
preserve_escapes => 1,
|
||||
);
|
||||
|
||||
%opts = (%default_opts, %opts);
|
||||
%opts = (%default_opts, %opts);
|
||||
|
||||
my @chars = split //, $line;
|
||||
my @chars = split //, $line;
|
||||
|
||||
my @args;
|
||||
my $escaped = 0;
|
||||
my $quote;
|
||||
my $token = '';
|
||||
my $ch = ' ';
|
||||
my $last_ch;
|
||||
my $next_ch;
|
||||
my $i = 0;
|
||||
my $pos;
|
||||
my $ignore_quote = 0;
|
||||
my $spaces = 0;
|
||||
my @args;
|
||||
my $escaped = 0;
|
||||
my $quote;
|
||||
my $token = '';
|
||||
my $ch = ' ';
|
||||
my $last_ch;
|
||||
my $next_ch;
|
||||
my $i = 0;
|
||||
my $pos;
|
||||
my $ignore_quote = 0;
|
||||
my $spaces = 0;
|
||||
|
||||
while (1) {
|
||||
$last_ch = $ch;
|
||||
while (1) {
|
||||
$last_ch = $ch;
|
||||
|
||||
if ($i >= @chars) {
|
||||
if (defined $quote) {
|
||||
# reached end, but unbalanced quote... reset to beginning of quote and ignore it
|
||||
$i = $pos;
|
||||
$ignore_quote = 1;
|
||||
$quote = undef;
|
||||
$last_ch = ' ';
|
||||
$token = '';
|
||||
} else {
|
||||
# add final token and exit
|
||||
push @args, $token if length $token;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ($i >= @chars) {
|
||||
if (defined $quote) {
|
||||
# reached end, but unbalanced quote... reset to beginning of quote and ignore it
|
||||
$i = $pos;
|
||||
$ignore_quote = 1;
|
||||
$quote = undef;
|
||||
$last_ch = ' ';
|
||||
$token = '';
|
||||
} else {
|
||||
# add final token and exit
|
||||
push @args, $token if length $token;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
$ch = $chars[$i++];
|
||||
$next_ch = $chars[$i];
|
||||
$ch = $chars[$i++];
|
||||
$next_ch = $chars[$i];
|
||||
|
||||
$spaces = 0 if $ch ne ' ';
|
||||
$spaces = 0 if $ch ne ' ';
|
||||
|
||||
if ($escaped) {
|
||||
if ($opts{preserve_escapes}) {
|
||||
$token .= "\\$ch";
|
||||
} else {
|
||||
$token .= $ch;
|
||||
}
|
||||
$escaped = 0;
|
||||
next;
|
||||
}
|
||||
|
||||
if ($ch eq '\\') {
|
||||
$escaped = 1;
|
||||
next;
|
||||
}
|
||||
|
||||
if (defined $quote) {
|
||||
if ($ch eq $quote and (not defined $next_ch or $next_ch =~ /[\s,:;})\].+=]/)) {
|
||||
# closing quote
|
||||
$token .= $ch unless $opts{strip_quotes};
|
||||
push @args, $token;
|
||||
$quote = undef;
|
||||
$token = '';
|
||||
} else {
|
||||
# still within quoted argument
|
||||
$token .= $ch;
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
if (($last_ch =~ /[\s:{(\[.+=]/) and not defined $quote and ($ch eq "'" or $ch eq '"')) {
|
||||
if ($ignore_quote) {
|
||||
# treat unbalanced quote as part of this argument
|
||||
$token .= $ch;
|
||||
$ignore_quote = 0;
|
||||
} else {
|
||||
# begin potential quoted argument
|
||||
$pos = $i - 1;
|
||||
$quote = $ch;
|
||||
$token .= $ch unless $opts{strip_quotes};
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
if ($ch eq ' ') {
|
||||
if (++$spaces > 1 and $opts{keep_spaces}) {
|
||||
$token .= $ch;
|
||||
next;
|
||||
} else {
|
||||
push @args, $token if length $token;
|
||||
$token = '';
|
||||
next;
|
||||
}
|
||||
}
|
||||
|
||||
if ($escaped) {
|
||||
if ($opts{preserve_escapes}) {
|
||||
$token .= "\\$ch";
|
||||
} else {
|
||||
$token .= $ch;
|
||||
}
|
||||
$escaped = 0;
|
||||
next;
|
||||
}
|
||||
|
||||
if ($ch eq '\\') {
|
||||
$escaped = 1;
|
||||
next;
|
||||
}
|
||||
|
||||
if (defined $quote) {
|
||||
if ($ch eq $quote and (not defined $next_ch or $next_ch =~ /[\s,:;})\].+=]/)) {
|
||||
# closing quote
|
||||
$token .= $ch unless $opts{strip_quotes};
|
||||
push @args, $token;
|
||||
$quote = undef;
|
||||
$token = '';
|
||||
} else {
|
||||
# still within quoted argument
|
||||
$token .= $ch;
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
if (($last_ch =~ /[\s:{(\[.+=]/) and not defined $quote and ($ch eq "'" or $ch eq '"')) {
|
||||
if ($ignore_quote) {
|
||||
# treat unbalanced quote as part of this argument
|
||||
$token .= $ch;
|
||||
$ignore_quote = 0;
|
||||
} else {
|
||||
# begin potential quoted argument
|
||||
$pos = $i - 1;
|
||||
$quote = $ch;
|
||||
$token .= $ch unless $opts{strip_quotes};
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
if ($ch eq ' ') {
|
||||
if (++$spaces > 1 and $opts{keep_spaces}) {
|
||||
$token .= $ch;
|
||||
next;
|
||||
} else {
|
||||
push @args, $token if length $token;
|
||||
$token = '';
|
||||
next;
|
||||
}
|
||||
}
|
||||
|
||||
$token .= $ch;
|
||||
}
|
||||
|
||||
return @args;
|
||||
return @args;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
Loading…
Reference in New Issue