mirror of
https://github.com/perlbot/perlbuut
synced 2025-06-07 10:35:41 -04:00
Starting setup of new evalserver
This commit is contained in:
Ryan Voots
parent
946e1fcada
commit
aab4315a6f
5 changed files with 209 additions and 4 deletions
|
|
@ -1,7 +1,40 @@
|
|||
#!/bin/bash
|
||||
|
||||
read -r -d '' CODE <<'EOC'
|
||||
javascript console.log("Hello World");
|
||||
perl
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
use Test::Deep qw(:v1 cmp_details deep_diag);
|
||||
|
||||
{
|
||||
package ClassA;
|
||||
|
||||
sub new { bless {}, shift }
|
||||
|
||||
sub values {
|
||||
foo => 1,
|
||||
bar => 2,
|
||||
baz => 3,
|
||||
}
|
||||
}
|
||||
|
||||
my $obj = ClassA->new;
|
||||
|
||||
cmp_deeply $obj, listmethods(
|
||||
values => code(sub {
|
||||
my ($it) = @_;
|
||||
my ($ok, $stack) = cmp_details { @$it }, {
|
||||
foo => 1,
|
||||
bar => 2,
|
||||
baz => 3,
|
||||
};
|
||||
$ok || (0, deep_diag $stack)
|
||||
}),
|
||||
);
|
||||
|
||||
done_testing;
|
||||
EOC
|
||||
|
||||
echo --------
|
||||
|
|
|
|||
|
|
@ -193,7 +193,9 @@ our %rule_sets = (
|
|||
|
||||
# language master rules
|
||||
lang_perl => {
|
||||
rules => [],
|
||||
rules => [
|
||||
{syscall => 'dup'}
|
||||
],
|
||||
include => ['default'],
|
||||
},
|
||||
|
||||
|
|
|
|||
|
|
@ -61,6 +61,8 @@ $|++;
|
|||
|
||||
my %exec_map = (
|
||||
'perl1' => {bin => '/langs/perl-1.0.16/bin/perl'},
|
||||
'perl2' => {bin => '/langs/perl2/bin/perl'},
|
||||
'perl3' => {bin => '/langs/perl3/bin/perl'},
|
||||
'perl4' => {bin => '/perl5/perlbrew/perls/perl-4.036/bin/perl'},
|
||||
'perl5.5' => {bin => '/perl5/perlbrew/perls/perl-5.005_04/bin/perl'},
|
||||
'perl5.6' => {bin => '/perl5/perlbrew/perls/perl-5.6.2/bin/perl'},
|
||||
|
|
@ -409,7 +411,7 @@ Biqsip biqsip 'ugh chan ghitlh lursa' nuh bey' ngun petaq qeng soj tlhej waqboch
|
|||
}
|
||||
';
|
||||
|
||||
unless ($version eq '4' || $version eq '1') {
|
||||
unless ($version eq '4' || $version eq '1' || $version eq '2' || $version eq '3') {
|
||||
exec($exec_map{'perl'.$version}{bin}, '-e', $wrapper) or die "Exec failed $!";
|
||||
} else {
|
||||
exec($exec_map{'perl'.$version}{bin}, '-e', $code); # the code for perl4 is actually still in STDIN, if we try to -e it needs to write files
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ use strict;
|
|||
|
||||
no warnings 'void';
|
||||
|
||||
my @versions = ('', qw(1 4 5.5 5.6 5.8 5.10 5.12 5.14 5.16 5.18 5.20 5.22 5.24 all));
|
||||
my @versions = ('', qw(1 2 3 4 5.5 5.6 5.8 5.10 5.12 5.14 5.16 5.18 5.20 5.22 5.24 all));
|
||||
|
||||
sub new {
|
||||
my( $class ) = @_;
|
||||
|
|
|
|||
168
plugins/supereval.pm
Normal file
168
plugins/supereval.pm
Normal file
|
|
@ -0,0 +1,168 @@
|
|||
# eval plugin for buubot3
|
||||
package Bot::BB3::Plugin::Supereval;
|
||||
|
||||
use POE::Filter::Reference;
|
||||
use IO::Socket::INET;
|
||||
use Data::Dumper;
|
||||
use App::EvalServerAdvanced::Protocol;
|
||||
use Encode;
|
||||
use strict;
|
||||
|
||||
no warnings 'void';
|
||||
|
||||
my @versions = ('', qw(1 2 3 4 5.5 5.6 5.8 5.10 5.12 5.14 5.16 5.18 5.20 5.22 5.24 all));
|
||||
|
||||
sub new {
|
||||
my( $class ) = @_;
|
||||
|
||||
my $self = bless {}, $class;
|
||||
$self->{name} = 'supereval';
|
||||
$self->{opts} = {
|
||||
command => 1,
|
||||
};
|
||||
|
||||
my @perl_aliases = map {("Xeval$_", "wXeval$_", "sXeval$_", "wsXeval$_", "swXeval$_")} @versions;
|
||||
|
||||
$self->{aliases} = [ qw/Xpleval Xperleval Xdeparse/, @perl_aliases ];
|
||||
$self->{dbh} = DBI->connect("dbi:SQLite:dbname=var/evallogs.db");
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub command {
|
||||
my( $self, $said, $pm ) = @_;
|
||||
|
||||
my $code = $said->{"body"};
|
||||
|
||||
my $command = $said->{command_match};
|
||||
my $type = $said->{command_match};
|
||||
$type =~ s/^\s*(\w+?)?Xeval(.*)?/$1$2/;
|
||||
warn "Initial type: $type\n";
|
||||
|
||||
my %translations = (
|
||||
js => 'javascript',
|
||||
perl => 'perl',
|
||||
pl => 'perl',
|
||||
php => 'php',
|
||||
deparse => 'deparse',
|
||||
'k20' => 'k20',
|
||||
'k' => 'k20',
|
||||
'rb' => 'ruby',
|
||||
'ruby' => 'ruby',
|
||||
'py' => 'python',
|
||||
'python' => 'python',
|
||||
'lua' => 'lua',
|
||||
'j' => 'j',
|
||||
'w' => 'perl',
|
||||
's' => 'perl',
|
||||
'ws' => 'perl',
|
||||
'sw' => 'perl',
|
||||
map {($_=>"perl$_", "w$_"=>"perl$_", "s$_" => "perl$_", "ws$_"=>"perl$_", "sw$_"=>"perl$_")} @versions
|
||||
);
|
||||
|
||||
my $orig_type = $type;
|
||||
$type = $translations{$type};
|
||||
if( not $type ) { $type = 'perl'; }
|
||||
warn "Found $type: $code";
|
||||
|
||||
if ($command =~ /^([ws]+)?Xeval/i) {
|
||||
my $c=$1;
|
||||
$code = "use warnings; ".$code if ($c =~ /w/);
|
||||
$code = "use strict; ".$code if ($c =~ /s/);
|
||||
}
|
||||
|
||||
$code =~ s//\n/g;
|
||||
|
||||
my $resultstr='';
|
||||
|
||||
unless ($type =~ /perlall/) {
|
||||
$resultstr = $self->do_singleeval($type, $code);
|
||||
} else {
|
||||
# TODO use channel config for this
|
||||
if ($said->{channel} eq '#perlbot' || $said->{channel} eq '*irc_msg') {
|
||||
$resultstr = $self->do_multieval([map {"perl".$_} @versions], $code);
|
||||
} else {
|
||||
$resultstr = "evalall only works in /msg or in #perlbot";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (!$said->{captured} && $resultstr !~ /\S/) {
|
||||
$resultstr = "No output.";
|
||||
}
|
||||
|
||||
if ($type eq 'perl') {
|
||||
$self->{dbh}->do("INSERT INTO evals (input, output) VALUES (?, ?)", {}, $code, $resultstr);
|
||||
}
|
||||
|
||||
|
||||
return( 'handled', $resultstr);
|
||||
}
|
||||
|
||||
sub do_multieval {
|
||||
my ($self, $types, $code) = @_;
|
||||
|
||||
|
||||
my $socket = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => '14401' )
|
||||
or die "error: cannot connect to eval server";
|
||||
|
||||
my $seq = 1;
|
||||
my $output = '';
|
||||
|
||||
for my $type (@$types) {
|
||||
my $eval_obj = {language => $type, files => [{filename => '__code', contents => $code}], prio => {pr_batch=>{}}, sequence => $seq++};
|
||||
print $socket encode_message(eval => $eval_obj);
|
||||
my $message = $self->read_message($socket);
|
||||
$output .= sprintf "[[ %s ]]\n%s\n", $type, $message->contents;
|
||||
}
|
||||
|
||||
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub do_singleeval {
|
||||
my ($self, $type, $code) = @_;
|
||||
|
||||
my $socket = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => '14401' )
|
||||
or die "error: cannot connect to eval server";
|
||||
|
||||
my $eval_obj = {language => $type, files => [{filename => '__code', contents => $code}], prio => {pr_realtime=>{}}, sequence => 1};
|
||||
|
||||
$socket->autoflush();
|
||||
print $socket encode_message(eval => $eval_obj);
|
||||
|
||||
my $buf = '';
|
||||
my $data = '';
|
||||
my $resultstr = "Failed to read a message";
|
||||
|
||||
my $message = $self->read_message($socket);
|
||||
|
||||
return $message->contents;
|
||||
}
|
||||
|
||||
sub read_message {
|
||||
my ($self, $socket) = @_;
|
||||
|
||||
my $header;
|
||||
$socket->read($header, 8) or die "Couldn't read from socket";
|
||||
|
||||
my ($reserved, $length) = unpack "NN", $header;
|
||||
|
||||
die "Invalid packet" unless $reserved == 0;
|
||||
|
||||
my $buffer;
|
||||
$socket->read($buffer, $length) or die "Couldn't read from socket2";
|
||||
|
||||
my ($res, $message, $nbuf) = decode_message($header . $buffer);
|
||||
|
||||
|
||||
die "Data left over in buffer" unless $nbuf eq '';
|
||||
die "Couldn't decode packet" unless $res;
|
||||
|
||||
return $message;
|
||||
}
|
||||
|
||||
"Bot::BB3::Plugin::Supereval";
|
||||
|
||||
__DATA__
|
||||
The eval plugin. Evaluates various different languages. Syntax, eval: code; also pleval deparse. You can use different perl versions by doing eval5.X, e.g. eval5.5: print "$]"; You can also add s or w to the eval to quickly add strict or warnings. sweval: print $foo;
|
||||
Loading…
Add table
Reference in a new issue