From 8bc8a7a8b1470cbbce7a298bbbaabfe924e30c1e Mon Sep 17 00:00:00 2001 From: Pragmatic Software Date: Wed, 12 Jun 2019 21:35:04 -0700 Subject: [PATCH] Refactoring compiler_vm a bit (1/2) --- modules/compiler_vm/compiler_vm_client.pl | 10 +- modules/compiler_vm/languages/_c_base.pm | 22 -- modules/compiler_vm/languages/_default.pm | 179 ++++++++++++-- modules/compiler_vm/languages/c89.pm | 2 - modules/compiler_vm/languages/c99.pm | 2 - modules/compiler_vm/languages/perl.pm | 31 --- .../compiler_vm/languages/server/_c_base.pm | 67 +++++- .../compiler_vm/languages/server/_default.pm | 227 +++++++++++------- 8 files changed, 367 insertions(+), 173 deletions(-) diff --git a/modules/compiler_vm/compiler_vm_client.pl b/modules/compiler_vm/compiler_vm_client.pl index bb6dab00..801cf852 100755 --- a/modules/compiler_vm/compiler_vm_client.pl +++ b/modules/compiler_vm/compiler_vm_client.pl @@ -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=] [-info] [language options] [-input=]\n"; + print "Usage: cc [-lang=] [-info] [-paste] [-args \"command-line arguments\"] [-stdin \"stdin input\"] [compiler/language options] \n"; } exit; } -my $lang = $language->new(%$h); +my $lang = $language->new(%{$h}); $lang->{local} = $ENV{CC_LOCAL}; diff --git a/modules/compiler_vm/languages/_c_base.pm b/modules/compiler_vm/languages/_c_base.pm index 12a95d5a..ad176495 100755 --- a/modules/compiler_vm/languages/_c_base.pm +++ b/modules/compiler_vm/languages/_c_base.pm @@ -211,28 +211,6 @@ sub preprocess_code { $prelude .= "\n#include \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; diff --git a/modules/compiler_vm/languages/_default.pm b/modules/compiler_vm/languages/_default.pm index bf5af657..6e78acea 100755 --- a/modules/compiler_vm/languages/_default.pm +++ b/modules/compiler_vm/languages/_default.pm @@ -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/(?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; diff --git a/modules/compiler_vm/languages/c89.pm b/modules/compiler_vm/languages/c89.pm index 6e6c5b37..66aa2e98 100755 --- a/modules/compiler_vm/languages/c89.pm +++ b/modules/compiler_vm/languages/c89.pm @@ -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 diff --git a/modules/compiler_vm/languages/c99.pm b/modules/compiler_vm/languages/c99.pm index 00164afb..7529ac26 100755 --- a/modules/compiler_vm/languages/c99.pm +++ b/modules/compiler_vm/languages/c99.pm @@ -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 diff --git a/modules/compiler_vm/languages/perl.pm b/modules/compiler_vm/languages/perl.pm index 14aec422..14d2c7f5 100755 --- a/modules/compiler_vm/languages/perl.pm +++ b/modules/compiler_vm/languages/perl.pm @@ -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 { diff --git a/modules/compiler_vm/languages/server/_c_base.pm b/modules/compiler_vm/languages/server/_c_base.pm index c790a034..74672005 100755 --- a/modules/compiler_vm/languages/server/_c_base.pm +++ b/modules/compiler_vm/languages/server/_c_base.pm @@ -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() { - $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; diff --git a/modules/compiler_vm/languages/server/_default.pm b/modules/compiler_vm/languages/server/_default.pm index ebcde229..4292190e 100755 --- a/modules/compiler_vm/languages/server/_default.pm +++ b/modules/compiler_vm/languages/server/_default.pm @@ -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/(?', '.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;