mirror of
https://github.com/perlbot/perlbuut
synced 2025-06-06 14:05:40 -04:00
Updates i hadnt done for a while
This commit is contained in:
parent
5d9ff37873
commit
b9d1ee614e
7 changed files with 109 additions and 13 deletions
|
|
@ -359,6 +359,7 @@ sub _create_plugin_chain {
|
|||
my $commands = $pre_built_chains->{commands};
|
||||
warn "in chain create parse: $said->{body}\n";
|
||||
my $command_list = $self->_parse_for_commands( $said, $commands );
|
||||
warn "got command list: [".join(',', $command_list->@*)."]";
|
||||
warn "in chain create post-parse: $said->{body}\n";
|
||||
|
||||
return [ $pre, $command_list, $handlers, $post ];
|
||||
|
|
@ -407,6 +408,8 @@ sub _parse_for_commands {
|
|||
sub _filter_plugin_list {
|
||||
my( $self, $said, $plugins ) = @_;
|
||||
|
||||
warn "Checking plugin filter: [".join(", ", map {$_->{name}} $plugins->@*)."]";
|
||||
|
||||
my @chain;
|
||||
for( @$plugins ) {
|
||||
my $conf = $self->plugin_conf( $_->{name}, $said->{server}, $said->{channel} );
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ sub _start {
|
|||
# TODO setup TCP server.
|
||||
$self->{server} = POE::Component::Server::TCP->new(
|
||||
Port => 1784,
|
||||
Address =>'192.168.196.2',
|
||||
Address =>'192.168.64.2',
|
||||
ClientFilter => "POE::Filter::Line",
|
||||
ClientInput => \&receive_paste,
|
||||
);
|
||||
|
|
|
|||
12
plugins/dumpsaid.pm
Normal file
12
plugins/dumpsaid.pm
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
use Data::Dumper;
|
||||
|
||||
no warnings 'void';
|
||||
sub {
|
||||
my( $said ) = @_;
|
||||
|
||||
print Dumper($said);
|
||||
return "FOO";
|
||||
};
|
||||
|
||||
__DATA__
|
||||
Prints the full said object out, used for debugging
|
||||
|
|
@ -57,6 +57,7 @@ my %commandhash = (
|
|||
"substitute" => \&get_fact_substitute,
|
||||
"nchain" => \&get_fact_namespace_chain,
|
||||
"factgrep" => \&get_fact_grep,
|
||||
"factseo" => \&get_fact_seo,
|
||||
);
|
||||
|
||||
my $commands_re = join '|', keys %commandhash;
|
||||
|
|
@ -796,6 +797,57 @@ SELECT DISTINCT ON(original_subject) original_subject, predicate FROM get_latest
|
|||
|
||||
}
|
||||
|
||||
sub get_fact_seo ($self, $body, $name, $said) {
|
||||
my ($aliasserver, $aliasnamespace) = $self->get_alias_namespace($said);
|
||||
my ($server, $namespace) = $self->get_namespace($said);
|
||||
|
||||
my $results;
|
||||
|
||||
my $value_only = $body =~ s/\s*--val\s+//;
|
||||
|
||||
$results = $self->dbh->selectall_arrayref("
|
||||
WITH RECURSIVE factoid_lookup_order_inner (depth, namespace, server, alias_namespace, alias_server, parent_namespace, parent_server, recursive, gen_server, gen_namespace) AS (
|
||||
SELECT 0 AS depth, namespace, server, alias_namespace, alias_server, parent_namespace, parent_server, recursive, generated_server, generated_namespace
|
||||
FROM factoid_config
|
||||
WHERE namespace = ? AND server = ?
|
||||
UNION ALL
|
||||
SELECT p.depth+1 AS depth, m.namespace, m.server, m.alias_namespace, m.alias_server, m.parent_namespace, m.parent_server, m.recursive, m.generated_server, m.generated_namespace
|
||||
FROM factoid_config m
|
||||
INNER JOIN factoid_lookup_order_inner p
|
||||
ON m.namespace = p.parent_namespace AND m.server = p.parent_server AND p.recursive
|
||||
),
|
||||
factoid_lookup_order (depth, namespace, server, alias_namespace, alias_server, parent_namespace, parent_server, recursive, gen_server, gen_namespace) AS (
|
||||
SELECT * FROM factoid_lookup_order_inner
|
||||
UNION ALL
|
||||
SELECT 0, '', '', NULL, NULL, NULL, NULL, false, '', '' WHERE NOT EXISTS (table factoid_lookup_order_inner)
|
||||
),
|
||||
get_latest_factoid (depth, factoid_id, subject, copula, predicate, author, modified_time, compose_macro, protected, original_subject, deleted, server, namespace) AS (
|
||||
SELECT lo.depth, factoid_id, subject, copula, predicate, author, modified_time, compose_macro, protected, original_subject, f.deleted, f.server, f.namespace
|
||||
FROM factoid f
|
||||
INNER JOIN factoid_lookup_order lo
|
||||
ON f.generated_server = lo.gen_server
|
||||
AND f.generated_namespace = lo.gen_namespace
|
||||
WHERE original_subject ~* ?
|
||||
ORDER BY depth ASC, factoid_id DESC
|
||||
)
|
||||
SELECT DISTINCT ON(original_subject) original_subject, predicate FROM get_latest_factoid WHERE NOT deleted ORDER BY original_subject ASC, depth ASC, factoid_id DESC",
|
||||
{ Slice => {} },
|
||||
$namespace, $server,
|
||||
$body,
|
||||
);
|
||||
|
||||
print STDERR "Got results: ".Dumper($results);
|
||||
|
||||
if ($results and @$results) {
|
||||
my $ret_string = encode_json([map {$value_only ? $_->{predicate} : $_->{original_subject}} @$results]);
|
||||
|
||||
return $ret_string;
|
||||
} else {
|
||||
return "[]";
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub get_fact_oldsearch ($self, $body, $name, $said) {
|
||||
my ($aliasserver, $aliasnamespace) = $self->get_alias_namespace($said);
|
||||
my ($server, $namespace) = $self->get_namespace($said);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
|
||||
package Bot::BB3::Plugin::Get;
|
||||
use LWP::UserAgent;
|
||||
use HTML::TreeBuilder::XPath;
|
||||
|
||||
|
|
@ -13,30 +15,49 @@ package
|
|||
}
|
||||
};
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
|
||||
sub {
|
||||
my( $said ) = @_;
|
||||
my $self = bless {}, $class;
|
||||
$self->{name} = "get";
|
||||
$self->{opts} = {
|
||||
command => 1,
|
||||
};
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
sub command {
|
||||
my( $self, $said, $pm ) = @_;
|
||||
|
||||
print STDERR "in get command plugin\n";
|
||||
|
||||
my $ua = LWP::UserAgent->new( agent => "Mozilla/5.0 (Macintosh; Intel Mac OS X 10_9_5) AppleWebKit/537.36 (KHTML, like Gecko, really Perlbot) Chrome/45.0.2454.85 Safari/537.36" );
|
||||
my $url;
|
||||
|
||||
print STDERR "Checking ".$said->{body}." for urls\n";
|
||||
|
||||
if( $said->{body} =~ s{(https?://\S+)\s*}{} ) {
|
||||
print STDERR "First check found, $1\n";
|
||||
$url = $1;
|
||||
}
|
||||
elsif( $said->{body} =~ s/(\S+)\s*// ) {
|
||||
print STDERR "Found bare domain/url $1\n";
|
||||
$url = "http://$1";
|
||||
}
|
||||
else {
|
||||
print "That doesn't look like a url..";
|
||||
return;
|
||||
print STDERR "Got broken url\n";
|
||||
return ('handled', "That doesn't look like a url to me.");
|
||||
}
|
||||
|
||||
print STDERR "GOT URL: $url\n";
|
||||
|
||||
my $resp = $ua->get( $url );
|
||||
|
||||
if( not $resp ) {
|
||||
print "Couldn't fetch [$url] you failure";
|
||||
return;
|
||||
print STDERR "Couldn't fetch [$url] you failure";
|
||||
return('handled', "Couldn't fetch [$url] $resp");
|
||||
}
|
||||
|
||||
my @text;
|
||||
|
|
@ -59,8 +80,14 @@ sub {
|
|||
}
|
||||
local $, = ', ';
|
||||
|
||||
print map { local $_ = "$_"; s/\s+/ /g;s/^ +//; s/ +$//; $_} @text
|
||||
my @values = map { local $_ = "$_"; s/\s+/ /g;s/^ +//; s/ +$//; $_} @text;
|
||||
|
||||
print STDERR "text? @text\n";
|
||||
|
||||
return ('handled', join("", @values));
|
||||
}
|
||||
|
||||
"Bot::BB3::Plugin::Get";
|
||||
|
||||
__DATA__
|
||||
get http://url/ //xpath - get page from interents, extract the xpath, show it to people. (Xpath defaults to '//title' + '//body' ) spaces squashed too
|
||||
|
|
|
|||
|
|
@ -80,7 +80,8 @@ sub command {
|
|||
}
|
||||
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});
|
||||
my $raw = $1;
|
||||
my $var = uri_encode($raw =~ s/\\([^\\])/$1/gr, {"encode_reserved" => 1});
|
||||
|
||||
$url = "https://perldoc.perl.org/variables/".$var
|
||||
}
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ sub make_pastebin_all {
|
|||
}
|
||||
}
|
||||
|
||||
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/);
|
||||
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 5.38 5.38.0/);
|
||||
|
||||
sub new {
|
||||
my( $class ) = @_;
|
||||
|
|
@ -130,6 +130,7 @@ sub command {
|
|||
wsdeparse => 'deparse',
|
||||
wdeparse => 'deparse',
|
||||
sdeparse => 'deparse',
|
||||
deparse => 'deparse',
|
||||
'k20' => 'k20',
|
||||
'k' => 'k20',
|
||||
'rb' => 'ruby',
|
||||
|
|
@ -173,7 +174,7 @@ sub command {
|
|||
|
||||
# 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"
|
||||
$type = "perl5.38"
|
||||
}
|
||||
|
||||
if ($command eq 'r' && (!$said->{addressed} && !$said->{nested} && ($said->{channel} ne "#perl6" && $said->{channel} eq '#raku'))) {
|
||||
|
|
@ -206,7 +207,7 @@ sub command {
|
|||
$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 = "use utf8; ". $code if ($type =~ /^perl(5.(8|10|12|14|16|18|20|22|24|26|28|30|32|34|36))?$/);
|
||||
|
||||
$code =~ s//\n/g;
|
||||
|
||||
|
|
@ -240,7 +241,7 @@ sub command {
|
|||
(!$nlflag && ($type eq 'perl6' || $type eq 'bash' || $type eq 'concise' || $type eq 'deparse2'));
|
||||
|
||||
if ($usenl) {
|
||||
$resultstr =~ s/\n/\x{2424}/g;
|
||||
$resultstr =~ s/\n/\x{21b5}/g;
|
||||
}
|
||||
|
||||
$resultstr =~ s/^(\x00)+//g;
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue