mirror of
https://github.com/perlbot/perlbuut
synced 2025-06-07 10:35:41 -04:00
Update plugins. Karma parsing for module names, and add a few more top/bottom options. Also update some eval stuff and make perldoc handle nested commands better
This commit is contained in:
Ryan Voots
parent
4b7f595637
commit
1e5af45c57
6 changed files with 261 additions and 52 deletions
|
|
@ -54,7 +54,7 @@ sub handle {
|
|||
my( $self, $said, $pm ) = @_;
|
||||
my $body = $said->{body};
|
||||
|
||||
if( $body =~ /\(([^\)]+)\)(\+\+|--)/ or $body =~ /([\w\[\]\\`_^{|}-]+)(\+\+|--)/ ) {
|
||||
if( $body =~ /\(([^\)]+)\)(\+\+|--)/ or $body =~ /([\w\[\]\\`_^{|}\-:]+)(\+\+|--)/ ) {
|
||||
my( $subject, $op ) = ($1,$2);
|
||||
if( $op eq '--' ) { $op = -1 } elsif( $op eq '++' ) { $op = 1 }
|
||||
my $lirc = l_irc($subject) || lc $subject;
|
||||
|
|
|
|||
|
|
@ -9,10 +9,6 @@ sub {
|
|||
my $body = $said->{body};
|
||||
s/^\s+//, s/\s+$// for $body;
|
||||
|
||||
warn "KARMATOPPLUGIN";
|
||||
use Data::Dumper;
|
||||
warn Dumper $said;
|
||||
|
||||
my $dbh = DBI->connect(
|
||||
"dbi:SQLite:dbname=var/karma.db",
|
||||
"",
|
||||
|
|
@ -20,8 +16,59 @@ sub {
|
|||
{ RaiseError => 1, PrintError => 0 }
|
||||
);
|
||||
|
||||
if ($said->{body} =~ /\s*(-?\d+)(\s*karma)?/)
|
||||
{
|
||||
if ($body =~ /me\s*(-?\d+)/) {
|
||||
my $count = $1;
|
||||
my $who = l_irc $said->{name};
|
||||
my $sth;
|
||||
if ($count > 0) {
|
||||
$sth = $dbh->prepare("SELECT author, kars FROM (SELECT author, sum(operation) as kars FROM karma WHERE author <> 'perlbot' AND subject = ? GROUP BY author) AS karmsub ORDER BY kars DESC LIMIT ?");
|
||||
} else {
|
||||
$sth = $dbh->prepare("SELECT author, kars FROM (SELECT author, sum(operation) as kars FROM karma WHERE author <> 'perlbot' AND subject = ? GROUP BY author) AS karmsub ORDER BY kars ASC LIMIT ?");
|
||||
}
|
||||
|
||||
$sth->execute($who, abs $count);
|
||||
|
||||
while (my $row = $sth->fetchrow_arrayref()) {
|
||||
my $subject=$row->[0];
|
||||
my $karma = $row->[1];
|
||||
|
||||
print "$subject: $karma ";
|
||||
}
|
||||
} elsif ($body =~ /abs\s*(-?\d+)/) {
|
||||
my $count = $1;
|
||||
my $sth;
|
||||
if ($count > 0) {
|
||||
$sth = $dbh->prepare("SELECT author, kars FROM (SELECT author, sum(abs(operation)) as kars FROM karma WHERE author <> 'perlbot' GROUP BY author) AS karmsub ORDER BY kars DESC LIMIT ?");
|
||||
} else {
|
||||
$sth = $dbh->prepare("SELECT author, kars FROM (SELECT author, sum(abs(operation)) as kars FROM karma WHERE author <> 'perlbot' GROUP BY author) AS karmsub ORDER BY kars ASC LIMIT ?");
|
||||
}
|
||||
|
||||
$sth->execute(abs $count);
|
||||
|
||||
while (my $row = $sth->fetchrow_arrayref()) {
|
||||
my $subject=$row->[0];
|
||||
my $karma = $row->[1];
|
||||
|
||||
print "$subject: $karma ";
|
||||
}
|
||||
} elsif ($body =~ /most\s*(-?\d+)(\s*karma)?/){
|
||||
my $count = $1;
|
||||
my $sth;
|
||||
if ($count > 0) {
|
||||
$sth = $dbh->prepare("SELECT author, kars FROM (SELECT author, sum(operation) as kars FROM karma WHERE operation > 0 AND author <> 'perlbot' GROUP BY author) AS karmsub ORDER BY kars DESC LIMIT ?");
|
||||
} else {
|
||||
$sth = $dbh->prepare("SELECT author, kars FROM (SELECT author, sum(operation) as kars FROM karma WHERE operation < 0 AND author <> 'perlbot' GROUP BY author) AS karmsub ORDER BY kars ASC LIMIT ?");
|
||||
}
|
||||
|
||||
$sth->execute(abs $count);
|
||||
|
||||
while (my $row = $sth->fetchrow_arrayref()) {
|
||||
my $subject=$row->[0];
|
||||
my $karma = $row->[1];
|
||||
|
||||
print "$subject: $karma ";
|
||||
}
|
||||
} elsif ($said->{body} =~ /\s*(-?\d+)(\s*karma)?/) {
|
||||
my $count = $1;
|
||||
my $sth;
|
||||
if ($count > 0)
|
||||
|
|
@ -42,9 +89,7 @@ sub {
|
|||
|
||||
print "$subject: $karma ";
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
} else {
|
||||
print "usage is: top/bottom \\d+ karma";
|
||||
}
|
||||
};
|
||||
|
|
|
|||
|
|
@ -1,21 +1,67 @@
|
|||
package Bot::BB3::Plugin::Perldoc;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use URI::Encode qw(uri_encode);
|
||||
|
||||
no warnings 'void';
|
||||
sub {
|
||||
my( $said, $pm ) = @_;
|
||||
|
||||
sub new {
|
||||
my( $class ) = @_;
|
||||
my $self = bless {}, $class;
|
||||
$self->{name} = 'perldoc';
|
||||
$self->{opts} = {
|
||||
command => 1,
|
||||
handler => 1,
|
||||
};
|
||||
|
||||
$self->{aliases} = ['perldoc'];
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub get_conf_for_channel {
|
||||
my ($self, $pm, $server, $channel) = @_;
|
||||
my $gc = sub {$pm->plugin_conf($_[0], $server, $channel)};
|
||||
|
||||
# Load factoids if it exists, otherwise grab the old nfacts setup
|
||||
my $conf = $gc->("perldoc");
|
||||
return $conf;
|
||||
}
|
||||
|
||||
sub handle {
|
||||
my( $self, $said, $pm ) = @_;
|
||||
my $conf = $self->get_conf_for_channel($pm, $said->{server}, $said->{channel});
|
||||
|
||||
my $url = "";
|
||||
|
||||
if ($said->{body} =~ /-q\s+(.*)/i) #faq questions
|
||||
if (!$said->{addressed} && !$conf->{addressed} && $said->{body} =~ /^perldoc\s+(.*?)$/i) {
|
||||
local $said->{body} = $1;
|
||||
|
||||
my ($handled, $result) = $self->command($said, $pm);
|
||||
|
||||
if ($handled eq "handled") {
|
||||
return $result;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub command {
|
||||
my( $self, $said, $pm ) = @_;
|
||||
|
||||
my $url = "";
|
||||
|
||||
if ($said->{body} =~ /-q\s+(.*?)\s*(?:#.*)?/i) #faq questions
|
||||
{#http://perldoc.perl.org/search.html?q=foo+bar
|
||||
my $trimmed = $1;
|
||||
$trimmed =~ s/^\s*(\S+)\s*$/$1/;
|
||||
my $query = uri_encode($trimmed);
|
||||
$query =~ s/%20/+/g;
|
||||
$url = "http://perldoc.perl.org/search.html?q=".$query;
|
||||
$url = "https://perldoc.pl/search?q=".$query;
|
||||
# $url = makeashorterlink($url);
|
||||
}
|
||||
elsif ($said->{body} =~ /-f\s+(.*)/i) #functions, only use the first part of a multiword expression
|
||||
elsif ($said->{body} =~ /-f\s+(\S+)\s*/i) #functions, only use the first part of a multiword expression
|
||||
{
|
||||
#http://perldoc.perl.org/functions/abs.html
|
||||
my $func = $1;
|
||||
|
|
@ -27,34 +73,51 @@ sub {
|
|||
|
||||
$url = "https://perldoc.pl/functions/".$func
|
||||
}
|
||||
elsif ($said->{body} =~ /-m\s+(.*)\s*$/i) # got a module!
|
||||
elsif ($said->{body} =~ /-v\s+(\S+)\s*/i) #functions, only use the first part of a multiword expression
|
||||
{
|
||||
my $var = uri_encode($1, {"encode_reserved" => 1});
|
||||
|
||||
$url = "https://perldoc.pl/variables/".$var
|
||||
}
|
||||
elsif ($said->{body} =~ /-m\s+(\S+)\s*/i) # got a module!
|
||||
{#http://search.cpan.org/search?query=foo%3ABar&mode=all
|
||||
my $query = uri_encode($1);
|
||||
# $query =~ s/%20/+/g;
|
||||
$url = "https://p3rl.org/".$query;
|
||||
$url = "https://perldoc.pl/".$query;
|
||||
# $url = makeashorterlink($url);
|
||||
}
|
||||
elsif ($said->{body} =~ /::/) #module, go to cpan also
|
||||
{
|
||||
my $trimmed = $said->{body};
|
||||
$trimmed =~ s/^\s*(\S+)\s*$/$1/;
|
||||
$trimmed =~ s/^\s*(\S+)\s*(?:#.*)?$/$1/;
|
||||
my $query = uri_encode($trimmed);
|
||||
$query =~ s/%20/+/g;
|
||||
$url = "https://p3rl.org/".$query;
|
||||
$url = "https://perldoc.pl/$query";
|
||||
# $url = makeashorterlink($url);
|
||||
}
|
||||
else # we've got just a plain word, use it as a doc title
|
||||
{ #http://perldoc.perl.org/perlrun.html
|
||||
if ($said->{body} =~ /\s*(\S+)\s*/)
|
||||
if ($said->{body} =~ /^\s*(\S+)\s*(?:#.*)?$/)
|
||||
{
|
||||
$url = "https://perldoc.pl/$1";
|
||||
}
|
||||
else
|
||||
{
|
||||
print "Please request a valid section of perl documentation; you may also use, -q, -f, and -m just like on the command line";
|
||||
if ($said->{addressed}) {
|
||||
return("handled", "Please request a valid section of perl documentation; you may also use, -q, -f, and -m just like on the command line");
|
||||
}
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
print "Your documentation is available at: ", $url;
|
||||
if (!$said->{nested}) {
|
||||
return ("handled", "Your documentation is available at: $url");
|
||||
} else {
|
||||
return ("handled", $url);
|
||||
}
|
||||
}
|
||||
|
||||
"Bot::BB3::Plugin::Perldoc";
|
||||
|
||||
__DATA__
|
||||
Provide links to perldoc pages and module documentation on metacpan. Takes most options like the perldoc command line program.
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ sub make_pastebin {
|
|||
}
|
||||
}
|
||||
|
||||
my @versions = ('', qw(1 2 3 4 5.0 5.1 5.2 5.3 5.4 5.5 5.6 5.6t 5.8 5.10 5.12 5.14 5.16 5.18 5.20 5.22 5.24 5.26 5.26t all));
|
||||
my @versions = ('', qw(1 2 3 4 5.0 5.1 5.2 5.3 5.4 5.5 5.6 5.6t 5.8 5.10 5.12 5.14 5.16 5.18 5.20 5.22 5.24 5.26 5.26t 5.28 all));
|
||||
|
||||
sub new {
|
||||
my( $class ) = @_;
|
||||
|
|
@ -47,9 +47,9 @@ sub new {
|
|||
command => 1,
|
||||
};
|
||||
|
||||
my @perl_aliases = map {("eval$_", "weval$_", "seval$_", "wseval$_", "sweval$_")} @versions;
|
||||
my @perl_aliases = map {("eval$_", "weval$_", "seval$_", "wseval$_", "sweval$_", "meval$_")} @versions;
|
||||
|
||||
$self->{aliases} = [ qw/jseval rkeval jeval phpeval pleval perleval deparse swdeparse wsdeparse wdeparse sdeparse k20eval rbeval pyeval luaeval cpeval wscpeval swcpeval wcpeval scpeval bleval coboleval cbeval/, @perl_aliases ];
|
||||
$self->{aliases} = [ qw/jseval rkeval jeval phpeval pleval perleval deparse swdeparse wsdeparse wdeparse sdeparse k20eval rbeval pyeval luaeval cpeval wscpeval swcpeval wcpeval scpeval bleval coboleval cbeval basheval/, @perl_aliases ];
|
||||
$self->{dbh} = DBI->connect("dbi:SQLite:dbname=var/evallogs.db");
|
||||
|
||||
return $self;
|
||||
|
|
@ -87,6 +87,7 @@ sub command {
|
|||
's' => 'perl',
|
||||
'ws' => 'perl',
|
||||
'sw' => 'perl',
|
||||
'm' => 'perl',
|
||||
'cp' => 'cperl',
|
||||
'swcp' => 'cperl',
|
||||
'wscp' => 'cperl',
|
||||
|
|
@ -96,7 +97,8 @@ sub command {
|
|||
'bl' => 'perl',
|
||||
'cb' => 'cobol',
|
||||
'cobol' => 'cobol',
|
||||
map {($_=>"perl$_", "w$_"=>"perl$_", "s$_" => "perl$_", "ws$_"=>"perl$_", "sw$_"=>"perl$_")} @versions
|
||||
'bash' => 'bash',
|
||||
map {($_=>"perl$_", "w$_"=>"perl$_", "s$_" => "perl$_", "ws$_"=>"perl$_", "sw$_"=>"perl$_", "m$_"=>"perl$_")} @versions
|
||||
);
|
||||
|
||||
my $orig_type = $type;
|
||||
|
|
@ -118,13 +120,14 @@ sub command {
|
|||
|
||||
$code = eval {Encode::decode("utf8", $code)} // $code;
|
||||
|
||||
if ($command =~ /^([ws]+)?(?:eval|deparse)(?:5\.(\d+))?(all)?/i) {
|
||||
if ($command =~ /^([wsm]+)?(?:eval|deparse)(?:5\.(\d+))?(all)?/i) {
|
||||
my $c=$1;
|
||||
my $v=$2;
|
||||
my $all = $3;
|
||||
$code = "use warnings; ".$code if ($c =~ /w/ && ($v>=6 || !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))?$/);
|
||||
|
|
|
|||
85
plugins/tell.pm
Normal file
85
plugins/tell.pm
Normal file
|
|
@ -0,0 +1,85 @@
|
|||
package Bot::BB3::Plugin::Tell;
|
||||
use strict;
|
||||
no warnings 'void';
|
||||
sub new {
|
||||
my( $class ) = @_;
|
||||
my $self = bless {}, $class;
|
||||
$self->{name} = 'tell';
|
||||
$self->{opts} = {
|
||||
command => 1,
|
||||
};
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub command {
|
||||
my( $self, $said, $pm ) = @_;
|
||||
|
||||
|
||||
my ($who, $what);
|
||||
|
||||
|
||||
if ($said->{body} =~ /^\s*(.*?)\s+about\s+(.*)$/ ||
|
||||
$said->{body} =~ /^\s*(\S*)\s+(.*)$/) {
|
||||
($who, $what) = ($1, $2)
|
||||
} else {
|
||||
return ("handled", "Tell who about what?");
|
||||
}
|
||||
|
||||
my ($success, $result) = runplugin($what, $said, $who, $pm);
|
||||
|
||||
unless ($success) {
|
||||
my $result2;
|
||||
($success, $result2) = runplugin("default $what", $said, $who, $pm);
|
||||
|
||||
if ($success) {
|
||||
$result = $result2;
|
||||
}
|
||||
}
|
||||
|
||||
if ($success) {
|
||||
return ("handled", "\x00$who: $result");
|
||||
} else {
|
||||
return ("handled", "Couldn't find anything for $what");
|
||||
}
|
||||
}
|
||||
|
||||
sub runplugin {
|
||||
my( $cmd_string, $said, $who, $pm) = @_;
|
||||
my( $cmd, $body ) = split " ", $cmd_string, 2;
|
||||
defined($cmd) or
|
||||
return( 0, "Error, cannot parse call to find command name, probably empty call in compose" );
|
||||
defined($body) or $body = "";
|
||||
|
||||
my $plugin = $pm->get_plugin( $cmd, $said )
|
||||
or return( 0, "Compose failed to find a plugin named: $cmd" );
|
||||
|
||||
my $newsaid = {%$said,
|
||||
body => $body,
|
||||
recommended_args => [ split /\s+/, $body ],
|
||||
command_match => $cmd,
|
||||
name => $who,
|
||||
body_raw => $said->{addressed_as}. ": $body",
|
||||
sender_raw => "$who!~$who\@NONLOCAL",
|
||||
by_root => 0,
|
||||
by_chan_op => 0,
|
||||
ircnname => "~$who",
|
||||
host => "NONLOCAL",
|
||||
nested => 1,
|
||||
};
|
||||
|
||||
local $@;
|
||||
my( $status, $results ) = eval { $plugin->command( $newsaid, $pm ) };
|
||||
|
||||
if( $@ ) { return( 0, "Failed to execute plugin: $cmd because $@" ); }
|
||||
|
||||
else { return( 1, $results ) }
|
||||
|
||||
return( 0, "Error, should never reach here" );
|
||||
}
|
||||
|
||||
|
||||
"Bot::BB3::Plugin::Tell";
|
||||
|
||||
__DATA__
|
||||
Tell other users about things. tell <who> [about] <what>"
|
||||
|
|
@ -11,10 +11,12 @@ close($fh);
|
|||
chomp $consumer_key;
|
||||
chomp $consumer_secret;
|
||||
|
||||
use HTML::Entities;
|
||||
|
||||
#die Dumper($consumer_key, $consumer_secret);
|
||||
|
||||
my $client = Twitter::API->new_with_traits(
|
||||
traits => [qw/ApiMethods AppAuth/],
|
||||
traits => [qw/ApiMethods AppAuth DecodeHtmlEntities/],
|
||||
consumer_key => $consumer_key,
|
||||
consumer_secret => $consumer_secret,
|
||||
);
|
||||
|
|
@ -27,11 +29,18 @@ sub display_tweet {
|
|||
my $tweet = shift;
|
||||
|
||||
if ($tweet) {
|
||||
my ($time, $text, $id) = @{$tweet}{qw/created_at text id/};
|
||||
my ($time, $text, $id) = @{$tweet}{qw/created_at full_text id/};
|
||||
$text //= $tweet->{text};
|
||||
|
||||
my $source = $tweet->{user}{name};
|
||||
my $url = "https://twitter.com/link/status/$id";
|
||||
|
||||
unless ($text =~ m|https://t.co/|) {
|
||||
print "<$source> $text $url";
|
||||
} else {
|
||||
print "<$source> $text";
|
||||
}
|
||||
|
||||
} else {
|
||||
print "No tweets found";
|
||||
}
|
||||
|
|
@ -45,7 +54,7 @@ sub {
|
|||
if ($said->{body} =~ /^\s*(#\S+)/ ||
|
||||
$said->{body} =~ /^\s*search\s+(.*)/) {
|
||||
# hash tags. omg.
|
||||
my $search = $client->search($1);
|
||||
my $search = $client->search($1, {tweet_mode => "extended"});
|
||||
|
||||
open (my $fh, ">", "/tmp/twitter");
|
||||
print $fh Dumper($search);
|
||||
|
|
@ -54,10 +63,14 @@ sub {
|
|||
my $tweet = $tweets->@[rand() * $tweets->@*];
|
||||
|
||||
display_tweet $tweet;
|
||||
} elsif ($said->{body} =~ m|twitter.com/([^/]+)/status/(\d+)|) {
|
||||
my ($userid, $tweetid) = ($1, $2);
|
||||
my $tweet = $client->show_status($tweetid, {tweet_mode => "extended"});
|
||||
display_tweet($tweet);
|
||||
} else {
|
||||
my ($userid, $count) = $said->{body} =~ /^\s*(\S+)(?:\s+(\d+))?/g;
|
||||
|
||||
my $timeline=$client->user_timeline($userid);
|
||||
my $timeline=$client->user_timeline($userid, {tweet_mode => "extended"});
|
||||
my $tweet = $timeline->[$count//0];
|
||||
|
||||
display_tweet $tweet;
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue