mirror of
https://github.com/pragma-/pbot.git
synced 2025-01-11 12:32:37 +01:00
Refactoring compiler_vm a bit (1/2)
This commit is contained in:
Pragmatic Software
parent
2832298af3
commit
8bc8a7a8b1
@ -19,8 +19,6 @@ eval {
|
||||
use lib 'languages';
|
||||
require "$language.pm";
|
||||
} or do {
|
||||
$language =~ s/^cfact_//;
|
||||
|
||||
my @modules = glob 'languages/*.pm';
|
||||
my $found = 0;
|
||||
my ($languages, $comma) = ('', '');
|
||||
@ -29,9 +27,11 @@ eval {
|
||||
$module = basename $module;
|
||||
$module =~ s/.pm$//;
|
||||
next if $module =~ m/^_/;
|
||||
require "$module.pm";
|
||||
|
||||
require "$module.pm" or die $!;
|
||||
my $mod = $module->new;
|
||||
|
||||
|
||||
if (exists $mod->{name} and $mod->{name} eq $language) {
|
||||
$language = $module;
|
||||
$found = 1;
|
||||
@ -53,12 +53,12 @@ if (not length $h->{code}) {
|
||||
if (exists $h->{usage}) {
|
||||
print "$h->{usage}\n";
|
||||
} else {
|
||||
print "Usage: cc [-paste] [-lang=<language>] [-info] [language options] <code> [-input=<stdin input>]\n";
|
||||
print "Usage: cc [-lang=<language>] [-info] [-paste] [-args \"command-line arguments\"] [-stdin \"stdin input\"] [compiler/language options] <code>\n";
|
||||
}
|
||||
exit;
|
||||
}
|
||||
|
||||
my $lang = $language->new(%$h);
|
||||
my $lang = $language->new(%{$h});
|
||||
|
||||
$lang->{local} = $ENV{CC_LOCAL};
|
||||
|
||||
|
||||
@ -211,28 +211,6 @@ sub preprocess_code {
|
||||
$prelude .= "\n#include <prelude.h>\n";
|
||||
}
|
||||
|
||||
if (defined $self->{arguments}) {
|
||||
my $qargs = quotemeta $self->{arguments};
|
||||
$qargs =~ s/\\ / /g;
|
||||
my @args = shellwords($self->{arguments});
|
||||
$prelude .= "\nint arglen = " . (scalar @args) . ";\n";
|
||||
|
||||
if (@args) {
|
||||
$prelude .= "char *args[] = { ";
|
||||
|
||||
my $comma = "";
|
||||
foreach my $arg (@args) {
|
||||
$arg =~ s/"/\\"/g;
|
||||
$prelude .= "$comma\"$arg\"";
|
||||
$comma = ", ";
|
||||
}
|
||||
|
||||
$prelude .= " };\n";
|
||||
} else {
|
||||
$prelude .= "char *args[] = {0};\n";
|
||||
}
|
||||
}
|
||||
|
||||
print "*** prelude: [$prelude]\n precode: [$precode]\n" if $self->{debug};
|
||||
|
||||
my $preprecode = $precode;
|
||||
|
||||
@ -14,6 +14,8 @@ use LWP::UserAgent;
|
||||
use Time::HiRes qw/gettimeofday/;
|
||||
use Text::Balanced qw/extract_delimited/;
|
||||
use JSON;
|
||||
use Getopt::Long qw/GetOptionsFromArray :config pass_through/;
|
||||
|
||||
|
||||
my $EXECUTE_PORT = '3333';
|
||||
|
||||
@ -40,11 +42,6 @@ sub new {
|
||||
$self->{lang} =~ s/^\s+|\s+$//g if defined $self->{lang};
|
||||
$self->{code} =~ s/^\s+|\s+$//g if defined $self->{code};
|
||||
|
||||
if (defined $self->{arguments}) {
|
||||
$self->{arguments} = quotemeta $self->{arguments};
|
||||
$self->{arguments} =~ s/\\ / /g;
|
||||
}
|
||||
|
||||
$self->initialize(%conf);
|
||||
|
||||
return $self;
|
||||
@ -70,10 +67,14 @@ sub preprocess_code {
|
||||
unless($self->{got_run} and $self->{copy_code}) {
|
||||
open FILE, ">> log.txt";
|
||||
print FILE localtime() . "\n";
|
||||
print FILE "$self->{nick} $self->{channel}: " . $self->{cmdline_options} . "$self->{code}\n";
|
||||
print FILE "$self->{nick} $self->{channel}: [" . $self->{arguments} . "] " . $self->{cmdline_options} . "$self->{code}\n";
|
||||
close FILE;
|
||||
}
|
||||
|
||||
if (exists $self->{prelude}) {
|
||||
$self->{code} = "$self->{prelude}\n$self->{code}";
|
||||
}
|
||||
|
||||
# replace \n outside of quotes with literal newline
|
||||
my $new_code = "";
|
||||
|
||||
@ -334,6 +335,11 @@ sub execute {
|
||||
$input =~ s/\s+$//;
|
||||
}
|
||||
|
||||
$input =~ s/(?<!\\)\\n/\n/mg;
|
||||
$input =~ s/(?<!\\)\\r/\r/mg;
|
||||
$input =~ s/(?<!\\)\\t/\t/mg;
|
||||
$input =~ s/(?<!\\)\\b/\b/mg;
|
||||
|
||||
my $pretty_code = $self->pretty_format($self->{code});
|
||||
|
||||
my $cmdline = $self->{cmdline};
|
||||
@ -371,8 +377,16 @@ sub execute {
|
||||
print FILE localtime() . "\n";
|
||||
print FILE "$cmdline\n$input\n$pretty_code\n";
|
||||
|
||||
my $compile_in = { lang => $self->{lang}, sourcefile => $self->{sourcefile}, execfile => $self->{execfile},
|
||||
cmdline => $cmdline, input => $input, date => $date, arguments => $self->{arguments}, code => $pretty_code };
|
||||
my $compile_in = {
|
||||
lang => $self->{lang},
|
||||
sourcefile => $self->{sourcefile},
|
||||
execfile => $self->{execfile},
|
||||
cmdline => $cmdline,
|
||||
input => $input,
|
||||
date => $date,
|
||||
arguments => $self->{arguments},
|
||||
code => $pretty_code
|
||||
};
|
||||
|
||||
$compile_in->{'factoid'} = $self->{'factoid'} if length $self->{'factoid'};
|
||||
$compile_in->{'persist-key'} = $self->{'persist-key'} if length $self->{'persist-key'};
|
||||
@ -384,7 +398,7 @@ sub execute {
|
||||
my $sent = 0;
|
||||
my $chunk_max = 4096;
|
||||
my $chunk_size = $length < $chunk_max ? $length : $chunk_max;
|
||||
my $chunks_sent;
|
||||
my $chunks_sent = 0;
|
||||
|
||||
#print FILE "Sending $length bytes [$compile_json] to vm_server\n";
|
||||
|
||||
@ -457,9 +471,30 @@ sub add_option {
|
||||
|
||||
sub process_standard_options {
|
||||
my $self = shift;
|
||||
my $code = $self->{code};
|
||||
|
||||
if ($code =~ s/(?:^|(?<=\s))-info\s*//i) {
|
||||
my @opt_args = $self->split_line($self->{code});
|
||||
|
||||
use Data::Dumper;
|
||||
print STDERR Dumper \@opt_args;
|
||||
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
|
||||
my ($info, $input, $arguments, $paste);
|
||||
my ($ret, $rest) = GetOptionsFromArray(\@opt_args,
|
||||
'info!' => \$info,
|
||||
'stdin|input=s' => \$input,
|
||||
'args|arguments=s' => \$arguments,
|
||||
'paste!' => \$paste);
|
||||
|
||||
print STDERR "getopt: ret: [$ret]: rest: [$rest], info: $info, input: $input, args: $arguments, paste: $paste\n";
|
||||
|
||||
print STDERR Dumper @opt_args;
|
||||
|
||||
if ($info) {
|
||||
my $cmdline = $self->{cmdline};
|
||||
if (length $self->{default_options}) {
|
||||
$cmdline =~ s/\$options/$self->{default_options}/;
|
||||
@ -473,15 +508,25 @@ sub process_standard_options {
|
||||
exit;
|
||||
}
|
||||
|
||||
if ($code =~ s/-(?:input|stdin)=(.*)$//i) {
|
||||
$self->add_option("-input", $1);
|
||||
if (defined $input) {
|
||||
if (not $input =~ s/^"(.*)"$/$1/) {
|
||||
$input =~ s/^'(.*)'$/$1/;
|
||||
}
|
||||
$self->add_option("-input", $input);
|
||||
}
|
||||
|
||||
if ($code =~ s/(?:^|(?<=\s))-paste\s*//i) {
|
||||
if (defined $arguments) {
|
||||
if (not $arguments =~ s/^"(.*)"$/$1/) {
|
||||
$arguments =~ s/^'(.*)'$/$1/;
|
||||
}
|
||||
$self->{arguments} = $arguments;
|
||||
}
|
||||
|
||||
if ($paste) {
|
||||
$self->add_option("-paste");
|
||||
}
|
||||
|
||||
$self->{code} = $code;
|
||||
$self->{code} = join ' ', @opt_args;
|
||||
}
|
||||
|
||||
sub process_custom_options {
|
||||
@ -1002,4 +1047,108 @@ sub process_interactive_edit {
|
||||
$self->{code} = $code;
|
||||
}
|
||||
|
||||
# splits line into quoted arguments while preserving quotes. handles
|
||||
# unbalanced quotes gracefully by treating them as part of the argument
|
||||
# they were found within.
|
||||
sub split_line {
|
||||
my ($self, $line, %opts) = @_;
|
||||
|
||||
my %default_opts = (
|
||||
strip_quotes => 0,
|
||||
keep_spaces => 0
|
||||
);
|
||||
|
||||
%opts = (%default_opts, %opts);
|
||||
|
||||
my @chars = split //, $line;
|
||||
|
||||
my @args;
|
||||
my $escaped = 0;
|
||||
my $quote;
|
||||
my $token = '';
|
||||
my $ch = ' ';
|
||||
my $last_ch;
|
||||
my $i = 0;
|
||||
my $pos;
|
||||
my $ignore_quote = 0;
|
||||
my $spaces = 0;
|
||||
|
||||
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;
|
||||
}
|
||||
}
|
||||
|
||||
$ch = $chars[$i++];
|
||||
|
||||
$spaces = 0 if $ch ne ' ';
|
||||
|
||||
if ($escaped) {
|
||||
$token .= "\\$ch";
|
||||
$escaped = 0;
|
||||
next;
|
||||
}
|
||||
|
||||
if ($ch eq '\\') {
|
||||
$escaped = 1;
|
||||
next;
|
||||
}
|
||||
|
||||
if (defined $quote) {
|
||||
if ($ch eq $quote) {
|
||||
# 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 eq ' ' 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;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@ -16,8 +16,6 @@ sub initialize {
|
||||
$self->{options_nopaste} = '-fno-diagnostics-show-caret';
|
||||
$self->{cmdline} = 'gcc -ggdb -g3 $sourcefile $options -o $execfile';
|
||||
|
||||
# $self->{default_options} .= ' -Werror' if defined $self->{nick} && $self->{nick} =~ m/marchelz/i;
|
||||
|
||||
$self->{prelude} = <<'END';
|
||||
#define _XOPEN_SOURCE 9001
|
||||
#define __USE_XOPEN
|
||||
|
||||
@ -16,8 +16,6 @@ sub initialize {
|
||||
$self->{options_nopaste} = '-fno-diagnostics-show-caret';
|
||||
$self->{cmdline} = 'gcc -ggdb -g3 $sourcefile $options -o $execfile';
|
||||
|
||||
# $self->{default_options} .= ' -Werror' if defined $self->{nick} && $self->{nick} =~ m/marchelz/i;
|
||||
|
||||
$self->{prelude} = <<'END';
|
||||
#define _XOPEN_SOURCE 9001
|
||||
#define __USE_XOPEN
|
||||
|
||||
@ -15,37 +15,6 @@ sub initialize {
|
||||
$self->{execfile} = 'prog.pl';
|
||||
$self->{default_options} = '-w';
|
||||
$self->{cmdline} = 'perl $options $sourcefile';
|
||||
|
||||
if (length $self->{arguments}) {
|
||||
$self->{cmdline} .= " $self->{arguments}";
|
||||
}
|
||||
}
|
||||
|
||||
sub preprocess_code {
|
||||
my $self = shift;
|
||||
$self->SUPER::preprocess_code;
|
||||
|
||||
if (defined $self->{arguments}) {
|
||||
my @args = shellwords($self->{arguments});
|
||||
my $prelude .= "\nmy \$arglen = " . (scalar @args) . ";\n";
|
||||
|
||||
if (@args) {
|
||||
$prelude .= "my \@args = (";
|
||||
|
||||
my $comma = "";
|
||||
foreach my $arg (@args) {
|
||||
$arg = quotemeta $arg;
|
||||
$prelude .= "$comma\"$arg\"";
|
||||
$comma = ", ";
|
||||
}
|
||||
|
||||
$prelude .= ");\n";
|
||||
} else {
|
||||
$prelude .= "my \@args;\n";
|
||||
}
|
||||
|
||||
$self->{code} = "$prelude\n$self->{code}";
|
||||
}
|
||||
}
|
||||
|
||||
sub postprocess_output {
|
||||
|
||||
@ -8,7 +8,55 @@ use parent '_default';
|
||||
|
||||
sub preprocess {
|
||||
my $self = shift;
|
||||
$self->SUPER::preprocess;
|
||||
|
||||
my $input = $self->{input};
|
||||
$input = "" if not defined $input;
|
||||
|
||||
print "writing input [$input]\n";
|
||||
open(my $fh, '>', '.input');
|
||||
print $fh "$input\n";
|
||||
close $fh;
|
||||
|
||||
$self->execute(10, undef, 'date', '-s', "\@$self->{date}");
|
||||
|
||||
my @cmd = $self->split_line($self->{cmdline}, strip_quotes => 1);
|
||||
|
||||
if ($self->{code} =~ m/print_last_statement\(.*\);$/m) {
|
||||
# remove print_last_statement wrapper in order to get warnings/errors from last statement line
|
||||
my $code = $self->{code};
|
||||
$code =~ s/print_last_statement\((.*)\);$/$1;/mg;
|
||||
open(my $fh, '>', $self->{sourcefile}) or die $!;
|
||||
print $fh $code . "\n";
|
||||
close $fh;
|
||||
|
||||
print "Executing [$self->{cmdline}] without print_last_statement\n";
|
||||
my ($retval, $stdout, $stderr) = $self->execute(60, undef, @cmd);
|
||||
$self->{output} = $stderr;
|
||||
$self->{output} .= ' ' if length $self->{output};
|
||||
$self->{output} .= $stdout;
|
||||
$self->{error} = $retval;
|
||||
|
||||
# now compile with print_last_statement intact, ignoring compile results
|
||||
if (not $self->{error}) {
|
||||
open(my $fh, '>', $self->{sourcefile}) or die $!;
|
||||
print $fh $self->{code} . "\n";
|
||||
close $fh;
|
||||
|
||||
print "Executing [$self->{cmdline}] with print_last_statement\n";
|
||||
$self->execute(60, undef, @cmd);
|
||||
}
|
||||
} else {
|
||||
open(my $fh, '>', $self->{sourcefile}) or die $!;
|
||||
print $fh $self->{code} . "\n";
|
||||
close $fh;
|
||||
|
||||
print "Executing [$self->{cmdline}]\n";
|
||||
my ($retval, $stdout, $stderr) = $self->execute(60, undef, @cmd);
|
||||
$self->{output} = $stderr;
|
||||
$self->{output} .= ' ' if length $self->{output};
|
||||
$self->{output} .= $stdout;
|
||||
$self->{error} = $retval;
|
||||
}
|
||||
|
||||
if ($self->{cmdline} =~ m/--(?:version|analyze)/) {
|
||||
$self->{done} = 1;
|
||||
@ -27,22 +75,17 @@ sub postprocess {
|
||||
}
|
||||
|
||||
print "Executing gdb\n";
|
||||
my ($retval, $result) = $self->execute(60, "date -s \@$self->{date}; ulimit -t 5; compiler_watchdog.pl $self->{arguments} > .output");
|
||||
my @args = $self->split_line($self->{arguments}, strip_quotes => 1);
|
||||
my ($exitval, $stdout, $stderr) = $self->execute(60, undef, 'compiler_watchdog.pl', @args);
|
||||
|
||||
$result = "";
|
||||
open(FILE, '.output');
|
||||
while(<FILE>) {
|
||||
$result .= $_;
|
||||
last if length $result >= 1024 * 20;
|
||||
}
|
||||
close(FILE);
|
||||
|
||||
$result =~ s/\s+$//;
|
||||
my $result = $stderr;
|
||||
$result .= ' ' if length $result;
|
||||
$result .= $stdout;
|
||||
|
||||
if (not length $result) {
|
||||
$self->{no_output} = 1;
|
||||
} elsif ($self->{code} =~ m/print_last_statement\(.*\);$/m
|
||||
&& ($result =~ m/A syntax error in expression/ || $result =~ m/No symbol.*in current context/ || $result =~ m/has unknown return type; cast the call to its declared/ || $result =~ m/Can't take address of.*which isn't an lvalue/)) {
|
||||
&& ($result =~ m/A syntax error in expression/ || $result =~ m/No symbol.*in current context/ || $result =~ m/has unknown return type; cast the call to its declared return/ || $result =~ m/Can't take address of.*which isn't an lvalue/)) {
|
||||
# strip print_last_statement and rebuild/re-run
|
||||
$self->{code} =~ s/print_last_statement\((.*)\);/$1;/mg;
|
||||
$self->preprocess;
|
||||
|
||||
@ -1,30 +1,32 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package _default;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use feature "switch";
|
||||
|
||||
use feature "switch";
|
||||
no if $] >= 5.018, warnings => "experimental::smartmatch";
|
||||
|
||||
package _default;
|
||||
use IPC::Run qw/run timeout/;
|
||||
use Data::Dumper;
|
||||
|
||||
sub new {
|
||||
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->{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;
|
||||
}
|
||||
|
||||
@ -35,52 +37,21 @@ sub initialize {
|
||||
sub preprocess {
|
||||
my $self = shift;
|
||||
|
||||
my $input = $self->{input};
|
||||
$input = "" if not defined $input;
|
||||
|
||||
print "writing input [$input]\n";
|
||||
|
||||
$input =~ s/(?<!\\)\\n/\n/mg;
|
||||
$input =~ s/(?<!\\)\\r/\r/mg;
|
||||
$input =~ s/(?<!\\)\\t/\t/mg;
|
||||
$input =~ s/(?<!\\)\\b/\b/mg;
|
||||
|
||||
open(my $fh, '>', '.input');
|
||||
print $fh "$input\n";
|
||||
open(my $fh, '>', $self->{sourcefile}) or die $!;
|
||||
print $fh $self->{code} . "\n";
|
||||
close $fh;
|
||||
|
||||
if ($self->{code} =~ m/print_last_statement\(.*\);$/m) {
|
||||
# remove print_last_statement wrapper in order to get warnings/errors from last statement line
|
||||
my $code = $self->{code};
|
||||
$code =~ s/print_last_statement\((.*)\);$/$1;/mg;
|
||||
open(my $fh, '>', $self->{sourcefile}) or die $!;
|
||||
print $fh $code . "\n";
|
||||
close $fh;
|
||||
$self->execute(10, undef, 'date', '-s', "\@$self->{date}");
|
||||
|
||||
print "Executing [$self->{cmdline}] without print_last_statement\n";
|
||||
my ($retval, $result) = $self->execute(60, "date -s \@$self->{date} > /dev/null; ulimit -t 5; $self->{cmdline}");
|
||||
$self->{output} = $result;
|
||||
$self->{error} = $retval;
|
||||
print "Executing [$self->{cmdline}] with args [$self->{arguments}]\n";
|
||||
my @cmdline = $self->split_line($self->{cmdline}, strip_quotes => 1);
|
||||
push @cmdline, $self->split_line($self->{arguments}, strip_quotes => 1);
|
||||
|
||||
# now compile with print_last_statement intact, ignoring compile results
|
||||
if (not $self->{error}) {
|
||||
open(my $fh, '>', $self->{sourcefile}) or die $!;
|
||||
print $fh $self->{code} . "\n";
|
||||
close $fh;
|
||||
|
||||
print "Executing [$self->{cmdline}] with print_last_statement\n";
|
||||
my ($retval, $result) = $self->execute(60, "date -s \@$self->{date} > /dev/null; ulimit -t 5; $self->{cmdline}");
|
||||
}
|
||||
} else {
|
||||
open(my $fh, '>', $self->{sourcefile}) or die $!;
|
||||
print $fh $self->{code} . "\n";
|
||||
close $fh;
|
||||
|
||||
print "Executing [$self->{cmdline}]\n";
|
||||
my ($retval, $result) = $self->execute(60, "date -s \@$self->{date} > /dev/null; ulimit -t 5; $self->{cmdline} < .input");
|
||||
$self->{output} = $result;
|
||||
$self->{error} = $retval;
|
||||
}
|
||||
my ($retval, $stdout, $stderr) = $self->execute(60, $self->{input}, @cmdline);
|
||||
$self->{output} = $stderr;
|
||||
$self->{output} .= ' ' if length $self->{output};
|
||||
$self->{output} .= $stdout;
|
||||
$self->{error} = $retval;
|
||||
}
|
||||
|
||||
sub postprocess {
|
||||
@ -88,42 +59,130 @@ sub postprocess {
|
||||
}
|
||||
|
||||
sub execute {
|
||||
my $self = shift;
|
||||
my $timeout = shift;
|
||||
my ($cmdline) = @_;
|
||||
my ($self, $timeout, $stdin, @cmdline) = @_;
|
||||
|
||||
my ($ret, $result);
|
||||
$stdin //= '';
|
||||
print "execute($timeout) [$stdin] ", Dumper \@cmdline, "\n";
|
||||
|
||||
($ret, $result) = eval {
|
||||
print "eval\n";
|
||||
|
||||
my $result = '';
|
||||
|
||||
my $pid = open(my $fh, '-|', "$cmdline 2>&1");
|
||||
|
||||
local $SIG{ALRM} = sub { print "Time out\n"; kill 'TERM', $pid; die "$result [Timed-out]\n"; };
|
||||
local $SIG{CHLD} = 'IGNORE';
|
||||
alarm($timeout);
|
||||
|
||||
while(my $line = <$fh>) {
|
||||
$result .= $line;
|
||||
}
|
||||
|
||||
close $fh;
|
||||
my $ret = $? >> 8;
|
||||
alarm 0;
|
||||
return ($ret, $result);
|
||||
my ($exitval, $stdout, $stderr) = eval {
|
||||
my ($stdout, $stderr);
|
||||
run \@cmdline, \$stdin, \$stdout, \$stderr, timeout($timeout);
|
||||
my $exitval = $? >> 8;
|
||||
return ($exitval, $stdout, $stderr);
|
||||
};
|
||||
|
||||
print "done eval\n";
|
||||
alarm 0;
|
||||
|
||||
if($@ =~ /Timed-out/) {
|
||||
return (-1, $@);
|
||||
if ($@) {
|
||||
my $error = $@;
|
||||
$error = "[Timed-out]" if $error =~ m/timeout on timer/;
|
||||
($exitval, $stdout, $stderr) = (-1, '', $error);
|
||||
}
|
||||
|
||||
print "[$ret, $result]\n";
|
||||
return ($ret, $result);
|
||||
print "exitval $exitval stdout [$stdout]\nstderr [$stderr]\n";
|
||||
return ($exitval, $stdout, $stderr);
|
||||
}
|
||||
|
||||
# splits line into quoted arguments while preserving quotes. handles
|
||||
# unbalanced quotes gracefully by treating them as part of the argument
|
||||
# they were found within.
|
||||
sub split_line {
|
||||
my ($self, $line, %opts) = @_;
|
||||
|
||||
my %default_opts = (
|
||||
strip_quotes => 0,
|
||||
keep_spaces => 0
|
||||
);
|
||||
|
||||
%opts = (%default_opts, %opts);
|
||||
|
||||
my @chars = split //, $line;
|
||||
|
||||
my @args;
|
||||
my $escaped = 0;
|
||||
my $quote;
|
||||
my $token = '';
|
||||
my $ch = ' ';
|
||||
my $last_ch;
|
||||
my $i = 0;
|
||||
my $pos;
|
||||
my $ignore_quote = 0;
|
||||
my $spaces = 0;
|
||||
|
||||
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;
|
||||
}
|
||||
}
|
||||
|
||||
$ch = $chars[$i++];
|
||||
|
||||
$spaces = 0 if $ch ne ' ';
|
||||
|
||||
if ($escaped) {
|
||||
$token .= "\\$ch";
|
||||
$escaped = 0;
|
||||
next;
|
||||
}
|
||||
|
||||
if ($ch eq '\\') {
|
||||
$escaped = 1;
|
||||
next;
|
||||
}
|
||||
|
||||
if (defined $quote) {
|
||||
if ($ch eq $quote) {
|
||||
# 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 eq ' ' 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;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user