mirror of https://github.com/pragma-/pbot.git
Pragmatic Software
parent
990c4f1455
commit
5fc4d8c86a
|
|
@ -7,8 +7,7 @@ use parent 'PBot::Class';
|
|||
|
||||
# purpose: provides interface to set/remove/modify/query user capabilities.
|
||||
#
|
||||
# Examples:
|
||||
#
|
||||
# Examples: See doc/Admin.md for examples.
|
||||
|
||||
use warnings; use strict;
|
||||
use feature 'unicode_strings';
|
||||
|
|
@ -18,16 +17,21 @@ no if $] >= 5.018, warnings => "experimental::smartmatch";
|
|||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
|
||||
# capabilities file
|
||||
my $filename = $conf{filename} // $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/capabilities';
|
||||
|
||||
# capabilities hash table
|
||||
$self->{caps} = PBot::HashObject->new(name => 'Capabilities', filename => $filename, pbot => $self->{pbot});
|
||||
|
||||
# load capabilities
|
||||
$self->{caps}->load;
|
||||
|
||||
# 'cap' command registered in PBot.pm because $self->{pbot}->{commands} is not yet loaded.
|
||||
# 'cap' command registered in PBot.pm because $self->{pbot}->{commands} is not yet loaded at this point.
|
||||
|
||||
# add some capabilities used in this file
|
||||
$self->add('can-modify-capabilities', undef, 1);
|
||||
$self->add('can-group-capabilities', undef, 1);
|
||||
$self->add('can-ungroup-capabilities', undef, 1);
|
||||
|
||||
# add some useful capabilities
|
||||
$self->add('is-whitelisted', undef, 1);
|
||||
|
|
@ -37,7 +41,7 @@ sub cmd_cap {
|
|||
my ($self, $context) = @_;
|
||||
|
||||
my $command = $self->{pbot}->{interpreter}->shift_arg($context->{arglist});
|
||||
my $result;
|
||||
|
||||
given ($command) {
|
||||
when ('list') {
|
||||
my $cap = $self->{pbot}->{interpreter}->shift_arg($context->{arglist});
|
||||
|
|
@ -46,14 +50,25 @@ sub cmd_cap {
|
|||
|
||||
when ('whohas') {
|
||||
my $cap = $self->{pbot}->{interpreter}->shift_arg($context->{arglist});
|
||||
return "Usage: cap whohas <capability>; Lists all users who have <capability>" if not defined $cap;
|
||||
return "No such capability $cap." if not $self->exists($cap);
|
||||
|
||||
if (not defined $cap) {
|
||||
return "Usage: cap whohas <capability>; Lists all users who have <capability>";
|
||||
}
|
||||
|
||||
if (not $self->exists($cap)) {
|
||||
return "No such capability $cap.";
|
||||
}
|
||||
|
||||
my $result = "Users with capability $cap: ";
|
||||
my $users = $self->{pbot}->{users}->{users};
|
||||
my @matches;
|
||||
|
||||
foreach my $name (sort $users->get_keys) {
|
||||
my $u = $users->get_data($name);
|
||||
push @matches, $users->get_key_name($name) if $self->userhas($u, $cap);
|
||||
|
||||
if ($self->userhas($u, $cap)) {
|
||||
push @matches, $users->get_key_name($name);
|
||||
}
|
||||
}
|
||||
|
||||
if (@matches) {
|
||||
|
|
@ -67,10 +82,15 @@ sub cmd_cap {
|
|||
|
||||
when ('userhas') {
|
||||
my ($name, $cap) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 2);
|
||||
return "Usage: cap userhas <username> [capability]; Lists capabilities belonging to <user>" if not defined $name;
|
||||
|
||||
if (not defined $name) {
|
||||
return "Usage: cap userhas <username> [capability]; Lists capabilities belonging to <user>";
|
||||
}
|
||||
|
||||
$cap = lc $cap if defined $cap;
|
||||
|
||||
my $u = $self->{pbot}->{users}->{users}->get_data($name);
|
||||
|
||||
if (not defined $u) {
|
||||
return "No such user $name.";
|
||||
}
|
||||
|
|
@ -78,70 +98,128 @@ sub cmd_cap {
|
|||
$name = $self->{pbot}->{users}->{users}->get_key_name($name);
|
||||
|
||||
if (defined $cap) {
|
||||
return "Try again. No such capability $cap." if not $self->exists($cap);
|
||||
if ($self->userhas($u, $cap)) { return "Yes. User $name has capability $cap."; }
|
||||
else { return "No. User $name does not have capability $cap."; }
|
||||
if (not $self->exists($cap)) {
|
||||
return "Try again. No such capability $cap.";
|
||||
}
|
||||
|
||||
if ($self->userhas($u, $cap)) {
|
||||
return "Yes. User $name has capability $cap.";
|
||||
} else {
|
||||
return "No. User $name does not have capability $cap.";
|
||||
}
|
||||
} else {
|
||||
my $result = "User $name has capabilities: ";
|
||||
my @groups;
|
||||
my @single;
|
||||
|
||||
foreach my $key (sort keys %{$u}) {
|
||||
next if $key eq '_name';
|
||||
next if not $self->exists($key);
|
||||
next if $key eq '_name'; # skip internal cached metadata
|
||||
next if not $self->exists($key); # skip metadata that isn't a capability
|
||||
|
||||
my $count = $self->{caps}->get_keys;
|
||||
if ($count > 0) { push @groups, "$key ($count cap" . ($count == 1 ? '' : 's') . ")"; }
|
||||
else { push @single, $key; }
|
||||
|
||||
if ($count > 0) {
|
||||
push @groups, "$key ($count cap" . ($count == 1 ? '' : 's') . ")";
|
||||
} else {
|
||||
push @single, $key;
|
||||
}
|
||||
}
|
||||
|
||||
if (@groups or @single) {
|
||||
# first list all capabilities that have sub-capabilities (i.e. grouped capabilities)
|
||||
# then list stand-alone (single) capabilities
|
||||
return "User $name has capabilities: " . join ', ', @groups, @single;
|
||||
} else {
|
||||
return "User $name has no capabilities.";
|
||||
}
|
||||
if (@groups or @single) { $result .= join ', ', @groups, @single; }
|
||||
else { $result = "User $name has no capabilities."; }
|
||||
return $result;
|
||||
}
|
||||
}
|
||||
|
||||
when ('group') {
|
||||
my ($cap, $subcaps) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 2);
|
||||
return "Usage: cap group <existing or new capability> <existing capabilities...>" if not defined $cap or not defined $subcaps;
|
||||
|
||||
if (not defined $cap or not defined $subcaps) {
|
||||
return "Usage: cap group <existing or new capability> <existing capabilities...>";
|
||||
}
|
||||
|
||||
my $u = $self->{pbot}->{users}->loggedin($context->{from}, $context->{hostmask});
|
||||
return "You must be logged into your user account to group capabilities together." if not defined $u;
|
||||
return "You must have the can-group-capabilities capability to group capabilities together." if not $self->userhas($u, 'can-group-capabilities');
|
||||
|
||||
my @caps = split /\s+|,/, $subcaps;
|
||||
if (not defined $u) {
|
||||
return "You must be logged into your user account to group capabilities together.";
|
||||
}
|
||||
|
||||
if (not $self->userhas($u, 'can-group-capabilities')) {
|
||||
return "You must have the can-group-capabilities capability to group capabilities together.";
|
||||
}
|
||||
|
||||
my @caps = split /\s+|,\s*/, $subcaps; # split by spaces or comma
|
||||
|
||||
foreach my $c (@caps) {
|
||||
return "No such capability $c." if not $self->exists($c);
|
||||
return "You cannot group a capability with itself." if lc $cap eq lc $c;
|
||||
if (not $self->exists($c)) {
|
||||
return "No such capability $c.";
|
||||
}
|
||||
|
||||
if (lc $cap eq lc $c) {
|
||||
return "You cannot group a capability with itself.";
|
||||
}
|
||||
|
||||
$self->add($cap, $c);
|
||||
}
|
||||
if (@caps > 1) { return "Capabilities " . join(', ', @caps) . " added to the $cap capability group."; }
|
||||
else { return "Capability $subcaps added to the $cap capability group."; }
|
||||
|
||||
if (@caps > 1) {
|
||||
return "Capabilities " . join(', ', @caps) . " added to the $cap capability group.";
|
||||
} else {
|
||||
return "Capability $subcaps added to the $cap capability group.";
|
||||
}
|
||||
}
|
||||
|
||||
when ('ungroup') {
|
||||
my ($cap, $subcaps) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 2);
|
||||
return "Usage: cap ungroup <existing capability group> <grouped capabilities...>" if not defined $cap or not defined $subcaps;
|
||||
return "No such capability $cap." if not $self->exists($cap);
|
||||
|
||||
if (not defined $cap or not defined $subcaps) {
|
||||
return "Usage: cap ungroup <existing capability group> <grouped capabilities...>";
|
||||
}
|
||||
|
||||
if (not $self->exists($cap)) {
|
||||
return "No such capability $cap.";
|
||||
}
|
||||
|
||||
my $u = $self->{pbot}->{users}->loggedin($context->{from}, $context->{hostmask});
|
||||
return "You must be logged into your user account to remove capabilities from groups." if not defined $u;
|
||||
return "You must have the can-ungroup-capabilities capability to remove capabilities from groups." if not $self->userhas($u, 'can-ungroup-capabilities');
|
||||
|
||||
my @caps = split /\s+|,/, $subcaps;
|
||||
if (not defined $u) {
|
||||
return "You must be logged into your user account to remove capabilities from groups.";
|
||||
}
|
||||
|
||||
if (not $self->userhas($u, 'can-group-capabilities')) {
|
||||
return "You must have the can-group-capabilities capability to remove capabilities from groups.";
|
||||
}
|
||||
|
||||
my @caps = split /\s+|,\s*/, $subcaps; # split by spaces or comma
|
||||
|
||||
foreach my $c (@caps) {
|
||||
return "No such capability $c." if not $self->exists($c);
|
||||
return "Capability $c does not belong to the $cap capability group." if not $self->has($cap, $c);
|
||||
if (not $self->exists($c)) {
|
||||
return "No such capability $c.";
|
||||
}
|
||||
|
||||
if (not $self->has($cap, $c)) {
|
||||
return "Capability $c does not belong to the $cap capability group.";
|
||||
}
|
||||
|
||||
$self->remove($cap, $c);
|
||||
}
|
||||
|
||||
if (@caps > 1) { return "Capabilities " . join(', ', @caps) . " removed from the $cap capability group."; }
|
||||
else { return "Capability $subcaps removed from the $cap capability group."; }
|
||||
if (@caps > 1) {
|
||||
return "Capabilities " . join(', ', @caps) . " removed from the $cap capability group.";
|
||||
} else {
|
||||
return "Capability $subcaps removed from the $cap capability group.";
|
||||
}
|
||||
}
|
||||
|
||||
default {
|
||||
$result =
|
||||
"Usage: cap list [capability] | cap group <existing or new capability group> <existing capabilities...> | cap ungroup <existing capability group> <grouped capabilities...> | cap userhas <user> [capability] | cap whohas <capability>";
|
||||
return "Usage: cap list [capability] | cap group <existing or new capability group> <existing capabilities...> "
|
||||
. "| cap ungroup <existing capability group> <grouped capabilities...> | cap userhas <user> [capability] "
|
||||
. "| cap whohas <capability>";
|
||||
}
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub has {
|
||||
|
|
@ -155,7 +233,8 @@ sub has {
|
|||
return 1;
|
||||
}
|
||||
|
||||
$depth //= 10;
|
||||
$depth //= 10; # set depth to 10 if it's not defined
|
||||
|
||||
if (--$depth <= 0) {
|
||||
$self->{pbot}->{logger}->log("Max recursion reached for PBot::Capabilities->has($cap, $subcap)\n");
|
||||
return 0;
|
||||
|
|
@ -165,35 +244,46 @@ sub has {
|
|||
return 1 if $c eq $subcap and $cap_data->{$c};
|
||||
return 1 if $self->has($c, $subcap, $depth);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub userhas {
|
||||
my ($self, $user, $cap) = @_;
|
||||
|
||||
return 0 if not defined $user;
|
||||
return 1 if $user->{$cap};
|
||||
|
||||
foreach my $key (keys %$user) {
|
||||
next if $key eq '_name';
|
||||
next if not $user->{$key};
|
||||
return 1 if $self->has($key, $cap);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub exists {
|
||||
my ($self, $cap) = @_;
|
||||
|
||||
$cap = lc $cap;
|
||||
|
||||
foreach my $c ($self->{caps}->get_keys) {
|
||||
return 1 if $c eq $cap;
|
||||
|
||||
foreach my $sub_cap ($self->{caps}->get_keys($c)) {
|
||||
return 1 if $sub_cap eq $cap;
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub add {
|
||||
my ($self, $cap, $subcap, $dontsave) = @_;
|
||||
|
||||
$cap = lc $cap;
|
||||
|
||||
if (not defined $subcap) {
|
||||
if (not $self->{caps}->exists($cap)) {
|
||||
$self->{caps}->add($cap, {}, $dontsave);
|
||||
|
|
@ -209,7 +299,9 @@ sub add {
|
|||
|
||||
sub remove {
|
||||
my ($self, $cap, $subcap) = @_;
|
||||
|
||||
$cap = lc $cap;
|
||||
|
||||
if (not defined $subcap) {
|
||||
foreach my $c ($self->{caps}->get_keys) {
|
||||
foreach my $sub_cap ($self->{caps}->get_keys($c)) {
|
||||
|
|
@ -220,18 +312,26 @@ sub remove {
|
|||
} else {
|
||||
$self->{caps}->remove($cap, $subcap, 1) if $self->{caps}->exists($cap);
|
||||
}
|
||||
|
||||
$self->{caps}->save;
|
||||
}
|
||||
|
||||
sub rebuild_botowner_capabilities {
|
||||
my ($self) = @_;
|
||||
|
||||
$self->{caps}->remove('botowner', undef, 1);
|
||||
foreach my $cap ($self->{caps}->get_keys) { $self->add('botowner', $cap, 1); }
|
||||
|
||||
foreach my $cap ($self->{caps}->get_keys) {
|
||||
$self->add('botowner', $cap, 1);
|
||||
}
|
||||
}
|
||||
|
||||
sub list {
|
||||
my ($self, $capability) = @_;
|
||||
return "No such capability $capability." if defined $capability and not $self->{caps}->exists($capability);
|
||||
|
||||
if (defined $capability and not $self->{caps}->exists($capability)) {
|
||||
return "No such capability $capability.";
|
||||
}
|
||||
|
||||
my @caps;
|
||||
my @groups;
|
||||
|
|
@ -243,7 +343,11 @@ sub list {
|
|||
$result = 'Capabilities: ';
|
||||
} else {
|
||||
@caps = sort $self->{caps}->get_keys($capability);
|
||||
return "Capability $capability has no grouped capabilities." if not @caps;
|
||||
|
||||
if (not @caps) {
|
||||
return "Capability $capability has no grouped capabilities."
|
||||
}
|
||||
|
||||
$result = "Grouped capabilities for $capability: ";
|
||||
}
|
||||
|
||||
|
|
@ -251,10 +355,16 @@ sub list {
|
|||
# then list stand-alone capabilities
|
||||
foreach my $cap (@caps) {
|
||||
my $count = $self->{caps}->get_keys($cap);
|
||||
if ($count > 0) { push @groups, "$cap ($count cap" . ($count == 1 ? '' : 's') . ")" if $count; }
|
||||
else { push @standalones, $cap; }
|
||||
|
||||
if ($count > 0) {
|
||||
push @groups, "$cap ($count cap" . ($count == 1 ? '' : 's') . ")";
|
||||
} else {
|
||||
push @standalones, $cap;
|
||||
}
|
||||
}
|
||||
|
||||
$result .= join ', ', @groups, @standalones;
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -12,6 +12,9 @@ package PBot::Class;
|
|||
use warnings;
|
||||
use strict;
|
||||
|
||||
use feature 'unicode_strings';
|
||||
use utf8;
|
||||
|
||||
sub new {
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
|
|
|
|||
|
|
@ -21,23 +21,14 @@ sub initialize {
|
|||
my ($self, %conf) = @_;
|
||||
$self->PBot::Registerable::initialize(%conf);
|
||||
|
||||
$self->{metadata} = PBot::HashObject->new(pbot => $self->{pbot}, name => 'Commands', filename => $conf{filename});
|
||||
# command metadata
|
||||
$self->{metadata} = PBot::HashObject->new(pbot => $self->{pbot}, name => 'Command metadata', filename => $conf{filename});
|
||||
$self->{metadata}->load;
|
||||
|
||||
$self->register(sub { $self->cmd_set(@_) }, "cmdset", 1);
|
||||
$self->register(sub { $self->cmd_unset(@_) }, "cmdunset", 1);
|
||||
$self->register(sub { $self->cmd_help(@_) }, "help", 0);
|
||||
$self->register(sub { $self->cmd_uptime(@_) }, "uptime", 0);
|
||||
$self->register(sub { $self->cmd_in_channel(@_) }, "in", 0);
|
||||
$self->register(sub { $self->cmd_nop(@_) }, "nop", 0);
|
||||
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-in', 1);
|
||||
}
|
||||
|
||||
sub cmd_nop {
|
||||
my ($self, $context) = @_;
|
||||
$self->{pbot}->{logger}->log("Disregarding NOP command.\n");
|
||||
return "";
|
||||
# register commands to manipulate command metadata and obtain help
|
||||
$self->register(sub { $self->cmd_set(@_) }, "cmdset", 1);
|
||||
$self->register(sub { $self->cmd_unset(@_) }, "cmdunset", 1);
|
||||
$self->register(sub { $self->cmd_help(@_) }, "help", 0);
|
||||
}
|
||||
|
||||
sub cmd_set {
|
||||
|
|
@ -69,13 +60,19 @@ sub cmd_help {
|
|||
my $name = $self->{metadata}->get_key_name($keyword);
|
||||
my $requires_cap = $self->{metadata}->get_data($keyword, 'requires_cap');
|
||||
my $help = $self->{metadata}->get_data($keyword, 'help');
|
||||
my $result = "/say $name: ";
|
||||
|
||||
my $result = "/say $name: ";
|
||||
$result .= "[Requires can-$keyword] " if $requires_cap;
|
||||
|
||||
if (not defined $help or not length $help) { $result .= "I have no help text for this command yet. To add help text, use the command `cmdset $keyword help <text>`."; }
|
||||
else { $result .= $help; }
|
||||
if (not defined $help or not length $help) {
|
||||
$result .= "I have no help text for this command yet. To add help text, use the command `cmdset $keyword help <text>`.";
|
||||
} else {
|
||||
$result .= $help;
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
return "$keyword is a built-in command, but I have no help for it yet.";
|
||||
}
|
||||
|
||||
|
|
@ -119,35 +116,15 @@ sub cmd_help {
|
|||
|
||||
my $help = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, 'help');
|
||||
|
||||
if (not defined $help or not length $help) { return "/say $trigger_name is a factoid for $channel_name, but I have no help text for it yet. To add help text, use the command `factset $trigger_name help <text>`."; }
|
||||
if (not defined $help or not length $help) {
|
||||
return "/say $trigger_name is a factoid for $channel_name, but I have no help text for it yet."
|
||||
. " To add help text, use the command `factset $trigger_name help <text>`.";
|
||||
}
|
||||
|
||||
$result .= $help;
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub cmd_uptime {
|
||||
my ($self, $context) = @_;
|
||||
return localtime($self->{pbot}->{startup_timestamp}) . " [" . duration(time - $self->{pbot}->{startup_timestamp}) . "]";
|
||||
}
|
||||
|
||||
sub cmd_in_channel {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
my $usage = "Usage: in <channel> <command>";
|
||||
return $usage if not length $context->{arguments};
|
||||
|
||||
my ($channel, $command) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 2, 0, 1);
|
||||
return $usage if not defined $channel or not defined $command;
|
||||
|
||||
if (not $self->{pbot}->{nicklist}->is_present($channel, $context->{nick})) {
|
||||
return "You must be present in $channel to do this.";
|
||||
}
|
||||
|
||||
$context->{from} = $channel;
|
||||
$context->{command} = $command;
|
||||
return $self->{pbot}->{interpreter}->interpret($context);
|
||||
}
|
||||
|
||||
sub register {
|
||||
my ($self, $subref, $name, $requires_cap) = @_;
|
||||
Carp::croak("Missing parameters to Commands::register") if not defined $subref or not defined $name;
|
||||
|
|
@ -156,12 +133,15 @@ sub register {
|
|||
$ref->{name} = lc $name;
|
||||
$ref->{requires_cap} = $requires_cap // 0;
|
||||
|
||||
if (not $self->{metadata}->exists($name)) { $self->{metadata}->add($name, {requires_cap => $requires_cap, help => ''}, 1); }
|
||||
else {
|
||||
if (not defined $self->get_meta($name, 'requires_cap')) { $self->{metadata}->set($name, 'requires_cap', $requires_cap, 1); }
|
||||
if (not $self->{metadata}->exists($name)) {
|
||||
$self->{metadata}->add($name, {requires_cap => $requires_cap, help => ''}, 1);
|
||||
} else {
|
||||
if (not defined $self->get_meta($name, 'requires_cap')) {
|
||||
$self->{metadata}->set($name, 'requires_cap', $requires_cap, 1);
|
||||
}
|
||||
}
|
||||
|
||||
# add can-cmd capability
|
||||
# add can-cmd capability if command requires such
|
||||
$self->{pbot}->{capabilities}->add("can-$name", undef, 1) if $requires_cap;
|
||||
return $ref;
|
||||
}
|
||||
|
|
@ -207,7 +187,10 @@ sub interpreter {
|
|||
my $from = $context->{from};
|
||||
|
||||
my ($cmd_channel) = $context->{arguments} =~ m/\B(#[^ ]+)/; # assume command is invoked in regards to first channel-like argument
|
||||
$cmd_channel = $from if not defined $cmd_channel; # otherwise command is invoked in regards to the channel the user is in
|
||||
$cmd_channel = $from if not defined $cmd_channel; # otherwise command is invoked in regards to the channel the user is in
|
||||
|
||||
$context->{channel} = $cmd_channel;
|
||||
|
||||
my $user = $self->{pbot}->{users}->find_user($cmd_channel, "$context->{nick}!$context->{user}\@$context->{host}");
|
||||
|
||||
my $cap_override;
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ sub load {
|
|||
return;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Loading $self->{name} from $filename ...\n");
|
||||
$self->{pbot}->{logger}->log("Loading $self->{name} from $filename\n");
|
||||
|
||||
if (not open(FILE, "< $filename")) {
|
||||
$self->{pbot}->{logger}->log("Skipping loading from file: Couldn't open $filename: $!\n");
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ use feature 'unicode_strings';
|
|||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_func(@_) }, 'func', 0);
|
||||
|
||||
$self->register(
|
||||
|
|
@ -50,15 +51,27 @@ sub initialize {
|
|||
|
||||
sub cmd_func {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
my $func = $self->{pbot}->{interpreter}->shift_arg($context->{arglist});
|
||||
return "Usage: func <keyword> [arguments]; see also: func help" if not defined $func;
|
||||
return "[No such func '$func']" if not exists $self->{funcs}->{$func};
|
||||
|
||||
if (not defined $func) {
|
||||
return "Usage: func <keyword> [arguments]; see also: func help";
|
||||
}
|
||||
|
||||
if (not exists $self->{funcs}->{$func}) {
|
||||
return "[No such func '$func']"
|
||||
}
|
||||
|
||||
my @params;
|
||||
while (defined(my $param = $self->{pbot}->{interpreter}->shift_arg($context->{arglist}))) { push @params, $param; }
|
||||
|
||||
while (defined(my $param = $self->{pbot}->{interpreter}->shift_arg($context->{arglist}))) {
|
||||
push @params, $param;
|
||||
}
|
||||
|
||||
my $result = $self->{funcs}->{$func}->{subref}->(@params);
|
||||
$result =~ s/\x1/1/g;
|
||||
|
||||
$result =~ s/\x1/1/g; # strip CTCP code
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
|
|
@ -74,26 +87,43 @@ sub unregister {
|
|||
|
||||
sub func_help {
|
||||
my ($self, $func) = @_;
|
||||
return "func: invoke built-in functions; usage: func <keyword> [arguments]; to list available functions: func list [regex]" if not length $func;
|
||||
return "No such func '$func'." if not exists $self->{funcs}->{$func};
|
||||
|
||||
if (not length $func) {
|
||||
return "func: invoke built-in functions; usage: func <keyword> [arguments]; to list available functions: func list [regex]";
|
||||
}
|
||||
|
||||
if (not exists $self->{funcs}->{$func}) {
|
||||
return "No such func '$func'.";
|
||||
}
|
||||
|
||||
return "$func: $self->{funcs}->{$func}->{desc}; usage: $self->{funcs}->{$func}->{usage}";
|
||||
}
|
||||
|
||||
sub func_list {
|
||||
my ($self, $regex) = @_;
|
||||
$regex = '.*' if not defined $regex;
|
||||
|
||||
$regex //= '.*';
|
||||
|
||||
my $result = eval {
|
||||
my $text = '';
|
||||
my @funcs;
|
||||
|
||||
foreach my $func (sort keys %{$self->{funcs}}) {
|
||||
if ($func =~ m/$regex/i or $self->{funcs}->{$func}->{desc} =~ m/$regex/i) { $text .= "$func, "; }
|
||||
if ($func =~ m/$regex/i or $self->{funcs}->{$func}->{desc} =~ m/$regex/i) {
|
||||
push @funcs, $func;
|
||||
}
|
||||
}
|
||||
|
||||
$text =~ s/,\s+$//;
|
||||
if (not length $text) {
|
||||
if ($regex eq '.*') { $text = "No funcs yet."; }
|
||||
else { $text = "No matching func."; }
|
||||
my $result = join ', ', @funcs;
|
||||
|
||||
if (not length $result) {
|
||||
if ($regex eq '.*') {
|
||||
$result = "No funcs yet.";
|
||||
} else {
|
||||
$result = "No matching func.";
|
||||
}
|
||||
}
|
||||
return "Available funcs: $text; see also: func help <keyword>";
|
||||
|
||||
return "Available funcs: $result; see also: func help <keyword>";
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
|
|
@ -101,6 +131,7 @@ sub func_list {
|
|||
$error =~ s/at PBot.Functions.*$//;
|
||||
return "Error: $error\n";
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ sub load {
|
|||
return;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Loading $self->{name} from $filename ...\n");
|
||||
$self->{pbot}->{logger}->log("Loading $self->{name} from $filename\n");
|
||||
|
||||
if (not open(FILE, "< $filename")) {
|
||||
$self->{pbot}->{logger}->log("Skipping loading from file: Couldn't open $filename: $!\n");
|
||||
|
|
|
|||
|
|
@ -47,6 +47,8 @@ sub process_line {
|
|||
$flood_threshold = $pbot->{registry}->get_value('antiflood', 'chat_flood_threshold') if not defined $flood_threshold;
|
||||
$flood_time_threshold = $pbot->{registry}->get_value('antiflood', 'chat_flood_time_threshold') if not defined $flood_time_threshold;
|
||||
|
||||
|
||||
=cut
|
||||
if (defined $from and $from =~ m/^#/) {
|
||||
my $chanmodes = $self->{pbot}->{channels}->get_meta($from, 'MODE');
|
||||
if (defined $chanmodes and $chanmodes =~ m/z/) {
|
||||
|
|
@ -59,6 +61,7 @@ sub process_line {
|
|||
$context->{banned} = 1 if $self->{pbot}->{banlist}->is_banned($nick, $user, $host, $from);
|
||||
}
|
||||
}
|
||||
=cut
|
||||
|
||||
$pbot->{antiflood}->check_flood(
|
||||
$from, $nick, $user, $host, $text,
|
||||
|
|
@ -66,10 +69,12 @@ sub process_line {
|
|||
$pbot->{messagehistory}->{MSG_CHAT}, $context
|
||||
) if defined $from;
|
||||
|
||||
=cut
|
||||
if ($context->{banned} or $context->{unidentified}) {
|
||||
$self->{pbot}->{logger}->log("Disregarding banned/unidentified user message (channel $from is +z).\n");
|
||||
return 1;
|
||||
}
|
||||
=cut
|
||||
|
||||
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
|
||||
|
||||
|
|
|
|||
|
|
@ -20,11 +20,21 @@ use Time::Duration;
|
|||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{lag_average} = undef; # average of entries in lag history, in seconds
|
||||
$self->{lag_string} = undef; # string representation of lag history and lag average
|
||||
$self->{lag_history} = []; # history of previous PING/PONG timings
|
||||
$self->{pong_received} = undef; # tracks pong replies; undef if no ping sent; 0 if ping sent but no pong reply yet; 1 if ping/pong completed
|
||||
$self->{ping_send_time} = undef; # when last ping was sent
|
||||
|
||||
# average of entries in lag history, in seconds
|
||||
$self->{lag_average} = undef;
|
||||
|
||||
# string representation of lag history and lag average
|
||||
$self->{lag_string} = undef;
|
||||
|
||||
# history of previous PING/PONG timings
|
||||
$self->{lag_history} = [];
|
||||
|
||||
# tracks pong replies; undef if no ping sent; 0 if ping sent but no pong reply yet; 1 if ping/pong completed
|
||||
$self->{pong_received} = undef;
|
||||
|
||||
# when last ping was sent
|
||||
$self->{ping_send_time} = undef;
|
||||
|
||||
# maximum number of lag history entries to retain
|
||||
$self->{pbot}->{registry}->add_default('text', 'lagchecker', 'lag_history_max', $conf{lag_history_max} // 3);
|
||||
|
|
@ -35,85 +45,30 @@ sub initialize {
|
|||
# how often to send PING, in seconds
|
||||
$self->{pbot}->{registry}->add_default('text', 'lagchecker', 'lag_history_interval', $conf{lag_history_interval} // 10);
|
||||
|
||||
$self->{pbot}->{registry}->add_trigger('lagchecker', 'lag_history_interval', sub { $self->lag_history_interval_trigger(@_) });
|
||||
# registry trigger for lag_history_interval changes
|
||||
$self->{pbot}->{registry}->add_trigger('lagchecker', 'lag_history_interval', sub { $self->trigger_lag_history_interval(@_) });
|
||||
|
||||
# timer to send PINGs
|
||||
$self->{pbot}->{timer}->register(
|
||||
sub { $self->send_ping },
|
||||
$self->{pbot}->{registry}->get_value('lagchecker', 'lag_history_interval'),
|
||||
'lag check'
|
||||
);
|
||||
|
||||
# lagcheck bot command
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_lagcheck(@_) }, "lagcheck", 0);
|
||||
|
||||
# PONG IRC handler
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.pong', sub { $self->on_pong(@_) });
|
||||
}
|
||||
|
||||
sub lag_history_interval_trigger {
|
||||
# registry trigger fires when value changes
|
||||
sub trigger_lag_history_interval {
|
||||
my ($self, $section, $item, $newvalue) = @_;
|
||||
$self->{pbot}->{timer}->update_interval('lag check', $newvalue);
|
||||
}
|
||||
|
||||
sub send_ping {
|
||||
my $self = shift;
|
||||
return unless defined $self->{pbot}->{conn};
|
||||
$self->{ping_send_time} = [gettimeofday];
|
||||
$self->{pong_received} = 0;
|
||||
$self->{pbot}->{conn}->sl("PING :lagcheck");
|
||||
}
|
||||
|
||||
sub on_pong {
|
||||
my $self = shift;
|
||||
|
||||
$self->{pong_received} = 1;
|
||||
|
||||
my $elapsed = tv_interval($self->{ping_send_time});
|
||||
push @{$self->{lag_history}}, [$self->{ping_send_time}[0], $elapsed * 1000];
|
||||
|
||||
my $len = @{$self->{lag_history}};
|
||||
|
||||
my $lag_history_max = $self->{pbot}->{registry}->get_value('lagchecker', 'lag_history_max');
|
||||
|
||||
while ($len > $lag_history_max) {
|
||||
shift @{$self->{lag_history}};
|
||||
$len--;
|
||||
}
|
||||
|
||||
$self->{lag_string} = "";
|
||||
my $comma = "";
|
||||
|
||||
my $lag_total = 0;
|
||||
foreach my $entry (@{$self->{lag_history}}) {
|
||||
my ($send_time, $lag_result) = @$entry;
|
||||
|
||||
$lag_total += $lag_result;
|
||||
my $ago = concise ago(gettimeofday - $send_time);
|
||||
$self->{lag_string} .= $comma . "[$ago] " . sprintf "%.1f ms", $lag_result;
|
||||
$comma = "; ";
|
||||
}
|
||||
|
||||
$self->{lag_average} = $lag_total / $len;
|
||||
$self->{lag_string} .= "; average: " . sprintf "%.1f ms", $self->{lag_average};
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub lagging {
|
||||
my $self = shift;
|
||||
|
||||
if (defined $self->{pong_received} and $self->{pong_received} == 0) {
|
||||
# a ping has been sent (pong_received is not undef) and no pong has been received yet
|
||||
my $elapsed = tv_interval($self->{ping_send_time});
|
||||
return $elapsed >= $self->{pbot}->{registry}->get_value('lagchecker', 'lag_threshold');
|
||||
}
|
||||
|
||||
return 0 if not defined $self->{lag_average};
|
||||
return $self->{lag_average} >= $self->{pbot}->{registry}->get_value('lagchecker', 'lag_threshold');
|
||||
}
|
||||
|
||||
sub lagstring {
|
||||
my $self = shift;
|
||||
my $lag = $self->{lag_string} || "initializing";
|
||||
return $lag;
|
||||
}
|
||||
|
||||
# lagcheck bot command
|
||||
sub cmd_lagcheck {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
|
|
@ -144,4 +99,81 @@ sub cmd_lagcheck {
|
|||
return "My lag: " . $self->lagstring;
|
||||
}
|
||||
|
||||
|
||||
sub send_ping {
|
||||
my $self = shift;
|
||||
|
||||
return unless defined $self->{pbot}->{conn};
|
||||
|
||||
$self->{ping_send_time} = [gettimeofday];
|
||||
$self->{pong_received} = 0;
|
||||
|
||||
$self->{pbot}->{conn}->sl("PING :lagcheck");
|
||||
}
|
||||
|
||||
sub on_pong {
|
||||
my $self = shift;
|
||||
|
||||
$self->{pong_received} = 1;
|
||||
|
||||
my $elapsed = tv_interval($self->{ping_send_time});
|
||||
|
||||
push @{$self->{lag_history}}, [$self->{ping_send_time}[0], $elapsed * 1000];
|
||||
|
||||
my $len = @{$self->{lag_history}};
|
||||
|
||||
my $lag_history_max = $self->{pbot}->{registry}->get_value('lagchecker', 'lag_history_max');
|
||||
|
||||
while ($len > $lag_history_max) {
|
||||
shift @{$self->{lag_history}};
|
||||
$len--;
|
||||
}
|
||||
|
||||
$self->{lag_string} = '';
|
||||
|
||||
my @entries;
|
||||
my $lag_total = 0;
|
||||
|
||||
foreach my $entry (@{$self->{lag_history}}) {
|
||||
my ($send_time, $lag_result) = @$entry;
|
||||
|
||||
$lag_total += $lag_result;
|
||||
|
||||
my $ago = concise ago(gettimeofday - $send_time);
|
||||
|
||||
push @entries, "[$ago] " . sprintf "%.1f ms", $lag_result;
|
||||
}
|
||||
|
||||
$self->{lag_string} = join '; ', @entries;
|
||||
|
||||
$self->{lag_average} = $lag_total / $len;
|
||||
|
||||
$self->{lag_string} .= "; average: " . sprintf "%.1f ms", $self->{lag_average};
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub lagging {
|
||||
my ($self) = @_;
|
||||
|
||||
if (defined $self->{pong_received} and $self->{pong_received} == 0) {
|
||||
# a ping has been sent (pong_received is not undef) and no pong has been received yet
|
||||
my $elapsed = tv_interval($self->{ping_send_time});
|
||||
|
||||
return $elapsed >= $self->{pbot}->{registry}->get_value('lagchecker', 'lag_threshold');
|
||||
}
|
||||
|
||||
return 0 if not defined $self->{lag_average};
|
||||
|
||||
return $self->{lag_average} >= $self->{pbot}->{registry}->get_value('lagchecker', 'lag_threshold');
|
||||
}
|
||||
|
||||
sub lagstring {
|
||||
my ($self) = @_;
|
||||
|
||||
my $lag = $self->{lag_string} || "initializing";
|
||||
|
||||
return $lag;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,216 @@
|
|||
# File: Commands.pm
|
||||
#
|
||||
# Author: pragma_
|
||||
#
|
||||
# Purpose: Registers misc PBot commands.
|
||||
|
||||
# This Source Code Form is subject to the terms of the Mozilla Public
|
||||
# License, v. 2.0. If a copy of the MPL was not distributed with this
|
||||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::MiscCommands;
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
use feature 'unicode_strings';
|
||||
|
||||
use Time::Duration qw/duration/;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
|
||||
# misc commands
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_nop(@_) }, 'nop', 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_uptime(@_) }, 'uptime', 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_in_channel(@_) }, 'in', 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_list(@_) }, 'list', 0);
|
||||
|
||||
# misc administrative commands
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_sl(@_) }, 'sl', 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_die(@_) }, 'die', 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_export(@_) }, 'export', 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_eval(@_) }, 'eval', 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_reload(@_) }, 'reload', 1);
|
||||
|
||||
# misc capabilities
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-in', 1);
|
||||
}
|
||||
|
||||
sub cmd_nop {
|
||||
my ($self, $context) = @_;
|
||||
$self->{pbot}->{logger}->log("Disregarding NOP command.\n");
|
||||
return '';
|
||||
}
|
||||
|
||||
sub cmd_uptime {
|
||||
my ($self, $context) = @_;
|
||||
return localtime($self->{pbot}->{startup_timestamp}) . ' [' . duration(time - $self->{pbot}->{startup_timestamp}) . ']';
|
||||
}
|
||||
|
||||
sub cmd_in_channel {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
my $usage = 'Usage: in <channel> <command>';
|
||||
return $usage if not length $context->{arguments};
|
||||
|
||||
my ($channel, $command) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 2, 0, 1);
|
||||
return $usage if not defined $channel or not defined $command;
|
||||
|
||||
if (not $self->{pbot}->{nicklist}->is_present($channel, $context->{nick})) {
|
||||
return "You must be present in $channel to do this.";
|
||||
}
|
||||
|
||||
$context->{from} = $channel;
|
||||
$context->{command} = $command;
|
||||
return $self->{pbot}->{interpreter}->interpret($context);
|
||||
}
|
||||
|
||||
sub cmd_list {
|
||||
my ($self, $context) = @_;
|
||||
my $text;
|
||||
|
||||
my $usage = 'Usage: list <modules|commands>';
|
||||
|
||||
return $usage if not length $context->{arguments};
|
||||
|
||||
if ($context->{arguments} =~ /^modules$/i) {
|
||||
$text = 'Loaded modules: ';
|
||||
foreach my $channel (sort $self->{pbot}->{factoids}->{factoids}->get_keys) {
|
||||
foreach my $command (sort $self->{pbot}->{factoids}->{factoids}->get_keys($channel)) {
|
||||
next if $command eq '_name';
|
||||
if ($self->{pbot}->{factoids}->{factoids}->get_data($channel, $command, 'type') eq 'module') {
|
||||
$text .= $self->{pbot}->{factoids}->{factoids}->get_data($channel, $command, '_name') . ' ';
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $text;
|
||||
}
|
||||
|
||||
if ($context->{arguments} =~ /^commands$/i) {
|
||||
$text = 'Registered commands: ';
|
||||
foreach my $command (sort { $a->{name} cmp $b->{name} } @{$self->{pbot}->{commands}->{handlers}}) {
|
||||
if ($command->{requires_cap}) {
|
||||
$text .= "+$command->{name} ";
|
||||
} else {
|
||||
$text .= "$command->{name} ";
|
||||
}
|
||||
}
|
||||
|
||||
return $text;
|
||||
}
|
||||
|
||||
return $usage;
|
||||
}
|
||||
|
||||
sub cmd_sl {
|
||||
my ($self, $context) = @_;
|
||||
return "Usage: sl <ircd command>" if not length $context->{arguments};
|
||||
$self->{pbot}->{conn}->sl($context->{arguments});
|
||||
return "/msg $context->{nick} sl: command sent. See log for result.";
|
||||
}
|
||||
|
||||
sub cmd_die {
|
||||
my ($self, $context) = @_;
|
||||
$self->{pbot}->{logger}->log("$context->{hostmask} made me exit.\n");
|
||||
$self->{pbot}->{conn}->privmsg($context->{from}, "Good-bye.") if $context->{from} ne 'stdin@pbot';
|
||||
$self->{pbot}->{conn}->quit("Departure requested.") if defined $self->{pbot}->{conn};
|
||||
$self->pbot->atexit();
|
||||
exit 0;
|
||||
}
|
||||
|
||||
sub cmd_export {
|
||||
my ($self, $context) = @_;
|
||||
return "Usage: export <factoids>" if not length $context->{arguments};
|
||||
if ($context->{arguments} =~ /^factoids$/i) { return $self->{pbot}->{factoids}->export_factoids; }
|
||||
}
|
||||
|
||||
sub cmd_eval {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
$self->{pbot}->{logger}->log("eval: $context->{from} $context->{hostmask} evaluating `$context->{arguments}`\n");
|
||||
|
||||
my $ret = '';
|
||||
my $result = eval $context->{arguments};
|
||||
if ($@) {
|
||||
if (length $result) { $ret .= "[Error: $@] "; }
|
||||
else { $ret .= "Error: $@"; }
|
||||
$ret =~ s/ at \(eval \d+\) line 1.//;
|
||||
}
|
||||
$result = 'Undefined.' if not defined $result;
|
||||
$result = 'No output.' if not length $result;
|
||||
return "/say $ret $result";
|
||||
}
|
||||
|
||||
sub cmd_reload {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
my %reloadables = (
|
||||
'capabilities' => sub {
|
||||
$self->{pbot}->{capabilities}->{caps}->load;
|
||||
return "Capabilities reloaded.";
|
||||
},
|
||||
|
||||
'commands' => sub {
|
||||
$self->{pbot}->{commands}->{metadata}->load;
|
||||
return "Commands metadata reloaded.";
|
||||
},
|
||||
|
||||
'blacklist' => sub {
|
||||
$self->{pbot}->{blacklist}->clear_blacklist;
|
||||
$self->{pbot}->{blacklist}->load_blacklist;
|
||||
return "Blacklist reloaded.";
|
||||
},
|
||||
|
||||
'ban-exemptions' => sub {
|
||||
$self->{pbot}->{antiflood}->{'ban-exemptions'}->load;
|
||||
return "Ban exemptions reloaded.";
|
||||
},
|
||||
|
||||
'ignores' => sub {
|
||||
$self->{pbot}->{ignorelist}->{ignorelist}->load;
|
||||
return "Ignore list reloaded.";
|
||||
},
|
||||
|
||||
'users' => sub {
|
||||
$self->{pbot}->{users}->load;
|
||||
return "Users reloaded.";
|
||||
},
|
||||
|
||||
'channels' => sub {
|
||||
$self->{pbot}->{channels}->{channels}->load;
|
||||
return "Channels reloaded.";
|
||||
},
|
||||
|
||||
'banlist' => sub {
|
||||
$self->{pbot}->{timer}->dequeue_event('unban #.*');
|
||||
$self->{pbot}->{timer}->dequeue_event('unmute #.*');
|
||||
$self->{pbot}->{banlist}->{banlist}->load;
|
||||
$self->{pbot}->{banlist}->{quietlist}->load;
|
||||
$self->{pbot}->{banlist}->enqueue_timeouts($self->{pbot}->{banlist}->{banlist}, 'b');
|
||||
$self->{pbot}->{banlist}->enqueue_timeouts($self->{pbot}->{banlist}->{quietlist}, 'q');
|
||||
return "Ban list reloaded.";
|
||||
},
|
||||
|
||||
'registry' => sub {
|
||||
$self->{pbot}->{registry}->load;
|
||||
return "Registry reloaded.";
|
||||
},
|
||||
|
||||
'factoids' => sub {
|
||||
$self->{pbot}->{factoids}->load_factoids;
|
||||
return "Factoids reloaded.";
|
||||
}
|
||||
);
|
||||
|
||||
if (not length $context->{arguments} or not exists $reloadables{$context->{arguments}}) {
|
||||
my $usage = 'Usage: reload <';
|
||||
$usage .= join '|', sort keys %reloadables;
|
||||
$usage .= '>';
|
||||
return $usage;
|
||||
}
|
||||
|
||||
return $reloadables{$context->{arguments}}();
|
||||
}
|
||||
|
||||
1;
|
||||
183
PBot/NickList.pm
183
PBot/NickList.pm
|
|
@ -27,11 +27,18 @@ use Getopt::Long qw/GetOptionsFromArray/;
|
|||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
|
||||
# nicklist hash
|
||||
$self->{nicklist} = {};
|
||||
|
||||
# nicklist debug registry entry
|
||||
$self->{pbot}->{registry}->add_default('text', 'nicklist', 'debug', '0');
|
||||
|
||||
# nicklist bot command
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_nicklist(@_) }, "nicklist", 1);
|
||||
|
||||
# handlers for various IRC events
|
||||
# TODO: track mode changes to update user flags
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.namreply', sub { $self->on_namreply(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.join', sub { $self->on_join(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.part', sub { $self->on_part(@_) });
|
||||
|
|
@ -42,15 +49,14 @@ sub initialize {
|
|||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->on_activity(@_) });
|
||||
|
||||
# handlers for the bot itself joining/leaving channels
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('pbot.join', sub { $self->on_join_channel(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('pbot.part', sub { $self->on_part_channel(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('pbot.join', sub { $self->on_self_join(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('pbot.part', sub { $self->on_self_part(@_) });
|
||||
}
|
||||
|
||||
sub cmd_nicklist {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
my $nicklist;
|
||||
my $usage = "Usage: nicklist (<channel [nick]> | <nick>) [-sort <by>] [-hostmask] [-join]; -hostmask to show hostmasks instead of nicks; -join to include join time";
|
||||
my $usage = "Usage: nicklist (<channel [nick]> | <nick>) [-sort <by>] [-hostmask] [-join]; -hostmask shows hostmasks instead of nicks; -join includes join time";
|
||||
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
|
|
@ -60,17 +66,19 @@ sub cmd_nicklist {
|
|||
|
||||
Getopt::Long::Configure("bundling_override");
|
||||
|
||||
my $sort_method = 'nick';
|
||||
my $sort_method = 'nick';
|
||||
my $full_hostmask = 0;
|
||||
my $include_join = 0;
|
||||
my $include_join = 0;
|
||||
|
||||
my @args = $self->{pbot}->{interpreter}->split_line($context->{arguments}, strip_quotes => 1);
|
||||
|
||||
GetOptionsFromArray(
|
||||
\@args,
|
||||
'sort|s=s' => \$sort_method,
|
||||
'hostmask|hm' => \$full_hostmask,
|
||||
'join|j' => \$include_join,
|
||||
);
|
||||
|
||||
return "$getopt_error; $usage" if defined $getopt_error;
|
||||
return "Too many arguments -- $usage" if @args > 2;
|
||||
return $usage if @args == 0 or not length $args[0];
|
||||
|
|
@ -110,6 +118,7 @@ sub cmd_nicklist {
|
|||
);
|
||||
|
||||
my $sort_direction = '+';
|
||||
|
||||
if ($sort_method =~ s/^(\+|\-)//) {
|
||||
$sort_direction = $1;
|
||||
}
|
||||
|
|
@ -118,87 +127,96 @@ sub cmd_nicklist {
|
|||
return "Invalid sort method '$sort_method'; valid methods are: " . join(', ', sort keys %sort) . "; prefix with - to invert sort direction.";
|
||||
}
|
||||
|
||||
# insert from channel as first argument if first argument is not a channel
|
||||
if ($args[0] !~ /^#/) {
|
||||
unshift @args, $context->{from};
|
||||
}
|
||||
|
||||
# ensure channel has a nicklist
|
||||
if (not exists $self->{nicklist}->{lc $args[0]}) {
|
||||
return "No nicklist for channel $args[0].";
|
||||
}
|
||||
|
||||
my $result;
|
||||
|
||||
if (@args == 1) {
|
||||
if (not exists $self->{nicklist}->{lc $args[0]}) {
|
||||
return "No nicklist for channel $args[0].";
|
||||
}
|
||||
# nicklist for a specific channel
|
||||
|
||||
my $count = keys %{$self->{nicklist}->{lc $args[0]}};
|
||||
$nicklist = "$count nick" . ($count == 1 ? '' : 's') . " in $args[0]:\n";
|
||||
|
||||
$result = "$count nick" . ($count == 1 ? '' : 's') . " in $args[0]:\n";
|
||||
|
||||
foreach my $entry (sort { $sort{$sort_method}->($self->{nicklist}->{lc $args[0]}, $sort_direction) } keys %{$self->{nicklist}->{lc $args[0]}}) {
|
||||
if ($full_hostmask) {
|
||||
$nicklist .= " $self->{nicklist}->{lc $args[0]}->{$entry}->{hostmask}";
|
||||
$result .= " $self->{nicklist}->{lc $args[0]}->{$entry}->{hostmask}";
|
||||
} else {
|
||||
$nicklist .= " $self->{nicklist}->{lc $args[0]}->{$entry}->{nick}";
|
||||
$result .= " $self->{nicklist}->{lc $args[0]}->{$entry}->{nick}";
|
||||
}
|
||||
|
||||
my $sep = ': ';
|
||||
|
||||
if ($self->{nicklist}->{lc $args[0]}->{$entry}->{timestamp} > 0) {
|
||||
my $duration = concise ago (gettimeofday - $self->{nicklist}->{lc $args[0]}->{$entry}->{timestamp});
|
||||
$nicklist .= "${sep}last spoken $duration";
|
||||
$result .= "${sep}last spoken $duration";
|
||||
$sep = ', ';
|
||||
}
|
||||
|
||||
if ($include_join and $self->{nicklist}->{lc $args[0]}->{$entry}->{join} > 0) {
|
||||
my $duration = concise ago (gettimeofday - $self->{nicklist}->{lc $args[0]}->{$entry}->{join});
|
||||
$nicklist .= "${sep}joined $duration";
|
||||
$result .= "${sep}joined $duration";
|
||||
$sep = ', ';
|
||||
}
|
||||
|
||||
foreach my $key (sort keys %{$self->{nicklist}->{lc $args[0]}->{$entry}}) {
|
||||
next if grep { $key eq $_ } qw/nick user host join timestamp hostmask/;
|
||||
if ($self->{nicklist}->{lc $args[0]}->{$entry}->{$key} == 1) {
|
||||
$nicklist .= "$sep$key";
|
||||
$result .= "$sep$key";
|
||||
} else {
|
||||
$nicklist .= "$sep$key => $self->{nicklist}->{lc $args[0]}->{$entry}->{$key}";
|
||||
$result .= "$sep$key => $self->{nicklist}->{lc $args[0]}->{$entry}->{$key}";
|
||||
}
|
||||
$sep = ', ';
|
||||
}
|
||||
$nicklist .= "\n";
|
||||
$result .= "\n";
|
||||
}
|
||||
} else {
|
||||
if (not exists $self->{nicklist}->{lc $args[0]}) {
|
||||
return "No nicklist for channel $args[0].";
|
||||
} elsif (not exists $self->{nicklist}->{lc $args[0]}->{lc $args[1]}) {
|
||||
# nicklist for a specific user
|
||||
|
||||
if (not exists $self->{nicklist}->{lc $args[0]}->{lc $args[1]}) {
|
||||
return "No such nick $args[1] in channel $args[0].";
|
||||
}
|
||||
|
||||
$nicklist = "Nicklist information for $self->{nicklist}->{lc $args[0]}->{lc $args[1]}->{hostmask} in $args[0]: ";
|
||||
$result = "Nicklist information for $self->{nicklist}->{lc $args[0]}->{lc $args[1]}->{hostmask} in $args[0]: ";
|
||||
my $sep = '';
|
||||
|
||||
if ($self->{nicklist}->{lc $args[0]}->{lc $args[1]}->{timestamp} > 0) {
|
||||
my $duration = concise ago (gettimeofday - $self->{nicklist}->{lc $args[0]}->{lc $args[1]}->{timestamp});
|
||||
$nicklist .= "last spoken $duration";
|
||||
$result .= "last spoken $duration";
|
||||
$sep = ', ';
|
||||
}
|
||||
|
||||
if ($self->{nicklist}->{lc $args[0]}->{lc $args[1]}->{join} > 0) {
|
||||
my $duration = concise ago (gettimeofday - $self->{nicklist}->{lc $args[0]}->{lc $args[1]}->{join});
|
||||
$nicklist .= "${sep}joined $duration";
|
||||
$result .= "${sep}joined $duration";
|
||||
$sep = ', ';
|
||||
}
|
||||
|
||||
foreach my $key (sort keys %{$self->{nicklist}->{lc $args[0]}->{lc $args[1]}}) {
|
||||
next if grep { $key eq $_ } qw/nick user host join timestamp hostmask/;
|
||||
$nicklist .= "$sep$key => $self->{nicklist}->{lc $args[0]}->{lc $args[1]}->{$key}";
|
||||
$result .= "$sep$key => $self->{nicklist}->{lc $args[0]}->{lc $args[1]}->{$key}";
|
||||
$sep = ', ';
|
||||
}
|
||||
|
||||
$nicklist .= 'no details' if $sep eq '';
|
||||
$result .= 'no details' if $sep eq '';
|
||||
}
|
||||
|
||||
return $nicklist;
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub update_timestamp {
|
||||
my ($self, $channel, $nick) = @_;
|
||||
|
||||
my $orig_nick = $nick;
|
||||
|
||||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
|
||||
|
|
@ -216,6 +234,7 @@ sub remove_channel {
|
|||
|
||||
sub add_nick {
|
||||
my ($self, $channel, $nick) = @_;
|
||||
|
||||
if (not exists $self->{nicklist}->{lc $channel}->{lc $nick}) {
|
||||
$self->{pbot}->{logger}->log("Adding nick '$nick' to channel '$channel'\n") if $self->{pbot}->{registry}->get_value('nicklist', 'debug');
|
||||
$self->{nicklist}->{lc $channel}->{lc $nick} = {nick => $nick, timestamp => 0};
|
||||
|
|
@ -230,12 +249,15 @@ sub remove_nick {
|
|||
|
||||
sub get_channels {
|
||||
my ($self, $nick) = @_;
|
||||
my @channels;
|
||||
|
||||
$nick = lc $nick;
|
||||
|
||||
my @channels;
|
||||
|
||||
foreach my $channel (keys %{$self->{nicklist}}) {
|
||||
if (exists $self->{nicklist}->{$channel}->{$nick}) { push @channels, $channel; }
|
||||
if (exists $self->{nicklist}->{$channel}->{$nick}) {
|
||||
push @channels, $channel;
|
||||
}
|
||||
}
|
||||
|
||||
return \@channels;
|
||||
|
|
@ -243,10 +265,17 @@ sub get_channels {
|
|||
|
||||
sub get_nicks {
|
||||
my ($self, $channel) = @_;
|
||||
|
||||
$channel = lc $channel;
|
||||
|
||||
my @nicks;
|
||||
|
||||
return @nicks if not exists $self->{nicklist}->{$channel};
|
||||
foreach my $nick (keys %{$self->{nicklist}->{$channel}}) { push @nicks, $self->{nicklist}->{$channel}->{$nick}->{nick}; }
|
||||
|
||||
foreach my $nick (keys %{$self->{nicklist}->{$channel}}) {
|
||||
push @nicks, $self->{nicklist}->{$channel}->{$nick}->{nick};
|
||||
}
|
||||
|
||||
return @nicks;
|
||||
}
|
||||
|
||||
|
|
@ -259,16 +288,19 @@ sub set_meta {
|
|||
if (not exists $self->{nicklist}->{$channel} or not exists $self->{nicklist}->{$channel}->{$nick}) {
|
||||
if (exists $self->{nicklist}->{$channel} and $nick =~ m/[*?]/) {
|
||||
my $regex = quotemeta $nick;
|
||||
|
||||
$regex =~ s/\\\*/.*?/g;
|
||||
$regex =~ s/\\\?/./g;
|
||||
|
||||
my $found = 0;
|
||||
|
||||
foreach my $n (keys %{$self->{nicklist}->{$channel}}) {
|
||||
if (exists $self->{nicklist}->{$channel}->{$n}->{hostmask} and $self->{nicklist}->{$channel}->{$n}->{hostmask} =~ m/$regex/i) {
|
||||
$self->{nicklist}->{$channel}->{$n}->{$key} = $value;
|
||||
$found++;
|
||||
}
|
||||
}
|
||||
|
||||
return $found;
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("Nicklist: Attempt to set invalid meta ($key => $value) for $nick in $channel.\n");
|
||||
|
|
@ -289,6 +321,7 @@ sub delete_meta {
|
|||
if (not exists $self->{nicklist}->{$channel} or not exists $self->{nicklist}->{$channel}->{$nick} or not exists $self->{nicklist}->{$channel}->{$nick}->{$key}) {
|
||||
return undef;
|
||||
}
|
||||
|
||||
return delete $self->{nicklist}->{$channel}->{$nick}->{$key};
|
||||
}
|
||||
|
||||
|
|
@ -311,8 +344,11 @@ sub is_present_any_channel {
|
|||
$nick = lc $nick;
|
||||
|
||||
foreach my $channel (keys %{$self->{nicklist}}) {
|
||||
if (exists $self->{nicklist}->{$channel}->{$nick}) { return $self->{nicklist}->{$channel}->{$nick}->{nick}; }
|
||||
if (exists $self->{nicklist}->{$channel}->{$nick}) {
|
||||
return $self->{nicklist}->{$channel}->{$nick}->{nick};
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
@ -322,8 +358,11 @@ sub is_present {
|
|||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
|
||||
if (exists $self->{nicklist}->{$channel} and exists $self->{nicklist}->{$channel}->{$nick}) { return $self->{nicklist}->{$channel}->{$nick}->{nick}; }
|
||||
else { return 0; }
|
||||
if (exists $self->{nicklist}->{$channel} and exists $self->{nicklist}->{$channel}->{$nick}) {
|
||||
return $self->{nicklist}->{$channel}->{$nick}->{nick};
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub is_present_similar {
|
||||
|
|
@ -332,24 +371,42 @@ sub is_present_similar {
|
|||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
|
||||
return 0 if not exists $self->{nicklist}->{$channel};
|
||||
return 0 if not exists $self->{nicklist}->{$channel};
|
||||
|
||||
return $self->{nicklist}->{$channel}->{$nick}->{nick} if $self->is_present($channel, $nick);
|
||||
return 0 if $nick =~ m/(?:^\$|\s)/; # not nick-like
|
||||
|
||||
my $percentage = $self->{pbot}->{registry}->get_value('interpreter', 'nick_similarity');
|
||||
$percentage = 0.20 if not defined $percentage;
|
||||
if ($nick =~ m/(?:^\$|\s)/) {
|
||||
# not nick-like
|
||||
# TODO: why do we have this check? added log message to find out when/if it happens
|
||||
$self->{pbot}->{logger}->log("NickList::is_present_similiar [$channel] [$nick] is not nick-like?\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
$percentage = $similar if defined $similar;
|
||||
my $percentage;
|
||||
|
||||
if (defined $similar) {
|
||||
$percentage = $similar;
|
||||
} else {
|
||||
$percentage = $self->{pbot}->{registry}->get_value('interpreter', 'nick_similarity') // 0.20;
|
||||
}
|
||||
|
||||
my $now = gettimeofday;
|
||||
foreach my $person (sort { $self->{nicklist}->{$channel}->{$b}->{timestamp} <=> $self->{nicklist}->{$channel}->{$a}->{timestamp} } keys %{$self->{nicklist}->{$channel}})
|
||||
{
|
||||
return 0 if $now - $self->{nicklist}->{$channel}->{$person}->{timestamp} > 3600; # 1 hour
|
||||
|
||||
foreach my $person (sort { $self->{nicklist}->{$channel}->{$b}->{timestamp} <=> $self->{nicklist}->{$channel}->{$a}->{timestamp} } keys %{$self->{nicklist}->{$channel}}) {
|
||||
if ($now - $self->{nicklist}->{$channel}->{$person}->{timestamp} > 3600) {
|
||||
# if it has been 1 hour since this person has last spoken, the similar nick
|
||||
# is probably not intended for them.
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $distance = fastdistance($nick, $person);
|
||||
my $length = length $nick > length $person ? length $nick : length $person;
|
||||
|
||||
if ($length != 0 && $distance / $length <= $percentage) { return $self->{nicklist}->{$channel}->{$person}->{nick}; }
|
||||
if ($length != 0 && $distance / $length <= $percentage) {
|
||||
return $self->{nicklist}->{$channel}->{$person}->{nick};
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
@ -360,9 +417,14 @@ sub random_nick {
|
|||
|
||||
if (exists $self->{nicklist}->{$channel}) {
|
||||
my $now = gettimeofday;
|
||||
|
||||
# build list of nicks that have spoken within the last 2 hours
|
||||
my @nicks = grep { $now - $self->{nicklist}->{$channel}->{$_}->{timestamp} < 3600 * 2 } keys %{$self->{nicklist}->{$channel}};
|
||||
|
||||
# pick a random nick from tha list
|
||||
my $nick = $nicks[rand @nicks];
|
||||
|
||||
# return its canonical name
|
||||
return $self->{nicklist}->{$channel}->{$nick}->{nick};
|
||||
} else {
|
||||
return undef;
|
||||
|
|
@ -375,7 +437,9 @@ sub on_namreply {
|
|||
|
||||
foreach my $nick (split ' ', $nicks) {
|
||||
my $stripped_nick = $nick;
|
||||
|
||||
$stripped_nick =~ s/^[@+%]//g; # remove OP/Voice/etc indicator from nick
|
||||
|
||||
$self->add_nick($channel, $stripped_nick);
|
||||
|
||||
my ($account_id, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($stripped_nick);
|
||||
|
|
@ -393,48 +457,66 @@ sub on_namreply {
|
|||
|
||||
if ($nick =~ m/\%/) { $self->set_meta($channel, $stripped_nick, '+h', 1); }
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_activity {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
|
||||
my ($nick, $user, $host, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->{to}[0]);
|
||||
|
||||
$self->update_timestamp($channel, $nick);
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_join {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
|
||||
my ($nick, $user, $host, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to);
|
||||
|
||||
$self->add_nick($channel, $nick);
|
||||
|
||||
$self->set_meta($channel, $nick, 'hostmask', "$nick!$user\@$host");
|
||||
$self->set_meta($channel, $nick, 'user', $user);
|
||||
$self->set_meta($channel, $nick, 'host', $host);
|
||||
$self->set_meta($channel, $nick, 'join', gettimeofday);
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_part {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
|
||||
my ($nick, $user, $host, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to);
|
||||
|
||||
$self->remove_nick($channel, $nick);
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_quit {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host);
|
||||
|
||||
my ($nick, $user, $host) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host);
|
||||
|
||||
foreach my $channel (keys %{$self->{nicklist}}) {
|
||||
if ($self->is_present($channel, $nick)) { $self->remove_nick($channel, $nick); }
|
||||
if ($self->is_present($channel, $nick)) {
|
||||
$self->remove_nick($channel, $nick);
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_kick {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
|
||||
my ($nick, $channel) = ($event->{event}->to, $event->{event}->{args}[0]);
|
||||
|
||||
$self->remove_nick($channel, $nick);
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
@ -445,23 +527,30 @@ sub on_nickchange {
|
|||
foreach my $channel (keys %{$self->{nicklist}}) {
|
||||
if ($self->is_present($channel, $nick)) {
|
||||
my $meta = delete $self->{nicklist}->{$channel}->{lc $nick};
|
||||
$meta->{nick} = $newnick;
|
||||
$meta->{timestamp} = gettimeofday;
|
||||
|
||||
$meta->{nick} = $newnick;
|
||||
$meta->{timestamp} = gettimeofday;
|
||||
|
||||
$self->{nicklist}->{$channel}->{lc $newnick} = $meta;
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_join_channel {
|
||||
sub on_self_join {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
|
||||
$self->remove_channel($event->{channel}); # clear nicklist to remove any stale nicks before repopulating with namreplies
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_part_channel {
|
||||
sub on_self_part {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
|
||||
$self->remove_channel($event->{channel});
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
|
|||
444
PBot/PBot.pm
444
PBot/PBot.pm
|
|
@ -1,7 +1,7 @@
|
|||
# File: PBot.pm
|
||||
# Author: pragma_
|
||||
#
|
||||
# Purpose: IRC Bot (3rd generation)
|
||||
# Purpose: IRC Bot
|
||||
|
||||
# This Source Code Form is subject to the terms of the Mozilla Public
|
||||
# License, v. 2.0. If a copy of the MPL was not distributed with this
|
||||
|
|
@ -11,6 +11,7 @@ package PBot::PBot;
|
|||
|
||||
use strict; use warnings;
|
||||
use feature 'unicode_strings';
|
||||
use utf8;
|
||||
|
||||
# unbuffer stdout
|
||||
STDOUT->autoflush(1);
|
||||
|
|
@ -18,39 +19,40 @@ STDOUT->autoflush(1);
|
|||
use Carp ();
|
||||
use PBot::Logger;
|
||||
use PBot::VERSION;
|
||||
use PBot::HashObject;
|
||||
use PBot::DualIndexHashObject;
|
||||
use PBot::DualIndexSQLiteObject;
|
||||
use PBot::Registry;
|
||||
use PBot::Capabilities;
|
||||
use PBot::SelectHandler;
|
||||
use PBot::StdinReader;
|
||||
use PBot::IRC;
|
||||
use PBot::EventDispatcher;
|
||||
use PBot::IRCHandlers;
|
||||
use PBot::Channels;
|
||||
use PBot::BanList;
|
||||
use PBot::NickList;
|
||||
use PBot::LagChecker;
|
||||
use PBot::MessageHistory;
|
||||
use PBot::AntiFlood;
|
||||
use PBot::AntiSpam;
|
||||
use PBot::Interpreter;
|
||||
use PBot::Commands;
|
||||
use PBot::ChanOps;
|
||||
use PBot::Factoids;
|
||||
use PBot::Users;
|
||||
use PBot::IgnoreList;
|
||||
use PBot::BanList;
|
||||
use PBot::BlackList;
|
||||
use PBot::Timer;
|
||||
use PBot::Refresher;
|
||||
use PBot::WebPaste;
|
||||
use PBot::Utils::ParseDate;
|
||||
use PBot::Plugins;
|
||||
use PBot::Capabilities;
|
||||
use PBot::Commands;
|
||||
use PBot::Channels;
|
||||
use PBot::ChanOps;
|
||||
use PBot::DualIndexHashObject;
|
||||
use PBot::DualIndexSQLiteObject;
|
||||
use PBot::EventDispatcher;
|
||||
use PBot::Factoids;
|
||||
use PBot::Functions;
|
||||
use PBot::HashObject;
|
||||
use PBot::IgnoreList;
|
||||
use PBot::Interpreter;
|
||||
use PBot::IRC;
|
||||
use PBot::IRCHandlers;
|
||||
use PBot::LagChecker;
|
||||
use PBot::MessageHistory;
|
||||
use PBot::Modules;
|
||||
use PBot::MiscCommands;
|
||||
use PBot::NickList;
|
||||
use PBot::Plugins;
|
||||
use PBot::ProcessManager;
|
||||
use PBot::Registry;
|
||||
use PBot::Refresher;
|
||||
use PBot::SelectHandler;
|
||||
use PBot::StdinReader;
|
||||
use PBot::Timer;
|
||||
use PBot::Updater;
|
||||
use PBot::Users;
|
||||
use PBot::Utils::ParseDate;
|
||||
use PBot::WebPaste;
|
||||
|
||||
sub new {
|
||||
my ($proto, %conf) = @_;
|
||||
|
|
@ -62,24 +64,20 @@ sub new {
|
|||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
|
||||
$self->{startup_timestamp} = time;
|
||||
|
||||
my $data_dir = $conf{data_dir};
|
||||
my $module_dir = $conf{module_dir};
|
||||
my $plugin_dir = $conf{plugin_dir};
|
||||
my $update_dir = $conf{update_dir};
|
||||
|
||||
# process command-line arguments
|
||||
# process command-line arguments for path and registry overrides
|
||||
foreach my $arg (@ARGV) {
|
||||
if ($arg =~ m/^-?(?:general\.)?((?:data|module|plugin|update)_dir)=(.*)$/) {
|
||||
# check command-line arguments for directory overrides
|
||||
my $override = $1;
|
||||
my $value = $2;
|
||||
$value =~ s/[\\\/]$//; # strip trailing directory separator
|
||||
$data_dir = $value if $override eq 'data_dir';
|
||||
$module_dir = $value if $override eq 'module_dir';
|
||||
$plugin_dir = $value if $override eq 'plugin_dir';
|
||||
$update_dir = $value if $override eq 'update_dir';
|
||||
$conf{data_dir} = $value if $override eq 'data_dir';
|
||||
$conf{module_dir} = $value if $override eq 'module_dir';
|
||||
$conf{plugin_dir} = $value if $override eq 'plugin_dir';
|
||||
$conf{update_dir} = $value if $override eq 'update_dir';
|
||||
} else {
|
||||
# check command-line arguments for registry overrides
|
||||
my ($item, $value) = split /=/, $arg, 2;
|
||||
|
|
@ -90,6 +88,7 @@ sub initialize {
|
|||
}
|
||||
|
||||
my ($section, $key) = split /\./, $item, 2;
|
||||
|
||||
if (not defined $section or not defined $key) {
|
||||
print STDERR "Fatal error: bad argument `$arg`; registry entries must be in the form of section.key (e.g.: irc.botnick)\n";
|
||||
exit;
|
||||
|
|
@ -100,163 +99,100 @@ sub initialize {
|
|||
}
|
||||
}
|
||||
|
||||
# make sure the data directory exists
|
||||
if (not -d $data_dir) {
|
||||
print STDERR "Data directory ($data_dir) does not exist; aborting...\n";
|
||||
exit;
|
||||
# make sure the paths exist
|
||||
foreach my $path (qw/data_dir module_dir plugin_dir update_dir/) {
|
||||
if (not -d $conf{$path}) {
|
||||
print STDERR "$path path ($conf{$path}) does not exist; aborting.\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
|
||||
# let modules register signal handlers
|
||||
$self->{atexit} = PBot::Registerable->new(%conf, pbot => $self);
|
||||
# let modules register atexit subroutines
|
||||
$self->{atexit} = PBot::Registerable->new(pbot => $self, %conf);
|
||||
|
||||
# register default signal handlers
|
||||
$self->register_signal_handlers;
|
||||
|
||||
# create logger
|
||||
$self->{logger} = PBot::Logger->new(pbot => $self, filename => "$data_dir/log/log", %conf);
|
||||
# prepare and open logger
|
||||
$self->{logger} = PBot::Logger->new(pbot => $self, filename => "$conf{data_dir}/log/log", %conf);
|
||||
|
||||
# make sure the rest of the environment is sane
|
||||
if (not -d $module_dir) {
|
||||
$self->{logger}->log("Modules directory ($module_dir) does not exist; aborting...\n");
|
||||
exit;
|
||||
}
|
||||
# log command-line arguments
|
||||
$self->{logger}->log("Args: @ARGV\n") if @ARGV;
|
||||
|
||||
if (not -d $plugin_dir) {
|
||||
$self->{logger}->log("Plugins directory ($plugin_dir) does not exist; aborting...\n");
|
||||
exit;
|
||||
}
|
||||
# log configured paths
|
||||
$self->{logger}->log("module_dir: $conf{module_dir}\n");
|
||||
$self->{logger}->log("plugin_dir: $conf{plugin_dir}\n");
|
||||
$self->{logger}->log(" data_dir: $conf{data_dir}\n");
|
||||
$self->{logger}->log("update_dir: $conf{update_dir}\n");
|
||||
|
||||
if (not -d $update_dir) {
|
||||
$self->{logger}->log("Updates directory ($update_dir) does not exist; aborting...\n");
|
||||
exit;
|
||||
}
|
||||
|
||||
$self->{updater} = PBot::Updater->new(pbot => $self, data_dir => $data_dir, update_dir => $update_dir);
|
||||
# prepare the updater
|
||||
$self->{updater} = PBot::Updater->new(pbot => $self, data_dir => $conf{data_dir}, update_dir => $conf{update_dir});
|
||||
|
||||
# update any data files to new locations/formats
|
||||
# --- this must happen before any data files are opened! ---
|
||||
if ($self->{updater}->update) {
|
||||
$self->{logger}->log("Update failed.\n");
|
||||
exit 0;
|
||||
}
|
||||
|
||||
# create capabilities so commands can add new capabilities
|
||||
$self->{capabilities} = PBot::Capabilities->new(pbot => $self, filename => "$data_dir/capabilities", %conf);
|
||||
$self->{capabilities} = PBot::Capabilities->new(pbot => $self, filename => "$conf{data_dir}/capabilities", %conf);
|
||||
|
||||
# create commands so the modules can register new commands
|
||||
$self->{commands} = PBot::Commands->new(pbot => $self, filename => "$data_dir/commands", %conf);
|
||||
$self->{commands} = PBot::Commands->new(pbot => $self, filename => "$conf{data_dir}/commands", %conf);
|
||||
|
||||
# add some commands
|
||||
$self->{commands}->register(sub { $self->cmd_list(@_) }, "list");
|
||||
$self->{commands}->register(sub { $self->cmd_die(@_) }, "die", 1);
|
||||
$self->{commands}->register(sub { $self->cmd_export(@_) }, "export", 1);
|
||||
$self->{commands}->register(sub { $self->cmd_reload(@_) }, "reload", 1);
|
||||
$self->{commands}->register(sub { $self->cmd_eval(@_) }, "eval", 1);
|
||||
$self->{commands}->register(sub { $self->cmd_sl(@_) }, "sl", 1);
|
||||
|
||||
# add 'cap' capability command
|
||||
# add 'cap' capability command here since $self->{commands} is created after $self->{capabilities}
|
||||
$self->{commands}->register(sub { $self->{capabilities}->cmd_cap(@_) }, "cap");
|
||||
|
||||
# prepare the version
|
||||
# prepare the version information and `version` command
|
||||
$self->{version} = PBot::VERSION->new(pbot => $self, %conf);
|
||||
$self->{logger}->log($self->{version}->version . "\n");
|
||||
$self->{logger}->log("Args: @ARGV\n") if @ARGV;
|
||||
|
||||
$self->{logger}->log("module_dir: $module_dir\n");
|
||||
$self->{logger}->log("plugin_dir: $plugin_dir\n");
|
||||
$self->{logger}->log("data_dir: $data_dir\n");
|
||||
$self->{logger}->log("update_dir: $update_dir\n");
|
||||
|
||||
|
||||
$self->{timer} = PBot::Timer->new(pbot => $self, timeout => 10, name => 'PBot Timer', %conf);
|
||||
$self->{modules} = PBot::Modules->new(pbot => $self, %conf);
|
||||
$self->{functions} = PBot::Functions->new(pbot => $self, %conf);
|
||||
$self->{refresher} = PBot::Refresher->new(pbot => $self);
|
||||
|
||||
# create registry and set some defaults
|
||||
$self->{registry} = PBot::Registry->new(pbot => $self, filename => "$data_dir/registry", %conf);
|
||||
|
||||
$self->{registry}->add_default('text', 'general', 'data_dir', $data_dir);
|
||||
$self->{registry}->add_default('text', 'general', 'module_dir', $module_dir);
|
||||
$self->{registry}->add_default('text', 'general', 'plugin_dir', $plugin_dir);
|
||||
$self->{registry}->add_default('text', 'general', 'update_dir', $update_dir);
|
||||
$self->{registry}->add_default('text', 'general', 'trigger', $conf{trigger} // '!');
|
||||
|
||||
$self->{registry}->add_default('text', 'irc', 'debug', $conf{irc_debug} // 0);
|
||||
$self->{registry}->add_default('text', 'irc', 'show_motd', $conf{show_motd} // 1);
|
||||
$self->{registry}->add_default('text', 'irc', 'max_msg_len', $conf{max_msg_len} // 425);
|
||||
$self->{registry}->add_default('text', 'irc', 'server', $conf{server} // "irc.freenode.net");
|
||||
$self->{registry}->add_default('text', 'irc', 'port', $conf{port} // 6667);
|
||||
$self->{registry}->add_default('text', 'irc', 'SSL', $conf{SSL} // 0);
|
||||
$self->{registry}->add_default('text', 'irc', 'SSL_ca_file', $conf{SSL_ca_file} // 'none');
|
||||
$self->{registry}->add_default('text', 'irc', 'SSL_ca_path', $conf{SSL_ca_path} // 'none');
|
||||
$self->{registry}->add_default('text', 'irc', 'botnick', $conf{botnick} // "");
|
||||
$self->{registry}->add_default('text', 'irc', 'username', $conf{username} // "pbot3");
|
||||
$self->{registry}->add_default('text', 'irc', 'realname', $conf{realname} // "https://github.com/pragma-/pbot");
|
||||
$self->{registry}->add_default('text', 'irc', 'identify_password', $conf{identify_password} // '');
|
||||
$self->{registry}->add_default('text', 'irc', 'log_default_handler', 1);
|
||||
|
||||
$self->{registry}->set_default('irc', 'SSL_ca_file', 'private', 1);
|
||||
$self->{registry}->set_default('irc', 'SSL_ca_path', 'private', 1);
|
||||
$self->{registry}->set_default('irc', 'identify_password', 'private', 1);
|
||||
|
||||
# load existing registry entries from file (if exists) to overwrite defaults
|
||||
if (-e $self->{registry}->{registry}->{filename}) { $self->{registry}->load; }
|
||||
|
||||
# update important paths
|
||||
$self->{registry}->set('general', 'data_dir', 'value', $data_dir, 0, 1);
|
||||
$self->{registry}->set('general', 'module_dir', 'value', $module_dir, 0, 1);
|
||||
$self->{registry}->set('general', 'plugin_dir', 'value', $plugin_dir, 0, 1);
|
||||
$self->{registry}->set('general', 'update_dir', 'value', $update_dir, 0, 1);
|
||||
|
||||
# override registry entries with command-line arguments, if any
|
||||
foreach my $override (keys %{$self->{overrides}}) {
|
||||
my ($section, $key) = split /\./, $override;
|
||||
my $value = $self->{overrides}->{$override};
|
||||
$self->{logger}->log("Overriding $section.$key to $value\n");
|
||||
$self->{registry}->set($section, $key, 'value', $value, 0, 1);
|
||||
}
|
||||
|
||||
# registry triggers fire when value changes
|
||||
$self->{registry}->add_trigger('irc', 'botnick', sub { $self->change_botnick_trigger(@_) });
|
||||
$self->{registry}->add_trigger('irc', 'debug', sub { $self->irc_debug_trigger(@_) });
|
||||
# prepare registry
|
||||
$self->{registry} = PBot::Registry->new(pbot => $self, filename => "$conf{data_dir}/registry", %conf);
|
||||
|
||||
# ensure user has attempted to configure the bot
|
||||
if (not length $self->{registry}->get_value('irc', 'botnick')) {
|
||||
$self->{logger}->log("Fatal error: IRC nickname not defined; please set registry key irc.botnick in $data_dir/registry to continue.\n");
|
||||
$self->{logger}->log("Fatal error: IRC nickname not defined; please set registry key irc.botnick in $conf{data_dir}/registry to continue.\n");
|
||||
exit;
|
||||
}
|
||||
|
||||
# prepare remaining core PBot modules -- do not change this order
|
||||
$self->{timer} = PBot::Timer->new(pbot => $self, timeout => 10, name => 'PBot Timer', %conf);
|
||||
$self->{event_dispatcher} = PBot::EventDispatcher->new(pbot => $self, %conf);
|
||||
$self->{process_manager} = PBot::ProcessManager->new(pbot => $self, %conf);
|
||||
$self->{irchandlers} = PBot::IRCHandlers->new(pbot => $self, %conf);
|
||||
$self->{select_handler} = PBot::SelectHandler->new(pbot => $self, %conf);
|
||||
$self->{users} = PBot::Users->new(pbot => $self, filename => "$data_dir/users", %conf);
|
||||
$self->{stdin_reader} = PBot::StdinReader->new(pbot => $self, %conf);
|
||||
$self->{lagchecker} = PBot::LagChecker->new(pbot => $self, %conf);
|
||||
$self->{messagehistory} = PBot::MessageHistory->new(pbot => $self, filename => "$data_dir/message_history.sqlite3", %conf);
|
||||
$self->{users} = PBot::Users->new(pbot => $self, filename => "$conf{data_dir}/users", %conf);
|
||||
$self->{antiflood} = PBot::AntiFlood->new(pbot => $self, %conf);
|
||||
$self->{antispam} = PBot::AntiSpam->new(pbot => $self, %conf);
|
||||
$self->{ignorelist} = PBot::IgnoreList->new(pbot => $self, filename => "$data_dir/ignorelist", %conf);
|
||||
$self->{blacklist} = PBot::BlackList->new(pbot => $self, filename => "$data_dir/blacklist", %conf);
|
||||
$self->{irc} = PBot::IRC->new();
|
||||
$self->{channels} = PBot::Channels->new(pbot => $self, filename => "$data_dir/channels", %conf);
|
||||
$self->{chanops} = PBot::ChanOps->new(pbot => $self, %conf);
|
||||
$self->{banlist} = PBot::BanList->new(pbot => $self, %conf);
|
||||
$self->{blacklist} = PBot::BlackList->new(pbot => $self, filename => "$conf{data_dir}/blacklist", %conf);
|
||||
$self->{channels} = PBot::Channels->new(pbot => $self, filename => "$conf{data_dir}/channels", %conf);
|
||||
$self->{chanops} = PBot::ChanOps->new(pbot => $self, %conf);
|
||||
$self->{factoids} = PBot::Factoids->new(pbot => $self, filename => "$conf{data_dir}/factoids.sqlite3", %conf);
|
||||
$self->{functions} = PBot::Functions->new(pbot => $self, %conf);
|
||||
$self->{refresher} = PBot::Refresher->new(pbot => $self);
|
||||
$self->{ignorelist} = PBot::IgnoreList->new(pbot => $self, filename => "$conf{data_dir}/ignorelist", %conf);
|
||||
$self->{irc} = PBot::IRC->new();
|
||||
$self->{irchandlers} = PBot::IRCHandlers->new(pbot => $self, %conf);
|
||||
$self->{interpreter} = PBot::Interpreter->new(pbot => $self, %conf);
|
||||
$self->{lagchecker} = PBot::LagChecker->new(pbot => $self, %conf);
|
||||
$self->{misc_commands} = PBot::MiscCommands->new(pbot => $self, %conf);
|
||||
$self->{messagehistory} = PBot::MessageHistory->new(pbot => $self, filename => "$conf{data_dir}/message_history.sqlite3", %conf);
|
||||
$self->{modules} = PBot::Modules->new(pbot => $self, %conf);
|
||||
$self->{nicklist} = PBot::NickList->new(pbot => $self, %conf);
|
||||
$self->{webpaste} = PBot::WebPaste->new(pbot => $self, %conf);
|
||||
$self->{parsedate} = PBot::Utils::ParseDate->new(pbot => $self, %conf);
|
||||
$self->{plugins} = PBot::Plugins->new(pbot => $self, %conf);
|
||||
$self->{process_manager} = PBot::ProcessManager->new(pbot => $self, %conf);
|
||||
$self->{select_handler} = PBot::SelectHandler->new(pbot => $self, %conf);
|
||||
$self->{stdin_reader} = PBot::StdinReader->new(pbot => $self, %conf);
|
||||
$self->{webpaste} = PBot::WebPaste->new(pbot => $self, %conf);
|
||||
|
||||
$self->{interpreter} = PBot::Interpreter->new(pbot => $self, %conf);
|
||||
# register command/factoid interpreters
|
||||
$self->{interpreter}->register(sub { $self->{commands}->interpreter(@_) });
|
||||
$self->{interpreter}->register(sub { $self->{factoids}->interpreter(@_) });
|
||||
|
||||
$self->{factoids} = PBot::Factoids->new(pbot => $self, filename => "$data_dir/factoids.sqlite3", %conf);
|
||||
|
||||
$self->{plugins} = PBot::Plugins->new(pbot => $self, %conf);
|
||||
|
||||
# load available plugins
|
||||
$self->{plugins}->autoload(%conf);
|
||||
|
||||
# give botowner all capabilities
|
||||
$self->{capabilities}->rebuild_botowner_capabilities();
|
||||
# -- this must happen last after all modules have registered their capabilities --
|
||||
$self->{capabilities}->rebuild_botowner_capabilities;
|
||||
|
||||
# flush all pending save events to disk at exit
|
||||
$self->{atexit}->register(sub {
|
||||
|
|
@ -275,18 +211,20 @@ sub random_nick {
|
|||
return $nick;
|
||||
}
|
||||
|
||||
# TODO: add disconnect subroutine
|
||||
# TODO: add disconnect subroutine and connect/disconnect/reconnect commands
|
||||
sub connect {
|
||||
my ($self, $server) = @_;
|
||||
my ($self) = @_;
|
||||
return if $ENV{PBOT_LOCAL};
|
||||
|
||||
if ($self->{connected}) {
|
||||
# TODO: disconnect, clean-up, etc
|
||||
}
|
||||
|
||||
$server = $self->{registry}->get_value('irc', 'server') if not defined $server;
|
||||
my $server = $self->{registry}->get_value('irc', 'server');
|
||||
my $port = $self->{registry}->get_value('irc', 'port');
|
||||
my $delay = $self->{registry}->get_value('irc', 'reconnect_delay') // 10;
|
||||
|
||||
$self->{logger}->log("Connecting to $server ...\n");
|
||||
$self->{logger}->log("Connecting to $server:$port\n");
|
||||
|
||||
while (
|
||||
not $self->{conn} = $self->{irc}->newconn(
|
||||
|
|
@ -294,17 +232,17 @@ sub connect {
|
|||
Username => $self->{registry}->get_value('irc', 'username'),
|
||||
Ircname => $self->{registry}->get_value('irc', 'realname'),
|
||||
Server => $server,
|
||||
Port => $port,
|
||||
Pacing => 1,
|
||||
UTF8 => 1,
|
||||
SSL => $self->{registry}->get_value('irc', 'SSL'),
|
||||
SSL_ca_file => $self->{registry}->get_value('irc', 'SSL_ca_file'),
|
||||
SSL_ca_path => $self->{registry}->get_value('irc', 'SSL_ca_path'),
|
||||
Port => $self->{registry}->get_value('irc', 'port')
|
||||
)
|
||||
)
|
||||
{
|
||||
$self->{logger}->log("$0: Can't connect to $server:" . $self->{registry}->get_value('irc', 'port') . ". Retrying in 15 seconds...\n");
|
||||
sleep 15;
|
||||
$self->{logger}->log("$0: Can't connect to $server:$port: $!\nRetrying in $delay seconds...\n");
|
||||
sleep $delay;
|
||||
}
|
||||
|
||||
$self->{connected} = 1;
|
||||
|
|
@ -331,13 +269,30 @@ sub connect {
|
|||
);
|
||||
}
|
||||
|
||||
#main loop
|
||||
sub register_signal_handlers {
|
||||
my $self = shift;
|
||||
|
||||
$SIG{INT} = sub {
|
||||
$self->{logger}->log("SIGINT received, exiting immediately.\n");
|
||||
$self->atexit; exit 0;
|
||||
};
|
||||
}
|
||||
|
||||
# called when PBot terminates
|
||||
sub atexit {
|
||||
my $self = shift;
|
||||
$self->{atexit}->execute_all;
|
||||
alarm 0;
|
||||
}
|
||||
|
||||
# main loop
|
||||
sub do_one_loop {
|
||||
my $self = shift;
|
||||
$self->{irc}->do_one_loop() if $self->{connected};
|
||||
$self->{select_handler}->do_select;
|
||||
}
|
||||
|
||||
# main entry point
|
||||
sub start {
|
||||
my $self = shift;
|
||||
while (1) {
|
||||
|
|
@ -346,169 +301,4 @@ sub start {
|
|||
}
|
||||
}
|
||||
|
||||
sub register_signal_handlers {
|
||||
my $self = shift;
|
||||
$SIG{INT} = sub { $self->atexit; exit 0; };
|
||||
}
|
||||
|
||||
sub atexit {
|
||||
my $self = shift;
|
||||
$self->{atexit}->execute_all;
|
||||
alarm 0;
|
||||
}
|
||||
|
||||
sub irc_debug_trigger {
|
||||
my ($self, $section, $item, $newvalue) = @_;
|
||||
$self->{irc}->debug($newvalue);
|
||||
$self->{conn}->debug($newvalue) if $self->{connected};
|
||||
}
|
||||
|
||||
sub change_botnick_trigger {
|
||||
my ($self, $section, $item, $newvalue) = @_;
|
||||
$self->{conn}->nick($newvalue) if $self->{connected};
|
||||
}
|
||||
|
||||
sub cmd_list {
|
||||
my ($self, $context) = @_;
|
||||
my $text;
|
||||
|
||||
my $usage = "Usage: list <modules|commands>";
|
||||
|
||||
return $usage if not length $context->{arguments};
|
||||
|
||||
if ($context->{arguments} =~ /^modules$/i) {
|
||||
$text = "Loaded modules: ";
|
||||
foreach my $channel (sort $self->{factoids}->{factoids}->get_keys) {
|
||||
foreach my $command (sort $self->{factoids}->{factoids}->get_keys($channel)) {
|
||||
next if $command eq '_name';
|
||||
if ($self->{factoids}->{factoids}->get_data($channel, $command, 'type') eq 'module') {
|
||||
$text .= $self->{factoids}->{factoids}->get_data($channel, $command, '_name') . ' ';
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $text;
|
||||
}
|
||||
|
||||
if ($context->{arguments} =~ /^commands$/i) {
|
||||
$text = "Registered commands: ";
|
||||
foreach my $command (sort { $a->{name} cmp $b->{name} } @{$self->{commands}->{handlers}}) {
|
||||
if ($command->{requires_cap}) { $text .= "+$command->{name} "; }
|
||||
else { $text .= "$command->{name} "; }
|
||||
}
|
||||
return $text;
|
||||
}
|
||||
return $usage;
|
||||
}
|
||||
|
||||
sub cmd_sl {
|
||||
my ($self, $context) = @_;
|
||||
return "Usage: sl <ircd command>" if not length $context->{arguments};
|
||||
$self->{conn}->sl($context->{arguments});
|
||||
return "/msg $context->{nick} sl: command sent. See log for result.";
|
||||
}
|
||||
|
||||
sub cmd_die {
|
||||
my ($self, $context) = @_;
|
||||
$self->{logger}->log("$context->{hostmask} made me exit.\n");
|
||||
$self->{conn}->privmsg($context->{from}, "Good-bye.") if $context->{from} ne 'stdin@pbot';
|
||||
$self->{conn}->quit("Departure requested.") if defined $self->{conn};
|
||||
$self->atexit();
|
||||
exit 0;
|
||||
}
|
||||
|
||||
sub cmd_export {
|
||||
my ($self, $context) = @_;
|
||||
return "Usage: export <factoids>" if not length $context->{arguments};
|
||||
if ($context->{arguments} =~ /^factoids$/i) { return $self->{factoids}->export_factoids; }
|
||||
}
|
||||
|
||||
sub cmd_eval {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
$self->{logger}->log("eval: $context->{from} $context->{hostmask} evaluating `$context->{arguments}`\n");
|
||||
|
||||
my $ret = '';
|
||||
my $result = eval $context->{arguments};
|
||||
if ($@) {
|
||||
if (length $result) { $ret .= "[Error: $@] "; }
|
||||
else { $ret .= "Error: $@"; }
|
||||
$ret =~ s/ at \(eval \d+\) line 1.//;
|
||||
}
|
||||
$result = 'Undefined.' if not defined $result;
|
||||
$result = 'No output.' if not length $result;
|
||||
return "/say $ret $result";
|
||||
}
|
||||
|
||||
sub cmd_reload {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
my %reloadables = (
|
||||
'capabilities' => sub {
|
||||
$self->{capabilities}->{caps}->load;
|
||||
return "Capabilities reloaded.";
|
||||
},
|
||||
|
||||
'commands' => sub {
|
||||
$self->{commands}->{metadata}->load;
|
||||
return "Commands metadata reloaded.";
|
||||
},
|
||||
|
||||
'blacklist' => sub {
|
||||
$self->{blacklist}->clear_blacklist;
|
||||
$self->{blacklist}->load_blacklist;
|
||||
return "Blacklist reloaded.";
|
||||
},
|
||||
|
||||
'ban-exemptions' => sub {
|
||||
$self->{antiflood}->{'ban-exemptions'}->load;
|
||||
return "Ban exemptions reloaded.";
|
||||
},
|
||||
|
||||
'ignores' => sub {
|
||||
$self->{ignorelist}->{ignorelist}->load;
|
||||
return "Ignore list reloaded.";
|
||||
},
|
||||
|
||||
'users' => sub {
|
||||
$self->{users}->load;
|
||||
return "Users reloaded.";
|
||||
},
|
||||
|
||||
'channels' => sub {
|
||||
$self->{channels}->{channels}->load;
|
||||
return "Channels reloaded.";
|
||||
},
|
||||
|
||||
'banlist' => sub {
|
||||
$self->{timer}->dequeue_event('unban #.*');
|
||||
$self->{timer}->dequeue_event('unmute #.*');
|
||||
$self->{banlist}->{banlist}->load;
|
||||
$self->{banlist}->{quietlist}->load;
|
||||
$self->{banlist}->enqueue_timeouts($self->{banlist}->{banlist}, 'b');
|
||||
$self->{banlist}->enqueue_timeouts($self->{banlist}->{quietlist}, 'q');
|
||||
return "Ban list reloaded.";
|
||||
},
|
||||
|
||||
'registry' => sub {
|
||||
$self->{registry}->load;
|
||||
return "Registry reloaded.";
|
||||
},
|
||||
|
||||
'factoids' => sub {
|
||||
$self->{factoids}->load_factoids;
|
||||
return "Factoids reloaded.";
|
||||
}
|
||||
);
|
||||
|
||||
if (not length $context->{arguments} or not exists $reloadables{$context->{arguments}}) {
|
||||
my $usage = 'Usage: reload <';
|
||||
$usage .= join '|', sort keys %reloadables;
|
||||
$usage .= '>';
|
||||
return $usage;
|
||||
}
|
||||
|
||||
return $reloadables{$context->{arguments}}();
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -22,6 +22,9 @@ sub initialize {
|
|||
$self->{pbot}->{commands}->register(sub { $self->cmd_unplug(@_) }, "unplug", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_replug(@_) }, "replug", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_pluglist(@_) }, "pluglist", 0);
|
||||
|
||||
# load configured plugins
|
||||
$self->autoload(%conf);
|
||||
}
|
||||
|
||||
sub cmd_plug {
|
||||
|
|
|
|||
172
PBot/Registry.pm
172
PBot/Registry.pm
|
|
@ -2,7 +2,7 @@
|
|||
# Author: pragma_
|
||||
#
|
||||
# Purpose: Provides a centralized registry of configuration settings that can
|
||||
# easily be examined and updated via set/unset commands without restarting.
|
||||
# easily be examined and updated via getters and setters.
|
||||
|
||||
# This Source Code Form is subject to the terms of the Mozilla Public
|
||||
# License, v. 2.0. If a copy of the MPL was not distributed with this
|
||||
|
|
@ -20,28 +20,121 @@ use PBot::RegistryCommands;
|
|||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
my $filename = $conf{filename} // Carp::croak("Missing filename reference in " . __FILE__);
|
||||
|
||||
# ensure we have a registry filename
|
||||
my $filename = $conf{filename} // Carp::croak("Missing filename configuration item in " . __FILE__);
|
||||
|
||||
# registry is stored as a dual-index hash object
|
||||
$self->{registry} = PBot::DualIndexHashObject->new(name => 'Registry', filename => $filename, pbot => $self->{pbot});
|
||||
|
||||
# registry triggers are processed when a registry entry is modified
|
||||
$self->{triggers} = {};
|
||||
|
||||
# save registry data at bot exit
|
||||
$self->{pbot}->{atexit}->register(sub { $self->save; return; });
|
||||
|
||||
# prepare registry-specific bot commands
|
||||
PBot::RegistryCommands->new(pbot => $self->{pbot});
|
||||
|
||||
# add default registry items
|
||||
$self->add_default('text', 'general', 'data_dir', $conf{data_dir});
|
||||
$self->add_default('text', 'general', 'module_dir', $conf{module_dir});
|
||||
$self->add_default('text', 'general', 'plugin_dir', $conf{plugin_dir});
|
||||
$self->add_default('text', 'general', 'update_dir', $conf{update_dir});
|
||||
|
||||
$self->add_default('text', 'general', 'trigger', $conf{trigger} // '!');
|
||||
|
||||
$self->add_default('text', 'irc', 'debug', $conf{irc_debug} // 0);
|
||||
$self->add_default('text', 'irc', 'show_motd', $conf{show_motd} // 1);
|
||||
$self->add_default('text', 'irc', 'max_msg_len', $conf{max_msg_len} // 425);
|
||||
$self->add_default('text', 'irc', 'server', $conf{server} // "irc.libera.chat");
|
||||
$self->add_default('text', 'irc', 'port', $conf{port} // 6667);
|
||||
$self->add_default('text', 'irc', 'SSL', $conf{SSL} // 0);
|
||||
$self->add_default('text', 'irc', 'SSL_ca_file', $conf{SSL_ca_file} // 'none');
|
||||
$self->add_default('text', 'irc', 'SSL_ca_path', $conf{SSL_ca_path} // 'none');
|
||||
$self->add_default('text', 'irc', 'botnick', $conf{botnick} // "");
|
||||
$self->add_default('text', 'irc', 'username', $conf{username} // "pbot3");
|
||||
$self->add_default('text', 'irc', 'realname', $conf{realname} // "https://github.com/pragma-/pbot");
|
||||
$self->add_default('text', 'irc', 'identify_password', $conf{identify_password} // '');
|
||||
$self->add_default('text', 'irc', 'log_default_handler', 1);
|
||||
|
||||
$self->set_default('irc', 'SSL_ca_file', 'private', 1);
|
||||
$self->set_default('irc', 'SSL_ca_path', 'private', 1);
|
||||
$self->set_default('irc', 'identify_password', 'private', 1);
|
||||
|
||||
# load existing registry entries from file (if exists) to overwrite defaults
|
||||
if (-e $filename) {
|
||||
$self->load;
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("No registry found at $filename, using defaults.\n");
|
||||
}
|
||||
|
||||
# update important paths
|
||||
$self->set('general', 'data_dir', 'value', $conf{data_dir}, 0, 1);
|
||||
$self->set('general', 'module_dir', 'value', $conf{module_dir}, 0, 1);
|
||||
$self->set('general', 'plugin_dir', 'value', $conf{plugin_dir}, 0, 1);
|
||||
$self->set('general', 'update_dir', 'value', $conf{update_dir}, 0, 1);
|
||||
|
||||
# override registry entries with command-line arguments, if any
|
||||
foreach my $override (keys %{$self->{pbot}->{overrides}}) {
|
||||
my $value = $self->{pbot}->{overrides}->{$override};
|
||||
my ($section, $key) = split /\./, $override;
|
||||
|
||||
$self->{pbot}->{logger}->log("Overriding $section.$key to $value\n");
|
||||
|
||||
$self->set($section, $key, 'value', $value, 0, 1);
|
||||
}
|
||||
|
||||
# add triggers
|
||||
$self->add_trigger('irc', 'debug', sub { $self->trigger_irc_debug(@_) });
|
||||
$self->add_trigger('irc', 'botnick', sub { $self->trigger_change_botnick(@_) });
|
||||
}
|
||||
|
||||
# registry triggers fire when value changes
|
||||
|
||||
sub trigger_irc_debug {
|
||||
my ($self, $section, $item, $newvalue) = @_;
|
||||
|
||||
$self->{pbot}->{irc}->debug($newvalue);
|
||||
|
||||
if ($self->{pbot}->{connected}) {
|
||||
$self->{pbot}->{conn}->debug($newvalue);
|
||||
}
|
||||
}
|
||||
|
||||
sub trigger_change_botnick {
|
||||
my ($self, $section, $item, $newvalue) = @_;
|
||||
|
||||
if ($self->{pbot}->{connected}) {
|
||||
$self->{pbot}->{conn}->nick($newvalue)
|
||||
}
|
||||
}
|
||||
|
||||
# registry api
|
||||
|
||||
sub load {
|
||||
my $self = shift;
|
||||
|
||||
# load registry from file
|
||||
$self->{registry}->load;
|
||||
|
||||
# fire off all registered triggers
|
||||
foreach my $section ($self->{registry}->get_keys) {
|
||||
foreach my $item ($self->{registry}->get_keys($section)) { $self->process_trigger($section, $item, $self->{registry}->get_data($section, $item, 'value')); }
|
||||
foreach my $item ($self->{registry}->get_keys($section)) {
|
||||
$self->process_trigger($section, $item, $self->{registry}->get_data($section, $item, 'value'));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub save {
|
||||
my $self = shift;
|
||||
|
||||
$self->{registry}->save;
|
||||
}
|
||||
|
||||
sub add_default {
|
||||
my ($self, $type, $section, $item, $value) = @_;
|
||||
|
||||
$self->add($type, $section, $item, $value, 1);
|
||||
}
|
||||
|
||||
|
|
@ -50,7 +143,10 @@ sub add {
|
|||
my ($type, $section, $item, $value, $is_default) = @_;
|
||||
$type = lc $type;
|
||||
|
||||
if ($is_default) { return if $self->{registry}->exists($section, $item); }
|
||||
if ($is_default) {
|
||||
# don't replace existing registry values if we're just adding a default value
|
||||
return if $self->{registry}->exists($section, $item);
|
||||
}
|
||||
|
||||
if (not $self->{registry}->exists($section, $item)) {
|
||||
my $data = {
|
||||
|
|
@ -62,73 +158,102 @@ sub add {
|
|||
$self->{registry}->set($section, $item, 'value', $value, 1);
|
||||
$self->{registry}->set($section, $item, 'type', $type, 1) unless $self->{registry}->exists($section, $item, 'type');
|
||||
}
|
||||
$self->process_trigger($section, $item, $value) unless $is_default;
|
||||
$self->save unless $is_default;
|
||||
|
||||
unless ($is_default) {
|
||||
$self->process_trigger($section, $item, $value);
|
||||
$self->save;
|
||||
}
|
||||
}
|
||||
|
||||
sub remove {
|
||||
my $self = shift;
|
||||
my ($section, $item) = @_;
|
||||
my ($self, $section, $item) = @_;
|
||||
|
||||
$self->{registry}->remove($section, $item);
|
||||
}
|
||||
|
||||
sub set_default {
|
||||
my ($self, $section, $item, $key, $value) = @_;
|
||||
|
||||
$self->set($section, $item, $key, $value, 1);
|
||||
}
|
||||
|
||||
sub set {
|
||||
my ($self, $section, $item, $key, $value, $is_default, $dont_save) = @_;
|
||||
|
||||
$key = lc $key if defined $key;
|
||||
|
||||
if ($is_default) { return if $self->{registry}->exists($section, $item, $key); }
|
||||
if ($is_default && $self->{registry}->exists($section, $item, $key)) {
|
||||
return;
|
||||
}
|
||||
|
||||
my $oldvalue = $self->get_value($section, $item, 1) if defined $value;
|
||||
$oldvalue = '' if not defined $oldvalue;
|
||||
my $oldvalue;
|
||||
|
||||
if (defined $value) {
|
||||
$oldvalue = $self->get_value($section, $item, 1);
|
||||
}
|
||||
|
||||
$oldvalue //= '';
|
||||
|
||||
my $result = $self->{registry}->set($section, $item, $key, $value, 1);
|
||||
|
||||
if (defined $key and $key eq 'value' and defined $value and $oldvalue ne $value) { $self->process_trigger($section, $item, $value); }
|
||||
if (defined $key and $key eq 'value' and defined $value and $oldvalue ne $value) {
|
||||
$self->process_trigger($section, $item, $value);
|
||||
}
|
||||
|
||||
$self->save if !$dont_save && $result =~ m/set to/ && not $is_default;
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub unset {
|
||||
my ($self, $section, $item, $key) = @_;
|
||||
$key = lc $key;
|
||||
|
||||
$key = lc $key if defined $key;
|
||||
|
||||
return $self->{registry}->unset($section, $item, $key);
|
||||
}
|
||||
|
||||
sub get_value {
|
||||
my ($self, $section, $item, $as_text, $context) = @_;
|
||||
|
||||
$section = lc $section;
|
||||
$item = lc $item;
|
||||
|
||||
my $key = $item;
|
||||
|
||||
# TODO: use user-metadata for this
|
||||
if (defined $context and exists $context->{nick}) {
|
||||
my $context_nick = lc $context->{nick};
|
||||
if ($self->{registry}->exists($section, "$item.nick.$context_nick")) { $key = "$item.nick.$context_nick"; }
|
||||
if ($self->{registry}->exists($section, "$item.nick.$context_nick")) {
|
||||
$key = "$item.nick.$context_nick";
|
||||
}
|
||||
}
|
||||
|
||||
if ($self->{registry}->exists($section, $key)) {
|
||||
if (not $as_text and $self->{registry}->get_data($section, $key, 'type') eq 'array') { return split /\s*,\s*/, $self->{registry}->get_data($section, $key, 'value'); }
|
||||
else { return $self->{registry}->get_data($section, $key, 'value'); }
|
||||
if (not $as_text and $self->{registry}->get_data($section, $key, 'type') eq 'array') {
|
||||
return split /\s*,\s*/, $self->{registry}->get_data($section, $key, 'value');
|
||||
} else {
|
||||
return $self->{registry}->get_data($section, $key, 'value');
|
||||
}
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub get_array_value {
|
||||
my ($self, $section, $item, $index, $context) = @_;
|
||||
|
||||
$section = lc $section;
|
||||
$item = lc $item;
|
||||
|
||||
my $key = $item;
|
||||
|
||||
# TODO: use user-metadata for this
|
||||
if (defined $context and exists $context->{nick}) {
|
||||
my $context_nick = lc $context->{nick};
|
||||
if ($self->{registry}->exists($section, "$item.nick.$context_nick")) { $key = "$item.nick.$context_nick"; }
|
||||
if ($self->{registry}->exists($section, "$item.nick.$context_nick")) {
|
||||
$key = "$item.nick.$context_nick";
|
||||
}
|
||||
}
|
||||
|
||||
if ($self->{registry}->exists($section, $key)) {
|
||||
|
|
@ -139,20 +264,27 @@ sub get_array_value {
|
|||
return $self->{registry}->get_data($section, $key, 'value');
|
||||
}
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub add_trigger {
|
||||
my ($self, $section, $item, $subref) = @_;
|
||||
|
||||
$self->{triggers}->{lc $section}->{lc $item} = $subref;
|
||||
}
|
||||
|
||||
sub process_trigger {
|
||||
my $self = shift;
|
||||
my ($section, $item) = @_;
|
||||
my $self = shift; # shift $self off of the top of @_
|
||||
my ($section, $item) = @_; # but leave $section and $item in @_
|
||||
|
||||
$section = lc $section;
|
||||
$item = lc $item;
|
||||
if (exists $self->{triggers}->{$section} and exists $self->{triggers}->{$section}->{$item}) { return &{$self->{triggers}->{$section}->{$item}}(@_); }
|
||||
|
||||
if (exists $self->{triggers}->{$section} and exists $self->{triggers}->{$section}->{$item}) {
|
||||
return &{$self->{triggers}->{$section}->{$item}}(@_); # $section and $item still in @_
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
# File: RegistryCommands.pm
|
||||
# Author: pragma_
|
||||
#
|
||||
# Purpose: Commands to introspect and update Registry
|
||||
# Purpose: Bot commands to manipulate Registry entries.
|
||||
|
||||
# This Source Code Form is subject to the terms of the Mozilla Public
|
||||
# License, v. 2.0. If a copy of the MPL was not distributed with this
|
||||
|
|
@ -26,11 +26,13 @@ sub initialize {
|
|||
|
||||
sub cmd_regset {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
my $usage = "Usage: regset <section>.<item> [value]";
|
||||
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($context->{arglist}) // return $usage;
|
||||
my ($item, $value);
|
||||
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
($value) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 1);
|
||||
|
|
@ -38,64 +40,90 @@ sub cmd_regset {
|
|||
($item, $value) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 2);
|
||||
}
|
||||
|
||||
if (not defined $section or not defined $item) { return $usage; }
|
||||
if (not defined $section or not defined $item) {
|
||||
return $usage;
|
||||
}
|
||||
|
||||
if (defined $value) { $self->{pbot}->{registry}->add('text', $section, $item, $value); }
|
||||
else { return $self->{pbot}->{registry}->set($section, $item, 'value'); }
|
||||
if (defined $value) {
|
||||
$self->{pbot}->{registry}->add('text', $section, $item, $value);
|
||||
} else {
|
||||
return $self->{pbot}->{registry}->set($section, $item, 'value');
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("$context->{hostmask} set registry entry $section.$item => $value\n");
|
||||
|
||||
$self->{pbot}->{logger}->log("$context->{hostmask} set registry entry [$section] $item => $value\n");
|
||||
return "$section.$item set to $value";
|
||||
}
|
||||
|
||||
sub cmd_regunset {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
my $usage = "Usage: regunset <section>.<item>";
|
||||
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($context->{arglist}) // return $usage;
|
||||
my $item;
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) { ($section, $item) = ($1, $2); }
|
||||
else { ($item) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 1); }
|
||||
|
||||
if (not defined $section or not defined $item) { return $usage; }
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
} else {
|
||||
($item) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 1);
|
||||
}
|
||||
|
||||
if (not $self->{pbot}->{registry}->{registry}->exists($section)) { return "No such registry section $section."; }
|
||||
if (not defined $section or not defined $item) {
|
||||
return $usage;
|
||||
}
|
||||
|
||||
if (not $self->{pbot}->{registry}->{registry}->exists($section, $item)) { return "No such item $item in section $section."; }
|
||||
if (not $self->{pbot}->{registry}->{registry}->exists($section)) {
|
||||
return "No such registry section $section.";
|
||||
}
|
||||
|
||||
if (not $self->{pbot}->{registry}->{registry}->exists($section, $item)) {
|
||||
return "No such item $item in section $section.";
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("$context->{hostmask} removed registry entry $section.$item\n");
|
||||
|
||||
$self->{pbot}->{registry}->remove($section, $item);
|
||||
|
||||
return "$section.$item deleted from registry";
|
||||
}
|
||||
|
||||
sub cmd_regsetmeta {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
my $usage = "Usage: regsetmeta <section>.<item> [key [value]]";
|
||||
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($context->{arglist}) // return $usage;
|
||||
my ($item, $key, $value);
|
||||
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
($key, $value) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 2);
|
||||
($key, $value) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 2);
|
||||
} else {
|
||||
($item, $key, $value) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 3);
|
||||
}
|
||||
|
||||
if (not defined $section or not defined $item) { return $usage; }
|
||||
if (not defined $section or not defined $item) {
|
||||
return $usage;
|
||||
}
|
||||
|
||||
$key = undef if not length $key;
|
||||
$value = undef if not length $value;
|
||||
|
||||
return $self->{pbot}->{registry}->set($section, $item, $key, $value);
|
||||
}
|
||||
|
||||
sub cmd_regunsetmeta {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
my $usage = "Usage: regunsetmeta <section>.<item> <key>";
|
||||
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($context->{arglist}) // return $usage;
|
||||
my ($item, $key);
|
||||
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
($key) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 1);
|
||||
|
|
@ -103,86 +131,114 @@ sub cmd_regunsetmeta {
|
|||
($item, $key) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 2);
|
||||
}
|
||||
|
||||
if (not defined $section or not defined $item or not defined $key) { return $usage; }
|
||||
if (not defined $section or not defined $item or not defined $key) {
|
||||
return $usage;
|
||||
}
|
||||
|
||||
return $self->{pbot}->{registry}->unset($section, $item, $key);
|
||||
}
|
||||
|
||||
sub cmd_regshow {
|
||||
my ($self, $context) = @_;
|
||||
my $registry = $self->{pbot}->{registry}->{registry};
|
||||
|
||||
my $usage = "Usage: regshow <section>.<item>";
|
||||
my $registry = $self->{pbot}->{registry}->{registry};
|
||||
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($context->{arglist}) // return $usage;
|
||||
my $item;
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) { ($section, $item) = ($1, $2); }
|
||||
else { ($item) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 1); }
|
||||
|
||||
if (not defined $section or not defined $item) { return $usage; }
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
} else {
|
||||
($item) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 1);
|
||||
}
|
||||
|
||||
if (not $registry->exists($section)) { return "No such registry section $section."; }
|
||||
if (not defined $section or not defined $item) {
|
||||
return $usage;
|
||||
}
|
||||
|
||||
if (not $registry->exists($section, $item)) { return "No such registry item $item in section $section."; }
|
||||
if (not $registry->exists($section)) {
|
||||
return "No such registry section $section.";
|
||||
}
|
||||
|
||||
if ($registry->get_data($section, $item, 'private')) { return "$section.$item: <private>"; }
|
||||
if (not $registry->exists($section, $item)) {
|
||||
return "No such registry item $item in section $section.";
|
||||
}
|
||||
|
||||
if ($registry->get_data($section, $item, 'private')) {
|
||||
return "$section.$item: <private>";
|
||||
}
|
||||
|
||||
my $result = "$section.$item: " . $registry->get_data($section, $item, 'value');
|
||||
|
||||
if ($registry->get_data($section, $item, 'type') eq 'array') { $result .= ' [array]'; }
|
||||
if ($registry->get_data($section, $item, 'type') eq 'array') {
|
||||
$result .= ' [array]';
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub cmd_regfind {
|
||||
my ($self, $context) = @_;
|
||||
my $registry = $self->{pbot}->{registry}->{registry};
|
||||
my $usage = "Usage: regfind [-showvalues] [-section section] <regex>";
|
||||
|
||||
my $usage = "Usage: regfind [-showvalues] [-section section] <regex>";
|
||||
my $registry = $self->{pbot}->{registry}->{registry};
|
||||
|
||||
my $arguments = $context->{arguments};
|
||||
|
||||
return $usage if not defined $arguments;
|
||||
|
||||
# TODO maybe use GetOptionsFromArray here
|
||||
my ($section, $showvalues);
|
||||
$section = $1 if $arguments =~ s/-section\s+([^\b\s]+)//i;
|
||||
$showvalues = 1 if $arguments =~ s/-showvalues?//i;
|
||||
|
||||
$arguments =~ s/^\s+//;
|
||||
$arguments =~ s/\s+$//;
|
||||
$arguments =~ s/^\s+|\s+$//g;
|
||||
$arguments =~ s/\s+/ /g;
|
||||
|
||||
return $usage if $arguments eq "";
|
||||
return $usage if not length $arguments;
|
||||
|
||||
$section = lc $section if defined $section;
|
||||
|
||||
my ($text, $last_item, $last_section, $i);
|
||||
$last_section = "";
|
||||
$i = 0;
|
||||
my ($text, $last_item, $last_section, $count);
|
||||
$last_section = '';
|
||||
$count = 0;
|
||||
|
||||
eval {
|
||||
use re::engine::RE2 -strict => 1;
|
||||
use re::engine::RE2 -strict => 1; # prevent user-defined regex from exploding
|
||||
|
||||
foreach my $section_key (sort $registry->get_keys) {
|
||||
next if defined $section and $section_key ne $section;
|
||||
foreach my $item_key (sort $registry->get_keys($section_key)) {
|
||||
next if $item_key eq '_name';
|
||||
next if $item_key eq '_name'; # skip internal cached value
|
||||
|
||||
if ($registry->get_data($section_key, $item_key, 'private')) {
|
||||
# do not match on value if private
|
||||
# if private, match on key only -- do not match on value
|
||||
next if $item_key !~ /$arguments/i;
|
||||
} else {
|
||||
next if $registry->get_data($section_key, $item_key, 'value') !~ /$arguments/i and $item_key !~ /$arguments/i;
|
||||
# otherwise check for match on key and value
|
||||
next if $item_key !~ /$arguments/i and $registry->get_data($section_key, $item_key, 'value') !~ /$arguments/i;
|
||||
}
|
||||
|
||||
$i++;
|
||||
$count++;
|
||||
|
||||
if ($section_key ne $last_section) {
|
||||
$text .= "[$section_key]\n";
|
||||
$last_section = $section_key;
|
||||
}
|
||||
|
||||
if ($showvalues) {
|
||||
if ($registry->get_data($section_key, $item_key, 'private')) { $text .= " $item_key = <private>\n"; }
|
||||
else {
|
||||
$text .=
|
||||
" $item_key = " . $registry->get_data($section_key, $item_key, 'value') . ($registry->get_data($section_key, $item_key, 'type') eq 'array' ? " [array]\n" : "\n");
|
||||
if ($registry->get_data($section_key, $item_key, 'private')) {
|
||||
$text .= " $item_key = <private>\n";
|
||||
} else {
|
||||
$text .= " $item_key = " . $registry->get_data($section_key, $item_key, 'value')
|
||||
. ($registry->get_data($section_key, $item_key, 'type') eq 'array' ? " [array]\n" : "\n");
|
||||
}
|
||||
} else {
|
||||
$text .= " $item_key\n";
|
||||
}
|
||||
|
||||
$last_item = $item_key;
|
||||
}
|
||||
}
|
||||
|
|
@ -190,18 +246,20 @@ sub cmd_regfind {
|
|||
|
||||
return "/msg $context->{nick} $context->{arguments}: $@" if $@;
|
||||
|
||||
if ($i == 1) {
|
||||
chop $text;
|
||||
if ($registry->get_data($last_section, $last_item, 'private')) { return "Found one registry entry: [$last_section] $last_item: <private>"; }
|
||||
else {
|
||||
if ($count == 1) {
|
||||
chomp $text;
|
||||
|
||||
if ($registry->get_data($last_section, $last_item, 'private')) {
|
||||
return "Found one registry entry: [$last_section] $last_item: <private>";
|
||||
} else {
|
||||
return
|
||||
"Found one registry entry: [$last_section] $last_item: "
|
||||
. $registry->get_data($last_section, $last_item, 'value')
|
||||
. ($registry->get_data($last_section, $last_item, 'type') eq 'array' ? ' [array]' : '');
|
||||
}
|
||||
} elsif ($count > 1) {
|
||||
return "Found $count registry entries:\n$text";
|
||||
} else {
|
||||
return "Found $i registry entries:\n$text" unless $i == 0;
|
||||
|
||||
my $sections = (defined $section ? "section $section" : 'any sections');
|
||||
return "No matching registry entries found in $sections.";
|
||||
}
|
||||
|
|
@ -209,7 +267,9 @@ sub cmd_regfind {
|
|||
|
||||
sub cmd_regchange {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
my ($section, $item, $delim, $tochange, $changeto, $modifier);
|
||||
|
||||
my $arguments = $context->{arguments};
|
||||
|
||||
if (length $arguments) {
|
||||
|
|
@ -226,31 +286,44 @@ sub cmd_regchange {
|
|||
}
|
||||
}
|
||||
|
||||
if (not defined $section or not defined $item or not defined $changeto) { return "Usage: regchange <section>.<item> s/<pattern>/<replacement>/"; }
|
||||
if (not defined $section or not defined $item or not defined $changeto) {
|
||||
return "Usage: regchange <section>.<item> s/<pattern>/<replacement>/";
|
||||
}
|
||||
|
||||
$section = lc $section;
|
||||
$item = lc $item;
|
||||
|
||||
my $registry = $self->{pbot}->{registry}->{registry};
|
||||
|
||||
if (not $registry->exists($section)) { return "No such registry section $section."; }
|
||||
if (not $registry->exists($section)) {
|
||||
return "No such registry section $section.";
|
||||
}
|
||||
|
||||
if (not $registry->exists($section, $item)) { return "No such registry item $item in section $section."; }
|
||||
if (not $registry->exists($section, $item)) {
|
||||
return "No such registry item $item in section $section.";
|
||||
}
|
||||
|
||||
my $ret = eval {
|
||||
use re::engine::RE2 -strict => 1;
|
||||
if (not $registry->get_data($section, $item, 'value') =~ s|$tochange|$changeto|) {
|
||||
my $result = eval {
|
||||
use re::engine::RE2 -strict => 1; # prevent user-defined regex from exploding
|
||||
|
||||
my $value = $registry->get_data($section, $item, 'value');
|
||||
|
||||
if (not $value =~ s|$tochange|$changeto|) {
|
||||
$self->{pbot}->{logger}->log("($context->{from}) $context->{hostmask}: failed to change $section.$item 's$delim$tochange$delim$changeto$delim$modifier\n");
|
||||
return "/msg $context->{nick} Change $section.$item failed.";
|
||||
} else {
|
||||
$registry->set($section, $item, 'value', $value, 1);
|
||||
|
||||
$self->{pbot}->{logger}->log("($context->{from}) $context->{hostmask}: changed $section.$item 's/$tochange/$changeto/\n");
|
||||
$self->{pbot}->{registry}->process_trigger($section, $item, 'value', $registry->get_data($section, $item, 'value'));
|
||||
$self->{pbot}->{registry}->process_trigger($section, $item, 'value', $value);
|
||||
$self->{pbot}->{registry}->save;
|
||||
return "$section.$item set to " . $registry->get_data($section, $item, 'value');
|
||||
return "$section.$item set to $value";
|
||||
}
|
||||
};
|
||||
|
||||
return "/msg $context->{nick} Failed to change $section.$item: $@" if $@;
|
||||
return $ret;
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -25,7 +25,11 @@ use constant {
|
|||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
|
||||
# register `version` command
|
||||
$self->{pbot}->{commands}->register(sub { $self->cmd_version(@_) }, "version", 0);
|
||||
|
||||
# initialize last_check version data
|
||||
$self->{last_check} = {timestamp => 0, version => BUILD_REVISION, date => BUILD_DATE};
|
||||
}
|
||||
|
||||
|
|
@ -38,31 +42,44 @@ sub cmd_version {
|
|||
$self->{last_check}->{timestamp} = time;
|
||||
|
||||
my $url = $self->{pbot}->{registry}->get_value('version', 'check_url') // 'https://raw.githubusercontent.com/pragma-/pbot/master/PBot/VERSION.pm';
|
||||
|
||||
$self->{pbot}->{logger}->log("Checking $url for new version...\n");
|
||||
|
||||
my $ua = LWP::UserAgent->new(timeout => 10);
|
||||
my $response = $ua->get($url);
|
||||
|
||||
return "Unable to get version information: " . $response->status_line if not $response->is_success;
|
||||
if (not $response->is_success) {
|
||||
return "Unable to get version information: " . $response->status_line;
|
||||
}
|
||||
|
||||
my $text = $response->decoded_content;
|
||||
my ($version, $date) = $text =~ m/^\s+BUILD_REVISION => (\d+).*^\s+BUILD_DATE\s+=> "([^"]+)"/ms;
|
||||
|
||||
if (not defined $version or not defined $date) { return "Unable to get version information: data did not match expected format"; }
|
||||
if (not defined $version or not defined $date) {
|
||||
return "Unable to get version information: data did not match expected format";
|
||||
}
|
||||
|
||||
$self->{last_check} = {timestamp => time, version => $version, date => $date};
|
||||
}
|
||||
|
||||
my $target_nick;
|
||||
$target_nick = $self->{pbot}->{nicklist}->is_present_similar($context->{from}, $context->{arguments}) if length $context->{arguments};
|
||||
if (length $context->{arguments}) {
|
||||
$target_nick = $self->{pbot}->{nicklist}->is_present_similar($context->{from}, $context->{arguments});
|
||||
}
|
||||
|
||||
my $result = '/say ';
|
||||
$result .= "$target_nick: " if $target_nick;
|
||||
$result .= $self->version;
|
||||
|
||||
if ($self->{last_check}->{version} > BUILD_REVISION) { $result .= "; new version available: $self->{last_check}->{version} $self->{last_check}->{date}!"; }
|
||||
if ($self->{last_check}->{version} > BUILD_REVISION) {
|
||||
$result .= "; new version available: $self->{last_check}->{version} $self->{last_check}->{date}!";
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub version { return BUILD_NAME . " version " . BUILD_REVISION . " " . BUILD_DATE; }
|
||||
sub version {
|
||||
return BUILD_NAME . " version " . BUILD_REVISION . " " . BUILD_DATE;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
# File: WebPaste.pm
|
||||
# Author: pragma_
|
||||
#
|
||||
# Purpose: Pastes text to web paste sites.
|
||||
# Purpose: Pastes text to a cycling list of web paste sites.
|
||||
|
||||
# This Source Code Form is subject to the terms of the Mozilla Public
|
||||
# License, v. 2.0. If a copy of the MPL was not distributed with this
|
||||
|
|
@ -22,6 +22,9 @@ use Encode;
|
|||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
|
||||
# There used to be many more paste sites in this list but one by one
|
||||
# many have died off. :-(
|
||||
|
||||
$self->{paste_sites} = [
|
||||
sub { $self->paste_0x0st(@_) },
|
||||
# sub { $self->paste_ixio(@_) }, # removed due to being too slow (temporarily hopefully)
|
||||
|
|
@ -32,53 +35,74 @@ sub initialize {
|
|||
|
||||
sub get_paste_site {
|
||||
my ($self) = @_;
|
||||
|
||||
my $subref = $self->{paste_sites}->[$self->{current_site}];
|
||||
if (++$self->{current_site} >= @{$self->{paste_sites}}) { $self->{current_site} = 0; }
|
||||
|
||||
if (++$self->{current_site} >= @{$self->{paste_sites}}) {
|
||||
$self->{current_site} = 0;
|
||||
}
|
||||
|
||||
return $subref;
|
||||
}
|
||||
|
||||
sub paste {
|
||||
my ($self, $text, %opts) = @_;
|
||||
|
||||
my %default_opts = (
|
||||
no_split => 0,
|
||||
);
|
||||
|
||||
%opts = (%default_opts, %opts);
|
||||
|
||||
$text =~ s/(.{120})\s/$1\n/g unless $opts{no_split};
|
||||
|
||||
my $result;
|
||||
my $response;
|
||||
|
||||
for (my $tries = 3; $tries > 0; $tries--) {
|
||||
my $paste_site = $self->get_paste_site;
|
||||
$result = $paste_site->($text);
|
||||
last if $result !~ m/error pasting/;
|
||||
|
||||
$response = $paste_site->($text);
|
||||
|
||||
last if $response->is_success;
|
||||
}
|
||||
|
||||
if (not $response->is_success) {
|
||||
return "error pasting: " . $response->status_line;
|
||||
}
|
||||
|
||||
my $result = $response->decoded_content;
|
||||
|
||||
$result =~ s/^\s+|\s+$//g;
|
||||
|
||||
alarm 1; # LWP::UserAgent::Paranoid kills alarm
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub paste_0x0st {
|
||||
my ($self, $text) = @_;
|
||||
|
||||
my $ua = LWP::UserAgent::Paranoid->new(request_timeout => 10);
|
||||
|
||||
push @{$ua->requests_redirectable}, 'POST';
|
||||
my $response = $ua->post(
|
||||
|
||||
return $ua->post(
|
||||
"https://0x0.st",
|
||||
[ file => [ undef, "file", Content => $text ] ],
|
||||
Content_Type => 'form-data'
|
||||
);
|
||||
alarm 1; # LWP::UserAgent::Paranoid kills alarm
|
||||
return "error pasting: " . $response->status_line if not $response->is_success;
|
||||
return $response->content;
|
||||
}
|
||||
|
||||
sub paste_ixio {
|
||||
my ($self, $text) = @_;
|
||||
|
||||
my $ua = LWP::UserAgent::Paranoid->new(request_timeout => 10);
|
||||
|
||||
push @{$ua->requests_redirectable}, 'POST';
|
||||
my %post = ('f:1' => $text);
|
||||
my $response = $ua->post("http://ix.io", \%post);
|
||||
alarm 1; # LWP::UserAgent::Paranoid kills alarm
|
||||
return "error pasting: " . $response->status_line if not $response->is_success;
|
||||
return $response->content;
|
||||
|
||||
my %post = ('f:1' => $text);
|
||||
|
||||
return $ua->post("http://ix.io", \%post);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
3917
|
||||
3998
|
||||
|
|
|
|||
|
|
@ -333,8 +333,7 @@ Name | Description | Belongs to group
|
|||
`can-mode-any` | Allows the [`mode`](#mode) command to set any mode flag. | botowner
|
||||
`can-modify-admins` | Allows the user to modify user accounts that have the `admin` capability | botowner
|
||||
`can-modify-capabilities` | Allows the user to use the [`useradd`](#useradd) or [`userset`](#userset) commands to add or remove capabilities from users. | botowner
|
||||
`can-group-capabilities` | Allows the user to use the [`cap group`](#cap) command to modify capability groups. | botowner
|
||||
`can-ungroup-capabilities` | Allows the user to use the [`cap ungroup`](#cap) command to modify capability groups. | botowner
|
||||
`can-group-capabilities` | Allows the user to use the [`cap group`](#cap) and [`cap ungroup`](#cap) commands to modify capability groups. | botowner
|
||||
`can-clear-bans` | Allows the user to use [`unban *`](#unbanunmute) to clear a channel's bans. | botowner, admin
|
||||
`can-clear-mutes` | Allows the user to use [`unmute *`](#unbanunmute) to clear a channel's mutes. | botowner, admin
|
||||
`can-kick-wildcard` | Allows the user to use wildcards with the [`kick`](#kick) command. | botowner, admin
|
||||
|
|
|
|||
Loading…
Reference in New Issue