Perlbot/perlbuut
1
0
Fork 0
mirror of https://github.com/perlbot/perlbuut synced 2025-06-07 00:45:43 -04:00
Code Issues Releases Wiki Activity
perlbuut/plugins/supereval.pm
Ryan Voots f92261fc40 whee
2022-06-22 19:37:55 -04:00

414 lines
14 KiB
Perl
Raw Blame History

# 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 DateTime::Event::Holiday::US;
use DateTime::Event::Cron;
use LWP::UserAgent;
use JSON::MaybeXS;
use Regexp::Optimizer;
use Regexp::Assemble;
use strict;
use utf8;
use DBI;
no warnings 'void';
sub make_pastebin {
my ($who, $input) = @_;
my $ua = LWP::UserAgent->new();
my $res = $ua->post("https://perl.bot/api/v1/paste", {
paste => $input,
description => 'Eval output for '.$who,
username => $who,
language => 'text'
});
if ($res->is_success()) {
my $content = $res->decoded_content;
my $data = decode_json $content;
return "Output at: ".$data->{url};
} else {
return "Couldn't pastebin output";
}
}
sub make_pastebin_all {
my ($who, $input, $type) = @_;
my $ua = LWP::UserAgent->new();
my $res = $ua->post("https://perl.bot/api/v1/paste", {
paste => $input,
description => 'Evalall output for '.$who,
username => $who,
language => "eval${type}all",
});
if ($res->is_success()) {
my $content = $res->decoded_content;
my $data = decode_json $content;
return $data->{url};
} else {
return "Couldn't pastebin output";
}
}
my @versions = ('', 't', qw(1 2 3 4 5.0 5.1 5.2 5.3 5.4 5.5 tall all rall yall), map {$_, $_."t"} sort qw/5.6 5.8 5.8.4 5.8.8 5.10 5.10.0 5.12 5.14 5.16 5.18 5.20 5.22 5.24 5.26 5.28 5.32 5.32.1 5.32.0 5.34.1 5.34.0 5.34 5.30 5.30.3 5.30.2 5.30.1 5.30.0 5.28.2 5.28.1 5.28.0 5.26.3 5.26.2 5.26.1 5.26.0 5.24.4 5.24.3 5.24.2 5.24.1 5.24.0 5.22.4 5.22.3 5.22.2 5.22.1 5.22.0 5.20.3 5.20.2 5.20.1 5.20.0 5.18.4 5.18.3 5.18.2 5.18.1 5.18.0 5.16.3 5.16.2 5.16.1 5.16.0 5.14.4 5.14.3 5.14.2 5.14.1 5.14.0 5.12.5 5.12.4 5.12.3 5.12.2 5.12.1 5.12.0 5.10.1 5.10.0 5.8.9 5.8.8 5.8.7 5.8.6 5.8.5 5.8.4 5.8.3 5.8.2 5.8.1 5.8.0 5.6.2 5.6.1 5.6.0 5.34 5.36 5.36.0/);
sub new {
my( $class ) = @_;
my $self = bless {}, $class;
$self->{name} = 'eval';
$self->{opts} = {
command => 1,
};
my $version_ra = Regexp::Assemble->new();
$version_ra->add(map {"\Q$_"} @versions);
my $version_re = $version_ra->re;
my $strict_re = qr/(?:(?:ws?|sw?)|m)?/;
my $suffix_re = qr/(nl(pb)?|pb(nl)?)?/;
my $perlcommand_ra = Regexp::Assemble->new();
$perlcommand_ra->add(qw/eval pleval perleval cpeval bleval deparse deparse2/);
my $perlcommand_re = $perlcommand_ra->re;
my $othercommand_ra = Regexp::Assemble->new();
$othercommand_ra->add(qw/jseval rkeval coboleval cbeval basheval r concise eval/);
my $othercommand_re = $othercommand_ra->re;
my $newversion_re = Regexp::Optimizer->new->optimize($version_re);
my $complete_re = qr/^(?:${strict_re}${perlcommand_re}${newversion_re}|${othercommand_re})${suffix_re}/;
$self->{alias_re} = $complete_re;
$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};
my ($postflags) = ($type =~ /((?:nl|pb)+)$/i);
my $nlflag = ($postflags =~ /nl/i);
my $pbflag = ($postflags =~ /pb/i);
$type =~ s/\Q$postflags\E$//;
$type =~ s/^\s*(\w+?)?eval(.*?)?/$1$2/i;
use JSON::MaybeXS qw/encode_json/;
warn "Initial type: $type $command ".encode_json($said)."\n";
my %translations = (
concise => 'concise',
js => 'javascript',
perl => 'perl',
pl => 'perl',
php => 'php',
deparse2 => 'deparse2',
swdeparse2 => 'deparse2',
wsdeparse2 => 'deparse2',
wdeparse2 => 'deparse2',
sdeparse2 => 'deparse2',
deparse2 => 'deparse2',
swdeparse => 'deparse',
wsdeparse => 'deparse',
wdeparse => 'deparse',
sdeparse => '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',
'm' => 'perl',
'cp' => 'cperl',
'swcp' => 'cperl',
'wscp' => 'cperl',
'wcp' => 'cperl',
'scp' => 'cperl',
'rk' => 'perl6',
'r' => 'perl6',
'bl' => 'perl',
'cb' => 'cobol',
'cobol' => 'cobol',
'bash' => 'bash',
map {($_=>"perl$_", "w$_"=>"perl$_", "s$_" => "perl$_", "ws$_"=>"perl$_", "sw$_"=>"perl$_", "m$_"=>"perl$_")} @versions
);
my $orig_type = $type;
$type = $translations{$type};
# $type = "perl6" if ($orig_type =~ /^[ws]*$/i && $said->{channel} eq '#perl6');
# We're in #perl6 and we weren't nested or addressed
if (($said->{channel} eq "#perl6" || $said->{channel} eq "#raku") && (!$said->{addressed} && !$said->{nested}) && $orig_type =~ /^[ws]*$/) {
return ("handled", "");
}
# we were addressed, but not nested, in #perl6. Switch to perl6, otherwise use perl5
if (($said->{channel} eq "#perl6" || $said->{channel} eq "#raku") && $said->{addressed} && !$said->{nested} && $orig_type =~ /^[ws]*$/) {
$type = "perl6"
}
# we were addressed, but not nested, in #perl6. Switch to perl6, otherwise use perl5
if ($said->{channel} eq "#pdl" && !$said->{nested} && $orig_type =~ /^[ws]*$/) {
$type = "perl5.34"
}
if ($command eq 'r' && (!$said->{addressed} && !$said->{nested} && ($said->{channel} ne "#perl6" && $said->{channel} eq '#raku'))) {
return ("handled", "");
}
warn "CODE CHECK $code\n";
if ($code !~ /\S/) {
return ("handled", "");
}
if ($type eq 'concise' || $type eq 'deparse2') {
$pbflag = !$pbflag; # $pbflag;
}
if( not $type ) { $type = 'perl'; }
warn "Found $type: $code";
$code = eval {Encode::decode("utf8", $code)} // $code;
if ($command =~ /^([wsm]+)?(?:eval|deparse)(?:5\.(\d+))?t?(all)?/i) {
my $c=$1;
my $v=$2;
my $all = $3;
$code = "use warnings; no warnings 'experimental';".$code if ($c =~ /w/ && ($v>=18 || !defined $v || $all));
$code = "use warnings;".$code if ($c =~ /w/ && (($v>=6 && $v < 18) || !defined $v || $all));
$code = '$^W=1;'.$code if ($c =~ /w/ && (defined $v && $v < 6 && !$all));
$code = "use strict; ".$code if ($c =~ /s/);
$code = "use ojo; ".$code if ($c =~ /m/);
}
$code = "use utf8; ". $code if ($type =~ /^perl(5.(8|10|12|14|16|18|20|22|24|26|28|30))?$/);
$code =~ s/␤/\n/g;
my $resultstr='';
if ($type =~ /perlall/) {
$resultstr = make_pastebin_all($said->{channel}, $code);
} elsif ($type =~ /perltall/) {
$resultstr = make_pastebin_all($said->{channel}, $code, "t");
} elsif ($type =~ /perlrall/) {
$resultstr = make_pastebin_all($said->{channel}, $code, "r");
} elsif ($type =~ /perlyall/) {
$resultstr = make_pastebin_all($said->{channel}, $code, "y");
} elsif ($pbflag) {
my $output = $self->do_singleeval($type, $code);
$resultstr = make_pastebin($said->{channel}, $code. "\n\n". $output);
} else {
$resultstr = $self->do_singleeval($type, $code);
}
# clean up the output of @INC and friends.
$resultstr =~ s|(/home/perlbot)/perl5/custom/blead(-[^/]*)?|\$BLEAD|g;
$resultstr =~ s|(/home/perlbot)?/perl5/custom|\$PERLS|g;
if ($type eq 'perl6' || $type eq 'bash') {
use IRC::FromANSI::Tiny;
$resultstr = IRC::FromANSI::Tiny::convert($resultstr);
}
my $usenl = ($nlflag && !($type eq 'perl6' || $type eq 'bash' || $type eq 'concise' || $type eq 'deparse2')) ||
(!$nlflag && ($type eq 'perl6' || $type eq 'bash' || $type eq 'concise' || $type eq 'deparse2'));
if ($usenl) {
$resultstr =~ s/\n/\x{2424}/g;
}
$resultstr =~ s/^(\x00)+//g;
if (!$said->{captured} && length($resultstr) == 0) {
$resultstr = "No output.";
} elsif (!$said->{captured} && $resultstr !~ /\S/) {
$resultstr = "\x{FEFF}$resultstr";
}
if ($type eq 'perl') {
$self->{dbh}->do("INSERT INTO evals (input, output) VALUES (?, ?)", {}, $code, $resultstr);
}
my $holiday=get_holiday();
my %special = (
'Halloween' => {prob => 0.75, chars => ["\x{1F383}", "\x{1F47B}", "\x{1F480}", "\x{1F577}"]},
'Christmas Eve' => {prob => 0.10, chars => ["\x{1F384}", "\x{1F385}"]},
'Christmas' => {prob => 0.50, chars => ["\x{1F384}", "\x{1F385}"]},
"Alaska Day" => {prob => 0.00, chars => []},
"April Fools Day" => {prob => 0.00, chars => []},
"Black Friday" => {prob => 0.10, chars => ["\x{1F4B8}", "\x{1F6D2}", "\x{1F6CD}"]},
"Cesar Chavez Day" => {prob => 0.00, chars => []},
"Citizenship Day" => {prob => 0.05, chars => ["\x{1F1FA}\x{1F1F8}"]},
"Columbus Day" => {prob => 0.00, chars => []},
"Confederate Memorial Day" => {prob => 0.00, chars => []},
"Earth Day" => {prob => 0.50, chars => ["\x{1F30E}", "\x{1F30D}", "\x{1F30F}"]},
"Election Day" => {prob => 1.00, chars => ["\x{1F5F3}\x{FE0F}"]},
"Emancipation Day" => {prob => 0.00, chars => []},
"Fathers Day" => {prob => 0.00, chars => []},
"Flag Day" => {prob => 0.00, chars => []}, # TODO all country flags
"Fourth of July" => {prob => 1.00, chars => ["\x{1F1FA}\x{1F1F8}"]},
"Groundhog Day" => {prob => 0.00, chars => []},
"Independence Day" => {prob => 1.00, chars => ["\x{1F1FA}\x{1F1F8}"]},
"Jefferson Davis Day" => {prob => 0.00, chars => []},
"Labor Day" => {prob => 0.00, chars => []},
"Leif Erikson Day" => {prob => 0.00, chars => []},
"Lincolns Birthday" => {prob => 0.00, chars => []},
"Martin Luther King Day" => {prob => 0.00, chars => []},
"Martin Luther King Jr Birthday" => {prob => 0.00, chars => []},
"Memorial Day" => {prob => 0.00, chars => []},
"Mothers Day" => {prob => 0.00, chars => []},
"New Years Day" => {prob => 0.00, chars => []},
"New Years Eve" => {prob => 0.00, chars => []},
"Patriot Day" => {prob => 0.00, chars => []},
"Pearl Harbor Remembrance Day" => {prob => 0.00, chars => []},
"Presidents Day" => {prob => 0.00, chars => []},
"Primary Election Day" => {prob => 0.00, chars => []},
"Sewards Day" => {prob => 0.00, chars => []},
"St. Patricks Day" => {prob => 0.00, chars => []},
"Super Bowl Sunday" => {prob => 0.00, chars => []},
"Susan B. Anthony Day" => {prob => 0.00, chars => []},
"Thanksgiving" => {prob => 1.00, chars => ["\x{1F983}"]},
"Thanksgiving Day" => {prob => 1.00, chars => ["\x{1F983}"]},
"Valentines Day" => {prob => 0.25, chars => ["\x{1F491}"]},
"Veterans Day" => {prob => 0.00, chars => []},
"Washingtons Birthday" => {prob => 0.00, chars => []},
"Washingtons Birthday (observed)" => {prob => 0.00, chars => []},
"Winter Solstice" => {prob => 0.00, chars => []},
"Womens Equality Day" => {prob => 0.00, chars => []},
"Guy Fawkes Day" => {prob => 0.33, chars => ["\N{BOMB}", "\N{CROWN}"]},
);
if ($special{$holiday}) {
if (rand() < $special{$holiday}{prob}) {
my $char = $special{$holiday}{chars}[rand()*@{$special{$holiday}{chars}}];
unless ($said->{nested}) { # if we're called in compose don't do this
$resultstr .= " ".$char; # disabled until i make it magic-erer
}
}
}
return( 'handled', $resultstr);
}
sub get_holiday {
my $dt = DateTime->now(time_zone=>"PST8PDT")->truncate(to => 'day');
my @known = DateTime::Event::Holiday::US::known();
my $holidays = DateTime::Event::Holiday::US::holidays(@known);
my $mass_set = DateTime::Event::Holiday::US::holidays_as_set(@known); # mass set of all of them
if ($mass_set->contains($dt)) {
# We're a holiday. do shit
for my $key (@known) {
if ($holidays->{$key}->contains($dt)) {
return $key;
}
}
}
my sub newcron {
return DateTime::Event::Cron->new($_[0]);
}
my %crons = (
"Guy Fawkes Day" => [newcron("* * 5 11 *")],
);
for my $key (keys %crons) {
my $crons = $crons{$key};
for my $test (@$crons) {
if ($test->match()) {
return $key;
}
}
}
return "";
}
sub do_singleeval {
my ($self, $type, $code) = @_;
my $socket = IO::Socket::INET->new( PeerAddr => '192.168.32.1', PeerPort => '14401' )
or die "error: cannot connect to eval server";
my $eval_obj = {language => $type, files => [{filename => '__code', contents => $code, encoding => "utf8"}], prio => {pr_realtime=>{}}, sequence => 1, encoding => "utf8"};
$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);
if (ref($message) =~ /Warning$/) {
return $message->message;
} else {
return $message->get_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 == 1;
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;
}
sub make_help {
my $self = shift;
my $help = q{The eval plugin. Syntax, «eval: code». Prefixes: w=>warnings, s=>strict, m=>use Ojo. Suffixes: t=>threaded, pb=>pastebin it, nl=>turn \n to ␤. languages: }. join(', ', map {s/eval//r || 'bleed'} grep {!/^[wsm]|(t|nl|pb)$/} @{$self->{aliases}});
return $help
}
"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;
Reference in a new issue View git blame Copy permalink