Perlbot/perlbuut
1
0
Fork 0
mirror of https://github.com/perlbot/perlbuut synced 2025-06-07 16:45:40 -04:00
Code Issues Releases Wiki Activity

Remove old evalserver. Use App::EvalServerAdvanced from not on

Browse source
This commit is contained in:
Ryan Voots 2017-07-18 13:39:38 -04:00
parent ef5ef5ddd6
commit 2faa98211a
7 changed files with 0 additions and 1406 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
bin/evalserver
View file

@ -1,25 +0,0 @@
#!/home/ryan/perl5/perlbrew/perls/perlbot-inuse/bin/perl
#use local::lib;
# Guess we're being activated inside bin/, so go up a directory.
BEGIN { if( not -e 'lib' and not -e 'etc' and -e 'bb3' ) { chdir ".."; } }
use FindBin;
use lib "$FindBin::Bin/../lib";
use EvalServer;
use POSIX qw/setsid/;
#$ENV{PATH}="/home/farnsworth/perl5/perlbrew/perls/perl-5.14.0/bin:/usr/bin/:/bin/";
# Only daemonize if we're asked to.
if( $ARGV[0] eq '-d' ) {
# Crude daemonization
setsid();
fork and exit;
open STDOUT, ">var/evalserver.stdout" or die "Tried to reopen STDOUT to bb3.stdout: $!";
open STDERR, ">var/evalserver.stderr" or die "Tried to reopen STDERR to bb3.stdout: $!";
close STDIN;
}
EvalServer->start;

243
lib/EvalServer.pm
View file

@ -1,243 +0,0 @@
package EvalServer;
use POE;
use POE::Wheel::SocketFactory;
use POE::Wheel::ReadWrite;
use POE::Filter::Reference;
use POE::Filter::Line;
use POE::Filter::Stream;
use POE::Wheel::Run;
use strict;
use EvalServer::Sandbox;
sub start {
my( $class ) = @_;
my $self = $class->new;
my $session = POE::Session->create(
object_states => [
$self => [ qw/
_start _stop
socket_new socket_fail socket_read socket_write
spawn_eval eval_read eval_err eval_close eval_stdin
dead_child timeout
/ ],
]
);
POE::Kernel->run();
}
sub new {
return bless {}, shift;
}
sub spawn_eval {
my( $self, $kernel, $args, $parent_id ) = @_[OBJECT,KERNEL,ARG0,ARG1];
my $filename = 'eval.pl';
if( not -e $filename ) {
$filename = $FindBin::Bin . "/../lib/$filename";
}
warn "Spawning Eval: $args->{code}\n";
my $wheel = POE::Wheel::Run->new(
Program => \&EvalServer::Sandbox::run_eval,
ProgramArgs => [ ],
CloseOnCall => 1, #Make sure all of the filehandles are closed.
Priority => 10, #Let's be nice!
StdoutEvent => 'eval_read',
StderrEvent => 'eval_err',
StdinEvent => 'eval_stdin',
CloseEvent => 'eval_close',
StdinFilter => POE::Filter::Line->new,
StdoutFilter => POE::Filter::Stream->new(),
StderrFilter => POE::Filter::Stream->new(),
);
warn "Storing Eval id: ", $wheel->ID, "\n";
$self->{ eval_wheels }->{ $wheel->ID } = { wheel => $wheel, parent_id => $parent_id };
$wheel->put( $args->{code} );
warn "Adding delay for 30 seconds: ", $wheel->ID;
$kernel->delay_set( timeout => 30, $wheel->ID );
}
sub timeout {
my( $self, $wheel_id ) = @_[OBJECT,ARG0];
warn "Got a timeout idea for $wheel_id";
my $wheel = $self->{ eval_wheels }->{ $wheel_id }->{ wheel }
or return; # Our wheel has gone away already.
warn "Trying to kill: ", $wheel->PID;
kill( 'TERM', $wheel->PID ); # Try to avoid orphaning any sub processes first
sleep(3);
kill( 'KILL', $wheel->PID );
}
sub _append_output {
my $self = shift; #Decrement @_ !
my( $cur_session, $kernel, $results, $id ) = @_[SESSION,KERNEL,ARG0,ARG1];
warn "AT UNDERSCORE: @_\n";
warn "Attempting to append: $self, $results, $id\n";
#return unless $results =~ /\S/;
my $output_buffer = $self->{ wheel_outputs }->{ $id } ||= [];
push @$output_buffer, $results;
warn "Checking length: ", scalar( @$output_buffer );
if( @$output_buffer > 1000 ) { # Lets not be silly
warn "Attempting to force a timeout using $cur_session";
$kernel->call( $cur_session->ID, timeout => $id ); #Force a timeout. Go away spammy outputs.
my $wheel = $self->{ eval_wheels }->{ $id }->{ wheel };
if( $wheel ) { $wheel->pause_stdout };
$kernel->call( $cur_session->ID, eval_close => $id );
}
}
sub eval_read {
#my( $self, $cur_session, $kernel, $results, $id ) = @_[OBJECT,SESSION,KERNEL,ARG0,ARG1];
my $self = $_[OBJECT];
$self->_append_output( @_ );
}
sub eval_err {
my( $self, $error ) = @_[OBJECT,ARG0];
$self->_append_output( @_ );
}
sub eval_stdin {
my( $self, $id ) = @_[OBJECT,ARG0];
warn "STDIN EVENT\n";
#We've successfully flushed our output to the eval child
#so shutdown the wheel's stdin
my $wheel = $self->{ eval_wheels }->{ $id }->{ wheel};
$wheel->shutdown_stdin;
}
sub eval_close {
my( $self, $id ) = @_[OBJECT,ARG0];
warn "CLOSE EVENT\n";
# Sorry.
# I should find a better way someday.
warn "Looking for id: $id\n";
my $wheel_struct = delete $self->{ eval_wheels }->{ $id };
return unless $wheel_struct;
# Get our parent's ID
my $parent_id = $wheel_struct->{ parent_id };
warn "Found parent: $parent_id\n";
my $parent_wheel = $self->{ socket_wheels }->{ $parent_id };
# Send the results back to our client
my $outputs = delete $self->{ wheel_outputs }->{ $id };
warn "Close, my outputs: ", Dumper( $outputs );
# Not sure how we end up without a $parent_wheel, but we shouldn't die
if( $parent_wheel ) {
if( $outputs and @$outputs ) {
$parent_wheel->put( [ join '', @$outputs ] );
}
else {
$parent_wheel->put( [ ] );
}
}
}
sub _start {
my( $self, $kernel ) = @_[OBJECT,KERNEL];
warn "Eval Server starting\n";
$self->{socket_factory} = POE::Wheel::SocketFactory->new(
BindAddress => "127.0.0.1",
BindPort => '14400',
SuccessEvent => 'socket_new',
FailureEvent => 'socket_fail',
Reuse => 'on',
);
warn "Ready for connections...\n";
$kernel->sig( 'CHLD' => 'dead_child' );
}
sub socket_new {
my( $self, $handle ) = @_[OBJECT,ARG0];
warn "Got a socket\n";
my $wheel = POE::Wheel::ReadWrite->new(
Handle => $handle,
Driver => POE::Driver::SysRW->new(),
Filter => POE::Filter::Reference->new(),
InputEvent => 'socket_read',
FlushedEvent => 'socket_write',
ErrorEvent => 'socket_error',
);
warn "Storing socket as : ", $wheel->ID, "\n";
$self->{socket_wheels}->{ $wheel->ID } = $wheel;
}
sub socket_fail {
warn "SOCKET FAIL: $_[ARG0],$_[ARG1]\n";
}
sub socket_read {
my( $object, $kernel, $input, $wheel_id ) = @_[OBJECT,KERNEL,ARG0,ARG1];
use Data::Dumper;
warn "Got Input: ", Dumper $input;
$kernel->yield( spawn_eval => $input, $wheel_id );
}
sub socket_write {
my( $self, $id ) = @_[OBJECT,ARG0];
warn "SOCKET_WRITE!\n";
# We've received our single chunk of output for this
# response so remove the wheel.
my $wheel = delete $self->{socket_wheels}->{ $id };
$wheel->shutdown_input();
$wheel->shutdown_output();
}
sub socket_error {
my( $self, $id ) = @_[OBJECT,ARG0];
warn "Socket failed!\n";
delete $self->{socket_wheels}->{ $id };
}
sub _stop {
}
sub dead_child {
#Do nothing
#Side effect is the child is already reaped
}
1;

74
lib/EvalServer/Sandbox.pm
View file

@ -1,74 +0,0 @@
package EvalServer::Sandbox;
use strict;
use warnings;
use Config;
use Sys::Linux::Namespace;
use Sys::Linux::Mount qw/:all/;
my %sig_map;
use FindBin;
do {
my @sig_names = split ' ', $Config{sig_name};
my @sig_nums = split ' ', $Config{sig_num};
@sig_map{@sig_nums} = map {'SIG' . $_} @sig_names;
$sig_map{31} = "SIGSYS (Illegal Syscall)";
};
my $namespace = Sys::Linux::Namespace->new(private_pid => 1, no_proc => 1, private_mount => 1, private_uts => 1, private_ipc => 0, private_sysvsem => 1);
# {files => [
# {filename => '...',
# contents => '...',},
# ...,],
# main_file => 'filename',
# main_language => '',
# }
#
sub run_eval {
my $code = shift; # TODO this should be more than just code
my $jail_path = $FindBin::Bin."/../jail";
my $jail_root_path = $FindBin::Bin."/../jail_root";
my $filename = '/eval/elib/eval.pl';
$namespace->run(code => sub {
my @binds = (
{src => $jail_root_path, target => "/"},
{src => "/lib64", target => "/lib64"},
{src => "/lib", target => "/lib"},
{src => "/usr/lib", target => "/usr/lib"},
{src => "/usr/bin", target => "/usr/bin"},
{src => "/home/ryan/perl5", target => "/perl5"},
{src => "/home/ryan/perl5", target => "/home/ryan/perl5"},
{src => $FindBin::Bin."/../lib", target => "/eval/elib"},
{src => $FindBin::Bin."/../langs", target => "/langs"},
);
for my $bind (@binds) {
mount($bind->{src}, $jail_path . $bind->{target}, undef, MS_BIND|MS_PRIVATE|MS_RDONLY, undef);
}
mount("tmpfs", $FindBin::Bin."/../jail/tmp", "tmpfs", 0, {size => "16m"});
mount("tmpfs", $FindBin::Bin."/../jail/tmp", "tmpfs", MS_PRIVATE, {size => "16m"});
chdir($jail_path) or die "Jail not made, see bin/makejail.sh";
chroot($jail_path) or die $!;
#system("/perl5/perlbrew/perls/perlbot-inuse/bin/perl", $filename);
system($^X, $filename);
my ($exit, $signal) = (($?&0xFF00)>>8, $?&0xFF);
if ($exit) {
print "[Exited $exit]";
} elsif ($signal) {
my $signame = $sig_map{$signal} // $signal;
print "[Died $signame]";
}
});
}
1;

375
lib/EvalServer/Seccomp.pm
View file

@ -1,375 +0,0 @@
package EvalServer::Seccomp;
use strict;
use warnings;
use Data::Dumper;
use List::Util qw/reduce uniq/;
use Moo;
use Linux::Clone;
use POSIX;
use Linux::Seccomp;
use Carp qw/croak/;
use Permute::Named::Iter qw/permute_named_iter/;
use constant {
CLONE_FILES => Linux::Clone::FILES,
CLONE_FS => Linux::Clone::FS,
CLONE_NEWNS => Linux::Clone::NEWNS,
CLONE_VM => Linux::Clone::VM,
CLONE_THREAD => Linux::Clone::THREAD,
CLONE_SIGHAND => Linux::Clone::SIGHAND,
CLONE_SYSVSEM => Linux::Clone::SYSVSEM,
CLONE_NEWUSER => Linux::Clone::NEWUSER,
CLONE_NEWPID => Linux::Clone::NEWPID,
CLONE_NEWUTS => Linux::Clone::NEWUTS,
CLONE_NEWIPC => Linux::Clone::NEWIPC,
CLONE_NEWNET => Linux::Clone::NEWNET,
CLONE_NEWCGROUP => Linux::Clone::NEWCGROUP,
CLONE_PTRACE => Linux::Clone::PTRACE,
CLONE_VFORK => Linux::Clone::VFORK,
CLONE_SETTLS => Linux::Clone::SETTLS,
CLONE_PARENT_SETTID => Linux::Clone::PARENT_SETTID,
CLONE_CHILD_SETTID => Linux::Clone::CHILD_SETTID,
CLONE_CHILD_CLEARTID => Linux::Clone::CHILD_CLEARTID,
CLONE_DETACHED => Linux::Clone::DETACHED,
CLONE_UNTRACED => Linux::Clone::UNTRACED,
CLONE_IO => Linux::Clone::IO,
};
has exec_map => (is => 'ro', default => sub {+{}});
has profiles => (is => 'ro'); # aref
has _rules => (is => 'rw');
has seccomp => (is => 'ro', default => sub {Linux::Seccomp->new(SCMP_ACT_KILL)});
has _permutes => (is => 'ro', default => sub {+{}});
has _used_sets => (is => 'ro', default => sub {+{}});
has _finalized => (is => 'rw', default => 0); # TODO make this set once
# Define some more open modes that POSIX doesn't have for us.
my ($O_DIRECTORY, $O_CLOEXEC, $O_NOCTTY, $O_NOFOLLOW) = (00200000, 02000000, 00000400, 00400000);
# TODO this needs some accessors to make it easier to define rulesets
our %rule_sets = (
default => {
include => ['time_calls', 'file_readonly', 'stdio', 'exec_wrapper', 'file_write', 'file_tty', 'file_opendir', 'perlmod_file_temp'],
rules => [{syscall => 'mmap'},
{syscall => 'munmap'},
{syscall => 'mremap'},
{syscall => 'mprotect'},
{syscall => 'madvise'},
{syscall => 'brk'},
{syscall => 'exit'},
{syscall => 'exit_group'},
{syscall => 'rt_sigaction'},
{syscall => 'rt_sigprocmask'},
{syscall => 'rt_sigreturn'},
{syscall => 'getuid'},
{syscall => 'geteuid'},
{syscall => 'getcwd'},
{syscall => 'getpid'},
{syscall => 'gettid'},
{syscall => 'getgid'},
{syscall => 'getegid'},
{syscall => 'getgroups'},
{syscall => 'access'}, # file_* instead?
{syscall => 'readlink'},
{syscall => 'arch_prctl'},
{syscall => 'set_tid_address'},
{syscall => 'set_robust_list'},
{syscall => 'futex'},
{syscall => 'getrlimit'},
# TODO these should be defaults? locked down more?
{syscall => 'prctl',},
{syscall => 'poll',},
{syscall => 'uname',},
],
},
perm_test => {
permute => {foo => [1, 2, 3], bar => [4, 5, 6]},
rules => [{syscall => 'permme', permute_rules => [[0, '==', \'foo'], [1, '==', \'bar']]}]
},
# File related stuff
stdio => {
rules => [{syscall => 'read', rules => [[qw|0 == 0|]]}, # STDIN
{syscall => 'write', rules => [[qw|0 == 1|]]}, # STDOUT
{syscall => 'write', rules => [[qw|0 == 2|]]},
],
},
file_open => {
rules => [{syscall => 'open', permute_rules => [['1', '==', \'open_modes']]},
{syscall => 'openat', permute_rules => [['2', '==', \'open_modes']]},
{syscall => 'close'},
{syscall => 'select'},
{syscall => 'read'},
{syscall => 'pread64'},
{syscall => 'lseek'},
{syscall => 'fstat'}, # default? not file_open?
{syscall => 'stat'},
{syscall => 'lstat'},
{syscall => 'fcntl'},
# 4352 ioctl(4, TCGETS, 0x7ffd10963820) = -1 ENOTTY (Inappropriate ioctl for device)
# This happens on opened files for some reason? wtf
{syscall => 'ioctl', rules =>[[1, '==', 0x5401]]},
],
},
file_opendir => {
rules => [{syscall => 'getdents'},
{syscall => 'open', rules => [['1', '==', $O_DIRECTORY|&POSIX::O_RDONLY|&POSIX::O_NONBLOCK|$O_CLOEXEC]]},
],
include => ['file_open'],
},
file_tty => {
permute => {open_modes => [$O_NOCTTY]},
include => ['file_open'],
},
file_readonly => {
permute => {open_modes => [&POSIX::O_NONBLOCK, &POSIX::O_EXCL, &POSIX::O_RDONLY, $O_NOFOLLOW, $O_CLOEXEC]},
include => ['file_open'],
},
file_write => {
permute => {open_modes => [&POSIX::O_CREAT,&POSIX::O_WRONLY, &POSIX::O_TRUNC, &POSIX::O_RDWR]},
rules => [{syscall => 'write'},
{syscall => 'pwrite64'},
],
include => ['file_open', 'file_readonly'],
},
# time related stuff
time_calls => {
rules => [
{syscall => 'nanosleep'},
{syscall => 'clock_gettime'},
{syscall => 'clock_getres'},
],
},
# ruby timer threads
ruby_timer_thread => {
# permute => {clone_flags => []},
rules => [
{syscall => 'clone', rules => [[0, '==', CLONE_VM|CLONE_FS|CLONE_FILES|CLONE_SIGHAND|CLONE_THREAD|CLONE_SYSVSEM|CLONE_SETTLS|CLONE_PARENT_SETTID|CLONE_CHILD_CLEARTID]]},
# Only allow a new signal stack context to be created, and only with a size of 8192 bytes. exactly what ruby does
# Have to allow it to be blind since i can't inspect inside the struct passed to it :( I'm not sure how i feel about this one
{syscall => 'sigaltstack', }, #=> rules [[1, '==', 0], [2, '==', 8192]]},
{syscall => 'pipe2', },
],
},
# perl module specific
perlmod_file_temp => {
rules => [
{syscall => 'chmod', rules => [[1, '==', 0600]]},
{syscall => 'unlink', },
],
},
# exec wrapper
exec_wrapper => {
# we have to generate these at runtime, we can't know ahead of time what they will be
rules => sub {
my $seccomp = shift;
my $strptr = sub {unpack "Q", pack("p", $_[0])};
my @rules;
my $exec_map = $seccomp->exec_map;
for my $version (keys %$exec_map) {
push @rules, {syscall => 'execve', rules => [[0, '==', $strptr->($exec_map->{$version}{bin})]]};
}
return @rules;
}, # sub returns a valid arrayref. given our $self as first arg.
},
# language master rules
lang_perl => {
rules => [
{syscall => 'dup'}
],
include => ['default'],
},
lang_javascript => {
rules => [{syscall => 'pipe2'},
{syscall => 'epoll_create1'},
{syscall => 'eventfd2'},
{syscall => 'epoll_ctl'},
{syscall => 'epoll_wait'},
{syscall => 'ioctl', rules => [[1, '==', 0x5451]]}, # ioctl(0, FIOCLEX)
{syscall => 'clone', rules => [[0, '==', CLONE_VM|CLONE_FS|CLONE_FILES|CLONE_SIGHAND|CLONE_THREAD|CLONE_SYSVSEM|CLONE_SETTLS|CLONE_PARENT_SETTID|CLONE_CHILD_CLEARTID]]},
{syscall => 'ioctl', rules => [[1, '==', 0x80045430]]}, #19348 ioctl(1, TIOCGPTN <unfinished ...>) = ?
{syscall => 'ioctl', rules => [[1, '==', 0x5421]]}, #ioctl(0, FIONBIO)
{syscall => 'ioctl', rules => [[0, '==', 1]]}, # just fucking let node do any ioctl to STDOUT
{syscall => 'ioctl', rules => [[0, '==', 2]]}, # just fucking let node do any ioctl to STDERR
],
include => ['default'],
},
lang_ruby => {
rules => [
# Thread IPC writes, these might not be fixed but I don't know how to detect them otherwise
{syscall => 'write', rules => [[0, '==', 5]]},
{syscall => 'write', rules => [[0, '==', 7]]},
],
include => ['default', 'ruby_timer_thread'],
},
);
sub rule_add {
my ($self, $name, @rules) = @_;
$self->seccomp->rule_add(SCMP_ACT_ALLOW, Linux::Seccomp::syscall_resolve_name($name), @rules);
}
sub _rec_get_rules {
my ($self, $profile) = @_;
return () if ($self->_used_sets->{$profile});
$self->_used_sets->{$profile} = 1;
croak "Rule set $profile not found" unless exists $rule_sets{$profile};
my @rules;
#print "getting profile $profile\n";
if (ref $rule_sets{$profile}{rules} eq 'ARRAY') {
push @rules, @{$rule_sets{$profile}{rules}};
} elsif (ref $rule_sets{$profile}{rules} eq 'CODE') {
my @sub_rules = $rule_sets{$profile}{rules}->($self);
push @rules, @sub_rules;
} elsif (!exists $rule_sets{$profile}{rules}) { # ignore it if missing
} else {
croak "Rule set $profile defines an invalid set of rules";
}
for my $perm (keys %{$rule_sets{$profile}{permute} // +{}}) {
push @{$self->_permutes->{$perm}}, @{$rule_sets{$profile}{permute}{$perm}};
}
for my $include (@{$rule_sets{$profile}{include}//[]}) {
push @rules, $self->_rec_get_rules($include);
}
return @rules;
}
sub build_seccomp {
my ($self) = @_;
croak "build_seccomp called more than once" if ($self->_finalized);
my %gathered_rules; # computed rules
for my $profile (@{$self->profiles}) {
my @rules = $self->_rec_get_rules($profile);
for my $rule (@rules) {
my $syscall = $rule->{syscall};
push @{$gathered_rules{$syscall}}, $rule;
}
}
# optimize phase
my %full_permute;
for my $permute (keys %{$self->_permutes}) {
my @modes = @{$self->_permutes->{$permute}} = sort {$a <=> $b} uniq @{$self->_permutes->{$permute}};
# Produce every bitpattern for this permutation
for my $b (1..(2**@modes) - 1) {
my $q = 1;
my $mode = 0;
#printf "%04b: ", $b;
do {
if ($q & $b) {
my $r = int(log($q)/log(2)+0.5); # get the thing
$mode |= $modes[$r];
#print "$r";
}
$q <<= 1;
} while ($q <= $b);
push @{$full_permute{$permute}}, $mode;
}
}
for my $k (keys %full_permute) {
@{$full_permute{$k}} = sort {$a <=> $b} uniq @{$full_permute{$k}}
}
my %comp_rules;
for my $syscall (keys %gathered_rules) {
my @rules = @{$gathered_rules{$syscall}};
for my $rule (@rules) {
my $syscall = $rule->{syscall};
if (exists ($rule->{permute_rules})) {
my @perm_on = ();
for my $prule (@{$rule->{permute_rules}}) {
if (ref $prule->[2]) {
push @perm_on, ${$prule->[2]};
}
if (ref $prule->[0]) {
croak "Permuation on argument number not supported using $syscall";
}
}
croak "Permutation on syscall rule without actual permutation specified" if (!@perm_on);
my %perm_hash = map {$_ => $full_permute{$_}} @perm_on;
my $iter = permute_named_iter(%perm_hash);
while (my $pvals = $iter->()) {
push @{$comp_rules{$syscall}},
[map {
my @r = @$_;
$r[2] = $pvals->{${$r[2]}};
\@r;
} @{$rule->{permute_rules}}];
}
} elsif (exists ($rule->{rules})) {
push @{$comp_rules{$syscall}}, $rule->{rules};
} else {
push @{$comp_rules{$syscall}}, [];
}
}
}
# TODO optimize for permissive rules
# e.g. write => OR write => [0, '==', 1] OR write => [0, '==', 2] becomes write =>
for my $syscall (keys %comp_rules) {
for my $rule (@{$comp_rules{$syscall}}) {
$self->rule_add($syscall, @$rule);
}
}
$self->_finalized(1);
}
sub apply_seccomp {
my $self = shift;
$self->seccomp->load;
}
sub engage {
my $self = shift;
$self->build_seccomp();
$self->apply_seccomp();
}
1;

21
lib/_Inline/config-i686-linux-5.014001
View file

@ -1,21 +0,0 @@
version : 0.48
languages : %
C : C
Foo : Foo
PYTHON : Python
Python : Python
foo : Foo
py : Python
python : Python
types : %
C : compiled
Foo : interpreted
Python : interpreted
modules : %
C : Inline::C
Foo : Inline::Foo
Python : Inline::Python
suffixes : %
C : so
Foo : foo
Python : pydat

522
lib/eval.pl
View file

@ -1,522 +0,0 @@
#!/usr/bin/env perl
#use lib '/home/ryan/perl5/lib/perl5/i686-linux';
#use lib '/home/ryan/perl5/lib/perl5';
use lib '/eval/elib';
use strict;
use Data::Dumper;
use Scalar::Util; #Required by Data::Dumper
use BSD::Resource;
use File::Glob;
use POSIX;
use List::Util qw/reduce/;
use Cwd;
use FindBin;
# Modules expected by many evals, load them now to avoid typing in channel
use Encode qw/encode decode/;
use IO::String;
use File::Slurper qw/read_text/;
use EvalServer::Seccomp;
use File::Temp;
# Easter eggs
do {package Tony::Robbins; sub import {die "Tony Robbins hungry: https://www.youtube.com/watch?v=GZXp7r_PP-w\n"}; $INC{"Tony/Robbins.pm"}=1};
do {
package Zathras;
our $AUTOLOAD;
use overload '""' => sub {
my $data = @{$_[0]{args}}? qq{$_[0]{data}(}.join(', ', map {"".$_} @{$_[0]{args}}).qq{)} : qq{$_[0]{data}};
my $old = $_[0]{old};
my ($pack, undef, undef, $meth) = caller(1);
if ($pack eq 'Zathras' && $meth ne 'Zahtras::dd_freeze') {
if (ref($old) ne 'Zathras') {
return "Zathras->$data";
} else {
return "${old}->$data";
}
} else {
$old = "" if (!ref($old));
return "$old->$data"
}
};
sub AUTOLOAD {$AUTOLOAD=~s/.*:://; bless {data=>$AUTOLOAD, args => \@_, old => shift}}
sub DESTROY {}; # keep it from recursing
sub dd_freeze {$_[0]=\($_[0]."")}
sub can {my ($self, $meth) = @_; return sub{$self->$meth(@_)}}
};
# save the old stdout, we're going to clobber it soon. STDOUT
my $oldout;
my $outbuffer = "";
open($oldout, ">&STDOUT") or die "Can't dup STDOUT: $!";
open(my $stdh, ">", \$outbuffer)
or die "Can't dup to buffer: $!";
select($stdh);
$|++;
#*STDOUT = $stdh;
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'},
'perl5.8' => {bin => '/perl5/perlbrew/perls/perl-5.8.9/bin/perl'},
'perl5.10' => {bin => '/perl5/perlbrew/perls/perl-5.10.1/bin/perl'},
'perl5.12' => {bin => '/perl5/perlbrew/perls/perl-5.12.5/bin/perl'},
'perl5.14' => {bin => '/perl5/perlbrew/perls/perl-5.14.4/bin/perl'},
'perl5.16' => {bin => '/perl5/perlbrew/perls/perl-5.16.3/bin/perl'},
'perl5.18' => {bin => '/perl5/perlbrew/perls/perl-5.18.4/bin/perl'},
'perl5.20' => {bin => '/perl5/perlbrew/perls/perl-5.20.3/bin/perl'},
'perl5.22' => {bin => '/perl5/perlbrew/perls/perl-5.22.3/bin/perl'},
'perl5.24' => {bin => '/perl5/perlbrew/perls/perl-5.24.0/bin/perl'},
'perl5.26' => {bin => '/perl5/perlbrew/perls/perl-5.26.0/bin/perl'},
'ruby' => {bin => '/usr/bin/ruby2.1'},
'node' => {bin => '/langs/node-custom/bin/node'},
);
no warnings;
# This sub is defined here so that it is defined before the 'use charnames'
# command. This causes extremely strange interactions that result in the
# deparse output being much longer than it should be.
sub deparse_perl_code {
my( $code ) = @_;
my $sub;
{
no strict; no warnings; no charnames;
$sub = eval "use $]; package botdeparse; sub{ $code\n }; use namespace::autoclean;";
}
my %methods = (map {$_ => botdeparse->can($_)} grep {botdeparse->can($_)} keys {%botdeparse::}->%*);
if( $@ ) { print STDOUT "Error: $@"; return }
my $dp = B::Deparse->new("-p", "-q", "-x7", "-d");
local *B::Deparse::declare_hints = sub { '' };
my @out;
my $clean_out = sub {
my $ret = shift;
$ret =~ s/\{//;
$ret =~ s/package (?:\w+(?:::)?)+;//;
$ret =~ s/no warnings;//;
$ret =~ s/\s+/ /g;
$ret =~ s/\s*\}\s*$//;
$ret =~ s/no feature ':all';//;
$ret =~ s/use feature [^;]+;//;
$ret =~ s/^\(\)//g;
$ret =~ s/^\s+|\s+$//g;
return $ret;
};
for my $sub (grep {!/^(can|DOES|isa)$/} keys %methods) {
my $ret = $clean_out->($dp->coderef2text($methods{$sub}));
push @out, "sub $sub {$ret} ";
}
my $ret = $dp->coderef2text($sub);
$ret = $clean_out->($ret);
push @out, $ret;
my $fullout = join(' ', @out);
use Perl::Tidy;
my $hide = do {package hiderr; sub print{}; bless {}};
my $tidy_out="";
eval {
my $foo = "$fullout";
Perl::Tidy::perltidy(source => \$foo, destination => \$tidy_out, errorfile => $hide, logfile => $hide);
};
$tidy_out = $fullout if ($@);
print STDOUT $tidy_out;
}
eval "use utf8; \$\343\201\257 = 42; 'ש' =~ /([\p{Bidi_Class:L}\p{Bidi_Class:R}])/"; # attempt to automatically load the utf8 libraries.
eval "use utf8; [ 'ß' =~ m/^\Qss\E\z/i ? 'True' : 'False' ];"; # Try to grab some more utf8 libs
eval "use utf8; [CORE::fc '€']";
use charnames qw(:full);
use PerlIO;
use PerlIO::scalar;
use Text::ParseWords;
eval {"\N{SPARKLE}"}; # force loading of some of the charnames stuff
# Required for perl_deparse
use B::Deparse;
## Javascript Libs
#BEGIN{ eval "use JavaScript::V8; require JSON::XS; JavaScript::V8::Context->new()->eval('1')"; }
#my $JSENV_CODE = do { local $/; open my $fh, "deps/env.js"; <$fh> };
#require 'bytes_heavy.pl';
use Tie::Hash::NamedCapture;
{#no warnings 'constant';
uc "\x{666}"; #Attempt to load unicode libraries.
lc "JONQUIÉRE";
}
binmode STDOUT, ":encoding(utf8)"; # Enable utf8 output.
#BEGIN{ eval "use PHP::Interpreter;"; }
# Evil Ruby stuff
#BEGIN{ eval "use Inline::Ruby qw/rb_eval/;"; }
#BEGIN { $SIG{SEGV} = sub { die "Segmentation Fault\n"; } } #Attempt to override the handler Ruby installs.
# # Evil K20 stuff
# BEGIN {
# local $@;
# eval "use Language::K20;";
# unless( $@ ) {
# Language::K20::k20eval( "2+2\n" ); # This eval loads the dynamic components before the chroot.
# # Note that k20eval always tries to output to stdout so we
# # must end the command with a \n to prevent this output.
# }
# }
#
# BEGIN { chdir "var/"; $0="../$0"; } # CHDIR to stop inline from creating stupid _Inline directories everywhere
# # Inline::Lua doesn't seem to provide an eval function. SIGH.
# BEGIN { eval 'use Inline Lua => "function lua_eval(str) return loadstring(str) end";'; }
# BEGIN { chdir ".."; $0=~s/^\.\.\/// } # Assume our earlier chdir succeded. Yay!
# # Evil python stuff
# BEGIN { eval "use Inline::Python qw/py_eval/;"; }
# # Evil J stuff
# BEGIN { eval "use Jplugin;"; }
use Carp::Heavy;
use Storable qw/nfreeze/; nfreeze([]); #Preload Nfreeze since it's loaded on demand
my $type = do { local $/=" ";
# have to do this with sysread in order to keep it from destroying STDIN for exec later.
my $q;
my $c;
while (sysread STDIN, $c, 1) {
$q .= $c;
last if $c eq $/;
}
chomp $q; $q
};
my $code = do {local $/; <STDIN>};
# Chomp code..
$code =~ s/\s*$//;
# redirect STDIN to /dev/null, to avoid warnings in convoluted cases.
# we have to leave this open for perl4, so only do this for other systems
open STDIN, '<', '/dev/null' or die "Can't open /dev/null: $!";
# Get the nobody uid before we chroot.
my $nobody_uid = 65534; #getpwnam("nobody");
die "Error, can't find a uid for 'nobody'. Replace with someone who exists" unless $nobody_uid;
# Set the CPU LIMIT.
# Do this before the chroot because some of the other
# setrlimit calls will prevent chroot from working
# however at the same time we need to preload an autload file
# that chroot will prevent, so do it here.
setrlimit(RLIMIT_CPU, 10,10);
# # Root Check
# if( $< != 0 )
# {
# die "Not root, can't chroot or take other precautions, dying\n";
# }
# The chroot section
chdir("/eval") or die $!;
# It's now safe for us to do this so that we can load modules and files provided by the user
push @INC, "/eval/lib";
if ($< == 0) {
# Here's where we actually drop our root privilege
$)="$nobody_uid $nobody_uid";
$(=$nobody_uid;
$<=$>=$nobody_uid;
POSIX::setgid($nobody_uid); #We just assume the uid is the same as the gid. Hot.
die "Failed to drop to nobody"
if $> != $nobody_uid
or $< != $nobody_uid;
}
my $kilo = 1024;
my $meg = $kilo * $kilo;
my $limit = 500 * $meg;
(
setrlimit(RLIMIT_VMEM, 1.5*$limit, 1.5*$limit)
and
setrlimit(RLIMIT_AS,1.5*$limit,1.5*$limit)
and
setrlimit(RLIMIT_DATA, $limit, $limit )
and
setrlimit(RLIMIT_STACK, 30 * $meg, 30*$meg )
and
setrlimit(RLIMIT_NPROC, 20,20) # CHANGED to 3 for Ruby. Might take it away.
and
setrlimit(RLIMIT_NOFILE, 30,30)
and
setrlimit(RLIMIT_OFILE, 30,30)
and
setrlimit(RLIMIT_OPEN_MAX,30,30)
and
setrlimit(RLIMIT_LOCKS, 5,5)
and
setrlimit(RLIMIT_MEMLOCK,100,100)
and
setrlimit(RLIMIT_CPU, 10, 10)
)
or die "Failed to set rlimit: $!";
%ENV=(TZ=>'Asia/Pyongyang');
#setrlimit(RLIMIT_MSGQUEUE,100,100);
die "Failed to drop root: $<" if $< == 0;
# close STDIN;
# Setup SECCOMP for us
my ($profile) = ($type =~ /^([a-z]+)/ig);
$profile = "perl" if $type eq 'deparse';
my $esc = EvalServer::Seccomp->new(profiles => ["lang_$profile"], exec_map => \%exec_map);
$esc->engage();
# Choose which type of evaluation to perform
# will probably be a dispatch table soon.
if( $type eq 'perl' or $type eq 'pl' ) {
perl_code($code);
}
elsif( $type eq 'deparse' ) {
deparse_perl_code($code);
}
elsif ($type =~ /perl([0-9.]+)/) { # run specific perl version
perl_version_code($1, $code);
}
elsif( $type eq 'javascript' ) {
javascript_code($code);
}
# elsif( $type eq 'php' ) {
# php_code($code);
# }
# elsif( $type eq 'k20' ) {
# k20_code($code);
# }
elsif( $type eq 'ruby' ) {
ruby_code($code);
}
# elsif( $type eq 'py' or $type eq 'python' ) {
# python_code($code);
# }
# elsif( $type eq 'lua' ) {
# lua_code($code);
# }
# elsif( $type eq 'j' ) {
# j_code($code);
# }
else {
die "Failed to find language $type";
}
# *STDOUT = $oldout;
close($stdh);
select(STDOUT);
print($outbuffer);
exit;
#-----------------------------------------------------------------------------
# Evaluate the actual code
#-----------------------------------------------------------------------------
sub perl_code {
my( $code ) = @_;
local $@;
local @INC = map {s|/home/ryan||r} @INC;
# local $$=24601;
close STDIN;
my $stdin = q{Biqsip bo'degh cha'par hu jev lev lir loghqam lotlhmoq nay' petaq qaryoq qeylis qul tuq qaq roswi' say'qu'moh tangqa' targh tiq 'ab. Chegh chevwi' tlhoy' da'vi' ghet ghuy'cha' jaghla' mevyap mu'qad ves naq pach qew qul tuq rach tagh tal tey'. Denibya' dugh ghaytanha' homwi' huchqed mara marwi' namtun qevas qay' tiqnagh lemdu' veqlargh 'em 'e'mam 'orghenya' rojmab. Baqa' chuy da'nal dilyum ghitlhwi' ghubdaq ghuy' hong boq chuydah hutvagh jorneb law' mil nadqa'ghach pujwi' qa'ri' ting toq yem yur yuvtlhe' 'e'mamnal 'iqnah qad 'orghenya' rojmab 'orghengan. Beb biqsip 'ugh denibya' ghal ghobchuq lodni'pu' ghochwi' huh jij lol nanwi' ngech pujwi' qawhaq qeng qo'qad qovpatlh ron ros say'qu'moh soq tugh tlhej tlhot verengan ha'dibah waqboch 'er'in 'irneh.
Cha'par denib qatlh denibya' ghiq jim megh'an nahjej naq nay' podmoh qanwi' qevas qin rilwi' ros sila' tey'lod tus vad vay' vem'eq yas cha'dich 'entepray' 'irnehnal 'urwi'. Baqa' be'joy' bi'res chegh chob'a' dah hos chohwi' piq pivlob qa'ri' qa'rol qewwi' qo'qad qi'tu' qu'vatlh say'qu'moh sa'hut sosbor'a' tlhach mu'mey vid'ir yas cha'dich yergho. Chegh denibya'ngan jajvam jij jim lev lo'lahbe'ghach ngun nguq pa' beb pivlob pujwi' qab qid sosbor'a' tlhepqe' tlhov va 'o'megh 'ud haqtaj. Bor cha'nas denibya' qatlh duran lung dir ghogh habli' homwi' hoq je' notqa' pegh per pitlh qarghan qawhaq qen red tey'lod valqis vid'ir wab yer yintagh 'edjen. Bi'rel tlharghduj cheb ghal lorlod ne' ngij pipyus pivlob qutluch red sila' tuqnigh.
Chob'a' choq chuq'a' dol jev jij lev marwi' mojaq ngij ngugh pujmoh puqni'be' qaywi' qirq qi'yah qum taq tey'be' tlhup valqis 'edsehcha. Chadvay' cha'par ghal je' lir lolchu' lursa' maqmigh ngun per qen qevas quv bey' soq targh tiq tlhot veqlargh wen. Baqa' chuq'a' jev juch logh lol lor mistaq nahjej nuh bey' nguq pujmoh qovpatlh ron tahqeq tuy' vithay' yo'seh yahniv yuqjijdivi' 'em 'orghenya'ngan. Beb cheb chob da'nal da'vi' ghoti' ghuy'cha' hoq loghqam ngav po ha'dibah qen qo'qad qid ril siq tuy' tlhoy' sas vinpu' wab yuqjijqa' 'em 'o'megh. Bachha' biq boqha''egh cheb dor duran lung dir ghang hos chohwi' je' luh mu'qad ves nav habli' qab qan rach siqwi' tennus tepqengwi' tuqnigh tlhoy' sas va vin yeq yuqjijdivi' 'ab 'edjen 'iqnah 'ud'a' 'urwi'.
Baqa' bi'res boq'egh da'vi' dol dor ghet ghetwi' ghogh habli' hos chohwi' nga'chuq petaq pirmus puqni' qutluch qaj qid qi'tu' qongdaqdaq siq tahqeq ti'ang toq tlhup yatqap yer 'ur. Biqsip 'ugh chang'eng choq choq hutvagh jajlo' qa' jer nanwi' nav habli' pirmus qab qa'meh vittlhegh qa'ri' sen siv vem'eq yer yo'seh yahniv yuqjijdivi' 'arlogh 'e'mamnal 'och. Chang'eng chas cha'dich choq lursa' mil natlh nay' puqni'be' qeng qid qulpa' ret sa'hut viq wen yiq yuqjijdivi' yu'egh 'edsehcha 'entepray' 'er'in 'ev 'irneh 'iw 'ip ghomey 'orwi' 'ud haqtaj 'usgheb. Chadvay' gheb lol lorbe' lursa' pivlob qep'it sen senwi' rilwi' je tajvaj wogh. Chevwi' tlhoy' huh lol lorbe' neslo' ne' pipyus qaq qi'yah tal 'ev.
Biqsip biqsip 'ugh chan ghitlh lursa' nuh bey' ngun petaq qeng soj tlhej waqboch 'ab 'entepray' 'e'mam. Bo denibya' ghetwi' ghochwi' ghuy' ghuy'cha' holqed huh jaj je' matlh pegh petaq qawhaq qa'meh qay' tagh tey' wogh yer yu'egh 'orghen 'urwi'. Boq'egh choq dav jim laq nga'chuq ngoqde' ngusdi' qan qu'vatlh sen tijwi'ghom ti'ang wogh 'orghenya'ngan. Biq cha'nas chegh chob dilyum ghetwi' juch me'nal motlh po ha'dibah puqni'lod qab qarghan qaywi' qaj rutlh say'qu'moh todsah tus yas wa'dich 'aqtu' 'edjen 'e'nal 'orwi'. Bor chob jaghla' je' jorneb mellota' meqba' nguq rachwi' ron tey' tiqnagh lemdu' vay' 'usgheb. Bis'ub cheb chob'a' dugh homwi' lotlhmoq mu'qad ves nahjej nanwi' naw' nitebha' ngoqde' ngusdi' pach pujmoh puqni'lod qan qay' rech senwi' tangqa' tepqengwi' tlhej tlhot valqis waqboch 'aqtu' 'e'mam 'iqnah 'orghen rojmab.};
open(STDIN, "<", \$stdin);
local $_;
my $ret;
my @os = qw/aix bsdos darwin dynixptx freebsd haiku linux hpux irix next openbsd dec_osf svr4 sco_sv unicos unicosmk solaris sunos MSWin32 MSWin16 MSWin63 dos os2 cygwin vos os390 os400 posix-bc riscos amigaos xenix/;
{
# local $^O = $os[rand()*@os];
no strict; no warnings; package main;
# my $oldout;
do {
local $/="\n";
local $\;
local $,;
$code = "use $]; use feature qw/postderef refaliasing lexical_subs postderef_qq signatures/; use experimental 'declared_refs';\n#line 1 \"(IRC)\"\n$code";
$ret = eval $code;
}
}
select STDOUT;
local $Data::Dumper::Terse = 1;
local $Data::Dumper::Quotekeys = 0;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Useqq = 1;
local $Data::Dumper::Freezer = "dd_freeze";
my $out = ref($ret) ? Dumper( $ret ) : "" . $ret;
print $out unless $outbuffer;
if( $@ ) { print "ERROR: $@" }
}
sub perl_version_code {
my ($version, $code) = @_;
my $qcode = quotemeta $code;
my $wrapper = 'use Data::Dumper;
local $Data::Dumper::Terse = 1;
local $Data::Dumper::Quotekeys = 0;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Useqq = 1;
my $val = eval "#line 1 \"(IRC)\"\n'.$qcode.'";
if ($@) {
print $@;
} else {
$val = ref($val) ? Dumper ($val) : "".$val;
print " ",$val;
}
';
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
}
}
sub ruby_code {
my ($code) = @_;
exec($exec_map{'ruby'}{bin}, '-e', $code);
}
sub javascript_code {
my ($code) = @_;
my $ft = File::Temp->new(SUFFIX=>'.js');
print $ft $code;
$ft->flush();
STDOUT->flush();
exec($exec_map{'node'}{bin}, "--v8-pool-size=1", "$ft");
}
# sub javascript_code {
# my( $code ) = @_;
# local $@;
#
# my $js = JavaScript::V8::Context->new;
#
# # Set up the Environment for ENVJS
# $js->bind("print", sub { print @_ } );
# $js->bind("write", sub { print @_ } );
#
# # for( qw/log debug info warn error/ ) {
# # $js->eval("Envjs.$_=function(x){}");
# # }
#
# # $js->eval($JSENV_CODE) or die $@;
#
# $code =~ s/(["\\])/\\$1/g;
# my $rcode = qq{write(eval("$code"))};
#
#
#
# my $out = eval { $js->eval($rcode) };
#
# if( $@ ) { print "ERROR: $@"; }
# else { print encode_json $out }
# }
#
# sub ruby_code {
# my( $code ) = @_;
# local $@;
#
# print rb_eval( $code );
# }
#
# sub php_code {
# my( $code ) = @_;
# local $@;
#
# #warn "PHP - [$code]";
#
# my $php = PHP::Interpreter->new;
#
# $php->set_output_handler(\ my $output );
#
# $php->eval("$code;");
#
# print $php->get_output;
#
# #warn "ENDING";
#
# if( $@ ) { print "ERROR: $@"; }
# }
#
# sub k20_code {
# my( $code ) = @_;
#
# $code =~ s/\r?\n//g;
#
#
# Language::K20::k20eval( '."\\\\r ' . int(rand(2**31)) . '";' . "\n"); # set random seed
#
# Language::K20::k20eval( $code );
# }
#
# sub python_code {
# my( $code ) = @_;
#
# py_eval( $code, 2 );
# }
#
# sub lua_code {
# my( $code ) = @_;
#
# #print lua_eval( $code )->();
#
# my $ret = lua_eval( $code );
#
# print ref $ret ? $ret->() : $ret;
# }
#
# sub j_code {
# my( $code ) = @_;
#
# Jplugin::jplugin( $code );
# }

146
plugins/eval.pm.old
View file

@ -1,146 +0,0 @@
# eval plugin for buubot3
package Bot::BB3::Plugin::Eval;
package Bot::BB3::Plugin::Eval;
use POE::Filter::Reference;
use IO::Socket::INET;
use Data::Dumper;
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} = 'eval';
$self->{opts} = {
command => 1,
};
my @perl_aliases = map {("eval$_", "weval$_", "seval$_", "wseval$_", "sweval$_")} @versions;
$self->{aliases} = [ qw/jseval jeval phpeval pleval perleval deparse k20eval rbeval pyeval luaeval/, @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+?)?eval(.*)?/$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]+)?eval/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_eval($type, $code);
} else {
my @outs;
# TODO use channel config for this
if ($said->{channel} eq '#perlbot' || $said->{channel} eq '*irc_msg') {
for my $version (@versions) {
my $torun = $version eq '' ? 'blead' : sprintf "%5s", $version;
next if $version eq 'all';
next if $version eq '4';
next if $version eq '5.5' && $command =~ /w/; # no warnings in 5.5
push @outs, "[[$torun]]", $self->do_eval('perl'.$version, $code);
}
$resultstr = join "\n", @outs;
} 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_eval {
my ($self, $type, $code) = @_;
my $filter = POE::Filter::Reference->new();
my $socket = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => '14400' )
or die "error: cannot connect to eval server";
my $refs = $filter->put( [ { code => "$type $code" } ] );
print $socket $refs->[0];
local $/;
my $output = <$socket>;
$socket->close;
my $result = $filter->get( [ $output ] );
my $resultstr = $result->[0]->[0];
$resultstr =~ s/\x0a?\x0d//g; # Prevent sending messages to the IRC server..
$resultstr = decode("utf8", $resultstr);
$resultstr =~ s/\0//g;
chomp $resultstr;
if (lc $resultstr eq "hello world" || lc $resultstr eq "hello, world!" ) {
$resultstr .= " I'm back!"
}
return $resultstr;
}
"Bot::BB3::Plugin::Eval";
__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;