From b6b90ffa498b955a898d3a82069da82b19d2263a Mon Sep 17 00:00:00 2001 From: Pragmatic Software Date: Wed, 14 Jan 2015 21:51:17 -0800 Subject: [PATCH] Significantly refactor compiler_vm module The compiler_vm module has been significantly refactored into distinct modules in order to better facilitate the addition of other languages and compilers. Currently there is support for C89, C99 and C11 using gcc, as well as support for Perl. This is an initial work-in-progress commit and there are still some minor rough edges to polish up. --- modules/compiler_vm/compiler_vm_client.pl | 1248 +---------------- modules/compiler_vm/compiler_vm_server.pl | 199 +-- modules/compiler_vm/languages/_default.pm | 806 +++++++++++ modules/compiler_vm/languages/c11.pm | 507 +++++++ modules/compiler_vm/languages/c89.pm | 39 + modules/compiler_vm/languages/c99.pm | 50 + modules/compiler_vm/languages/perl.pm | 26 + .../compiler_vm/languages/server/_default.pm | 87 ++ modules/compiler_vm/languages/server/c11.pm | 37 + modules/compiler_vm/languages/server/c89.pm | 9 + modules/compiler_vm/languages/server/c99.pm | 9 + 11 files changed, 1648 insertions(+), 1369 deletions(-) create mode 100755 modules/compiler_vm/languages/_default.pm create mode 100755 modules/compiler_vm/languages/c11.pm create mode 100755 modules/compiler_vm/languages/c89.pm create mode 100755 modules/compiler_vm/languages/c99.pm create mode 100755 modules/compiler_vm/languages/perl.pm create mode 100755 modules/compiler_vm/languages/server/_default.pm create mode 100755 modules/compiler_vm/languages/server/c11.pm create mode 100755 modules/compiler_vm/languages/server/c89.pm create mode 100755 modules/compiler_vm/languages/server/c99.pm diff --git a/modules/compiler_vm/compiler_vm_client.pl b/modules/compiler_vm/compiler_vm_client.pl index 2da1f378..48fc09a0 100755 --- a/modules/compiler_vm/compiler_vm_client.pl +++ b/modules/compiler_vm/compiler_vm_client.pl @@ -1,1230 +1,30 @@ -#!/usr/bin/perl +#!/usr/bin/env perl -# use warnings; +use warnings; use strict; -use feature "switch"; -no if $] >= 5.018, warnings => "experimental::smartmatch"; +my $language = shift @ARGV // 'c11'; +$language = lc $language; -use IPC::Open2; -use Text::Balanced qw(extract_bracketed extract_delimited); -use IO::Socket; -use LWP::UserAgent; -use Time::HiRes qw/gettimeofday/; - -my $debug = 0; - -$SIG{INT} = sub { cleanup(); exit 1; }; - -my $compiler_client; - -sub cleanup { - close $compiler_client if defined $compiler_client; -} - -my $USE_LOCAL = defined $ENV{'CC_LOCAL'}; -my $MAX_UNDO_HISTORY = 1000000; - -my $output = ""; -my $nooutput = 'No output.'; - -my $warn_unterminated_define = 0; -my $save_last_code = 0; -my $unshift_last_code = 0; -my $only_show = 0; - -my %languages = ( - 'C11' => "gcc -std=c11 -pedantic -Wall -Wextra -Wno-unused -Wfloat-equal -Wshadow -Wfatal-errors", - 'C99' => "gcc -std=c99 -pedantic -Wall -Wextra -Wno-unused -Wfloat-equal -Wshadow -Wfatal-errors", - 'C89' => "gcc -std=c89 -pedantic -Wall -Wextra -Wno-unused -Wfloat-equal -Wshadow -Wfatal-errors", -); - -my %preludes = ( - 'C99' => "#define _XOPEN_SOURCE 9001\n#define __USE_XOPEN\n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#inclue \n#include \n#include \n#include \n\n", - 'C11' => "#define _XOPEN_SOURCE 9001\n#define __USE_XOPEN\n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n\n", - 'C89' => "#define _XOPEN_SOURCE 9001\n#define __USE_XOPEN\n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n\n", -); - -sub pretty { - my $code = join '', @_; - my $result; - - open my $fh, ">prog.c" or die "Couldn't write prog.c: $!"; - print $fh $code; - close $fh; - - system("astyle", "-UHfenq", "prog.c"); - - open $fh, "; - close $fh; - - return $result; -} - -sub paste_codepad { - my $text = join(' ', @_); - - $text =~ s/(.{120})\s/$1\n/g; - - my $ua = LWP::UserAgent->new(); - $ua->agent("Mozilla/5.0"); - push @{ $ua->requests_redirectable }, 'POST'; - - my %post = ( 'lang' => 'C', 'code' => $text, 'private' => 'True', 'submit' => 'Submit' ); - my $response = $ua->post("http://codepad.org", \%post); - - if(not $response->is_success) { - return $response->status_line; - } - - return $response->request->uri; -} - -sub paste_sprunge { - my $text = join(' ', @_); - - $text =~ s/(.{120})\s/$1\n/g; - - my $ua = LWP::UserAgent->new(); - $ua->agent("Mozilla/5.0"); - $ua->requests_redirectable([ ]); - - my %post = ( 'sprunge' => $text, 'submit' => 'Submit' ); - my $response = $ua->post("http://sprunge.us", \%post); - - if(not $response->is_success) { - return $response->status_line; - } - - my $result = $response->content; - $result =~ s/^\s+//; - $result =~ s/\s+$/?c/; - - # 2014/7/23 -- sprunge.us suddenly stops producing URLs and only produces paste id - if ($result !~ /sprunge.us/) { - $result = "http://sprunge.us/$result"; - } - - return $result; -} - -sub compile { - my ($lang, $code, $args, $input, $local) = @_; - - my ($compiler, $compiler_output, $pid); - - if(defined $local and $local != 0) { - print "Using local compiler instead of virtual machine\n"; - $pid = open2($compiler_output, $compiler, './compiler_vm_server.pl') || die "repl failed: $@\n"; - print "Started compiler, pid: $pid\n"; - } else { - $compiler = IO::Socket::INET->new(PeerAddr => '127.0.0.1', PeerPort => '3333', Proto => 'tcp', Type => SOCK_STREAM); - die "Could not create socket: $!" unless $compiler; - $compiler_output = $compiler; - $compiler_client = $compiler; - } - - my $date = time; - - print $compiler "compile:$lang:$args:$input:$date\n"; - print $compiler "$code\n"; - print $compiler "compile:end\n"; - - my $result = ""; - my $got_result = 0; - - while(my $line = <$compiler_output>) { - $line =~ s/[\r\n]+$//; - - last if $line =~ /^result:end$/; - - if($line =~ /^result:/) { - $line =~ s/^result://; - $result .= $line; - $got_result = 1; - next; - } - - if($got_result) { - $result .= $line . "\n"; - } - } - - close $compiler; - close $output if defined $output; - waitpid($pid, 0) if defined $pid; - return $result; -} - -if($#ARGV < 2) { - print "Usage: cc [-compiler options] [-options] [-stdin=input]\n"; - # usage for shell: cc [-compiler -options] [-stdin=input] - exit 0; -} - -my $nick = shift @ARGV; -my $channel = lc shift @ARGV; -my $code = join ' ', @ARGV; -my @last_code; - -print " code: [$code]\n" if $debug; - -my $subcode = $code; -while ($subcode =~ s/^\s*(-[^ ]+)\s*//) {} - -my $copy_code; -if($subcode =~ s/^\s*copy\s+(\S+)\s*//) { - my $copy = $1; - - if(open FILE, "< history/$copy.hist") { - $copy_code = ; - close FILE; - goto COPY_ERROR if not $copy_code;; - chomp $copy_code; - } else { - goto COPY_ERROR; - } - - goto COPY_SUCCESS; - - COPY_ERROR: - print "$nick: No history for $copy.\n"; - exit 0; - - COPY_SUCCESS: - $code = $copy_code; - $only_show = 1; - $save_last_code = 1; -} - -if($subcode =~ m/^\s*(?:and\s+)?(?:diff|show)\s+(\S+)\s*$/) { - $channel = $1; -} - -if(open FILE, "< history/$channel.hist") { - while(my $line = ) { - chomp $line; - push @last_code, $line; - } - close FILE; -} - -unshift @last_code, $copy_code if defined $copy_code; - -if($subcode =~ m/^\s*(?:and\s+)?show(?:\s+\S+)?\s*$/i) { - if(defined $last_code[0]) { - print "$nick: $last_code[0]\n"; - } else { - print "$nick: No recent code to show.\n" - } - exit 0; -} - -if($subcode =~ m/^\s*(?:and\s+)?diff(?:\s+\S+)?\s*$/i) { - if($#last_code < 1) { - print "$nick: Not enough recent code to diff.\n" - } else { - use Text::WordDiff; - my $diff = word_diff(\$last_code[1], \$last_code[0], { STYLE => 'Diff' }); - if($diff !~ /(?:|)/) { - $diff = "No difference."; - } else { - $diff =~ s/(.*?)(\s+)<\/del>/$1<\/del>$2/g; - $diff =~ s/(.*?)(\s+)<\/ins>/$1<\/ins>$2/g; - $diff =~ s/((?:(?!).)*)<\/del>\s*((?:(?!).)*)<\/ins>/`replaced $1 with $2`/g; - $diff =~ s/(.*?)<\/del>/`removed $1`/g; - $diff =~ s/(.*?)<\/ins>/`inserted $1`/g; - } - - print "$nick: $diff\n"; - } - exit 0; -} - -my $got_run; - -if($subcode =~ m/^\s*(?:and\s+)?(run|paste)\s*$/i) { - $got_run = lc $1; - if(defined $last_code[0]) { - $code = $last_code[0]; - $only_show = 0; - } else { - print "$nick: No recent code to $got_run.\n"; - exit 0; - } -} else { - my $got_undo = 0; - my $got_sub = 0; - - while($subcode =~ s/^\s*(and)?\s*undo//) { - splice @last_code, 0, 1; - if(not defined $last_code[0]) { - print "$nick: No more undos remaining.\n"; - exit 0; - } else { - $code = $last_code[0]; - $got_undo = 1; - } - } - - my @replacements; - my $prevchange = $last_code[0]; - my $got_changes = 0; - my $last_keyword; - - while(1) { - $got_sub = 0; - #$got_changes = 0; - - $subcode =~ s/^\s*and\s+'/and $last_keyword '/ if defined $last_keyword; - - if($subcode =~ m/^\s*(and)?\s*remove \s*([^']+)?\s*'/) { - $last_keyword = 'remove'; - my $modifier = 'first'; - - $subcode =~ s/^\s*(and)?\s*//; - $subcode =~ s/remove\s*([^']+)?\s*//i; - $modifier = $1 if defined $1; - $modifier =~ s/\s+$//; - - my ($e, $r) = extract_delimited($subcode, "'"); - - my $text; - - if(defined $e) { - $text = $e; - $text =~ s/^'//; - $text =~ s/'$//; - $subcode = "replace $modifier '$text' with ''$r"; - } else { - print "$nick: Unbalanced single quotes. Usage: cc remove [all, first, .., tenth, last] 'text' [and ...]\n"; - exit 0; - } - next; - } - - if($subcode =~ s/^\s*(and)?\s*prepend '//) { - $last_keyword = 'prepend'; - $subcode = "'$subcode"; - - my ($e, $r) = extract_delimited($subcode, "'"); - - my $text; - - if(defined $e) { - $text = $e; - $text =~ s/^'//; - $text =~ s/'$//; - $subcode = $r; - - $got_sub = 1; - $got_changes = 1; - - if(not defined $prevchange) { - print "$nick: No recent code to prepend to.\n"; - exit 0; - } - - $code = $prevchange; - $code =~ s/^/$text /; - $prevchange = $code; - } else { - print "$nick: Unbalanced single quotes. Usage: cc prepend 'text' [and ...]\n"; - exit 0; - } - next; - } - - if($subcode =~ s/^\s*(and)?\s*append '//) { - $last_keyword = 'append'; - $subcode = "'$subcode"; - - my ($e, $r) = extract_delimited($subcode, "'"); - - my $text; - - if(defined $e) { - $text = $e; - $text =~ s/^'//; - $text =~ s/'$//; - $subcode = $r; - - $got_sub = 1; - $got_changes = 1; - - if(not defined $prevchange) { - print "$nick: No recent code to append to.\n"; - exit 0; - } - - $code = $prevchange; - $code =~ s/$/ $text/; - $prevchange = $code; - } else { - print "$nick: Unbalanced single quotes. Usage: cc append 'text' [and ...]\n"; - exit 0; - } - next; - } - - if($subcode =~ m/^\s*(and)?\s*replace\s*([^']+)?\s*'.*'\s*with\s*'.*?'/i) { - $last_keyword = 'replace'; - $got_sub = 1; - my $modifier = 'first'; - - $subcode =~ s/^\s*(and)?\s*//; - $subcode =~ s/replace\s*([^']+)?\s*//i; - $modifier = $1 if defined $1; - $modifier =~ s/\s+$//; - - my ($from, $to); - my ($e, $r) = extract_delimited($subcode, "'"); - - if(defined $e) { - $from = $e; - $from =~ s/^'//; - $from =~ s/'$//; - $from = quotemeta $from; - $subcode = $r; - $subcode =~ s/\s*with\s*//i; - } else { - print "$nick: Unbalanced single quotes. Usage: cc replace 'from' with 'to' [and ...]\n"; - exit 0; - } - - ($e, $r) = extract_delimited($subcode, "'"); - - if(defined $e) { - $to = $e; - $to =~ s/^'//; - $to =~ s/'$//; - $subcode = $r; - } else { - print "$nick: Unbalanced single quotes. Usage: cc replace 'from' with 'to' [and replace ... with ... [and ...]]\n"; - exit 0; - } - - given($modifier) { - when($_ eq 'all' ) {} - when($_ eq 'last' ) {} - when($_ eq 'first' ) { $modifier = 1; } - when($_ eq 'second' ) { $modifier = 2; } - when($_ eq 'third' ) { $modifier = 3; } - when($_ eq 'fourth' ) { $modifier = 4; } - when($_ eq 'fifth' ) { $modifier = 5; } - when($_ eq 'sixth' ) { $modifier = 6; } - when($_ eq 'seventh') { $modifier = 7; } - when($_ eq 'eighth' ) { $modifier = 8; } - when($_ eq 'nineth' ) { $modifier = 9; } - when($_ eq 'tenth' ) { $modifier = 10; } - default { print "$nick: Bad replacement modifier '$modifier'; valid modifiers are 'all', 'first', 'second', ..., 'tenth', 'last'\n"; exit 0; } - } - - my $replacement = {}; - $replacement->{'from'} = $from; - $replacement->{'to'} = $to; - $replacement->{'modifier'} = $modifier; - - push @replacements, $replacement; - next; - } - - if($subcode =~ m/^\s*(and)?\s*s\/.*\//) { - $last_keyword = undef; - $got_sub = 1; - $subcode =~ s/^\s*(and)?\s*s//; - - my ($regex, $to); - my ($e, $r) = extract_delimited($subcode, '/'); - - if(defined $e) { - $regex = $e; - $regex =~ s/^\///; - $regex =~ s/\/$//; - $subcode = "/$r"; - } else { - print "$nick: Unbalanced slashes. Usage: cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n"; - exit 0; - } - - ($e, $r) = extract_delimited($subcode, '/'); - - if(defined $e) { - $to = $e; - $to =~ s/^\///; - $to =~ s/\/$//; - $subcode = $r; - } else { - print "$nick: Unbalanced slashes. Usage: cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n"; - exit 0; - } - - my $suffix; - $suffix = $1 if $subcode =~ s/^([^ ]+)//; - - if(length $suffix and $suffix =~ m/[^gi]/) { - print "$nick: Bad regex modifier '$suffix'. Only 'i' and 'g' are allowed.\n"; - exit 0; - } - if(defined $prevchange) { - $code = $prevchange; - } else { - print "$nick: No recent code to change.\n"; - exit 0; - } - - my $ret = eval { - my ($ret, $a, $b, $c, $d, $e, $f, $g, $h, $i, $before, $after); - - if(not length $suffix) { - $ret = $code =~ s|$regex|$to|; - ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); - $before = $`; - $after = $'; - } elsif($suffix =~ /^i$/) { - $ret = $code =~ s|$regex|$to|i; - ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); - $before = $`; - $after = $'; - } elsif($suffix =~ /^g$/) { - $ret = $code =~ s|$regex|$to|g; - ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); - $before = $`; - $after = $'; - } elsif($suffix =~ /^ig$/ or $suffix =~ /^gi$/) { - $ret = $code =~ s|$regex|$to|gi; - ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); - $before = $`; - $after = $'; - } - - if($ret) { - $code =~ s/\$1/$a/g; - $code =~ s/\$2/$b/g; - $code =~ s/\$3/$c/g; - $code =~ s/\$4/$d/g; - $code =~ s/\$5/$e/g; - $code =~ s/\$6/$f/g; - $code =~ s/\$7/$g/g; - $code =~ s/\$8/$h/g; - $code =~ s/\$9/$i/g; - $code =~ s/\$`/$before/g; - $code =~ s/\$'/$after/g; - } - - return $ret; - }; - - if($@) { - my $foo = $@; - $foo =~ s/ at \.\/compiler_vm_client.pl line \d+\.\s*//; - print "$nick: $foo\n"; - exit 0; - } - - if($ret) { - $got_changes = 1; - } - - $prevchange = $code; - } - - if($got_sub and not $got_changes) { - print "$nick: No substitutions made.\n"; - exit 0; - } elsif($got_sub and $got_changes) { - next; - } - - last; - } - - if($#replacements > -1) { - use re::engine::RE2 -strict => 1; - @replacements = sort { $a->{'from'} cmp $b->{'from'} or $a->{'modifier'} <=> $b->{'modifier'} } @replacements; - - my ($previous_from, $previous_modifier); - - foreach my $replacement (@replacements) { - my $from = $replacement->{'from'}; - my $to = $replacement->{'to'}; - my $modifier = $replacement->{'modifier'}; - - if(defined $previous_from) { - if($previous_from eq $from and $previous_modifier =~ /^\d+$/) { - $modifier -= $modifier - $previous_modifier; - } - } - - if(defined $prevchange) { - $code = $prevchange; - } else { - print "$nick: No recent code to change.\n"; - exit 0; - } - - my $ret = eval { - my $got_change; - - my ($first_char, $last_char, $first_bound, $last_bound); - $first_char = $1 if $from =~ m/^(.)/; - $last_char = $1 if $from =~ m/(.)$/; - - if($first_char =~ /\W/) { - $first_bound = '.'; - } else { - $first_bound = '\b'; - } - - if($last_char =~ /\W/) { - $last_bound = '\B'; - } else { - $last_bound = '\b'; - } - - if($modifier eq 'all') { - if($code =~ s/($first_bound)$from($last_bound)/$1$to$2/g) { - $got_change = 1; - } - } elsif($modifier eq 'last') { - if($code =~ s/(.*)($first_bound)$from($last_bound)/$1$2$to$3/) { - $got_change = 1; - } - } else { - my $count = 0; - my $unescaped = $from; - $unescaped =~ s/\\//g; - if($code =~ s/($first_bound)$from($last_bound)/if(++$count == $modifier) { "$1$to$2"; } else { "$1$unescaped$2"; }/ge) { - $got_change = 1; - } - } - return $got_change; - }; - - if($@) { - my $foo = $@; - $foo =~ s/ at \.\/compiler_vm_client.pl line \d+\.\s*//; - print "$nick: $foo\n"; - exit 0; - } - - if($ret) { - $got_sub = 1; - $got_changes = 1; - } - - $prevchange = $code; - $previous_from = $from; - $previous_modifier = $modifier; - } - - if(not $got_changes) { - print "$nick: No replacements made.\n"; - exit 0; - } - } - - $save_last_code = 1; - - unless($got_undo and not $got_changes) { - $unshift_last_code = 1 unless $copy_code and not $got_changes; - } - - if($copy_code and $got_changes) { - $only_show = 0; - } - - if($got_undo and not $got_changes) { - $only_show = 1; - } -} - -my $lang = "C11"; -$lang = uc $1 if $code =~ s/-lang=([^\b\s]+)//i; - -if($save_last_code) { - if($unshift_last_code) { - unshift @last_code, $code; - } - - open FILE, "> history/$channel.hist"; - - my $i = 0; - foreach my $line (@last_code) { - last if(++$i > $MAX_UNDO_HISTORY); - print FILE "$line\n"; - } - - close FILE; -} - -my $input = ""; -$input = $1 if $code =~ s/-(?:input|stdin)=(.*)$//i; - -my $extracted_args = ''; - -my $got_paste = undef; -$got_paste = 1 and $extracted_args .= "-paste " if $code =~ s/(?<=\s)*-paste\s*//i; - -my $got_nomain = undef; -$got_nomain = 1 and $extracted_args .= "-nomain " if $code =~ s/(?<=\s)*-nomain\s*//i; - -my $include_args = ""; -while($code =~ s/-include\s+(\S+)\s+//) { - $include_args .= "#include <$1> "; -} - -my $args = ""; -$args .= "$1 " while $code =~ s/^\s*(-[^ ]+)\s*//; -$args =~ s/\s+$//; - -$code = "$include_args$code"; - -if($only_show) { - print "$nick: $code\n"; - exit 0; -} - -unless($got_run and $copy_code) { - open FILE, ">> log.txt"; - print FILE "------------------------------------------------------------------------\n"; - print FILE localtime() . "\n"; - print FILE "$nick: $code\n"; -} - -my $found = 0; -my @langs; -foreach my $l (sort { uc $a cmp uc $b } keys %languages) { - push @langs, sprintf("%s => %s", $l, $languages{$l}); - if(uc $lang eq uc $l) { - $lang = $l; - $found = 1; - } -} - -if(not $found) { - print "$nick: Invalid language '$lang'. Supported languages are:\n", (join ",\n", @langs), "\n; For additional languages try the cc2 command."; - exit 0; -} - -print "code before: [$code]\n" if $debug; - -# replace \n outside of quotes with literal newline -my $new_code = ""; - -use constant { - NORMAL => 0, - DOUBLE_QUOTED => 1, - SINGLE_QUOTED => 2, +eval { + use lib 'languages'; + require "$language.pm"; +} or do { + print "Language '$language' is not supported.\n"; + die $@; }; -my $state = NORMAL; -my $escaped = 0; - -while($code =~ m/(.)/gs) { - my $ch = $1; - - given ($ch) { - when ('\\') { - if($escaped == 0) { - $escaped = 1; - next; - } - } - - if($state == NORMAL) { - when ($_ eq '"' and not $escaped) { - $state = DOUBLE_QUOTED; - } - - when ($_ eq "'" and not $escaped) { - $state = SINGLE_QUOTED; - } - - when ($_ eq 'n' and $escaped == 1) { - $ch = "\n"; - $escaped = 0; - } - } - - if($state == DOUBLE_QUOTED) { - when ($_ eq '"' and not $escaped) { - $state = NORMAL; - } - } - - if($state == SINGLE_QUOTED) { - when ($_ eq "'" and not $escaped) { - $state = NORMAL; - } - } - } - - $new_code .= '\\' and $escaped = 0 if $escaped; - $new_code .= $ch; -} - -$code = $new_code; - -print "code after \\n replacement: [$code]\n" if $debug; - -my $single_quote = 0; -my $double_quote = 0; -my $parens = 0; -my $escaped = 0; -my $cpp = 0; # preprocessor - -while($code =~ m/(.)/msg) { - my $ch = $1; - my $pos = pos $code; - - print "adding newlines, ch = [$ch], parens: $parens, cpp: $cpp, single: $single_quote, double: $double_quote, escaped: $escaped, pos: $pos\n" if $debug >= 10; - - if($ch eq '\\') { - $escaped = not $escaped; - } elsif($ch eq '#' and not $cpp and not $escaped and not $single_quote and not $double_quote) { - $cpp = 1; - - if($code =~ m/include\s*<([^>\n]*)>/msg) { - my $match = $1; - $pos = pos $code; - substr ($code, $pos, 0) = "\n"; - pos $code = $pos; - $cpp = 0; - } elsif($code =~ m/include\s*"([^"\n]*)"/msg) { - my $match = $1; - $pos = pos $code; - substr ($code, $pos, 0) = "\n"; - pos $code = $pos; - $cpp = 0; - } else { - pos $code = $pos; - } - } elsif($ch eq '"') { - $double_quote = not $double_quote unless $escaped or $single_quote; - $escaped = 0; - } elsif($ch eq '(' and not $single_quote and not $double_quote) { - $parens++; - } elsif($ch eq ')' and not $single_quote and not $double_quote) { - $parens--; - $parens = 0 if $parens < 0; - } elsif($ch eq ';' and not $cpp and not $single_quote and not $double_quote and $parens == 0) { - if(not substr($code, $pos, 1) =~ m/[\n\r]/) { - substr ($code, $pos, 0) = "\n"; - pos $code = $pos + 1; - } - } elsif($ch eq "'") { - $single_quote = not $single_quote unless $escaped or $double_quote; - $escaped = 0; - } elsif($ch eq 'n' and $escaped) { - if(not $single_quote and not $double_quote) { - print "added newline\n" if $debug >= 10; - substr ($code, $pos - 2, 2) = "\n"; - pos $code = $pos; - $cpp = 0; - } - $escaped = 0; - } elsif($ch eq '{' and not $cpp and not $single_quote and not $double_quote) { - if(not substr($code, $pos, 1) =~ m/[\n\r]/) { - substr ($code, $pos, 0) = "\n"; - pos $code = $pos + 1; - } - } elsif($ch eq '}' and not $cpp and not $single_quote and not $double_quote) { - if(not substr($code, $pos, 1) =~ m/[\n\r;]/) { - substr ($code, $pos, 0) = "\n"; - pos $code = $pos + 1; - } - } elsif($ch eq "\n" and $cpp and not $single_quote and not $double_quote) { - $cpp = 0; - } else { - $escaped = 0; - } -} - -print "code after \\n additions: [$code]\n" if $debug; - -# white-out contents of quoted literals -my $white_code = $code; -$white_code =~ s/(?:\"((?:\\\"|(?!\").)*)\")/'"' . ('-' x length $1) . '"'/ge; -$white_code =~ s/(?:\'((?:\\\'|(?!\').)*)\')/"'" . ('-' x length $1) . "'"/ge; - -my $precode; -if($white_code =~ m/#include/) { - $precode = $code; -} else { - $precode = $preludes{$lang} . $code; -} -$code = ''; - -print "--- precode: [$precode]\n" if $debug; - -if($lang eq 'C89' or $lang eq 'C99' or $lang eq 'C11' or $lang eq 'C++') { - my $has_main = 0; - - my $prelude = ''; - while($precode =~ s/^\s*(#.*\n{1,2})//g) { - $prelude .= $1; - } - - if($precode =~ m/^\s*(#.*)/ms) { - my $line = $1; - - if($line !~ m/\n/) { - $warn_unterminated_define = 1; - } - } - - print "*** prelude: [$prelude]\n precode: [$precode]\n" if $debug; - - my $preprecode = $precode; - - # white-out contents of quoted literals - $preprecode =~ s/(?:\"((?:\\\"|(?!\").)*)\")/'"' . ('-' x length $1) . '"'/ge; - $preprecode =~ s/(?:\'((?:\\\'|(?!\').)*)\')/"'" . ('-' x length $1) . "'"/ge; - - # strip C and C++ style comments - if($lang eq 'C89' or $args =~ m/-std=(gnu89|c89)/i) { - $preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs; - $preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse; - } else { - $preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse; - $preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs; - } - - print "preprecode: [$preprecode]\n" if $debug; - - print "looking for functions, has main: $has_main\n" if $debug >= 2; - - my $func_regex = qr/^([ *\w]+)\s+([ ()*\w]+)\s*\(([^;{]*)\s*\)\s*({.*|<%.*|\?\?<.*)/ims; - - # look for potential functions to extract - while($preprecode =~ /$func_regex/ms) { - my ($pre_ret, $pre_ident, $pre_params, $pre_potential_body) = ($1, $2, $3, $4); - my $precode_code; - - print "looking for functions, found [$pre_ret][$pre_ident][$pre_params][$pre_potential_body], has main: $has_main\n" if $debug >= 1; - - # find the pos at which this function lives, for extracting from precode - $preprecode =~ m/(\Q$pre_ret\E\s+\Q$pre_ident\E\s*\(\s*\Q$pre_params\E\s*\)\s*\Q$pre_potential_body\E)/g; - my $extract_pos = (pos $preprecode) - (length $1); - - # now that we have the pos, substitute out the extracted potential function from preprecode - $preprecode =~ s/$func_regex//ms; - - # create tmpcode object that starts from extract pos, to skip any quoted code - my $tmpcode = substr($precode, $extract_pos); - print "tmpcode: [$tmpcode]\n" if $debug; - - $precode = substr($precode, 0, $extract_pos); - print "precode: [$precode]\n" if $debug; - $precode_code = $precode; - - $tmpcode =~ m/$func_regex/ms; - my ($ret, $ident, $params, $potential_body) = ($1, $2, $3, $4); - - print "1st extract: [$ret][$ident][$params][$potential_body]\n" if $debug; - - $ret =~ s/^\s+//; - $ret =~ s/\s+$//; - - if(not length $ret or $ret eq "else" or $ret eq "while" or $ret eq "if" or $ret eq "for" or $ident eq "for" or $ident eq "while" or $ident eq "if") { - $precode .= "$ret $ident ($params) $potential_body"; - next; - } else { - $tmpcode =~ s/$func_regex//ms; - } - - $potential_body =~ s/^\s*<%/{/ms; - $potential_body =~ s/%>\s*$/}/ms; - $potential_body =~ s/^\s*\?\?$/}/ms; - - my @extract = extract_bracketed($potential_body, '{}'); - my $body; - if(not defined $extract[0]) { - if($debug == 0) { - print "error: unmatched brackets\n"; - } else { - print "error: unmatched brackets for function '$ident';\n"; - print "body: [$potential_body]\n"; - } - exit; - } else { - $body = $extract[0]; - $preprecode = $extract[1]; - $precode = $extract[1]; - } - - print "final extract: [$ret][$ident][$params][$body]\n" if $debug; - $code .= "$precode_code\n$ret $ident($params) $body\n"; - - if($debug >= 2) { print '-' x 20 . "\n" } - print " code: [$code]\n" if $debug >= 2; - if($debug >= 2) { print '-' x 20 . "\n" } - print " precode: [$precode]\n" if $debug >= 2; - - $has_main = 1 if $ident =~ m/^\s*\(?\s*main\s*\)?\s*$/; - } - - $precode =~ s/^\s+//; - $precode =~ s/\s+$//; - - $precode =~ s/^{(.*)}$/$1/s; - - if(not $has_main and not $got_nomain) { - $code = "$prelude\n$code\n" . "int main(void) {\n$precode\n;\nreturn 0;\n}\n"; - $nooutput = "No warnings, errors or output."; - } else { - $code = "$prelude\n$code\n"; - $nooutput = "No warnings, errors or output."; - } -} else { - $code = $precode; -} - -print "after func extract, code: [$code]\n" if $debug; - -$code =~ s/\|n/\n/g; -$code =~ s/^\s+//; -$code =~ s/\s+$//; -$code =~ s/;\s*;\n/;\n/gs; -$code =~ s/;(\s*\/\*.*?\*\/\s*);\n/;$1/gs; -$code =~ s/;(\s*\/\/.*?\s*);\n/;$1/gs; -$code =~ s/({|})\n\s*;\n/$1\n/gs; -$code =~ s/(?:\n\n)+/\n\n/g; - -print "final code: [$code]\n" if $debug; - -$input = `fortune -u -s` if not length $input; -$input =~ s/[\n\r\t]/ /msg; -$input =~ s/:/ - /g; -$input =~ s/\s+/ /g; -$input =~ s/^\s+//; -$input =~ s/\s+$//; - -print FILE "$nick: [lang:$lang][args:$args][input:$input]\n", pretty($code), "\n" unless $got_run and $copy_code; - -my $pretty_code = pretty $code; - -$args .= ' -paste' if defined $got_paste or $got_run eq "paste"; -$output = compile($lang, $pretty_code, $args, $input, $USE_LOCAL); -$args =~ s/ -paste$// if defined $got_paste or $got_run eq "paste"; - -if($output =~ m/^\s*$/) { - $output = $nooutput -} else { - unless($got_run and $copy_code) { - print FILE localtime() . "\n"; - print FILE "$output\n"; - } - - $output =~ s/In file included from .*?:\d+:\d+.\s*from prog.c:\d+.\s*//msg; - $output =~ s/In file included from .*?:\d+:\d+.\s*//msg; - $output =~ s/\s*from prog.c:\d+.\s*//g; - $output =~ s/prog: prog.c:\d+: [^:]+: Assertion/Assertion/g; - $output =~ s,/usr/include/[^:]+:\d+:\d+:\s+,,g; - - unless(defined $got_paste or (defined $got_run and $got_run eq "paste")) { - $output =~ s/ Line \d+ ://g; - $output =~ s/prog\.c:[:\d]*//g; - } else { - $output =~ s/prog\.c:(\d+)/\n$1/g; - $output =~ s/prog\.c://g; - } - - $output =~ s/;?\s?__PRETTY_FUNCTION__ = "[^"]+"//g; - $output =~ s/(\d+:\d+:\s*)*cc1: (all\s+)?warnings being treated as errors//; - $output =~ s/(\d+:\d+:\s*)* \(first use in this function\)//g; - $output =~ s/(\d+:\d+:\s*)*error: \(Each undeclared identifier is reported only once.*?\)//msg; - $output =~ s/(\d+:\d+:\s*)*ld: warning: cannot find entry symbol _start; defaulting to [^ ]+//; -# $output =~ s/(\d+:\d+:\s*)*error: (.*?) error/error: $1; error/msg; - $output =~ s/(\d+:\d+:\s*)*\/tmp\/.*\.o://g; - $output =~ s/(\d+:\d+:\s*)*collect2: ld returned \d+ exit status//g; - $output =~ s/\(\.text\+[^)]+\)://g; - $output =~ s/\[ In/[In/; - $output =~ s/(\d+:\d+:\s*)*warning: Can't read pathname for load map: Input.output error.//g; - my $left_quote = chr(226) . chr(128) . chr(152); - my $right_quote = chr(226) . chr(128) . chr(153); - $output =~ s/$left_quote/'/msg; - $output =~ s/$right_quote/'/msg; - $output =~ s/`/'/msg; - $output =~ s/\t/ /g; - if($output =~ /In function '([^']+)':/) { - if($1 eq 'main') { - $output =~ s/(\d+:\d+:\s*)*\s?In function .main.:\s*//g; - } else { - $output =~ s/(\d+:\d+:\s*)*\s?In function .main.:\s?/In function 'main':/g; - } - } - $output =~ s/(\d+:\d+:\s*)*warning: unknown conversion type character 'b' in format \[-Wformat=?\]\s+(\d+:\d+:\s*)*warning: too many arguments for format \[-Wformat-extra-args\]/info: %b is a candide extension/g; - $output =~ s/(\d+:\d+:\s*)*warning: unknown conversion type character 'b' in format \[-Wformat=?\]//g; - $output =~ s/\s\(core dumped\)/./; -# $output =~ s/\[\s+/[/g; - $output =~ s/ \[enabled by default\]//g; - $output =~ s/initializer\s+warning: \(near/initializer (near/g; - $output =~ s/(\d+:\d+:\s*)*note: each undeclared identifier is reported only once for each function it appears in//g; - $output =~ s/\(gdb\)//g; - $output =~ s/", '\\(\d{3})' ,? ?"/\\$1/g; - $output =~ s/, '\\(\d{3})' \s*//g; - $output =~ s/(\\000)+/\\0/g; - $output =~ s/\\0[^">']+/\\0/g; - $output =~ s/= (\d+) '\\0'/= $1/g; - $output =~ s/\\0"/"/g; - $output =~ s/"\\0/"/g; - $output =~ s/\.\.\.>/>/g; -# $output =~ s/(?\s*//g; - $output =~ s/\s*compilation terminated due to -Wfatal-errors\.//g; - $output =~ s/^======= Backtrace.*\[vsyscall\]\s*$//ms; - $output =~ s/glibc detected \*\*\* \/home\/compiler\/prog: //; - $output =~ s/: \/home\/compiler\/prog terminated//; - $output =~ s///g; - $output =~ s/\s*In file included from\s+\/usr\/include\/.*?:\d+:\d+:\s*/, /g; - $output =~ s/\s*collect2: error: ld returned 1 exit status//g; - $output =~ s/In function\s*`main':\s*\/home\/compiler\/ undefined reference to/error: undefined reference to/g; - $output =~ s/\/home\/compiler\///g; - $output =~ s/compilation terminated.//; - $output =~ s/'(.*?)' = char/'$1' = int/g; $output =~ s/(\(\s*char\s*\)\s*'.*?') = int/$1 = char/; # gdb thinks 'a' is type char, which is not true for C - $output =~ s/= (-?\d+) ''/= $1/g; - $output =~ s/, //g; - $output =~ s/\s*warning: shadowed declaration is here \[-Wshadow\]//g unless $got_paste or $got_run eq 'paste'; - $output =~ s/preprocessor macro>\s+/preprocessor macro>/g; - $output =~ s/\s*//g; - $output =~ s/cc1: all warnings being treated as; errors//g; - $output =~ s/, note: this is the location of the previous definition//g; - $output =~ s/ called by gdb \(\) at statement: void gdb\(\) { __asm__\(""\); }//g; -# $output =~ s/(?=\s*maxRead\(.*?\)\s*//gs; - $output =~ s/\s*needed\s*to\s*satisfy\s*precondition:\s*requires\s*max.*?\(.*?\)\s*>=\s*\d+//gs; - $output =~ s/\s*needed\s*to\s*satisfy\s*precondition:\s*requires\s*max.*?\(.*?\)\s*>=\s*.*?@//gs; - $output =~ s/\s*To allow all numeric types to match, use \+relaxtypes.//g; - $output =~ s/\s*Corresponding format code//g; - $output =~ s/Command Line: Setting .*? redundant with current value\s*//g; - # $output =~ s/maxSet\((.*?)\s*@\s*\)/$1/g; - $output =~ s/\s*Unable to resolve constraint: requires .*? >= [^ \]]+//gs; - $output =~ s/\s*To\s*allow\s*arbitrary\s*integral\s*types\s*to\s*match\s*any\s*integral\s*type,\s*use\s*\+matchanyintegral.//gs; - $output =~ s/\s+//g; - $output =~ s/Make breakpoint pending on future shared library load\? \(y or \[n\]\) \[answered N; input not from terminal\]//g; - $output =~ s/\s*Storage\s*.*?\s*becomes\s*static//gs; - $output =~ s/Possibly\s*null\s*storage\s*passed\s*as\s*non-null\s*param:/Possibly null storage passed to function:/g; - $output =~ s/A\s*possibly\s*null\s*pointer\s*is\s*passed\s*as\s*a\s*parameter\s*corresponding\s*to\s*a\s*formal\s*parameter\s*with\s*no\s*\/\*\@null\@\*\/\s*annotation.\s*If\s*NULL\s*may\s*be\s*used\s*for\s*this\s*parameter,\s*add\s*a\s*\/\*\@null\@\*\/\s*annotation\s*to\s*the\s*function\s*parameter\s*declaration./A possibly null pointer is passed as a parameter to a function./gs; - $output =~ s/ called by \?\? \(\)//g; - $output =~ s/\s*Copyright\s*\(C\)\s*\d+\s*Free\s*Software\s*Foundation,\s*Inc.\s*This\s*is\s*free\s*software;\s*see\s*the\s*source\s*for\s*copying\s*conditions.\s*\s*There\s*is\s*NO\s*warranty;\s*not\s*even\s*for\s*MERCHANTABILITY\s*or\s*FITNESS\s*FOR\s*A\s*PARTICULAR\s*PURPOSE.//gs; - $output =~ s/\s*process\s*\d+\s*is\s*executing\s*new\s*program:\s*.*?\s*Error\s*in\s*re-setting\s*breakpoint\s*\d+:\s*.*?No\s*symbol\s*table\s*is\s*loaded.\s*\s*Use\s*the\s*"file"\s*command.//s; - $output =~ s/\](\d+:\d+:\s*)*warning:/]\n$1warning:/g; - $output =~ s/\](\d+:\d+:\s*)*error:/]\n$1error:/g; - $output =~ s/\s+no output/ no output/; - $output =~ s/^\s+no output/no output/; - - # backspace - my $boutput = ""; - my $active_position = 0; - $output =~ s/\n$//; - while($output =~ /(.)/gms) { - my $c = $1; - if($c eq "\b") { - if(--$active_position <= 0) { - $active_position = 0; - } - next; - } - substr($boutput, $active_position++, 1) = $c; - } - $output = $boutput; -} - -if($warn_unterminated_define == 1) { - if($output =~ m/^\[(warning:|info:)/) { - $output =~ s/^\[/[warning: preprocessor directive not terminated by \\n, the remainder of the line will be part of this directive /; - } else { - $output =~ s/^/[warning: preprocessor directive not terminated by \\n, the remainder of the line will be part of this directive] /; - } -} - -unless($got_run and $copy_code) { - print FILE "$nick: $output\n"; - close FILE; -} - -if(defined $got_paste or (defined $got_run and $got_run eq "paste")) { - my $flags = ""; - - $extracted_args =~ s/-paste //g; - if(length $extracted_args) { - $extracted_args =~ s/\s*$//; - $flags .= '[' . $extracted_args . '] '; - } - - if(length $args) { - $flags .= "gcc " . $args . " -o prog prog.c"; - } else { - $flags .= $languages{$lang} . " -o prog prog.c"; - } - - $pretty_code .= "\n\n/************* COMPILER FLAGS *************\n$flags\n************** COMPILER FLAGS *************/\n"; - - $output =~ s/\s+$//; - $pretty_code .= "\n/************* OUTPUT *************\n$output\n************** OUTPUT *************/\n"; - - my $uri = paste_sprunge($pretty_code); - - print "$nick: $uri\n"; - exit 0; -} - -if(length $output > 22 and open FILE, "< history/$channel.last-output") { - my $last_output; - my $time = ; - - if(gettimeofday - $time > 60 * 10) { - close FILE; - } else { - while(my $line = ) { - $last_output .= $line; - } - close FILE; - - if($last_output eq $output) { - print "$nick: Same output.\n"; - exit 0; - } - } -} - -print "$nick: $output\n"; - -open FILE, "> history/$channel.last-output" or die "Couldn't open $channel.last-output: $!"; -my $now = gettimeofday; -print FILE "$now\n"; -print FILE "$output"; -close FILE; +my $nick = shift @ARGV // (print "Missing nick argument.\n" and die); +my $channel = shift @ARGV // (print "Missing channel argument.\n" and die); +my $code = join(' ', @ARGV); + +my $lang = $language->new(nick => $nick, channel => $channel, lang => $language, code => $code); + +$lang->process_interactive_edit; +$lang->process_standard_options; +$lang->process_custom_options; +$lang->process_cmdline_options; +$lang->preprocess_code; +$lang->execute; +$lang->postprocess_output; +$lang->show_output; diff --git a/modules/compiler_vm/compiler_vm_server.pl b/modules/compiler_vm/compiler_vm_server.pl index e6568cb4..d5e97b9c 100755 --- a/modules/compiler_vm/compiler_vm_server.pl +++ b/modules/compiler_vm/compiler_vm_server.pl @@ -1,34 +1,33 @@ -#!/usr/bin/perl +#!/usr/bin/env perl use warnings; use strict; +use File::Basename; + my $USE_LOCAL = defined $ENV{'CC_LOCAL'}; -my %languages = ( - 'C89' => { - 'cmdline' => 'gcc $file $args -o prog -ggdb -g3', - 'args' => '-Wextra -Wall -Wno-unused -std=gnu89 -lm -Wfloat-equal -Wshadow -Wfatal-errors', - 'file' => 'prog.c', - }, - 'C++' => { - 'cmdline' => 'g++ $file $args -o prog -ggdb', - 'args' => '-lm', - 'file' => 'prog.cpp', - }, - 'C99' => { - 'cmdline' => 'gcc $file $args -o prog -ggdb -g3', - 'args' => '-Wextra -Wall -Wno-unused -pedantic -Wfloat-equal -Wshadow -std=c99 -lm -Wfatal-errors', - 'file' => 'prog.c', - }, - 'C11' => { - 'cmdline' => 'gcc $file $args -o prog -ggdb -g3', - 'args' => '-Wextra -Wall -Wno-unused -pedantic -Wfloat-equal -Wshadow -std=c11 -lm -Wfatal-errors', - 'file' => 'prog.c', - }, -); +# uncomment the following if installed to the virtual machine +# use constant MOD_DIR => '/usr/local/share/compiler_vm/languages'; -sub runserver { +use constant MOD_DIR => 'languages/server'; + +use lib MOD_DIR; + +my %languages; + +sub load_modules { + my @files = glob MOD_DIR . "/*.pm"; + foreach my $mod (@files){ + print "Loading module $mod\n"; + my $filename = basename($mod); + require $filename; + $filename =~ s/\.pm$//; + $languages{$filename} = 1; + } +} + +sub run_server { my ($input, $output, $heartbeat); if(not defined $USE_LOCAL or $USE_LOCAL == 0) { @@ -42,8 +41,10 @@ sub runserver { my $date; my $lang; + my $sourcefile; + my $execfile; my $code; - my $user_args; + my $cmdline; my $user_input; print "Waiting for input...\n"; @@ -62,14 +63,12 @@ sub runserver { print "Attempting compile [$lang] ...\n"; - my $result = interpret($lang, $code, $user_args, $user_input, $date); + my $result = interpret($lang, $sourcefile, $execfile, $code, $cmdline, $user_input, $date); print "Done compiling; result: [$result]\n"; print $output "result:$result\n"; print $output "result:end\n"; - #system("rm prog"); - if(not defined $USE_LOCAL or $USE_LOCAL == 0) { print "input: "; next; @@ -80,18 +79,22 @@ sub runserver { if($line =~ m/^compile:\s*(.*)/) { my $options = $1; - $user_args = undef; + $cmdline = undef; $user_input = undef; $lang = undef; + $sourcefile = undef; + $execfile = undef; - ($lang, $user_args, $user_input, $date) = split /:/, $options; + ($lang, $sourcefile, $execfile, $cmdline, $user_input, $date) = split /:/, $options; $code = ""; - $lang = "C11" if not defined $lang; - $user_args = "" if not defined $user_args; + $sourcefile = "/dev/null" if not defined $sourcefile; + $execfile = "/dev/null" if not defined $execfile; + $lang = "unknown" if not defined $lang; + $cmdline = "echo No cmdline specified!" if not defined $cmdline; $user_input = "" if not defined $user_input; - print "Setting lang [$lang]; [$user_args]; [$user_input]; [$date]\n"; + print "Setting lang [$lang]; [$sourcefile]; [$cmdline]; [$user_input]; [$date]\n"; next; } @@ -110,128 +113,34 @@ sub runserver { } sub interpret { - my ($lang, $code, $user_args, $user_input, $date) = @_; + my ($lang, $sourcefile, $execfile, $code, $cmdline, $input, $date) = @_; - print "lang: [$lang], code: [$code], user_args: [$user_args], input: [$user_input], date: [$date]\n"; + print "lang: [$lang], sourcefile: [$sourcefile], execfile [$execfile], code: [$code], cmdline: [$cmdline], input: [$input], date: [$date]\n"; - $lang = uc $lang; - - if(not exists $languages{$lang}) { - return "No support for language '$lang' at this time.\n"; - } + $lang = '_default' if not exists $languages{$lang}; system("chmod -R 755 /home/compiler"); - open(my $fh, '>', $languages{$lang}{'file'}) or die $!; - print $fh $code . "\n"; - close $fh; + my $mod = $lang->new(sourcefile => $sourcefile, execfile => $execfile, code => $code, + cmdline => $cmdline, input => $input, date => $date); - my $cmdline = $languages{$lang}{'cmdline'}; + $mod->preprocess; - my $diagnostics_caret; - if($user_args =~ s/\s+-paste//) { - $diagnostics_caret = '-fdiagnostics-show-caret'; - } else { - $diagnostics_caret = '-fno-diagnostics-show-caret'; + if($cmdline =~ m/-?-version/) { + # cmdline contained version request, so don't postprocess and just return the version output + $mod->{output} =~ s/\s+\(Ubuntu.*-\d+ubuntu\d+\)//; + return $mod->{output}; } - if(length $user_args) { - print "Replacing args with $user_args\n"; - my $user_args_quoted = quotemeta($user_args); - $user_args_quoted =~ s/\\ / /g; - $cmdline =~ s/\$args/$user_args_quoted $diagnostics_caret/; - } else { - $cmdline =~ s/\$args/$languages{$lang}{'args'} $diagnostics_caret/; + $mod->postprocess if not $mod->{error}; + + if (not length $mod->{output}) { + $mod->{output} = "Success (no output).\n" if not $mod->{error}; + $mod->{output} = "Success (exit code $mod->{error}).\n" if $mod->{error}; } - $cmdline =~ s/\$file/$languages{$lang}{'file'}/; - - print "Executing [$cmdline]\n"; - my ($ret, $result) = execute(60, $cmdline); - # print "Got result: ($ret) [$result]\n"; - - # if exit code was not 0, then there was a problem compiling, such as an error diagnostic - # so return the compiler output - if($ret != 0) { - return $result; - } - - if($user_args =~ m/--version/) { - # arg contained --version, so don't compile and just return the version output - $result =~ s/\s+\(Ubuntu.*-\d+ubuntu\d+\)//; - return $result; - } - - # no errors compiling, but if $result contains something, it must be a warning message - # so prepend it to the output - my $output = ""; - if(length $result) { - $result =~ s/^\s+//; - $result =~ s/\s+$//; - $output = "[$result]\n"; - } - - print "Executing gdb\n"; - my $user_input_quoted = quotemeta $user_input; - $user_input_quoted =~ s/\\"/"'\\"'"/g; - ($ret, $result) = execute(60, "bash -c \"date -s \@$date; ulimit -t 1; compiler_watchdog.pl $user_input_quoted > .output\""); - - $result = ""; - - open(FILE, '.output'); - while() { - $result .= $_; - last if length $result >= 2048 * 20; - } - close(FILE); - - $result =~ s/\s+$//; - - # print "Executed prog; got result: ($ret) [$result]\n"; - - if(not length $result) { - $result = "Success (no output).\n" if $ret == 0; - $result = "Success (exit code $ret).\n" if $ret != 0; - } - - return $output . "\n" . $result; + return $mod->{output}; } -sub execute { - my $timeout = shift @_; - my ($cmdline) = @_; - - my ($ret, $result); - - ($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"; }; - alarm($timeout); - - while(my $line = <$fh>) { - $result .= $line; - } - - close $fh; - my $ret = $? >> 8; - alarm 0; - return ($ret, $result); - }; - - print "done eval\n"; - alarm 0; - - if($@ =~ /Timed-out/) { - return (-1, $@); - } - - print "[$ret, $result]\n"; - return ($ret, $result); -} - -runserver; +load_modules; +run_server; diff --git a/modules/compiler_vm/languages/_default.pm b/modules/compiler_vm/languages/_default.pm new file mode 100755 index 00000000..f2d39a13 --- /dev/null +++ b/modules/compiler_vm/languages/_default.pm @@ -0,0 +1,806 @@ +#!/usr/bin/perl + +use warnings; +use strict; +use feature "switch"; + +no if $] >= 5.018, warnings => "experimental::smartmatch"; + +package _default; + +use IPC::Open2; +use IO::Socket; +use LWP::UserAgent; +use Time::HiRes qw/gettimeofday/; +use Text::Balanced qw/extract_delimited/; + +my $EXECUTE_PORT = '3334'; + +sub new { + my ($class, %conf) = @_; + my $self = bless {}, $class; + + $self->{debug} = $conf{debug} // 0; + $self->{nick} = $conf{nick}; + $self->{channel} = $conf{channel}; + $self->{lang} = $conf{lang}; + $self->{code} = $conf{code}; + $self->{max_history} = $conf{max_history} // 10000; + + $self->{default_options} = ''; + $self->{cmdline} = 'echo Hello, world!'; + + $self->initialize(%conf); + + return $self; +} + +sub initialize { + my ($self, %conf) = @_; +} + +sub pretty_format { + my $self = shift; + return $self->{code}; +} + +sub preprocess_code { + my $self = shift; + + if ($self->{only_show}) { + print "$self->{nick}: $self->{code}\n"; + exit; + } + + 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"; + close FILE; + } +} + +sub postprocess_output { + my $self = shift; + + unless($self->{got_run} and $self->{copy_code}) { + open FILE, ">> log.txt"; + print FILE "------------------------------------------------------------------------\n"; + print FILE localtime() . "\n"; + print FILE "$self->{output}\n"; + close FILE; + } +} + +sub show_output { + my $self = shift; + my $output = $self->{output}; + + unless($self->{got_run} and $self->{copy_code}) { + open FILE, ">> log.txt"; + print FILE "------------------------------------------------------------------------\n"; + print FILE localtime() . "\n"; + print FILE "$output\n"; + print FILE "========================================================================\n"; + close FILE; + } + + if(exists $self->{options}->{'-paste'} or (defined $self->{got_run} and $self->{got_run} eq "paste")) { + my $flags = ""; + +=cut + $extracted_args =~ s/-paste //g; + if(length $extracted_args) { + $extracted_args =~ s/\s*$//; + $flags .= '[' . $extracted_args . '] '; + } + + if(length $args) { + $flags .= "gcc " . $args . " -o $self->{execfile} $self->{sourcefile}"; + } else { + $flags .= $languages{$lang} . " -o $self->{execfile} $self->{sourcefile}"; + } +=cut + + my $pretty_code = $self->pretty_format($self->{code}); + + $pretty_code .= "\n\n/************* COMPILER FLAGS *************\n$flags\n************** COMPILER FLAGS *************/\n"; + + $output =~ s/\s+$//; + $pretty_code .= "\n/************* OUTPUT *************\n$output\n************** OUTPUT *************/\n"; + + my $uri = paste_sprunge($pretty_code); + + print "$self->{nick}: $uri\n"; + exit 0; + } + + if(length $output > 22 and open FILE, "< history/$self->{channel}-$self->{lang}.last-output") { + my $last_output; + my $time = ; + + if(gettimeofday - $time > 60 * 10) { + close FILE; + } else { + while(my $line = ) { + $last_output .= $line; + } + close FILE; + + if($last_output eq $output) { + print "$self->{nick}: Same output.\n"; + exit 0; + } + } + } + + print "$self->{nick}: $output\n"; + + open FILE, "> history/$self->{channel}-$self->{lang}.last-output" or die "Couldn't open $self->{channel}-$self->{lang}.last-output: $!"; + my $now = gettimeofday; + print FILE "$now\n"; + print FILE "$output"; + close FILE; +} + +sub paste_codepad { + my $self = shift; + my $text = join(' ', @_); + + $text =~ s/(.{120})\s/$1\n/g; + + my $ua = LWP::UserAgent->new(); + $ua->agent("Mozilla/5.0"); + push @{ $ua->requests_redirectable }, 'POST'; + + my %post = ( 'lang' => 'C', 'code' => $text, 'private' => 'True', 'submit' => 'Submit' ); + my $response = $ua->post("http://codepad.org", \%post); + + if(not $response->is_success) { + return $response->status_line; + } + + return $response->request->uri; +} + +sub paste_sprunge { + my $self = shift; + my $text = join(' ', @_); + + $text =~ s/(.{120})\s/$1\n/g; + + my $ua = LWP::UserAgent->new(); + $ua->agent("Mozilla/5.0"); + $ua->requests_redirectable([ ]); + + my %post = ( 'sprunge' => $text, 'submit' => 'Submit' ); + my $response = $ua->post("http://sprunge.us", \%post); + + if(not $response->is_success) { + return $response->status_line; + } + + my $result = $response->content; + $result =~ s/^\s+//; + $result =~ s/\s+$/?c/; + + return $result; +} + +sub execute { + my ($self, $local) = @_; + + my ($compiler, $compiler_output, $pid); + + if(defined $local and $local != 0) { + print "Using local compiler instead of virtual machine\n"; + $pid = open2($compiler_output, $compiler, './compiler_vm_server.pl') || die "repl failed: $@\n"; + print "Started compiler, pid: $pid\n"; + } else { + $compiler = IO::Socket::INET->new(PeerAddr => '127.0.0.1', PeerPort => $EXECUTE_PORT, Proto => 'tcp', Type => SOCK_STREAM); + die "Could not create socket: $!" unless $compiler; + $compiler_output = $compiler; + } + + my $date = time; + my $input = $self->{options}->{'-input'}; + + $input = `fortune -u -s` if not length $input; + $input =~ s/[\n\r\t]/ /msg; + $input =~ s/:/ - /g; + $input =~ s/\s+/ /g; + $input =~ s/^\s+//; + $input =~ s/\s+$//; + + my $pretty_code = $self->pretty_format($self->{code}); + + my $cmdline = $self->{cmdline}; + $cmdline .= ' -paste' if exists $self->{options}->{'-paste'}; + + $cmdline =~ s/\$sourcefile/$self->{sourcefile}/g; + $cmdline =~ s/\$execfile/$self->{execfile}/g; + + if (length $self->{cmdline_options}) { + $cmdline =~ s/\$options/$self->{cmdline_options}/g; + } else { + $cmdline =~ s/\$options/$self->{default_options}/g; + } + + open FILE, ">> log.txt"; + print FILE "------------------------------------------------------------------------\n"; + print FILE localtime() . "\n"; + print FILE "$cmdline\n$input\n$pretty_code\n"; + close FILE; + + print $compiler "compile:$self->{lang}:$self->{sourcefile}:$self->{execfile}:$cmdline:$input:$date\n"; + print $compiler "$pretty_code\n"; + print $compiler "compile:end\n"; + + my $result = ""; + my $got_result = 0; + + while(my $line = <$compiler_output>) { + $line =~ s/[\r\n]+$//; + + last if $line =~ /^result:end$/; + + if($line =~ /^result:/) { + $line =~ s/^result://; + $result .= "$line\n"; + $got_result = 1; + next; + } + + if($got_result) { + $result .= "$line\n"; + } + } + + close $compiler; + waitpid($pid, 0) if defined $pid; + + $self->{output} = $result; + + return $result; +} + +sub add_option { + my $self = shift; + my ($option, $value) = @_; + + $self->{options_order} = [] if not exists $self->{options_order}; + + $self->{options}->{$option} = $value; + push $self->{options_order}, $option; +} + +sub process_standard_options { + my $self = shift; + my $code = $self->{code}; + + if ($code =~ s/-(?:input|stdin)=(.*)$//i) { + $self->add_option("-input", $1); + } + + if ($code =~ s/(?:^|(?<=\s))-paste\s*//i) { + $self->add_option("-paste"); + } + + $self->{code} = $code; +} + +sub process_custom_options { +} + +sub process_cmdline_options { + my $self = shift; + my $code = $self->{code}; + + $self->{cmdline_options} = ""; + + while ($code =~ s/^\s*(-[^ ]+)\s*//) { + $self->{cmdline_options} .= "$1 "; + $self->add_option($1); + } + + $self->{cmdline_options} =~ s/\s$//; + + $self->{code} = $code; +} + +sub process_interactive_edit { + my $self = shift; + my $code = $self->{code}; + my (@last_code, $save_last_code, $unshift_last_code); + + print " code: [$code]\n" if $self->{debug}; + + my $subcode = $code; + while ($subcode =~ s/^\s*(-[^ ]+)\s*//) {} + + my $copy_code; + if($subcode =~ s/^\s*copy\s+(\S+)\s*//) { + my $copy = $1; + + if(open FILE, "< history/$copy-$self->{lang}.hist") { + $copy_code = ; + close FILE; + goto COPY_ERROR if not $copy_code;; + chomp $copy_code; + } else { + goto COPY_ERROR; + } + + goto COPY_SUCCESS; + + COPY_ERROR: + print "$self->{nick}: No history for $copy.\n"; + exit 0; + + COPY_SUCCESS: + $code = $copy_code; + $self->{only_show} = 1; + $self->{copy_code} = 1; + $save_last_code = 1; + } + + if($subcode =~ m/^\s*(?:and\s+)?(?:diff|show)\s+(\S+)\s*$/) { + $self->{channel} = $1; + } + + if(open FILE, "< history/$self->{channel}-$self->{lang}.hist") { + while(my $line = ) { + chomp $line; + push @last_code, $line; + } + close FILE; + } + + unshift @last_code, $copy_code if defined $copy_code; + + if($subcode =~ m/^\s*(?:and\s+)?show(?:\s+\S+)?\s*$/i) { + if(defined $last_code[0]) { + print "$self->{nick}: $last_code[0]\n"; + } else { + print "$self->{nick}: No recent code to show.\n" + } + exit 0; + } + + if($subcode =~ m/^\s*(?:and\s+)?diff(?:\s+\S+)?\s*$/i) { + if($#last_code < 1) { + print "$self->{nick}: Not enough recent code to diff.\n" + } else { + use Text::WordDiff; + my $diff = word_diff(\$last_code[1], \$last_code[0], { STYLE => 'Diff' }); + if($diff !~ /(?:|)/) { + $diff = "No difference."; + } else { + $diff =~ s/(.*?)(\s+)<\/del>/$1<\/del>$2/g; + $diff =~ s/(.*?)(\s+)<\/ins>/$1<\/ins>$2/g; + $diff =~ s/((?:(?!).)*)<\/del>\s*((?:(?!).)*)<\/ins>/`replaced $1 with $2`/g; + $diff =~ s/(.*?)<\/del>/`removed $1`/g; + $diff =~ s/(.*?)<\/ins>/`inserted $1`/g; + } + + print "$self->{nick}: $diff\n"; + } + exit 0; + } + + if($subcode =~ m/^\s*(?:and\s+)?(run|paste)\s*$/i) { + $self->{got_run} = lc $1; + if(defined $last_code[0]) { + $code = $last_code[0]; + $self->{only_show} = 0; + } else { + print "$self->{nick}: No recent code to $self->{got_run}.\n"; + exit 0; + } + } else { + my $got_undo = 0; + my $got_sub = 0; + + while($subcode =~ s/^\s*(and)?\s*undo//) { + splice @last_code, 0, 1; + if(not defined $last_code[0]) { + print "$self->{nick}: No more undos remaining.\n"; + exit 0; + } else { + $code = $last_code[0]; + $got_undo = 1; + } + } + + my @replacements; + my $prevchange = $last_code[0]; + my $got_changes = 0; + my $last_keyword; + + while(1) { + $got_sub = 0; + #$got_changes = 0; + + $subcode =~ s/^\s*and\s+'/and $last_keyword '/ if defined $last_keyword; + + if($subcode =~ m/^\s*(and)?\s*remove \s*([^']+)?\s*'/) { + $last_keyword = 'remove'; + my $modifier = 'first'; + + $subcode =~ s/^\s*(and)?\s*//; + $subcode =~ s/remove\s*([^']+)?\s*//i; + $modifier = $1 if defined $1; + $modifier =~ s/\s+$//; + + my ($e, $r) = extract_delimited($subcode, "'"); + + my $text; + + if(defined $e) { + $text = $e; + $text =~ s/^'//; + $text =~ s/'$//; + $subcode = "replace $modifier '$text' with ''$r"; + } else { + print "$self->{nick}: Unbalanced single quotes. Usage: cc remove [all, first, .., tenth, last] 'text' [and ...]\n"; + exit 0; + } + next; + } + + if($subcode =~ s/^\s*(and)?\s*prepend '//) { + $last_keyword = 'prepend'; + $subcode = "'$subcode"; + + my ($e, $r) = extract_delimited($subcode, "'"); + + my $text; + + if(defined $e) { + $text = $e; + $text =~ s/^'//; + $text =~ s/'$//; + $subcode = $r; + + $got_sub = 1; + $got_changes = 1; + + if(not defined $prevchange) { + print "$self->{nick}: No recent code to prepend to.\n"; + exit 0; + } + + $code = $prevchange; + $code =~ s/^/$text /; + $prevchange = $code; + } else { + print "$self->{nick}: Unbalanced single quotes. Usage: cc prepend 'text' [and ...]\n"; + exit 0; + } + next; + } + + if($subcode =~ s/^\s*(and)?\s*append '//) { + $last_keyword = 'append'; + $subcode = "'$subcode"; + + my ($e, $r) = extract_delimited($subcode, "'"); + + my $text; + + if(defined $e) { + $text = $e; + $text =~ s/^'//; + $text =~ s/'$//; + $subcode = $r; + + $got_sub = 1; + $got_changes = 1; + + if(not defined $prevchange) { + print "$self->{nick}: No recent code to append to.\n"; + exit 0; + } + + $code = $prevchange; + $code =~ s/$/ $text/; + $prevchange = $code; + } else { + print "$self->{nick}: Unbalanced single quotes. Usage: cc append 'text' [and ...]\n"; + exit 0; + } + next; + } + + if($subcode =~ m/^\s*(and)?\s*replace\s*([^']+)?\s*'.*'\s*with\s*'.*?'/i) { + $last_keyword = 'replace'; + $got_sub = 1; + my $modifier = 'first'; + + $subcode =~ s/^\s*(and)?\s*//; + $subcode =~ s/replace\s*([^']+)?\s*//i; + $modifier = $1 if defined $1; + $modifier =~ s/\s+$//; + + my ($from, $to); + my ($e, $r) = extract_delimited($subcode, "'"); + + if(defined $e) { + $from = $e; + $from =~ s/^'//; + $from =~ s/'$//; + $from = quotemeta $from; + $subcode = $r; + $subcode =~ s/\s*with\s*//i; + } else { + print "$self->{nick}: Unbalanced single quotes. Usage: cc replace 'from' with 'to' [and ...]\n"; + exit 0; + } + + ($e, $r) = extract_delimited($subcode, "'"); + + if(defined $e) { + $to = $e; + $to =~ s/^'//; + $to =~ s/'$//; + $subcode = $r; + } else { + print "$self->{nick}: Unbalanced single quotes. Usage: cc replace 'from' with 'to' [and replace ... with ... [and ...]]\n"; + exit 0; + } + + given($modifier) { + when($_ eq 'all' ) {} + when($_ eq 'last' ) {} + when($_ eq 'first' ) { $modifier = 1; } + when($_ eq 'second' ) { $modifier = 2; } + when($_ eq 'third' ) { $modifier = 3; } + when($_ eq 'fourth' ) { $modifier = 4; } + when($_ eq 'fifth' ) { $modifier = 5; } + when($_ eq 'sixth' ) { $modifier = 6; } + when($_ eq 'seventh') { $modifier = 7; } + when($_ eq 'eighth' ) { $modifier = 8; } + when($_ eq 'nineth' ) { $modifier = 9; } + when($_ eq 'tenth' ) { $modifier = 10; } + default { print "$self->{nick}: Bad replacement modifier '$modifier'; valid modifiers are 'all', 'first', 'second', ..., 'tenth', 'last'\n"; exit 0; } + } + + my $replacement = {}; + $replacement->{'from'} = $from; + $replacement->{'to'} = $to; + $replacement->{'modifier'} = $modifier; + + push @replacements, $replacement; + next; + } + + if($subcode =~ m/^\s*(and)?\s*s\/.*\//) { + $last_keyword = undef; + $got_sub = 1; + $subcode =~ s/^\s*(and)?\s*s//; + + my ($regex, $to); + my ($e, $r) = extract_delimited($subcode, '/'); + + if(defined $e) { + $regex = $e; + $regex =~ s/^\///; + $regex =~ s/\/$//; + $subcode = "/$r"; + } else { + print "$self->{nick}: Unbalanced slashes. Usage: cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n"; + exit 0; + } + + ($e, $r) = extract_delimited($subcode, '/'); + + if(defined $e) { + $to = $e; + $to =~ s/^\///; + $to =~ s/\/$//; + $subcode = $r; + } else { + print "$self->{nick}: Unbalanced slashes. Usage: cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n"; + exit 0; + } + + my $suffix; + $suffix = $1 if $subcode =~ s/^([^ ]+)//; + + if(length $suffix and $suffix =~ m/[^gi]/) { + print "$self->{nick}: Bad regex modifier '$suffix'. Only 'i' and 'g' are allowed.\n"; + exit 0; + } + if(defined $prevchange) { + $code = $prevchange; + } else { + print "$self->{nick}: No recent code to change.\n"; + exit 0; + } + + my $ret = eval { + my ($ret, $a, $b, $c, $d, $e, $f, $g, $h, $i, $before, $after); + + if(not length $suffix) { + $ret = $code =~ s|$regex|$to|; + ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); + $before = $`; + $after = $'; + } elsif($suffix =~ /^i$/) { + $ret = $code =~ s|$regex|$to|i; + ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); + $before = $`; + $after = $'; + } elsif($suffix =~ /^g$/) { + $ret = $code =~ s|$regex|$to|g; + ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); + $before = $`; + $after = $'; + } elsif($suffix =~ /^ig$/ or $suffix =~ /^gi$/) { + $ret = $code =~ s|$regex|$to|gi; + ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); + $before = $`; + $after = $'; + } + + if($ret) { + $code =~ s/\$1/$a/g; + $code =~ s/\$2/$b/g; + $code =~ s/\$3/$c/g; + $code =~ s/\$4/$d/g; + $code =~ s/\$5/$e/g; + $code =~ s/\$6/$f/g; + $code =~ s/\$7/$g/g; + $code =~ s/\$8/$h/g; + $code =~ s/\$9/$i/g; + $code =~ s/\$`/$before/g; + $code =~ s/\$'/$after/g; + } + + return $ret; + }; + + if($@) { + my $error = $@; + $error =~ s/ at .* line \d+\.\s*$//; + print "$self->{nick}: $error\n"; + exit 0; + } + + if($ret) { + $got_changes = 1; + } + + $prevchange = $code; + } + + if($got_sub and not $got_changes) { + print "$self->{nick}: No substitutions made.\n"; + exit 0; + } elsif($got_sub and $got_changes) { + next; + } + + last; + } + + if($#replacements > -1) { + use re::engine::RE2 -strict => 1; + @replacements = sort { $a->{'from'} cmp $b->{'from'} or $a->{'modifier'} <=> $b->{'modifier'} } @replacements; + + my ($previous_from, $previous_modifier); + + foreach my $replacement (@replacements) { + my $from = $replacement->{'from'}; + my $to = $replacement->{'to'}; + my $modifier = $replacement->{'modifier'}; + + if(defined $previous_from) { + if($previous_from eq $from and $previous_modifier =~ /^\d+$/) { + $modifier -= $modifier - $previous_modifier; + } + } + + if(defined $prevchange) { + $code = $prevchange; + } else { + print "$self->{nick}: No recent code to change.\n"; + exit 0; + } + + my $ret = eval { + my $got_change; + + my ($first_char, $last_char, $first_bound, $last_bound); + $first_char = $1 if $from =~ m/^(.)/; + $last_char = $1 if $from =~ m/(.)$/; + + if($first_char =~ /\W/) { + $first_bound = '.'; + } else { + $first_bound = '\b'; + } + + if($last_char =~ /\W/) { + $last_bound = '\B'; + } else { + $last_bound = '\b'; + } + + if($modifier eq 'all') { + if($code =~ s/($first_bound)$from($last_bound)/$1$to$2/g) { + $got_change = 1; + } + } elsif($modifier eq 'last') { + if($code =~ s/(.*)($first_bound)$from($last_bound)/$1$2$to$3/) { + $got_change = 1; + } + } else { + my $count = 0; + my $unescaped = $from; + $unescaped =~ s/\\//g; + if($code =~ s/($first_bound)$from($last_bound)/if(++$count == $modifier) { "$1$to$2"; } else { "$1$unescaped$2"; }/ge) { + $got_change = 1; + } + } + return $got_change; + }; + + if($@) { + my $error = $@; + $error =~ s/ at .* line \d+\.\s*$//; + print "$self->{nick}: $error\n"; + exit 0; + } + + if($ret) { + $got_sub = 1; + $got_changes = 1; + } + + $prevchange = $code; + $previous_from = $from; + $previous_modifier = $modifier; + } + + if(not $got_changes) { + print "$self->{nick}: No replacements made.\n"; + exit 0; + } + } + + $save_last_code = 1; + + unless($got_undo and not $got_changes) { + $unshift_last_code = 1 unless $copy_code and not $got_changes; + } + + if($copy_code and $got_changes) { + $self->{only_show} = 0; + } + + if($got_undo and not $got_changes) { + $self->{only_show} = 1; + } + } + + if($save_last_code) { + if($unshift_last_code) { + unshift @last_code, $code; + } + + open FILE, "> history/$self->{channel}-$self->{lang}.hist"; + + my $i = 0; + foreach my $line (@last_code) { + last if(++$i > $self->{max_history}); + print FILE "$line\n"; + } + + close FILE; + } + + $self->{code} = $code; +} + +1; diff --git a/modules/compiler_vm/languages/c11.pm b/modules/compiler_vm/languages/c11.pm new file mode 100755 index 00000000..d00650cc --- /dev/null +++ b/modules/compiler_vm/languages/c11.pm @@ -0,0 +1,507 @@ +#!/usr/bin/perl + +use warnings; +use strict; +use feature "switch"; + +no if $] >= 5.018, warnings => "experimental::smartmatch"; + +package c11; +use parent '_default'; + +use Text::Balanced qw/extract_bracketed/; + +sub initialize { + my ($self, %conf) = @_; + + $self->{sourcefile} = 'prog.c'; + $self->{execfile} = 'prog'; + $self->{default_options} = '-Wextra -Wall -Wno-unused -pedantic -Wfloat-equal -Wshadow -std=c11 -lm -Wfatal-errors'; + $self->{cmdline} = 'gcc -ggdb -g3 $sourcefile $options -o $execfile'; + + $self->{prelude} = <<'END'; +#define _XOPEN_SOURCE 9001 +#define __USE_XOPEN +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +END +} + +sub process_custom_options { + my $self = shift; + $self->{code} = $self->{code}; + + $self->add_option("-nomain") if $self->{code} =~ s/(?:^|(?<=\s))-nomain\s*//i; + + $self->{include_options} = ""; + while ($self->{code} =~ s/(?:^|(?<=\s))-include\s+(\S+)\s+//) { + $self->{include_options} .= "#include <$1> "; + $self->add_option("-include $1"); + } + + $self->{code} = $self->{code}; +} + +sub pretty_format { + my $self = shift; + my $code = join '', @_; + my $result; + + $code = $self->{code} if not defined $code; + + open my $fh, ">$self->{sourcefile}" or die "Couldn't write $self->{sourcefile}: $!"; + print $fh $code; + close $fh; + + system("astyle", "-UHfenq", $self->{sourcefile}); + + open $fh, "<$self->{sourcefile}" or die "Couldn't read $self->{sourcefile}: $!"; + $result = join '', <$fh>; + close $fh; + + return $result; +} + +sub preprocess_code { + my $self = shift; + $self->SUPER::preprocess_code; + + my $default_prelude = $self->{prelude}; + + $self->{code} = $self->{include_options} . $self->{code}; + + print "code before: [$self->{code}]\n" if $self->{debug}; + + # replace \n outside of quotes with literal newline + my $new_code = ""; + + use constant { + NORMAL => 0, + DOUBLE_QUOTED => 1, + SINGLE_QUOTED => 2, + }; + + my $state = NORMAL; + my $escaped = 0; + + while($self->{code} =~ m/(.)/gs) { + my $ch = $1; + + given ($ch) { + when ('\\') { + if($escaped == 0) { + $escaped = 1; + next; + } + } + + if($state == NORMAL) { + when ($_ eq '"' and not $escaped) { + $state = DOUBLE_QUOTED; + } + + when ($_ eq "'" and not $escaped) { + $state = SINGLE_QUOTED; + } + + when ($_ eq 'n' and $escaped == 1) { + $ch = "\n"; + $escaped = 0; + } + } + + if($state == DOUBLE_QUOTED) { + when ($_ eq '"' and not $escaped) { + $state = NORMAL; + } + } + + if($state == SINGLE_QUOTED) { + when ($_ eq "'" and not $escaped) { + $state = NORMAL; + } + } + } + + $new_code .= '\\' and $escaped = 0 if $escaped; + $new_code .= $ch; + } + + $self->{code} = $new_code; + + print "code after \\n replacement: [$self->{code}]\n" if $self->{debug}; + + # add newlines to ends of statements and #includes + my $single_quote = 0; + my $double_quote = 0; + my $parens = 0; + my $cpp = 0; # preprocessor + $escaped = 0; + + while($self->{code} =~ m/(.)/msg) { + my $ch = $1; + my $pos = pos $self->{code}; + + print "adding newlines, ch = [$ch], parens: $parens, cpp: $cpp, single: $single_quote, double: $double_quote, escaped: $escaped, pos: $pos\n" if $self->{debug} >= 10; + + if($ch eq '\\') { + $escaped = not $escaped; + } elsif($ch eq '#' and not $cpp and not $escaped and not $single_quote and not $double_quote) { + $cpp = 1; + + if($self->{code} =~ m/include\s*<([^>\n]*)>/msg) { + my $match = $1; + $pos = pos $self->{code}; + substr ($self->{code}, $pos, 0) = "\n"; + pos $self->{code} = $pos; + $cpp = 0; + } elsif($self->{code} =~ m/include\s*"([^"\n]*)"/msg) { + my $match = $1; + $pos = pos $self->{code}; + substr ($self->{code}, $pos, 0) = "\n"; + pos $self->{code} = $pos; + $cpp = 0; + } else { + pos $self->{code} = $pos; + } + } elsif($ch eq '"') { + $double_quote = not $double_quote unless $escaped or $single_quote; + $escaped = 0; + } elsif($ch eq '(' and not $single_quote and not $double_quote) { + $parens++; + } elsif($ch eq ')' and not $single_quote and not $double_quote) { + $parens--; + $parens = 0 if $parens < 0; + } elsif($ch eq ';' and not $cpp and not $single_quote and not $double_quote and $parens == 0) { + if(not substr($self->{code}, $pos, 1) =~ m/[\n\r]/) { + substr ($self->{code}, $pos, 0) = "\n"; + pos $self->{code} = $pos + 1; + } + } elsif($ch eq "'") { + $single_quote = not $single_quote unless $escaped or $double_quote; + $escaped = 0; + } elsif($ch eq 'n' and $escaped) { + if(not $single_quote and not $double_quote) { + print "added newline\n" if $self->{debug} >= 10; + substr ($self->{code}, $pos - 2, 2) = "\n"; + pos $self->{code} = $pos; + $cpp = 0; + } + $escaped = 0; + } elsif($ch eq '{' and not $cpp and not $single_quote and not $double_quote) { + if(not substr($self->{code}, $pos, 1) =~ m/[\n\r]/) { + substr ($self->{code}, $pos, 0) = "\n"; + pos $self->{code} = $pos + 1; + } + } elsif($ch eq '}' and not $cpp and not $single_quote and not $double_quote) { + if(not substr($self->{code}, $pos, 1) =~ m/[\n\r;]/) { + substr ($self->{code}, $pos, 0) = "\n"; + pos $self->{code} = $pos + 1; + } + } elsif($ch eq "\n" and $cpp and not $single_quote and not $double_quote) { + $cpp = 0; + } else { + $escaped = 0; + } + } + + print "code after \\n additions: [$self->{code}]\n" if $self->{debug}; + + # white-out contents of quoted literals so content within literals aren't parsed as code + my $white_code = $self->{code}; + $white_code =~ s/(?:\"((?:\\\"|(?!\").)*)\")/'"' . ('-' x length $1) . '"'/ge; + $white_code =~ s/(?:\'((?:\\\'|(?!\').)*)\')/"'" . ('-' x length $1) . "'"/ge; + + my $precode; + + if($white_code =~ m/#include/) { + $precode = $self->{code}; + } else { + $precode = $default_prelude . $self->{code}; + } + + $self->{code} = ''; + + print "--- precode: [$precode]\n" if $self->{debug}; + + $self->{warn_unterminated_define} = 0; + + my $has_main = 0; + + my $prelude = ''; + while($precode =~ s/^\s*(#.*\n{1,2})//g) { + $prelude .= $1; + } + + if($precode =~ m/^\s*(#.*)/ms) { + my $line = $1; + + if($line !~ m/\n/) { + $self->{warn_unterminated_define} = 1; + } + } + + print "*** prelude: [$prelude]\n precode: [$precode]\n" if $self->{debug}; + + my $preprecode = $precode; + + # white-out contents of quoted literals + $preprecode =~ s/(?:\"((?:\\\"|(?!\").)*)\")/'"' . ('-' x length $1) . '"'/ge; + $preprecode =~ s/(?:\'((?:\\\'|(?!\').)*)\')/"'" . ('-' x length $1) . "'"/ge; + + # strip comments + if ($self->{lang} eq 'c89') { + $preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs; + $preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse; + } else { + $preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse; + $preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs; + } + + print "preprecode: [$preprecode]\n" if $self->{debug}; + + print "looking for functions, has main: $has_main\n" if $self->{debug} >= 2; + + my $func_regex = qr/^([ *\w]+)\s+([ ()*\w]+)\s*\(([^;{]*)\s*\)\s*({.*|<%.*|\?\?<.*)/ims; + + # look for potential functions to extract + while($preprecode =~ /$func_regex/ms) { + my ($pre_ret, $pre_ident, $pre_params, $pre_potential_body) = ($1, $2, $3, $4); + my $precode_code; + + print "looking for functions, found [$pre_ret][$pre_ident][$pre_params][$pre_potential_body], has main: $has_main\n" if $self->{debug} >= 1; + + # find the pos at which this function lives, for extracting from precode + $preprecode =~ m/(\Q$pre_ret\E\s+\Q$pre_ident\E\s*\(\s*\Q$pre_params\E\s*\)\s*\Q$pre_potential_body\E)/g; + my $extract_pos = (pos $preprecode) - (length $1); + + # now that we have the pos, substitute out the extracted potential function from preprecode + $preprecode =~ s/$func_regex//ms; + + # create tmpcode object that starts from extract pos, to skip any quoted code + my $tmpcode = substr($precode, $extract_pos); + print "tmpcode: [$tmpcode]\n" if $self->{debug}; + + $precode = substr($precode, 0, $extract_pos); + print "precode: [$precode]\n" if $self->{debug}; + $precode_code = $precode; + + $tmpcode =~ m/$func_regex/ms; + my ($ret, $ident, $params, $potential_body) = ($1, $2, $3, $4); + + print "1st extract: [$ret][$ident][$params][$potential_body]\n" if $self->{debug}; + + $ret =~ s/^\s+//; + $ret =~ s/\s+$//; + + if(not length $ret or $ret eq "else" or $ret eq "while" or $ret eq "if" or $ret eq "for" or $ident eq "for" or $ident eq "while" or $ident eq "if") { + $precode .= "$ret $ident ($params) $potential_body"; + next; + } else { + $tmpcode =~ s/$func_regex//ms; + } + + $potential_body =~ s/^\s*<%/{/ms; + $potential_body =~ s/%>\s*$/}/ms; + $potential_body =~ s/^\s*\?\?$/}/ms; + + my @extract = extract_bracketed($potential_body, '{}'); + my $body; + if(not defined $extract[0]) { + if($self->{debug} == 0) { + print "error: unmatched brackets\n"; + } else { + print "error: unmatched brackets for function '$ident';\n"; + print "body: [$potential_body]\n"; + } + exit; + } else { + $body = $extract[0]; + $preprecode = $extract[1]; + $precode = $extract[1]; + } + + print "final extract: [$ret][$ident][$params][$body]\n" if $self->{debug}; + $self->{code} .= "$precode_code\n$ret $ident($params) $body\n"; + + if($self->{debug} >= 2) { print '-' x 20 . "\n" } + print " code: [$self->{code}]\n" if $self->{debug} >= 2; + if($self->{debug} >= 2) { print '-' x 20 . "\n" } + print " precode: [$precode]\n" if $self->{debug} >= 2; + + $has_main = 1 if $ident =~ m/^\s*\(?\s*main\s*\)?\s*$/; + } + + $precode =~ s/^\s+//; + $precode =~ s/\s+$//; + + $precode =~ s/^{(.*)}$/$1/s; + + if(not $has_main and not exists $self->{options}->{'-nomain'}) { + $self->{code} = "$prelude\n$self->{code}\n" . "int main(void) {\n$precode\n;\nreturn 0;\n}\n"; + } else { + $self->{code} = "$prelude\n$self->{code}\n"; + } + + print "after func extract, code: [$self->{code}]\n" if $self->{debug}; + + $self->{code} =~ s/\|n/\n/g; + $self->{code} =~ s/^\s+//; + $self->{code} =~ s/\s+$//; + $self->{code} =~ s/;\s*;\n/;\n/gs; + $self->{code} =~ s/;(\s*\/\*.*?\*\/\s*);\n/;$1/gs; + $self->{code} =~ s/;(\s*\/\/.*?\s*);\n/;$1/gs; + $self->{code} =~ s/({|})\n\s*;\n/$1\n/gs; + $self->{code} =~ s/(?:\n\n)+/\n\n/g; + + print "final code: [$self->{code}]\n" if $self->{debug}; +} + +sub postprocess_output { + my $self = shift; + $self->SUPER::postprocess_output; + + my $output = $self->{output}; + + $output =~ s/In file included from .*?:\d+:\d+.\s*from $self->{sourcefile}:\d+.\s*//msg; + $output =~ s/In file included from .*?:\d+:\d+.\s*//msg; + $output =~ s/\s*from $self->{sourcefile}:\d+.\s*//g; + $output =~ s/$self->{execfile}: $self->{sourcefile}:\d+: [^:]+: Assertion/Assertion/g; + $output =~ s,/usr/include/[^:]+:\d+:\d+:\s+,,g; + + unless(exists $self->{options}->{'-paste'} or (defined $self->{got_run} and $self->{got_run} eq "paste")) { + $output =~ s/ Line \d+ ://g; + $output =~ s/$self->{sourcefile}:[:\d]*//g; + } else { + $output =~ s/$self->{sourcefile}:(\d+)/\n$1/g; + $output =~ s/$self->{sourcefile}://g; + } + + $output =~ s/;?\s?__PRETTY_FUNCTION__ = "[^"]+"//g; + $output =~ s/(\d+:\d+:\s*)*cc1: (all\s+)?warnings being treated as errors//; + $output =~ s/(\d+:\d+:\s*)* \(first use in this function\)//g; + $output =~ s/(\d+:\d+:\s*)*error: \(Each undeclared identifier is reported only once.*?\)//msg; + $output =~ s/(\d+:\d+:\s*)*ld: warning: cannot find entry symbol _start; defaulting to [^ ]+//; + $output =~ s/(\d+:\d+:\s*)*\/tmp\/.*\.o://g; + $output =~ s/(\d+:\d+:\s*)*collect2: ld returned \d+ exit status//g; + $output =~ s/\(\.text\+[^)]+\)://g; + $output =~ s/\[ In/[In/; + $output =~ s/(\d+:\d+:\s*)*warning: Can't read pathname for load map: Input.output error.//g; + my $left_quote = chr(226) . chr(128) . chr(152); + my $right_quote = chr(226) . chr(128) . chr(153); + $output =~ s/$left_quote/'/msg; + $output =~ s/$right_quote/'/msg; + $output =~ s/`/'/msg; + $output =~ s/\t/ /g; + if($output =~ /In function '([^']+)':/) { + if($1 eq 'main') { + $output =~ s/(\d+:\d+:\s*)*\s?In function .main.:\s*//g; + } else { + $output =~ s/(\d+:\d+:\s*)*\s?In function .main.:\s?/In function 'main':/g; + } + } + $output =~ s/(\d+:\d+:\s*)*warning: unknown conversion type character 'b' in format \[-Wformat=?\]\s+(\d+:\d+:\s*)*warning: too many arguments for format \[-Wformat-extra-args\]/info: %b is a candide extension/g; + $output =~ s/(\d+:\d+:\s*)*warning: unknown conversion type character 'b' in format \[-Wformat=?\]//g; + $output =~ s/\s\(core dumped\)/./; + $output =~ s/ \[enabled by default\]//g; + $output =~ s/initializer\s+warning: \(near/initializer (near/g; + $output =~ s/(\d+:\d+:\s*)*note: each undeclared identifier is reported only once for each function it appears in//g; + $output =~ s/\(gdb\)//g; + $output =~ s/", '\\(\d{3})' ,? ?"/\\$1/g; + $output =~ s/, '\\(\d{3})' \s*//g; + $output =~ s/(\\000)+/\\0/g; + $output =~ s/\\0[^">']+/\\0/g; + $output =~ s/= (\d+) '\\0'/= $1/g; + $output =~ s/\\0"/"/g; + $output =~ s/"\\0/"/g; + $output =~ s/\.\.\.>/>/g; + $output =~ s/<\s*included at \/home\/compiler\/>\s*//g; + $output =~ s/\s*compilation terminated due to -Wfatal-errors\.//g; + $output =~ s/^======= Backtrace.*\[vsyscall\]\s*$//ms; + $output =~ s/glibc detected \*\*\* \/home\/compiler\/$self->{execfile}: //; + $output =~ s/: \/home\/compiler\/$self->{execfile} terminated//; + $output =~ s//{sourcefile}:0>/g; + $output =~ s/\s*In file included from\s+\/usr\/include\/.*?:\d+:\d+:\s*/, /g; + $output =~ s/\s*collect2: error: ld returned 1 exit status//g; + $output =~ s/In function\s*`main':\s*\/home\/compiler\/ undefined reference to/error: undefined reference to/g; + $output =~ s/\/home\/compiler\///g; + $output =~ s/compilation terminated.//; + $output =~ s/'(.*?)' = char/'$1' = int/g; $output =~ s/(\(\s*char\s*\)\s*'.*?') = int/$1 = char/; # gdb thinks 'a' is type char, which is not true for C + $output =~ s/= (-?\d+) ''/= $1/g; + $output =~ s/, //g; + $output =~ s/\s*warning: shadowed declaration is here \[-Wshadow\]//g unless exists $self->{options}->{'-paste'} or (defined $self->{got_run} and $self->{got_run} eq 'paste'); + $output =~ s/\s*note: shadowed declaration is here//g unless exists $self->{options}->{'-paste'} or (defined $self->{got_run} and $self->{got_run} eq 'paste'); + $output =~ s/preprocessor macro>\s+/preprocessor macro>/g; + $output =~ s/\s*//g; + $output =~ s/cc1: all warnings being treated as; errors//g; + $output =~ s/, note: this is the location of the previous definition//g; + $output =~ s/ called by gdb \(\) at statement: void gdb\(\) { __asm__\(""\); }//g; + + my $removed_warning = 0; + + $removed_warning++ if $output =~ s/warning: ISO C forbids nested functions \[-pedantic\]\s*//g; + + if($removed_warning) { + $output =~ s/^\[\]\s*//; + } + + $output =~ s/^\[\s+(warning:|info:)/[$1/; # remove leading spaces in first warning/info + + # backspace + my $boutput = ""; + my $active_position = 0; + $output =~ s/\n$//; + while($output =~ /(.)/gms) { + my $c = $1; + if($c eq "\b") { + if(--$active_position <= 0) { + $active_position = 0; + } + next; + } + substr($boutput, $active_position++, 1) = $c; + } + $output = $boutput; + + if($self->{warn_unterminated_define} == 1) { + if($output =~ m/^\[(warning:|info:)/) { + $output =~ s/^\[/[warning: preprocessor directive not terminated by \\n, the remainder of the line will be part of this directive /; + } else { + $output =~ s/^/[warning: preprocessor directive not terminated by \\n, the remainder of the line will be part of this directive] /; + } + } + + $self->{output} = $output; +} + +1; diff --git a/modules/compiler_vm/languages/c89.pm b/modules/compiler_vm/languages/c89.pm new file mode 100755 index 00000000..337fbf87 --- /dev/null +++ b/modules/compiler_vm/languages/c89.pm @@ -0,0 +1,39 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +package c89; +use parent 'c11'; + +sub initialize { + my ($self, %conf) = @_; + + $self->{sourcefile} = 'prog.c'; + $self->{execfile} = 'prog'; + $self->{default_options} = '-Wextra -Wall -Wno-unused -pedantic -Wfloat-equal -Wshadow -std=c89 -lm -Wfatal-errors'; + $self->{cmdline} = 'gcc -ggdb -g3 $sourcefile $options -o $execfile'; + + $self->{prelude} = <<'END'; +#define _XOPEN_SOURCE 9001 +#define __USE_XOPEN +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +END +} + +1; diff --git a/modules/compiler_vm/languages/c99.pm b/modules/compiler_vm/languages/c99.pm new file mode 100755 index 00000000..685a5511 --- /dev/null +++ b/modules/compiler_vm/languages/c99.pm @@ -0,0 +1,50 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +package c99; +use parent 'c11'; + +sub initialize { + my ($self, %conf) = @_; + + $self->{sourcefile} = 'prog.c'; + $self->{execfile} = 'prog'; + $self->{default_options} = '-Wextra -Wall -Wno-unused -pedantic -Wfloat-equal -Wshadow -std=c99 -lm -Wfatal-errors'; + $self->{cmdline} = 'gcc -ggdb -g3 $sourcefile $options -o $execfile'; + + $self->{prelude} = <<'END'; +#define _XOPEN_SOURCE 9001 +#define __USE_XOPEN +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#inclue +#include +#include +#include + +END +} + +1; diff --git a/modules/compiler_vm/languages/perl.pm b/modules/compiler_vm/languages/perl.pm new file mode 100755 index 00000000..69f8702e --- /dev/null +++ b/modules/compiler_vm/languages/perl.pm @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +package perl; +use parent '_default'; + +sub initialize { + my ($self, %conf) = @_; + + $self->{sourcefile} = 'prog.pl'; + $self->{execfile} = 'prog.pl'; + $self->{default_options} = ''; + $self->{cmdline} = 'perl $options $sourcefile'; +} + +sub postprocess_output { + my $self = shift; + $self->SUPER::postprocess_output; + + $self->{output} =~ s/\s+at $self->{sourcefile} line \d+, near ".*?"//; + $self->{output} =~ s/\s*Execution of $self->{sourcefile} aborted due to compilation errors.//; +} + +1; diff --git a/modules/compiler_vm/languages/server/_default.pm b/modules/compiler_vm/languages/server/_default.pm new file mode 100755 index 00000000..3a7916f8 --- /dev/null +++ b/modules/compiler_vm/languages/server/_default.pm @@ -0,0 +1,87 @@ +#!/usr/bin/perl + +use warnings; +use strict; +use feature "switch"; + +no if $] >= 5.018, warnings => "experimental::smartmatch"; + +package _default; + +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->initialize(%conf); + + return $self; +} + +sub initialize { + my ($self, %conf) = @_; +} + +sub preprocess { + my $self = shift; + + 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, $self->{cmdline}); + + $self->{output} = $result; + $self->{error} = $retval; +} + +sub postprocess { +} + +sub execute { + my $self = shift; + my $timeout = shift; + my ($cmdline) = @_; + + my ($ret, $result); + + ($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"; }; + alarm($timeout); + + while(my $line = <$fh>) { + $result .= $line; + } + + close $fh; + my $ret = $? >> 8; + alarm 0; + return ($ret, $result); + }; + + print "done eval\n"; + alarm 0; + + if($@ =~ /Timed-out/) { + return (-1, $@); + } + + print "[$ret, $result]\n"; + return ($ret, $result); +} + +1; diff --git a/modules/compiler_vm/languages/server/c11.pm b/modules/compiler_vm/languages/server/c11.pm new file mode 100755 index 00000000..310675da --- /dev/null +++ b/modules/compiler_vm/languages/server/c11.pm @@ -0,0 +1,37 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +package c11; +use parent '_default'; + +sub postprocess { + my $self = shift; + + # no errors compiling, but if output contains something, it must be diagnostic messages + if(length $self->{output}) { + $self->{output} =~ s/^\s+//; + $self->{output} =~ s/\s+$//; + $self->{output} = "[$self->{output}]\n"; + } + + print "Executing gdb\n"; + my $input_quoted = quotemeta $self->{input}; + $input_quoted =~ s/\\"/"'\\"'"/g; + my ($retval, $result) = $self->execute(60, "bash -c \"date -s \@$self->{date}; ulimit -t 1; compiler_watchdog.pl $input_quoted > .output\""); + + $result = ""; + open(FILE, '.output'); + while() { + $result .= $_; + last if length $result >= 1024 * 20; + } + close(FILE); + + $result =~ s/\s+$//; + + $self->{output} .= $result; +} + +1; diff --git a/modules/compiler_vm/languages/server/c89.pm b/modules/compiler_vm/languages/server/c89.pm new file mode 100755 index 00000000..21b1f2d0 --- /dev/null +++ b/modules/compiler_vm/languages/server/c89.pm @@ -0,0 +1,9 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +package c89; +use parent 'c11'; + +1; diff --git a/modules/compiler_vm/languages/server/c99.pm b/modules/compiler_vm/languages/server/c99.pm new file mode 100755 index 00000000..1e3d2c0b --- /dev/null +++ b/modules/compiler_vm/languages/server/c99.pm @@ -0,0 +1,9 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +package c99; +use parent 'c11'; + +1;