From 93658e0f6fc7c9543e5c4ca0901e34f0eae7d423 Mon Sep 17 00:00:00 2001 From: Pragmatic Software Date: Wed, 26 Jan 2011 01:59:19 +0000 Subject: [PATCH] modules: added compiler virtual machine scripts; use to set up your own environment for !cc/compiler_client.pl --- PBot/VERSION.pm | 2 +- modules/compiler_vm/README | 57 ++ modules/compiler_vm/compiler_client.pl | 25 + modules/compiler_vm/compiler_server.pl | 165 ++++++ modules/compiler_vm/compiler_vm_client.pl | 667 ++++++++++++++++++++++ modules/compiler_vm/compiler_vm_server.pl | 176 ++++++ modules/compiler_vm/compiler_watchdog.pl | 138 +++++ modules/compiler_vm/monitor | 1 + modules/compiler_vm/runqemu | 1 + modules/compiler_vm/runqemu.net | 1 + modules/compiler_vm/serial | 1 + 11 files changed, 1233 insertions(+), 1 deletion(-) create mode 100644 modules/compiler_vm/README create mode 100755 modules/compiler_vm/compiler_client.pl create mode 100755 modules/compiler_vm/compiler_server.pl create mode 100755 modules/compiler_vm/compiler_vm_client.pl create mode 100755 modules/compiler_vm/compiler_vm_server.pl create mode 100755 modules/compiler_vm/compiler_watchdog.pl create mode 100755 modules/compiler_vm/monitor create mode 100755 modules/compiler_vm/runqemu create mode 100755 modules/compiler_vm/runqemu.net create mode 100755 modules/compiler_vm/serial diff --git a/PBot/VERSION.pm b/PBot/VERSION.pm index 5a9886fe..baa451c9 100644 --- a/PBot/VERSION.pm +++ b/PBot/VERSION.pm @@ -13,7 +13,7 @@ use warnings; # These are set automatically by the build/commit script use constant { BUILD_NAME => "PBot", - BUILD_REVISION => 255, + BUILD_REVISION => 258, BUILD_DATE => "2011-01-25", }; diff --git a/modules/compiler_vm/README b/modules/compiler_vm/README new file mode 100644 index 00000000..7c42d005 --- /dev/null +++ b/modules/compiler_vm/README @@ -0,0 +1,57 @@ +Installation: + +You will need to download qemu and set up a virtual machine containing a compiler. + +Then you will need to edit some of the following files and replace IP addresses +and paths where appropriate (some locations may not yet be documented). + +Once the files have been configured and copied to the appropriate locations, +you will need to first start up the compiler_vm_server.pl script, and then +connect to qemu's monitor and issue the 'savevm 1' command to save the virtual +machine in this state. Between compiles, this state will be loaded via +'loadvm 1' in order to reset everything within the machine for a clean and working +environment for subsequent compiles. + +Files: + +(Read within each file for configuration instructions.) + +- compiler_client.pl: Main entry point for compiling snippets. Sends over TCP to + compiler_server.pl. This file can be run be run from the + client machine or anywhere. + +- compiler_server.pl: Responsible for setting up a TCP server to listen for + incoming compile requests; and launching and resetting + the virtual machine. Sends to compiler_vm_client.pl. + Run this file on the server hosting the virtual machine. + +- compiler_vm_client.pl: Responsible for sending snippets to the virtual + machine. Also expands/translates and formats + snippets into compilable code (with main function and + headers), and handles "interactive-editing". + Sends over TCP to qemu serial port, waits for result, + then sends result back caller (compiler_server.pl). + Run this file on the server hosting the virtual machine. + +- compiler_vm_server.pl: Runs on the system inside the virtual machine. + This script listens for incoming code snippets over + the virtual machine's serial port. + Calls compiler_watchdog.pl to monitor its exit signal + or exit status, then returns result back over serial + port (to compiler_vm_client.pl). + +- compiler_watchdog.pl: Runs a program and watches its exit signals/status. + +*** The following files are just auxiliary tools to start/connect to qemu, provided +for convenience only. Perhaps they will be useful during installation/testing: + +- monitor: Connects to qemu monitor (internal console) over TCP. + +- serial: Connects to qemu serial port over TCP. + +- runqemu: Launches qemu with a visible window, but without networking support. + +- runeqmu.net: Launches qemu with a visible window, and with networking support. + You may load a state previously saved with runqemu and reboot it + or otherwise reload its networking configuration to gain networking. + diff --git a/modules/compiler_vm/compiler_client.pl b/modules/compiler_vm/compiler_client.pl new file mode 100755 index 00000000..5e614bbe --- /dev/null +++ b/modules/compiler_vm/compiler_client.pl @@ -0,0 +1,25 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use IO::Socket; + +my $sock = IO::Socket::INET->new( + PeerAddr => '71.93.78.61', + PeerPort => 9000, + Proto => 'tcp') || die "Cannot create socket: $!"; + +my $nick = shift @ARGV; +my $lang = shift @ARGV; +my $code = join ' ', @ARGV; + +print $sock "compile:$nick:$lang\n"; +print $sock "$code\n"; +print $sock "compile:end\n"; + +while(my $line = <$sock>) { + print "$line"; +} + +close $sock; diff --git a/modules/compiler_vm/compiler_server.pl b/modules/compiler_vm/compiler_server.pl new file mode 100755 index 00000000..22b14cff --- /dev/null +++ b/modules/compiler_vm/compiler_server.pl @@ -0,0 +1,165 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use IO::Socket; +use Net::hostent; + +my $PORT = 9000; + +sub server_listen { + my $port = shift @_; + + my $server = IO::Socket::INET->new( + Proto => 'tcp', + LocalPort => $port, + Listen => SOMAXCONN, + Reuse => 1); + + die "can't setup server" unless $server; + + print "[Server $0 accepting clients]\n"; + + return $server; +} + +sub vm_stop { + my $pid = shift @_; + return if not defined $pid; + kill 'TERM', $pid; +} + +sub vm_start { + my $pid = fork; + + if(not defined $pid) { + die "fork failed: $!"; + } + + if($pid == 0) { + exec('"/cygdrive/c/Program Files (x86)\QemuManager\qemu\qemu-system-x86_64.exe" -L "C:\Program Files (x86)\QemuManager\qemu" -M "pc" -m 512 -cpu "qemu64" -vga cirrus -drive "file=C:\Program Files (x86)\QemuManager\images\Test.qcow2,index=0,media=disk" -enable-kqemu -kernel-kqemu -net none -localtime -serial "tcp:127.0.0.1:4444,server,nowait" -monitor "tcp:127.0.0.1:4445,server,nowait" -kernel-kqemu -loadvm 1 -nographic'); + } else { + return $pid; + } +} + +sub execute { + my ($cmdline) = @_; + + my ($ret, $result); + + my $child = fork; + + if($child == 0) { + ($ret, $result) = eval { + my $result = ''; + + my $pid = open(my $fh, '-|', "$cmdline 2>&1"); + + local $SIG{ALRM} = sub { print "Time out\n"; kill 'TERM', $pid; die "Timed-out\n"; }; + alarm(6); + + while(my $line = <$fh>) { + $result .= $line; + } + + close $fh; + + my $ret = $? >> 8; + alarm 0; + return ($ret, $result); + }; + + alarm 0; + if($@ =~ /Timed-out/) { + #kill 'TERM', $child; + return (-13, '[Timed-out]'); + } + + print "[$ret, $result]\n"; + + return ($ret, $result); + } else { + waitpid($child, 0); + #print "child exited, parent continuing\n"; + return undef; + } +} + +sub compiler_server { + my $vm_pid = vm_start; + print "vm started pid: $vm_pid\n"; + + my $server = server_listen($PORT); + + while (my $client = $server->accept()) { + $client->autoflush(1); + my $hostinfo = gethostbyaddr($client->peeraddr); + printf "[Connect from %s]\n", $hostinfo->name || $client->peerhost; + eval { + my $lang; + my $nick; + my $code = ""; + + local $SIG{ALRM} = sub { die 'Timed-out'; }; + alarm 1; + + while (my $line = <$client>) { + $line =~ s/[\r\n]+$//; + next if $line =~ m/^\s*$/; + alarm 1; + print "got: [$line]\n"; + + if($line =~ /compile:end/) { + $code = quotemeta($code); + print "Attemping compile...\n"; + alarm 0; + my $tnick = quotemeta($nick); + my $tlang = quotemeta($lang); + + my ($ret, $result) = execute("./compiler_vm_client.pl $tnick -lang=$tlang $code"); + + if(not defined $ret) { + #print "parent continued\n"; + last; + } + + print "Ret: $ret; result: [$result]\n"; + + if($ret == -13) { + print $client "$nick: "; + } + + print $client $result . "\n"; + close $client; + # child exit + exit; + } + + if($line =~ /compile:([^:]+):(.*)$/) { + $nick = $1; + $lang = $2; + $code = ""; + next; + } + + $code .= $line . "\n"; + + } + + alarm 0; + }; + + alarm 0; + + close $client; + + print "stopping vm $vm_pid\n"; + vm_stop $vm_pid; + $vm_pid = vm_start; + print "new vm pid: $vm_pid\n"; + } +} + +compiler_server; diff --git a/modules/compiler_vm/compiler_vm_client.pl b/modules/compiler_vm/compiler_vm_client.pl new file mode 100755 index 00000000..7400cd09 --- /dev/null +++ b/modules/compiler_vm/compiler_vm_client.pl @@ -0,0 +1,667 @@ +#!/usr/bin/perl + +# use warnings; +use strict; +use feature qw(switch); + +use IPC::Open2; +use Text::Balanced qw(extract_codeblock extract_delimited); +use IO::Socket; +use LWP::UserAgent; + +my $MAX_UNDO_HISTORY = 100; + +my $output = ""; +my $nooutput = 'No output.'; + +my %languages = ( + 'C99' => "std=C99 with pedantic warnings", + 'C' => "std=gnu89", + 'CLANG' => "std=gnu89 clang/llvm", + 'CLANG99' => "std=c99 clang/llvm with pedantic warnings", +# 'C++' => 1, +); + +my %preludes = ( + 'C99' => "#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n\n", + 'C' => "#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n\n", + 'C++' => "#include \n#include \n\nusing namespace std;\n\n", + ); + +sub reset_vm { + my $sock = IO::Socket::INET->new(PeerAddr => '127.0.0.1', PeerPort => '4445', Proto => 'tcp', Type => 'SOCK_STREAM'); + die "Could not create socket: $!" unless $sock; + + $sock->autoflush(); + print $sock "loadvm 2\r\n"; + while(my $line = <$sock>) { + last if $line =~ /loadvm 2/; + } + sleep 2; + $sock->shutdown(1); +} + +sub pretty { + my $code = join '', @_; + my $result; + + my $pid = open2(\*IN, \*OUT, 'astyle -Upf'); + print OUT "$code\n"; + close OUT; + while(my $line = ) { + $result .= $line; + } + close IN; + waitpid($pid, 0); + 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 compile { + my ($lang, $code, $args, $input) = @_; + + my $sock = IO::Socket::INET->new(PeerAddr => '127.0.0.1', PeerPort => '4444', Proto => 'tcp', Type => 'SOCK_STREAM'); + + die "Could not create socket: $!" unless $sock; + + print $sock "compile:$lang:$args:$input\n"; + print $sock "$code\n"; + print $sock "compile:end\n"; + + my $result = ""; + my $got_result = 0; + + while(my $line = <$sock>) { + $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 $sock; + return $result; +} + +if($#ARGV < 1) { + print "Usage: cc [-compiler -options] [-stdin=input]\n"; + exit 0; +} + +my $nick = shift @ARGV; +my $code = join ' ', @ARGV; +my @last_code; + +my $lang = "C99"; +$lang = $1 if $code =~ s/-lang=([^\b\s]+)//i; +$lang = "C" if $code =~ s/-nowarn[ings]*//i; + +my $input = ""; +$input = $1 if $code =~ s/-input=(.*)$//i; + +my $args = ""; +$args .= "$1 " while $code =~ s/^\s*(-[^ ]+)\s*//; +$args =~ s/\s+$//; + +if(open FILE, "< last_code.txt") { + while(my $line = ) { + chomp $line; + push @last_code, $line; + } + close FILE; +} + +if($code =~ m/^\s*show\s*$/i) { + if(defined $last_code[0]) { + print "$nick: $last_code[0]\n"; + } else { + print "$nick: No recent code to show.\n" + } + exit 0; +} + +my $got_run = undef; + +if($code =~ m/^\s*(run|paste)\s*$/i) { + $got_run = lc $1; + if(defined $last_code[0]) { + $code = $last_code[0]; + } else { + print "$nick: No recent code to $got_run.\n"; + exit 0; + } +} else { + my $subcode = $code; + 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; + + while(1) { + $got_sub = 0; + $got_changes = 0; + + if($subcode =~ m/^\s*(and)?\s*remove \s*([^']+)?\s*'/) { + 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 '//) { + $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 '//) { + $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) { + $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\/.*\//) { + $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($@) { + print "$nick: $@\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) { + @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') { + while($code =~ s/($first_bound)$from($last_bound)/$1$to$2/) { + $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"; }/gex) { + $got_change = 1; + } + } + return $got_change; + }; + + if($@) { + print "$nick: $@\n"; + exit 0; + } + + if($ret) { + $got_sub = 1; + $got_changes = 1; + } + + $prevchange = $code; + $previous_from = $from; + $previous_modifier = $modifier; + } + + if($got_sub and not $got_changes) { + print "$nick: No replacements made.\n"; + exit 0; + } + } + + open FILE, "> last_code.txt"; + + unless ($got_undo and not $got_sub) { + unshift @last_code, $code; + } + + my $i = 0; + foreach my $line (@last_code) { + last if(++$i > $MAX_UNDO_HISTORY); + print FILE "$line\n"; + } + close FILE; + + if($got_undo and not $got_sub) { + print "$nick: $code\n"; + exit 0; + } +} + +# check to see if -flags were added by replacements +$lang = $1 if $code =~ s/-lang=([^\b\s]+)//i; +$lang = "C" if $code =~ s/-nowarn[ings]*//i; +$input = $1 if $code =~ s/-input=(.*)$//i; +$args .= "$1 " while $code =~ s/^\s*(-[^ ]+)\s*//; +$args =~ s/\s+$//; + +unless($got_run) { + open FILE, ">> log.txt"; + 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(" %-30s => %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"; + exit 0; +} + +$code =~ s/#include <([^>]+)>/#include <$1>\n/g; +$code =~ s/#([^ ]+) (.*?)\\n/#$1 $2\n/g; +$code =~ s/#([\w\d_]+)\\n/#$1\n/g; + +my $precode = $preludes{$lang} . $code; +$code = ''; + +if($lang eq 'C' or $lang eq 'C99' or $lang eq 'C++') { + my $has_main = 0; + + my $prelude = ''; + $prelude = "$1$2" if $precode =~ s/^\s*(#.*)(#.*?[>\n])//s; + + my $preprecode = $precode; + + while($preprecode =~ s/([ a-zA-Z0-9\_\*\[\]]+)\s+([a-zA-Z0-9_*]+)\s*\((.*?)\)\s*({.*)//) { + my ($ret, $ident, $params, $potential_body) = ($1, $2, $3, $4); + + $ret =~ s/^\s+//; + $ret =~ s/\s+$//; + + if($ret eq "else" or $ret eq "while") { + $precode .= "$ret $ident ($params) $potential_body"; + next; + } else { + $precode =~ s/([ a-zA-Z0-9\_\*\[\]]+)\s+([a-zA-Z0-9_*]+)\s*\((.*?)\)\s*({.*)//; + } + + my @extract = extract_codeblock($potential_body, '{}'); + my $body; + if(not defined $extract[0]) { + $output .= "error: unmatched brackets for function '$ident';\n"; + $body = $extract[1]; + } else { + $body = $extract[0]; + $preprecode .= $extract[1]; + $precode .= $extract[1]; + } + #print "[$ret][$ident][$params][$body]\n"; + $code .= "$ret $ident($params) $body\n\n"; + $has_main = 1 if $ident eq 'main'; + } + + $precode =~ s/^\s+//; + $precode =~ s/\s+$//; + + if(not $has_main) { + $code = "$prelude\n\n$code\n\nint main(int argc, char **argv) {\n$precode\n;\nreturn 0;\n}\n"; + $nooutput = "Success [no output]."; + } else { + $code = "$prelude\n\n$precode\n\n$code\n"; + $nooutput = "No output."; + } +} else { + $code = $precode; +} + +$code =~ s/\|n/\n/g; +$code =~ s/^\s+//; +$code =~ s/\s+$//; +$code =~ s/;\n;\n/;\n/g; +$code =~ s/(\n\n)+/\n\n/g; + +if(defined $got_run and $got_run eq "paste") { + my $uri = paste_codepad(pretty($code)); + print "$nick: $uri\n"; + exit 0; +} + +print FILE "$nick: [lang:$lang][args:$args][input:$input]\n$code\n"; + +$output = compile($lang, $code, $args, $input); + +$output =~ s/cc1: warnings being treated as errors//; +$output =~ s/ Line \d+ ://g; +$output =~ s/ \(first use in this function\)//g; +$output =~ s/error: \(Each undeclared identifier is reported only once.*?\)//msg; +$output =~ s/prog\.c:[:\d]*//g; +$output =~ s/ld: warning: cannot find entry symbol _start; defaulting to [^ ]+//; +$output =~ s/error: (.*?) error/error: $1; error/msg; +$output =~ s/\/tmp\/.*\.o://g; +$output =~ s/collect2: ld returned \d+ exit status//g; +$output =~ s/\(\.text\+[^)]+\)://g; +$output =~ s/\[ In/[In/; + +my $left_quote = chr(226) . chr(128) . chr(152); +my $right_quote = chr(226) . chr(128) . chr(153); +$output =~ s/$left_quote/'/g; +$output =~ s/$right_quote/'/g; + +$output = $nooutput if $output =~ m/^\s+$/; + +unless($got_run) { + print FILE localtime() . "\n"; + print FILE "$nick: $output\n\n"; + close FILE; +} + +print "$nick: $output\n"; + +#reset_vm; diff --git a/modules/compiler_vm/compiler_vm_server.pl b/modules/compiler_vm/compiler_vm_server.pl new file mode 100755 index 00000000..c11a0205 --- /dev/null +++ b/modules/compiler_vm/compiler_vm_server.pl @@ -0,0 +1,176 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +my %languages = ( + 'C' => { + 'cmdline' => 'gcc $args $file -o prog', + 'args' => '-Wextra -Wall -Wno-unused -std=gnu89', + 'file' => 'prog.c', + }, + 'C++' => { + 'cmdline' => 'g++ $args $file -o prog', + 'args' => '', + 'file' => 'prog.cpp', + }, + 'C99' => { + 'cmdline' => 'gcc $args $file -o prog', + 'args' => '-Wextra -Wall -Wno-unused -pedantic -std=c99', + 'file' => 'prog.c', + }, +); + +sub runserver { + open(my $input, '<', "/dev/ttyS0") or die $!; + open(my $output, '>', "/dev/ttyS0") or die $!; + + my $lang; + my $code; + my $user_args; + my $user_input; + + print "Waiting for input...\n"; + + while(my $line = <$input>) { + chomp $line; + next unless length $line; + + print "Got [$line]\n"; + + if($line =~ m/^compile:\s*end/) { + next if not defined $lang or not defined $code; + + print "Attempting compile [$lang] ...\n"; + + my $result = interpret($lang, $code, $user_args, $user_input); + + print "Done compiling; result: [$result]\n"; + print $output "result:$result\n"; + print $output "result:end\n"; + + print "input: "; + next; + } + + if($line =~ m/^compile:\s*(.*)/) { + my $options = $1; + $user_args = undef; + $user_input = undef; + $lang = undef; + + ($lang, $user_args, $user_input) = split /:/, $options; + + $code = ""; + $lang = "C99" if not defined $lang; + $user_args = "" if not defined $user_args; + $user_input = "" if not defined $user_input; + + print "Setting lang [$lang]; [$user_args]; [$user_input]\n"; + next; + } + + $code .= $line . "\n"; + } + + close $input; + close $output; +} + +sub interpret { + my ($lang, $code, $user_args, $user_input) = @_; + + print "lang: [$lang], code: [$code], user_args: [$user_args], input: [$user_input]\n"; + + $lang = uc $lang; + + if(not exists $languages{$lang}) { + return "No support for language '$lang' at this time.\n"; + } + + open(my $fh, '>', $languages{$lang}{'file'}) or die $!; + print $fh $code . "\n"; + close $fh; + + my $cmdline = $languages{$lang}{'cmdline'}; + + if(length $user_args) { + print "Replacing args with $user_args\n"; + $user_args = quotemeta($user_args); + $user_args =~ s/\\ / /g; + $cmdline =~ s/\$args/$user_args/; + } else { + $cmdline =~ s/\$args/$languages{$lang}{'args'}/; + } + + $cmdline =~ s/\$file/$languages{$lang}{'file'}/; + + print "Executing [$cmdline]\n"; + my ($ret, $result) = execute(60, $cmdline); + print "Got result: ($ret) [$result]\n"; + + if($ret != 0) { + return $result; + } + + my $output = ""; + + if(length $result) { + $result =~ s/^\s+//; + $result =~ s/\s+$//; + $output = "[$result]\n"; + } + + ($ret, $result) = execute(5, "./compiler_watchdog.pl"); + + print "Executed prog; got result: ($ret) [$result]\n"; + + $result =~ s/^\s+//; + $result =~ s/\s+$//; + + 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; +} + +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; diff --git a/modules/compiler_vm/compiler_watchdog.pl b/modules/compiler_vm/compiler_watchdog.pl new file mode 100755 index 00000000..0d49a3fb --- /dev/null +++ b/modules/compiler_vm/compiler_watchdog.pl @@ -0,0 +1,138 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use POSIX ":sys_wait_h"; + +my @signame; +$signame[0] = 'SIGZERO'; +$signame[1] = 'SIGHUP'; +$signame[2] = 'SIGINT'; +$signame[3] = 'SIGQUIT'; +$signame[4] = 'SIGILL'; +$signame[5] = 'SIGTRAP'; +$signame[6] = 'SIGABRT'; +$signame[7] = 'SIGBUS'; +$signame[8] = 'SIGFPE'; +$signame[9] = 'SIGKILL'; +$signame[10] = 'SIGUSR1'; +$signame[11] = 'SIGSEGV'; +$signame[12] = 'SIGUSR2'; +$signame[13] = 'SIGPIPE'; +$signame[14] = 'SIGALRM'; +$signame[15] = 'SIGTERM'; +$signame[16] = 'SIGSTKFLT'; +$signame[17] = 'SIGCHLD'; +$signame[18] = 'SIGCONT'; +$signame[19] = 'SIGSTOP'; +$signame[20] = 'SIGTSTP'; +$signame[21] = 'SIGTTIN'; +$signame[22] = 'SIGTTOU'; +$signame[23] = 'SIGURG'; +$signame[24] = 'SIGXCPU'; +$signame[25] = 'SIGXFSZ'; +$signame[26] = 'SIGVTALRM'; +$signame[27] = 'SIGPROF'; +$signame[28] = 'SIGWINCH'; +$signame[29] = 'SIGIO'; +$signame[30] = 'SIGPWR'; +$signame[31] = 'SIGSYS'; +$signame[32] = 'SIGNUM32'; +$signame[33] = 'SIGNUM33'; +$signame[34] = 'SIGRTMIN'; +$signame[35] = 'SIGNUM35'; +$signame[36] = 'SIGNUM36'; +$signame[37] = 'SIGNUM37'; +$signame[38] = 'SIGNUM38'; +$signame[39] = 'SIGNUM39'; +$signame[40] = 'SIGNUM40'; +$signame[41] = 'SIGNUM41'; +$signame[42] = 'SIGNUM42'; +$signame[43] = 'SIGNUM43'; +$signame[44] = 'SIGNUM44'; +$signame[45] = 'SIGNUM45'; +$signame[46] = 'SIGNUM46'; +$signame[47] = 'SIGNUM47'; +$signame[48] = 'SIGNUM48'; +$signame[49] = 'SIGNUM49'; +$signame[50] = 'SIGNUM50'; +$signame[51] = 'SIGNUM51'; +$signame[52] = 'SIGNUM52'; +$signame[53] = 'SIGNUM53'; +$signame[54] = 'SIGNUM54'; +$signame[55] = 'SIGNUM55'; +$signame[56] = 'SIGNUM56'; +$signame[57] = 'SIGNUM57'; +$signame[58] = 'SIGNUM58'; +$signame[59] = 'SIGNUM59'; +$signame[60] = 'SIGNUM60'; +$signame[61] = 'SIGNUM61'; +$signame[62] = 'SIGNUM62'; +$signame[63] = 'SIGNUM63'; +$signame[64] = 'SIGRTMAX'; +$signame[65] = 'SIGIOT'; +$signame[66] = 'SIGCLD'; +$signame[67] = 'SIGPOLL'; +$signame[68] = 'SIGUNUSED'; + +sub reaper { + my $child; + while (($child=waitpid(-1,WNOHANG))>0) { + + # See waitpid(2) and POSIX(3perl) + my $status = $?; + my $exitcode = $status >> 8; + my $wifexited = WIFEXITED($status); + my $wexitstatus = $wifexited ? WEXITSTATUS($status) : undef; + my $wifsignaled = WIFSIGNALED($status); + my $wtermsig = $wifsignaled ? WTERMSIG($status) : undef; + my $wifstopped = WIFSTOPPED($status); + my $wstopsig = $wifstopped ? WSTOPSIG($status) : undef; + + if($wifsignaled == 1) { + print "\nProgram received signal $wtermsig ($signame[$wtermsig])\n"; + exit; + } + + if(($wifexited == 1) && ($exitcode != 0)) { + print "\nExit: $exitcode\n"; + exit; + } elsif(($wifexited ==1) && ($exitcode == 0)) { + exit; + } + else { + + print "" + ." status=$status exitcode=$exitcode" + ." wifexited=$wifexited" + ." wexitstatus=".(defined($wexitstatus) ? $wexitstatus : " + +undef") + ." wifsignaled=$wifsignaled" + ." wtermsig=".(defined($wtermsig) ? $wtermsig : "undef") + ." wifstopped=$wifstopped" + ." wstopsig=".(defined($wstopsig) ? $wstopsig : "undef") + ."\n"; + exit; + } + } +} + +sub execute { + my ($cmdline) = @_; + my ($ret, $result); + + local $SIG{CHLD} = \&reaper; + + my $child = fork; + + local $SIG{TERM} = sub { kill 'TERM', $child; }; + + if($child == 0) { + exec("$cmdline 2>&1"); + } else { + while(1) { sleep 10; } + } +} + +execute("./prog"); diff --git a/modules/compiler_vm/monitor b/modules/compiler_vm/monitor new file mode 100755 index 00000000..08ef3a49 --- /dev/null +++ b/modules/compiler_vm/monitor @@ -0,0 +1 @@ +telnet localhost 4445 diff --git a/modules/compiler_vm/runqemu b/modules/compiler_vm/runqemu new file mode 100755 index 00000000..155dbd36 --- /dev/null +++ b/modules/compiler_vm/runqemu @@ -0,0 +1 @@ +"/cygdrive/c/Program Files (x86)\QemuManager\qemu\qemu-system-x86_64.exe" -L "C:\Program Files (x86)\QemuManager\qemu" -M "pc" -m 512 -cpu "qemu64" -vga cirrus -drive "file=C:\Program Files (x86)\QemuManager\images\Test.qcow2,index=0,media=disk" -enable-kqemu -kernel-kqemu -net none -localtime -serial "tcp:127.0.0.1:4444,server,nowait" -monitor "tcp:127.0.0.1:4445,server,nowait" -kernel-kqemu -loadvm 1 diff --git a/modules/compiler_vm/runqemu.net b/modules/compiler_vm/runqemu.net new file mode 100755 index 00000000..2b8f90ec --- /dev/null +++ b/modules/compiler_vm/runqemu.net @@ -0,0 +1 @@ +"/cygdrive/c/Program Files (x86)\QemuManager\qemu\qemu-system-x86_64.exe" -L "C:\Program Files (x86)\QemuManager\qemu" -M "pc" -m 512 -cpu "qemu64" -vga cirrus -drive "file=C:\Program Files (x86)\QemuManager\images\Test.qcow2,index=0,media=disk" -enable-kqemu -net nic,vlan=0,macaddr=52-54-00-F0-EC-8D,model=rtl8139 -net user,vlan=0 -localtime -serial "tcp:127.0.0.1:4444,server,nowait" -monitor "tcp:127.0.0.1:4445,server,nowait" -loadvm 1 diff --git a/modules/compiler_vm/serial b/modules/compiler_vm/serial new file mode 100755 index 00000000..4e609544 --- /dev/null +++ b/modules/compiler_vm/serial @@ -0,0 +1 @@ +telnet localhost 4444