From 1e5af45c57723a404cb6cd0a1e52e1c83320b926 Mon Sep 17 00:00:00 2001 From: Ryan Voots Date: Thu, 13 Sep 2018 14:27:34 -0400 Subject: [PATCH] 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 --- plugins/karma_modify.pm | 2 +- plugins/karmatop.pm | 101 +++++++++++++++++++++++++++++----------- plugins/perldoc.pm | 89 +++++++++++++++++++++++++++++------ plugins/supereval.pm | 13 ++++-- plugins/tell.pm | 85 +++++++++++++++++++++++++++++++++ plugins/twitter.pm | 23 +++++++-- 6 files changed, 261 insertions(+), 52 deletions(-) create mode 100644 plugins/tell.pm diff --git a/plugins/karma_modify.pm b/plugins/karma_modify.pm index b38fcc0..abeb89d 100644 --- a/plugins/karma_modify.pm +++ b/plugins/karma_modify.pm @@ -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; diff --git a/plugins/karmatop.pm b/plugins/karmatop.pm index b698eb2..6b0e7f7 100644 --- a/plugins/karmatop.pm +++ b/plugins/karmatop.pm @@ -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,33 +16,82 @@ sub { { RaiseError => 1, PrintError => 0 } ); - if ($said->{body} =~ /\s*(-?\d+)(\s*karma)?/) - { - my $count = $1; - my $sth; - if ($count > 0) - { - $sth = $dbh->prepare("SELECT subject, kars FROM (SELECT subject, sum(operation) as kars FROM karma GROUP BY subject) AS karmsub ORDER BY kars DESC LIMIT ?"); - } - else - { - $sth = $dbh->prepare("SELECT subject, kars FROM (SELECT subject, sum(operation) as kars FROM karma GROUP BY subject) AS karmsub ORDER BY kars ASC LIMIT ?"); - } + 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(abs $count); + $sth->execute($who, abs $count); - while (my $row = $sth->fetchrow_arrayref()) - { - my $subject=$row->[0]; - my $karma = $row->[1]; + while (my $row = $sth->fetchrow_arrayref()) { + my $subject=$row->[0]; + my $karma = $row->[1]; - print "$subject: $karma "; - } - } - else - { - print "usage is: top/bottom \\d+ karma"; - } + 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) + { + $sth = $dbh->prepare("SELECT subject, kars FROM (SELECT subject, sum(operation) as kars FROM karma GROUP BY subject) AS karmsub ORDER BY kars DESC LIMIT ?"); + } + else + { + $sth = $dbh->prepare("SELECT subject, kars FROM (SELECT subject, sum(operation) as kars FROM karma GROUP BY subject) 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 "; + } + } else { + print "usage is: top/bottom \\d+ karma"; + } }; __DATA__ diff --git a/plugins/perldoc.pm b/plugins/perldoc.pm index f1dcdd8..0f306cf 100644 --- a/plugins/perldoc.pm +++ b/plugins/perldoc.pm @@ -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. diff --git a/plugins/supereval.pm b/plugins/supereval.pm index d4ecbcd..5b2cd2c 100644 --- a/plugins/supereval.pm +++ b/plugins/supereval.pm @@ -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))?$/); diff --git a/plugins/tell.pm b/plugins/tell.pm new file mode 100644 index 0000000..bdb0806 --- /dev/null +++ b/plugins/tell.pm @@ -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 [about] " diff --git a/plugins/twitter.pm b/plugins/twitter.pm index 32021bf..ba03b19 100644 --- a/plugins/twitter.pm +++ b/plugins/twitter.pm @@ -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"; - print "<$source> $text $url"; + 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;