view release on metacpan or  search on metacpan

lib/App/EvalServerAdvanced/Sandbox/Plugin/Perlbot.pm  view on Meta::CPAN

package App::EvalServerAdvanced::Sandbox::Plugin::Perlbot;

use strict;
use warnings;
use Moo::Role;

use Data::Dumper;
use B::Deparse;
use Perl::Tidy;
use PerlIO;
do {my $temp; open(my $fh, ">", \$temp); close($fh)};

sub deparse_perl_code {
    my( $class, $lang, $code ) = @_;
    my $sub;
    {
        no strict; no warnings; no charnames;
        $sub = eval "use $]; package botdeparse; sub{ $code\n }; use namespace::autoclean;";
    }
    if( $@ ) { die $@ }

    my %methods = (map {$_ => botdeparse->can($_)} grep {botdeparse->can($_)} keys {%botdeparse::}->%*);

    my $dp = B::Deparse->new("-p", "-q", "-x7", "-d");
    no warnings;
    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);

    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;
}

#-----------------------------------------------------------------------------
# Evaluate the actual code
#-----------------------------------------------------------------------------
sub run_perl {
    my( $class, $lang, $code ) = @_;

    my $outbuffer = "";
    open(my $stdh, ">", \$outbuffer);
    select($stdh);
    $|++;

    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...
    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'r...
    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...
    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...
    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'. ...
    open(STDIN, "<", \$stdin);

    local $_;

    my ($ret, $err);
    {
        no strict; no warnings; package main;
        do {
            local $/="\n";
            local $\;
            local $,;
            if ($] >= 5.026) {
                $code = "use $]; use feature qw/postderef refaliasing lexical_subs postderef_qq signatures/; use experimental 'declared_refs';\n#line 1 \"(IRC)\"\n$code";
            } else {
                $code = "use $]; use feature qw/postderef refaliasing lexical_subs postderef_qq signatures/;\n#line 1 \"(IRC)\"\n$code";
            }
            $ret = eval $code;
            $err = $@;
        }
    }
    select STDOUT;



    if (length($outbuffer) > 0) {
        print $outbuffer;
    } else {
        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";

        no warnings;
        my $out = ref($ret) ? Dumper( $ret ) : "" . $ret;
    
      print $out;
    }

    if( $err ) { print "ERROR: $err" }
}

sub perl_wrap {
    my ($class, $lang, $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;
    }
    ';
    return $wrapper;
}