view release on metacpan or  search on metacpan

lib/Webqq/Client/Plugin/Perlcode.pm  view on Meta::CPAN

use POSIX qw(strftime);

if($^O !~ /linux/){
    console_stderr "Webqq::Client::App::Perlcode只能运行在linux系统上\n";
    exit;
}
chomp(my $PERL_COMMAND = `/bin/env which perl`);
mkpath "/tmp/webqq/log/",{owner=>"nobody",group=>"nobody",mode=>0555};
mkpath "/tmp/webqq/bin/",{owner=>"nobody",group=>"nobody",mode=>0555};
mkpath "/tmp/webqq/src/",{owner=>"nobody",group=>"nobody",mode=>0555};
chown +(getpwnam("nobody"))[2,3],"/tmp/webqq/";
chown +(getpwnam("nobody"))[2,3],"/tmp/webqq/log";
chown +(getpwnam("nobody"))[2,3],"/tmp/webqq/bin";
chown +(getpwnam("nobody"))[2,3],"/tmp/webqq/src";

open LOG,">>/tmp/webqq/log/exec.log" or die $!;
sub call{
    my ($client,$msg,$perl_path) = @_;
    return 1 if time - $msg->{msg_time} > 10;
    $PERL_COMMAND = $perl_path if defined $perl_path;
    if($msg->{content} =~/(?:>>>)(.*?)(?:__END__|$)/s or $msg->{content} =~/perl\s+-e\s+'([^']+)'/s){
        $msg->{allow_plugin} = 0;
        my $doc = '';
        my $code = $1;