mirror of https://github.com/pragma-/pbot.git
Tidy things up
This commit is contained in:
Pragmatic Software
parent
c14402dd04
commit
5c4e10a35c
1762
PBot/AntiFlood.pm
1762
PBot/AntiFlood.pm
File diff suppressed because it is too large
Load Diff
207
PBot/AntiSpam.pm
207
PBot/AntiSpam.pm
|
|
@ -20,140 +20,125 @@ use Time::HiRes qw(gettimeofday);
|
|||
use POSIX qw/strftime/;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
my $filename = $conf{spamkeywords_file} // $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/spam_keywords';
|
||||
$self->{keywords} = PBot::DualIndexHashObject->new(name => 'SpamKeywords', filename => $filename, pbot => $self->{pbot});
|
||||
$self->{keywords}->load;
|
||||
my ($self, %conf) = @_;
|
||||
my $filename = $conf{spamkeywords_file} // $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/spam_keywords';
|
||||
$self->{keywords} = PBot::DualIndexHashObject->new(name => 'SpamKeywords', filename => $filename, pbot => $self->{pbot});
|
||||
$self->{keywords}->load;
|
||||
|
||||
$self->{pbot}->{registry}->add_default('text', 'antispam', 'enforce', $conf{enforce_antispam} // 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->antispam_cmd(@_) }, "antispam", 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-antispam', 1);
|
||||
$self->{pbot}->{registry}->add_default('text', 'antispam', 'enforce', $conf{enforce_antispam} // 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->antispam_cmd(@_) }, "antispam", 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-antispam', 1);
|
||||
}
|
||||
|
||||
sub is_spam {
|
||||
my ($self, $namespace, $text, $all_namespaces) = @_;
|
||||
my $lc_namespace = lc $namespace;
|
||||
my ($self, $namespace, $text, $all_namespaces) = @_;
|
||||
my $lc_namespace = lc $namespace;
|
||||
|
||||
return 0 if not $self->{pbot}->{registry}->get_value('antispam', 'enforce');
|
||||
return 0 if $self->{pbot}->{registry}->get_value($namespace, 'dont_enforce_antispam');
|
||||
return 0 if not $self->{pbot}->{registry}->get_value('antispam', 'enforce');
|
||||
return 0 if $self->{pbot}->{registry}->get_value($namespace, 'dont_enforce_antispam');
|
||||
|
||||
my $ret = eval {
|
||||
foreach my $space ($self->{keywords}->get_keys) {
|
||||
if ($all_namespaces or $lc_namespace eq $space) {
|
||||
foreach my $keyword ($self->{keywords}->get_keys($space)) {
|
||||
return 1 if $text =~ m/$keyword/i;
|
||||
my $ret = eval {
|
||||
foreach my $space ($self->{keywords}->get_keys) {
|
||||
if ($all_namespaces or $lc_namespace eq $space) {
|
||||
foreach my $keyword ($self->{keywords}->get_keys($space)) { return 1 if $text =~ m/$keyword/i; }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
};
|
||||
return 0;
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Error in is_spam: $@");
|
||||
return 0;
|
||||
}
|
||||
$self->{pbot}->{logger}->log("AntiSpam: spam detected!\n") if $ret;
|
||||
return $ret;
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Error in is_spam: $@");
|
||||
return 0;
|
||||
}
|
||||
$self->{pbot}->{logger}->log("AntiSpam: spam detected!\n") if $ret;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub antispam_cmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
|
||||
my $arglist = $stuff->{arglist};
|
||||
my $arglist = $stuff->{arglist};
|
||||
|
||||
my $command = $self->{pbot}->{interpreter}->shift_arg($arglist);
|
||||
my $command = $self->{pbot}->{interpreter}->shift_arg($arglist);
|
||||
|
||||
return "Usage: antispam <command>, where commands are: list/show, add, remove, set, unset" if not defined $command;
|
||||
return "Usage: antispam <command>, where commands are: list/show, add, remove, set, unset" if not defined $command;
|
||||
|
||||
given ($command) {
|
||||
when ($_ eq "list" or $_ eq "show") {
|
||||
my $text = "Spam keywords:\n";
|
||||
my $entries = 0;
|
||||
foreach my $namespace ($self->{keywords}->get_keys) {
|
||||
$text .= ' ' . $self->{keywords}->get_data($namespace, '_name') . ":\n";
|
||||
foreach my $keyword ($self->{keywords}->get_keys($namespace)) {
|
||||
$text .= ' ' . $self->{keywords}->get_data($namespace, $keyword, '_name') . ",\n";
|
||||
$entries++;
|
||||
given ($command) {
|
||||
when ($_ eq "list" or $_ eq "show") {
|
||||
my $text = "Spam keywords:\n";
|
||||
my $entries = 0;
|
||||
foreach my $namespace ($self->{keywords}->get_keys) {
|
||||
$text .= ' ' . $self->{keywords}->get_data($namespace, '_name') . ":\n";
|
||||
foreach my $keyword ($self->{keywords}->get_keys($namespace)) {
|
||||
$text .= ' ' . $self->{keywords}->get_data($namespace, $keyword, '_name') . ",\n";
|
||||
$entries++;
|
||||
}
|
||||
}
|
||||
$text .= "none" if $entries == 0;
|
||||
return $text;
|
||||
}
|
||||
}
|
||||
$text .= "none" if $entries == 0;
|
||||
return $text;
|
||||
}
|
||||
when ("set") {
|
||||
my ($namespace, $keyword, $flag, $value) = $self->{pbot}->{interpreter}->split_args($arglist, 4);
|
||||
return "Usage: antispam set <namespace> <regex> [flag [value]]" if not defined $namespace or not defined $keyword;
|
||||
when ("set") {
|
||||
my ($namespace, $keyword, $flag, $value) = $self->{pbot}->{interpreter}->split_args($arglist, 4);
|
||||
return "Usage: antispam set <namespace> <regex> [flag [value]]" if not defined $namespace or not defined $keyword;
|
||||
|
||||
if (not $self->{keywords}->exists($namespace)) {
|
||||
return "There is no such namespace `$namespace`.";
|
||||
}
|
||||
if (not $self->{keywords}->exists($namespace)) { return "There is no such namespace `$namespace`."; }
|
||||
|
||||
if (not $self->{keywords}->exists($namespace, $keyword)) {
|
||||
return "There is no such regex `$keyword` for namespace `" . $self->{keywords}->get_data($namespace, '_name') . '`.';
|
||||
}
|
||||
if (not $self->{keywords}->exists($namespace, $keyword)) {
|
||||
return "There is no such regex `$keyword` for namespace `" . $self->{keywords}->get_data($namespace, '_name') . '`.';
|
||||
}
|
||||
|
||||
if (not defined $flag) {
|
||||
my $text = "Flags:\n";
|
||||
my $comma = '';
|
||||
foreach $flag ($self->{keywords}->get_keys($namespace, $keyword)) {
|
||||
if ($flag eq 'created_on') {
|
||||
my $timestamp = strftime "%a %b %e %H:%M:%S %Z %Y", localtime $self->{keywords}->get_data($namespace, $keyword, $flag);
|
||||
$text .= $comma . "created_on: $timestamp";
|
||||
} else {
|
||||
$value = $self->{keywords}->get_data($namespace, $keyword, $flag);
|
||||
$text .= $comma . "$flag: $value";
|
||||
}
|
||||
$comma = ",\n ";
|
||||
if (not defined $flag) {
|
||||
my $text = "Flags:\n";
|
||||
my $comma = '';
|
||||
foreach $flag ($self->{keywords}->get_keys($namespace, $keyword)) {
|
||||
if ($flag eq 'created_on') {
|
||||
my $timestamp = strftime "%a %b %e %H:%M:%S %Z %Y", localtime $self->{keywords}->get_data($namespace, $keyword, $flag);
|
||||
$text .= $comma . "created_on: $timestamp";
|
||||
} else {
|
||||
$value = $self->{keywords}->get_data($namespace, $keyword, $flag);
|
||||
$text .= $comma . "$flag: $value";
|
||||
}
|
||||
$comma = ",\n ";
|
||||
}
|
||||
return $text;
|
||||
}
|
||||
|
||||
if (not defined $value) {
|
||||
$value = $self->{keywords}->get_data($namespace, $keyword, $flag);
|
||||
if (not defined $value) { return "/say $flag is not set."; }
|
||||
else { return "/say $flag is set to $value"; }
|
||||
}
|
||||
$self->{keywords}->set($namespace, $keyword, $flag, $value);
|
||||
return "Flag set.";
|
||||
}
|
||||
return $text;
|
||||
}
|
||||
when ("unset") {
|
||||
my ($namespace, $keyword, $flag) = $self->{pbot}->{interpreter}->split_args($arglist, 3);
|
||||
return "Usage: antispam unset <namespace> <regex> <flag>" if not defined $namespace or not defined $keyword or not defined $flag;
|
||||
|
||||
if (not defined $value) {
|
||||
$value = $self->{keywords}->get_data($namespace, $keyword, $flag);
|
||||
if (not defined $value) {
|
||||
return "/say $flag is not set.";
|
||||
} else {
|
||||
return "/say $flag is set to $value";
|
||||
if (not $self->{keywords}->exists($namespace)) { return "There is no such namespace `$namespace`."; }
|
||||
|
||||
if (not $self->{keywords}->exists($namespace, $keyword)) { return "There is no such keyword `$keyword` for namespace `$namespace`."; }
|
||||
|
||||
if (not $self->{keywords}->exists($namespace, $keyword, $flag)) { return "There is no such flag `$flag` for regex `$keyword` for namespace `$namespace`."; }
|
||||
return $self->{keywords}->remove($namespace, $keyword, $flag);
|
||||
}
|
||||
}
|
||||
$self->{keywords}->set($namespace, $keyword, $flag, $value);
|
||||
return "Flag set.";
|
||||
when ("add") {
|
||||
my ($namespace, $keyword) = $self->{pbot}->{interpreter}->split_args($arglist, 2);
|
||||
return "Usage: antispam add <namespace> <regex>" if not defined $namespace or not defined $keyword;
|
||||
my $data = {
|
||||
owner => "$nick!$user\@$host",
|
||||
created_on => scalar gettimeofday
|
||||
};
|
||||
$self->{keywords}->add($namespace, $keyword, $data);
|
||||
return "/say Added `$keyword`.";
|
||||
}
|
||||
when ("remove") {
|
||||
my ($namespace, $keyword) = $self->{pbot}->{interpreter}->split_args($arglist, 2);
|
||||
return "Usage: antispam remove <namespace> <regex>" if not defined $namespace or not defined $keyword;
|
||||
return $self->{keywords}->remove($namespace, $keyword);
|
||||
}
|
||||
default { return "Unknown command '$command'; commands are: list/show, add, remove"; }
|
||||
}
|
||||
when ("unset") {
|
||||
my ($namespace, $keyword, $flag) = $self->{pbot}->{interpreter}->split_args($arglist, 3);
|
||||
return "Usage: antispam unset <namespace> <regex> <flag>" if not defined $namespace or not defined $keyword or not defined $flag;
|
||||
|
||||
if (not $self->{keywords}->exists($namespace)) {
|
||||
return "There is no such namespace `$namespace`.";
|
||||
}
|
||||
|
||||
if (not $self->{keywords}->exists($namespace, $keyword)) {
|
||||
return "There is no such keyword `$keyword` for namespace `$namespace`.";
|
||||
}
|
||||
|
||||
if (not $self->{keywords}->exists($namespace, $keyword, $flag)) {
|
||||
return "There is no such flag `$flag` for regex `$keyword` for namespace `$namespace`.";
|
||||
}
|
||||
return $self->{keywords}->remove($namespace, $keyword, $flag);
|
||||
}
|
||||
when ("add") {
|
||||
my ($namespace, $keyword) = $self->{pbot}->{interpreter}->split_args($arglist, 2);
|
||||
return "Usage: antispam add <namespace> <regex>" if not defined $namespace or not defined $keyword;
|
||||
my $data = {
|
||||
owner => "$nick!$user\@$host",
|
||||
created_on => scalar gettimeofday
|
||||
};
|
||||
$self->{keywords}->add($namespace, $keyword, $data);
|
||||
return "/say Added `$keyword`.";
|
||||
}
|
||||
when ("remove") {
|
||||
my ($namespace, $keyword) = $self->{pbot}->{interpreter}->split_args($arglist, 2);
|
||||
return "Usage: antispam remove <namespace> <regex>" if not defined $namespace or not defined $keyword;
|
||||
return $self->{keywords}->remove($namespace, $keyword);
|
||||
}
|
||||
default {
|
||||
return "Unknown command '$command'; commands are: list/show, add, remove";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::BanTracker;
|
||||
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -19,213 +20,208 @@ use feature 'unicode_strings';
|
|||
use Time::HiRes qw/gettimeofday/;
|
||||
use Time::Duration;
|
||||
use Data::Dumper;
|
||||
|
||||
$Data::Dumper::Sortkeys = 1;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('text', 'bantracker', 'chanserv_ban_timeout', '604800');
|
||||
$self->{pbot}->{registry}->add_default('text', 'bantracker', 'mute_timeout', '604800');
|
||||
$self->{pbot}->{registry}->add_default('text', 'bantracker', 'debug', '0');
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('text', 'bantracker', 'chanserv_ban_timeout', '604800');
|
||||
$self->{pbot}->{registry}->add_default('text', 'bantracker', 'mute_timeout', '604800');
|
||||
$self->{pbot}->{registry}->add_default('text', 'bantracker', 'debug', '0');
|
||||
|
||||
$self->{pbot}->{commands}->register(sub { $self->dumpbans(@_) }, "dumpbans", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->dumpbans(@_) }, "dumpbans", 1);
|
||||
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.endofnames', sub { $self->get_banlist(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.banlist', sub { $self->on_banlist_entry(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.quietlist', sub { $self->on_quietlist_entry(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.endofnames', sub { $self->get_banlist(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.banlist', sub { $self->on_banlist_entry(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.quietlist', sub { $self->on_quietlist_entry(@_) });
|
||||
|
||||
$self->{banlist} = {};
|
||||
$self->{banlist} = {};
|
||||
}
|
||||
|
||||
sub dumpbans {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my $bans = Dumper($self->{banlist});
|
||||
return $bans;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my $bans = Dumper($self->{banlist});
|
||||
return $bans;
|
||||
}
|
||||
|
||||
sub get_banlist {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my $channel = lc $event->{event}->{args}[1];
|
||||
return 0 if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
delete $self->{banlist}->{$channel};
|
||||
$self->{pbot}->{logger}->log("Retrieving banlist for $channel.\n");
|
||||
$event->{conn}->sl("mode $channel +bq");
|
||||
return 0;
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my $channel = lc $event->{event}->{args}[1];
|
||||
return 0 if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
delete $self->{banlist}->{$channel};
|
||||
$self->{pbot}->{logger}->log("Retrieving banlist for $channel.\n");
|
||||
$event->{conn}->sl("mode $channel +bq");
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_banlist_entry {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my $channel = lc $event->{event}->{args}[1];
|
||||
my $target = lc $event->{event}->{args}[2];
|
||||
my $source = lc $event->{event}->{args}[3];
|
||||
my $timestamp = $event->{event}->{args}[4];
|
||||
|
||||
my $ago = ago(gettimeofday - $timestamp);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
|
||||
$self->{pbot}->{logger}->log("ban-tracker: [banlist entry] $channel: $target banned by $source $ago.\n");
|
||||
$self->{banlist}->{$channel}->{'+b'}->{$target} = [ $source, $timestamp ];
|
||||
my $channel = lc $event->{event}->{args}[1];
|
||||
my $target = lc $event->{event}->{args}[2];
|
||||
my $source = lc $event->{event}->{args}[3];
|
||||
my $timestamp = $event->{event}->{args}[4];
|
||||
|
||||
if ($target =~ m/^\*!\*@/ or $target =~ m/^\*!.*\@gateway\/web/i) {
|
||||
my $timeout = 60 * 60 * 24 * 7;
|
||||
my $ago = ago(gettimeofday - $timestamp);
|
||||
|
||||
if ($target =~ m/\// and $target !~ m/\@gateway/) {
|
||||
$timeout = 0; # permanent bans for cloaks that aren't gateway
|
||||
$self->{pbot}->{logger}->log("ban-tracker: [banlist entry] $channel: $target banned by $source $ago.\n");
|
||||
$self->{banlist}->{$channel}->{'+b'}->{$target} = [$source, $timestamp];
|
||||
|
||||
if ($target =~ m/^\*!\*@/ or $target =~ m/^\*!.*\@gateway\/web/i) {
|
||||
my $timeout = 60 * 60 * 24 * 7;
|
||||
|
||||
if ($target =~ m/\// and $target !~ m/\@gateway/) {
|
||||
$timeout = 0; # permanent bans for cloaks that aren't gateway
|
||||
}
|
||||
|
||||
if ($timeout && $self->{pbot}->{chanops}->can_gain_ops($channel)) {
|
||||
if (not $self->{pbot}->{chanops}->{unban_timeout}->exists($channel, $target)) {
|
||||
$self->{pbot}->{logger}->log("Temp ban for $target in $channel.\n");
|
||||
my $data = {
|
||||
timeout => gettimeofday + $timeout,
|
||||
owner => $source,
|
||||
reason => 'Temp ban on *!*@... or *!...@gateway/web'
|
||||
};
|
||||
$self->{pbot}->{chanops}->{unban_timeout}->add($channel, $target, $data);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($timeout && $self->{pbot}->{chanops}->can_gain_ops($channel)) {
|
||||
if (not $self->{pbot}->{chanops}->{unban_timeout}->exists($channel, $target)) {
|
||||
$self->{pbot}->{logger}->log("Temp ban for $target in $channel.\n");
|
||||
my $data = {
|
||||
timeout => gettimeofday + $timeout,
|
||||
owner => $source,
|
||||
reason => 'Temp ban on *!*@... or *!...@gateway/web'
|
||||
};
|
||||
$self->{pbot}->{chanops}->{unban_timeout}->add($channel, $target, $data);
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_quietlist_entry {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my $channel = lc $event->{event}->{args}[1];
|
||||
my $target = lc $event->{event}->{args}[3];
|
||||
my $source = lc $event->{event}->{args}[4];
|
||||
my $timestamp = $event->{event}->{args}[5];
|
||||
|
||||
my $ago = ago(gettimeofday - $timestamp);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
|
||||
$self->{pbot}->{logger}->log("ban-tracker: [quietlist entry] $channel: $target quieted by $source $ago.\n");
|
||||
$self->{banlist}->{$channel}->{'+q'}->{$target} = [ $source, $timestamp ];
|
||||
return 0;
|
||||
my $channel = lc $event->{event}->{args}[1];
|
||||
my $target = lc $event->{event}->{args}[3];
|
||||
my $source = lc $event->{event}->{args}[4];
|
||||
my $timestamp = $event->{event}->{args}[5];
|
||||
|
||||
my $ago = ago(gettimeofday - $timestamp);
|
||||
|
||||
$self->{pbot}->{logger}->log("ban-tracker: [quietlist entry] $channel: $target quieted by $source $ago.\n");
|
||||
$self->{banlist}->{$channel}->{'+q'}->{$target} = [$source, $timestamp];
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub get_baninfo {
|
||||
my ($self, $mask, $channel, $account) = @_;
|
||||
my ($bans, $ban_account);
|
||||
my ($self, $mask, $channel, $account) = @_;
|
||||
my ($bans, $ban_account);
|
||||
|
||||
$account = undef if not length $account;
|
||||
$account = lc $account if defined $account;
|
||||
$account = undef if not length $account;
|
||||
$account = lc $account if defined $account;
|
||||
|
||||
if ($self->{pbot}->{registry}->get_value('bantracker', 'debug')) {
|
||||
$self->{pbot}->{logger}->log("[get-baninfo] Getting baninfo for $mask in $channel using account " . (defined $account ? $account : "[undefined]") . "\n");
|
||||
}
|
||||
|
||||
my ($nick, $user, $host) = $mask =~ m/([^!]+)!([^@]+)@(.*)/;
|
||||
|
||||
foreach my $mode (keys %{ $self->{banlist}->{$channel} }) {
|
||||
foreach my $banmask (keys %{ $self->{banlist}->{$channel}->{$mode} }) {
|
||||
if ($banmask =~ m/^\$a:(.*)/) {
|
||||
$ban_account = lc $1;
|
||||
} else {
|
||||
$ban_account = "";
|
||||
}
|
||||
|
||||
my $banmask_key = $banmask;
|
||||
$banmask = quotemeta $banmask;
|
||||
$banmask =~ s/\\\*/.*?/g;
|
||||
$banmask =~ s/\\\?/./g;
|
||||
|
||||
my $banned;
|
||||
|
||||
$banned = 1 if defined $account and $account eq $ban_account;
|
||||
$banned = 1 if $mask =~ m/^$banmask$/i;
|
||||
|
||||
if ($banmask_key =~ m{\@gateway/web/irccloud.com} and $host =~ m{^gateway/web/irccloud.com}) {
|
||||
my ($bannick, $banuser, $banhost) = $banmask_key =~ m/([^!]+)!([^@]+)@(.*)/;
|
||||
|
||||
if (lc $user eq lc $banuser) {
|
||||
$banned = 1;
|
||||
}
|
||||
}
|
||||
|
||||
if ($banned) {
|
||||
if (not defined $bans) {
|
||||
$bans = [];
|
||||
}
|
||||
|
||||
my $baninfo = {};
|
||||
$baninfo->{banmask} = $banmask_key;
|
||||
$baninfo->{channel} = $channel;
|
||||
$baninfo->{owner} = $self->{banlist}->{$channel}->{$mode}->{$banmask_key}->[0];
|
||||
$baninfo->{when} = $self->{banlist}->{$channel}->{$mode}->{$banmask_key}->[1];
|
||||
$baninfo->{type} = $mode;
|
||||
#$self->{pbot}->{logger}->log("get-baninfo: dump: " . Dumper($baninfo) . "\n");
|
||||
#$self->{pbot}->{logger}->log("get-baninfo: $baninfo->{banmask} $baninfo->{type} in $baninfo->{channel} by $baninfo->{owner} on $baninfo->{when}\n");
|
||||
|
||||
push @$bans, $baninfo;
|
||||
}
|
||||
if ($self->{pbot}->{registry}->get_value('bantracker', 'debug')) {
|
||||
$self->{pbot}->{logger}->log("[get-baninfo] Getting baninfo for $mask in $channel using account " . (defined $account ? $account : "[undefined]") . "\n");
|
||||
}
|
||||
}
|
||||
|
||||
return $bans;
|
||||
my ($nick, $user, $host) = $mask =~ m/([^!]+)!([^@]+)@(.*)/;
|
||||
|
||||
foreach my $mode (keys %{$self->{banlist}->{$channel}}) {
|
||||
foreach my $banmask (keys %{$self->{banlist}->{$channel}->{$mode}}) {
|
||||
if ($banmask =~ m/^\$a:(.*)/) { $ban_account = lc $1; }
|
||||
else { $ban_account = ""; }
|
||||
|
||||
my $banmask_key = $banmask;
|
||||
$banmask = quotemeta $banmask;
|
||||
$banmask =~ s/\\\*/.*?/g;
|
||||
$banmask =~ s/\\\?/./g;
|
||||
|
||||
my $banned;
|
||||
|
||||
$banned = 1 if defined $account and $account eq $ban_account;
|
||||
$banned = 1 if $mask =~ m/^$banmask$/i;
|
||||
|
||||
if ($banmask_key =~ m{\@gateway/web/irccloud.com} and $host =~ m{^gateway/web/irccloud.com}) {
|
||||
my ($bannick, $banuser, $banhost) = $banmask_key =~ m/([^!]+)!([^@]+)@(.*)/;
|
||||
|
||||
if (lc $user eq lc $banuser) { $banned = 1; }
|
||||
}
|
||||
|
||||
if ($banned) {
|
||||
if (not defined $bans) { $bans = []; }
|
||||
|
||||
my $baninfo = {};
|
||||
$baninfo->{banmask} = $banmask_key;
|
||||
$baninfo->{channel} = $channel;
|
||||
$baninfo->{owner} = $self->{banlist}->{$channel}->{$mode}->{$banmask_key}->[0];
|
||||
$baninfo->{when} = $self->{banlist}->{$channel}->{$mode}->{$banmask_key}->[1];
|
||||
$baninfo->{type} = $mode;
|
||||
|
||||
#$self->{pbot}->{logger}->log("get-baninfo: dump: " . Dumper($baninfo) . "\n");
|
||||
#$self->{pbot}->{logger}->log("get-baninfo: $baninfo->{banmask} $baninfo->{type} in $baninfo->{channel} by $baninfo->{owner} on $baninfo->{when}\n");
|
||||
|
||||
push @$bans, $baninfo;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $bans;
|
||||
}
|
||||
|
||||
sub is_banned {
|
||||
my ($self, $nick, $user, $host, $channel) = @_;
|
||||
my ($self, $nick, $user, $host, $channel) = @_;
|
||||
|
||||
my $message_account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
my @nickserv_accounts = $self->{pbot}->{messagehistory}->{database}->get_nickserv_accounts($message_account);
|
||||
push @nickserv_accounts, undef;
|
||||
my $message_account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
my @nickserv_accounts = $self->{pbot}->{messagehistory}->{database}->get_nickserv_accounts($message_account);
|
||||
push @nickserv_accounts, undef;
|
||||
|
||||
my $banned = undef;
|
||||
my $banned = undef;
|
||||
|
||||
foreach my $nickserv_account (@nickserv_accounts) {
|
||||
my $baninfos = $self->get_baninfo("$nick!$user\@$host", $channel, $nickserv_account);
|
||||
foreach my $nickserv_account (@nickserv_accounts) {
|
||||
my $baninfos = $self->get_baninfo("$nick!$user\@$host", $channel, $nickserv_account);
|
||||
|
||||
if (defined $baninfos) {
|
||||
foreach my $baninfo (@$baninfos) {
|
||||
my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host");
|
||||
my $whitelisted = $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted');
|
||||
if ($self->{pbot}->{antiflood}->ban_exempted($baninfo->{channel}, $baninfo->{banmask}) || $whitelisted) {
|
||||
$self->{pbot}->{logger}->log("[BanTracker] is_banned: $nick!$user\@$host banned as $baninfo->{banmask} in $baninfo->{channel}, but allowed through whitelist\n");
|
||||
} else {
|
||||
if ($channel eq lc $baninfo->{channel}) {
|
||||
my $mode = $baninfo->{type} eq "+b" ? "banned" : "quieted";
|
||||
$self->{pbot}->{logger}->log("[BanTracker] is_banned: $nick!$user\@$host $mode as $baninfo->{banmask} in $baninfo->{channel} by $baninfo->{owner}\n");
|
||||
$banned = $baninfo;
|
||||
last;
|
||||
}
|
||||
if (defined $baninfos) {
|
||||
foreach my $baninfo (@$baninfos) {
|
||||
my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host");
|
||||
my $whitelisted = $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted');
|
||||
if ($self->{pbot}->{antiflood}->ban_exempted($baninfo->{channel}, $baninfo->{banmask}) || $whitelisted) {
|
||||
$self->{pbot}->{logger}->log("[BanTracker] is_banned: $nick!$user\@$host banned as $baninfo->{banmask} in $baninfo->{channel}, but allowed through whitelist\n");
|
||||
} else {
|
||||
if ($channel eq lc $baninfo->{channel}) {
|
||||
my $mode = $baninfo->{type} eq "+b" ? "banned" : "quieted";
|
||||
$self->{pbot}->{logger}->log("[BanTracker] is_banned: $nick!$user\@$host $mode as $baninfo->{banmask} in $baninfo->{channel} by $baninfo->{owner}\n");
|
||||
$banned = $baninfo;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return $banned;
|
||||
return $banned;
|
||||
}
|
||||
|
||||
sub track_mode {
|
||||
my $self = shift;
|
||||
my ($source, $mode, $target, $channel) = @_;
|
||||
my $self = shift;
|
||||
my ($source, $mode, $target, $channel) = @_;
|
||||
|
||||
$mode = lc $mode;
|
||||
$target = lc $target;
|
||||
$channel = lc $channel;
|
||||
$mode = lc $mode;
|
||||
$target = lc $target;
|
||||
$channel = lc $channel;
|
||||
|
||||
if ($mode eq "+b" or $mode eq "+q") {
|
||||
$self->{pbot}->{logger}->log("ban-tracker: $target " . ($mode eq '+b' ? 'banned' : 'quieted') . " by $source in $channel.\n");
|
||||
$self->{banlist}->{$channel}->{$mode}->{$target} = [ $source, gettimeofday ];
|
||||
$self->{pbot}->{antiflood}->devalidate_accounts($target, $channel);
|
||||
}
|
||||
elsif ($mode eq "-b" or $mode eq "-q") {
|
||||
$self->{pbot}->{logger}->log("ban-tracker: $target " . ($mode eq '-b' ? 'unbanned' : 'unquieted') . " by $source in $channel.\n");
|
||||
delete $self->{banlist}->{$channel}->{$mode eq "-b" ? "+b" : "+q"}->{$target};
|
||||
if ($mode eq "+b" or $mode eq "+q") {
|
||||
$self->{pbot}->{logger}->log("ban-tracker: $target " . ($mode eq '+b' ? 'banned' : 'quieted') . " by $source in $channel.\n");
|
||||
$self->{banlist}->{$channel}->{$mode}->{$target} = [$source, gettimeofday];
|
||||
$self->{pbot}->{antiflood}->devalidate_accounts($target, $channel);
|
||||
} elsif ($mode eq "-b" or $mode eq "-q") {
|
||||
$self->{pbot}->{logger}->log("ban-tracker: $target " . ($mode eq '-b' ? 'unbanned' : 'unquieted') . " by $source in $channel.\n");
|
||||
delete $self->{banlist}->{$channel}->{$mode eq "-b" ? "+b" : "+q"}->{$target};
|
||||
|
||||
if ($mode eq "-b") {
|
||||
if ($self->{pbot}->{chanops}->{unban_timeout}->exists($channel, $target)) {
|
||||
$self->{pbot}->{chanops}->{unban_timeout}->remove($channel, $target);
|
||||
} elsif ($self->{pbot}->{chanops}->{unban_timeout}->exists($channel, "$target\$##stop_join_flood")) {
|
||||
# freenode strips channel forwards from unban result if no ban exists with a channel forward
|
||||
$self->{pbot}->{chanops}->{unban_timeout}->remove($channel, "$target\$##stop_join_flood");
|
||||
}
|
||||
if ($mode eq "-b") {
|
||||
if ($self->{pbot}->{chanops}->{unban_timeout}->exists($channel, $target)) { $self->{pbot}->{chanops}->{unban_timeout}->remove($channel, $target); }
|
||||
elsif ($self->{pbot}->{chanops}->{unban_timeout}->exists($channel, "$target\$##stop_join_flood")) {
|
||||
|
||||
# freenode strips channel forwards from unban result if no ban exists with a channel forward
|
||||
$self->{pbot}->{chanops}->{unban_timeout}->remove($channel, "$target\$##stop_join_flood");
|
||||
}
|
||||
} elsif ($mode eq "-q") {
|
||||
if ($self->{pbot}->{chanops}->{unmute_timeout}->exists($channel, $target)) { $self->{pbot}->{chanops}->{unmute_timeout}->remove($channel, $target); }
|
||||
}
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("BanTracker: Unknown mode '$mode'\n");
|
||||
}
|
||||
elsif ($mode eq "-q") {
|
||||
if ($self->{pbot}->{chanops}->{unmute_timeout}->exists($channel, $target)) {
|
||||
$self->{pbot}->{chanops}->{unmute_timeout}->remove($channel, $target);
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("BanTracker: Unknown mode '$mode'\n");
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -19,134 +19,128 @@ no if $] >= 5.018, warnings => "experimental::smartmatch";
|
|||
use Time::HiRes qw(gettimeofday);
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{filename} = $conf{filename};
|
||||
$self->{blacklist} = {};
|
||||
$self->{pbot}->{commands}->register(sub { $self->blacklist(@_) }, "blacklist", 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-blacklist', 1);
|
||||
$self->load_blacklist;
|
||||
my ($self, %conf) = @_;
|
||||
$self->{filename} = $conf{filename};
|
||||
$self->{blacklist} = {};
|
||||
$self->{pbot}->{commands}->register(sub { $self->blacklist(@_) }, "blacklist", 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-blacklist', 1);
|
||||
$self->load_blacklist;
|
||||
}
|
||||
|
||||
sub add {
|
||||
my ($self, $channel, $hostmask) = @_;
|
||||
$self->{blacklist}->{lc $channel}->{lc $hostmask} = 1;
|
||||
$self->save_blacklist();
|
||||
my ($self, $channel, $hostmask) = @_;
|
||||
$self->{blacklist}->{lc $channel}->{lc $hostmask} = 1;
|
||||
$self->save_blacklist();
|
||||
}
|
||||
|
||||
sub remove {
|
||||
my $self = shift;
|
||||
my ($channel, $hostmask) = @_;
|
||||
my $self = shift;
|
||||
my ($channel, $hostmask) = @_;
|
||||
|
||||
$channel = lc $channel;
|
||||
$hostmask = lc $hostmask;
|
||||
$channel = lc $channel;
|
||||
$hostmask = lc $hostmask;
|
||||
|
||||
if (exists $self->{blacklist}->{$channel}) {
|
||||
delete $self->{blacklist}->{$channel}->{$hostmask};
|
||||
if (exists $self->{blacklist}->{$channel}) {
|
||||
delete $self->{blacklist}->{$channel}->{$hostmask};
|
||||
|
||||
if (keys %{ $self->{blacklist}->{$channel} } == 0) {
|
||||
delete $self->{blacklist}->{$channel};
|
||||
if (keys %{$self->{blacklist}->{$channel}} == 0) { delete $self->{blacklist}->{$channel}; }
|
||||
}
|
||||
}
|
||||
$self->save_blacklist();
|
||||
$self->save_blacklist();
|
||||
}
|
||||
|
||||
sub clear_blacklist {
|
||||
my $self = shift;
|
||||
$self->{blacklist} = {};
|
||||
my $self = shift;
|
||||
$self->{blacklist} = {};
|
||||
}
|
||||
|
||||
sub load_blacklist {
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
if (@_) { $filename = shift; } else { $filename = $self->{filename}; }
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
if (@_) { $filename = shift; }
|
||||
else { $filename = $self->{filename}; }
|
||||
|
||||
if (not defined $filename) {
|
||||
$self->{pbot}->{logger}->log("No blacklist path specified -- skipping loading of blacklist");
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Loading blacklist from $filename ...\n");
|
||||
|
||||
open(FILE, "< $filename") or Carp::croak "Couldn't open $filename: $!\n";
|
||||
my @contents = <FILE>;
|
||||
close(FILE);
|
||||
|
||||
my $i = 0;
|
||||
|
||||
foreach my $line (@contents) {
|
||||
chomp $line;
|
||||
$i++;
|
||||
|
||||
my ($channel, $hostmask) = split(/\s+/, $line);
|
||||
|
||||
if (not defined $hostmask || not defined $channel) {
|
||||
Carp::croak "Syntax error around line $i of $filename\n";
|
||||
if (not defined $filename) {
|
||||
$self->{pbot}->{logger}->log("No blacklist path specified -- skipping loading of blacklist");
|
||||
return;
|
||||
}
|
||||
|
||||
if (exists $self->{blacklist}->{$channel}->{$hostmask}) {
|
||||
Carp::croak "Duplicate blacklist entry [$hostmask][$channel] found in $filename around line $i\n";
|
||||
$self->{pbot}->{logger}->log("Loading blacklist from $filename ...\n");
|
||||
|
||||
open(FILE, "< $filename") or Carp::croak "Couldn't open $filename: $!\n";
|
||||
my @contents = <FILE>;
|
||||
close(FILE);
|
||||
|
||||
my $i = 0;
|
||||
|
||||
foreach my $line (@contents) {
|
||||
chomp $line;
|
||||
$i++;
|
||||
|
||||
my ($channel, $hostmask) = split(/\s+/, $line);
|
||||
|
||||
if (not defined $hostmask || not defined $channel) { Carp::croak "Syntax error around line $i of $filename\n"; }
|
||||
|
||||
if (exists $self->{blacklist}->{$channel}->{$hostmask}) { Carp::croak "Duplicate blacklist entry [$hostmask][$channel] found in $filename around line $i\n"; }
|
||||
|
||||
$self->{blacklist}->{$channel}->{$hostmask} = 1;
|
||||
}
|
||||
|
||||
$self->{blacklist}->{$channel}->{$hostmask} = 1;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log(" $i entries in blacklist\n");
|
||||
$self->{pbot}->{logger}->log(" $i entries in blacklist\n");
|
||||
}
|
||||
|
||||
sub save_blacklist {
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
|
||||
if (@_) { $filename = shift; } else { $filename = $self->{filename}; }
|
||||
if (@_) { $filename = shift; }
|
||||
else { $filename = $self->{filename}; }
|
||||
|
||||
if (not defined $filename) {
|
||||
$self->{pbot}->{logger}->log("No blacklist path specified -- skipping saving of blacklist\n");
|
||||
return;
|
||||
}
|
||||
|
||||
open(FILE, "> $filename") or die "Couldn't open $filename: $!\n";
|
||||
|
||||
foreach my $channel (keys %{ $self->{blacklist} }) {
|
||||
foreach my $hostmask (keys %{ $self->{blacklist}->{$channel} }) {
|
||||
print FILE "$channel $hostmask\n";
|
||||
if (not defined $filename) {
|
||||
$self->{pbot}->{logger}->log("No blacklist path specified -- skipping saving of blacklist\n");
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
close(FILE);
|
||||
open(FILE, "> $filename") or die "Couldn't open $filename: $!\n";
|
||||
|
||||
foreach my $channel (keys %{$self->{blacklist}}) {
|
||||
foreach my $hostmask (keys %{$self->{blacklist}->{$channel}}) { print FILE "$channel $hostmask\n"; }
|
||||
}
|
||||
|
||||
close(FILE);
|
||||
}
|
||||
|
||||
sub check_blacklist {
|
||||
my $self = shift;
|
||||
my ($hostmask, $channel, $nickserv, $gecos) = @_;
|
||||
my $self = shift;
|
||||
my ($hostmask, $channel, $nickserv, $gecos) = @_;
|
||||
|
||||
return 0 if not defined $channel;
|
||||
return 0 if not defined $channel;
|
||||
|
||||
foreach my $black_channel (keys %{ $self->{blacklist} }) {
|
||||
foreach my $black_hostmask (keys %{ $self->{blacklist}->{$black_channel} }) {
|
||||
my $flag = '';
|
||||
$flag = $1 if $black_hostmask =~ s/^\$(.)://;
|
||||
foreach my $black_channel (keys %{$self->{blacklist}}) {
|
||||
foreach my $black_hostmask (keys %{$self->{blacklist}->{$black_channel}}) {
|
||||
my $flag = '';
|
||||
$flag = $1 if $black_hostmask =~ s/^\$(.)://;
|
||||
|
||||
my $black_channel_escaped = quotemeta $black_channel;
|
||||
my $black_hostmask_escaped = quotemeta $black_hostmask;
|
||||
my $black_channel_escaped = quotemeta $black_channel;
|
||||
my $black_hostmask_escaped = quotemeta $black_hostmask;
|
||||
|
||||
$black_channel_escaped =~ s/\\(\.|\*)/$1/g;
|
||||
$black_hostmask_escaped =~ s/\\(\.|\*)/$1/g;
|
||||
$black_channel_escaped =~ s/\\(\.|\*)/$1/g;
|
||||
$black_hostmask_escaped =~ s/\\(\.|\*)/$1/g;
|
||||
|
||||
next if $channel !~ /^$black_channel_escaped$/;
|
||||
next if $channel !~ /^$black_channel_escaped$/;
|
||||
|
||||
if ($flag eq 'a' && defined $nickserv && $nickserv =~ /^$black_hostmask_escaped$/i) {
|
||||
$self->{pbot}->{logger}->log("$hostmask nickserv $nickserv blacklisted in channel $channel (matches [\$a:$black_hostmask] host and [$black_channel] channel)\n");
|
||||
return 1;
|
||||
} elsif ($flag eq 'r' && defined $gecos && $gecos =~ /^$black_hostmask_escaped$/i) {
|
||||
$self->{pbot}->{logger}->log("$hostmask GECOS $gecos blacklisted in channel $channel (matches [\$r:$black_hostmask] host and [$black_channel] channel)\n");
|
||||
return 1;
|
||||
} elsif ($flag eq '' && $hostmask =~ /^$black_hostmask_escaped$/i) {
|
||||
$self->{pbot}->{logger}->log("$hostmask blacklisted in channel $channel (matches [$black_hostmask] host and [$black_channel] channel)\n");
|
||||
return 1;
|
||||
}
|
||||
if ($flag eq 'a' && defined $nickserv && $nickserv =~ /^$black_hostmask_escaped$/i) {
|
||||
$self->{pbot}->{logger}->log("$hostmask nickserv $nickserv blacklisted in channel $channel (matches [\$a:$black_hostmask] host and [$black_channel] channel)\n");
|
||||
return 1;
|
||||
} elsif ($flag eq 'r' && defined $gecos && $gecos =~ /^$black_hostmask_escaped$/i) {
|
||||
$self->{pbot}->{logger}->log("$hostmask GECOS $gecos blacklisted in channel $channel (matches [\$r:$black_hostmask] host and [$black_channel] channel)\n");
|
||||
return 1;
|
||||
} elsif ($flag eq '' && $hostmask =~ /^$black_hostmask_escaped$/i) {
|
||||
$self->{pbot}->{logger}->log("$hostmask blacklisted in channel $channel (matches [$black_hostmask] host and [$black_channel] channel)\n");
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub blacklist {
|
||||
|
|
@ -161,18 +155,15 @@ sub blacklist {
|
|||
|
||||
given ($command) {
|
||||
when ($_ eq "list" or $_ eq "show") {
|
||||
my $text = "Blacklist:\n";
|
||||
my $text = "Blacklist:\n";
|
||||
my $entries = 0;
|
||||
foreach my $channel (sort keys %{ $self->{blacklist} }) {
|
||||
if ($channel eq '.*') {
|
||||
$text .= " all channels:\n";
|
||||
} else {
|
||||
$text .= " $channel:\n";
|
||||
}
|
||||
foreach my $mask (sort keys %{ $self->{blacklist}->{$channel} }) {
|
||||
$text .= " $mask,\n";
|
||||
$entries++;
|
||||
}
|
||||
foreach my $channel (sort keys %{$self->{blacklist}}) {
|
||||
if ($channel eq '.*') { $text .= " all channels:\n"; }
|
||||
else { $text .= " $channel:\n"; }
|
||||
foreach my $mask (sort keys %{$self->{blacklist}->{$channel}}) {
|
||||
$text .= " $mask,\n";
|
||||
$entries++;
|
||||
}
|
||||
}
|
||||
$text .= "none" if $entries == 0;
|
||||
return "/msg $nick $text";
|
||||
|
|
@ -194,17 +185,15 @@ sub blacklist {
|
|||
$channel = '.*' if not defined $channel;
|
||||
|
||||
if (exists $self->{blacklist}->{$channel} and not exists $self->{blacklist}->{$channel}->{$mask}) {
|
||||
$self->{pbot}->{logger}->log("$nick attempt to remove nonexistent [$mask][$channel] from blacklist\n");
|
||||
return "/say $mask not found in blacklist for channel $channel (use `blacklist list` to display blacklist)";
|
||||
$self->{pbot}->{logger}->log("$nick attempt to remove nonexistent [$mask][$channel] from blacklist\n");
|
||||
return "/say $mask not found in blacklist for channel $channel (use `blacklist list` to display blacklist)";
|
||||
}
|
||||
|
||||
$self->remove($channel, $mask);
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host removed [$mask] from blacklist for channel [$channel]\n");
|
||||
return "/say $mask removed from blacklist for channel $channel";
|
||||
}
|
||||
default {
|
||||
return "Unknown command '$command'; commands are: list/show, add, remove";
|
||||
}
|
||||
default { return "Unknown command '$command'; commands are: list/show, add, remove"; }
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -17,261 +17,234 @@ use feature 'switch';
|
|||
no if $] >= 5.018, warnings => "experimental::smartmatch";
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
my $filename = $conf{filename} // $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/capabilities';
|
||||
$self->{caps} = PBot::HashObject->new(name => 'Capabilities', filename => $filename, pbot => $self->{pbot});
|
||||
$self->{caps}->load;
|
||||
# 'cap' command registered in PBot.pm because $self->{pbot}->{commands} is not yet loaded.
|
||||
my ($self, %conf) = @_;
|
||||
my $filename = $conf{filename} // $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/capabilities';
|
||||
$self->{caps} = PBot::HashObject->new(name => 'Capabilities', filename => $filename, pbot => $self->{pbot});
|
||||
$self->{caps}->load;
|
||||
|
||||
# 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);
|
||||
# 'cap' command registered in PBot.pm because $self->{pbot}->{commands} is not yet loaded.
|
||||
|
||||
# add some useful capabilities
|
||||
$self->add('is-whitelisted', undef, 1);
|
||||
# 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);
|
||||
}
|
||||
|
||||
sub has {
|
||||
my ($self, $cap, $subcap, $depth) = @_;
|
||||
my $cap_data = $self->{caps}->get_data($cap);
|
||||
return 0 if not defined $cap_data;
|
||||
return 1 if $cap eq $subcap and $cap_data->{$subcap};
|
||||
my ($self, $cap, $subcap, $depth) = @_;
|
||||
my $cap_data = $self->{caps}->get_data($cap);
|
||||
return 0 if not defined $cap_data;
|
||||
return 1 if $cap eq $subcap and $cap_data->{$subcap};
|
||||
|
||||
$depth //= 10;
|
||||
if (--$depth <= 0) {
|
||||
$self->{pbot}->{logger}->log("Max recursion reached for PBot::Capabilities->has($cap, $subcap)\n");
|
||||
$depth //= 10;
|
||||
if (--$depth <= 0) {
|
||||
$self->{pbot}->{logger}->log("Max recursion reached for PBot::Capabilities->has($cap, $subcap)\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
foreach my $c ($self->{caps}->get_keys($cap)) {
|
||||
return 1 if $c eq $subcap and $cap_data->{$c};
|
||||
return 1 if $self->has($c, $subcap, $depth);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
foreach my $c ($self->{caps}->get_keys($cap)) {
|
||||
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;
|
||||
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;
|
||||
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;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub add {
|
||||
my ($self, $cap, $subcap, $dontsave) = @_;
|
||||
if (not defined $subcap) {
|
||||
if (not $self->{caps}->exists($cap)) {
|
||||
$self->{caps}->add($cap, {}, $dontsave);
|
||||
}
|
||||
} else {
|
||||
if ($self->{caps}->exists($cap)) {
|
||||
$self->{caps}->set($cap, $subcap, 1, $dontsave);
|
||||
my ($self, $cap, $subcap, $dontsave) = @_;
|
||||
if (not defined $subcap) {
|
||||
if (not $self->{caps}->exists($cap)) { $self->{caps}->add($cap, {}, $dontsave); }
|
||||
} else {
|
||||
$self->{caps}->add($cap, { $subcap => 1 }, $dontsave);
|
||||
if ($self->{caps}->exists($cap)) { $self->{caps}->set($cap, $subcap, 1, $dontsave); }
|
||||
else { $self->{caps}->add($cap, {$subcap => 1}, $dontsave); }
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
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)) {
|
||||
$self->{caps}->remove($c, $sub_cap, 1) if $sub_cap eq $cap;
|
||||
}
|
||||
$self->{caps}->remove($c, undef, 1) if $c eq $cap;
|
||||
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)) { $self->{caps}->remove($c, $sub_cap, 1) if $sub_cap eq $cap; }
|
||||
$self->{caps}->remove($c, undef, 1) if $c eq $cap;
|
||||
}
|
||||
} else {
|
||||
$self->{caps}->remove($cap, $subcap, 1) if $self->{caps}->exists($cap);
|
||||
}
|
||||
} else {
|
||||
$self->{caps}->remove($cap, $subcap, 1) if $self->{caps}->exists($cap);
|
||||
}
|
||||
$self->{caps}->save;
|
||||
$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);
|
||||
}
|
||||
my ($self) = @_;
|
||||
$self->{caps}->remove('botowner', undef, 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);
|
||||
my ($self, $capability) = @_;
|
||||
return "No such capability $capability." if defined $capability and not $self->{caps}->exists($capability);
|
||||
|
||||
my @caps;
|
||||
my @groups;
|
||||
my @standalones;
|
||||
my $result;
|
||||
my @caps;
|
||||
my @groups;
|
||||
my @standalones;
|
||||
my $result;
|
||||
|
||||
if (not defined $capability) {
|
||||
@caps = sort $self->{caps}->get_keys;
|
||||
$result = 'Capabilities: ';
|
||||
} else {
|
||||
@caps = sort $self->{caps}->get_keys($capability);
|
||||
return "Capability $capability has no grouped capabilities." if not @caps;
|
||||
$result = "Grouped capabilities for $capability: ";
|
||||
}
|
||||
|
||||
# first list all capabilities that have sub-capabilities (i.e. grouped capabilities)
|
||||
# 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;
|
||||
if (not defined $capability) {
|
||||
@caps = sort $self->{caps}->get_keys;
|
||||
$result = 'Capabilities: ';
|
||||
} else {
|
||||
push @standalones, $cap;
|
||||
@caps = sort $self->{caps}->get_keys($capability);
|
||||
return "Capability $capability has no grouped capabilities." if not @caps;
|
||||
$result = "Grouped capabilities for $capability: ";
|
||||
}
|
||||
}
|
||||
$result .= join ', ', @groups, @standalones;
|
||||
return $result;
|
||||
|
||||
# first list all capabilities that have sub-capabilities (i.e. grouped capabilities)
|
||||
# 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; }
|
||||
}
|
||||
$result .= join ', ', @groups, @standalones;
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub capcmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
|
||||
my $command = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
my $result;
|
||||
given ($command) {
|
||||
when ('list') {
|
||||
my $cap = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
return $self->list($cap);
|
||||
}
|
||||
|
||||
when ('whohas') {
|
||||
my $cap = $self->{pbot}->{interpreter}->shift_arg($stuff->{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);
|
||||
my $result = "Users with capability $cap: ";
|
||||
my $matched = 0;
|
||||
my $users = $self->{pbot}->{users}->{users};
|
||||
foreach my $channel (sort $users->get_keys) {
|
||||
my @matches;
|
||||
foreach my $hostmask (sort $users->get_keys($channel)) {
|
||||
my $u = $users->get_data($channel, $hostmask);
|
||||
push @matches, $u->{name} if $self->userhas($u, $cap);
|
||||
my $command = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
my $result;
|
||||
given ($command) {
|
||||
when ('list') {
|
||||
my $cap = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
return $self->list($cap);
|
||||
}
|
||||
if (@matches) {
|
||||
$result .= '; ' if $matched;
|
||||
my $global = $matched ? 'global: ' : '';
|
||||
$result .= $users->get_data($channel, '_name') eq '.*' ? $global : $users->get_data($channel, '_name') . ': ';
|
||||
$result .= join ', ', @matches;
|
||||
$matched = 1;
|
||||
|
||||
when ('whohas') {
|
||||
my $cap = $self->{pbot}->{interpreter}->shift_arg($stuff->{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);
|
||||
my $result = "Users with capability $cap: ";
|
||||
my $matched = 0;
|
||||
my $users = $self->{pbot}->{users}->{users};
|
||||
foreach my $channel (sort $users->get_keys) {
|
||||
my @matches;
|
||||
foreach my $hostmask (sort $users->get_keys($channel)) {
|
||||
my $u = $users->get_data($channel, $hostmask);
|
||||
push @matches, $u->{name} if $self->userhas($u, $cap);
|
||||
}
|
||||
if (@matches) {
|
||||
$result .= '; ' if $matched;
|
||||
my $global = $matched ? 'global: ' : '';
|
||||
$result .= $users->get_data($channel, '_name') eq '.*' ? $global : $users->get_data($channel, '_name') . ': ';
|
||||
$result .= join ', ', @matches;
|
||||
$matched = 1;
|
||||
}
|
||||
}
|
||||
$result .= 'nobody' if not $matched;
|
||||
return $result;
|
||||
}
|
||||
}
|
||||
$result .= 'nobody' if not $matched;
|
||||
return $result;
|
||||
}
|
||||
|
||||
when ('userhas') {
|
||||
my ($hostmask, $cap) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
return "Usage: cap userhas <user> [capability]; Lists capabilities belonging to <user>" if not defined $hostmask;
|
||||
$cap = lc $cap if defined $cap;
|
||||
when ('userhas') {
|
||||
my ($hostmask, $cap) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
return "Usage: cap userhas <user> [capability]; Lists capabilities belonging to <user>" if not defined $hostmask;
|
||||
$cap = lc $cap if defined $cap;
|
||||
|
||||
my $u = $self->{pbot}->{users}->find_user($from, $hostmask, 1);
|
||||
if (not defined $u) {
|
||||
$from = 'global' if $from !~ /^#/;
|
||||
return "No such user $hostmask in $from."
|
||||
}
|
||||
my $u = $self->{pbot}->{users}->find_user($from, $hostmask, 1);
|
||||
if (not defined $u) {
|
||||
$from = 'global' if $from !~ /^#/;
|
||||
return "No such user $hostmask in $from.";
|
||||
}
|
||||
|
||||
if (defined $cap) {
|
||||
return "Try again. No such capability $cap." if not $self->exists($cap);
|
||||
if ($self->userhas($u, $cap)) {
|
||||
return "Yes. User $u->{name} has capability $cap.";
|
||||
} else {
|
||||
return "No. User $u->{name} does not have capability $cap.";
|
||||
if (defined $cap) {
|
||||
return "Try again. No such capability $cap." if not $self->exists($cap);
|
||||
if ($self->userhas($u, $cap)) { return "Yes. User $u->{name} has capability $cap."; }
|
||||
else { return "No. User $u->{name} does not have capability $cap."; }
|
||||
} else {
|
||||
my $result = "User $u->{name} has capabilities: ";
|
||||
my @groups;
|
||||
my @single;
|
||||
foreach my $key (sort keys %{$u}) {
|
||||
next if $key eq '_name';
|
||||
next if not $self->exists($key);
|
||||
my $count = $self->{caps}->get_keys;
|
||||
if ($count > 0) { push @groups, "$key ($count cap" . ($count == 1 ? '' : 's') . ")"; }
|
||||
else { push @single, $key; }
|
||||
}
|
||||
if (@groups or @single) { $result .= join ', ', @groups, @single; }
|
||||
else { $result = "User $u->{name} has no capabilities."; }
|
||||
return $result;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
my $result = "User $u->{name} has capabilities: ";
|
||||
my @groups;
|
||||
my @single;
|
||||
foreach my $key (sort keys %{$u}) {
|
||||
next if $key eq '_name';
|
||||
next if not $self->exists($key);
|
||||
my $count = $self->{caps}->get_keys;
|
||||
if ($count > 0) {
|
||||
push @groups, "$key ($count cap" . ($count == 1 ? '' : 's') . ")";
|
||||
} else {
|
||||
push @single, $key;
|
||||
}
|
||||
|
||||
when ('group') {
|
||||
my ($cap, $subcaps) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
return "Usage: cap group <existing or new capability> <existing capabilities...>" if not defined $cap or not defined $subcaps;
|
||||
|
||||
my $u = $self->{pbot}->{users}->loggedin($from, "$nick!$user\@$host");
|
||||
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;
|
||||
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;
|
||||
$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 (@groups or @single) {
|
||||
$result .= join ', ', @groups, @single;
|
||||
} else {
|
||||
$result = "User $u->{name} has no capabilities.";
|
||||
|
||||
when ('ungroup') {
|
||||
my ($cap, $subcaps) = $self->{pbot}->{interpreter}->split_args($stuff->{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);
|
||||
|
||||
my $u = $self->{pbot}->{users}->loggedin($from, "$nick!$user\@$host");
|
||||
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;
|
||||
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);
|
||||
$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."; }
|
||||
}
|
||||
|
||||
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 $result;
|
||||
}
|
||||
}
|
||||
|
||||
when ('group') {
|
||||
my ($cap, $subcaps) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
return "Usage: cap group <existing or new capability> <existing capabilities...>" if not defined $cap or not defined $subcaps;
|
||||
|
||||
my $u = $self->{pbot}->{users}->loggedin($from, "$nick!$user\@$host");
|
||||
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;
|
||||
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;
|
||||
$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.";
|
||||
}
|
||||
}
|
||||
|
||||
when ('ungroup') {
|
||||
my ($cap, $subcaps) = $self->{pbot}->{interpreter}->split_args($stuff->{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);
|
||||
|
||||
my $u = $self->{pbot}->{users}->loggedin($from, "$nick!$user\@$host");
|
||||
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;
|
||||
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);
|
||||
$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.";
|
||||
}
|
||||
}
|
||||
|
||||
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 $result;
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
684
PBot/ChanOps.pm
684
PBot/ChanOps.pm
|
|
@ -8,6 +8,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::ChanOps;
|
||||
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -18,496 +19,475 @@ use Time::HiRes qw(gettimeofday);
|
|||
use Time::Duration qw(concise duration);
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
my ($self, %conf) = @_;
|
||||
|
||||
$self->{unban_timeout} = PBot::DualIndexHashObject->new(
|
||||
pbot => $self->{pbot},
|
||||
name => 'Unban Timeouts',
|
||||
filename => $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/unban_timeouts'
|
||||
);
|
||||
$self->{unban_timeout} = PBot::DualIndexHashObject->new(
|
||||
pbot => $self->{pbot},
|
||||
name => 'Unban Timeouts',
|
||||
filename => $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/unban_timeouts'
|
||||
);
|
||||
|
||||
$self->{unban_timeout}->load;
|
||||
$self->{unban_timeout}->load;
|
||||
|
||||
$self->{unmute_timeout} = PBot::DualIndexHashObject->new(
|
||||
pbot => $self->{pbot},
|
||||
name => 'Unmute Timeouts',
|
||||
filename => $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/unmute_timeouts'
|
||||
);
|
||||
$self->{unmute_timeout} = PBot::DualIndexHashObject->new(
|
||||
pbot => $self->{pbot},
|
||||
name => 'Unmute Timeouts',
|
||||
filename => $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/unmute_timeouts'
|
||||
);
|
||||
|
||||
$self->{unmute_timeout}->load;
|
||||
$self->{unmute_timeout}->load;
|
||||
|
||||
$self->{ban_queue} = {};
|
||||
$self->{unban_queue} = {};
|
||||
$self->{ban_queue} = {};
|
||||
$self->{unban_queue} = {};
|
||||
|
||||
$self->{op_commands} = {};
|
||||
$self->{is_opped} = {};
|
||||
$self->{op_requested} = {};
|
||||
$self->{op_commands} = {};
|
||||
$self->{is_opped} = {};
|
||||
$self->{op_requested} = {};
|
||||
|
||||
$self->{commands} = PBot::ChanOpCommands->new(pbot => $self->{pbot});
|
||||
$self->{commands} = PBot::ChanOpCommands->new(pbot => $self->{pbot});
|
||||
|
||||
$self->{pbot}->{registry}->add_default('text', 'general', 'deop_timeout', 300);
|
||||
$self->{pbot}->{registry}->add_default('text', 'general', 'deop_timeout', 300);
|
||||
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_opped_timeouts }, 10);
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_unban_timeouts }, 10);
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_unmute_timeouts }, 10);
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_unban_queue }, 30);
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_opped_timeouts }, 10);
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_unban_timeouts }, 10);
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_unmute_timeouts }, 10);
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_unban_queue }, 30);
|
||||
}
|
||||
|
||||
sub can_gain_ops {
|
||||
my ($self, $channel) = @_;
|
||||
$channel = lc $channel;
|
||||
return $self->{pbot}->{channels}->{channels}->exists($channel)
|
||||
&& $self->{pbot}->{channels}->{channels}->get_data($channel, 'chanop')
|
||||
&& $self->{pbot}->{channels}->{channels}->get_data($channel, 'enabled');
|
||||
my ($self, $channel) = @_;
|
||||
$channel = lc $channel;
|
||||
return
|
||||
$self->{pbot}->{channels}->{channels}->exists($channel)
|
||||
&& $self->{pbot}->{channels}->{channels}->get_data($channel, 'chanop')
|
||||
&& $self->{pbot}->{channels}->{channels}->get_data($channel, 'enabled');
|
||||
}
|
||||
|
||||
sub gain_ops {
|
||||
my $self = shift;
|
||||
my $channel = shift;
|
||||
$channel = lc $channel;
|
||||
my $self = shift;
|
||||
my $channel = shift;
|
||||
$channel = lc $channel;
|
||||
|
||||
return if exists $self->{op_requested}->{$channel};
|
||||
return if not $self->can_gain_ops($channel);
|
||||
return if exists $self->{op_requested}->{$channel};
|
||||
return if not $self->can_gain_ops($channel);
|
||||
|
||||
my $op_nick = $self->{pbot}->{registry}->get_value($channel, 'op_nick') //
|
||||
$self->{pbot}->{registry}->get_value('general', 'op_nick') // 'chanserv';
|
||||
my $op_nick = $self->{pbot}->{registry}->get_value($channel, 'op_nick') // $self->{pbot}->{registry}->get_value('general', 'op_nick') // 'chanserv';
|
||||
|
||||
my $op_command = $self->{pbot}->{registry}->get_value($channel, 'op_command') //
|
||||
$self->{pbot}->{registry}->get_value('general', 'op_command') // "op $channel";
|
||||
my $op_command = $self->{pbot}->{registry}->get_value($channel, 'op_command') // $self->{pbot}->{registry}->get_value('general', 'op_command') // "op $channel";
|
||||
|
||||
$op_command =~ s/\$channel\b/$channel/g;
|
||||
$op_command =~ s/\$channel\b/$channel/g;
|
||||
|
||||
if (not exists $self->{is_opped}->{$channel}) {
|
||||
$self->{pbot}->{conn}->privmsg($op_nick, $op_command);
|
||||
$self->{op_requested}->{$channel} = scalar gettimeofday;
|
||||
} else {
|
||||
$self->perform_op_commands($channel);
|
||||
}
|
||||
if (not exists $self->{is_opped}->{$channel}) {
|
||||
$self->{pbot}->{conn}->privmsg($op_nick, $op_command);
|
||||
$self->{op_requested}->{$channel} = scalar gettimeofday;
|
||||
} else {
|
||||
$self->perform_op_commands($channel);
|
||||
}
|
||||
}
|
||||
|
||||
sub lose_ops {
|
||||
my $self = shift;
|
||||
my $channel = shift;
|
||||
$channel = lc $channel;
|
||||
$self->{pbot}->{conn}->mode($channel, '-o ' . $self->{pbot}->{registry}->get_value('irc', 'botnick'));
|
||||
my $self = shift;
|
||||
my $channel = shift;
|
||||
$channel = lc $channel;
|
||||
$self->{pbot}->{conn}->mode($channel, '-o ' . $self->{pbot}->{registry}->get_value('irc', 'botnick'));
|
||||
}
|
||||
|
||||
sub add_op_command {
|
||||
my ($self, $channel, $command) = @_;
|
||||
$channel = lc $channel;
|
||||
return if not $self->can_gain_ops($channel);
|
||||
push @{ $self->{op_commands}->{$channel} }, $command;
|
||||
my ($self, $channel, $command) = @_;
|
||||
$channel = lc $channel;
|
||||
return if not $self->can_gain_ops($channel);
|
||||
push @{$self->{op_commands}->{$channel}}, $command;
|
||||
}
|
||||
|
||||
sub perform_op_commands {
|
||||
my $self = shift;
|
||||
my $channel = shift;
|
||||
$channel = lc $channel;
|
||||
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
|
||||
my $self = shift;
|
||||
my $channel = shift;
|
||||
$channel = lc $channel;
|
||||
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
|
||||
|
||||
$self->{pbot}->{logger}->log("Performing op commands...\n");
|
||||
while (my $command = shift @{ $self->{op_commands}->{$channel} }) {
|
||||
if ($command =~ /^mode (.*?) (.*)/i) {
|
||||
$self->{pbot}->{conn}->mode($1, $2);
|
||||
$self->{pbot}->{logger}->log(" executing mode $1 $2\n");
|
||||
} elsif ($command =~ /^kick (.*?) (.*?) (.*)/i) {
|
||||
$self->{pbot}->{conn}->kick($1, $2, $3) unless $1 =~ /^\Q$botnick\E$/i;
|
||||
$self->{pbot}->{logger}->log(" executing kick on $1 $2 $3\n");
|
||||
} elsif ($command =~ /^sl (.*)/i) {
|
||||
$self->{pbot}->{conn}->sl($1);
|
||||
$self->{pbot}->{logger}->log(" executing sl $1\n");
|
||||
$self->{pbot}->{logger}->log("Performing op commands...\n");
|
||||
while (my $command = shift @{$self->{op_commands}->{$channel}}) {
|
||||
if ($command =~ /^mode (.*?) (.*)/i) {
|
||||
$self->{pbot}->{conn}->mode($1, $2);
|
||||
$self->{pbot}->{logger}->log(" executing mode $1 $2\n");
|
||||
} elsif ($command =~ /^kick (.*?) (.*?) (.*)/i) {
|
||||
$self->{pbot}->{conn}->kick($1, $2, $3) unless $1 =~ /^\Q$botnick\E$/i;
|
||||
$self->{pbot}->{logger}->log(" executing kick on $1 $2 $3\n");
|
||||
} elsif ($command =~ /^sl (.*)/i) {
|
||||
$self->{pbot}->{conn}->sl($1);
|
||||
$self->{pbot}->{logger}->log(" executing sl $1\n");
|
||||
}
|
||||
}
|
||||
}
|
||||
$self->{pbot}->{logger}->log("Done.\n");
|
||||
$self->{pbot}->{logger}->log("Done.\n");
|
||||
}
|
||||
|
||||
sub ban_user {
|
||||
my $self = shift;
|
||||
my ($mask, $channel, $immediately) = @_;
|
||||
$self->add_to_ban_queue($channel, 'b', $mask);
|
||||
if (not defined $immediately or $immediately != 0) {
|
||||
$self->check_ban_queue;
|
||||
}
|
||||
my $self = shift;
|
||||
my ($mask, $channel, $immediately) = @_;
|
||||
$self->add_to_ban_queue($channel, 'b', $mask);
|
||||
if (not defined $immediately or $immediately != 0) { $self->check_ban_queue; }
|
||||
}
|
||||
|
||||
sub get_bans {
|
||||
my ($self, $mask, $channel) = @_;
|
||||
my $masks;
|
||||
my ($self, $mask, $channel) = @_;
|
||||
my $masks;
|
||||
|
||||
if ($mask !~ m/[!@\$]/) {
|
||||
my ($message_account, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($mask);
|
||||
if ($mask !~ m/[!@\$]/) {
|
||||
my ($message_account, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($mask);
|
||||
|
||||
if (defined $hostmask) {
|
||||
my $nickserv = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($message_account);
|
||||
$masks = $self->{pbot}->{bantracker}->get_baninfo($hostmask, $channel, $nickserv);
|
||||
if (defined $hostmask) {
|
||||
my $nickserv = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($message_account);
|
||||
$masks = $self->{pbot}->{bantracker}->get_baninfo($hostmask, $channel, $nickserv);
|
||||
}
|
||||
|
||||
my %akas = $self->{pbot}->{messagehistory}->{database}->get_also_known_as($mask);
|
||||
|
||||
foreach my $aka (keys %akas) {
|
||||
next if $akas{$aka}->{type} == $self->{pbot}->{messagehistory}->{database}->{alias_type}->{WEAK};
|
||||
next if $akas{$aka}->{nickchange} == 1;
|
||||
|
||||
my $b = $self->{pbot}->{bantracker}->get_baninfo($aka, $channel);
|
||||
if (defined $b) {
|
||||
$masks = {} if not defined $masks;
|
||||
push @$masks, @$b;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my %akas = $self->{pbot}->{messagehistory}->{database}->get_also_known_as($mask);
|
||||
|
||||
foreach my $aka (keys %akas) {
|
||||
next if $akas{$aka}->{type} == $self->{pbot}->{messagehistory}->{database}->{alias_type}->{WEAK};
|
||||
next if $akas{$aka}->{nickchange} == 1;
|
||||
|
||||
my $b = $self->{pbot}->{bantracker}->get_baninfo($aka, $channel);
|
||||
if (defined $b) {
|
||||
$masks = {} if not defined $masks;
|
||||
push @$masks, @$b;
|
||||
}
|
||||
}
|
||||
}
|
||||
return $masks
|
||||
return $masks;
|
||||
}
|
||||
|
||||
sub unmode_user {
|
||||
my ($self, $mask, $channel, $immediately, $mode) = @_;
|
||||
my ($self, $mask, $channel, $immediately, $mode) = @_;
|
||||
|
||||
$mask = lc $mask;
|
||||
$channel = lc $channel;
|
||||
$self->{pbot}->{logger}->log("Removing mode $mode from $mask in $channel\n");
|
||||
$mask = lc $mask;
|
||||
$channel = lc $channel;
|
||||
$self->{pbot}->{logger}->log("Removing mode $mode from $mask in $channel\n");
|
||||
|
||||
my $bans = $self->get_bans($mask, $channel);
|
||||
my %unbanned;
|
||||
my $bans = $self->get_bans($mask, $channel);
|
||||
my %unbanned;
|
||||
|
||||
if (not defined $bans) {
|
||||
my $baninfo = {};
|
||||
$baninfo->{banmask} = $mask;
|
||||
$baninfo->{type} = '+' . $mode;
|
||||
push @$bans, $baninfo;
|
||||
}
|
||||
if (not defined $bans) {
|
||||
my $baninfo = {};
|
||||
$baninfo->{banmask} = $mask;
|
||||
$baninfo->{type} = '+' . $mode;
|
||||
push @$bans, $baninfo;
|
||||
}
|
||||
|
||||
foreach my $baninfo (@$bans) {
|
||||
next if $baninfo->{type} ne '+' . $mode;
|
||||
next if exists $unbanned{$baninfo->{banmask}};
|
||||
$unbanned{$baninfo->{banmask}} = 1;
|
||||
$self->add_to_unban_queue($channel, $mode, $baninfo->{banmask});
|
||||
}
|
||||
$self->check_unban_queue if $immediately;
|
||||
foreach my $baninfo (@$bans) {
|
||||
next if $baninfo->{type} ne '+' . $mode;
|
||||
next if exists $unbanned{$baninfo->{banmask}};
|
||||
$unbanned{$baninfo->{banmask}} = 1;
|
||||
$self->add_to_unban_queue($channel, $mode, $baninfo->{banmask});
|
||||
}
|
||||
$self->check_unban_queue if $immediately;
|
||||
}
|
||||
|
||||
sub nick_to_banmask {
|
||||
my ($self, $mask) = @_;
|
||||
my ($self, $mask) = @_;
|
||||
|
||||
if ($mask !~ m/[!@\$]/) {
|
||||
my ($message_account, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($mask);
|
||||
if (defined $hostmask) {
|
||||
my $nickserv = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($message_account);
|
||||
if (defined $nickserv && length $nickserv) {
|
||||
$mask = '$a:' . $nickserv;
|
||||
} else {
|
||||
my ($nick, $user, $host) = $hostmask =~ m/([^!]+)!([^@]+)@(.*)/;
|
||||
$mask = "*!$user\@" .$self->{pbot}->{antiflood}->address_to_mask($host);
|
||||
}
|
||||
} else {
|
||||
$mask .= '!*@*';
|
||||
if ($mask !~ m/[!@\$]/) {
|
||||
my ($message_account, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($mask);
|
||||
if (defined $hostmask) {
|
||||
my $nickserv = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($message_account);
|
||||
if (defined $nickserv && length $nickserv) { $mask = '$a:' . $nickserv; }
|
||||
else {
|
||||
my ($nick, $user, $host) = $hostmask =~ m/([^!]+)!([^@]+)@(.*)/;
|
||||
$mask = "*!$user\@" . $self->{pbot}->{antiflood}->address_to_mask($host);
|
||||
}
|
||||
} else {
|
||||
$mask .= '!*@*';
|
||||
}
|
||||
}
|
||||
}
|
||||
return $mask;
|
||||
return $mask;
|
||||
}
|
||||
|
||||
sub unban_user {
|
||||
my ($self, $mask, $channel, $immediately) = @_;
|
||||
$mask = lc $mask;
|
||||
$channel = lc $channel;
|
||||
$self->{pbot}->{logger}->log("Unbanning $channel $mask\n");
|
||||
$self->unmode_user($mask, $channel, $immediately, 'b');
|
||||
my ($self, $mask, $channel, $immediately) = @_;
|
||||
$mask = lc $mask;
|
||||
$channel = lc $channel;
|
||||
$self->{pbot}->{logger}->log("Unbanning $channel $mask\n");
|
||||
$self->unmode_user($mask, $channel, $immediately, 'b');
|
||||
}
|
||||
|
||||
sub ban_user_timed {
|
||||
my $self = shift;
|
||||
my ($owner, $reason, $mask, $channel, $length, $immediately) = @_;
|
||||
my $self = shift;
|
||||
my ($owner, $reason, $mask, $channel, $length, $immediately) = @_;
|
||||
|
||||
$channel = lc $channel;
|
||||
$mask = lc $mask;
|
||||
$channel = lc $channel;
|
||||
$mask = lc $mask;
|
||||
|
||||
$mask = $self->nick_to_banmask($mask);
|
||||
$self->ban_user($mask, $channel, $immediately);
|
||||
$mask = $self->nick_to_banmask($mask);
|
||||
$self->ban_user($mask, $channel, $immediately);
|
||||
|
||||
if ($length > 0) {
|
||||
my $data = {
|
||||
timeout => gettimeofday + $length
|
||||
};
|
||||
$data->{owner} = $owner if defined $owner;
|
||||
$data->{reason} = $reason if defined $reason;
|
||||
$self->{unban_timeout}->add($channel, $mask, $data);
|
||||
} else {
|
||||
if ($self->{unban_timeout}->exists($channel, $mask)) {
|
||||
$self->{unban_timeout}->remove($channel, $mask);
|
||||
if ($length > 0) {
|
||||
my $data = {timeout => gettimeofday + $length};
|
||||
$data->{owner} = $owner if defined $owner;
|
||||
$data->{reason} = $reason if defined $reason;
|
||||
$self->{unban_timeout}->add($channel, $mask, $data);
|
||||
} else {
|
||||
if ($self->{unban_timeout}->exists($channel, $mask)) { $self->{unban_timeout}->remove($channel, $mask); }
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub checkban {
|
||||
my ($self, $channel, $target) = @_;
|
||||
my $mask = $self->nick_to_banmask($target);
|
||||
my ($self, $channel, $target) = @_;
|
||||
my $mask = $self->nick_to_banmask($target);
|
||||
|
||||
if ($self->{unban_timeout}->exists($channel, $mask)) {
|
||||
my $timeout = $self->{unban_timeout}->get_data($channel, $mask, 'timeout');
|
||||
my $owner = $self->{unban_timeout}->get_data($channel, $mask, 'owner');
|
||||
my $reason = $self->{unban_timeout}->get_data($channel, $mask, 'reason');
|
||||
my $duration = concise duration($timeout - gettimeofday);
|
||||
if ($self->{unban_timeout}->exists($channel, $mask)) {
|
||||
|
||||
my $result = "$mask banned in $channel ";
|
||||
$result .= "by $owner " if defined $owner;
|
||||
$result .= "for $reason " if defined $reason;
|
||||
$result .= "($duration remaining)";
|
||||
return $result;
|
||||
} else {
|
||||
return "$mask has no ban timeout.";
|
||||
}
|
||||
my $timeout = $self->{unban_timeout}->get_data($channel, $mask, 'timeout');
|
||||
my $owner = $self->{unban_timeout}->get_data($channel, $mask, 'owner');
|
||||
my $reason = $self->{unban_timeout}->get_data($channel, $mask, 'reason');
|
||||
my $duration = concise duration($timeout - gettimeofday);
|
||||
|
||||
my $result = "$mask banned in $channel ";
|
||||
|
||||
$result .= "by $owner " if defined $owner;
|
||||
$result .= "for $reason " if defined $reason;
|
||||
$result .= "($duration remaining)";
|
||||
return $result;
|
||||
} else {
|
||||
return "$mask has no ban timeout.";
|
||||
}
|
||||
}
|
||||
|
||||
sub mute_user {
|
||||
my $self = shift;
|
||||
my ($mask, $channel, $immediately) = @_;
|
||||
$self->add_to_ban_queue($channel, 'q', $mask);
|
||||
if (not defined $immediately or $immediately != 0) {
|
||||
$self->check_ban_queue;
|
||||
}
|
||||
my $self = shift;
|
||||
my ($mask, $channel, $immediately) = @_;
|
||||
$self->add_to_ban_queue($channel, 'q', $mask);
|
||||
if (not defined $immediately or $immediately != 0) { $self->check_ban_queue; }
|
||||
}
|
||||
|
||||
sub unmute_user {
|
||||
my ($self, $mask, $channel, $immediately) = @_;
|
||||
$mask = lc $mask;
|
||||
$channel = lc $channel;
|
||||
$self->{pbot}->{logger}->log("Unmuting $channel $mask\n");
|
||||
$self->unmode_user($mask, $channel, $immediately, 'q');
|
||||
my ($self, $mask, $channel, $immediately) = @_;
|
||||
$mask = lc $mask;
|
||||
$channel = lc $channel;
|
||||
$self->{pbot}->{logger}->log("Unmuting $channel $mask\n");
|
||||
$self->unmode_user($mask, $channel, $immediately, 'q');
|
||||
}
|
||||
|
||||
sub mute_user_timed {
|
||||
my $self = shift;
|
||||
my ($owner, $reason, $mask, $channel, $length, $immediately) = @_;
|
||||
my $self = shift;
|
||||
my ($owner, $reason, $mask, $channel, $length, $immediately) = @_;
|
||||
|
||||
$mask = $self->nick_to_banmask($mask);
|
||||
$self->mute_user($mask, $channel, $immediately);
|
||||
$mask = $self->nick_to_banmask($mask);
|
||||
$self->mute_user($mask, $channel, $immediately);
|
||||
|
||||
if ($length > 0) {
|
||||
my $data = {
|
||||
timeout => gettimeofday + $length
|
||||
};
|
||||
$data->{owner} = $owner if defined $owner;
|
||||
$data->{reason} = $reason if defined $reason;
|
||||
$self->{unmute_timeout}->add($channel, $mask, $data);
|
||||
} else {
|
||||
if ($self->{unmute_timeout}->exists($channel, $mask)) {
|
||||
$self->{unmute_timeout}->remove($channel, $mask);
|
||||
if ($length > 0) {
|
||||
my $data = {timeout => gettimeofday + $length};
|
||||
$data->{owner} = $owner if defined $owner;
|
||||
$data->{reason} = $reason if defined $reason;
|
||||
$self->{unmute_timeout}->add($channel, $mask, $data);
|
||||
} else {
|
||||
if ($self->{unmute_timeout}->exists($channel, $mask)) { $self->{unmute_timeout}->remove($channel, $mask); }
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub checkmute {
|
||||
my ($self, $channel, $target) = @_;
|
||||
my $mask = $self->nick_to_banmask($target);
|
||||
my ($self, $channel, $target) = @_;
|
||||
my $mask = $self->nick_to_banmask($target);
|
||||
|
||||
if ($self->{unmute_timeout}->exists($channel, $mask)) {
|
||||
my $timeout = $self->{unmute_timeout}->get_data($channel, $mask, 'timeout');
|
||||
my $owner = $self->{unmute_timeout}->get_data($channel, $mask, 'owner');
|
||||
my $reason = $self->{unmute_timeout}->get_data($channel, $mask, 'reason');
|
||||
my $duration = concise duration($timeout - gettimeofday);
|
||||
if ($self->{unmute_timeout}->exists($channel, $mask)) {
|
||||
|
||||
my $result = "$mask muted in $channel ";
|
||||
$result .= "by $owner " if defined $owner;
|
||||
$result .= "for $reason " if defined $reason;
|
||||
$result .= "($duration remaining)";
|
||||
my $timeout = $self->{unmute_timeout}->get_data($channel, $mask, 'timeout');
|
||||
my $owner = $self->{unmute_timeout}->get_data($channel, $mask, 'owner');
|
||||
my $reason = $self->{unmute_timeout}->get_data($channel, $mask, 'reason');
|
||||
my $duration = concise duration($timeout - gettimeofday);
|
||||
|
||||
return $result;
|
||||
} else {
|
||||
return "$mask has no mute timeout.";
|
||||
}
|
||||
my $result = "$mask muted in $channel ";
|
||||
|
||||
$result .= "by $owner " if defined $owner;
|
||||
$result .= "for $reason " if defined $reason;
|
||||
$result .= "($duration remaining)";
|
||||
|
||||
return $result;
|
||||
} else {
|
||||
return "$mask has no mute timeout.";
|
||||
}
|
||||
}
|
||||
|
||||
sub join_channel {
|
||||
my ($self, $channels) = @_;
|
||||
my ($self, $channels) = @_;
|
||||
|
||||
$self->{pbot}->{conn}->join($channels);
|
||||
$self->{pbot}->{conn}->join($channels);
|
||||
|
||||
foreach my $channel (split /,/, $channels) {
|
||||
$channel = lc $channel;
|
||||
$self->{pbot}->{event_dispatcher}->dispatch_event('pbot.join', { channel => $channel });
|
||||
foreach my $channel (split /,/, $channels) {
|
||||
$channel = lc $channel;
|
||||
$self->{pbot}->{event_dispatcher}->dispatch_event('pbot.join', {channel => $channel});
|
||||
|
||||
delete $self->{is_opped}->{$channel};
|
||||
delete $self->{op_requested}->{$channel};
|
||||
delete $self->{is_opped}->{$channel};
|
||||
delete $self->{op_requested}->{$channel};
|
||||
|
||||
if ($self->{pbot}->{channels}->{channels}->exists($channel)
|
||||
and $self->{pbot}->{channels}->{channels}->get_data($channel, 'permop')) {
|
||||
$self->gain_ops($channel);
|
||||
if ($self->{pbot}->{channels}->{channels}->exists($channel) and $self->{pbot}->{channels}->{channels}->get_data($channel, 'permop')) { $self->gain_ops($channel); }
|
||||
|
||||
$self->{pbot}->{conn}->mode($channel);
|
||||
}
|
||||
|
||||
$self->{pbot}->{conn}->mode($channel);
|
||||
}
|
||||
}
|
||||
|
||||
sub part_channel {
|
||||
my ($self, $channel) = @_;
|
||||
$channel = lc $channel;
|
||||
$self->{pbot}->{event_dispatcher}->dispatch_event('pbot.part', { channel => $channel });
|
||||
$self->{pbot}->{conn}->part($channel);
|
||||
delete $self->{is_opped}->{$channel};
|
||||
delete $self->{op_requested}->{$channel};
|
||||
my ($self, $channel) = @_;
|
||||
$channel = lc $channel;
|
||||
$self->{pbot}->{event_dispatcher}->dispatch_event('pbot.part', {channel => $channel});
|
||||
$self->{pbot}->{conn}->part($channel);
|
||||
delete $self->{is_opped}->{$channel};
|
||||
delete $self->{op_requested}->{$channel};
|
||||
}
|
||||
|
||||
sub has_ban_timeout {
|
||||
my ($self, $channel, $mask) = @_;
|
||||
return $self->{unban_timeout}->exists($channel, $mask);
|
||||
my ($self, $channel, $mask) = @_;
|
||||
return $self->{unban_timeout}->exists($channel, $mask);
|
||||
}
|
||||
|
||||
sub has_mute_timeout {
|
||||
my ($self, $channel, $mask) = @_;
|
||||
return $self->{unmute_timeout}->exists($channel, $mask);
|
||||
my ($self, $channel, $mask) = @_;
|
||||
return $self->{unmute_timeout}->exists($channel, $mask);
|
||||
}
|
||||
|
||||
sub add_to_ban_queue {
|
||||
my ($self, $channel, $mode, $target) = @_;
|
||||
push @{$self->{ban_queue}->{$channel}->{$mode}}, $target;
|
||||
$self->{pbot}->{logger}->log("Added +$mode $target for $channel to ban queue.\n");
|
||||
my ($self, $channel, $mode, $target) = @_;
|
||||
push @{$self->{ban_queue}->{$channel}->{$mode}}, $target;
|
||||
$self->{pbot}->{logger}->log("Added +$mode $target for $channel to ban queue.\n");
|
||||
}
|
||||
|
||||
sub check_ban_queue {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
my $MAX_COMMANDS = 4;
|
||||
my $commands = 0;
|
||||
my $MAX_COMMANDS = 4;
|
||||
my $commands = 0;
|
||||
|
||||
foreach my $channel (keys %{$self->{ban_queue}}) {
|
||||
my $done = 0;
|
||||
while (not $done) {
|
||||
my ($list, $count, $modes);
|
||||
$list = '';
|
||||
$modes = '+';
|
||||
$count = 0;
|
||||
foreach my $channel (keys %{$self->{ban_queue}}) {
|
||||
my $done = 0;
|
||||
while (not $done) {
|
||||
my ($list, $count, $modes);
|
||||
$list = '';
|
||||
$modes = '+';
|
||||
$count = 0;
|
||||
|
||||
foreach my $mode (keys %{$self->{ban_queue}->{$channel}}) {
|
||||
while (@{$self->{ban_queue}->{$channel}->{$mode}}) {
|
||||
my $target = pop @{$self->{ban_queue}->{$channel}->{$mode}};
|
||||
$list .= " $target";
|
||||
$modes .= $mode;
|
||||
last if ++$count >= $self->{pbot}->{ircd}->{MODES};
|
||||
foreach my $mode (keys %{$self->{ban_queue}->{$channel}}) {
|
||||
while (@{$self->{ban_queue}->{$channel}->{$mode}}) {
|
||||
my $target = pop @{$self->{ban_queue}->{$channel}->{$mode}};
|
||||
$list .= " $target";
|
||||
$modes .= $mode;
|
||||
last if ++$count >= $self->{pbot}->{ircd}->{MODES};
|
||||
}
|
||||
|
||||
if (not @{$self->{ban_queue}->{$channel}->{$mode}}) { delete $self->{ban_queue}->{$channel}->{$mode}; }
|
||||
|
||||
last if $count >= $self->{pbot}->{ircd}->{MODES};
|
||||
}
|
||||
|
||||
if (not keys %{$self->{ban_queue}->{$channel}}) {
|
||||
delete $self->{ban_queue}->{$channel};
|
||||
$done = 1;
|
||||
}
|
||||
|
||||
if ($count) {
|
||||
$self->add_op_command($channel, "mode $channel $modes $list");
|
||||
$self->gain_ops($channel);
|
||||
|
||||
return if ++$commands >= $MAX_COMMANDS;
|
||||
}
|
||||
}
|
||||
|
||||
if (not @{$self->{ban_queue}->{$channel}->{$mode}}) {
|
||||
delete $self->{ban_queue}->{$channel}->{$mode};
|
||||
}
|
||||
|
||||
last if $count >= $self->{pbot}->{ircd}->{MODES};
|
||||
}
|
||||
|
||||
if (not keys %{ $self->{ban_queue}->{$channel} }) {
|
||||
delete $self->{ban_queue}->{$channel};
|
||||
$done = 1;
|
||||
}
|
||||
|
||||
if ($count) {
|
||||
$self->add_op_command($channel, "mode $channel $modes $list");
|
||||
$self->gain_ops($channel);
|
||||
|
||||
return if ++$commands >= $MAX_COMMANDS;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub add_to_unban_queue {
|
||||
my ($self, $channel, $mode, $target) = @_;
|
||||
push @{$self->{unban_queue}->{$channel}->{$mode}}, $target;
|
||||
$self->{pbot}->{logger}->log("Added -$mode $target for $channel to unban queue.\n");
|
||||
my ($self, $channel, $mode, $target) = @_;
|
||||
push @{$self->{unban_queue}->{$channel}->{$mode}}, $target;
|
||||
$self->{pbot}->{logger}->log("Added -$mode $target for $channel to unban queue.\n");
|
||||
}
|
||||
|
||||
sub check_unban_queue {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
my $MAX_COMMANDS = 4;
|
||||
my $commands = 0;
|
||||
my $MAX_COMMANDS = 4;
|
||||
my $commands = 0;
|
||||
|
||||
foreach my $channel (keys %{$self->{unban_queue}}) {
|
||||
my $done = 0;
|
||||
while (not $done) {
|
||||
my ($list, $count, $modes);
|
||||
$list = '';
|
||||
$modes = '-';
|
||||
$count = 0;
|
||||
foreach my $channel (keys %{$self->{unban_queue}}) {
|
||||
my $done = 0;
|
||||
while (not $done) {
|
||||
my ($list, $count, $modes);
|
||||
$list = '';
|
||||
$modes = '-';
|
||||
$count = 0;
|
||||
|
||||
foreach my $mode (keys %{$self->{unban_queue}->{$channel}}) {
|
||||
while (@{$self->{unban_queue}->{$channel}->{$mode}}) {
|
||||
my $target = pop @{$self->{unban_queue}->{$channel}->{$mode}};
|
||||
$list .= " $target";
|
||||
$modes .= $mode;
|
||||
last if ++$count >= $self->{pbot}->{ircd}->{MODES};
|
||||
foreach my $mode (keys %{$self->{unban_queue}->{$channel}}) {
|
||||
while (@{$self->{unban_queue}->{$channel}->{$mode}}) {
|
||||
my $target = pop @{$self->{unban_queue}->{$channel}->{$mode}};
|
||||
$list .= " $target";
|
||||
$modes .= $mode;
|
||||
last if ++$count >= $self->{pbot}->{ircd}->{MODES};
|
||||
}
|
||||
|
||||
if (not @{$self->{unban_queue}->{$channel}->{$mode}}) { delete $self->{unban_queue}->{$channel}->{$mode}; }
|
||||
|
||||
last if $count >= $self->{pbot}->{ircd}->{MODES};
|
||||
}
|
||||
|
||||
if (not keys %{$self->{unban_queue}->{$channel}}) {
|
||||
delete $self->{unban_queue}->{$channel};
|
||||
$done = 1;
|
||||
}
|
||||
|
||||
if ($count) {
|
||||
$self->add_op_command($channel, "mode $channel $modes $list");
|
||||
$self->gain_ops($channel);
|
||||
|
||||
return if ++$commands >= $MAX_COMMANDS;
|
||||
}
|
||||
}
|
||||
|
||||
if (not @{$self->{unban_queue}->{$channel}->{$mode}}) {
|
||||
delete $self->{unban_queue}->{$channel}->{$mode};
|
||||
}
|
||||
|
||||
last if $count >= $self->{pbot}->{ircd}->{MODES};
|
||||
}
|
||||
|
||||
if (not keys %{ $self->{unban_queue}->{$channel} }) {
|
||||
delete $self->{unban_queue}->{$channel};
|
||||
$done = 1;
|
||||
}
|
||||
|
||||
if ($count) {
|
||||
$self->add_op_command($channel, "mode $channel $modes $list");
|
||||
$self->gain_ops($channel);
|
||||
|
||||
return if ++$commands >= $MAX_COMMANDS;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub check_unban_timeouts {
|
||||
my $self = shift;
|
||||
return if not $self->{pbot}->{joined_channels};
|
||||
my $now = gettimeofday();
|
||||
foreach my $channel ($self->{unban_timeout}->get_keys) {
|
||||
foreach my $mask ($self->{unban_timeout}->get_keys($channel)) {
|
||||
if ($self->{unban_timeout}->get_data($channel, $mask, 'timeout') < $now) {
|
||||
$self->{unban_timeout}->set($channel, $mask, 'timeout', $now + 7200);
|
||||
$self->unban_user($mask, $channel);
|
||||
}
|
||||
my $self = shift;
|
||||
return if not $self->{pbot}->{joined_channels};
|
||||
my $now = gettimeofday();
|
||||
foreach my $channel ($self->{unban_timeout}->get_keys) {
|
||||
foreach my $mask ($self->{unban_timeout}->get_keys($channel)) {
|
||||
if ($self->{unban_timeout}->get_data($channel, $mask, 'timeout') < $now) {
|
||||
$self->{unban_timeout}->set($channel, $mask, 'timeout', $now + 7200);
|
||||
$self->unban_user($mask, $channel);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub check_unmute_timeouts {
|
||||
my $self = shift;
|
||||
return if not $self->{pbot}->{joined_channels};
|
||||
my $now = gettimeofday();
|
||||
foreach my $channel ($self->{unmute_timeout}->get_keys) {
|
||||
foreach my $mask ($self->{unmute_timeout}->get_keys($channel)) {
|
||||
if ($self->{unmute_timeout}->get_data($channel, $mask, 'timeout') < $now) {
|
||||
$self->{unmute_timeout}->set($channel, $mask, 'timeout', $now + 7200);
|
||||
$self->unmute_user($mask, $channel);
|
||||
}
|
||||
my $self = shift;
|
||||
return if not $self->{pbot}->{joined_channels};
|
||||
my $now = gettimeofday();
|
||||
foreach my $channel ($self->{unmute_timeout}->get_keys) {
|
||||
foreach my $mask ($self->{unmute_timeout}->get_keys($channel)) {
|
||||
if ($self->{unmute_timeout}->get_data($channel, $mask, 'timeout') < $now) {
|
||||
$self->{unmute_timeout}->set($channel, $mask, 'timeout', $now + 7200);
|
||||
$self->unmute_user($mask, $channel);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub check_opped_timeouts {
|
||||
my $self = shift;
|
||||
my $now = gettimeofday();
|
||||
foreach my $channel (keys %{ $self->{is_opped} }) {
|
||||
if ($self->{is_opped}->{$channel}{timeout} < $now) {
|
||||
unless ($self->{pbot}->{channels}->{channels}->exists($channel)
|
||||
and $self->{pbot}->{channels}->{channels}->get_data($channel, 'permop')) {
|
||||
$self->lose_ops($channel);
|
||||
}
|
||||
my $self = shift;
|
||||
my $now = gettimeofday();
|
||||
foreach my $channel (keys %{$self->{is_opped}}) {
|
||||
if ($self->{is_opped}->{$channel}{timeout} < $now) {
|
||||
unless ($self->{pbot}->{channels}->{channels}->exists($channel) and $self->{pbot}->{channels}->{channels}->get_data($channel, 'permop')) { $self->lose_ops($channel); }
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $channel (keys %{ $self->{op_requested} }) {
|
||||
if ($now - $self->{op_requested}->{$channel} > 60 * 5) {
|
||||
if ($self->{pbot}->{channels}->{channels}->exists($channel)
|
||||
and $self->{pbot}->{channels}->{channels}->get_data($channel, 'enabled')) {
|
||||
$self->{pbot}->{logger}->log("5 minutes since OP request for $channel and no OP yet; trying again ...\n");
|
||||
delete $self->{op_requested}->{$channel};
|
||||
$self->gain_ops($channel);
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("Disregarding OP request for $channel (channel is disabled)\n");
|
||||
delete $self->{op_requested}->{$channel};
|
||||
}
|
||||
foreach my $channel (keys %{$self->{op_requested}}) {
|
||||
if ($now - $self->{op_requested}->{$channel} > 60 * 5) {
|
||||
if ($self->{pbot}->{channels}->{channels}->exists($channel) and $self->{pbot}->{channels}->{channels}->get_data($channel, 'enabled')) {
|
||||
$self->{pbot}->{logger}->log("5 minutes since OP request for $channel and no OP yet; trying again ...\n");
|
||||
delete $self->{op_requested}->{$channel};
|
||||
$self->gain_ops($channel);
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("Disregarding OP request for $channel (channel is disabled)\n");
|
||||
delete $self->{op_requested}->{$channel};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
159
PBot/Channels.pm
159
PBot/Channels.pm
|
|
@ -14,130 +14,125 @@ use warnings; use strict;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{channels} = PBot::HashObject->new(pbot => $self->{pbot}, name => 'Channels', filename => $conf{filename});
|
||||
$self->{channels}->load;
|
||||
my ($self, %conf) = @_;
|
||||
$self->{channels} = PBot::HashObject->new(pbot => $self->{pbot}, name => 'Channels', filename => $conf{filename});
|
||||
$self->{channels}->load;
|
||||
|
||||
$self->{pbot}->{commands}->register(sub { $self->join(@_) }, "join", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->part(@_) }, "part", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->set(@_) }, "chanset", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->unset(@_) }, "chanunset", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->add(@_) }, "chanadd", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->remove(@_) }, "chanrem", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->list(@_) }, "chanlist", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->join(@_) }, "join", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->part(@_) }, "part", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->set(@_) }, "chanset", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->unset(@_) }, "chanunset", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->add(@_) }, "chanadd", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->remove(@_) }, "chanrem", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->list(@_) }, "chanlist", 1);
|
||||
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-join', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-part', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-chanlist', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-join', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-part', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-chanlist', 1);
|
||||
}
|
||||
|
||||
sub join {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
foreach my $channel (split /[\s+,]/, $arguments) {
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host made me join $channel\n");
|
||||
$self->{pbot}->{chanops}->join_channel($channel);
|
||||
}
|
||||
return "/msg $nick Joining $arguments";
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
foreach my $channel (split /[\s+,]/, $arguments) {
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host made me join $channel\n");
|
||||
$self->{pbot}->{chanops}->join_channel($channel);
|
||||
}
|
||||
return "/msg $nick Joining $arguments";
|
||||
}
|
||||
|
||||
sub part {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
$arguments = $from if not $arguments;
|
||||
foreach my $channel (split /[\s+,]/, $arguments) {
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host made me part $channel\n");
|
||||
$self->{pbot}->{chanops}->part_channel($channel);
|
||||
}
|
||||
return "/msg $nick Parting $arguments";
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
$arguments = $from if not $arguments;
|
||||
foreach my $channel (split /[\s+,]/, $arguments) {
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host made me part $channel\n");
|
||||
$self->{pbot}->{chanops}->part_channel($channel);
|
||||
}
|
||||
return "/msg $nick Parting $arguments";
|
||||
}
|
||||
|
||||
sub set {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($channel, $key, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3);
|
||||
return "Usage: chanset <channel> [key [value]]" if not defined $channel;
|
||||
return $self->{channels}->set($channel, $key, $value);
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($channel, $key, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3);
|
||||
return "Usage: chanset <channel> [key [value]]" if not defined $channel;
|
||||
return $self->{channels}->set($channel, $key, $value);
|
||||
}
|
||||
|
||||
sub unset {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($channel, $key) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
return "Usage: chanunset <channel> <key>" if not defined $channel or not defined $key;
|
||||
return $self->{channels}->unset($channel, $key);
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($channel, $key) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
return "Usage: chanunset <channel> <key>" if not defined $channel or not defined $key;
|
||||
return $self->{channels}->unset($channel, $key);
|
||||
}
|
||||
|
||||
sub add {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
return "Usage: chanadd <channel>" if not defined $arguments or not length $arguments;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
return "Usage: chanadd <channel>" if not defined $arguments or not length $arguments;
|
||||
|
||||
my $data = {
|
||||
enabled => 1,
|
||||
chanop => 0,
|
||||
permop => 0
|
||||
};
|
||||
my $data = {
|
||||
enabled => 1,
|
||||
chanop => 0,
|
||||
permop => 0
|
||||
};
|
||||
|
||||
return $self->{channels}->add($arguments, $data);
|
||||
return $self->{channels}->add($arguments, $data);
|
||||
}
|
||||
|
||||
sub remove {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
return "Usage: chanrem <channel>" if not defined $arguments or not length $arguments;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
return "Usage: chanrem <channel>" if not defined $arguments or not length $arguments;
|
||||
|
||||
# clear unban timeouts
|
||||
if ($self->{pbot}->{chanops}->{unban_timeout}->exists($arguments)) {
|
||||
$self->{pbot}->{chanops}->{unban_timeout}->remove($arguments);
|
||||
}
|
||||
# clear unban timeouts
|
||||
if ($self->{pbot}->{chanops}->{unban_timeout}->exists($arguments)) { $self->{pbot}->{chanops}->{unban_timeout}->remove($arguments); }
|
||||
|
||||
# clear unmute timeouts
|
||||
if ($self->{pbot}->{chanops}->{unmute_timeout}->exists($arguments)) {
|
||||
$self->{pbot}->{chanops}->{unmute_timeout}->remove($arguments);
|
||||
}
|
||||
# clear unmute timeouts
|
||||
if ($self->{pbot}->{chanops}->{unmute_timeout}->exists($arguments)) { $self->{pbot}->{chanops}->{unmute_timeout}->remove($arguments); }
|
||||
|
||||
# TODO: ignores, etc?
|
||||
return $self->{channels}->remove($arguments);
|
||||
# TODO: ignores, etc?
|
||||
return $self->{channels}->remove($arguments);
|
||||
}
|
||||
|
||||
sub list {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my $result;
|
||||
foreach my $channel (sort $self->{channels}->get_keys) {
|
||||
$result .= $self->{channels}->get_data($channel, '_name') . ': {';
|
||||
my $comma = ' ';
|
||||
foreach my $key (sort $self->{channels}->get_keys($channel)) {
|
||||
$result .= "$comma$key => " . $self->{channels}->get_data($channel, $key);
|
||||
$comma = ', ';
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my $result;
|
||||
foreach my $channel (sort $self->{channels}->get_keys) {
|
||||
$result .= $self->{channels}->get_data($channel, '_name') . ': {';
|
||||
my $comma = ' ';
|
||||
foreach my $key (sort $self->{channels}->get_keys($channel)) {
|
||||
$result .= "$comma$key => " . $self->{channels}->get_data($channel, $key);
|
||||
$comma = ', ';
|
||||
}
|
||||
$result .= " }\n";
|
||||
}
|
||||
$result .= " }\n";
|
||||
}
|
||||
return $result;
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub autojoin {
|
||||
my ($self) = @_;
|
||||
return if $self->{pbot}->{joined_channels};
|
||||
my $channels;
|
||||
foreach my $channel ($self->{channels}->get_keys) {
|
||||
if ($self->{channels}->get_data($channel, 'enabled')) {
|
||||
$channels .= $self->{channels}->get_data($channel, '_name') . ',';
|
||||
my ($self) = @_;
|
||||
return if $self->{pbot}->{joined_channels};
|
||||
my $channels;
|
||||
foreach my $channel ($self->{channels}->get_keys) {
|
||||
if ($self->{channels}->get_data($channel, 'enabled')) { $channels .= $self->{channels}->get_data($channel, '_name') . ','; }
|
||||
}
|
||||
}
|
||||
$self->{pbot}->{logger}->log("Joining channels: $channels\n");
|
||||
$self->{pbot}->{chanops}->join_channel($channels);
|
||||
$self->{pbot}->{joined_channels} = 1;
|
||||
$self->{pbot}->{logger}->log("Joining channels: $channels\n");
|
||||
$self->{pbot}->{chanops}->join_channel($channels);
|
||||
$self->{pbot}->{joined_channels} = 1;
|
||||
}
|
||||
|
||||
sub is_active {
|
||||
my ($self, $channel) = @_;
|
||||
# returns undef if channel doesn't exist; otherwise, the value of 'enabled'
|
||||
return $self->{channels}->get_data($channel, 'enabled');
|
||||
my ($self, $channel) = @_;
|
||||
|
||||
# returns undef if channel doesn't exist; otherwise, the value of 'enabled'
|
||||
return $self->{channels}->get_data($channel, 'enabled');
|
||||
}
|
||||
|
||||
sub is_active_op {
|
||||
my ($self, $channel) = @_;
|
||||
return $self->is_active($channel) && $self->{channels}->get_data($channel, 'chanop');
|
||||
my ($self, $channel) = @_;
|
||||
return $self->is_active($channel) && $self->{channels}->get_data($channel, 'chanop');
|
||||
}
|
||||
|
||||
sub get_meta {
|
||||
my ($self, $channel, $key) = @_;
|
||||
return $self->{channels}->get_data($channel, $key);
|
||||
my ($self, $channel, $key) = @_;
|
||||
return $self->{channels}->get_data($channel, $key);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -13,26 +13,26 @@ use warnings;
|
|||
use strict;
|
||||
|
||||
sub new {
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
|
||||
if (not exists $conf{pbot}) {
|
||||
my ($package, $filename, $line) = caller(0);
|
||||
my (undef, undef, undef, $subroutine) = caller(1);
|
||||
Carp::croak("Missing pbot reference to " . $class . ", created by $subroutine at $filename:$line");
|
||||
}
|
||||
if (not exists $conf{pbot}) {
|
||||
my ($package, $filename, $line) = caller(0);
|
||||
my (undef, undef, undef, $subroutine) = caller(1);
|
||||
Carp::croak("Missing pbot reference to " . $class . ", created by $subroutine at $filename:$line");
|
||||
}
|
||||
|
||||
$self->{pbot} = $conf{pbot};
|
||||
$self->{pbot}->{logger}->log("Initializing $class\n");
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
$self->{pbot} = $conf{pbot};
|
||||
$self->{pbot}->{logger}->log("Initializing $class\n");
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($package, $filename, $line) = caller(0);
|
||||
my (undef, undef, undef, $subroutine) = caller(1);
|
||||
Carp::croak("Missing initialize subroutine in $subroutine at $filename:$line");
|
||||
my ($package, $filename, $line) = caller(0);
|
||||
my (undef, undef, undef, $subroutine) = caller(1);
|
||||
Carp::croak("Missing initialize subroutine in $subroutine at $filename:$line");
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
356
PBot/Commands.pm
356
PBot/Commands.pm
|
|
@ -18,249 +18,235 @@ use feature 'unicode_strings';
|
|||
use Time::Duration qw/duration/;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->PBot::Registerable::initialize(%conf);
|
||||
my ($self, %conf) = @_;
|
||||
$self->PBot::Registerable::initialize(%conf);
|
||||
|
||||
$self->{metadata} = PBot::HashObject->new(pbot => $self->{pbot}, name => 'Commands', filename => $conf{filename});
|
||||
$self->{metadata}->load;
|
||||
$self->{metadata} = PBot::HashObject->new(pbot => $self->{pbot}, name => 'Commands', filename => $conf{filename});
|
||||
$self->{metadata}->load;
|
||||
|
||||
$self->register(sub { $self->cmdset(@_) }, "cmdset", 1);
|
||||
$self->register(sub { $self->cmdunset(@_) }, "cmdunset", 1);
|
||||
$self->register(sub { $self->help(@_) }, "help", 0);
|
||||
$self->register(sub { $self->uptime(@_) }, "uptime", 0);
|
||||
$self->register(sub { $self->in_channel(@_) }, "in", 1);
|
||||
$self->register(sub { $self->cmdset(@_) }, "cmdset", 1);
|
||||
$self->register(sub { $self->cmdunset(@_) }, "cmdunset", 1);
|
||||
$self->register(sub { $self->help(@_) }, "help", 0);
|
||||
$self->register(sub { $self->uptime(@_) }, "uptime", 0);
|
||||
$self->register(sub { $self->in_channel(@_) }, "in", 1);
|
||||
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-in', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-in', 1);
|
||||
}
|
||||
|
||||
sub register {
|
||||
my ($self, $subref, $name, $requires_cap) = @_;
|
||||
Carp::croak("Missing parameters to Commands::register") if not defined $subref or not defined $name;
|
||||
my ($self, $subref, $name, $requires_cap) = @_;
|
||||
Carp::croak("Missing parameters to Commands::register") if not defined $subref or not defined $name;
|
||||
|
||||
my $ref = $self->PBot::Registerable::register($subref);
|
||||
$ref->{name} = lc $name;
|
||||
$ref->{requires_cap} = $requires_cap // 0;
|
||||
my $ref = $self->PBot::Registerable::register($subref);
|
||||
$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
|
||||
$self->{pbot}->{capabilities}->add("can-$name", undef, 1) if $requires_cap;
|
||||
return $ref;
|
||||
# add can-cmd capability
|
||||
$self->{pbot}->{capabilities}->add("can-$name", undef, 1) if $requires_cap;
|
||||
return $ref;
|
||||
}
|
||||
|
||||
sub unregister {
|
||||
my ($self, $name) = @_;
|
||||
Carp::croak("Missing name parameter to Commands::unregister") if not defined $name;
|
||||
$name = lc $name;
|
||||
@{ $self->{handlers} } = grep { $_->{name} ne $name } @{ $self->{handlers} };
|
||||
my ($self, $name) = @_;
|
||||
Carp::croak("Missing name parameter to Commands::unregister") if not defined $name;
|
||||
$name = lc $name;
|
||||
@{$self->{handlers}} = grep { $_->{name} ne $name } @{$self->{handlers}};
|
||||
}
|
||||
|
||||
sub exists {
|
||||
my ($self, $keyword) = @_;
|
||||
$keyword = lc $keyword;
|
||||
foreach my $ref (@{ $self->{handlers} }) {
|
||||
return 1 if $ref->{name} eq $keyword;
|
||||
}
|
||||
return 0;
|
||||
my ($self, $keyword) = @_;
|
||||
$keyword = lc $keyword;
|
||||
foreach my $ref (@{$self->{handlers}}) { return 1 if $ref->{name} eq $keyword; }
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub interpreter {
|
||||
my ($self, $stuff) = @_;
|
||||
my $result;
|
||||
my ($self, $stuff) = @_;
|
||||
my $result;
|
||||
|
||||
if ($self->{pbot}->{registry}->get_value('general', 'debugcontext')) {
|
||||
use Data::Dumper;
|
||||
$Data::Dumper::Sortkeys = 1;
|
||||
$self->{pbot}->{logger}->log("Commands::interpreter\n");
|
||||
$self->{pbot}->{logger}->log(Dumper $stuff);
|
||||
}
|
||||
|
||||
my $keyword = lc $stuff->{keyword};
|
||||
my $from = $stuff->{from};
|
||||
|
||||
my ($cmd_channel) = $stuff->{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
|
||||
my $user = $self->{pbot}->{users}->find_user($cmd_channel, "$stuff->{nick}!$stuff->{user}\@$stuff->{host}");
|
||||
|
||||
my $cap_override;
|
||||
if (exists $stuff->{'cap-override'}) {
|
||||
$self->{pbot}->{logger}->log("Override cap to $stuff->{'cap-override'}\n");
|
||||
$cap_override = $stuff->{'cap-override'};
|
||||
}
|
||||
|
||||
foreach my $ref (@{ $self->{handlers} }) {
|
||||
if ($ref->{name} eq $keyword) {
|
||||
my $requires_cap = $self->get_meta($keyword, 'requires_cap') // $ref->{requires_cap};
|
||||
if ($requires_cap) {
|
||||
if (defined $cap_override) {
|
||||
if (not $self->{pbot}->{capabilities}->has($cap_override, "can-$keyword")) {
|
||||
return "/msg $stuff->{nick} The $keyword command requires the can-$keyword capability, which cap-override $cap_override does not have.";
|
||||
}
|
||||
} else {
|
||||
if (not defined $user) {
|
||||
my ($found_chan, $found_mask) = $self->{pbot}->{users}->find_user_account($cmd_channel, "$stuff->{nick}!$stuff->{user}\@$stuff->{host}", 1);
|
||||
if (not defined $found_chan) {
|
||||
return "/msg $stuff->{nick} You must have a user account to use $keyword.";
|
||||
} else {
|
||||
return "/msg $stuff->{nick} You must have a user account in $cmd_channel to use $keyword. (You have an account in $found_chan.)";
|
||||
}
|
||||
} elsif (not $user->{loggedin}) {
|
||||
return "/msg $stuff->{nick} You must be logged into your user account to use $keyword.";
|
||||
}
|
||||
|
||||
if (not $self->{pbot}->{capabilities}->userhas($user, "can-$keyword")) {
|
||||
return "/msg $stuff->{nick} The $keyword command requires the can-$keyword capability, which your user account does not have.";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$stuff->{no_nickoverride} = 1;
|
||||
if ($self->get_meta($keyword, 'background-process')) {
|
||||
my $timeout = $self->get_meta($keyword, 'process-timeout') // $self->{pbot}->{registry}->get_value('processmanager', 'default_timeout');
|
||||
$self->{pbot}->{process_manager}->execute_process(
|
||||
$stuff,
|
||||
sub { $stuff->{result} = $ref->{subref}->($stuff->{from}, $stuff->{nick}, $stuff->{user}, $stuff->{host}, $stuff->{arguments}, $stuff) },
|
||||
$timeout
|
||||
);
|
||||
return "";
|
||||
} else {
|
||||
my $result = $ref->{subref}->($stuff->{from}, $stuff->{nick}, $stuff->{user}, $stuff->{host}, $stuff->{arguments}, $stuff);
|
||||
return undef if $stuff->{referenced} and $result =~ m/(?:usage:|no results)/i;
|
||||
return $result;
|
||||
}
|
||||
if ($self->{pbot}->{registry}->get_value('general', 'debugcontext')) {
|
||||
use Data::Dumper;
|
||||
$Data::Dumper::Sortkeys = 1;
|
||||
$self->{pbot}->{logger}->log("Commands::interpreter\n");
|
||||
$self->{pbot}->{logger}->log(Dumper $stuff);
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
|
||||
my $keyword = lc $stuff->{keyword};
|
||||
my $from = $stuff->{from};
|
||||
|
||||
my ($cmd_channel) = $stuff->{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
|
||||
my $user = $self->{pbot}->{users}->find_user($cmd_channel, "$stuff->{nick}!$stuff->{user}\@$stuff->{host}");
|
||||
|
||||
my $cap_override;
|
||||
if (exists $stuff->{'cap-override'}) {
|
||||
$self->{pbot}->{logger}->log("Override cap to $stuff->{'cap-override'}\n");
|
||||
$cap_override = $stuff->{'cap-override'};
|
||||
}
|
||||
|
||||
foreach my $ref (@{$self->{handlers}}) {
|
||||
if ($ref->{name} eq $keyword) {
|
||||
my $requires_cap = $self->get_meta($keyword, 'requires_cap') // $ref->{requires_cap};
|
||||
if ($requires_cap) {
|
||||
if (defined $cap_override) {
|
||||
if (not $self->{pbot}->{capabilities}->has($cap_override, "can-$keyword")) {
|
||||
return "/msg $stuff->{nick} The $keyword command requires the can-$keyword capability, which cap-override $cap_override does not have.";
|
||||
}
|
||||
} else {
|
||||
if (not defined $user) {
|
||||
my ($found_chan, $found_mask) = $self->{pbot}->{users}->find_user_account($cmd_channel, "$stuff->{nick}!$stuff->{user}\@$stuff->{host}", 1);
|
||||
if (not defined $found_chan) { return "/msg $stuff->{nick} You must have a user account to use $keyword."; }
|
||||
else { return "/msg $stuff->{nick} You must have a user account in $cmd_channel to use $keyword. (You have an account in $found_chan.)"; }
|
||||
} elsif (not $user->{loggedin}) {
|
||||
return "/msg $stuff->{nick} You must be logged into your user account to use $keyword.";
|
||||
}
|
||||
|
||||
if (not $self->{pbot}->{capabilities}->userhas($user, "can-$keyword")) {
|
||||
return "/msg $stuff->{nick} The $keyword command requires the can-$keyword capability, which your user account does not have.";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$stuff->{no_nickoverride} = 1;
|
||||
if ($self->get_meta($keyword, 'background-process')) {
|
||||
my $timeout = $self->get_meta($keyword, 'process-timeout') // $self->{pbot}->{registry}->get_value('processmanager', 'default_timeout');
|
||||
$self->{pbot}->{process_manager}->execute_process(
|
||||
$stuff,
|
||||
sub { $stuff->{result} = $ref->{subref}->($stuff->{from}, $stuff->{nick}, $stuff->{user}, $stuff->{host}, $stuff->{arguments}, $stuff) },
|
||||
$timeout
|
||||
);
|
||||
return "";
|
||||
} else {
|
||||
my $result = $ref->{subref}->($stuff->{from}, $stuff->{nick}, $stuff->{user}, $stuff->{host}, $stuff->{arguments}, $stuff);
|
||||
return undef if $stuff->{referenced} and $result =~ m/(?:usage:|no results)/i;
|
||||
return $result;
|
||||
}
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub set_meta {
|
||||
my ($self, $command, $key, $value, $save) = @_;
|
||||
return undef if not $self->{metadata}->exists($command);
|
||||
$self->{metadata}->set($command, $key, $value, !$save);
|
||||
return 1;
|
||||
my ($self, $command, $key, $value, $save) = @_;
|
||||
return undef if not $self->{metadata}->exists($command);
|
||||
$self->{metadata}->set($command, $key, $value, !$save);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub get_meta {
|
||||
my ($self, $command, $key) = @_;
|
||||
return $self->{metadata}->get_data($command, $key);
|
||||
my ($self, $command, $key) = @_;
|
||||
return $self->{metadata}->get_data($command, $key);
|
||||
}
|
||||
|
||||
sub cmdset {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($command, $key, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3);
|
||||
return "Usage: cmdset <command> [key [value]]" if not defined $command;
|
||||
return $self->{metadata}->set($command, $key, $value);
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($command, $key, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3);
|
||||
return "Usage: cmdset <command> [key [value]]" if not defined $command;
|
||||
return $self->{metadata}->set($command, $key, $value);
|
||||
}
|
||||
|
||||
sub cmdunset {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($command, $key) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
return "Usage: cmdunset <command> <key>" if not defined $command or not defined $key;
|
||||
return $self->{metadata}->unset($command, $key);
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($command, $key) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
return "Usage: cmdunset <command> <key>" if not defined $command or not defined $key;
|
||||
return $self->{metadata}->unset($command, $key);
|
||||
}
|
||||
|
||||
sub help {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
|
||||
if (not length $arguments) {
|
||||
return "For general help, see <https://github.com/pragma-/pbot/tree/master/doc>. For help about a specific command or factoid, use `help <keyword> [channel]`.";
|
||||
}
|
||||
|
||||
my $keyword = lc $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
|
||||
# check built-in commands first
|
||||
if ($self->exists($keyword)) {
|
||||
if ($self->{metadata}->exists($keyword)) {
|
||||
my $name = $self->{metadata}->get_data($keyword, '_name');
|
||||
my $requires_cap = $self->{metadata}->get_data($keyword, 'requires_cap');
|
||||
my $help = $self->{metadata}->get_data($keyword, 'help');
|
||||
my $result = "/say $name: ";
|
||||
$result .= "[Requires can-$keyword] " if $requires_cap;
|
||||
|
||||
if (not defined $help or not length $help) {
|
||||
$result .= "I have no help for this command yet.";
|
||||
} else {
|
||||
$result .= $help;
|
||||
}
|
||||
return $result;
|
||||
if (not length $arguments) {
|
||||
return "For general help, see <https://github.com/pragma-/pbot/tree/master/doc>. For help about a specific command or factoid, use `help <keyword> [channel]`.";
|
||||
}
|
||||
return "$keyword is a built-in command, but I have no help for it yet.";
|
||||
}
|
||||
|
||||
# then factoids
|
||||
my $channel_arg = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
$channel_arg = $from if not defined $channel_arg or not length $channel_arg;
|
||||
$channel_arg = '.*' if $channel_arg !~ m/^#/;
|
||||
my $keyword = lc $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
|
||||
my @factoids = $self->{pbot}->{factoids}->find_factoid($channel_arg, $keyword, exact_trigger => 1);
|
||||
# check built-in commands first
|
||||
if ($self->exists($keyword)) {
|
||||
if ($self->{metadata}->exists($keyword)) {
|
||||
my $name = $self->{metadata}->get_data($keyword, '_name');
|
||||
my $requires_cap = $self->{metadata}->get_data($keyword, 'requires_cap');
|
||||
my $help = $self->{metadata}->get_data($keyword, 'help');
|
||||
my $result = "/say $name: ";
|
||||
$result .= "[Requires can-$keyword] " if $requires_cap;
|
||||
|
||||
if (not @factoids or not $factoids[0]) {
|
||||
return "I don't know anything about $keyword.";
|
||||
}
|
||||
|
||||
my ($channel, $trigger);
|
||||
|
||||
if (@factoids > 1) {
|
||||
if (not grep { $_->[0] eq $channel_arg } @factoids) {
|
||||
return "/say $keyword found in multiple channels: " . (join ', ', sort map { $_->[0] eq '.*' ? 'global' : $_->[0] } @factoids) . "; use `help $keyword <channel>` to disambiguate.";
|
||||
} else {
|
||||
foreach my $factoid (@factoids) {
|
||||
if ($factoid->[0] eq $channel_arg) {
|
||||
($channel, $trigger) = ($factoid->[0], $factoid->[1]);
|
||||
last;
|
||||
if (not defined $help or not length $help) { $result .= "I have no help for this command yet."; }
|
||||
else { $result .= $help; }
|
||||
return $result;
|
||||
}
|
||||
}
|
||||
return "$keyword is a built-in command, but I have no help for it yet.";
|
||||
}
|
||||
} else {
|
||||
($channel, $trigger) = ($factoids[0]->[0], $factoids[0]->[1]);
|
||||
}
|
||||
|
||||
my $channel_name = $self->{pbot}->{factoids}->{factoids}->get_data($channel, '_name');
|
||||
my $trigger_name = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, '_name');
|
||||
$channel_name = 'global channel' if $channel_name eq '.*';
|
||||
$trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /;
|
||||
# then factoids
|
||||
my $channel_arg = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
$channel_arg = $from if not defined $channel_arg or not length $channel_arg;
|
||||
$channel_arg = '.*' if $channel_arg !~ m/^#/;
|
||||
|
||||
my $result = "/say ";
|
||||
$result .= "[$channel_name] " if $channel ne $from and $channel ne '.*';
|
||||
$result .= "$trigger_name: ";
|
||||
my @factoids = $self->{pbot}->{factoids}->find_factoid($channel_arg, $keyword, exact_trigger => 1);
|
||||
|
||||
my $help = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, 'help');
|
||||
if (not @factoids or not $factoids[0]) { return "I don't know anything about $keyword."; }
|
||||
|
||||
if (not defined $help or not length $help) {
|
||||
return "/say $trigger_name is a factoid for $channel_name, but I have no help for it yet.";
|
||||
}
|
||||
my ($channel, $trigger);
|
||||
|
||||
$result .= $help;
|
||||
return $result;
|
||||
if (@factoids > 1) {
|
||||
if (not grep { $_->[0] eq $channel_arg } @factoids) {
|
||||
return
|
||||
"/say $keyword found in multiple channels: "
|
||||
. (join ', ', sort map { $_->[0] eq '.*' ? 'global' : $_->[0] } @factoids)
|
||||
. "; use `help $keyword <channel>` to disambiguate.";
|
||||
} else {
|
||||
foreach my $factoid (@factoids) {
|
||||
if ($factoid->[0] eq $channel_arg) {
|
||||
($channel, $trigger) = ($factoid->[0], $factoid->[1]);
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
($channel, $trigger) = ($factoids[0]->[0], $factoids[0]->[1]);
|
||||
}
|
||||
|
||||
my $channel_name = $self->{pbot}->{factoids}->{factoids}->get_data($channel, '_name');
|
||||
my $trigger_name = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, '_name');
|
||||
$channel_name = 'global channel' if $channel_name eq '.*';
|
||||
$trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /;
|
||||
|
||||
my $result = "/say ";
|
||||
$result .= "[$channel_name] " if $channel ne $from and $channel ne '.*';
|
||||
$result .= "$trigger_name: ";
|
||||
|
||||
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 for it yet."; }
|
||||
|
||||
$result .= $help;
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub uptime {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
return localtime ($self->{pbot}->{startup_timestamp}) . " [" . duration (time - $self->{pbot}->{startup_timestamp}) . "]";
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
return localtime($self->{pbot}->{startup_timestamp}) . " [" . duration(time - $self->{pbot}->{startup_timestamp}) . "]";
|
||||
}
|
||||
|
||||
sub in_channel {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
|
||||
my $usage = "Usage: in <channel> <command>";
|
||||
return $usage if not $arguments;
|
||||
my $usage = "Usage: in <channel> <command>";
|
||||
return $usage if not $arguments;
|
||||
|
||||
my ($channel, $command) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2, 0, 1);
|
||||
return $usage if not defined $channel or not defined $command;
|
||||
my ($channel, $command) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2, 0, 1);
|
||||
return $usage if not defined $channel or not defined $command;
|
||||
|
||||
if (not $self->{pbot}->{nicklist}->is_present($channel, $nick)) {
|
||||
return "You must be present in $channel to do this.";
|
||||
}
|
||||
if (not $self->{pbot}->{nicklist}->is_present($channel, $nick)) { return "You must be present in $channel to do this."; }
|
||||
|
||||
$stuff->{from} = $channel;
|
||||
$stuff->{command} = $command;
|
||||
return $self->{pbot}->{interpreter}->interpret($stuff);
|
||||
$stuff->{from} = $channel;
|
||||
$stuff->{command} = $command;
|
||||
return $self->{pbot}->{interpreter}->interpret($stuff);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -20,364 +20,347 @@ use Text::Levenshtein qw(fastdistance);
|
|||
use JSON;
|
||||
|
||||
sub new {
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
Carp::croak("Missing pbot reference to " . __FILE__) unless exists $conf{pbot};
|
||||
$self->{pbot} = $conf{pbot};
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
Carp::croak("Missing pbot reference to " . __FILE__) unless exists $conf{pbot};
|
||||
$self->{pbot} = $conf{pbot};
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{name} = $conf{name} // 'Dual Index hash object';
|
||||
$self->{filename} = $conf{filename} // Carp::carp("Missing filename to DualIndexHashObject, will not be able to save to or load from file.");
|
||||
$self->{hash} = {};
|
||||
my ($self, %conf) = @_;
|
||||
$self->{name} = $conf{name} // 'Dual Index hash object';
|
||||
$self->{filename} = $conf{filename} // Carp::carp("Missing filename to DualIndexHashObject, will not be able to save to or load from file.");
|
||||
$self->{hash} = {};
|
||||
}
|
||||
|
||||
sub load {
|
||||
my ($self, $filename) = @_;
|
||||
$filename = $self->{filename} if not defined $filename;
|
||||
my ($self, $filename) = @_;
|
||||
$filename = $self->{filename} if not defined $filename;
|
||||
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No $self->{name} filename specified -- skipping loading from file";
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Loading $self->{name} from $filename ...\n");
|
||||
|
||||
if (not open(FILE, "< $filename")) {
|
||||
Carp::carp "Skipping loading from file: Couldn't open $filename: $!\n";
|
||||
return;
|
||||
}
|
||||
|
||||
my $contents = do {
|
||||
local $/;
|
||||
<FILE>;
|
||||
};
|
||||
|
||||
$self->{hash} = decode_json $contents if length $contents;
|
||||
close FILE;
|
||||
|
||||
# update existing entries to use _name to preserve case
|
||||
# and lowercase any non-lowercased entries
|
||||
foreach my $primary_index (keys %{ $self->{hash} }) {
|
||||
if (not exists $self->{hash}->{$primary_index}->{_name}) {
|
||||
if (lc $primary_index eq $primary_index) {
|
||||
$self->{hash}->{$primary_index}->{_name} = $primary_index;
|
||||
} else {
|
||||
if (exists $self->{hash}->{lc $primary_index}) {
|
||||
Carp::croak "Cannot update $self->{name} primary index $primary_index; duplicate object found";
|
||||
}
|
||||
|
||||
my $data = delete $self->{hash}->{$primary_index};
|
||||
$data->{_name} = $primary_index;
|
||||
$primary_index = lc $primary_index;
|
||||
$self->{hash}->{$primary_index} = $data;
|
||||
}
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No $self->{name} filename specified -- skipping loading from file";
|
||||
return;
|
||||
}
|
||||
|
||||
foreach my $secondary_index (keys %{ $self->{hash}->{$primary_index} }) {
|
||||
next if $secondary_index eq '_name';
|
||||
if (not exists $self->{hash}->{$primary_index}->{$secondary_index}->{_name}) {
|
||||
if (lc $secondary_index eq $secondary_index) {
|
||||
$self->{hash}->{$primary_index}->{$secondary_index}->{_name} = $secondary_index;
|
||||
} else {
|
||||
if (exists $self->{hash}->{$primary_index}->{lc $secondary_index}) {
|
||||
Carp::croak "Cannot update $self->{name} $primary_index sub-object $secondary_index; duplicate object found";
|
||||
}
|
||||
$self->{pbot}->{logger}->log("Loading $self->{name} from $filename ...\n");
|
||||
|
||||
my $data = delete $self->{hash}->{$primary_index}->{$secondary_index};
|
||||
$data->{_name} = $secondary_index;
|
||||
$secondary_index = lc $secondary_index;
|
||||
$self->{hash}->{$primary_index}->{$secondary_index} = $data;
|
||||
}
|
||||
}
|
||||
if (not open(FILE, "< $filename")) {
|
||||
$self->{pbot}->{logger}->log("Skipping loading from file: Couldn't open $filename: $!\n");
|
||||
return;
|
||||
}
|
||||
|
||||
my $contents = do {
|
||||
local $/;
|
||||
<FILE>;
|
||||
};
|
||||
|
||||
$self->{hash} = decode_json $contents if length $contents;
|
||||
close FILE;
|
||||
|
||||
# update existing entries to use _name to preserve case
|
||||
# and lowercase any non-lowercased entries
|
||||
foreach my $primary_index (keys %{$self->{hash}}) {
|
||||
if (not exists $self->{hash}->{$primary_index}->{_name}) {
|
||||
if (lc $primary_index eq $primary_index) { $self->{hash}->{$primary_index}->{_name} = $primary_index; }
|
||||
else {
|
||||
if (exists $self->{hash}->{lc $primary_index}) { Carp::croak "Cannot update $self->{name} primary index $primary_index; duplicate object found"; }
|
||||
|
||||
my $data = delete $self->{hash}->{$primary_index};
|
||||
$data->{_name} = $primary_index;
|
||||
$primary_index = lc $primary_index;
|
||||
$self->{hash}->{$primary_index} = $data;
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $secondary_index (keys %{$self->{hash}->{$primary_index}}) {
|
||||
next if $secondary_index eq '_name';
|
||||
if (not exists $self->{hash}->{$primary_index}->{$secondary_index}->{_name}) {
|
||||
if (lc $secondary_index eq $secondary_index) { $self->{hash}->{$primary_index}->{$secondary_index}->{_name} = $secondary_index; }
|
||||
else {
|
||||
if (exists $self->{hash}->{$primary_index}->{lc $secondary_index}) {
|
||||
Carp::croak "Cannot update $self->{name} $primary_index sub-object $secondary_index; duplicate object found";
|
||||
}
|
||||
|
||||
my $data = delete $self->{hash}->{$primary_index}->{$secondary_index};
|
||||
$data->{_name} = $secondary_index;
|
||||
$secondary_index = lc $secondary_index;
|
||||
$self->{hash}->{$primary_index}->{$secondary_index} = $data;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub save {
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
if (@_) { $filename = shift; } else { $filename = $self->{filename}; }
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
if (@_) { $filename = shift; }
|
||||
else { $filename = $self->{filename}; }
|
||||
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No $self->{name} filename specified -- skipping saving to file.\n";
|
||||
return;
|
||||
}
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No $self->{name} filename specified -- skipping saving to file.\n";
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Saving $self->{name} to $filename\n");
|
||||
$self->{pbot}->{logger}->log("Saving $self->{name} to $filename\n");
|
||||
|
||||
my $json = JSON->new;
|
||||
my $json_text = $json->pretty->canonical->utf8->encode($self->{hash});
|
||||
my $json = JSON->new;
|
||||
my $json_text = $json->pretty->canonical->utf8->encode($self->{hash});
|
||||
|
||||
open(FILE, "> $filename") or die "Couldn't open $filename: $!\n";
|
||||
print FILE "$json_text\n";
|
||||
close FILE;
|
||||
open(FILE, "> $filename") or die "Couldn't open $filename: $!\n";
|
||||
print FILE "$json_text\n";
|
||||
close FILE;
|
||||
}
|
||||
|
||||
sub clear {
|
||||
my $self = shift;
|
||||
$self->{hash} = {};
|
||||
my $self = shift;
|
||||
$self->{hash} = {};
|
||||
}
|
||||
|
||||
sub levenshtein_matches {
|
||||
my ($self, $primary_index, $secondary_index, $distance, $strictnamespace) = @_;
|
||||
my $comma = '';
|
||||
my $result = "";
|
||||
my ($self, $primary_index, $secondary_index, $distance, $strictnamespace) = @_;
|
||||
my $comma = '';
|
||||
my $result = "";
|
||||
|
||||
$distance = 0.60 if not defined $distance;
|
||||
$distance = 0.60 if not defined $distance;
|
||||
|
||||
$primary_index = '.*' if not defined $primary_index;
|
||||
$primary_index = '.*' if not defined $primary_index;
|
||||
|
||||
if (not $secondary_index) {
|
||||
foreach my $index (sort keys %{ $self->{hash} }) {
|
||||
my $distance_result = fastdistance($primary_index, $index);
|
||||
my $length = (length $primary_index > length $index) ? length $primary_index : length $index;
|
||||
if (not $secondary_index) {
|
||||
foreach my $index (sort keys %{$self->{hash}}) {
|
||||
my $distance_result = fastdistance($primary_index, $index);
|
||||
my $length = (length $primary_index > length $index) ? length $primary_index : length $index;
|
||||
|
||||
if ($distance_result / $length < $distance) {
|
||||
my $name = $self->{hash}->{$index}->{_name};
|
||||
if ($name =~ / /) {
|
||||
$result .= $comma . "\"$name\"";
|
||||
} else {
|
||||
$result .= $comma . $name;
|
||||
if ($distance_result / $length < $distance) {
|
||||
my $name = $self->{hash}->{$index}->{_name};
|
||||
if ($name =~ / /) { $result .= $comma . "\"$name\""; }
|
||||
else { $result .= $comma . $name; }
|
||||
$comma = ", ";
|
||||
}
|
||||
}
|
||||
$comma = ", ";
|
||||
}
|
||||
}
|
||||
} else {
|
||||
my $lc_primary_index = lc $primary_index;
|
||||
if (not exists $self->{hash}->{$lc_primary_index}) {
|
||||
return 'none';
|
||||
}
|
||||
} else {
|
||||
my $lc_primary_index = lc $primary_index;
|
||||
if (not exists $self->{hash}->{$lc_primary_index}) { return 'none'; }
|
||||
|
||||
my $last_header = "";
|
||||
my $header = "";
|
||||
my $last_header = "";
|
||||
my $header = "";
|
||||
|
||||
foreach my $index1 (sort keys %{ $self->{hash} }) {
|
||||
$header = "[$self->{hash}->{$index1}->{_name}] ";
|
||||
$header = '[global] ' if $header eq '[.*] ';
|
||||
foreach my $index1 (sort keys %{$self->{hash}}) {
|
||||
$header = "[$self->{hash}->{$index1}->{_name}] ";
|
||||
$header = '[global] ' if $header eq '[.*] ';
|
||||
|
||||
if ($strictnamespace) {
|
||||
next unless $index1 eq '.*' or $index1 eq $lc_primary_index;
|
||||
$header = "" unless $header eq '[global] ';
|
||||
}
|
||||
if ($strictnamespace) {
|
||||
next unless $index1 eq '.*' or $index1 eq $lc_primary_index;
|
||||
$header = "" unless $header eq '[global] ';
|
||||
}
|
||||
|
||||
foreach my $index2 (sort keys %{ $self->{hash}->{$index1} }) {
|
||||
my $distance_result = fastdistance($secondary_index, $index2);
|
||||
my $length = (length $secondary_index > length $index2) ? length $secondary_index : length $index2;
|
||||
foreach my $index2 (sort keys %{$self->{hash}->{$index1}}) {
|
||||
my $distance_result = fastdistance($secondary_index, $index2);
|
||||
my $length = (length $secondary_index > length $index2) ? length $secondary_index : length $index2;
|
||||
|
||||
if ($distance_result / $length < $distance) {
|
||||
my $name = $self->{hash}->{$index1}->{$index2}->{_name};
|
||||
$header = "" if $last_header eq $header;
|
||||
$last_header = $header;
|
||||
$comma = '; ' if $comma ne '' and $header ne '';
|
||||
if ($name =~ / /) {
|
||||
$result .= $comma . $header . "\"$name\"";
|
||||
} else {
|
||||
$result .= $comma . $header . $name;
|
||||
}
|
||||
$comma = ", ";
|
||||
if ($distance_result / $length < $distance) {
|
||||
my $name = $self->{hash}->{$index1}->{$index2}->{_name};
|
||||
$header = "" if $last_header eq $header;
|
||||
$last_header = $header;
|
||||
$comma = '; ' if $comma ne '' and $header ne '';
|
||||
if ($name =~ / /) { $result .= $comma . $header . "\"$name\""; }
|
||||
else { $result .= $comma . $header . $name; }
|
||||
$comma = ", ";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$result =~ s/(.*), /$1 or /;
|
||||
$result = 'none' if $comma eq '';
|
||||
return $result;
|
||||
$result =~ s/(.*), /$1 or /;
|
||||
$result = 'none' if $comma eq '';
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub set {
|
||||
my ($self, $primary_index, $secondary_index, $key, $value, $dont_save) = @_;
|
||||
my $lc_primary_index = lc $primary_index;
|
||||
my $lc_secondary_index = lc $secondary_index;
|
||||
my ($self, $primary_index, $secondary_index, $key, $value, $dont_save) = @_;
|
||||
my $lc_primary_index = lc $primary_index;
|
||||
my $lc_secondary_index = lc $secondary_index;
|
||||
|
||||
if (not exists $self->{hash}->{$lc_primary_index}) {
|
||||
my $result = "$self->{name}: $primary_index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($primary_index);
|
||||
return $result;
|
||||
}
|
||||
|
||||
if (not exists $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}) {
|
||||
my $secondary_text = $secondary_index =~ / / ? "\"$secondary_index\"" : $secondary_index;
|
||||
my $result = "$self->{name}: [$self->{hash}->{$lc_primary_index}->{_name}] $secondary_text not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($primary_index, $secondary_index);
|
||||
return $result;
|
||||
}
|
||||
|
||||
my $name1 = $self->{hash}->{$lc_primary_index}->{_name};
|
||||
my $name2 = $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{_name};
|
||||
|
||||
$name1 = 'global' if $name1 eq '.*';
|
||||
$name2 = "\"$name2\"" if $name2 =~ / /;
|
||||
|
||||
if (not defined $key) {
|
||||
my $result = "[$name1] $name2 keys:\n";
|
||||
my $comma = '';
|
||||
foreach my $key (sort keys %{ $self->{hash}->{$lc_primary_index}->{$lc_secondary_index} }) {
|
||||
next if $key eq '_name';
|
||||
$result .= $comma . "$key => " . $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{$key};
|
||||
$comma = ";\n";
|
||||
if (not exists $self->{hash}->{$lc_primary_index}) {
|
||||
my $result = "$self->{name}: $primary_index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($primary_index);
|
||||
return $result;
|
||||
}
|
||||
$result .= "none" if ($comma eq '');
|
||||
return $result;
|
||||
}
|
||||
|
||||
if (not defined $value) {
|
||||
$value = $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{$key};
|
||||
} else {
|
||||
$self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{$key} = $value;
|
||||
$self->save unless $dont_save;
|
||||
}
|
||||
if (not exists $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}) {
|
||||
my $secondary_text = $secondary_index =~ / / ? "\"$secondary_index\"" : $secondary_index;
|
||||
my $result = "$self->{name}: [$self->{hash}->{$lc_primary_index}->{_name}] $secondary_text not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($primary_index, $secondary_index);
|
||||
return $result;
|
||||
}
|
||||
|
||||
return "[$name1] $name2: $key " . (defined $value ? "set to $value" : "is not set.");
|
||||
my $name1 = $self->{hash}->{$lc_primary_index}->{_name};
|
||||
my $name2 = $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{_name};
|
||||
|
||||
$name1 = 'global' if $name1 eq '.*';
|
||||
$name2 = "\"$name2\"" if $name2 =~ / /;
|
||||
|
||||
if (not defined $key) {
|
||||
my $result = "[$name1] $name2 keys:\n";
|
||||
my $comma = '';
|
||||
foreach my $key (sort keys %{$self->{hash}->{$lc_primary_index}->{$lc_secondary_index}}) {
|
||||
next if $key eq '_name';
|
||||
$result .= $comma . "$key => " . $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{$key};
|
||||
$comma = ";\n";
|
||||
}
|
||||
$result .= "none" if ($comma eq '');
|
||||
return $result;
|
||||
}
|
||||
|
||||
if (not defined $value) { $value = $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{$key}; }
|
||||
else {
|
||||
$self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{$key} = $value;
|
||||
$self->save unless $dont_save;
|
||||
}
|
||||
|
||||
return "[$name1] $name2: $key " . (defined $value ? "set to $value" : "is not set.");
|
||||
}
|
||||
|
||||
sub unset {
|
||||
my ($self, $primary_index, $secondary_index, $key) = @_;
|
||||
my $lc_primary_index = lc $primary_index;
|
||||
my $lc_secondary_index = lc $secondary_index;
|
||||
my ($self, $primary_index, $secondary_index, $key) = @_;
|
||||
my $lc_primary_index = lc $primary_index;
|
||||
my $lc_secondary_index = lc $secondary_index;
|
||||
|
||||
if (not exists $self->{hash}->{$lc_primary_index}) {
|
||||
my $result = "$self->{name}: $primary_index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($primary_index);
|
||||
return $result;
|
||||
}
|
||||
if (not exists $self->{hash}->{$lc_primary_index}) {
|
||||
my $result = "$self->{name}: $primary_index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($primary_index);
|
||||
return $result;
|
||||
}
|
||||
|
||||
my $name1 = $self->{hash}->{$lc_primary_index}->{_name};
|
||||
$name1 = 'global' if $name1 eq '.*';
|
||||
my $name1 = $self->{hash}->{$lc_primary_index}->{_name};
|
||||
$name1 = 'global' if $name1 eq '.*';
|
||||
|
||||
if (not exists $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}) {
|
||||
my $result = "$self->{name}: [$name1] $secondary_index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($primary_index, $secondary_index);
|
||||
return $result;
|
||||
}
|
||||
if (not exists $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}) {
|
||||
my $result = "$self->{name}: [$name1] $secondary_index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($primary_index, $secondary_index);
|
||||
return $result;
|
||||
}
|
||||
|
||||
my $name2 = $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{_name};
|
||||
$name2 = "\"$name2\"" if $name2 =~ / /;
|
||||
my $name2 = $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{_name};
|
||||
$name2 = "\"$name2\"" if $name2 =~ / /;
|
||||
|
||||
if (defined delete $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{$key}) {
|
||||
if (defined delete $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{$key}) {
|
||||
$self->save;
|
||||
return "$self->{name}: [$name1] $name2: $key unset.";
|
||||
} else {
|
||||
return "$self->{name}: [$name1] $name2: $key does not exist.";
|
||||
}
|
||||
$self->save;
|
||||
return "$self->{name}: [$name1] $name2: $key unset.";
|
||||
} else {
|
||||
return "$self->{name}: [$name1] $name2: $key does not exist.";
|
||||
}
|
||||
$self->save;
|
||||
}
|
||||
|
||||
sub exists {
|
||||
my ($self, $primary_index, $secondary_index, $data_index) = @_;
|
||||
return 0 if not defined $primary_index;
|
||||
$primary_index = lc $primary_index;
|
||||
return 0 if not exists $self->{hash}->{$primary_index};
|
||||
return 1 if not defined $secondary_index;
|
||||
$secondary_index = lc $secondary_index;
|
||||
return 0 if not exists $self->{hash}->{$primary_index}->{$secondary_index};
|
||||
return 1 if not defined $data_index;
|
||||
return exists $self->{hash}->{$primary_index}->{$secondary_index}->{$data_index};
|
||||
my ($self, $primary_index, $secondary_index, $data_index) = @_;
|
||||
return 0 if not defined $primary_index;
|
||||
$primary_index = lc $primary_index;
|
||||
return 0 if not exists $self->{hash}->{$primary_index};
|
||||
return 1 if not defined $secondary_index;
|
||||
$secondary_index = lc $secondary_index;
|
||||
return 0 if not exists $self->{hash}->{$primary_index}->{$secondary_index};
|
||||
return 1 if not defined $data_index;
|
||||
return exists $self->{hash}->{$primary_index}->{$secondary_index}->{$data_index};
|
||||
}
|
||||
|
||||
sub get_keys {
|
||||
my ($self, $primary_index, $secondary_index) = @_;
|
||||
return keys %{$self->{hash}} if not defined $primary_index;
|
||||
my ($self, $primary_index, $secondary_index) = @_;
|
||||
return keys %{$self->{hash}} if not defined $primary_index;
|
||||
|
||||
if (not defined $secondary_index) {
|
||||
return grep { $_ ne '_name' } keys %{$self->{hash}->{lc $primary_index}};
|
||||
}
|
||||
if (not defined $secondary_index) {
|
||||
return grep { $_ ne '_name' } keys %{$self->{hash}->{lc $primary_index}};
|
||||
}
|
||||
|
||||
return grep { $_ ne '_name' } keys %{$self->{hash}->{lc $primary_index}->{lc $secondary_index}};
|
||||
return grep { $_ ne '_name' } keys %{$self->{hash}->{lc $primary_index}->{lc $secondary_index}};
|
||||
}
|
||||
|
||||
sub get_data {
|
||||
my ($self, $primary_index, $secondary_index, $data_index) = @_;
|
||||
$primary_index = lc $primary_index if defined $primary_index;
|
||||
$secondary_index = lc $secondary_index if defined $secondary_index;
|
||||
return undef if not exists $self->{hash}->{$primary_index};
|
||||
return $self->{hash}->{$primary_index} if not defined $secondary_index;
|
||||
return $self->{hash}->{$primary_index}->{$secondary_index} if not defined $data_index;
|
||||
return $self->{hash}->{$primary_index}->{$secondary_index}->{$data_index};
|
||||
my ($self, $primary_index, $secondary_index, $data_index) = @_;
|
||||
$primary_index = lc $primary_index if defined $primary_index;
|
||||
$secondary_index = lc $secondary_index if defined $secondary_index;
|
||||
return undef if not exists $self->{hash}->{$primary_index};
|
||||
return $self->{hash}->{$primary_index} if not defined $secondary_index;
|
||||
return $self->{hash}->{$primary_index}->{$secondary_index} if not defined $data_index;
|
||||
return $self->{hash}->{$primary_index}->{$secondary_index}->{$data_index};
|
||||
}
|
||||
|
||||
sub add {
|
||||
my ($self, $primary_index, $secondary_index, $data, $dont_save, $quiet) = @_;
|
||||
my $lc_primary_index = lc $primary_index;
|
||||
my $lc_secondary_index = lc $secondary_index;
|
||||
my ($self, $primary_index, $secondary_index, $data, $dont_save, $quiet) = @_;
|
||||
my $lc_primary_index = lc $primary_index;
|
||||
my $lc_secondary_index = lc $secondary_index;
|
||||
|
||||
if (not exists $self->{hash}->{$lc_primary_index}) {
|
||||
$self->{hash}->{$lc_primary_index}->{_name} = $primary_index; # preserve case
|
||||
}
|
||||
if (not exists $self->{hash}->{$lc_primary_index}) {
|
||||
$self->{hash}->{$lc_primary_index}->{_name} = $primary_index; # preserve case
|
||||
}
|
||||
|
||||
$data->{_name} = $secondary_index; # preserve case
|
||||
$self->{hash}->{$lc_primary_index}->{$lc_secondary_index} = $data;
|
||||
$self->save() unless $dont_save;
|
||||
$data->{_name} = $secondary_index; # preserve case
|
||||
$self->{hash}->{$lc_primary_index}->{$lc_secondary_index} = $data;
|
||||
$self->save() unless $dont_save;
|
||||
|
||||
my $name1 = $self->{hash}->{$lc_primary_index}->{_name};
|
||||
my $name2 = $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{_name};
|
||||
$name1 = 'global' if $name1 eq '.*';
|
||||
$name2 = "\"$name2\"" if $name2 =~ / /;
|
||||
$self->{pbot}->{logger}->log("$self->{name}: [$name1]: $name2 added.\n") unless $dont_save or $quiet;
|
||||
return "$self->{name}: [$name1]: $name2 added.";
|
||||
my $name1 = $self->{hash}->{$lc_primary_index}->{_name};
|
||||
my $name2 = $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{_name};
|
||||
$name1 = 'global' if $name1 eq '.*';
|
||||
$name2 = "\"$name2\"" if $name2 =~ / /;
|
||||
$self->{pbot}->{logger}->log("$self->{name}: [$name1]: $name2 added.\n") unless $dont_save or $quiet;
|
||||
return "$self->{name}: [$name1]: $name2 added.";
|
||||
}
|
||||
|
||||
sub remove {
|
||||
my ($self, $primary_index, $secondary_index, $data_index, $dont_save) = @_;
|
||||
my $lc_primary_index = lc $primary_index;
|
||||
my $lc_secondary_index = lc $secondary_index;
|
||||
my ($self, $primary_index, $secondary_index, $data_index, $dont_save) = @_;
|
||||
my $lc_primary_index = lc $primary_index;
|
||||
my $lc_secondary_index = lc $secondary_index;
|
||||
|
||||
if (not exists $self->{hash}->{$lc_primary_index}) {
|
||||
my $result = "$self->{name}: $primary_index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($primary_index);
|
||||
return $result;
|
||||
}
|
||||
|
||||
if (not defined $secondary_index) {
|
||||
my $data = delete $self->{hash}->{$lc_primary_index};
|
||||
if (defined $data) {
|
||||
my $name = $data->{_name};
|
||||
$name = 'global' if $name eq '.*';
|
||||
$self->save unless $dont_save;
|
||||
return "$self->{name}: $name removed.";
|
||||
} else {
|
||||
return "$self->{name}: $primary_index does not exist.";
|
||||
if (not exists $self->{hash}->{$lc_primary_index}) {
|
||||
my $result = "$self->{name}: $primary_index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($primary_index);
|
||||
return $result;
|
||||
}
|
||||
}
|
||||
|
||||
my $name1 = $self->{hash}->{$lc_primary_index}->{_name};
|
||||
$name1 = 'global' if $name1 eq '.*';
|
||||
|
||||
if (not exists $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}) {
|
||||
my $result = "$self->{name}: [$name1] $secondary_index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($primary_index, $secondary_index);
|
||||
return $result;
|
||||
}
|
||||
|
||||
if (not defined $data_index) {
|
||||
my $data = delete $self->{hash}->{$lc_primary_index}->{$lc_secondary_index};
|
||||
if (defined $data) {
|
||||
my $name2 = $data->{_name};
|
||||
$name2 = "\"$name2\"" if $name2 =~ / /;
|
||||
|
||||
# remove primary group if no more secondaries (only key left should be the _name key)
|
||||
if (keys %{ $self->{hash}->{$lc_primary_index} } == 1) {
|
||||
delete $self->{hash}->{$lc_primary_index};
|
||||
}
|
||||
|
||||
$self->save unless $dont_save;
|
||||
return "$self->{name}: [$name1] $name2 removed.";
|
||||
} else {
|
||||
return "$self->{name}: [$name1] $secondary_index does not exist.";
|
||||
if (not defined $secondary_index) {
|
||||
my $data = delete $self->{hash}->{$lc_primary_index};
|
||||
if (defined $data) {
|
||||
my $name = $data->{_name};
|
||||
$name = 'global' if $name eq '.*';
|
||||
$self->save unless $dont_save;
|
||||
return "$self->{name}: $name removed.";
|
||||
} else {
|
||||
return "$self->{name}: $primary_index does not exist.";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $name2 = $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{_name};
|
||||
if (defined delete $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{$data_index}) {
|
||||
return "$self->{name}: [$name1] $name2.$data_index removed.";
|
||||
} else {
|
||||
return "$self->{name}: [$name1] $name2.$data_index does not exist.";
|
||||
}
|
||||
my $name1 = $self->{hash}->{$lc_primary_index}->{_name};
|
||||
$name1 = 'global' if $name1 eq '.*';
|
||||
|
||||
if (not exists $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}) {
|
||||
my $result = "$self->{name}: [$name1] $secondary_index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($primary_index, $secondary_index);
|
||||
return $result;
|
||||
}
|
||||
|
||||
if (not defined $data_index) {
|
||||
my $data = delete $self->{hash}->{$lc_primary_index}->{$lc_secondary_index};
|
||||
if (defined $data) {
|
||||
my $name2 = $data->{_name};
|
||||
$name2 = "\"$name2\"" if $name2 =~ / /;
|
||||
|
||||
# remove primary group if no more secondaries (only key left should be the _name key)
|
||||
if (keys %{$self->{hash}->{$lc_primary_index}} == 1) { delete $self->{hash}->{$lc_primary_index}; }
|
||||
|
||||
$self->save unless $dont_save;
|
||||
return "$self->{name}: [$name1] $name2 removed.";
|
||||
} else {
|
||||
return "$self->{name}: [$name1] $secondary_index does not exist.";
|
||||
}
|
||||
}
|
||||
|
||||
my $name2 = $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{_name};
|
||||
if (defined delete $self->{hash}->{$lc_primary_index}->{$lc_secondary_index}->{$data_index}) { return "$self->{name}: [$name1] $name2.$data_index removed."; }
|
||||
else { return "$self->{name}: [$name1] $name2.$data_index does not exist."; }
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -11,79 +11,77 @@ use feature 'unicode_strings';
|
|||
use IO::Select;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{handlers} = { any => [] };
|
||||
my ($self, %conf) = @_;
|
||||
$self->{handlers} = {any => []};
|
||||
}
|
||||
|
||||
sub register_handler {
|
||||
my ($self, $event_type, $sub, $package_override) = @_;
|
||||
my ($package) = caller(0);
|
||||
$package = $package_override if defined $package_override;
|
||||
my $info = "$package\-\>$event_type";
|
||||
$self->{pbot}->{logger}->log("Adding handler: $info\n") if $self->{pbot}->{registry}->get_value('eventdispatcher', 'debug');
|
||||
push @{$self->{handlers}->{$event_type}}, [$sub, $info];
|
||||
my ($self, $event_type, $sub, $package_override) = @_;
|
||||
my ($package) = caller(0);
|
||||
$package = $package_override if defined $package_override;
|
||||
my $info = "$package\-\>$event_type";
|
||||
$self->{pbot}->{logger}->log("Adding handler: $info\n") if $self->{pbot}->{registry}->get_value('eventdispatcher', 'debug');
|
||||
push @{$self->{handlers}->{$event_type}}, [$sub, $info];
|
||||
}
|
||||
|
||||
sub remove_handler {
|
||||
my ($self, $event_type, $package_override) = @_;
|
||||
my ($package) = caller(0);
|
||||
$package = $package_override if defined $package_override;
|
||||
my $info = "$package\-\>$event_type";
|
||||
my ($self, $event_type, $package_override) = @_;
|
||||
my ($package) = caller(0);
|
||||
$package = $package_override if defined $package_override;
|
||||
my $info = "$package\-\>$event_type";
|
||||
|
||||
if (exists $self->{handlers}->{$event_type}) {
|
||||
for (my $i = 0; $i < @{$self->{handlers}->{$event_type}}; $i++) {
|
||||
my $ref = @{$self->{handlers}->{$event_type}}[$i];
|
||||
if ($info eq $ref->[1]) {
|
||||
$self->{pbot}->{logger}->log("Removing handler: $info\n") if $self->{pbot}->{registry}->get_value('eventdispatcher', 'debug');
|
||||
splice @{$self->{handlers}->{$event_type}}, $i--, 1;
|
||||
}
|
||||
if (exists $self->{handlers}->{$event_type}) {
|
||||
for (my $i = 0; $i < @{$self->{handlers}->{$event_type}}; $i++) {
|
||||
my $ref = @{$self->{handlers}->{$event_type}}[$i];
|
||||
if ($info eq $ref->[1]) {
|
||||
$self->{pbot}->{logger}->log("Removing handler: $info\n") if $self->{pbot}->{registry}->get_value('eventdispatcher', 'debug');
|
||||
splice @{$self->{handlers}->{$event_type}}, $i--, 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub dispatch_event {
|
||||
my ($self, $event_type, $event_data) = @_;
|
||||
my $ret = undef;
|
||||
my ($self, $event_type, $event_data) = @_;
|
||||
my $ret = undef;
|
||||
|
||||
if (exists $self->{handlers}->{$event_type}) {
|
||||
for (my $i = 0; $i < @{$self->{handlers}->{$event_type}}; $i++) {
|
||||
my $ref = @{$self->{handlers}->{$event_type}}[$i];
|
||||
my ($handler, $info) = ($ref->[0], $ref->[1]);
|
||||
my $debug = $self->{pbot}->{registry}->get_value('eventdispatcher', 'debug') // 0;
|
||||
$self->{pbot}->{logger}->log("Dispatching $event_type to handler $info\n") if $debug > 1;
|
||||
if (exists $self->{handlers}->{$event_type}) {
|
||||
for (my $i = 0; $i < @{$self->{handlers}->{$event_type}}; $i++) {
|
||||
my $ref = @{$self->{handlers}->{$event_type}}[$i];
|
||||
my ($handler, $info) = ($ref->[0], $ref->[1]);
|
||||
my $debug = $self->{pbot}->{registry}->get_value('eventdispatcher', 'debug') // 0;
|
||||
$self->{pbot}->{logger}->log("Dispatching $event_type to handler $info\n") if $debug > 1;
|
||||
|
||||
eval {
|
||||
$ret = $handler->($event_type, $event_data);
|
||||
};
|
||||
eval { $ret = $handler->($event_type, $event_data); };
|
||||
|
||||
if ($@) {
|
||||
chomp $@;
|
||||
$self->{pbot}->{logger}->log("Error in event handler: $@\n");
|
||||
#$self->{pbot}->{logger}->log("Removing handler.\n");
|
||||
#splice @{$self->{handlers}->{$event_type}}, $i--, 1;
|
||||
}
|
||||
return $ret if $ret;
|
||||
if ($@) {
|
||||
chomp $@;
|
||||
$self->{pbot}->{logger}->log("Error in event handler: $@\n");
|
||||
|
||||
#$self->{pbot}->{logger}->log("Removing handler.\n");
|
||||
#splice @{$self->{handlers}->{$event_type}}, $i--, 1;
|
||||
}
|
||||
return $ret if $ret;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
for (my $i = 0; $i < @{$self->{handlers}->{any}}; $i++) {
|
||||
my $ref = @{$self->{handlers}->{any}}[$i];
|
||||
my ($handler, $info) = ($ref->[0], $ref->[1]);
|
||||
$self->{pbot}->{logger}->log("Dispatching any to handler $info\n") if $self->{pbot}->{registry}->get_value('eventdispatcher', 'debug');
|
||||
for (my $i = 0; $i < @{$self->{handlers}->{any}}; $i++) {
|
||||
my $ref = @{$self->{handlers}->{any}}[$i];
|
||||
my ($handler, $info) = ($ref->[0], $ref->[1]);
|
||||
$self->{pbot}->{logger}->log("Dispatching any to handler $info\n") if $self->{pbot}->{registry}->get_value('eventdispatcher', 'debug');
|
||||
|
||||
eval {
|
||||
$ret = $handler->($event_type, $event_data);
|
||||
};
|
||||
eval { $ret = $handler->($event_type, $event_data); };
|
||||
|
||||
if ($@) {
|
||||
chomp $@;
|
||||
$self->{pbot}->{logger}->log("Error in event handler: $@\n");
|
||||
#$self->{pbot}->{logger}->log("Removing handler.\n");
|
||||
#splice @{$self->{handlers}->{any}}, $i--, 1;
|
||||
if ($@) {
|
||||
chomp $@;
|
||||
$self->{pbot}->{logger}->log("Error in event handler: $@\n");
|
||||
|
||||
#$self->{pbot}->{logger}->log("Removing handler.\n");
|
||||
#splice @{$self->{handlers}->{any}}, $i--, 1;
|
||||
}
|
||||
return $ret if $ret;
|
||||
}
|
||||
return $ret if $ret;
|
||||
}
|
||||
return $ret;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
1817
PBot/Factoids.pm
1817
PBot/Factoids.pm
File diff suppressed because it is too large
Load Diff
|
|
@ -26,89 +26,82 @@ use warnings; use strict;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->do_func(@_) }, 'func', 0);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->do_func(@_) }, 'func', 0);
|
||||
|
||||
$self->register(
|
||||
'help',
|
||||
{
|
||||
desc => 'provides help about a func',
|
||||
usage => 'help [func]',
|
||||
subref => sub { $self->func_help(@_) }
|
||||
}
|
||||
);
|
||||
$self->register(
|
||||
'help',
|
||||
{
|
||||
desc => 'provides help about a func',
|
||||
usage => 'help [func]',
|
||||
subref => sub { $self->func_help(@_) }
|
||||
}
|
||||
);
|
||||
|
||||
$self->register(
|
||||
'list',
|
||||
{
|
||||
desc => 'lists available funcs',
|
||||
usage => 'list [regex]',
|
||||
subref => sub { $self->func_list(@_) }
|
||||
}
|
||||
);
|
||||
$self->register(
|
||||
'list',
|
||||
{
|
||||
desc => 'lists available funcs',
|
||||
usage => 'list [regex]',
|
||||
subref => sub { $self->func_list(@_) }
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub register {
|
||||
my ($self, $func, $data) = @_;
|
||||
$self->{funcs}->{$func} = $data;
|
||||
my ($self, $func, $data) = @_;
|
||||
$self->{funcs}->{$func} = $data;
|
||||
}
|
||||
|
||||
sub unregister {
|
||||
my ($self, $func) = @_;
|
||||
delete $self->{funcs}->{$func};
|
||||
my ($self, $func) = @_;
|
||||
delete $self->{funcs}->{$func};
|
||||
}
|
||||
|
||||
sub do_func {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $func = $self->{pbot}->{interpreter}->shift_arg($stuff->{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};
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $func = $self->{pbot}->{interpreter}->shift_arg($stuff->{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};
|
||||
|
||||
my @params;
|
||||
while (my $param = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist})) {
|
||||
push @params, $param;
|
||||
}
|
||||
my @params;
|
||||
while (my $param = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist})) { push @params, $param; }
|
||||
|
||||
my $result = $self->{funcs}->{$func}->{subref}->(@params);
|
||||
$result =~ s/\x1/1/g;
|
||||
return $result;
|
||||
my $result = $self->{funcs}->{$func}->{subref}->(@params);
|
||||
$result =~ s/\x1/1/g;
|
||||
return $result;
|
||||
}
|
||||
|
||||
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};
|
||||
return "$func: $self->{funcs}->{$func}->{desc}; usage: $self->{funcs}->{$func}->{usage}";
|
||||
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};
|
||||
return "$func: $self->{funcs}->{$func}->{desc}; usage: $self->{funcs}->{$func}->{usage}";
|
||||
}
|
||||
|
||||
sub func_list {
|
||||
my ($self, $regex) = @_;
|
||||
$regex = '.*' if not defined $regex;
|
||||
my $result = eval {
|
||||
my $text = '';
|
||||
foreach my $func (sort keys %{$self->{funcs}}) {
|
||||
if ($func =~ m/$regex/i or $self->{funcs}->{$func}->{desc} =~ m/$regex/i) {
|
||||
$text .= "$func, ";
|
||||
}
|
||||
}
|
||||
my ($self, $regex) = @_;
|
||||
$regex = '.*' if not defined $regex;
|
||||
my $result = eval {
|
||||
my $text = '';
|
||||
foreach my $func (sort keys %{$self->{funcs}}) {
|
||||
if ($func =~ m/$regex/i or $self->{funcs}->{$func}->{desc} =~ m/$regex/i) { $text .= "$func, "; }
|
||||
}
|
||||
|
||||
$text =~ s/,\s+$//;
|
||||
if (not length $text) {
|
||||
if ($regex eq '.*') {
|
||||
$text = "No funcs yet.";
|
||||
} else {
|
||||
$text = "No matching func.";
|
||||
}
|
||||
}
|
||||
return "Available funcs: $text; see also: func help <keyword>";
|
||||
};
|
||||
$text =~ s/,\s+$//;
|
||||
if (not length $text) {
|
||||
if ($regex eq '.*') { $text = "No funcs yet."; }
|
||||
else { $text = "No matching func."; }
|
||||
}
|
||||
return "Available funcs: $text; see also: func help <keyword>";
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
my $error = $@;
|
||||
$error =~ s/at PBot.Functions.*$//;
|
||||
return "Error: $error\n";
|
||||
}
|
||||
return $result;
|
||||
if ($@) {
|
||||
my $error = $@;
|
||||
$error =~ s/at PBot.Functions.*$//;
|
||||
return "Error: $error\n";
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -19,218 +19,216 @@ use Text::Levenshtein qw(fastdistance);
|
|||
use JSON;
|
||||
|
||||
sub new {
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
Carp::croak("Missing pbot reference to " . __FILE__) unless exists $conf{pbot};
|
||||
$self->{pbot} = $conf{pbot};
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
Carp::croak("Missing pbot reference to " . __FILE__) unless exists $conf{pbot};
|
||||
$self->{pbot} = $conf{pbot};
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{name} = $conf{name} // 'hash object';
|
||||
$self->{filename} = $conf{filename} // Carp::carp("Missing filename to HashObject, will not be able to save to or load from file.");
|
||||
$self->{hash} = {};
|
||||
my ($self, %conf) = @_;
|
||||
$self->{name} = $conf{name} // 'hash object';
|
||||
$self->{filename} = $conf{filename} // Carp::carp("Missing filename to HashObject, will not be able to save to or load from file.");
|
||||
$self->{hash} = {};
|
||||
}
|
||||
|
||||
sub load {
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
if (@_) { $filename = shift; } else { $filename = $self->{filename}; }
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
if (@_) { $filename = shift; }
|
||||
else { $filename = $self->{filename}; }
|
||||
|
||||
$self->clear;
|
||||
$self->clear;
|
||||
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No $self->{name} filename specified -- skipping loading from file";
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Loading $self->{name} from $filename ...\n");
|
||||
|
||||
if (not open(FILE, "< $filename")) {
|
||||
Carp::carp "Skipping loading from file: Couldn't open $filename: $!\n";
|
||||
return;
|
||||
}
|
||||
|
||||
my $contents = do {
|
||||
local $/;
|
||||
<FILE>;
|
||||
};
|
||||
|
||||
$self->{hash} = decode_json $contents;
|
||||
close FILE;
|
||||
|
||||
# update existing entries to use _name to preserve case
|
||||
# and lowercase any non-lowercased entries
|
||||
foreach my $index (keys %{$self->{hash}}) {
|
||||
if (not exists $self->{hash}->{$index}->{_name}) {
|
||||
if (lc $index eq $index) {
|
||||
$self->{hash}->{$index}->{_name} = $index;
|
||||
} else {
|
||||
if (exists $self->{hash}->{lc $index}) {
|
||||
Carp::croak "Cannot update $self->{name} object $index; duplicate object found";
|
||||
}
|
||||
|
||||
my $data = delete $self->{hash}->{$index};
|
||||
$data->{_name} = $index;
|
||||
$self->{hash}->{lc $index} = $data;
|
||||
}
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No $self->{name} filename specified -- skipping loading from file";
|
||||
return;
|
||||
}
|
||||
|
||||
$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");
|
||||
return;
|
||||
}
|
||||
|
||||
my $contents = do {
|
||||
local $/;
|
||||
<FILE>;
|
||||
};
|
||||
|
||||
$self->{hash} = decode_json $contents;
|
||||
close FILE;
|
||||
|
||||
# update existing entries to use _name to preserve case
|
||||
# and lowercase any non-lowercased entries
|
||||
foreach my $index (keys %{$self->{hash}}) {
|
||||
if (not exists $self->{hash}->{$index}->{_name}) {
|
||||
if (lc $index eq $index) { $self->{hash}->{$index}->{_name} = $index; }
|
||||
else {
|
||||
if (exists $self->{hash}->{lc $index}) { Carp::croak "Cannot update $self->{name} object $index; duplicate object found"; }
|
||||
|
||||
my $data = delete $self->{hash}->{$index};
|
||||
$data->{_name} = $index;
|
||||
$self->{hash}->{lc $index} = $data;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub save {
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
if (@_) { $filename = shift; } else { $filename = $self->{filename}; }
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
if (@_) { $filename = shift; }
|
||||
else { $filename = $self->{filename}; }
|
||||
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No $self->{name} filename specified -- skipping saving to file.\n";
|
||||
return;
|
||||
}
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No $self->{name} filename specified -- skipping saving to file.\n";
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Saving $self->{name} to $filename\n");
|
||||
$self->{pbot}->{logger}->log("Saving $self->{name} to $filename\n");
|
||||
|
||||
my $json = JSON->new;
|
||||
my $json_text = $json->pretty->canonical->utf8->encode($self->{hash});
|
||||
my $json = JSON->new;
|
||||
my $json_text = $json->pretty->canonical->utf8->encode($self->{hash});
|
||||
|
||||
open(FILE, "> $filename") or die "Couldn't open $filename: $!\n";
|
||||
print FILE "$json_text\n";
|
||||
close(FILE);
|
||||
open(FILE, "> $filename") or die "Couldn't open $filename: $!\n";
|
||||
print FILE "$json_text\n";
|
||||
close(FILE);
|
||||
}
|
||||
|
||||
sub clear {
|
||||
my $self = shift;
|
||||
$self->{hash} = {};
|
||||
my $self = shift;
|
||||
$self->{hash} = {};
|
||||
}
|
||||
|
||||
sub levenshtein_matches {
|
||||
my ($self, $keyword) = @_;
|
||||
my $comma = '';
|
||||
my $result = "";
|
||||
my ($self, $keyword) = @_;
|
||||
my $comma = '';
|
||||
my $result = "";
|
||||
|
||||
foreach my $index (sort keys %{$self->{hash}}) {
|
||||
my $distance = fastdistance($keyword, $index);
|
||||
my $length = (length $keyword > length $index) ? length $keyword : length $index;
|
||||
foreach my $index (sort keys %{$self->{hash}}) {
|
||||
my $distance = fastdistance($keyword, $index);
|
||||
my $length = (length $keyword > length $index) ? length $keyword : length $index;
|
||||
|
||||
if ($length != 0 && $distance / $length < 0.50) {
|
||||
$result .= $comma . $index;
|
||||
$comma = ", ";
|
||||
if ($length != 0 && $distance / $length < 0.50) {
|
||||
$result .= $comma . $index;
|
||||
$comma = ", ";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$result =~ s/(.*), /$1 or /;
|
||||
$result = "none" if $comma eq '';
|
||||
return $result;
|
||||
$result =~ s/(.*), /$1 or /;
|
||||
$result = "none" if $comma eq '';
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub set {
|
||||
my ($self, $index, $key, $value, $dont_save) = @_;
|
||||
my $lc_index = lc $index;
|
||||
my ($self, $index, $key, $value, $dont_save) = @_;
|
||||
my $lc_index = lc $index;
|
||||
|
||||
if (not exists $self->{hash}->{$lc_index}) {
|
||||
my $result = "$self->{name}: $index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($index);
|
||||
return $result;
|
||||
}
|
||||
|
||||
if (not defined $key) {
|
||||
my $result = "[$self->{name}] $self->{hash}->{$lc_index}->{_name} keys: ";
|
||||
my $comma = '';
|
||||
foreach my $k (sort keys %{$self->{hash}->{$lc_index}}) {
|
||||
next if $k eq '_name';
|
||||
$result .= $comma . "$k => " . $self->{hash}->{$lc_index}->{$k};
|
||||
$comma = "; ";
|
||||
if (not exists $self->{hash}->{$lc_index}) {
|
||||
my $result = "$self->{name}: $index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($index);
|
||||
return $result;
|
||||
}
|
||||
$result .= "none" if ($comma eq '');
|
||||
return $result;
|
||||
}
|
||||
|
||||
if (not defined $value) {
|
||||
$value = $self->{hash}->{$lc_index}->{$key};
|
||||
} else {
|
||||
$self->{hash}->{$lc_index}->{$key} = $value;
|
||||
$self->save unless $dont_save;
|
||||
}
|
||||
return "[$self->{name}] $self->{hash}->{$lc_index}->{_name}: $key " . (defined $value ? "set to $value" : "is not set.");
|
||||
if (not defined $key) {
|
||||
my $result = "[$self->{name}] $self->{hash}->{$lc_index}->{_name} keys: ";
|
||||
my $comma = '';
|
||||
foreach my $k (sort keys %{$self->{hash}->{$lc_index}}) {
|
||||
next if $k eq '_name';
|
||||
$result .= $comma . "$k => " . $self->{hash}->{$lc_index}->{$k};
|
||||
$comma = "; ";
|
||||
}
|
||||
$result .= "none" if ($comma eq '');
|
||||
return $result;
|
||||
}
|
||||
|
||||
if (not defined $value) { $value = $self->{hash}->{$lc_index}->{$key}; }
|
||||
else {
|
||||
$self->{hash}->{$lc_index}->{$key} = $value;
|
||||
$self->save unless $dont_save;
|
||||
}
|
||||
return "[$self->{name}] $self->{hash}->{$lc_index}->{_name}: $key " . (defined $value ? "set to $value" : "is not set.");
|
||||
}
|
||||
|
||||
sub unset {
|
||||
my ($self, $index, $key) = @_;
|
||||
my $lc_index = lc $index;
|
||||
my ($self, $index, $key) = @_;
|
||||
my $lc_index = lc $index;
|
||||
|
||||
if (not exists $self->{hash}->{$lc_index}) {
|
||||
my $result = "$self->{name}: $index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($index);
|
||||
return $result;
|
||||
}
|
||||
if (not exists $self->{hash}->{$lc_index}) {
|
||||
my $result = "$self->{name}: $index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($index);
|
||||
return $result;
|
||||
}
|
||||
|
||||
if (defined delete $self->{hash}->{$lc_index}->{$key}) {
|
||||
$self->save;
|
||||
return "[$self->{name}] $self->{hash}->{$lc_index}->{_name}: $key unset.";
|
||||
} else {
|
||||
return "[$self->{name}] $self->{hash}->{$lc_index}->{_name}: $key does not exist.";
|
||||
}
|
||||
if (defined delete $self->{hash}->{$lc_index}->{$key}) {
|
||||
$self->save;
|
||||
return "[$self->{name}] $self->{hash}->{$lc_index}->{_name}: $key unset.";
|
||||
} else {
|
||||
return "[$self->{name}] $self->{hash}->{$lc_index}->{_name}: $key does not exist.";
|
||||
}
|
||||
}
|
||||
|
||||
sub exists {
|
||||
my ($self, $index, $data_index) = @_;
|
||||
return exists $self->{hash}->{lc $index} if not defined $data_index;
|
||||
return exists $self->{hash}->{lc $index}->{$data_index};
|
||||
my ($self, $index, $data_index) = @_;
|
||||
return exists $self->{hash}->{lc $index} if not defined $data_index;
|
||||
return exists $self->{hash}->{lc $index}->{$data_index};
|
||||
}
|
||||
|
||||
sub get_keys {
|
||||
my ($self, $index) = @_;
|
||||
return keys %{$self->{hash}} if not defined $index;
|
||||
return grep { $_ ne '_name' } keys %{$self->{hash}->{lc $index}};
|
||||
my ($self, $index) = @_;
|
||||
return keys %{$self->{hash}} if not defined $index;
|
||||
return grep { $_ ne '_name' } keys %{$self->{hash}->{lc $index}};
|
||||
}
|
||||
|
||||
sub get_data {
|
||||
my ($self, $index, $data_index) = @_;
|
||||
my $lc_index = lc $index;
|
||||
return undef if not exists $self->{hash}->{$lc_index};
|
||||
return $self->{hash}->{$lc_index} if not defined $data_index;
|
||||
return $self->{hash}->{$lc_index}->{$data_index};
|
||||
my ($self, $index, $data_index) = @_;
|
||||
my $lc_index = lc $index;
|
||||
return undef if not exists $self->{hash}->{$lc_index};
|
||||
return $self->{hash}->{$lc_index} if not defined $data_index;
|
||||
return $self->{hash}->{$lc_index}->{$data_index};
|
||||
}
|
||||
|
||||
sub add {
|
||||
my ($self, $index, $data, $dont_save) = @_;
|
||||
my $lc_index = lc $index;
|
||||
$data->{_name} = $index; # preserve case of index
|
||||
$self->{hash}->{$lc_index} = $data;
|
||||
$self->save unless $dont_save;
|
||||
return "$index added to $self->{name}.";
|
||||
my ($self, $index, $data, $dont_save) = @_;
|
||||
my $lc_index = lc $index;
|
||||
$data->{_name} = $index; # preserve case of index
|
||||
$self->{hash}->{$lc_index} = $data;
|
||||
$self->save unless $dont_save;
|
||||
return "$index added to $self->{name}.";
|
||||
}
|
||||
|
||||
sub remove {
|
||||
my ($self, $index, $data_index, $dont_save) = @_;
|
||||
my $lc_index = lc $index;
|
||||
my ($self, $index, $data_index, $dont_save) = @_;
|
||||
my $lc_index = lc $index;
|
||||
|
||||
if (not exists $self->{hash}->{$lc_index}) {
|
||||
my $result = "$self->{name}: $index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($lc_index);
|
||||
return $result;
|
||||
}
|
||||
|
||||
if (defined $data_index) {
|
||||
if (defined delete $self->{hash}->{$lc_index}->{$data_index}) {
|
||||
delete $self->{hash}->{$lc_index} if keys(%{$self->{hash}->{$lc_index}}) == 1;
|
||||
$self->save unless $dont_save;
|
||||
return "$self->{hash}->{$lc_index}->{_name}.$data_index removed from $self->{name}";
|
||||
} else {
|
||||
return "$self->{name}: $self->{hash}->{$lc_index}->{_name}.$data_index does not exist.";
|
||||
if (not exists $self->{hash}->{$lc_index}) {
|
||||
my $result = "$self->{name}: $index not found; similiar matches: ";
|
||||
$result .= $self->levenshtein_matches($lc_index);
|
||||
return $result;
|
||||
}
|
||||
}
|
||||
|
||||
my $data = delete $self->{hash}->{$lc_index};
|
||||
if (defined $data) {
|
||||
$self->save unless $dont_save;
|
||||
return "$data->{_name} removed from $self->{name}.";
|
||||
} else {
|
||||
return "$self->{name}: $data_index does not exist.";
|
||||
}
|
||||
if (defined $data_index) {
|
||||
if (defined delete $self->{hash}->{$lc_index}->{$data_index}) {
|
||||
delete $self->{hash}->{$lc_index} if keys(%{$self->{hash}->{$lc_index}}) == 1;
|
||||
$self->save unless $dont_save;
|
||||
return "$self->{hash}->{$lc_index}->{_name}.$data_index removed from $self->{name}";
|
||||
} else {
|
||||
return "$self->{name}: $self->{hash}->{$lc_index}->{_name}.$data_index does not exist.";
|
||||
}
|
||||
}
|
||||
|
||||
my $data = delete $self->{hash}->{$lc_index};
|
||||
if (defined $data) {
|
||||
$self->save unless $dont_save;
|
||||
return "$data->{_name} removed from $self->{name}.";
|
||||
} else {
|
||||
return "$self->{name}: $data_index does not exist.";
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
257
PBot/IRC.pm
257
PBot/IRC.pm
|
|
@ -13,23 +13,19 @@
|
|||
#####################################################################
|
||||
# $Id: IRC.pm,v 1.10 2004/04/30 18:02:51 jmuhlich Exp $
|
||||
|
||||
|
||||
package PBot::IRC; # pragma_ 2011/01/21
|
||||
package PBot::IRC; # pragma_ 2011/01/21
|
||||
|
||||
BEGIN { require 5.004; } # needs IO::* and $coderef->(@args) syntax
|
||||
|
||||
use PBot::IRC::Connection; # pragma_ 2011/01/21
|
||||
use PBot::IRC::EventQueue; # pragma_ 2011/01/21
|
||||
use PBot::IRC::Connection; # pragma_ 2011/01/21
|
||||
use PBot::IRC::EventQueue; # pragma_ 2011/01/21
|
||||
use IO::Select;
|
||||
use Carp;
|
||||
|
||||
use feature 'unicode_strings';
|
||||
|
||||
# grab the drop-in replacement for time() from Time::HiRes, if it's available
|
||||
BEGIN {
|
||||
Time::HiRes->import('time') if eval "require Time::HiRes";
|
||||
}
|
||||
|
||||
BEGIN { Time::HiRes->import('time') if eval "require Time::HiRes"; }
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
|
|
@ -37,42 +33,42 @@ use vars qw($VERSION);
|
|||
$VERSION = "0.79";
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $proto = shift;
|
||||
|
||||
my $self = {
|
||||
'_conn' => [],
|
||||
'_connhash' => {},
|
||||
'_error' => IO::Select->new(),
|
||||
'_debug' => 0,
|
||||
'_schedulequeue' => new PBot::IRC::EventQueue(), # pragma_ 2011/01/21
|
||||
'_outputqueue' => new PBot::IRC::EventQueue(), # pragma_ 2011/01/21
|
||||
'_read' => IO::Select->new(),
|
||||
'_timeout' => 1,
|
||||
'_write' => IO::Select->new(),
|
||||
};
|
||||
my $self = {
|
||||
'_conn' => [],
|
||||
'_connhash' => {},
|
||||
'_error' => IO::Select->new(),
|
||||
'_debug' => 0,
|
||||
'_schedulequeue' => new PBot::IRC::EventQueue(), # pragma_ 2011/01/21
|
||||
'_outputqueue' => new PBot::IRC::EventQueue(), # pragma_ 2011/01/21
|
||||
'_read' => IO::Select->new(),
|
||||
'_timeout' => 1,
|
||||
'_write' => IO::Select->new(),
|
||||
};
|
||||
|
||||
bless $self, $proto;
|
||||
bless $self, $proto;
|
||||
|
||||
return $self;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub outputqueue {
|
||||
my $self = shift;
|
||||
return $self->{_outputqueue};
|
||||
my $self = shift;
|
||||
return $self->{_outputqueue};
|
||||
}
|
||||
|
||||
sub schedulequeue {
|
||||
my $self = shift;
|
||||
return $self->{_schedulequeue};
|
||||
my $self = shift;
|
||||
return $self->{_schedulequeue};
|
||||
}
|
||||
|
||||
# Front end to addfh(), below. Sets it to read by default.
|
||||
# Takes at least 1 arg: an object to add to the select loop.
|
||||
# (optional) a flag string to pass to addfh() (see below)
|
||||
sub addconn {
|
||||
my ($self, $conn) = @_;
|
||||
my ($self, $conn) = @_;
|
||||
|
||||
$self->addfh( $conn->socket, $conn->can('parse'), ($_[2] || 'r'), $conn);
|
||||
$self->addfh($conn->socket, $conn->can('parse'), ($_[2] || 'r'), $conn);
|
||||
}
|
||||
|
||||
# Adds a filehandle to the select loop. Tasty and flavorful.
|
||||
|
|
@ -83,197 +79,182 @@ sub addconn {
|
|||
# except that you can combine flags (i.e., "rw").
|
||||
# (optional) an object that the coderef is a method of
|
||||
sub addfh {
|
||||
my ($self, $fh, $code, $flag, $obj) = @_;
|
||||
my ($letter);
|
||||
my ($self, $fh, $code, $flag, $obj) = @_;
|
||||
my ($letter);
|
||||
|
||||
die "Not enough arguments to IRC->addfh()" unless defined $code;
|
||||
die "Not enough arguments to IRC->addfh()" unless defined $code;
|
||||
|
||||
if ($flag) {
|
||||
foreach $letter (split(//, lc $flag)) {
|
||||
if ($letter eq 'r') {
|
||||
$self->{_read}->add( $fh );
|
||||
} elsif ($letter eq 'w') {
|
||||
$self->{_write}->add( $fh );
|
||||
} elsif ($letter eq 'e') {
|
||||
$self->{_error}->add( $fh );
|
||||
}
|
||||
if ($flag) {
|
||||
foreach $letter (split(//, lc $flag)) {
|
||||
if ($letter eq 'r') { $self->{_read}->add($fh); }
|
||||
elsif ($letter eq 'w') { $self->{_write}->add($fh); }
|
||||
elsif ($letter eq 'e') { $self->{_error}->add($fh); }
|
||||
}
|
||||
} else {
|
||||
$self->{_read}->add($fh);
|
||||
}
|
||||
} else {
|
||||
$self->{_read}->add( $fh );
|
||||
}
|
||||
|
||||
$self->{_connhash}->{$fh} = [ $code, $obj ];
|
||||
$self->{_connhash}->{$fh} = [$code, $obj];
|
||||
}
|
||||
|
||||
# Sets or returns the debugging flag for this object.
|
||||
# Takes 1 optional arg: a new boolean value for the flag.
|
||||
sub debug {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
if (@_) {
|
||||
$self->{_debug} = $_[0];
|
||||
}
|
||||
return $self->{_debug};
|
||||
if (@_) { $self->{_debug} = $_[0]; }
|
||||
return $self->{_debug};
|
||||
}
|
||||
|
||||
# Goes through one iteration of the main event loop. Useful for integrating
|
||||
# other event-based systems (Tk, etc.) with Net::IRC.
|
||||
# Takes no args.
|
||||
sub do_one_loop {
|
||||
my $self = shift;
|
||||
my ($ev, $sock, $time, $nexttimer, $timeout);
|
||||
my (undef, undef, undef, $caller) = caller(1);
|
||||
my $self = shift;
|
||||
my ($ev, $sock, $time, $nexttimer, $timeout);
|
||||
my (undef, undef, undef, $caller) = caller(1);
|
||||
|
||||
$time = time(); # no use calling time() all the time.
|
||||
$time = time(); # no use calling time() all the time.
|
||||
|
||||
if (!$self->outputqueue->is_empty) {
|
||||
my $outputevent = undef;
|
||||
while (defined($outputevent = $self->outputqueue->head)
|
||||
&& $outputevent->time <= $time) {
|
||||
$outputevent = $self->outputqueue->dequeue();
|
||||
$outputevent->content->{coderef}->(@{$outputevent->content->{args}});
|
||||
if (!$self->outputqueue->is_empty) {
|
||||
my $outputevent = undef;
|
||||
while (defined($outputevent = $self->outputqueue->head) && $outputevent->time <= $time) {
|
||||
$outputevent = $self->outputqueue->dequeue();
|
||||
$outputevent->content->{coderef}->(@{$outputevent->content->{args}});
|
||||
}
|
||||
$nexttimer = $self->outputqueue->head->time if !$self->outputqueue->is_empty();
|
||||
}
|
||||
$nexttimer = $self->outputqueue->head->time if !$self->outputqueue->is_empty();
|
||||
}
|
||||
|
||||
# we don't want to bother waiting on input or running
|
||||
# scheduled events if we're just flushing the output queue
|
||||
# so we bail out here
|
||||
return if $caller eq 'PBot::IRC::flush_output_queue'; # pragma_ 2011/01/21
|
||||
# we don't want to bother waiting on input or running
|
||||
# scheduled events if we're just flushing the output queue
|
||||
# so we bail out here
|
||||
return if $caller eq 'PBot::IRC::flush_output_queue'; # pragma_ 2011/01/21
|
||||
|
||||
# Check the queue for scheduled events to run.
|
||||
if (!$self->schedulequeue->is_empty) {
|
||||
my $scheduledevent = undef;
|
||||
while (defined($scheduledevent = $self->schedulequeue->head) && $scheduledevent->time <= $time) {
|
||||
$scheduledevent = $self->schedulequeue->dequeue();
|
||||
$scheduledevent->content->{coderef}->(@{$scheduledevent->content->{args}});
|
||||
# Check the queue for scheduled events to run.
|
||||
if (!$self->schedulequeue->is_empty) {
|
||||
my $scheduledevent = undef;
|
||||
while (defined($scheduledevent = $self->schedulequeue->head) && $scheduledevent->time <= $time) {
|
||||
$scheduledevent = $self->schedulequeue->dequeue();
|
||||
$scheduledevent->content->{coderef}->(@{$scheduledevent->content->{args}});
|
||||
}
|
||||
if (!$self->schedulequeue->is_empty() && $nexttimer && $self->schedulequeue->head->time < $nexttimer) { $nexttimer = $self->schedulequeue->head->time; }
|
||||
}
|
||||
if (!$self->schedulequeue->is_empty()
|
||||
&& $nexttimer
|
||||
&& $self->schedulequeue->head->time < $nexttimer) {
|
||||
$nexttimer = $self->schedulequeue->head->time;
|
||||
|
||||
# Block until input arrives, then hand the filehandle over to the
|
||||
# user-supplied coderef. Look! It's a freezer full of government cheese!
|
||||
|
||||
if ($nexttimer) { $timeout = $nexttimer - $time < $self->{_timeout} ? $nexttimer - $time : $self->{_timeout}; }
|
||||
else { $timeout = $self->{_timeout}; }
|
||||
foreach $ev (
|
||||
IO::Select->select(
|
||||
$self->{_read},
|
||||
$self->{_write},
|
||||
$self->{_error},
|
||||
$timeout
|
||||
)
|
||||
)
|
||||
{
|
||||
foreach $sock (@{$ev}) {
|
||||
my $conn = $self->{_connhash}->{$sock};
|
||||
$conn or next;
|
||||
|
||||
# $conn->[0] is a code reference to a handler sub.
|
||||
# $conn->[1] is optionally an object which the
|
||||
# handler sub may be a method of.
|
||||
|
||||
$conn->[0]->($conn->[1] ? ($conn->[1], $sock) : $sock);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Block until input arrives, then hand the filehandle over to the
|
||||
# user-supplied coderef. Look! It's a freezer full of government cheese!
|
||||
|
||||
if ($nexttimer) {
|
||||
$timeout = $nexttimer - $time < $self->{_timeout}
|
||||
? $nexttimer - $time : $self->{_timeout};
|
||||
} else {
|
||||
$timeout = $self->{_timeout};
|
||||
}
|
||||
foreach $ev (IO::Select->select($self->{_read},
|
||||
$self->{_write},
|
||||
$self->{_error},
|
||||
$timeout)) {
|
||||
foreach $sock (@{$ev}) {
|
||||
my $conn = $self->{_connhash}->{$sock};
|
||||
$conn or next;
|
||||
|
||||
# $conn->[0] is a code reference to a handler sub.
|
||||
# $conn->[1] is optionally an object which the
|
||||
# handler sub may be a method of.
|
||||
|
||||
$conn->[0]->($conn->[1] ? ($conn->[1], $sock) : $sock);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub flush_output_queue {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
while (!$self->outputqueue->is_empty()) {
|
||||
$self->do_one_loop();
|
||||
}
|
||||
while (!$self->outputqueue->is_empty()) { $self->do_one_loop(); }
|
||||
}
|
||||
|
||||
# Creates and returns a new Connection object.
|
||||
# Any args here get passed to Connection->connect().
|
||||
sub newconn {
|
||||
my $self = shift;
|
||||
my $conn = PBot::IRC::Connection->new($self, @_); # pragma_ 2011/01/21
|
||||
my $self = shift;
|
||||
my $conn = PBot::IRC::Connection->new($self, @_); # pragma_ 2011/01/21
|
||||
|
||||
return if $conn->error;
|
||||
return $conn;
|
||||
return if $conn->error;
|
||||
return $conn;
|
||||
}
|
||||
|
||||
# Takes the args passed to it by Connection->schedule()... see it for details.
|
||||
sub enqueue_scheduled_event {
|
||||
my $self = shift;
|
||||
my $time = shift;
|
||||
my $coderef = shift;
|
||||
my @args = @_;
|
||||
my $self = shift;
|
||||
my $time = shift;
|
||||
my $coderef = shift;
|
||||
my @args = @_;
|
||||
|
||||
return $self->schedulequeue->enqueue($time, { coderef => $coderef, args => \@args });
|
||||
return $self->schedulequeue->enqueue($time, {coderef => $coderef, args => \@args});
|
||||
}
|
||||
|
||||
# Takes a scheduled event ID to remove from the queue.
|
||||
# Returns the deleted coderef, if you actually care.
|
||||
sub dequeue_scheduled_event {
|
||||
my ($self, $id) = @_;
|
||||
$self->schedulequeue->dequeue($id);
|
||||
my ($self, $id) = @_;
|
||||
$self->schedulequeue->dequeue($id);
|
||||
}
|
||||
|
||||
# Takes the args passed to it by Connection->schedule()... see it for details.
|
||||
sub enqueue_output_event {
|
||||
my $self = shift;
|
||||
my $time = shift;
|
||||
my $coderef = shift;
|
||||
my @args = @_;
|
||||
my $self = shift;
|
||||
my $time = shift;
|
||||
my $coderef = shift;
|
||||
my @args = @_;
|
||||
|
||||
return $self->outputqueue->enqueue($time, { coderef => $coderef, args => \@args });
|
||||
return $self->outputqueue->enqueue($time, {coderef => $coderef, args => \@args});
|
||||
}
|
||||
|
||||
# Takes a scheduled event ID to remove from the queue.
|
||||
# Returns the deleted coderef, if you actually care.
|
||||
sub dequeue_output_event {
|
||||
my ($self, $id) = @_;
|
||||
$self->outputqueue->dequeue($id);
|
||||
my ($self, $id) = @_;
|
||||
$self->outputqueue->dequeue($id);
|
||||
}
|
||||
|
||||
# Front-end for removefh(), below.
|
||||
# Takes 1 arg: a Connection (or DCC or whatever) to remove.
|
||||
sub removeconn {
|
||||
my ($self, $conn) = @_;
|
||||
my ($self, $conn) = @_;
|
||||
|
||||
$self->removefh( $conn->socket );
|
||||
$self->removefh($conn->socket);
|
||||
}
|
||||
|
||||
# Given a filehandle, removes it from all select lists. You get the picture.
|
||||
sub removefh {
|
||||
my ($self, $fh) = @_;
|
||||
my ($self, $fh) = @_;
|
||||
|
||||
$self->{_read}->remove( $fh );
|
||||
$self->{_write}->remove( $fh );
|
||||
$self->{_error}->remove( $fh );
|
||||
delete $self->{_connhash}->{$fh};
|
||||
$self->{_read}->remove($fh);
|
||||
$self->{_write}->remove($fh);
|
||||
$self->{_error}->remove($fh);
|
||||
delete $self->{_connhash}->{$fh};
|
||||
}
|
||||
|
||||
# Begin the main loop. Wheee. Hope you remembered to set up your handlers
|
||||
# first... (takes no args, of course)
|
||||
sub start {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
while (1) {
|
||||
$self->do_one_loop();
|
||||
}
|
||||
while (1) { $self->do_one_loop(); }
|
||||
}
|
||||
|
||||
# Sets or returns the current timeout, in seconds, for the select loop.
|
||||
# Takes 1 optional arg: the new value for the timeout, in seconds.
|
||||
# Fractional timeout values are just fine, as per the core select().
|
||||
sub timeout {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
if (@_) { $self->{_timeout} = $_[0] }
|
||||
return $self->{_timeout};
|
||||
if (@_) { $self->{_timeout} = $_[0] }
|
||||
return $self->{_timeout};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
716
PBot/IRC/DCC.pm
716
PBot/IRC/DCC.pm
|
|
@ -13,7 +13,7 @@
|
|||
#####################################################################
|
||||
# $Id: DCC.pm,v 1.1.1.1 2002/11/14 17:32:15 jmuhlich Exp $
|
||||
|
||||
package PBot::IRC::DCC; # pragma_ 2011/21/01
|
||||
package PBot::IRC::DCC; # pragma_ 2011/21/01
|
||||
|
||||
use strict;
|
||||
|
||||
|
|
@ -32,52 +32,37 @@ use feature 'unicode_strings';
|
|||
# \merlyn: but he seems like a nice trucker guy...
|
||||
# archon: you offered to shower with a random guy?
|
||||
|
||||
|
||||
# Methods that can be shared between the various DCC classes.
|
||||
package PBot::IRC::DCC::Connection; # pragma_ 2011/21/01
|
||||
package PBot::IRC::DCC::Connection; # pragma_ 2011/21/01
|
||||
|
||||
use Carp;
|
||||
use Socket; # need inet_ntoa...
|
||||
use Socket; # need inet_ntoa...
|
||||
use strict;
|
||||
|
||||
sub fixaddr {
|
||||
my ($address) = @_;
|
||||
|
||||
chomp $address; # just in case, sigh.
|
||||
if ($address =~ /^\d+$/) {
|
||||
return inet_ntoa(pack "N", $address);
|
||||
} elsif ($address =~ /^[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}$/) {
|
||||
return $address;
|
||||
} elsif ($address =~ tr/a-zA-Z//) { # Whee! Obfuscation!
|
||||
chomp $address; # just in case, sigh.
|
||||
if ($address =~ /^\d+$/) { return inet_ntoa(pack "N", $address); }
|
||||
elsif ($address =~ /^[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}$/) { return $address; }
|
||||
elsif ($address =~ tr/a-zA-Z//) { # Whee! Obfuscation!
|
||||
return inet_ntoa(((gethostbyname($address))[4])[0]);
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
sub bytes_in {
|
||||
return shift->{_bin};
|
||||
}
|
||||
sub bytes_in { return shift->{_bin}; }
|
||||
|
||||
sub bytes_out {
|
||||
return shift->{_bout};
|
||||
}
|
||||
sub bytes_out { return shift->{_bout}; }
|
||||
|
||||
sub nick {
|
||||
return shift->{_nick};
|
||||
}
|
||||
sub nick { return shift->{_nick}; }
|
||||
|
||||
sub socket {
|
||||
return shift->{_socket};
|
||||
}
|
||||
sub socket { return shift->{_socket}; }
|
||||
|
||||
sub time {
|
||||
return time - shift->{_time};
|
||||
}
|
||||
sub time { return time - shift->{_time}; }
|
||||
|
||||
sub debug {
|
||||
return shift->{_debug};
|
||||
}
|
||||
sub debug { return shift->{_debug}; }
|
||||
|
||||
# Changes here 1998-04-01 by MJD
|
||||
# Optional third argument `$block'.
|
||||
|
|
@ -88,54 +73,60 @@ sub _getline {
|
|||
my $frag = $self->{_frag};
|
||||
|
||||
if (defined $sock->recv($input, 10240)) {
|
||||
$frag .= $input;
|
||||
if (length($frag) > 0) {
|
||||
$frag .= $input;
|
||||
if (length($frag) > 0) {
|
||||
|
||||
warn "Got ". length($frag) ." bytes from $sock\n"
|
||||
if $self->{_debug};
|
||||
warn "Got " . length($frag) . " bytes from $sock\n" if $self->{_debug};
|
||||
|
||||
if ($block) { # Block mode (GET)
|
||||
return $input;
|
||||
if ($block) { # Block mode (GET)
|
||||
return $input;
|
||||
|
||||
} else { # Line mode (CHAT)
|
||||
# We're returning \n's 'cause DCC's need 'em
|
||||
my @lines = split /\012/, $frag, -1;
|
||||
$lines[-1] .= "\012";
|
||||
$self->{_frag} = ($frag !~ /\012$/) ? pop @lines : '';
|
||||
return (@lines);
|
||||
}
|
||||
}
|
||||
else {
|
||||
# um, if we can read, i say we should read more than 0
|
||||
# besides, recv isn't returning undef on closed
|
||||
# sockets. getting rid of this connection...
|
||||
} else { # Line mode (CHAT)
|
||||
# We're returning \n's 'cause DCC's need 'em
|
||||
my @lines = split /\012/, $frag, -1;
|
||||
$lines[-1] .= "\012";
|
||||
$self->{_frag} = ($frag !~ /\012$/) ? pop @lines : '';
|
||||
return (@lines);
|
||||
}
|
||||
} else {
|
||||
|
||||
warn "recv() received 0 bytes in _getline, closing connection.\n"
|
||||
if $self->{_debug};
|
||||
# um, if we can read, i say we should read more than 0
|
||||
# besides, recv isn't returning undef on closed
|
||||
# sockets. getting rid of this connection...
|
||||
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}));
|
||||
$self->{_parent}->parent->removefh($sock);
|
||||
$self->{_socket}->close;
|
||||
$self->{_fh}->close if $self->{_fh};
|
||||
return;
|
||||
}
|
||||
warn "recv() received 0 bytes in _getline, closing connection.\n" if $self->{_debug};
|
||||
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}
|
||||
)
|
||||
);
|
||||
$self->{_parent}->parent->removefh($sock);
|
||||
$self->{_socket}->close;
|
||||
$self->{_fh}->close if $self->{_fh};
|
||||
return;
|
||||
}
|
||||
} else {
|
||||
# Error, lets scrap this connection
|
||||
|
||||
warn "recv() returned undef, socket error in _getline()\n"
|
||||
if $self->{_debug};
|
||||
# Error, lets scrap this connection
|
||||
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}));
|
||||
$self->{_parent}->parent->removefh($sock);
|
||||
$self->{_socket}->close;
|
||||
$self->{_fh}->close if $self->{_fh};
|
||||
return;
|
||||
warn "recv() returned undef, socket error in _getline()\n" if $self->{_debug};
|
||||
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}
|
||||
)
|
||||
);
|
||||
$self->{_parent}->parent->removefh($sock);
|
||||
$self->{_socket}->close;
|
||||
$self->{_fh}->close if $self->{_fh};
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -146,20 +137,22 @@ sub DESTROY {
|
|||
# live. Duplicate dcc_close events would be a Bad Thing.
|
||||
|
||||
if ($self->{_socket}->opened) {
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}));
|
||||
$self->{_socket}->close;
|
||||
close $self->{_fh} if $self->{_fh};
|
||||
$self->{_parent}->{_parent}->parent->removeconn($self);
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}
|
||||
)
|
||||
);
|
||||
$self->{_socket}->close;
|
||||
close $self->{_fh} if $self->{_fh};
|
||||
$self->{_parent}->{_parent}->parent->removeconn($self);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub peer {
|
||||
return ( $_[0]->{_nick}, "DCC " . $_[0]->{_type} );
|
||||
}
|
||||
sub peer { return ($_[0]->{_nick}, "DCC " . $_[0]->{_type}); }
|
||||
|
||||
# -- #perl was here! --
|
||||
# orev: hehe...
|
||||
|
|
@ -168,48 +161,56 @@ sub peer {
|
|||
# tmtowtdi: \merlyn will be hacked to death by a psycho
|
||||
# archon: yeah, but with is much more amusing
|
||||
|
||||
|
||||
# Connection handling GETs
|
||||
package PBot::IRC::DCC::GET; # pragma_ 2011/21/01
|
||||
package PBot::IRC::DCC::GET; # pragma_ 2011/21/01
|
||||
|
||||
use IO::Socket;
|
||||
use Carp;
|
||||
use strict;
|
||||
|
||||
@PBot::IRC::DCC::GET::ISA = qw(Net::IRC::DCC::Connection); # pragma_ 2011/21/01
|
||||
@PBot::IRC::DCC::GET::ISA = qw(Net::IRC::DCC::Connection); # pragma_ 2011/21/01
|
||||
|
||||
sub new {
|
||||
|
||||
my ($class, $container, $nick, $address,
|
||||
$port, $size, $filename, $handle, $offset) = @_;
|
||||
my (
|
||||
$class, $container, $nick, $address,
|
||||
$port, $size, $filename, $handle, $offset
|
||||
) = @_;
|
||||
my ($sock, $fh);
|
||||
|
||||
# get the address into a dotted quad
|
||||
$address = &PBot::IRC::DCC::Connection::fixaddr($address); # pragma_ 2011/21/01
|
||||
$address = &PBot::IRC::DCC::Connection::fixaddr($address); # pragma_ 2011/21/01
|
||||
return if $port < 1024 or not defined $address or $size < 1;
|
||||
|
||||
$fh = defined $handle ? $handle : IO::File->new(">$filename");
|
||||
|
||||
unless (defined $fh) {
|
||||
carp "Can't open $filename for writing: $!";
|
||||
$sock = new IO::Socket::INET( Proto => "tcp",
|
||||
PeerAddr => "$address:$port" ) and
|
||||
$sock->close();
|
||||
$sock = new IO::Socket::INET(
|
||||
Proto => "tcp",
|
||||
PeerAddr => "$address:$port"
|
||||
) and $sock->close();
|
||||
return;
|
||||
}
|
||||
|
||||
binmode $fh; # I love this next line. :-)
|
||||
binmode $fh; # I love this next line. :-)
|
||||
ref $fh eq 'GLOB' ? select((select($fh), $|++)[0]) : $fh->autoflush(1);
|
||||
|
||||
$sock = new IO::Socket::INET( Proto => "tcp",
|
||||
PeerAddr => "$address:$port" );
|
||||
$sock = new IO::Socket::INET(
|
||||
Proto => "tcp",
|
||||
PeerAddr => "$address:$port"
|
||||
);
|
||||
|
||||
if (defined $sock) {
|
||||
$container->handler(PBot::IRC::Event->new('dcc_open', # pragma_ 2011/21/01
|
||||
$nick,
|
||||
$sock,
|
||||
'get',
|
||||
'get', $sock));
|
||||
$container->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_open', # pragma_ 2011/21/01
|
||||
$nick,
|
||||
$sock,
|
||||
'get',
|
||||
'get', $sock
|
||||
)
|
||||
);
|
||||
|
||||
} else {
|
||||
carp "Can't connect to $address: $!";
|
||||
|
|
@ -220,20 +221,20 @@ sub new {
|
|||
$sock->autoflush(1);
|
||||
|
||||
my $self = {
|
||||
_bin => defined $offset ? $offset : 0, # bytes recieved so far
|
||||
_bout => 0, # Bytes we've sent
|
||||
_connected => 1,
|
||||
_debug => $container->debug,
|
||||
_fh => $fh, # FileHandle we will be writing to.
|
||||
_filename => $filename,
|
||||
_frag => '',
|
||||
_nick => $nick, # Nick of person on other end
|
||||
_parent => $container,
|
||||
_size => $size, # Expected size of file
|
||||
_socket => $sock, # Socket we're reading from
|
||||
_time => time,
|
||||
_type => 'GET',
|
||||
};
|
||||
_bin => defined $offset ? $offset : 0, # bytes recieved so far
|
||||
_bout => 0, # Bytes we've sent
|
||||
_connected => 1,
|
||||
_debug => $container->debug,
|
||||
_fh => $fh, # FileHandle we will be writing to.
|
||||
_filename => $filename,
|
||||
_frag => '',
|
||||
_nick => $nick, # Nick of person on other end
|
||||
_parent => $container,
|
||||
_size => $size, # Expected size of file
|
||||
_socket => $sock, # Socket we're reading from
|
||||
_time => time,
|
||||
_type => 'GET',
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
|
|
@ -255,31 +256,38 @@ sub parse {
|
|||
|
||||
next unless defined $line;
|
||||
unless (print {$self->{_fh}} $line) {
|
||||
carp ("Error writing to " . $self->{_filename} . ": $!");
|
||||
close $self->{_fh};
|
||||
$self->{_parent}->parent->removeconn($self);
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}));
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
carp("Error writing to " . $self->{_filename} . ": $!");
|
||||
close $self->{_fh};
|
||||
$self->{_parent}->parent->removeconn($self);
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}
|
||||
)
|
||||
);
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{_bin} += length($line);
|
||||
|
||||
|
||||
# confirm the packet we've just recieved
|
||||
unless ( $self->{_socket}->send( pack("N", $self->{_bin}) ) ) {
|
||||
carp "Error writing to DCC GET socket: $!";
|
||||
close $self->{_fh};
|
||||
$self->{_parent}->parent->removeconn($self);
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}));
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
unless ($self->{_socket}->send(pack("N", $self->{_bin}))) {
|
||||
carp "Error writing to DCC GET socket: $!";
|
||||
close $self->{_fh};
|
||||
$self->{_parent}->parent->removeconn($self);
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}
|
||||
)
|
||||
);
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{_bout} += 4;
|
||||
|
|
@ -287,40 +295,48 @@ sub parse {
|
|||
# The file is done.
|
||||
# If we close the socket, the select loop gets screwy because
|
||||
# it won't remove its reference to the socket.
|
||||
if ( $self->{_size} and $self->{_size} <= $self->{_bin} ) {
|
||||
if ($self->{_size} and $self->{_size} <= $self->{_bin}) {
|
||||
close $self->{_fh};
|
||||
$self->{_parent}->parent->removeconn($self);
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}));
|
||||
$self->{_socket}->close;
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}
|
||||
)
|
||||
);
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_update', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self,
|
||||
$self->{_type},
|
||||
$self ));
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_update', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self,
|
||||
$self->{_type},
|
||||
$self
|
||||
)
|
||||
);
|
||||
}
|
||||
|
||||
sub filename {
|
||||
return shift->{_filename};
|
||||
}
|
||||
sub filename { return shift->{_filename}; }
|
||||
|
||||
sub size {
|
||||
return shift->{_size};
|
||||
}
|
||||
sub size { return shift->{_size}; }
|
||||
|
||||
sub close {
|
||||
my ($self, $sock) = @_;
|
||||
$self->{_fh}->close;
|
||||
$self->{_parent}->parent->removeconn($self);
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}));
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}
|
||||
)
|
||||
);
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
}
|
||||
|
|
@ -335,10 +351,9 @@ sub close {
|
|||
# Silmaril: AWWWWwwww yeeeaAAHH.
|
||||
# archon: waka chica waka chica
|
||||
|
||||
|
||||
# Connection handling SENDs
|
||||
package PBot::IRC::DCC::SEND; # pragma_ 2011/21/01
|
||||
@PBot::IRC::DCC::SEND::ISA = qw(Net::IRC::DCC::Connection); # pragma_ 2011/21/01
|
||||
package PBot::IRC::DCC::SEND; # pragma_ 2011/21/01
|
||||
@PBot::IRC::DCC::SEND::ISA = qw(Net::IRC::DCC::Connection); # pragma_ 2011/21/01
|
||||
|
||||
use IO::File;
|
||||
use IO::Socket;
|
||||
|
|
@ -359,7 +374,7 @@ sub new {
|
|||
|
||||
unless (defined $fh) {
|
||||
carp "Couldn't open $filename for reading: $!";
|
||||
return;
|
||||
return;
|
||||
}
|
||||
|
||||
binmode $fh;
|
||||
|
|
@ -367,8 +382,10 @@ sub new {
|
|||
$size = $fh->tell;
|
||||
$fh->seek(0, SEEK_SET);
|
||||
|
||||
$sock = new IO::Socket::INET( Proto => "tcp",
|
||||
Listen => 1);
|
||||
$sock = new IO::Socket::INET(
|
||||
Proto => "tcp",
|
||||
Listen => 1
|
||||
);
|
||||
|
||||
unless (defined $sock) {
|
||||
carp "Couldn't open DCC SEND socket: $!";
|
||||
|
|
@ -376,31 +393,33 @@ sub new {
|
|||
return;
|
||||
}
|
||||
|
||||
$container->ctcp('DCC SEND', $nick, $filename,
|
||||
unpack("N",inet_aton($container->hostname())),
|
||||
$sock->sockport(), $size);
|
||||
$container->ctcp(
|
||||
'DCC SEND', $nick, $filename,
|
||||
unpack("N", inet_aton($container->hostname())),
|
||||
$sock->sockport(), $size
|
||||
);
|
||||
|
||||
$sock->autoflush(1);
|
||||
|
||||
my $self = {
|
||||
_bin => 0, # Bytes we've recieved thus far
|
||||
_blocksize => $blocksize,
|
||||
_bout => 0, # Bytes we've sent
|
||||
_debug => $container->debug,
|
||||
_fh => $fh, # FileHandle we will be reading from.
|
||||
_filename => $filename,
|
||||
_frag => '',
|
||||
_nick => $nick,
|
||||
_parent => $container,
|
||||
_size => $size, # Size of file
|
||||
_socket => $sock, # Socket we're writing to
|
||||
_time => 0, # This gets set by Accept->parse()
|
||||
_type => 'SEND',
|
||||
_bin => 0, # Bytes we've recieved thus far
|
||||
_blocksize => $blocksize,
|
||||
_bout => 0, # Bytes we've sent
|
||||
_debug => $container->debug,
|
||||
_fh => $fh, # FileHandle we will be reading from.
|
||||
_filename => $filename,
|
||||
_frag => '',
|
||||
_nick => $nick,
|
||||
_parent => $container,
|
||||
_size => $size, # Size of file
|
||||
_socket => $sock, # Socket we're writing to
|
||||
_time => 0, # This gets set by Accept->parse()
|
||||
_type => 'SEND',
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
$sock = PBot::IRC::DCC::Accept->new($sock, $self); # pragma_ 2011/21/01
|
||||
$sock = PBot::IRC::DCC::Accept->new($sock, $self); # pragma_ 2011/21/01
|
||||
|
||||
unless (defined $sock) {
|
||||
carp "Error in accept: $!";
|
||||
|
|
@ -431,35 +450,44 @@ sub parse {
|
|||
$self->{_bin} += 4;
|
||||
|
||||
unless (defined $size) {
|
||||
# Dang! The other end unexpectedly canceled.
|
||||
carp (($self->peer)[1] . " connection to " .
|
||||
($self->peer)[0] . " lost");
|
||||
$self->{_fh}->close;
|
||||
$self->{_parent}->parent->removefh($sock);
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}));
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
|
||||
# Dang! The other end unexpectedly canceled.
|
||||
carp(($self->peer)[1] . " connection to " . ($self->peer)[0] . " lost");
|
||||
$self->{_fh}->close;
|
||||
$self->{_parent}->parent->removefh($sock);
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}
|
||||
)
|
||||
);
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
}
|
||||
|
||||
$size = unpack("N", $size);
|
||||
|
||||
if ($size >= $self->{_size}) {
|
||||
|
||||
if ($self->{_debug}) {
|
||||
warn "Other end acknowledged entire file ($size >= ",
|
||||
$self->{_size}, ")";
|
||||
}
|
||||
if ($self->{_debug}) {
|
||||
warn "Other end acknowledged entire file ($size >= ",
|
||||
$self->{_size}, ")";
|
||||
}
|
||||
|
||||
# they've acknowledged the whole file, we outtie
|
||||
$self->{_fh}->close;
|
||||
$self->{_parent}->parent->removeconn($self);
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}));
|
||||
$self->{_socket}->close;
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}
|
||||
)
|
||||
);
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
}
|
||||
|
||||
|
|
@ -467,43 +495,51 @@ sub parse {
|
|||
# better not send any more
|
||||
return if $size < $self->{_bout};
|
||||
|
||||
unless (defined $self->{_fh}->read($buf,$self->{_blocksize})) {
|
||||
unless (defined $self->{_fh}->read($buf, $self->{_blocksize})) {
|
||||
|
||||
if ($self->{_debug}) {
|
||||
warn "Failed to read from source file in DCC SEND!";
|
||||
}
|
||||
$self->{_fh}->close;
|
||||
if ($self->{_debug}) { warn "Failed to read from source file in DCC SEND!"; }
|
||||
$self->{_fh}->close;
|
||||
$self->{_parent}->parent->removeconn($self);
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}));
|
||||
$self->{_socket}->close;
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}
|
||||
)
|
||||
);
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
}
|
||||
|
||||
unless ($self->{_socket}->send($buf)) {
|
||||
|
||||
if ($self->{_debug}) {
|
||||
warn "send() failed horribly in DCC SEND"
|
||||
}
|
||||
if ($self->{_debug}) { warn "send() failed horribly in DCC SEND" }
|
||||
$self->{_fh}->close;
|
||||
$self->{_parent}->parent->removeconn($self);
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}));
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}
|
||||
)
|
||||
);
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{_bout} += length($buf);
|
||||
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_update', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self,
|
||||
$self->{_type},
|
||||
$self ));
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_update', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self,
|
||||
$self->{_type},
|
||||
$self
|
||||
)
|
||||
);
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
|
@ -517,10 +553,9 @@ sub parse {
|
|||
# archon: she's in league with the guy in your shower
|
||||
# archon: she gets you drunk and he takes your wallet!
|
||||
|
||||
|
||||
# handles CHAT connections
|
||||
package PBot::IRC::DCC::CHAT; # pragma_ 2011/21/01
|
||||
@PBot::IRC::DCC::CHAT::ISA = qw(Net::IRC::DCC::Connection); # pragma_ 2011/21/01
|
||||
package PBot::IRC::DCC::CHAT; # pragma_ 2011/21/01
|
||||
@PBot::IRC::DCC::CHAT::ISA = qw(Net::IRC::DCC::Connection); # pragma_ 2011/21/01
|
||||
|
||||
use IO::Socket;
|
||||
use Carp;
|
||||
|
|
@ -532,79 +567,92 @@ sub new {
|
|||
my ($sock, $self);
|
||||
|
||||
if ($type) {
|
||||
|
||||
# we're initiating
|
||||
|
||||
$sock = new IO::Socket::INET( Proto => "tcp",
|
||||
Listen => 1);
|
||||
$sock = new IO::Socket::INET(
|
||||
Proto => "tcp",
|
||||
Listen => 1
|
||||
);
|
||||
|
||||
unless (defined $sock) {
|
||||
carp "Couldn't open DCC CHAT socket: $!";
|
||||
return;
|
||||
}
|
||||
|
||||
$sock->autoflush(1);
|
||||
$container->ctcp('DCC CHAT', $nick, 'chat',
|
||||
unpack("N",inet_aton($container->hostname)),
|
||||
$sock->sockport());
|
||||
$sock->autoflush(1);
|
||||
$container->ctcp(
|
||||
'DCC CHAT', $nick, 'chat',
|
||||
unpack("N", inet_aton($container->hostname)),
|
||||
$sock->sockport()
|
||||
);
|
||||
|
||||
$self = {
|
||||
_bin => 0, # Bytes we've recieved thus far
|
||||
_bout => 0, # Bytes we've sent
|
||||
_connected => 1,
|
||||
_debug => $container->debug,
|
||||
_frag => '',
|
||||
_nick => $nick, # Nick of the client on the other end
|
||||
_parent => $container,
|
||||
_socket => $sock, # Socket we're reading from
|
||||
_time => 0, # This gets set by Accept->parse()
|
||||
_type => 'CHAT',
|
||||
};
|
||||
$self = {
|
||||
_bin => 0, # Bytes we've recieved thus far
|
||||
_bout => 0, # Bytes we've sent
|
||||
_connected => 1,
|
||||
_debug => $container->debug,
|
||||
_frag => '',
|
||||
_nick => $nick, # Nick of the client on the other end
|
||||
_parent => $container,
|
||||
_socket => $sock, # Socket we're reading from
|
||||
_time => 0, # This gets set by Accept->parse()
|
||||
_type => 'CHAT',
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
bless $self, $class;
|
||||
|
||||
$sock = PBot::IRC::DCC::Accept->new($sock, $self); # pragma_ 2011/21/01
|
||||
$sock = PBot::IRC::DCC::Accept->new($sock, $self); # pragma_ 2011/21/01
|
||||
|
||||
unless (defined $sock) {
|
||||
carp "Error in DCC CHAT connect: $!";
|
||||
return;
|
||||
}
|
||||
unless (defined $sock) {
|
||||
carp "Error in DCC CHAT connect: $!";
|
||||
return;
|
||||
}
|
||||
|
||||
} else { # we're connecting
|
||||
} else { # we're connecting
|
||||
|
||||
$address = &PBot::IRC::DCC::Connection::fixaddr($address); # pragma_ 2011/21/01
|
||||
return if $port < 1024 or not defined $address;
|
||||
$address = &PBot::IRC::DCC::Connection::fixaddr($address); # pragma_ 2011/21/01
|
||||
return if $port < 1024 or not defined $address;
|
||||
|
||||
$sock = new IO::Socket::INET( Proto => "tcp",
|
||||
PeerAddr => "$address:$port");
|
||||
$sock = new IO::Socket::INET(
|
||||
Proto => "tcp",
|
||||
PeerAddr => "$address:$port"
|
||||
);
|
||||
|
||||
if (defined $sock) {
|
||||
$container->handler(PBot::IRC::Event->new('dcc_open', # pragma_ 2011/21/01
|
||||
$nick,
|
||||
$sock,
|
||||
'chat',
|
||||
'chat', $sock));
|
||||
} else {
|
||||
carp "Error in DCC CHAT connect: $!";
|
||||
return;
|
||||
}
|
||||
$container->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_open', # pragma_ 2011/21/01
|
||||
$nick,
|
||||
$sock,
|
||||
'chat',
|
||||
'chat', $sock
|
||||
)
|
||||
);
|
||||
} else {
|
||||
carp "Error in DCC CHAT connect: $!";
|
||||
return;
|
||||
}
|
||||
|
||||
$sock->autoflush(1);
|
||||
$sock->autoflush(1);
|
||||
|
||||
$self = {
|
||||
_bin => 0, # Bytes we've recieved thus far
|
||||
_bout => 0, # Bytes we've sent
|
||||
_connected => 1,
|
||||
_nick => $nick, # Nick of the client on the other end
|
||||
_parent => $container,
|
||||
_socket => $sock, # Socket we're reading from
|
||||
_time => time,
|
||||
_type => 'CHAT',
|
||||
};
|
||||
$self = {
|
||||
_bin => 0, # Bytes we've recieved thus far
|
||||
_bout => 0, # Bytes we've sent
|
||||
_connected => 1,
|
||||
_nick => $nick, # Nick of the client on the other end
|
||||
_parent => $container,
|
||||
_socket => $sock, # Socket we're reading from
|
||||
_time => time,
|
||||
_type => 'CHAT',
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
bless $self, $class;
|
||||
|
||||
$self->{_parent}->parent->addfh($self->socket,
|
||||
$self->can('parse'), 'r', $self);
|
||||
$self->{_parent}->parent->addfh(
|
||||
$self->socket,
|
||||
$self->can('parse'), 'r', $self
|
||||
);
|
||||
}
|
||||
|
||||
return $self;
|
||||
|
|
@ -623,24 +671,32 @@ sub parse {
|
|||
my ($self, $sock) = @_;
|
||||
|
||||
foreach my $line ($self->_getline($sock)) {
|
||||
return unless defined $line;
|
||||
return unless defined $line;
|
||||
|
||||
$self->{_bin} += length($line);
|
||||
$self->{_bin} += length($line);
|
||||
|
||||
return undef if $line eq "\012";
|
||||
$self->{_bout} += length($line);
|
||||
return undef if $line eq "\012";
|
||||
$self->{_bout} += length($line);
|
||||
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('chat', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
'chat',
|
||||
$line));
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'chat', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
'chat',
|
||||
$line
|
||||
)
|
||||
);
|
||||
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_update', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self,
|
||||
$self->{_type},
|
||||
$self ));
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_update', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self,
|
||||
$self->{_type},
|
||||
$self
|
||||
)
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -650,15 +706,12 @@ sub parse {
|
|||
sub privmsg {
|
||||
my ($self) = shift;
|
||||
|
||||
unless (@_) {
|
||||
croak 'Not enough arguments to privmsg()';
|
||||
}
|
||||
unless (@_) { croak 'Not enough arguments to privmsg()'; }
|
||||
|
||||
# Don't send a CR over DCC CHAT -- it's not wanted.
|
||||
$self->socket->send(join('', @_) . "\012");
|
||||
}
|
||||
|
||||
|
||||
# -- #perl was here! --
|
||||
# \merlyn: this girl carly at the bar is aBABE
|
||||
# archon: are you sure? you don't sound like you're in a condition to
|
||||
|
|
@ -668,26 +721,25 @@ sub privmsg {
|
|||
# tmtowtdi: uh, yeah...
|
||||
# \merlyn: good topic
|
||||
|
||||
|
||||
# Sockets waiting for accept() use this to shoehorn into the select loop.
|
||||
package PBot::IRC::DCC::Accept; # pragma_ 2011/21/01
|
||||
package PBot::IRC::DCC::Accept; # pragma_ 2011/21/01
|
||||
|
||||
@PBot::IRC::DCC::Accept::ISA = qw(Net::IRC::DCC::Connection); # pragma_ 2011/21/01
|
||||
@PBot::IRC::DCC::Accept::ISA = qw(Net::IRC::DCC::Connection); # pragma_ 2011/21/01
|
||||
use Carp;
|
||||
use Socket; # we use a lot of Socket functions in parse()
|
||||
use Socket; # we use a lot of Socket functions in parse()
|
||||
use strict;
|
||||
|
||||
|
||||
sub new {
|
||||
my ($class, $sock, $parent) = @_;
|
||||
my ($self);
|
||||
|
||||
$self = { _debug => $parent->debug,
|
||||
_nonblock => 1,
|
||||
_socket => $sock,
|
||||
_parent => $parent,
|
||||
_type => 'accept',
|
||||
};
|
||||
$self = {
|
||||
_debug => $parent->debug,
|
||||
_nonblock => 1,
|
||||
_socket => $sock,
|
||||
_parent => $parent,
|
||||
_type => 'accept',
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
|
|
@ -703,48 +755,50 @@ sub parse {
|
|||
my ($self) = shift;
|
||||
my ($sock);
|
||||
|
||||
$sock = $self->{_socket}->accept;
|
||||
$sock = $self->{_socket}->accept;
|
||||
$self->{_parent}->{_socket} = $sock;
|
||||
$self->{_parent}->{_time} = time;
|
||||
$self->{_parent}->{_time} = time;
|
||||
|
||||
if ($self->{_parent}->{_type} eq 'SEND') {
|
||||
# ok, to get the ball rolling, we send them the first packet.
|
||||
my $buf;
|
||||
unless (defined $self->{_parent}->{_fh}->
|
||||
read($buf, $self->{_parent}->{_blocksize})) {
|
||||
return;
|
||||
}
|
||||
unless (defined $sock->send($buf)) {
|
||||
$sock->close;
|
||||
$self->{_parent}->{_fh}->close;
|
||||
$self->{_parent}->{_parent}->parent->removefh($sock);
|
||||
$self->{_parent}->handler(PBot::IRC::Event->new('dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}));
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
}
|
||||
|
||||
# ok, to get the ball rolling, we send them the first packet.
|
||||
my $buf;
|
||||
unless (defined $self->{_parent}->{_fh}->read($buf, $self->{_parent}->{_blocksize})) { return; }
|
||||
unless (defined $sock->send($buf)) {
|
||||
$sock->close;
|
||||
$self->{_parent}->{_fh}->close;
|
||||
$self->{_parent}->{_parent}->parent->removefh($sock);
|
||||
$self->{_parent}->handler(
|
||||
PBot::IRC::Event->new(
|
||||
'dcc_close', # pragma_ 2011/21/01
|
||||
$self->{_nick},
|
||||
$self->{_socket},
|
||||
$self->{_type}
|
||||
)
|
||||
);
|
||||
$self->{_socket}->close;
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
$self->{_parent}->{_parent}->parent->addconn($self->{_parent});
|
||||
$self->{_parent}->{_parent}->parent->removeconn($self);
|
||||
|
||||
$self->{_parent}->{_parent}->handler(PBot::IRC::Event-> # pragma_ 2011/21/01
|
||||
new('dcc_open',
|
||||
$self->{_parent}->{_nick},
|
||||
$self->{_parent}->{_socket},
|
||||
$self->{_parent}->{_type},
|
||||
$self->{_parent}->{_type},
|
||||
$self->{_parent}->{_socket})
|
||||
);
|
||||
$self->{_parent}->{_parent}->handler(
|
||||
PBot::IRC::Event-> # pragma_ 2011/21/01
|
||||
new(
|
||||
'dcc_open',
|
||||
$self->{_parent}->{_nick},
|
||||
$self->{_parent}->{_socket},
|
||||
$self->{_parent}->{_type},
|
||||
$self->{_parent}->{_type},
|
||||
$self->{_parent}->{_socket}
|
||||
)
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@
|
|||
# Well, welcome to the real world, guys, where code needs to be
|
||||
# maintainable and sane.
|
||||
|
||||
package PBot::IRC::Event; # pragma_ 2011/21/01
|
||||
package PBot::IRC::Event; # pragma_ 2011/21/01
|
||||
|
||||
use feature 'unicode_strings';
|
||||
|
||||
|
|
@ -36,73 +36,70 @@ our %_names;
|
|||
# the name of the format string for the event
|
||||
# (optional) any number of arguments provided by the event
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $type = shift;
|
||||
my $from = shift;
|
||||
my $to = shift;
|
||||
my $format = shift;
|
||||
my $args = \@_;
|
||||
|
||||
my $self = {
|
||||
'type' => $type,
|
||||
'from' => undef,
|
||||
'to' => ref($to) eq 'ARRAY' ? $to : [ $to ],
|
||||
'format' => $format,
|
||||
'args' => [],
|
||||
};
|
||||
my $class = shift;
|
||||
|
||||
bless $self, $class;
|
||||
my $type = shift;
|
||||
my $from = shift;
|
||||
my $to = shift;
|
||||
my $format = shift;
|
||||
my $args = \@_;
|
||||
|
||||
if ($self->type !~ /\D/) {
|
||||
$self->type($self->trans($self->type));
|
||||
} else {
|
||||
$self->type(lc($self->type));
|
||||
}
|
||||
my $self = {
|
||||
'type' => $type,
|
||||
'from' => undef,
|
||||
'to' => ref($to) eq 'ARRAY' ? $to : [$to],
|
||||
'format' => $format,
|
||||
'args' => [],
|
||||
};
|
||||
|
||||
$self->from($from); # sets nick, user, and host
|
||||
$self->args($args); # strips colons from args
|
||||
bless $self, $class;
|
||||
|
||||
return $self;
|
||||
if ($self->type !~ /\D/) { $self->type($self->trans($self->type)); }
|
||||
else { $self->type(lc($self->type)); }
|
||||
|
||||
$self->from($from); # sets nick, user, and host
|
||||
$self->args($args); # strips colons from args
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# Sets or returns an argument list for this event.
|
||||
# Takes any number of args: the arguments for the event.
|
||||
sub args {
|
||||
my $self = shift;
|
||||
my $args = shift;
|
||||
my $self = shift;
|
||||
my $args = shift;
|
||||
|
||||
if ($args) {
|
||||
my (@q, $i, $ct) = @{$args}; # This line is solemnly dedicated to \mjd.
|
||||
if ($args) {
|
||||
my (@q, $i, $ct) = @{$args}; # This line is solemnly dedicated to \mjd.
|
||||
|
||||
$self->{'args'} = [ ];
|
||||
while (@q) {
|
||||
$i = shift @q;
|
||||
next unless defined $i;
|
||||
$self->{'args'} = [];
|
||||
while (@q) {
|
||||
$i = shift @q;
|
||||
next unless defined $i;
|
||||
|
||||
if ($i =~ /^:/ and $ct) { # Concatenate :-args.
|
||||
$i = join ' ', (substr($i, 1), @q);
|
||||
push @{$self->{'args'}}, $i;
|
||||
last;
|
||||
}
|
||||
push @{$self->{'args'}}, $i;
|
||||
$ct++;
|
||||
if ($i =~ /^:/ and $ct) { # Concatenate :-args.
|
||||
$i = join ' ', (substr($i, 1), @q);
|
||||
push @{$self->{'args'}}, $i;
|
||||
last;
|
||||
}
|
||||
push @{$self->{'args'}}, $i;
|
||||
$ct++;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return @{$self->{'args'}};
|
||||
return @{$self->{'args'}};
|
||||
}
|
||||
|
||||
# Dumps the contents of an event to STDERR so you can see what's inside.
|
||||
# Takes no args.
|
||||
sub dump {
|
||||
my ($self, $arg, $counter) = (shift, undef, 0); # heh heh!
|
||||
my ($self, $arg, $counter) = (shift, undef, 0); # heh heh!
|
||||
|
||||
printf STDERR "TYPE: %-30s FORMAT: %-30s\n", $self->type, $self->format;
|
||||
print STDERR "FROM: ", $self->from, "\n";
|
||||
print STDERR "TO: ", join(", ", @{$self->to}), "\n";
|
||||
foreach $arg ($self->args) {
|
||||
print STDERR "Arg ", $counter++, ": ", $arg, "\n";
|
||||
}
|
||||
foreach $arg ($self->args) { print STDERR "Arg ", $counter++, ": ", $arg, "\n"; }
|
||||
}
|
||||
|
||||
# Sets or returns the format string for this event.
|
||||
|
|
@ -121,18 +118,18 @@ sub from {
|
|||
my @part;
|
||||
|
||||
if (@_) {
|
||||
# avoid certain irritating and spurious warnings from this line...
|
||||
{ local $^W;
|
||||
@part = split /[\@!]/, $_[0], 3;
|
||||
}
|
||||
|
||||
$self->nick(defined $part[0] ? $part[0] : '');
|
||||
$self->user(defined $part[1] ? $part[1] : '');
|
||||
$self->host(defined $part[2] ? $part[2] : '');
|
||||
defined $self->user ?
|
||||
$self->userhost($self->user . '@' . $self->host) :
|
||||
$self->userhost($self->host);
|
||||
$self->{'from'} = $_[0];
|
||||
# avoid certain irritating and spurious warnings from this line...
|
||||
{
|
||||
local $^W;
|
||||
@part = split /[\@!]/, $_[0], 3;
|
||||
}
|
||||
|
||||
$self->nick(defined $part[0] ? $part[0] : '');
|
||||
$self->user(defined $part[1] ? $part[1] : '');
|
||||
$self->host(defined $part[2] ? $part[2] : '');
|
||||
defined $self->user ? $self->userhost($self->user . '@' . $self->host) : $self->userhost($self->host);
|
||||
$self->{'from'} = $_[0];
|
||||
}
|
||||
|
||||
return $self->{'from'};
|
||||
|
|
@ -161,7 +158,7 @@ sub nick {
|
|||
sub to {
|
||||
my $self = shift;
|
||||
|
||||
$self->{'to'} = [ @_ ] if @_;
|
||||
$self->{'to'} = [@_] if @_;
|
||||
return wantarray ? @{$self->{'to'}} : $self->{'to'};
|
||||
}
|
||||
|
||||
|
|
@ -194,292 +191,291 @@ sub userhost {
|
|||
# Simple sub for translating server numerics to their appropriate names.
|
||||
# Takes one arg: the number to be translated.
|
||||
sub trans {
|
||||
shift if (ref($_[0]) || $_[0]) =~ /^PBot::IRC/; # pragma_ 2011/21/01
|
||||
shift if (ref($_[0]) || $_[0]) =~ /^PBot::IRC/; # pragma_ 2011/21/01
|
||||
my $ev = shift;
|
||||
|
||||
return (exists $_names{$ev} ? $_names{$ev} : undef);
|
||||
}
|
||||
|
||||
%_names = (
|
||||
# suck! these aren't treated as strings --
|
||||
# 001 ne 1 for the purpose of hash keying, apparently.
|
||||
'001' => "welcome",
|
||||
'002' => "yourhost",
|
||||
'003' => "created",
|
||||
'004' => "myinfo",
|
||||
'005' => "map", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
|
||||
'006' => "mapmore", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
|
||||
'007' => "mapend", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
|
||||
'008' => "snomask", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
|
||||
'009' => "statmemtot", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
|
||||
'010' => "statmem", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
|
||||
|
||||
200 => "tracelink",
|
||||
201 => "traceconnecting",
|
||||
202 => "tracehandshake",
|
||||
203 => "traceunknown",
|
||||
204 => "traceoperator",
|
||||
205 => "traceuser",
|
||||
206 => "traceserver",
|
||||
208 => "tracenewtype",
|
||||
209 => "traceclass",
|
||||
211 => "statslinkinfo",
|
||||
212 => "statscommands",
|
||||
213 => "statscline",
|
||||
214 => "statsnline",
|
||||
215 => "statsiline",
|
||||
216 => "statskline",
|
||||
217 => "statsqline",
|
||||
218 => "statsyline",
|
||||
219 => "endofstats",
|
||||
220 => "statsbline", # UnrealIrcd, Hendrik Frenzel
|
||||
221 => "umodeis",
|
||||
222 => "sqline_nick", # UnrealIrcd, Hendrik Frenzel
|
||||
223 => "statsgline", # UnrealIrcd, Hendrik Frenzel
|
||||
224 => "statstline", # UnrealIrcd, Hendrik Frenzel
|
||||
225 => "statseline", # UnrealIrcd, Hendrik Frenzel
|
||||
226 => "statsnline", # UnrealIrcd, Hendrik Frenzel
|
||||
227 => "statsvline", # UnrealIrcd, Hendrik Frenzel
|
||||
231 => "serviceinfo",
|
||||
232 => "endofservices",
|
||||
233 => "service",
|
||||
234 => "servlist",
|
||||
235 => "servlistend",
|
||||
241 => "statslline",
|
||||
242 => "statsuptime",
|
||||
243 => "statsoline",
|
||||
244 => "statshline",
|
||||
245 => "statssline", # Reserved, Kajetan@Hinner.com, 17/10/98
|
||||
246 => "statstline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
247 => "statsgline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
# suck! these aren't treated as strings --
|
||||
# 001 ne 1 for the purpose of hash keying, apparently.
|
||||
'001' => "welcome",
|
||||
'002' => "yourhost",
|
||||
'003' => "created",
|
||||
'004' => "myinfo",
|
||||
'005' => "map", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
|
||||
'006' => "mapmore", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
|
||||
'007' => "mapend", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
|
||||
'008' => "snomask", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
|
||||
'009' => "statmemtot", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
|
||||
'010' => "statmem", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
|
||||
|
||||
200 => "tracelink",
|
||||
201 => "traceconnecting",
|
||||
202 => "tracehandshake",
|
||||
203 => "traceunknown",
|
||||
204 => "traceoperator",
|
||||
205 => "traceuser",
|
||||
206 => "traceserver",
|
||||
208 => "tracenewtype",
|
||||
209 => "traceclass",
|
||||
211 => "statslinkinfo",
|
||||
212 => "statscommands",
|
||||
213 => "statscline",
|
||||
214 => "statsnline",
|
||||
215 => "statsiline",
|
||||
216 => "statskline",
|
||||
217 => "statsqline",
|
||||
218 => "statsyline",
|
||||
219 => "endofstats",
|
||||
220 => "statsbline", # UnrealIrcd, Hendrik Frenzel
|
||||
221 => "umodeis",
|
||||
222 => "sqline_nick", # UnrealIrcd, Hendrik Frenzel
|
||||
223 => "statsgline", # UnrealIrcd, Hendrik Frenzel
|
||||
224 => "statstline", # UnrealIrcd, Hendrik Frenzel
|
||||
225 => "statseline", # UnrealIrcd, Hendrik Frenzel
|
||||
226 => "statsnline", # UnrealIrcd, Hendrik Frenzel
|
||||
227 => "statsvline", # UnrealIrcd, Hendrik Frenzel
|
||||
231 => "serviceinfo",
|
||||
232 => "endofservices",
|
||||
233 => "service",
|
||||
234 => "servlist",
|
||||
235 => "servlistend",
|
||||
241 => "statslline",
|
||||
242 => "statsuptime",
|
||||
243 => "statsoline",
|
||||
244 => "statshline",
|
||||
245 => "statssline", # Reserved, Kajetan@Hinner.com, 17/10/98
|
||||
246 => "statstline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
247 => "statsgline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
### TODO: need numerics to be able to map to multiple strings
|
||||
### 247 => "statsxline", # UnrealIrcd, Hendrik Frenzel
|
||||
248 => "statsuline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
249 => "statsdebug", # Unspecific Extension, Kajetan@Hinner.com, 17/10/98
|
||||
250 => "luserconns", # 1998-03-15 -- tkil
|
||||
251 => "luserclient",
|
||||
252 => "luserop",
|
||||
253 => "luserunknown",
|
||||
254 => "luserchannels",
|
||||
255 => "luserme",
|
||||
256 => "adminme",
|
||||
257 => "adminloc1",
|
||||
258 => "adminloc2",
|
||||
259 => "adminemail",
|
||||
261 => "tracelog",
|
||||
262 => "endoftrace", # 1997-11-24 -- archon
|
||||
265 => "n_local", # 1997-10-16 -- tkil
|
||||
266 => "n_global", # 1997-10-16 -- tkil
|
||||
271 => "silelist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
272 => "endofsilelist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
275 => "statsdline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
280 => "glist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
281 => "endofglist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
290 => "helphdr", # UnrealIrcd, Hendrik Frenzel
|
||||
291 => "helpop", # UnrealIrcd, Hendrik Frenzel
|
||||
292 => "helptlr", # UnrealIrcd, Hendrik Frenzel
|
||||
293 => "helphlp", # UnrealIrcd, Hendrik Frenzel
|
||||
294 => "helpfwd", # UnrealIrcd, Hendrik Frenzel
|
||||
295 => "helpign", # UnrealIrcd, Hendrik Frenzel
|
||||
248 => "statsuline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
249 => "statsdebug", # Unspecific Extension, Kajetan@Hinner.com, 17/10/98
|
||||
250 => "luserconns", # 1998-03-15 -- tkil
|
||||
251 => "luserclient",
|
||||
252 => "luserop",
|
||||
253 => "luserunknown",
|
||||
254 => "luserchannels",
|
||||
255 => "luserme",
|
||||
256 => "adminme",
|
||||
257 => "adminloc1",
|
||||
258 => "adminloc2",
|
||||
259 => "adminemail",
|
||||
261 => "tracelog",
|
||||
262 => "endoftrace", # 1997-11-24 -- archon
|
||||
265 => "n_local", # 1997-10-16 -- tkil
|
||||
266 => "n_global", # 1997-10-16 -- tkil
|
||||
271 => "silelist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
272 => "endofsilelist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
275 => "statsdline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
280 => "glist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
281 => "endofglist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
290 => "helphdr", # UnrealIrcd, Hendrik Frenzel
|
||||
291 => "helpop", # UnrealIrcd, Hendrik Frenzel
|
||||
292 => "helptlr", # UnrealIrcd, Hendrik Frenzel
|
||||
293 => "helphlp", # UnrealIrcd, Hendrik Frenzel
|
||||
294 => "helpfwd", # UnrealIrcd, Hendrik Frenzel
|
||||
295 => "helpign", # UnrealIrcd, Hendrik Frenzel
|
||||
|
||||
300 => "none",
|
||||
301 => "away",
|
||||
302 => "userhost",
|
||||
303 => "ison",
|
||||
304 => "rpl_text", # Bahamut IRCD
|
||||
305 => "unaway",
|
||||
306 => "nowaway",
|
||||
307 => "userip", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
308 => "rulesstart", # UnrealIrcd, Hendrik Frenzel
|
||||
309 => "endofrules", # UnrealIrcd, Hendrik Frenzel
|
||||
310 => "whoishelp", # (July01-01)Austnet Extension, found by Andypoo <andypoo@secret.com.au>
|
||||
311 => "whoisuser",
|
||||
312 => "whoisserver",
|
||||
313 => "whoisoperator",
|
||||
314 => "whowasuser",
|
||||
315 => "endofwho",
|
||||
316 => "whoischanop",
|
||||
317 => "whoisidle",
|
||||
318 => "endofwhois",
|
||||
319 => "whoischannels",
|
||||
320 => "whoisvworld", # (July01-01)Austnet Extension, found by Andypoo <andypoo@secret.com.au>
|
||||
321 => "liststart",
|
||||
322 => "list",
|
||||
323 => "listend",
|
||||
324 => "channelmodeis",
|
||||
329 => "channelcreate", # 1997-11-24 -- archon
|
||||
330 => "whoisaccount", # 2011-02-10 pragma_ for freenode
|
||||
331 => "notopic",
|
||||
332 => "topic",
|
||||
333 => "topicinfo", # 1997-11-24 -- archon
|
||||
334 => "listusage", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
335 => "whoisbot", # UnrealIrcd, Hendrik Frenzel
|
||||
341 => "inviting",
|
||||
342 => "summoning",
|
||||
346 => "invitelist", # UnrealIrcd, Hendrik Frenzel
|
||||
347 => "endofinvitelist", # UnrealIrcd, Hendrik Frenzel
|
||||
348 => "exlist", # UnrealIrcd, Hendrik Frenzel
|
||||
349 => "endofexlist", # UnrealIrcd, Hendrik Frenzel
|
||||
351 => "version",
|
||||
352 => "whoreply",
|
||||
353 => "namreply",
|
||||
354 => "whospcrpl", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
361 => "killdone",
|
||||
362 => "closing",
|
||||
363 => "closeend",
|
||||
364 => "links",
|
||||
365 => "endoflinks",
|
||||
366 => "endofnames",
|
||||
367 => "banlist",
|
||||
368 => "endofbanlist",
|
||||
369 => "endofwhowas",
|
||||
371 => "info",
|
||||
372 => "motd",
|
||||
373 => "infostart",
|
||||
374 => "endofinfo",
|
||||
375 => "motdstart",
|
||||
376 => "endofmotd",
|
||||
377 => "motd2", # 1997-10-16 -- tkil
|
||||
378 => "austmotd", # (July01-01)Austnet Extension, found by Andypoo <andypoo@secret.com.au>
|
||||
379 => "whoismodes", # UnrealIrcd, Hendrik Frenzel
|
||||
381 => "youreoper",
|
||||
382 => "rehashing",
|
||||
383 => "youreservice", # UnrealIrcd, Hendrik Frenzel
|
||||
384 => "myportis",
|
||||
385 => "notoperanymore", # Unspecific Extension, Kajetan@Hinner.com, 17/10/98
|
||||
386 => "qlist", # UnrealIrcd, Hendrik Frenzel
|
||||
387 => "endofqlist", # UnrealIrcd, Hendrik Frenzel
|
||||
388 => "alist", # UnrealIrcd, Hendrik Frenzel
|
||||
389 => "endofalist", # UnrealIrcd, Hendrik Frenzel
|
||||
391 => "time",
|
||||
392 => "usersstart",
|
||||
393 => "users",
|
||||
394 => "endofusers",
|
||||
395 => "nousers",
|
||||
300 => "none",
|
||||
301 => "away",
|
||||
302 => "userhost",
|
||||
303 => "ison",
|
||||
304 => "rpl_text", # Bahamut IRCD
|
||||
305 => "unaway",
|
||||
306 => "nowaway",
|
||||
307 => "userip", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
308 => "rulesstart", # UnrealIrcd, Hendrik Frenzel
|
||||
309 => "endofrules", # UnrealIrcd, Hendrik Frenzel
|
||||
310 => "whoishelp", # (July01-01)Austnet Extension, found by Andypoo <andypoo@secret.com.au>
|
||||
311 => "whoisuser",
|
||||
312 => "whoisserver",
|
||||
313 => "whoisoperator",
|
||||
314 => "whowasuser",
|
||||
315 => "endofwho",
|
||||
316 => "whoischanop",
|
||||
317 => "whoisidle",
|
||||
318 => "endofwhois",
|
||||
319 => "whoischannels",
|
||||
320 => "whoisvworld", # (July01-01)Austnet Extension, found by Andypoo <andypoo@secret.com.au>
|
||||
321 => "liststart",
|
||||
322 => "list",
|
||||
323 => "listend",
|
||||
324 => "channelmodeis",
|
||||
329 => "channelcreate", # 1997-11-24 -- archon
|
||||
330 => "whoisaccount", # 2011-02-10 pragma_ for freenode
|
||||
331 => "notopic",
|
||||
332 => "topic",
|
||||
333 => "topicinfo", # 1997-11-24 -- archon
|
||||
334 => "listusage", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
335 => "whoisbot", # UnrealIrcd, Hendrik Frenzel
|
||||
341 => "inviting",
|
||||
342 => "summoning",
|
||||
346 => "invitelist", # UnrealIrcd, Hendrik Frenzel
|
||||
347 => "endofinvitelist", # UnrealIrcd, Hendrik Frenzel
|
||||
348 => "exlist", # UnrealIrcd, Hendrik Frenzel
|
||||
349 => "endofexlist", # UnrealIrcd, Hendrik Frenzel
|
||||
351 => "version",
|
||||
352 => "whoreply",
|
||||
353 => "namreply",
|
||||
354 => "whospcrpl", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
361 => "killdone",
|
||||
362 => "closing",
|
||||
363 => "closeend",
|
||||
364 => "links",
|
||||
365 => "endoflinks",
|
||||
366 => "endofnames",
|
||||
367 => "banlist",
|
||||
368 => "endofbanlist",
|
||||
369 => "endofwhowas",
|
||||
371 => "info",
|
||||
372 => "motd",
|
||||
373 => "infostart",
|
||||
374 => "endofinfo",
|
||||
375 => "motdstart",
|
||||
376 => "endofmotd",
|
||||
377 => "motd2", # 1997-10-16 -- tkil
|
||||
378 => "austmotd", # (July01-01)Austnet Extension, found by Andypoo <andypoo@secret.com.au>
|
||||
379 => "whoismodes", # UnrealIrcd, Hendrik Frenzel
|
||||
381 => "youreoper",
|
||||
382 => "rehashing",
|
||||
383 => "youreservice", # UnrealIrcd, Hendrik Frenzel
|
||||
384 => "myportis",
|
||||
385 => "notoperanymore", # Unspecific Extension, Kajetan@Hinner.com, 17/10/98
|
||||
386 => "qlist", # UnrealIrcd, Hendrik Frenzel
|
||||
387 => "endofqlist", # UnrealIrcd, Hendrik Frenzel
|
||||
388 => "alist", # UnrealIrcd, Hendrik Frenzel
|
||||
389 => "endofalist", # UnrealIrcd, Hendrik Frenzel
|
||||
391 => "time",
|
||||
392 => "usersstart",
|
||||
393 => "users",
|
||||
394 => "endofusers",
|
||||
395 => "nousers",
|
||||
|
||||
401 => "nosuchnick",
|
||||
402 => "nosuchserver",
|
||||
403 => "nosuchchannel",
|
||||
404 => "cannotsendtochan",
|
||||
405 => "toomanychannels",
|
||||
406 => "wasnosuchnick",
|
||||
407 => "toomanytargets",
|
||||
408 => "nosuchservice", # UnrealIrcd, Hendrik Frenzel
|
||||
409 => "noorigin",
|
||||
411 => "norecipient",
|
||||
412 => "notexttosend",
|
||||
413 => "notoplevel",
|
||||
414 => "wildtoplevel",
|
||||
416 => "querytoolong", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
421 => "unknowncommand",
|
||||
422 => "nomotd",
|
||||
423 => "noadmininfo",
|
||||
424 => "fileerror",
|
||||
425 => "noopermotd", # UnrealIrcd, Hendrik Frenzel
|
||||
431 => "nonicknamegiven",
|
||||
432 => "erroneusnickname", # This iz how its speld in thee RFC.
|
||||
433 => "nicknameinuse",
|
||||
434 => "norules", # UnrealIrcd, Hendrik Frenzel
|
||||
435 => "serviceconfused", # UnrealIrcd, Hendrik Frenzel
|
||||
436 => "nickcollision",
|
||||
437 => "bannickchange", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
438 => "nicktoofast", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
439 => "targettoofast", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
440 => "servicesdown", # Bahamut IRCD
|
||||
441 => "usernotinchannel",
|
||||
442 => "notonchannel",
|
||||
443 => "useronchannel",
|
||||
444 => "nologin",
|
||||
445 => "summondisabled",
|
||||
446 => "usersdisabled",
|
||||
447 => "nonickchange", # UnrealIrcd, Hendrik Frenzel
|
||||
451 => "notregistered",
|
||||
455 => "hostilename", # UnrealIrcd, Hendrik Frenzel
|
||||
459 => "nohiding", # UnrealIrcd, Hendrik Frenzel
|
||||
460 => "notforhalfops", # UnrealIrcd, Hendrik Frenzel
|
||||
461 => "needmoreparams",
|
||||
462 => "alreadyregistered",
|
||||
463 => "nopermforhost",
|
||||
464 => "passwdmismatch",
|
||||
465 => "yourebannedcreep", # I love this one...
|
||||
466 => "youwillbebanned",
|
||||
467 => "keyset",
|
||||
468 => "invalidusername", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
469 => "linkset", # UnrealIrcd, Hendrik Frenzel
|
||||
470 => "linkchannel", # UnrealIrcd, Hendrik Frenzel
|
||||
471 => "channelisfull",
|
||||
472 => "unknownmode",
|
||||
473 => "inviteonlychan",
|
||||
474 => "bannedfromchan",
|
||||
475 => "badchannelkey",
|
||||
476 => "badchanmask",
|
||||
477 => "needreggednick", # Bahamut IRCD
|
||||
478 => "banlistfull", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
479 => "secureonlychannel", # pircd
|
||||
401 => "nosuchnick",
|
||||
402 => "nosuchserver",
|
||||
403 => "nosuchchannel",
|
||||
404 => "cannotsendtochan",
|
||||
405 => "toomanychannels",
|
||||
406 => "wasnosuchnick",
|
||||
407 => "toomanytargets",
|
||||
408 => "nosuchservice", # UnrealIrcd, Hendrik Frenzel
|
||||
409 => "noorigin",
|
||||
411 => "norecipient",
|
||||
412 => "notexttosend",
|
||||
413 => "notoplevel",
|
||||
414 => "wildtoplevel",
|
||||
416 => "querytoolong", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
421 => "unknowncommand",
|
||||
422 => "nomotd",
|
||||
423 => "noadmininfo",
|
||||
424 => "fileerror",
|
||||
425 => "noopermotd", # UnrealIrcd, Hendrik Frenzel
|
||||
431 => "nonicknamegiven",
|
||||
432 => "erroneusnickname", # This iz how its speld in thee RFC.
|
||||
433 => "nicknameinuse",
|
||||
434 => "norules", # UnrealIrcd, Hendrik Frenzel
|
||||
435 => "serviceconfused", # UnrealIrcd, Hendrik Frenzel
|
||||
436 => "nickcollision",
|
||||
437 => "bannickchange", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
438 => "nicktoofast", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
439 => "targettoofast", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
440 => "servicesdown", # Bahamut IRCD
|
||||
441 => "usernotinchannel",
|
||||
442 => "notonchannel",
|
||||
443 => "useronchannel",
|
||||
444 => "nologin",
|
||||
445 => "summondisabled",
|
||||
446 => "usersdisabled",
|
||||
447 => "nonickchange", # UnrealIrcd, Hendrik Frenzel
|
||||
451 => "notregistered",
|
||||
455 => "hostilename", # UnrealIrcd, Hendrik Frenzel
|
||||
459 => "nohiding", # UnrealIrcd, Hendrik Frenzel
|
||||
460 => "notforhalfops", # UnrealIrcd, Hendrik Frenzel
|
||||
461 => "needmoreparams",
|
||||
462 => "alreadyregistered",
|
||||
463 => "nopermforhost",
|
||||
464 => "passwdmismatch",
|
||||
465 => "yourebannedcreep", # I love this one...
|
||||
466 => "youwillbebanned",
|
||||
467 => "keyset",
|
||||
468 => "invalidusername", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
469 => "linkset", # UnrealIrcd, Hendrik Frenzel
|
||||
470 => "linkchannel", # UnrealIrcd, Hendrik Frenzel
|
||||
471 => "channelisfull",
|
||||
472 => "unknownmode",
|
||||
473 => "inviteonlychan",
|
||||
474 => "bannedfromchan",
|
||||
475 => "badchannelkey",
|
||||
476 => "badchanmask",
|
||||
477 => "needreggednick", # Bahamut IRCD
|
||||
478 => "banlistfull", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
479 => "secureonlychannel", # pircd
|
||||
### TODO: see above todo
|
||||
### 479 => "linkfail", # UnrealIrcd, Hendrik Frenzel
|
||||
480 => "cannotknock", # UnrealIrcd, Hendrik Frenzel
|
||||
481 => "noprivileges",
|
||||
482 => "chanoprivsneeded",
|
||||
483 => "cantkillserver",
|
||||
484 => "ischanservice", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
485 => "killdeny", # UnrealIrcd, Hendrik Frenzel
|
||||
486 => "htmdisabled", # UnrealIrcd, Hendrik Frenzel
|
||||
489 => "secureonlychan", # UnrealIrcd, Hendrik Frenzel
|
||||
491 => "nooperhost",
|
||||
492 => "noservicehost",
|
||||
480 => "cannotknock", # UnrealIrcd, Hendrik Frenzel
|
||||
481 => "noprivileges",
|
||||
482 => "chanoprivsneeded",
|
||||
483 => "cantkillserver",
|
||||
484 => "ischanservice", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
485 => "killdeny", # UnrealIrcd, Hendrik Frenzel
|
||||
486 => "htmdisabled", # UnrealIrcd, Hendrik Frenzel
|
||||
489 => "secureonlychan", # UnrealIrcd, Hendrik Frenzel
|
||||
491 => "nooperhost",
|
||||
492 => "noservicehost",
|
||||
|
||||
501 => "umodeunknownflag",
|
||||
502 => "usersdontmatch",
|
||||
501 => "umodeunknownflag",
|
||||
502 => "usersdontmatch",
|
||||
|
||||
511 => "silelistfull", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
513 => "nosuchgline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
513 => "badping", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
518 => "noinvite", # UnrealIrcd, Hendrik Frenzel
|
||||
519 => "admonly", # UnrealIrcd, Hendrik Frenzel
|
||||
520 => "operonly", # UnrealIrcd, Hendrik Frenzel
|
||||
521 => "listsyntax", # UnrealIrcd, Hendrik Frenzel
|
||||
524 => "operspverify", # UnrealIrcd, Hendrik Frenzel
|
||||
511 => "silelistfull", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
513 => "nosuchgline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
513 => "badping", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
|
||||
518 => "noinvite", # UnrealIrcd, Hendrik Frenzel
|
||||
519 => "admonly", # UnrealIrcd, Hendrik Frenzel
|
||||
520 => "operonly", # UnrealIrcd, Hendrik Frenzel
|
||||
521 => "listsyntax", # UnrealIrcd, Hendrik Frenzel
|
||||
524 => "operspverify", # UnrealIrcd, Hendrik Frenzel
|
||||
|
||||
600 => "rpl_logon", # Bahamut IRCD
|
||||
601 => "rpl_logoff", # Bahamut IRCD
|
||||
602 => "rpl_watchoff", # UnrealIrcd, Hendrik Frenzel
|
||||
603 => "rpl_watchstat", # UnrealIrcd, Hendrik Frenzel
|
||||
604 => "rpl_nowon", # Bahamut IRCD
|
||||
605 => "rpl_nowoff", # Bahamut IRCD
|
||||
606 => "rpl_watchlist", # UnrealIrcd, Hendrik Frenzel
|
||||
607 => "rpl_endofwatchlist", # UnrealIrcd, Hendrik Frenzel
|
||||
610 => "mapmore", # UnrealIrcd, Hendrik Frenzel
|
||||
640 => "rpl_dumping", # UnrealIrcd, Hendrik Frenzel
|
||||
641 => "rpl_dumprpl", # UnrealIrcd, Hendrik Frenzel
|
||||
642 => "rpl_eodump", # UnrealIrcd, Hendrik Frenzel
|
||||
728 => "quietlist", # freenode +q, pragma_ 12/12/2011
|
||||
600 => "rpl_logon", # Bahamut IRCD
|
||||
601 => "rpl_logoff", # Bahamut IRCD
|
||||
602 => "rpl_watchoff", # UnrealIrcd, Hendrik Frenzel
|
||||
603 => "rpl_watchstat", # UnrealIrcd, Hendrik Frenzel
|
||||
604 => "rpl_nowon", # Bahamut IRCD
|
||||
605 => "rpl_nowoff", # Bahamut IRCD
|
||||
606 => "rpl_watchlist", # UnrealIrcd, Hendrik Frenzel
|
||||
607 => "rpl_endofwatchlist", # UnrealIrcd, Hendrik Frenzel
|
||||
610 => "mapmore", # UnrealIrcd, Hendrik Frenzel
|
||||
640 => "rpl_dumping", # UnrealIrcd, Hendrik Frenzel
|
||||
641 => "rpl_dumprpl", # UnrealIrcd, Hendrik Frenzel
|
||||
642 => "rpl_eodump", # UnrealIrcd, Hendrik Frenzel
|
||||
728 => "quietlist", # freenode +q, pragma_ 12/12/2011
|
||||
|
||||
999 => "numericerror", # Bahamut IRCD
|
||||
|
||||
# add these events so that default handlers will kick in and handle them
|
||||
# pragma_ 10/30/2014
|
||||
'notice' => 'notice',
|
||||
'public' => 'public',
|
||||
'kick' => 'kick',
|
||||
'mode' => 'mode',
|
||||
'msg' => 'msg',
|
||||
'disconnect' => 'disconnect',
|
||||
'part' => 'part',
|
||||
'join' => 'join',
|
||||
'caction' => 'caction',
|
||||
'quit' => 'quit',
|
||||
'nick' => 'nick',
|
||||
'pong' => 'pong',
|
||||
'invite' => 'invite',
|
||||
'cap' => 'cap',
|
||||
'account' => 'account',
|
||||
);
|
||||
999 => "numericerror", # Bahamut IRCD
|
||||
|
||||
# add these events so that default handlers will kick in and handle them
|
||||
# pragma_ 10/30/2014
|
||||
'notice' => 'notice',
|
||||
'public' => 'public',
|
||||
'kick' => 'kick',
|
||||
'mode' => 'mode',
|
||||
'msg' => 'msg',
|
||||
'disconnect' => 'disconnect',
|
||||
'part' => 'part',
|
||||
'join' => 'join',
|
||||
'caction' => 'caction',
|
||||
'quit' => 'quit',
|
||||
'nick' => 'nick',
|
||||
'pong' => 'pong',
|
||||
'invite' => 'invite',
|
||||
'cap' => 'cap',
|
||||
'account' => 'account',
|
||||
);
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
|
|
|||
|
|
@ -1,75 +1,75 @@
|
|||
package PBot::IRC::EventQueue; # pragma_ 2011/21/01
|
||||
package PBot::IRC::EventQueue; # pragma_ 2011/21/01
|
||||
|
||||
use feature 'unicode_strings';
|
||||
|
||||
use PBot::IRC::EventQueue::Entry; # pragma_ 2011/21/01
|
||||
use PBot::IRC::EventQueue::Entry; # pragma_ 2011/21/01
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $class = shift;
|
||||
|
||||
my $self = {
|
||||
'queue' => {},
|
||||
};
|
||||
my $self = {
|
||||
'queue' => {},
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
bless $self, $class;
|
||||
}
|
||||
|
||||
sub queue {
|
||||
my $self = shift;
|
||||
return $self->{'queue'};
|
||||
my $self = shift;
|
||||
return $self->{'queue'};
|
||||
}
|
||||
|
||||
sub enqueue {
|
||||
my $self = shift;
|
||||
my $time = shift;
|
||||
my $content = shift;
|
||||
my $self = shift;
|
||||
my $time = shift;
|
||||
my $content = shift;
|
||||
|
||||
my $entry = new PBot::IRC::EventQueue::Entry($time, $content); # pragma_ 2011/21/01
|
||||
$self->queue->{$entry->id} = $entry;
|
||||
return $entry->id;
|
||||
my $entry = new PBot::IRC::EventQueue::Entry($time, $content); # pragma_ 2011/21/01
|
||||
$self->queue->{$entry->id} = $entry;
|
||||
return $entry->id;
|
||||
}
|
||||
|
||||
sub dequeue {
|
||||
my $self = shift;
|
||||
my $event = shift;
|
||||
my $result;
|
||||
my $self = shift;
|
||||
my $event = shift;
|
||||
my $result;
|
||||
|
||||
if (!$event) { # we got passed nothing, so return the first event
|
||||
$event = $self->head();
|
||||
delete $self->queue->{$event->id};
|
||||
$result = $event;
|
||||
} elsif (!ref($event)) { # we got passed an id
|
||||
$result = $self->queue->{$event};
|
||||
delete $self->queue->{$event};
|
||||
} else { # we got passed an actual event object
|
||||
ref($event) eq 'PBot::IRC::EventQueue::Entry' # pragma_ 2011/21/01
|
||||
or die "Cannot delete event type of " . ref($event) . "!";
|
||||
if (!$event) { # we got passed nothing, so return the first event
|
||||
$event = $self->head();
|
||||
delete $self->queue->{$event->id};
|
||||
$result = $event;
|
||||
} elsif (!ref($event)) { # we got passed an id
|
||||
$result = $self->queue->{$event};
|
||||
delete $self->queue->{$event};
|
||||
} else { # we got passed an actual event object
|
||||
ref($event) eq 'PBot::IRC::EventQueue::Entry' # pragma_ 2011/21/01
|
||||
or die "Cannot delete event type of " . ref($event) . "!";
|
||||
|
||||
$result = $self->queue->{$event->id};
|
||||
delete $self->queue->{$event->id};
|
||||
}
|
||||
$result = $self->queue->{$event->id};
|
||||
delete $self->queue->{$event->id};
|
||||
}
|
||||
|
||||
return $result;
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub head {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
return undef if $self->is_empty;
|
||||
return undef if $self->is_empty;
|
||||
|
||||
no warnings; # because we want to numerically sort strings...
|
||||
my $headkey = (sort {$a <=> $b} (keys(%{$self->queue})))[0];
|
||||
use warnings;
|
||||
no warnings; # because we want to numerically sort strings...
|
||||
my $headkey = (sort { $a <=> $b } (keys(%{$self->queue})))[0];
|
||||
use warnings;
|
||||
|
||||
return $self->queue->{$headkey};
|
||||
return $self->queue->{$headkey};
|
||||
}
|
||||
|
||||
sub is_empty {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
return keys(%{$self->queue}) ? 0 : 1;
|
||||
return keys(%{$self->queue}) ? 0 : 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
package PBot::IRC::EventQueue::Entry; # pragma_ 2011/21/01
|
||||
package PBot::IRC::EventQueue::Entry; # pragma_ 2011/21/01
|
||||
|
||||
use strict;
|
||||
|
||||
|
|
@ -7,35 +7,35 @@ use feature 'unicode_strings';
|
|||
my $id = 0;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $time = shift;
|
||||
my $content = shift;
|
||||
my $class = shift;
|
||||
my $time = shift;
|
||||
my $content = shift;
|
||||
|
||||
my $self = {
|
||||
'time' => $time,
|
||||
'content' => $content,
|
||||
'id' => "$time:" . $id++,
|
||||
};
|
||||
my $self = {
|
||||
'time' => $time,
|
||||
'content' => $content,
|
||||
'id' => "$time:" . $id++,
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub id {
|
||||
my $self = shift;
|
||||
return $self->{'id'};
|
||||
my $self = shift;
|
||||
return $self->{'id'};
|
||||
}
|
||||
|
||||
sub time {
|
||||
my $self = shift;
|
||||
$self->{'time'} = $_[0] if @_;
|
||||
return $self->{'time'};
|
||||
my $self = shift;
|
||||
$self->{'time'} = $_[0] if @_;
|
||||
return $self->{'time'};
|
||||
}
|
||||
|
||||
sub content {
|
||||
my $self = shift;
|
||||
$self->{'content'} = $_[0] if @_;
|
||||
return $self->{'content'};
|
||||
my $self = shift;
|
||||
$self->{'content'} = $_[0] if @_;
|
||||
return $self->{'content'};
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -8,6 +8,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::IgnoreList;
|
||||
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -17,135 +18,123 @@ use PBot::IgnoreListCommands;
|
|||
use Time::HiRes qw(gettimeofday);
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{filename} = $conf{filename};
|
||||
my ($self, %conf) = @_;
|
||||
$self->{filename} = $conf{filename};
|
||||
|
||||
$self->{ignore_list} = {};
|
||||
$self->{ignore_flood_counter} = {};
|
||||
$self->{last_timestamp} = {};
|
||||
$self->{ignore_list} = {};
|
||||
$self->{ignore_flood_counter} = {};
|
||||
$self->{last_timestamp} = {};
|
||||
|
||||
$self->{commands} = PBot::IgnoreListCommands->new(pbot => $self->{pbot});
|
||||
$self->load_ignores();
|
||||
$self->{commands} = PBot::IgnoreListCommands->new(pbot => $self->{pbot});
|
||||
$self->load_ignores();
|
||||
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_ignore_timeouts }, 10);
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_ignore_timeouts }, 10);
|
||||
}
|
||||
|
||||
sub add {
|
||||
my $self = shift;
|
||||
my ($hostmask, $channel, $length) = @_;
|
||||
my $self = shift;
|
||||
my ($hostmask, $channel, $length) = @_;
|
||||
|
||||
if ($length < 0) {
|
||||
$self->{ignore_list}->{$hostmask}->{$channel} = -1;
|
||||
} else {
|
||||
$self->{ignore_list}->{$hostmask}->{$channel} = gettimeofday + $length;
|
||||
}
|
||||
if ($length < 0) { $self->{ignore_list}->{$hostmask}->{$channel} = -1; }
|
||||
else { $self->{ignore_list}->{$hostmask}->{$channel} = gettimeofday + $length; }
|
||||
|
||||
$self->save_ignores();
|
||||
$self->save_ignores();
|
||||
}
|
||||
|
||||
sub remove {
|
||||
my $self = shift;
|
||||
my ($hostmask, $channel) = @_;
|
||||
my $self = shift;
|
||||
my ($hostmask, $channel) = @_;
|
||||
|
||||
delete $self->{ignore_list}->{$hostmask}->{$channel};
|
||||
delete $self->{ignore_list}->{$hostmask}->{$channel};
|
||||
|
||||
if (not keys %{ $self->{ignore_list}->{$hostmask} }) {
|
||||
delete $self->{ignore_list}->{$hostmask};
|
||||
}
|
||||
if (not keys %{$self->{ignore_list}->{$hostmask}}) { delete $self->{ignore_list}->{$hostmask}; }
|
||||
|
||||
$self->save_ignores();
|
||||
$self->save_ignores();
|
||||
}
|
||||
|
||||
sub clear_ignores {
|
||||
my $self = shift;
|
||||
$self->{ignore_list} = {};
|
||||
my $self = shift;
|
||||
$self->{ignore_list} = {};
|
||||
}
|
||||
|
||||
sub load_ignores {
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
|
||||
if (@_) { $filename = shift; } else { $filename = $self->{filename}; }
|
||||
if (@_) { $filename = shift; }
|
||||
else { $filename = $self->{filename}; }
|
||||
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No ignorelist path specified -- skipping loading of ignorelist";
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Loading ignorelist from $filename ...\n");
|
||||
|
||||
open(FILE, "< $filename") or Carp::croak "Couldn't open $filename: $!\n";
|
||||
my @contents = <FILE>;
|
||||
close(FILE);
|
||||
|
||||
my $i = 0;
|
||||
|
||||
foreach my $line (@contents) {
|
||||
chomp $line;
|
||||
$i++;
|
||||
|
||||
my ($hostmask, $channel, $length) = split(/\s+/, $line);
|
||||
|
||||
if (not defined $hostmask || not defined $channel || not defined $length) {
|
||||
Carp::croak "Syntax error around line $i of $filename\n";
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No ignorelist path specified -- skipping loading of ignorelist";
|
||||
return;
|
||||
}
|
||||
|
||||
if (exists ${ $self->{ignore_list} }{$hostmask}{$channel}) {
|
||||
Carp::croak "Duplicate ignore [$hostmask][$channel] found in $filename around line $i\n";
|
||||
$self->{pbot}->{logger}->log("Loading ignorelist from $filename ...\n");
|
||||
|
||||
open(FILE, "< $filename") or Carp::croak "Couldn't open $filename: $!\n";
|
||||
my @contents = <FILE>;
|
||||
close(FILE);
|
||||
|
||||
my $i = 0;
|
||||
|
||||
foreach my $line (@contents) {
|
||||
chomp $line;
|
||||
$i++;
|
||||
|
||||
my ($hostmask, $channel, $length) = split(/\s+/, $line);
|
||||
|
||||
if (not defined $hostmask || not defined $channel || not defined $length) { Carp::croak "Syntax error around line $i of $filename\n"; }
|
||||
|
||||
if (exists ${$self->{ignore_list}}{$hostmask}{$channel}) { Carp::croak "Duplicate ignore [$hostmask][$channel] found in $filename around line $i\n"; }
|
||||
|
||||
$self->{ignore_list}->{$hostmask}->{$channel} = $length;
|
||||
}
|
||||
|
||||
$self->{ignore_list}->{$hostmask}->{$channel} = $length;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log(" $i entries in ignorelist\n");
|
||||
$self->{pbot}->{logger}->log(" $i entries in ignorelist\n");
|
||||
}
|
||||
|
||||
sub save_ignores {
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
|
||||
if (@_) { $filename = shift; } else { $filename = $self->{filename}; }
|
||||
if (@_) { $filename = shift; }
|
||||
else { $filename = $self->{filename}; }
|
||||
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No ignorelist path specified -- skipping saving of ignorelist\n";
|
||||
return;
|
||||
}
|
||||
|
||||
open(FILE, "> $filename") or die "Couldn't open $filename: $!\n";
|
||||
|
||||
foreach my $hostmask (keys %{ $self->{ignore_list} }) {
|
||||
foreach my $channel (keys %{ $self->{ignore_list}->{$hostmask} }) {
|
||||
my $length = $self->{ignore_list}->{$hostmask}->{$channel};
|
||||
print FILE "$hostmask $channel $length\n";
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No ignorelist path specified -- skipping saving of ignorelist\n";
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
close(FILE);
|
||||
open(FILE, "> $filename") or die "Couldn't open $filename: $!\n";
|
||||
|
||||
foreach my $hostmask (keys %{$self->{ignore_list}}) {
|
||||
foreach my $channel (keys %{$self->{ignore_list}->{$hostmask}}) {
|
||||
my $length = $self->{ignore_list}->{$hostmask}->{$channel};
|
||||
print FILE "$hostmask $channel $length\n";
|
||||
}
|
||||
}
|
||||
|
||||
close(FILE);
|
||||
}
|
||||
|
||||
sub check_ignore {
|
||||
my $self = shift;
|
||||
my ($nick, $user, $host, $channel, $silent) = @_;
|
||||
my $pbot = $self->{pbot};
|
||||
$channel = lc $channel;
|
||||
my $self = shift;
|
||||
my ($nick, $user, $host, $channel, $silent) = @_;
|
||||
my $pbot = $self->{pbot};
|
||||
$channel = lc $channel;
|
||||
|
||||
my $hostmask = "$nick!$user\@$host";
|
||||
my $hostmask = "$nick!$user\@$host";
|
||||
|
||||
my $now = gettimeofday;
|
||||
my $now = gettimeofday;
|
||||
|
||||
if (defined $channel) { # do not execute following if text is coming from STDIN ($channel undef)
|
||||
if ($channel =~ /^#/) {
|
||||
$self->{ignore_flood_counter}->{$channel}++;
|
||||
}
|
||||
if (defined $channel) { # do not execute following if text is coming from STDIN ($channel undef)
|
||||
if ($channel =~ /^#/) { $self->{ignore_flood_counter}->{$channel}++; }
|
||||
|
||||
if (not exists $self->{last_timestamp}->{$channel}) {
|
||||
$self->{last_timestamp}->{$channel} = $now;
|
||||
} elsif ($now - $self->{last_timestamp}->{$channel} >= 30) {
|
||||
$self->{last_timestamp}->{$channel} = $now;
|
||||
if (exists $self->{ignore_flood_counter}->{$channel} and $self->{ignore_flood_counter}->{$channel} > 0) {
|
||||
$self->{ignore_flood_counter}->{$channel} = 0;
|
||||
}
|
||||
}
|
||||
if (not exists $self->{last_timestamp}->{$channel}) { $self->{last_timestamp}->{$channel} = $now; }
|
||||
elsif ($now - $self->{last_timestamp}->{$channel} >= 30) {
|
||||
$self->{last_timestamp}->{$channel} = $now;
|
||||
if (exists $self->{ignore_flood_counter}->{$channel} and $self->{ignore_flood_counter}->{$channel} > 0) { $self->{ignore_flood_counter}->{$channel} = 0; }
|
||||
}
|
||||
|
||||
=cut
|
||||
if (exists $self->{ignore_flood_counter}->{$channel} and $self->{ignore_flood_counter}->{$channel} > 5) {
|
||||
|
|
@ -158,42 +147,41 @@ sub check_ignore {
|
|||
}
|
||||
}
|
||||
=cut
|
||||
}
|
||||
|
||||
foreach my $ignored (keys %{ $self->{ignore_list} }) {
|
||||
foreach my $ignored_channel (keys %{ $self->{ignore_list}->{$ignored} }) {
|
||||
my $ignored_channel_escaped = quotemeta $ignored_channel;
|
||||
my $ignored_escaped = quotemeta $ignored;
|
||||
|
||||
$ignored_channel_escaped =~ s/\\(\.|\*)/$1/g;
|
||||
$ignored_escaped =~ s/\\(\.|\*)/$1/g;
|
||||
|
||||
if (($channel =~ /$ignored_channel_escaped/i) && ($hostmask =~ /$ignored_escaped/i)) {
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host message ignored in channel $channel (matches [$ignored] host and [$ignored_channel] channel)\n") unless $silent;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
|
||||
foreach my $ignored (keys %{$self->{ignore_list}}) {
|
||||
foreach my $ignored_channel (keys %{$self->{ignore_list}->{$ignored}}) {
|
||||
my $ignored_channel_escaped = quotemeta $ignored_channel;
|
||||
my $ignored_escaped = quotemeta $ignored;
|
||||
|
||||
$ignored_channel_escaped =~ s/\\(\.|\*)/$1/g;
|
||||
$ignored_escaped =~ s/\\(\.|\*)/$1/g;
|
||||
|
||||
if (($channel =~ /$ignored_channel_escaped/i) && ($hostmask =~ /$ignored_escaped/i)) {
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host message ignored in channel $channel (matches [$ignored] host and [$ignored_channel] channel)\n") unless $silent;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub check_ignore_timeouts {
|
||||
my $self = shift;
|
||||
my $now = gettimeofday();
|
||||
my $self = shift;
|
||||
my $now = gettimeofday();
|
||||
|
||||
foreach my $hostmask (keys %{ $self->{ignore_list} }) {
|
||||
foreach my $channel (keys %{ $self->{ignore_list}->{$hostmask} }) {
|
||||
next if ($self->{ignore_list}->{$hostmask}->{$channel} == -1); #permanent ignore
|
||||
foreach my $hostmask (keys %{$self->{ignore_list}}) {
|
||||
foreach my $channel (keys %{$self->{ignore_list}->{$hostmask}}) {
|
||||
next if ($self->{ignore_list}->{$hostmask}->{$channel} == -1); #permanent ignore
|
||||
|
||||
if ($self->{ignore_list}->{$hostmask}->{$channel} < $now) {
|
||||
$self->{pbot}->{logger}->log("Unignoring $hostmask in channel $channel.\n");
|
||||
$self->remove($hostmask, $channel);
|
||||
if ($hostmask eq ".*") {
|
||||
$self->{pbot}->{conn}->me($channel, "awakens.");
|
||||
if ($self->{ignore_list}->{$hostmask}->{$channel} < $now) {
|
||||
$self->{pbot}->{logger}->log("Unignoring $hostmask in channel $channel.\n");
|
||||
$self->remove($hostmask, $channel);
|
||||
if ($hostmask eq ".*") { $self->{pbot}->{conn}->me($channel, "awakens."); }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::IgnoreListCommands;
|
||||
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -17,83 +18,81 @@ use Time::HiRes qw(gettimeofday);
|
|||
use Time::Duration;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->ignore_user(@_) }, "ignore", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->unignore_user(@_) }, "unignore", 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-ignore', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-unignore', 1);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->ignore_user(@_) }, "ignore", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->unignore_user(@_) }, "unignore", 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-ignore', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-unignore', 1);
|
||||
}
|
||||
|
||||
sub ignore_user {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
|
||||
return "Usage: ignore <hostmask> [channel [timeout]]" if not defined $arguments;
|
||||
return "Usage: ignore <hostmask> [channel [timeout]]" if not defined $arguments;
|
||||
|
||||
my ($target, $channel, $length) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3);
|
||||
my ($target, $channel, $length) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3);
|
||||
|
||||
if (not defined $target) {
|
||||
return "Usage: ignore <hostmask> [channel [timeout]]";
|
||||
}
|
||||
if (not defined $target) { return "Usage: ignore <hostmask> [channel [timeout]]"; }
|
||||
|
||||
if ($target =~ /^list$/i) {
|
||||
my $text = "Ignored: ";
|
||||
my $sep = "";
|
||||
if ($target =~ /^list$/i) {
|
||||
my $text = "Ignored: ";
|
||||
my $sep = "";
|
||||
|
||||
foreach my $ignored (sort keys %{ $self->{pbot}->{ignorelist}->{ignore_list} }) {
|
||||
foreach my $channel (sort keys %{ ${ $self->{pbot}->{ignorelist}->{ignore_list} }{$ignored} }) {
|
||||
$text .= $sep . "$ignored [$channel] " . ($self->{pbot}->{ignorelist}->{ignore_list}->{$ignored}->{$channel} < 0 ? "perm" : duration($self->{pbot}->{ignorelist}->{ignore_list}->{$ignored}->{$channel} - gettimeofday));
|
||||
$sep = ";\n";
|
||||
}
|
||||
foreach my $ignored (sort keys %{$self->{pbot}->{ignorelist}->{ignore_list}}) {
|
||||
foreach my $channel (sort keys %{${$self->{pbot}->{ignorelist}->{ignore_list}}{$ignored}}) {
|
||||
$text .=
|
||||
$sep
|
||||
. "$ignored [$channel] "
|
||||
. (
|
||||
$self->{pbot}->{ignorelist}->{ignore_list}->{$ignored}->{$channel} < 0
|
||||
? "perm"
|
||||
: duration($self->{pbot}->{ignorelist}->{ignore_list}->{$ignored}->{$channel} - gettimeofday)
|
||||
);
|
||||
$sep = ";\n";
|
||||
}
|
||||
}
|
||||
return "/msg $nick $text";
|
||||
}
|
||||
return "/msg $nick $text";
|
||||
}
|
||||
|
||||
if (not defined $channel) {
|
||||
$channel = ".*"; # all channels
|
||||
}
|
||||
if (not defined $channel) {
|
||||
$channel = ".*"; # all channels
|
||||
}
|
||||
|
||||
if (not defined $length) {
|
||||
$length = -1; # permanently
|
||||
} else {
|
||||
my $error;
|
||||
($length, $error) = $self->{pbot}->{parsedate}->parsedate($length);
|
||||
return $error if defined $error;
|
||||
}
|
||||
if (not defined $length) {
|
||||
$length = -1; # permanently
|
||||
} else {
|
||||
my $error;
|
||||
($length, $error) = $self->{pbot}->{parsedate}->parsedate($length);
|
||||
return $error if defined $error;
|
||||
}
|
||||
|
||||
$self->{pbot}->{ignorelist}->add($target, $channel, $length);
|
||||
$self->{pbot}->{ignorelist}->add($target, $channel, $length);
|
||||
|
||||
if ($length >= 0) {
|
||||
$length = "for " . duration($length);
|
||||
} else {
|
||||
$length = "permanently";
|
||||
}
|
||||
if ($length >= 0) { $length = "for " . duration($length); }
|
||||
else { $length = "permanently"; }
|
||||
|
||||
$self->{pbot}->{logger}->log("$nick added [$target][$channel] to ignore list $length\n");
|
||||
return "/msg $nick [$target][$channel] added to ignore list $length";
|
||||
$self->{pbot}->{logger}->log("$nick added [$target][$channel] to ignore list $length\n");
|
||||
return "/msg $nick [$target][$channel] added to ignore list $length";
|
||||
}
|
||||
|
||||
sub unignore_user {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($target, $channel) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($target, $channel) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
|
||||
if (not defined $target) {
|
||||
return "Usage: unignore <hostmask> [channel]";
|
||||
}
|
||||
if (not defined $target) { return "Usage: unignore <hostmask> [channel]"; }
|
||||
|
||||
if (not defined $channel) {
|
||||
$channel = ".*";
|
||||
}
|
||||
if (not defined $channel) { $channel = ".*"; }
|
||||
|
||||
if (exists $self->{pbot}->{ignorelist}->{ignore_list}->{$target} and not exists $self->{pbot}->{ignorelist}->{ignore_list}->{$target}->{$channel}) {
|
||||
$self->{pbot}->{logger}->log("$nick attempt to remove nonexistent [$target][$channel] from ignore list\n");
|
||||
return "/msg $nick [$target][$channel] not found in ignore list (use `ignore list` to list ignores)";
|
||||
}
|
||||
if (exists $self->{pbot}->{ignorelist}->{ignore_list}->{$target} and not exists $self->{pbot}->{ignorelist}->{ignore_list}->{$target}->{$channel}) {
|
||||
$self->{pbot}->{logger}->log("$nick attempt to remove nonexistent [$target][$channel] from ignore list\n");
|
||||
return "/msg $nick [$target][$channel] not found in ignore list (use `ignore list` to list ignores)";
|
||||
}
|
||||
|
||||
$self->{pbot}->{ignorelist}->remove($target, $channel);
|
||||
$self->{pbot}->{logger}->log("$nick removed [$target][$channel] from ignore list\n");
|
||||
return "/msg $nick [$target][$channel] unignored";
|
||||
$self->{pbot}->{ignorelist}->remove($target, $channel);
|
||||
$self->{pbot}->{logger}->log("$nick removed [$target][$channel] from ignore list\n");
|
||||
return "/msg $nick [$target][$channel] unignored";
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
1683
PBot/Interpreter.pm
1683
PBot/Interpreter.pm
File diff suppressed because it is too large
Load Diff
|
|
@ -9,6 +9,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::LagChecker;
|
||||
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -18,127 +19,131 @@ use Time::HiRes qw(gettimeofday tv_interval);
|
|||
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
|
||||
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
|
||||
|
||||
# maximum number of lag history entries to retain
|
||||
$self->{pbot}->{registry}->add_default('text', 'lagchecker', 'lag_history_max', $conf{lag_history_max} // 3);
|
||||
# lagging is true if lag_average reaches or exceeds this threshold, in milliseconds
|
||||
$self->{pbot}->{registry}->add_default('text', 'lagchecker', 'lag_threshold', $conf{lag_threshhold} // 2000);
|
||||
# how often to send PING, in seconds
|
||||
$self->{pbot}->{registry}->add_default('text', 'lagchecker', 'lag_history_interval', $conf{lag_history_interval} // 10);
|
||||
# maximum number of lag history entries to retain
|
||||
$self->{pbot}->{registry}->add_default('text', 'lagchecker', 'lag_history_max', $conf{lag_history_max} // 3);
|
||||
|
||||
$self->{pbot}->{registry}->add_trigger('lagchecker', 'lag_history_interval', sub { $self->lag_history_interval_trigger(@_) });
|
||||
# lagging is true if lag_average reaches or exceeds this threshold, in milliseconds
|
||||
$self->{pbot}->{registry}->add_default('text', 'lagchecker', 'lag_threshold', $conf{lag_threshhold} // 2000);
|
||||
|
||||
$self->{pbot}->{timer}->register(
|
||||
sub { $self->send_ping },
|
||||
$self->{pbot}->{registry}->get_value('lagchecker', 'lag_history_interval'),
|
||||
'lag_history_interval'
|
||||
);
|
||||
# how often to send PING, in seconds
|
||||
$self->{pbot}->{registry}->add_default('text', 'lagchecker', 'lag_history_interval', $conf{lag_history_interval} // 10);
|
||||
|
||||
$self->{pbot}->{commands}->register(sub { $self->lagcheck(@_) }, "lagcheck", 0);
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.pong', sub { $self->on_pong(@_) });
|
||||
$self->{pbot}->{registry}->add_trigger('lagchecker', 'lag_history_interval', sub { $self->lag_history_interval_trigger(@_) });
|
||||
|
||||
$self->{pbot}->{timer}->register(
|
||||
sub { $self->send_ping },
|
||||
$self->{pbot}->{registry}->get_value('lagchecker', 'lag_history_interval'),
|
||||
'lag_history_interval'
|
||||
);
|
||||
|
||||
$self->{pbot}->{commands}->register(sub { $self->lagcheck(@_) }, "lagcheck", 0);
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.pong', sub { $self->on_pong(@_) });
|
||||
}
|
||||
|
||||
sub lag_history_interval_trigger {
|
||||
my ($self, $section, $item, $newvalue) = @_;
|
||||
$self->{pbot}->{timer}->update_interval('lag_history_interval', $newvalue);
|
||||
my ($self, $section, $item, $newvalue) = @_;
|
||||
$self->{pbot}->{timer}->update_interval('lag_history_interval', $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");
|
||||
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;
|
||||
my $self = shift;
|
||||
|
||||
$self->{pong_received} = 1;
|
||||
$self->{pong_received} = 1;
|
||||
|
||||
my $elapsed = tv_interval($self->{ping_send_time});
|
||||
push @{$self->{lag_history}}, [ $self->{ping_send_time}[0], $elapsed * 1000];
|
||||
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 $len = @{$self->{lag_history}};
|
||||
|
||||
my $lag_history_max = $self->{pbot}->{registry}->get_value('lagchecker', 'lag_history_max');
|
||||
my $lag_history_max = $self->{pbot}->{registry}->get_value('lagchecker', 'lag_history_max');
|
||||
|
||||
while ($len > $lag_history_max) {
|
||||
shift @{$self->{lag_history}};
|
||||
$len--;
|
||||
}
|
||||
while ($len > $lag_history_max) {
|
||||
shift @{$self->{lag_history}};
|
||||
$len--;
|
||||
}
|
||||
|
||||
$self->{lag_string} = "";
|
||||
my $comma = "";
|
||||
$self->{lag_string} = "";
|
||||
my $comma = "";
|
||||
|
||||
my $lag_total = 0;
|
||||
foreach my $entry (@{$self->{lag_history}}) {
|
||||
my ($send_time, $lag_result) = @$entry;
|
||||
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 = "; ";
|
||||
}
|
||||
$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;
|
||||
$self->{lag_average} = $lag_total / $len;
|
||||
$self->{lag_string} .= "; average: " . sprintf "%.1f ms", $self->{lag_average};
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub lagging {
|
||||
my $self = shift;
|
||||
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');
|
||||
}
|
||||
if (defined $self->{pong_received} and $self->{pong_received} == 0) {
|
||||
|
||||
return 0 if not defined $self->{lag_average};
|
||||
return $self->{lag_average} >= $self->{pbot}->{registry}->get_value('lagchecker', 'lag_threshold');
|
||||
# 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;
|
||||
my $self = shift;
|
||||
my $lag = $self->{lag_string} || "initializing";
|
||||
return $lag;
|
||||
}
|
||||
|
||||
sub lagcheck {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
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});
|
||||
my $lag_total = $elapsed;
|
||||
my $len = @{$self->{lag_history}};
|
||||
if (defined $self->{pong_received} and $self->{pong_received} == 0) {
|
||||
|
||||
my $lagstring = "";
|
||||
my $comma = "";
|
||||
# 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});
|
||||
my $lag_total = $elapsed;
|
||||
my $len = @{$self->{lag_history}};
|
||||
|
||||
foreach my $entry (@{$self->{lag_history}}) {
|
||||
my ($send_time, $lag_result) = @$entry;
|
||||
$lag_total += $lag_result;
|
||||
my $ago = concise ago(gettimeofday - $send_time);
|
||||
$lagstring .= $comma . "[$ago] " . sprintf "%.1f ms", $lag_result;
|
||||
$comma = "; ";
|
||||
}
|
||||
my $lagstring = "";
|
||||
my $comma = "";
|
||||
|
||||
$lagstring .= $comma . "[waiting for pong] $elapsed";
|
||||
foreach my $entry (@{$self->{lag_history}}) {
|
||||
my ($send_time, $lag_result) = @$entry;
|
||||
$lag_total += $lag_result;
|
||||
my $ago = concise ago(gettimeofday - $send_time);
|
||||
$lagstring .= $comma . "[$ago] " . sprintf "%.1f ms", $lag_result;
|
||||
$comma = "; ";
|
||||
}
|
||||
|
||||
my $average = $lag_total / ($len + 1);
|
||||
$lagstring .= "; average: " . sprintf "%.1f ms", $average;
|
||||
return $lagstring;
|
||||
}
|
||||
$lagstring .= $comma . "[waiting for pong] $elapsed";
|
||||
|
||||
return "My lag: " . $self->lagstring;
|
||||
my $average = $lag_total / ($len + 1);
|
||||
$lagstring .= "; average: " . sprintf "%.1f ms", $average;
|
||||
return $lagstring;
|
||||
}
|
||||
|
||||
return "My lag: " . $self->lagstring;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -11,55 +11,56 @@ use Scalar::Util qw/openhandle/;
|
|||
use File::Basename;
|
||||
|
||||
sub new {
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
Carp::croak("Missing pbot reference to " . __FILE__) unless exists $conf{pbot};
|
||||
$self->{pbot} = $conf{pbot};
|
||||
print "Initializing " . __PACKAGE__ . "\n" unless $self->{pbot}->{overrides}->{'general.daemon'};
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
Carp::croak("Missing pbot reference to " . __FILE__) unless exists $conf{pbot};
|
||||
$self->{pbot} = $conf{pbot};
|
||||
print "Initializing " . __PACKAGE__ . "\n" unless $self->{pbot}->{overrides}->{'general.daemon'};
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{logfile} = $conf{filename} // Carp::croak "Missing logfile parameter in " . __FILE__;
|
||||
$self->{start} = time;
|
||||
my ($self, %conf) = @_;
|
||||
$self->{logfile} = $conf{filename} // Carp::croak "Missing logfile parameter in " . __FILE__;
|
||||
$self->{start} = time;
|
||||
|
||||
my $path = dirname $self->{logfile};
|
||||
if (not -d $path) {
|
||||
print "Creating new logfile path: $path\n" unless $self->{pbot}->{overrides}->{'general.daemon'};
|
||||
mkdir $path or Carp::croak "Couldn't create logfile path: $!\n";
|
||||
}
|
||||
my $path = dirname $self->{logfile};
|
||||
if (not -d $path) {
|
||||
print "Creating new logfile path: $path\n" unless $self->{pbot}->{overrides}->{'general.daemon'};
|
||||
mkdir $path or Carp::croak "Couldn't create logfile path: $!\n";
|
||||
}
|
||||
|
||||
open LOGFILE, ">>$self->{logfile}" or Carp::croak "Couldn't open logfile $self->{logfile}: $!\n";
|
||||
LOGFILE->autoflush(1);
|
||||
open LOGFILE, ">>$self->{logfile}" or Carp::croak "Couldn't open logfile $self->{logfile}: $!\n";
|
||||
LOGFILE->autoflush(1);
|
||||
|
||||
$self->{pbot}->{atexit}->register(sub { $self->rotate_log; return; });
|
||||
return $self;
|
||||
$self->{pbot}->{atexit}->register(sub { $self->rotate_log; return; });
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub log {
|
||||
my ($self, $text) = @_;
|
||||
my $time = localtime;
|
||||
$text =~ s/(\P{PosixGraph})/my $ch = $1; if ($ch =~ m{[\s]}) { $ch } else { sprintf "\\x%02X", ord $ch }/ge;
|
||||
print LOGFILE "$time :: $text" if openhandle *LOGFILE;
|
||||
print "$time :: $text" unless $self->{pbot}->{overrides}->{'general.daemon'};
|
||||
my ($self, $text) = @_;
|
||||
my $time = localtime;
|
||||
$text =~ s/(\P{PosixGraph})/my $ch = $1; if ($ch =~ m{[\s]}) { $ch } else { sprintf "\\x%02X", ord $ch }/ge;
|
||||
print LOGFILE "$time :: $text" if openhandle * LOGFILE;
|
||||
print "$time :: $text" unless $self->{pbot}->{overrides}->{'general.daemon'};
|
||||
}
|
||||
|
||||
sub rotate_log {
|
||||
my ($self) = @_;
|
||||
my $time = localtime $self->{start};
|
||||
$time =~ s/\s+/_/g;
|
||||
my ($self) = @_;
|
||||
my $time = localtime $self->{start};
|
||||
$time =~ s/\s+/_/g;
|
||||
|
||||
$self->log("Rotating log to $self->{logfile}-$time\n");
|
||||
# logfile has to be closed first for maximum compatibility with `rename`
|
||||
close LOGFILE;
|
||||
rename $self->{logfile}, $self->{logfile} . '-' . $time;
|
||||
$self->log("Rotating log to $self->{logfile}-$time\n");
|
||||
|
||||
# reopen renamed logfile to resume any needed logging
|
||||
open LOGFILE, ">>$self->{logfile}-$time" or Carp::carp "Couldn't re-open logfile $self->{logfile}-$time: $!\n";
|
||||
LOGFILE->autoflush(1) if openhandle *LOGFILE;
|
||||
# logfile has to be closed first for maximum compatibility with `rename`
|
||||
close LOGFILE;
|
||||
rename $self->{logfile}, $self->{logfile} . '-' . $time;
|
||||
|
||||
# reopen renamed logfile to resume any needed logging
|
||||
open LOGFILE, ">>$self->{logfile}-$time" or Carp::carp "Couldn't re-open logfile $self->{logfile}-$time: $!\n";
|
||||
LOGFILE->autoflush(1) if openhandle * LOGFILE;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::MessageHistory;
|
||||
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -24,392 +25,355 @@ use Time::Duration;
|
|||
use PBot::MessageHistory_SQLite;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{filename} = $conf{filename} // $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/message_history.sqlite3';
|
||||
my ($self, %conf) = @_;
|
||||
$self->{filename} = $conf{filename} // $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/message_history.sqlite3';
|
||||
|
||||
$self->{database} = PBot::MessageHistory_SQLite->new(pbot => $self->{pbot}, filename => $self->{filename});
|
||||
$self->{database}->begin();
|
||||
$self->{database}->devalidate_all_channels();
|
||||
$self->{database} = PBot::MessageHistory_SQLite->new(pbot => $self->{pbot}, filename => $self->{filename});
|
||||
$self->{database}->begin();
|
||||
$self->{database}->devalidate_all_channels();
|
||||
|
||||
$self->{MSG_CHAT} = 0; # PRIVMSG, ACTION
|
||||
$self->{MSG_JOIN} = 1; # JOIN
|
||||
$self->{MSG_DEPARTURE} = 2; # PART, QUIT, KICK
|
||||
$self->{MSG_NICKCHANGE} = 3; # CHANGED NICK
|
||||
$self->{MSG_CHAT} = 0; # PRIVMSG, ACTION
|
||||
$self->{MSG_JOIN} = 1; # JOIN
|
||||
$self->{MSG_DEPARTURE} = 2; # PART, QUIT, KICK
|
||||
$self->{MSG_NICKCHANGE} = 3; # CHANGED NICK
|
||||
|
||||
$self->{pbot}->{registry}->add_default('text', 'messagehistory', 'max_recall_time', $conf{max_recall_time} // 0);
|
||||
$self->{pbot}->{registry}->add_default('text', 'messagehistory', 'max_messages', 32);
|
||||
$self->{pbot}->{registry}->add_default('text', 'messagehistory', 'max_recall_time', $conf{max_recall_time} // 0);
|
||||
$self->{pbot}->{registry}->add_default('text', 'messagehistory', 'max_messages', 32);
|
||||
|
||||
$self->{pbot}->{commands}->register(sub { $self->recall_message(@_) }, "recall", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->list_also_known_as(@_) }, "aka", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->rebuild_aliases(@_) }, "rebuildaliases", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->aka_link(@_) }, "akalink", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->aka_unlink(@_) }, "akaunlink", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->recall_message(@_) }, "recall", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->list_also_known_as(@_) }, "aka", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->rebuild_aliases(@_) }, "rebuildaliases", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->aka_link(@_) }, "akalink", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->aka_unlink(@_) }, "akaunlink", 1);
|
||||
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-akalink', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-akaunlink', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-akalink', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-akaunlink', 1);
|
||||
|
||||
$self->{pbot}->{atexit}->register(sub { $self->{database}->end(); return; });
|
||||
$self->{pbot}->{atexit}->register(sub { $self->{database}->end(); return; });
|
||||
}
|
||||
|
||||
sub get_message_account {
|
||||
my ($self, $nick, $user, $host) = @_;
|
||||
return $self->{database}->get_message_account($nick, $user, $host);
|
||||
my ($self, $nick, $user, $host) = @_;
|
||||
return $self->{database}->get_message_account($nick, $user, $host);
|
||||
}
|
||||
|
||||
sub add_message {
|
||||
my ($self, $account, $mask, $channel, $text, $mode) = @_;
|
||||
$self->{database}->add_message($account, $mask, $channel, { timestamp => scalar gettimeofday, msg => $text, mode => $mode });
|
||||
my ($self, $account, $mask, $channel, $text, $mode) = @_;
|
||||
$self->{database}->add_message($account, $mask, $channel, {timestamp => scalar gettimeofday, msg => $text, mode => $mode});
|
||||
}
|
||||
|
||||
sub rebuild_aliases {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
$self->{database}->rebuild_aliases_table;
|
||||
$self->{database}->rebuild_aliases_table;
|
||||
}
|
||||
|
||||
sub aka_link {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
my ($id, $alias, $type) = split /\s+/, $arguments;
|
||||
my ($id, $alias, $type) = split /\s+/, $arguments;
|
||||
|
||||
$type = $self->{database}->{alias_type}->{STRONG} if not defined $type;
|
||||
$type = $self->{database}->{alias_type}->{STRONG} if not defined $type;
|
||||
|
||||
if (not $id or not $alias) {
|
||||
return "Usage: link <target id> <alias id> [type]";
|
||||
}
|
||||
if (not $id or not $alias) { return "Usage: link <target id> <alias id> [type]"; }
|
||||
|
||||
my $source = $self->{database}->find_most_recent_hostmask($id);
|
||||
my $target = $self->{database}->find_most_recent_hostmask($alias);
|
||||
my $source = $self->{database}->find_most_recent_hostmask($id);
|
||||
my $target = $self->{database}->find_most_recent_hostmask($alias);
|
||||
|
||||
if (not $source) {
|
||||
return "No such id $id found.";
|
||||
}
|
||||
if (not $source) { return "No such id $id found."; }
|
||||
|
||||
if (not $target) {
|
||||
return "No such id $alias found.";
|
||||
}
|
||||
if (not $target) { return "No such id $alias found."; }
|
||||
|
||||
if ($self->{database}->link_alias($id, $alias, $type)) {
|
||||
return "/say $source " . ($type == $self->{database}->{alias_type}->{WEAK} ? "weakly" : "strongly") . " linked to $target.";
|
||||
} else {
|
||||
return "Link failed.";
|
||||
}
|
||||
if ($self->{database}->link_alias($id, $alias, $type)) {
|
||||
return "/say $source " . ($type == $self->{database}->{alias_type}->{WEAK} ? "weakly" : "strongly") . " linked to $target.";
|
||||
} else {
|
||||
return "Link failed.";
|
||||
}
|
||||
}
|
||||
|
||||
sub aka_unlink {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
my ($id, $alias) = split /\s+/, $arguments;
|
||||
my ($id, $alias) = split /\s+/, $arguments;
|
||||
|
||||
if (not $id or not $alias) {
|
||||
return "Usage: unlink <target id> <alias id>";
|
||||
}
|
||||
if (not $id or not $alias) { return "Usage: unlink <target id> <alias id>"; }
|
||||
|
||||
my $source = $self->{database}->find_most_recent_hostmask($id);
|
||||
my $target = $self->{database}->find_most_recent_hostmask($alias);
|
||||
my $source = $self->{database}->find_most_recent_hostmask($id);
|
||||
my $target = $self->{database}->find_most_recent_hostmask($alias);
|
||||
|
||||
if (not $source) {
|
||||
return "No such id $id found.";
|
||||
}
|
||||
if (not $source) { return "No such id $id found."; }
|
||||
|
||||
if (not $target) {
|
||||
return "No such id $alias found.";
|
||||
}
|
||||
if (not $target) { return "No such id $alias found."; }
|
||||
|
||||
if ($self->{database}->unlink_alias($id, $alias)) {
|
||||
return "/say $source unlinked from $target.";
|
||||
} else {
|
||||
return "Unlink failed.";
|
||||
}
|
||||
if ($self->{database}->unlink_alias($id, $alias)) { return "/say $source unlinked from $target."; }
|
||||
else { return "Unlink failed."; }
|
||||
}
|
||||
|
||||
sub list_also_known_as {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
my $usage = "Usage: aka [-hingr] <nick>; -h show hostmasks; -i show ids; -n show nickserv accounts; -g show gecos, -r show relationships";
|
||||
my $usage = "Usage: aka [-hingr] <nick>; -h show hostmasks; -i show ids; -n show nickserv accounts; -g show gecos, -r show relationships";
|
||||
|
||||
if (not length $arguments) {
|
||||
return $usage;
|
||||
}
|
||||
if (not length $arguments) { return $usage; }
|
||||
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
|
||||
Getopt::Long::Configure ("bundling");
|
||||
Getopt::Long::Configure("bundling");
|
||||
|
||||
my ($show_hostmasks, $show_gecos, $show_nickserv, $show_id, $show_relationship, $show_weak, $dont_use_aliases_table);
|
||||
my ($ret, $args) = GetOptionsFromString($arguments,
|
||||
'h' => \$show_hostmasks,
|
||||
'n' => \$show_nickserv,
|
||||
'r' => \$show_relationship,
|
||||
'g' => \$show_gecos,
|
||||
'w' => \$show_weak,
|
||||
'nt' => \$dont_use_aliases_table,
|
||||
'i' => \$show_id);
|
||||
my ($show_hostmasks, $show_gecos, $show_nickserv, $show_id, $show_relationship, $show_weak, $dont_use_aliases_table);
|
||||
my ($ret, $args) = GetOptionsFromString(
|
||||
$arguments,
|
||||
'h' => \$show_hostmasks,
|
||||
'n' => \$show_nickserv,
|
||||
'r' => \$show_relationship,
|
||||
'g' => \$show_gecos,
|
||||
'w' => \$show_weak,
|
||||
'nt' => \$dont_use_aliases_table,
|
||||
'i' => \$show_id
|
||||
);
|
||||
|
||||
return "/say $getopt_error -- $usage" if defined $getopt_error;
|
||||
return "Too many arguments -- $usage" if @$args > 1;
|
||||
return "Missing argument -- $usage" if @$args != 1;
|
||||
return "/say $getopt_error -- $usage" if defined $getopt_error;
|
||||
return "Too many arguments -- $usage" if @$args > 1;
|
||||
return "Missing argument -- $usage" if @$args != 1;
|
||||
|
||||
my %akas = $self->{database}->get_also_known_as(@$args[0], $dont_use_aliases_table);
|
||||
my %akas = $self->{database}->get_also_known_as(@$args[0], $dont_use_aliases_table);
|
||||
|
||||
if (%akas) {
|
||||
my $result = "@$args[0] also known as:\n";
|
||||
if (%akas) {
|
||||
my $result = "@$args[0] also known as:\n";
|
||||
|
||||
my %nicks;
|
||||
my $sep = "";
|
||||
foreach my $aka (sort keys %akas) {
|
||||
next if $aka =~ /^Guest\d+(?:!.*)?$/;
|
||||
next if $akas{$aka}->{type} == $self->{database}->{alias_type}->{WEAK} && not $show_weak;
|
||||
my %nicks;
|
||||
my $sep = "";
|
||||
foreach my $aka (sort keys %akas) {
|
||||
next if $aka =~ /^Guest\d+(?:!.*)?$/;
|
||||
next if $akas{$aka}->{type} == $self->{database}->{alias_type}->{WEAK} && not $show_weak;
|
||||
|
||||
if (not $show_hostmasks) {
|
||||
my ($nick) = $aka =~ m/([^!]+)/;
|
||||
next if exists $nicks{$nick};
|
||||
$nicks{$nick}->{id} = $akas{$aka}->{id};
|
||||
$result .= "$sep$nick";
|
||||
} else {
|
||||
$result .= "$sep$aka";
|
||||
}
|
||||
if (not $show_hostmasks) {
|
||||
my ($nick) = $aka =~ m/([^!]+)/;
|
||||
next if exists $nicks{$nick};
|
||||
$nicks{$nick}->{id} = $akas{$aka}->{id};
|
||||
$result .= "$sep$nick";
|
||||
} else {
|
||||
$result .= "$sep$aka";
|
||||
}
|
||||
|
||||
$result .= "?" if $akas{$aka}->{nickchange} == 1;
|
||||
$result .= " ($akas{$aka}->{nickserv})" if $show_nickserv and exists $akas{$aka}->{nickserv};
|
||||
$result .= " {$akas{$aka}->{gecos}}" if $show_gecos and exists $akas{$aka}->{gecos};
|
||||
$result .= "?" if $akas{$aka}->{nickchange} == 1;
|
||||
$result .= " ($akas{$aka}->{nickserv})" if $show_nickserv and exists $akas{$aka}->{nickserv};
|
||||
$result .= " {$akas{$aka}->{gecos}}" if $show_gecos and exists $akas{$aka}->{gecos};
|
||||
|
||||
if ($show_relationship) {
|
||||
if ($akas{$aka}->{id} == $akas{$aka}->{alias}) {
|
||||
$result .= " [$akas{$aka}->{id}]";
|
||||
} else {
|
||||
$result .= " [$akas{$aka}->{id} -> $akas{$aka}->{alias}]";
|
||||
if ($show_relationship) {
|
||||
if ($akas{$aka}->{id} == $akas{$aka}->{alias}) { $result .= " [$akas{$aka}->{id}]"; }
|
||||
else { $result .= " [$akas{$aka}->{id} -> $akas{$aka}->{alias}]"; }
|
||||
} elsif ($show_id) {
|
||||
$result .= " [$akas{$aka}->{id}]";
|
||||
}
|
||||
|
||||
$result .= " [WEAK]" if $akas{$aka}->{type} == $self->{database}->{alias_type}->{WEAK};
|
||||
|
||||
if ($show_hostmasks or $show_nickserv or $show_gecos or $show_id or $show_relationship) { $sep = ",\n"; }
|
||||
else { $sep = ", "; }
|
||||
}
|
||||
} elsif ($show_id) {
|
||||
$result .= " [$akas{$aka}->{id}]";
|
||||
}
|
||||
|
||||
$result .= " [WEAK]" if $akas{$aka}->{type} == $self->{database}->{alias_type}->{WEAK};
|
||||
|
||||
if ($show_hostmasks or $show_nickserv or $show_gecos or $show_id or $show_relationship) {
|
||||
$sep = ",\n";
|
||||
} else {
|
||||
$sep = ", ";
|
||||
}
|
||||
return $result;
|
||||
} else {
|
||||
return "I don't know anybody named @$args[0].";
|
||||
}
|
||||
return $result;
|
||||
} else {
|
||||
return "I don't know anybody named @$args[0].";
|
||||
}
|
||||
}
|
||||
|
||||
sub recall_message {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
if (not defined $from) {
|
||||
$self->{pbot}->{logger}->log("Command missing ~from parameter!\n");
|
||||
return "";
|
||||
}
|
||||
|
||||
my $usage = 'Usage: recall [nick [history [channel]]] [-c,channel <channel>] [-t,text,h,history <history>] [-b,before <context before>] [-a,after <context after>] [-x,context <nick>] [-n,count <count>] [+ ...]';
|
||||
|
||||
if (not defined $arguments or not length $arguments) {
|
||||
return $usage;
|
||||
}
|
||||
|
||||
$arguments = lc $arguments;
|
||||
|
||||
my @recalls = split /\s\+\s/, $arguments;
|
||||
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
|
||||
my $recall_text = '';
|
||||
Getopt::Long::Configure ("bundling");
|
||||
|
||||
foreach my $recall (@recalls) {
|
||||
my ($recall_nick, $recall_history, $recall_channel, $recall_before, $recall_after, $recall_context, $recall_count);
|
||||
|
||||
my ($ret, $args) = GetOptionsFromString($recall,
|
||||
'channel|c:s' => \$recall_channel,
|
||||
'text|t|history|h:s' => \$recall_history,
|
||||
'before|b:i' => \$recall_before,
|
||||
'after|a:i' => \$recall_after,
|
||||
'count|n:i' => \$recall_count,
|
||||
'context|x:s' => \$recall_context);
|
||||
|
||||
return "/say $getopt_error -- $usage" if defined $getopt_error;
|
||||
|
||||
my $channel_arg = 1 if defined $recall_channel;
|
||||
my $history_arg = 1 if defined $recall_history;
|
||||
|
||||
$recall_nick = shift @$args if @$args;
|
||||
$recall_history = shift @$args if @$args and not defined $recall_history;
|
||||
$recall_channel = "@$args" if @$args and not defined $recall_channel;
|
||||
|
||||
$recall_count = 1 if (not defined $recall_count) || ($recall_count <= 0);
|
||||
return "You may only select a count of up to 50 messages." if $recall_count > 50;
|
||||
|
||||
$recall_before = 0 if not defined $recall_before;
|
||||
$recall_after = 0 if not defined $recall_after;
|
||||
|
||||
# imply -x if -n > 1 and no history
|
||||
if ($recall_count > 1 and not defined $recall_history) {
|
||||
$recall_context = $recall_nick;
|
||||
if (not defined $from) {
|
||||
$self->{pbot}->{logger}->log("Command missing ~from parameter!\n");
|
||||
return "";
|
||||
}
|
||||
|
||||
# make -n behave like -b if -n > 1 and nick is context
|
||||
if ((defined $recall_context or not defined $recall_history) and $recall_count > 1) {
|
||||
$recall_before = $recall_count - 1;
|
||||
$recall_count = 0;
|
||||
}
|
||||
my $usage =
|
||||
'Usage: recall [nick [history [channel]]] [-c,channel <channel>] [-t,text,h,history <history>] [-b,before <context before>] [-a,after <context after>] [-x,context <nick>] [-n,count <count>] [+ ...]';
|
||||
|
||||
if ($recall_before + $recall_after > 200) {
|
||||
return "You may only select up to 200 lines of surrounding context.";
|
||||
}
|
||||
if (not defined $arguments or not length $arguments) { return $usage; }
|
||||
|
||||
if ($recall_count > 1 and ($recall_before > 0 or $recall_after > 0)) {
|
||||
return "The `count` and `context before/after` options cannot be used together.";
|
||||
}
|
||||
$arguments = lc $arguments;
|
||||
|
||||
# swap nick and channel if recall nick looks like channel and channel wasn't specified
|
||||
if (not $channel_arg and $recall_nick =~ m/^#/) {
|
||||
my $temp = $recall_nick;
|
||||
$recall_nick = $recall_channel;
|
||||
$recall_channel = $temp;
|
||||
}
|
||||
my @recalls = split /\s\+\s/, $arguments;
|
||||
|
||||
$recall_history = 1 if not defined $recall_history;
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
|
||||
# swap history and channel if history looks like a channel and neither history or channel were specified
|
||||
if (not $channel_arg and not $history_arg and $recall_history =~ m/^#/) {
|
||||
my $temp = $recall_history;
|
||||
$recall_history = $recall_channel;
|
||||
$recall_channel = $temp;
|
||||
}
|
||||
my $recall_text = '';
|
||||
Getopt::Long::Configure("bundling");
|
||||
|
||||
# skip recall command if recalling self without arguments
|
||||
$recall_history = $nick eq $recall_nick ? 2 : 1 if defined $recall_nick and not defined $recall_history;
|
||||
foreach my $recall (@recalls) {
|
||||
my ($recall_nick, $recall_history, $recall_channel, $recall_before, $recall_after, $recall_context, $recall_count);
|
||||
|
||||
# set history to most recent message if not specified
|
||||
$recall_history = '1' if not defined $recall_history;
|
||||
my ($ret, $args) = GetOptionsFromString(
|
||||
$recall,
|
||||
'channel|c:s' => \$recall_channel,
|
||||
'text|t|history|h:s' => \$recall_history,
|
||||
'before|b:i' => \$recall_before,
|
||||
'after|a:i' => \$recall_after,
|
||||
'count|n:i' => \$recall_count,
|
||||
'context|x:s' => \$recall_context
|
||||
);
|
||||
|
||||
# set channel to current channel if not specified
|
||||
$recall_channel = $from if not defined $recall_channel;
|
||||
return "/say $getopt_error -- $usage" if defined $getopt_error;
|
||||
|
||||
# another sanity check for people using it wrong
|
||||
if ($recall_channel !~ m/^#/) {
|
||||
$recall_history = "$recall_history $recall_channel";
|
||||
$recall_channel = $from;
|
||||
}
|
||||
my $channel_arg = 1 if defined $recall_channel;
|
||||
my $history_arg = 1 if defined $recall_history;
|
||||
|
||||
if (not defined $recall_nick and defined $recall_context) {
|
||||
$recall_nick = $recall_context;
|
||||
}
|
||||
$recall_nick = shift @$args if @$args;
|
||||
$recall_history = shift @$args if @$args and not defined $recall_history;
|
||||
$recall_channel = "@$args" if @$args and not defined $recall_channel;
|
||||
|
||||
my ($account, $found_nick);
|
||||
$recall_count = 1 if (not defined $recall_count) || ($recall_count <= 0);
|
||||
return "You may only select a count of up to 50 messages." if $recall_count > 50;
|
||||
|
||||
if (defined $recall_nick) {
|
||||
($account, $found_nick) = $self->{database}->find_message_account_by_nick($recall_nick);
|
||||
$recall_before = 0 if not defined $recall_before;
|
||||
$recall_after = 0 if not defined $recall_after;
|
||||
|
||||
if (not defined $account) {
|
||||
return "I don't know anybody named $recall_nick.";
|
||||
}
|
||||
# imply -x if -n > 1 and no history
|
||||
if ($recall_count > 1 and not defined $recall_history) { $recall_context = $recall_nick; }
|
||||
|
||||
$found_nick =~ s/!.*$//;
|
||||
}
|
||||
|
||||
my $message;
|
||||
|
||||
if ($recall_history =~ /^\d+$/) {
|
||||
# integral history
|
||||
if (defined $account) {
|
||||
my $max_messages = $self->{database}->get_max_messages($account, $recall_channel);
|
||||
if ($recall_history < 1 || $recall_history > $max_messages) {
|
||||
if ($max_messages == 0) {
|
||||
my @channels = $self->{database}->get_channels($account);
|
||||
my $result = "No messages for $recall_nick in $recall_channel; I have messages for them in ";
|
||||
my $comma = '';
|
||||
my $count = 0;
|
||||
foreach my $channel (sort @channels) {
|
||||
next if $channel !~ /^#/;
|
||||
$result .= "$comma$channel";
|
||||
$comma = ', ';
|
||||
$count++;
|
||||
}
|
||||
if ($count == 0) {
|
||||
return "I have no messages for $recall_nick.";
|
||||
} else {
|
||||
return "/say $result.";
|
||||
}
|
||||
} else {
|
||||
return "Please choose a history between 1 and $max_messages";
|
||||
}
|
||||
# make -n behave like -b if -n > 1 and nick is context
|
||||
if ((defined $recall_context or not defined $recall_history) and $recall_count > 1) {
|
||||
$recall_before = $recall_count - 1;
|
||||
$recall_count = 0;
|
||||
}
|
||||
}
|
||||
|
||||
$recall_history--;
|
||||
$message = $self->{database}->recall_message_by_count($account, $recall_channel, $recall_history, '(?:recall|mock|ftfy|fix)');
|
||||
if ($recall_before + $recall_after > 200) { return "You may only select up to 200 lines of surrounding context."; }
|
||||
|
||||
if (not defined $message) {
|
||||
return "No message found at index $recall_history in channel $recall_channel.";
|
||||
}
|
||||
} else {
|
||||
# regex history
|
||||
$message = $self->{database}->recall_message_by_text($account, $recall_channel, $recall_history, '(?:recall|mock|ftfy|fix)');
|
||||
if ($recall_count > 1 and ($recall_before > 0 or $recall_after > 0)) { return "The `count` and `context before/after` options cannot be used together."; }
|
||||
|
||||
if (not defined $message) {
|
||||
if (defined $account) {
|
||||
return "No message for nick $found_nick in channel $recall_channel containing \"$recall_history\"";
|
||||
# swap nick and channel if recall nick looks like channel and channel wasn't specified
|
||||
if (not $channel_arg and $recall_nick =~ m/^#/) {
|
||||
my $temp = $recall_nick;
|
||||
$recall_nick = $recall_channel;
|
||||
$recall_channel = $temp;
|
||||
}
|
||||
|
||||
$recall_history = 1 if not defined $recall_history;
|
||||
|
||||
# swap history and channel if history looks like a channel and neither history or channel were specified
|
||||
if (not $channel_arg and not $history_arg and $recall_history =~ m/^#/) {
|
||||
my $temp = $recall_history;
|
||||
$recall_history = $recall_channel;
|
||||
$recall_channel = $temp;
|
||||
}
|
||||
|
||||
# skip recall command if recalling self without arguments
|
||||
$recall_history = $nick eq $recall_nick ? 2 : 1 if defined $recall_nick and not defined $recall_history;
|
||||
|
||||
# set history to most recent message if not specified
|
||||
$recall_history = '1' if not defined $recall_history;
|
||||
|
||||
# set channel to current channel if not specified
|
||||
$recall_channel = $from if not defined $recall_channel;
|
||||
|
||||
# another sanity check for people using it wrong
|
||||
if ($recall_channel !~ m/^#/) {
|
||||
$recall_history = "$recall_history $recall_channel";
|
||||
$recall_channel = $from;
|
||||
}
|
||||
|
||||
if (not defined $recall_nick and defined $recall_context) { $recall_nick = $recall_context; }
|
||||
|
||||
my ($account, $found_nick);
|
||||
|
||||
if (defined $recall_nick) {
|
||||
($account, $found_nick) = $self->{database}->find_message_account_by_nick($recall_nick);
|
||||
|
||||
if (not defined $account) { return "I don't know anybody named $recall_nick."; }
|
||||
|
||||
$found_nick =~ s/!.*$//;
|
||||
}
|
||||
|
||||
my $message;
|
||||
|
||||
if ($recall_history =~ /^\d+$/) {
|
||||
|
||||
# integral history
|
||||
if (defined $account) {
|
||||
my $max_messages = $self->{database}->get_max_messages($account, $recall_channel);
|
||||
if ($recall_history < 1 || $recall_history > $max_messages) {
|
||||
if ($max_messages == 0) {
|
||||
my @channels = $self->{database}->get_channels($account);
|
||||
my $result = "No messages for $recall_nick in $recall_channel; I have messages for them in ";
|
||||
my $comma = '';
|
||||
my $count = 0;
|
||||
foreach my $channel (sort @channels) {
|
||||
next if $channel !~ /^#/;
|
||||
$result .= "$comma$channel";
|
||||
$comma = ', ';
|
||||
$count++;
|
||||
}
|
||||
if ($count == 0) { return "I have no messages for $recall_nick."; }
|
||||
else { return "/say $result."; }
|
||||
} else {
|
||||
return "Please choose a history between 1 and $max_messages";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$recall_history--;
|
||||
$message = $self->{database}->recall_message_by_count($account, $recall_channel, $recall_history, '(?:recall|mock|ftfy|fix)');
|
||||
|
||||
if (not defined $message) { return "No message found at index $recall_history in channel $recall_channel."; }
|
||||
} else {
|
||||
return "No message in channel $recall_channel containing \"$recall_history\".";
|
||||
|
||||
# regex history
|
||||
$message = $self->{database}->recall_message_by_text($account, $recall_channel, $recall_history, '(?:recall|mock|ftfy|fix)');
|
||||
|
||||
if (not defined $message) {
|
||||
if (defined $account) { return "No message for nick $found_nick in channel $recall_channel containing \"$recall_history\""; }
|
||||
else { return "No message in channel $recall_channel containing \"$recall_history\"."; }
|
||||
}
|
||||
}
|
||||
|
||||
my $context_account;
|
||||
|
||||
if (defined $recall_context) {
|
||||
($context_account) = $self->{database}->find_message_account_by_nick($recall_context);
|
||||
|
||||
if (not defined $context_account) { return "I don't know anybody named $recall_context."; }
|
||||
}
|
||||
|
||||
my $messages = $self->{database}->get_message_context($message, $recall_before, $recall_after, $recall_count, $recall_history, $context_account);
|
||||
|
||||
my $max_recall_time = $self->{pbot}->{registry}->get_value('messagehistory', 'max_recall_time');
|
||||
|
||||
foreach my $msg (@$messages) {
|
||||
$self->{pbot}->{logger}->log("$nick ($from) recalled <$msg->{nick}/$msg->{channel}> $msg->{msg}\n");
|
||||
|
||||
if ($max_recall_time && gettimeofday - $msg->{timestamp} > $max_recall_time && not $self->{pbot}->{users}->loggedin_admin($from, "$nick!$user\@$host")) {
|
||||
$max_recall_time = duration($max_recall_time);
|
||||
$recall_text .= "Sorry, you can not recall messages older than $max_recall_time.";
|
||||
return $recall_text;
|
||||
}
|
||||
|
||||
my $text = $msg->{msg};
|
||||
my $ago = concise ago(gettimeofday - $msg->{timestamp});
|
||||
|
||||
if ( $text =~ s/^(NICKCHANGE)\b/changed nick to/
|
||||
or $text =~ s/^(KICKED|QUIT)\b/lc "$1"/e
|
||||
or $text =~ s/^MODE ([^ ]+) (.*)/set mode $1 on $2/
|
||||
or $text =~ s/^(JOIN|PART)\b/lc "$1ed"/e)
|
||||
{
|
||||
$text =~ s/^(quit) (.*)/$1 ($2)/; # fix ugly "[nick] quit Quit: Leaving."
|
||||
$recall_text .= "[$ago] $msg->{nick} $text\n";
|
||||
} elsif ($text =~ s/^\/me\s+//) {
|
||||
$recall_text .= "[$ago] * $msg->{nick} $text\n";
|
||||
} else {
|
||||
$recall_text .= "[$ago] <$msg->{nick}> $text\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $context_account;
|
||||
|
||||
if (defined $recall_context) {
|
||||
($context_account) = $self->{database}->find_message_account_by_nick($recall_context);
|
||||
|
||||
if (not defined $context_account) {
|
||||
return "I don't know anybody named $recall_context.";
|
||||
}
|
||||
}
|
||||
|
||||
my $messages = $self->{database}->get_message_context($message, $recall_before, $recall_after, $recall_count, $recall_history, $context_account);
|
||||
|
||||
my $max_recall_time = $self->{pbot}->{registry}->get_value('messagehistory', 'max_recall_time');
|
||||
|
||||
foreach my $msg (@$messages) {
|
||||
$self->{pbot}->{logger}->log("$nick ($from) recalled <$msg->{nick}/$msg->{channel}> $msg->{msg}\n");
|
||||
|
||||
if ($max_recall_time && gettimeofday - $msg->{timestamp} > $max_recall_time && not $self->{pbot}->{users}->loggedin_admin($from, "$nick!$user\@$host")) {
|
||||
$max_recall_time = duration($max_recall_time);
|
||||
$recall_text .= "Sorry, you can not recall messages older than $max_recall_time.";
|
||||
return $recall_text;
|
||||
}
|
||||
|
||||
my $text = $msg->{msg};
|
||||
my $ago = concise ago(gettimeofday - $msg->{timestamp});
|
||||
|
||||
if ($text =~ s/^(NICKCHANGE)\b/changed nick to/ or
|
||||
$text =~ s/^(KICKED|QUIT)\b/lc "$1"/e or
|
||||
$text =~ s/^MODE ([^ ]+) (.*)/set mode $1 on $2/ or
|
||||
$text =~ s/^(JOIN|PART)\b/lc "$1ed"/e) {
|
||||
$text =~ s/^(quit) (.*)/$1 ($2)/; # fix ugly "[nick] quit Quit: Leaving."
|
||||
$recall_text .= "[$ago] $msg->{nick} $text\n";
|
||||
} elsif ($text =~ s/^\/me\s+//) {
|
||||
$recall_text .= "[$ago] * $msg->{nick} $text\n";
|
||||
} else {
|
||||
$recall_text .= "[$ago] <$msg->{nick}> $text\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $recall_text;
|
||||
return $recall_text;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
182
PBot/Modules.pm
182
PBot/Modules.pm
|
|
@ -6,6 +6,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::Modules;
|
||||
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -15,124 +16,117 @@ use IPC::Run qw/run timeout/;
|
|||
use Encode;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->load_cmd(@_) }, "load", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->unload_cmd(@_) }, "unload", 1);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->load_cmd(@_) }, "load", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->unload_cmd(@_) }, "unload", 1);
|
||||
}
|
||||
|
||||
sub load_cmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $factoids = $self->{pbot}->{factoids}->{factoids};
|
||||
my ($keyword, $module) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
return "Usage: load <keyword> <module>" if not defined $module;
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $factoids = $self->{pbot}->{factoids}->{factoids};
|
||||
my ($keyword, $module) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
return "Usage: load <keyword> <module>" if not defined $module;
|
||||
|
||||
if ($factoids->exists('.*', $keyword)) {
|
||||
return 'There is already a keyword named ' . $factoids->get_data('.*', $keyword, '_name') . '.';
|
||||
}
|
||||
if ($factoids->exists('.*', $keyword)) { return 'There is already a keyword named ' . $factoids->get_data('.*', $keyword, '_name') . '.'; }
|
||||
|
||||
$self->{pbot}->{factoids}->add_factoid('module', '.*', "$nick!$user\@$host", $keyword, $module, 1);
|
||||
$factoids->set('.*', $keyword, 'add_nick', 1, 1);
|
||||
$factoids->set('.*', $keyword, 'nooverride', 1);
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host loaded module $keyword => $module\n");
|
||||
return "Loaded module $keyword => $module";
|
||||
$self->{pbot}->{factoids}->add_factoid('module', '.*', "$nick!$user\@$host", $keyword, $module, 1);
|
||||
$factoids->set('.*', $keyword, 'add_nick', 1, 1);
|
||||
$factoids->set('.*', $keyword, 'nooverride', 1);
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host loaded module $keyword => $module\n");
|
||||
return "Loaded module $keyword => $module";
|
||||
}
|
||||
|
||||
sub unload_cmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $module = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
return "Usage: unload <keyword>" if not defined $module;
|
||||
my $factoids = $self->{pbot}->{factoids}->{factoids};
|
||||
return "/say $module not found." if not $factoids->exists('.*', $module);
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $module = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
return "Usage: unload <keyword>" if not defined $module;
|
||||
my $factoids = $self->{pbot}->{factoids}->{factoids};
|
||||
return "/say $module not found." if not $factoids->exists('.*', $module);
|
||||
|
||||
if ($factoids->get_data('.*', $module, 'type') ne 'module') {
|
||||
return "/say " . $factoids->get_data('.*', $module, '_name') . ' is not a module.';
|
||||
}
|
||||
if ($factoids->get_data('.*', $module, 'type') ne 'module') { return "/say " . $factoids->get_data('.*', $module, '_name') . ' is not a module.'; }
|
||||
|
||||
my $name = $factoids->get_data('.*', $module, '_name');
|
||||
$factoids->remove('.*', $module);
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host unloaded module $module\n");
|
||||
return "/say $name unloaded.";
|
||||
my $name = $factoids->get_data('.*', $module, '_name');
|
||||
$factoids->remove('.*', $module);
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host unloaded module $module\n");
|
||||
return "/say $name unloaded.";
|
||||
}
|
||||
|
||||
sub execute_module {
|
||||
my ($self, $stuff) = @_;
|
||||
my $text;
|
||||
my ($self, $stuff) = @_;
|
||||
my $text;
|
||||
|
||||
if ($self->{pbot}->{registry}->get_value('general', 'debugcontext')) {
|
||||
use Data::Dumper;
|
||||
$Data::Dumper::Sortkeys = 1;
|
||||
$self->{pbot}->{logger}->log("execute_module\n");
|
||||
$self->{pbot}->{logger}->log(Dumper $stuff);
|
||||
}
|
||||
if ($self->{pbot}->{registry}->get_value('general', 'debugcontext')) {
|
||||
use Data::Dumper;
|
||||
$Data::Dumper::Sortkeys = 1;
|
||||
$self->{pbot}->{logger}->log("execute_module\n");
|
||||
$self->{pbot}->{logger}->log(Dumper $stuff);
|
||||
}
|
||||
|
||||
$self->{pbot}->{process_manager}->execute_process($stuff, sub { $self->launch_module(@_) });
|
||||
$self->{pbot}->{process_manager}->execute_process($stuff, sub { $self->launch_module(@_) });
|
||||
}
|
||||
|
||||
sub launch_module {
|
||||
my ($self, $stuff) = @_;
|
||||
$stuff->{arguments} = "" if not defined $stuff->{arguments};
|
||||
my @factoids = $self->{pbot}->{factoids}->find_factoid($stuff->{from}, $stuff->{keyword}, exact_channel => 2, exact_trigger => 2);
|
||||
if (not @factoids or not $factoids[0]) {
|
||||
$stuff->{checkflood} = 1;
|
||||
$self->{pbot}->{interpreter}->handle_result($stuff, "/msg $stuff->{nick} Failed to find module for '$stuff->{keyword}' in channel $stuff->{from}\n");
|
||||
return;
|
||||
}
|
||||
|
||||
my ($channel, $trigger) = ($factoids[0]->[0], $factoids[0]->[1]);
|
||||
$stuff->{channel} = $channel;
|
||||
$stuff->{keyword} = $trigger;
|
||||
$stuff->{trigger} = $trigger;
|
||||
|
||||
my $module = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, 'action');
|
||||
$self->{pbot}->{logger}->log("(" . (defined $stuff->{from} ? $stuff->{from} : "(undef)") . "): $stuff->{nick}!$stuff->{user}\@$stuff->{host}: Executing module [$stuff->{command}] $module $stuff->{arguments}\n");
|
||||
$stuff->{arguments} = $self->{pbot}->{factoids}->expand_special_vars($stuff->{from}, $stuff->{nick}, $stuff->{root_keyword}, $stuff->{arguments});
|
||||
|
||||
my $module_dir = $self->{pbot}->{registry}->get_value('general', 'module_dir');
|
||||
if (not chdir $module_dir) {
|
||||
$self->{pbot}->{logger}->log("Could not chdir to '$module_dir': $!\n");
|
||||
Carp::croak("Could not chdir to '$module_dir': $!");
|
||||
}
|
||||
|
||||
if ($self->{pbot}->{factoids}->{factoids}->exists($channel, $trigger, 'workdir')) {
|
||||
chdir $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, 'workdir');
|
||||
}
|
||||
|
||||
# FIXME -- add check to ensure $module exists
|
||||
my ($exitval, $stdout, $stderr) = eval {
|
||||
my $args = $stuff->{arguments};
|
||||
if (not $stuff->{args_utf8}) {
|
||||
$args = encode('UTF-8', $args);
|
||||
my ($self, $stuff) = @_;
|
||||
$stuff->{arguments} = "" if not defined $stuff->{arguments};
|
||||
my @factoids = $self->{pbot}->{factoids}->find_factoid($stuff->{from}, $stuff->{keyword}, exact_channel => 2, exact_trigger => 2);
|
||||
if (not @factoids or not $factoids[0]) {
|
||||
$stuff->{checkflood} = 1;
|
||||
$self->{pbot}->{interpreter}->handle_result($stuff, "/msg $stuff->{nick} Failed to find module for '$stuff->{keyword}' in channel $stuff->{from}\n");
|
||||
return;
|
||||
}
|
||||
my @cmdline = ("./$module", $self->{pbot}->{interpreter}->split_line($args));
|
||||
my $timeout = $self->{pbot}->{registry}->get_value('general', 'module_timeout') // 30;
|
||||
my ($stdin, $stdout, $stderr);
|
||||
run \@cmdline, \$stdin, \$stdout, \$stderr, timeout($timeout);
|
||||
my $exitval = $? >> 8;
|
||||
utf8::decode($stdout);
|
||||
utf8::decode($stderr);
|
||||
return ($exitval, $stdout, $stderr);
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
my $error = $@;
|
||||
if ($error =~ m/timeout on timer/) {
|
||||
($exitval, $stdout, $stderr) = (-1, "$stuff->{trigger}: timed-out", '');
|
||||
} else {
|
||||
($exitval, $stdout, $stderr) = (-1, '', $error);
|
||||
my ($channel, $trigger) = ($factoids[0]->[0], $factoids[0]->[1]);
|
||||
$stuff->{channel} = $channel;
|
||||
$stuff->{keyword} = $trigger;
|
||||
$stuff->{trigger} = $trigger;
|
||||
|
||||
my $module = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, 'action');
|
||||
$self->{pbot}->{logger}->log("("
|
||||
. (defined $stuff->{from} ? $stuff->{from} : "(undef)")
|
||||
. "): $stuff->{nick}!$stuff->{user}\@$stuff->{host}: Executing module [$stuff->{command}] $module $stuff->{arguments}\n");
|
||||
$stuff->{arguments} = $self->{pbot}->{factoids}->expand_special_vars($stuff->{from}, $stuff->{nick}, $stuff->{root_keyword}, $stuff->{arguments});
|
||||
|
||||
my $module_dir = $self->{pbot}->{registry}->get_value('general', 'module_dir');
|
||||
if (not chdir $module_dir) {
|
||||
$self->{pbot}->{logger}->log("Could not chdir to '$module_dir': $!\n");
|
||||
Carp::croak("Could not chdir to '$module_dir': $!");
|
||||
}
|
||||
}
|
||||
|
||||
if (length $stderr) {
|
||||
if (open(my $fh, '>>', "$module-stderr")) {
|
||||
print $fh $stderr;
|
||||
close $fh;
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("Failed to open $module-stderr: $!\n");
|
||||
if ($self->{pbot}->{factoids}->{factoids}->exists($channel, $trigger, 'workdir')) {
|
||||
chdir $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, 'workdir');
|
||||
}
|
||||
}
|
||||
|
||||
$stuff->{result} = $stdout;
|
||||
chomp $stuff->{result};
|
||||
# FIXME -- add check to ensure $module exists
|
||||
my ($exitval, $stdout, $stderr) = eval {
|
||||
my $args = $stuff->{arguments};
|
||||
if (not $stuff->{args_utf8}) { $args = encode('UTF-8', $args); }
|
||||
my @cmdline = ("./$module", $self->{pbot}->{interpreter}->split_line($args));
|
||||
my $timeout = $self->{pbot}->{registry}->get_value('general', 'module_timeout') // 30;
|
||||
my ($stdin, $stdout, $stderr);
|
||||
run \@cmdline, \$stdin, \$stdout, \$stderr, timeout($timeout);
|
||||
my $exitval = $? >> 8;
|
||||
utf8::decode($stdout);
|
||||
utf8::decode($stderr);
|
||||
return ($exitval, $stdout, $stderr);
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
my $error = $@;
|
||||
if ($error =~ m/timeout on timer/) { ($exitval, $stdout, $stderr) = (-1, "$stuff->{trigger}: timed-out", ''); }
|
||||
else { ($exitval, $stdout, $stderr) = (-1, '', $error); }
|
||||
}
|
||||
|
||||
if (length $stderr) {
|
||||
if (open(my $fh, '>>', "$module-stderr")) {
|
||||
print $fh $stderr;
|
||||
close $fh;
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("Failed to open $module-stderr: $!\n");
|
||||
}
|
||||
}
|
||||
|
||||
$stuff->{result} = $stdout;
|
||||
chomp $stuff->{result};
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
410
PBot/NickList.pm
410
PBot/NickList.pm
|
|
@ -10,6 +10,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::NickList;
|
||||
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -17,342 +18,315 @@ use feature 'unicode_strings';
|
|||
|
||||
use Text::Levenshtein qw/fastdistance/;
|
||||
use Data::Dumper;
|
||||
|
||||
$Data::Dumper::Sortkeys = 1;
|
||||
use Time::HiRes qw/gettimeofday/;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{nicklist} = {};
|
||||
$self->{pbot}->{registry}->add_default('text', 'nicklist', 'debug', '0');
|
||||
my ($self, %conf) = @_;
|
||||
$self->{nicklist} = {};
|
||||
$self->{pbot}->{registry}->add_default('text', 'nicklist', 'debug', '0');
|
||||
|
||||
$self->{pbot}->{commands}->register(sub { $self->show_nicklist(@_) }, "nicklist", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->show_nicklist(@_) }, "nicklist", 0);
|
||||
|
||||
$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(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.quit', sub { $self->on_quit(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.kick', sub { $self->on_kick(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.nick', sub { $self->on_nickchange(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_activity(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->on_activity(@_) });
|
||||
$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(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.quit', sub { $self->on_quit(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.kick', sub { $self->on_kick(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.nick', sub { $self->on_nickchange(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_activity(@_) });
|
||||
$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(@_) });
|
||||
# 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(@_) });
|
||||
}
|
||||
|
||||
sub show_nicklist {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my $nicklist;
|
||||
return "Usage: nicklist <channel> [nick]" if not length $arguments;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my $nicklist;
|
||||
return "Usage: nicklist <channel> [nick]" if not length $arguments;
|
||||
|
||||
my @args = split / /, $arguments;
|
||||
my @args = split / /, $arguments;
|
||||
|
||||
if (@args == 1) {
|
||||
if (not exists $self->{nicklist}->{lc $arguments}) {
|
||||
return "No nicklist for $arguments.";
|
||||
if (@args == 1) {
|
||||
if (not exists $self->{nicklist}->{lc $arguments}) { return "No nicklist for $arguments."; }
|
||||
$nicklist = Dumper($self->{nicklist}->{lc $arguments});
|
||||
} else {
|
||||
if (not exists $self->{nicklist}->{lc $args[0]}) { return "No nicklist for $args[0]."; }
|
||||
elsif (not exists $self->{nicklist}->{lc $args[0]}->{lc $args[1]}) { return "No such nick $args[1] in channel $args[0]."; }
|
||||
$nicklist = Dumper($self->{nicklist}->{lc $args[0]}->{lc $args[1]});
|
||||
}
|
||||
$nicklist = Dumper($self->{nicklist}->{lc $arguments});
|
||||
} else {
|
||||
if (not exists $self->{nicklist}->{lc $args[0]}) {
|
||||
return "No nicklist for $args[0].";
|
||||
} elsif (not exists $self->{nicklist}->{lc $args[0]}->{lc $args[1]}) {
|
||||
return "No such nick $args[1] in channel $args[0].";
|
||||
}
|
||||
$nicklist = Dumper($self->{nicklist}->{lc $args[0]}->{lc $args[1]});
|
||||
}
|
||||
return $nicklist;
|
||||
return $nicklist;
|
||||
}
|
||||
|
||||
sub update_timestamp {
|
||||
my ($self, $channel, $nick) = @_;
|
||||
my $orig_nick = $nick;
|
||||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
my ($self, $channel, $nick) = @_;
|
||||
my $orig_nick = $nick;
|
||||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
|
||||
if (exists $self->{nicklist}->{$channel} and exists $self->{nicklist}->{$channel}->{$nick}) {
|
||||
$self->{nicklist}->{$channel}->{$nick}->{timestamp} = gettimeofday;
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("Adding nick '$orig_nick' to channel '$channel'\n") if $self->{pbot}->{registry}->get_value('nicklist', 'debug');
|
||||
$self->{nicklist}->{$channel}->{$nick} = { nick => $orig_nick, timestamp => scalar gettimeofday };
|
||||
}
|
||||
if (exists $self->{nicklist}->{$channel} and exists $self->{nicklist}->{$channel}->{$nick}) { $self->{nicklist}->{$channel}->{$nick}->{timestamp} = gettimeofday; }
|
||||
else {
|
||||
$self->{pbot}->{logger}->log("Adding nick '$orig_nick' to channel '$channel'\n") if $self->{pbot}->{registry}->get_value('nicklist', 'debug');
|
||||
$self->{nicklist}->{$channel}->{$nick} = {nick => $orig_nick, timestamp => scalar gettimeofday};
|
||||
}
|
||||
}
|
||||
|
||||
sub remove_channel {
|
||||
my ($self, $channel) = @_;
|
||||
delete $self->{nicklist}->{lc $channel};
|
||||
my ($self, $channel) = @_;
|
||||
delete $self->{nicklist}->{lc $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 };
|
||||
}
|
||||
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};
|
||||
}
|
||||
}
|
||||
|
||||
sub remove_nick {
|
||||
my ($self, $channel, $nick) = @_;
|
||||
$self->{pbot}->{logger}->log("Removing nick '$nick' from channel '$channel'\n") if $self->{pbot}->{registry}->get_value('nicklist', 'debug');
|
||||
delete $self->{nicklist}->{lc $channel}->{lc $nick};
|
||||
my ($self, $channel, $nick) = @_;
|
||||
$self->{pbot}->{logger}->log("Removing nick '$nick' from channel '$channel'\n") if $self->{pbot}->{registry}->get_value('nicklist', 'debug');
|
||||
delete $self->{nicklist}->{lc $channel}->{lc $nick};
|
||||
}
|
||||
|
||||
sub get_channels {
|
||||
my ($self, $nick) = @_;
|
||||
my @channels;
|
||||
my ($self, $nick) = @_;
|
||||
my @channels;
|
||||
|
||||
$nick = lc $nick;
|
||||
$nick = lc $nick;
|
||||
|
||||
foreach my $channel (keys %{ $self->{nicklist} }) {
|
||||
if (exists $self->{nicklist}->{$channel}->{$nick}) {
|
||||
push @channels, $channel;
|
||||
foreach my $channel (keys %{$self->{nicklist}}) {
|
||||
if (exists $self->{nicklist}->{$channel}->{$nick}) { push @channels, $channel; }
|
||||
}
|
||||
}
|
||||
|
||||
return \@channels;
|
||||
return \@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};
|
||||
}
|
||||
return @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}; }
|
||||
return @nicks;
|
||||
}
|
||||
|
||||
sub set_meta {
|
||||
my ($self, $channel, $nick, $key, $value) = @_;
|
||||
my ($self, $channel, $nick, $key, $value) = @_;
|
||||
|
||||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
|
||||
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;
|
||||
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++;
|
||||
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");
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
return $found;
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("Nicklist: Attempt to set invalid meta ($key => $value) for $nick in $channel.\n");
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
$self->{nicklist}->{$channel}->{$nick}->{$key} = $value;
|
||||
return 1;
|
||||
$self->{nicklist}->{$channel}->{$nick}->{$key} = $value;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub delete_meta {
|
||||
my ($self, $channel, $nick, $key) = @_;
|
||||
my ($self, $channel, $nick, $key) = @_;
|
||||
|
||||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
|
||||
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};
|
||||
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};
|
||||
}
|
||||
|
||||
sub get_meta {
|
||||
my ($self, $channel, $nick, $key) = @_;
|
||||
my ($self, $channel, $nick, $key) = @_;
|
||||
|
||||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
|
||||
if (not exists $self->{nicklist}->{$channel}
|
||||
or not exists $self->{nicklist}->{$channel}->{$nick}
|
||||
or not exists $self->{nicklist}->{$channel}->{$nick}->{$key}) {
|
||||
return undef;
|
||||
}
|
||||
if (not exists $self->{nicklist}->{$channel} or not exists $self->{nicklist}->{$channel}->{$nick} or not exists $self->{nicklist}->{$channel}->{$nick}->{$key}) {
|
||||
return undef;
|
||||
}
|
||||
|
||||
return $self->{nicklist}->{$channel}->{$nick}->{$key};
|
||||
return $self->{nicklist}->{$channel}->{$nick}->{$key};
|
||||
}
|
||||
|
||||
sub is_present_any_channel {
|
||||
my ($self, $nick) = @_;
|
||||
my ($self, $nick) = @_;
|
||||
|
||||
$nick = lc $nick;
|
||||
$nick = lc $nick;
|
||||
|
||||
foreach my $channel (keys %{ $self->{nicklist} }) {
|
||||
if (exists $self->{nicklist}->{$channel}->{$nick}) {
|
||||
return $self->{nicklist}->{$channel}->{$nick}->{nick};
|
||||
foreach my $channel (keys %{$self->{nicklist}}) {
|
||||
if (exists $self->{nicklist}->{$channel}->{$nick}) { return $self->{nicklist}->{$channel}->{$nick}->{nick}; }
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub is_present {
|
||||
my ($self, $channel, $nick) = @_;
|
||||
my ($self, $channel, $nick) = @_;
|
||||
|
||||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
$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 {
|
||||
my ($self, $channel, $nick, $similar) = @_;
|
||||
my ($self, $channel, $nick, $similar) = @_;
|
||||
|
||||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
$channel = lc $channel;
|
||||
$nick = lc $nick;
|
||||
|
||||
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
|
||||
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;
|
||||
my $percentage = $self->{pbot}->{registry}->get_value('interpreter', 'nick_similarity');
|
||||
$percentage = 0.20 if not defined $percentage;
|
||||
|
||||
$percentage = $similar if defined $similar;
|
||||
$percentage = $similar if defined $similar;
|
||||
|
||||
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
|
||||
my $distance = fastdistance($nick, $person);
|
||||
my $length = length $nick > length $person ? length $nick : length $person;
|
||||
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
|
||||
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;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub random_nick {
|
||||
my ($self, $channel) = @_;
|
||||
my ($self, $channel) = @_;
|
||||
|
||||
$channel = lc $channel;
|
||||
$channel = lc $channel;
|
||||
|
||||
if (exists $self->{nicklist}->{$channel}) {
|
||||
my $now = gettimeofday;
|
||||
my @nicks = grep { $now - $self->{nicklist}->{$channel}->{$_}->{timestamp} < 3600 * 2 } keys %{ $self->{nicklist}->{$channel} };
|
||||
if (exists $self->{nicklist}->{$channel}) {
|
||||
my $now = gettimeofday;
|
||||
my @nicks = grep { $now - $self->{nicklist}->{$channel}->{$_}->{timestamp} < 3600 * 2 } keys %{$self->{nicklist}->{$channel}};
|
||||
|
||||
my $nick = $nicks[rand @nicks];
|
||||
return $self->{nicklist}->{$channel}->{$nick}->{nick};
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
my $nick = $nicks[rand @nicks];
|
||||
return $self->{nicklist}->{$channel}->{$nick}->{nick};
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
sub on_namreply {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($channel, $nicks) = ($event->{event}->{args}[2], $event->{event}->{args}[3]);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($channel, $nicks) = ($event->{event}->{args}[2], $event->{event}->{args}[3]);
|
||||
|
||||
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);
|
||||
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);
|
||||
my ($account_id, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($stripped_nick);
|
||||
|
||||
if (defined $hostmask) {
|
||||
my ($user, $host) = $hostmask =~ m/[^!]+!([^@]+)@(.*)/;
|
||||
$self->set_meta($channel, $stripped_nick, 'hostmask', $hostmask);
|
||||
$self->set_meta($channel, $stripped_nick, 'user', $user);
|
||||
$self->set_meta($channel, $stripped_nick, 'host', $host);
|
||||
if (defined $hostmask) {
|
||||
my ($user, $host) = $hostmask =~ m/[^!]+!([^@]+)@(.*)/;
|
||||
$self->set_meta($channel, $stripped_nick, 'hostmask', $hostmask);
|
||||
$self->set_meta($channel, $stripped_nick, 'user', $user);
|
||||
$self->set_meta($channel, $stripped_nick, 'host', $host);
|
||||
}
|
||||
|
||||
if ($nick =~ m/\@/) { $self->set_meta($channel, $stripped_nick, '+o', 1); }
|
||||
|
||||
if ($nick =~ m/\+/) { $self->set_meta($channel, $stripped_nick, '+v', 1); }
|
||||
|
||||
if ($nick =~ m/\%/) { $self->set_meta($channel, $stripped_nick, '+h', 1); }
|
||||
}
|
||||
|
||||
if ($nick =~ m/\@/) {
|
||||
$self->set_meta($channel, $stripped_nick, '+o', 1);
|
||||
}
|
||||
|
||||
if ($nick =~ m/\+/) {
|
||||
$self->set_meta($channel, $stripped_nick, '+v', 1);
|
||||
}
|
||||
|
||||
if ($nick =~ m/\%/) {
|
||||
$self->set_meta($channel, $stripped_nick, '+h', 1);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
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;
|
||||
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);
|
||||
return 0;
|
||||
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);
|
||||
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;
|
||||
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 ($self, $event_type, $event) = @_;
|
||||
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);
|
||||
foreach my $channel (keys %{$self->{nicklist}}) {
|
||||
if ($self->is_present($channel, $nick)) { $self->remove_nick($channel, $nick); }
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
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;
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $channel) = ($event->{event}->to, $event->{event}->{args}[0]);
|
||||
$self->remove_nick($channel, $nick);
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_nickchange {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $newnick) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $newnick) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
|
||||
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;
|
||||
$self->{nicklist}->{$channel}->{lc $newnick} = $meta;
|
||||
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;
|
||||
$self->{nicklist}->{$channel}->{lc $newnick} = $meta;
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_join_channel {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
$self->remove_channel($event->{channel}); # clear nicklist to remove any stale nicks before repopulating with namreplies
|
||||
return 0;
|
||||
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 {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
$self->remove_channel($event->{channel});
|
||||
return 0;
|
||||
my ($self, $event_type, $event) = @_;
|
||||
$self->remove_channel($event->{channel});
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
664
PBot/PBot.pm
664
PBot/PBot.pm
|
|
@ -51,451 +51,449 @@ use PBot::Modules;
|
|||
use PBot::ProcessManager;
|
||||
|
||||
sub new {
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{startup_timestamp} = time;
|
||||
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 $data_dir = $conf{data_dir};
|
||||
my $module_dir = $conf{module_dir};
|
||||
my $plugin_dir = $conf{plugin_dir};
|
||||
|
||||
# check command-line arguments for directory overrides
|
||||
foreach my $arg (@ARGV) {
|
||||
if ($arg =~ m/^-?(?:general\.)?((?:data|module|plugin)_dir)=(.*)$/) {
|
||||
my $override = $1;
|
||||
my $value = $2;
|
||||
$data_dir = $value if $override eq 'data_dir';
|
||||
$module_dir = $value if $override eq 'module_dir';
|
||||
$plugin_dir = $value if $override eq 'plugin_dir';
|
||||
}
|
||||
}
|
||||
|
||||
# check command-line arguments for registry overrides
|
||||
foreach my $arg (@ARGV) {
|
||||
next if $arg =~ m/^-?(?:general\.)?(?:config|data|module|plugin)_dir=.*$/; # already processed
|
||||
my ($item, $value) = split /=/, $arg, 2;
|
||||
|
||||
if (not defined $item or not defined $value) {
|
||||
print STDERR "Fatal error: unknown argument `$arg`; arguments must be in the form of `section.key=value` (e.g.: irc.botnick=newnick)\n";
|
||||
exit;
|
||||
# check command-line arguments for directory overrides
|
||||
foreach my $arg (@ARGV) {
|
||||
if ($arg =~ m/^-?(?:general\.)?((?:data|module|plugin)_dir)=(.*)$/) {
|
||||
my $override = $1;
|
||||
my $value = $2;
|
||||
$data_dir = $value if $override eq 'data_dir';
|
||||
$module_dir = $value if $override eq 'module_dir';
|
||||
$plugin_dir = $value if $override eq 'plugin_dir';
|
||||
}
|
||||
}
|
||||
|
||||
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;
|
||||
# check command-line arguments for registry overrides
|
||||
foreach my $arg (@ARGV) {
|
||||
next if $arg =~ m/^-?(?:general\.)?(?:config|data|module|plugin)_dir=.*$/; # already processed
|
||||
my ($item, $value) = split /=/, $arg, 2;
|
||||
|
||||
if (not defined $item or not defined $value) {
|
||||
print STDERR "Fatal error: unknown argument `$arg`; arguments must be in the form of `section.key=value` (e.g.: irc.botnick=newnick)\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
$section =~ s/^-//; # remove a leading - to allow arguments like -irc.botnick due to habitual use of -args
|
||||
$self->{overrides}->{"$section.$key"} = $value;
|
||||
}
|
||||
|
||||
$section =~ s/^-//; # remove a leading - to allow arguments like -irc.botnick due to habitual use of -args
|
||||
$self->{overrides}->{"$section.$key"} = $value;
|
||||
}
|
||||
# let modules register signal handlers
|
||||
$self->{atexit} = PBot::Registerable->new(%conf, pbot => $self);
|
||||
$self->register_signal_handlers;
|
||||
|
||||
# let modules register signal handlers
|
||||
$self->{atexit} = PBot::Registerable->new(%conf, pbot => $self);
|
||||
$self->register_signal_handlers;
|
||||
# create logger
|
||||
$self->{logger} = PBot::Logger->new(pbot => $self, filename => "$data_dir/log/log", %conf);
|
||||
|
||||
# create logger
|
||||
$self->{logger} = PBot::Logger->new(pbot => $self, filename => "$data_dir/log/log", %conf);
|
||||
# make sure the environment is sane
|
||||
if (not -d $data_dir) {
|
||||
$self->{logger}->log("Data directory ($data_dir) does not exist; aborting...\n");
|
||||
exit;
|
||||
}
|
||||
|
||||
# make sure the environment is sane
|
||||
if (not -d $data_dir) {
|
||||
$self->{logger}->log("Data directory ($data_dir) does not exist; aborting...\n");
|
||||
exit;
|
||||
}
|
||||
if (not -d $module_dir) {
|
||||
$self->{logger}->log("Modules directory ($module_dir) does not exist; aborting...\n");
|
||||
exit;
|
||||
}
|
||||
|
||||
if (not -d $module_dir) {
|
||||
$self->{logger}->log("Modules directory ($module_dir) does not exist; aborting...\n");
|
||||
exit;
|
||||
}
|
||||
if (not -d $plugin_dir) {
|
||||
$self->{logger}->log("Plugins directory ($plugin_dir) does not exist; aborting...\n");
|
||||
exit;
|
||||
}
|
||||
|
||||
if (not -d $plugin_dir) {
|
||||
$self->{logger}->log("Plugins directory ($plugin_dir) does not exist; aborting...\n");
|
||||
exit;
|
||||
}
|
||||
# then capabilities so commands can add new capabilities
|
||||
$self->{capabilities} = PBot::Capabilities->new(pbot => $self, filename => "$data_dir/capabilities", %conf);
|
||||
|
||||
# then capabilities so commands can add new capabilities
|
||||
$self->{capabilities} = PBot::Capabilities->new(pbot => $self, filename => "$data_dir/capabilities", %conf);
|
||||
# then commands so the modules can register new commands
|
||||
$self->{commands} = PBot::Commands->new(pbot => $self, filename => "$data_dir/commands", %conf);
|
||||
|
||||
# then commands so the modules can register new commands
|
||||
$self->{commands} = PBot::Commands->new(pbot => $self, filename => "$data_dir/commands", %conf);
|
||||
# add some commands
|
||||
$self->{commands}->register(sub { $self->listcmd(@_) }, "list");
|
||||
$self->{commands}->register(sub { $self->ack_die(@_) }, "die", 1);
|
||||
$self->{commands}->register(sub { $self->export(@_) }, "export", 1);
|
||||
$self->{commands}->register(sub { $self->reload(@_) }, "reload", 1);
|
||||
$self->{commands}->register(sub { $self->evalcmd(@_) }, "eval", 1);
|
||||
$self->{commands}->register(sub { $self->sl(@_) }, "sl", 1);
|
||||
|
||||
# add some commands
|
||||
$self->{commands}->register(sub { $self->listcmd(@_) }, "list");
|
||||
$self->{commands}->register(sub { $self->ack_die(@_) }, "die", 1);
|
||||
$self->{commands}->register(sub { $self->export(@_) }, "export", 1);
|
||||
$self->{commands}->register(sub { $self->reload(@_) }, "reload", 1);
|
||||
$self->{commands}->register(sub { $self->evalcmd(@_) }, "eval", 1);
|
||||
$self->{commands}->register(sub { $self->sl(@_) }, "sl", 1);
|
||||
# add 'cap' capability command
|
||||
$self->{commands}->register(sub { $self->{capabilities}->capcmd(@_) }, "cap");
|
||||
|
||||
# add 'cap' capability command
|
||||
$self->{commands}->register(sub { $self->{capabilities}->capcmd(@_) }, "cap");
|
||||
# prepare the version
|
||||
$self->{version} = PBot::VERSION->new(pbot => $self, %conf);
|
||||
$self->{logger}->log($self->{version}->version . "\n");
|
||||
$self->{logger}->log("Args: @ARGV\n") if @ARGV;
|
||||
|
||||
# prepare the version
|
||||
$self->{version} = PBot::VERSION->new(pbot => $self, %conf);
|
||||
$self->{logger}->log($self->{version}->version . "\n");
|
||||
$self->{logger}->log("Args: @ARGV\n") if @ARGV;
|
||||
# log the configured paths
|
||||
$self->{logger}->log("data_dir: $data_dir\n");
|
||||
$self->{logger}->log("module_dir: $module_dir\n");
|
||||
$self->{logger}->log("plugin_dir: $plugin_dir\n");
|
||||
|
||||
# log the configured paths
|
||||
$self->{logger}->log("data_dir: $data_dir\n");
|
||||
$self->{logger}->log("module_dir: $module_dir\n");
|
||||
$self->{logger}->log("plugin_dir: $plugin_dir\n");
|
||||
$self->{timer} = PBot::Timer->new(pbot => $self, timeout => 10, %conf);
|
||||
$self->{modules} = PBot::Modules->new(pbot => $self, %conf);
|
||||
$self->{functions} = PBot::Functions->new(pbot => $self, %conf);
|
||||
$self->{refresher} = PBot::Refresher->new(pbot => $self);
|
||||
|
||||
$self->{timer} = PBot::Timer->new(pbot => $self, timeout => 10, %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);
|
||||
|
||||
# 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', 'trigger', $conf{trigger} // '!');
|
||||
|
||||
$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', '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}->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);
|
||||
|
||||
$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; }
|
||||
|
||||
# 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);
|
||||
|
||||
# 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);
|
||||
# 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);
|
||||
}
|
||||
|
||||
# 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(@_) });
|
||||
|
||||
# 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(@_) });
|
||||
# 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");
|
||||
exit;
|
||||
}
|
||||
|
||||
# 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");
|
||||
exit;
|
||||
}
|
||||
$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->{bantracker} = PBot::BanTracker->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->{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->{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->{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->{bantracker} = PBot::BanTracker->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->{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->{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->{interpreter} = PBot::Interpreter->new(pbot => $self, %conf);
|
||||
$self->{interpreter}->register(sub { $self->{commands}->interpreter(@_) });
|
||||
$self->{interpreter}->register(sub { $self->{factoids}->interpreter(@_) });
|
||||
|
||||
$self->{interpreter} = PBot::Interpreter->new(pbot => $self, %conf);
|
||||
$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", %conf);
|
||||
|
||||
$self->{factoids} = PBot::Factoids->new(pbot => $self, filename => "$data_dir/factoids", %conf);
|
||||
$self->{plugins} = PBot::Plugins->new(pbot => $self, %conf);
|
||||
|
||||
$self->{plugins} = PBot::Plugins->new(pbot => $self, %conf);
|
||||
# load available plugins
|
||||
$self->{plugins}->autoload(%conf);
|
||||
|
||||
# load available plugins
|
||||
$self->{plugins}->autoload(%conf);
|
||||
|
||||
# give botowner all capabilities
|
||||
$self->{capabilities}->rebuild_botowner_capabilities();
|
||||
# give botowner all capabilities
|
||||
$self->{capabilities}->rebuild_botowner_capabilities();
|
||||
}
|
||||
|
||||
sub random_nick {
|
||||
my ($self, $length) = @_;
|
||||
$length //= 9;
|
||||
my @chars = ("A".."Z", "a".."z", "0".."9");
|
||||
my $nick = $chars[rand @chars - 10]; # nicks cannot start with a digit
|
||||
$nick .= $chars[rand @chars] for 1..$length;
|
||||
return $nick;
|
||||
my ($self, $length) = @_;
|
||||
$length //= 9;
|
||||
my @chars = ("A" .. "Z", "a" .. "z", "0" .. "9");
|
||||
my $nick = $chars[rand @chars - 10]; # nicks cannot start with a digit
|
||||
$nick .= $chars[rand @chars] for 1 .. $length;
|
||||
return $nick;
|
||||
}
|
||||
|
||||
# TODO: add disconnect subroutine
|
||||
sub connect {
|
||||
my ($self, $server) = @_;
|
||||
my ($self, $server) = @_;
|
||||
|
||||
if ($self->{connected}) {
|
||||
# TODO: disconnect, clean-up, etc
|
||||
}
|
||||
if ($self->{connected}) {
|
||||
|
||||
$server = $self->{registry}->get_value('irc', 'server') if not defined $server;
|
||||
# TODO: disconnect, clean-up, etc
|
||||
}
|
||||
|
||||
$self->{logger}->log("Connecting to $server ...\n");
|
||||
$server = $self->{registry}->get_value('irc', 'server') if not defined $server;
|
||||
|
||||
while (not $self->{conn} = $self->{irc}->newconn(
|
||||
Nick => $self->{registry}->get_value('irc', 'randomize_nick') ? $self->random_nick : $self->{registry}->get_value('irc', 'botnick'),
|
||||
Username => $self->{registry}->get_value('irc', 'username'),
|
||||
Ircname => $self->{registry}->get_value('irc', 'realname'),
|
||||
Server => $server,
|
||||
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("Connecting to $server ...\n");
|
||||
|
||||
$self->{connected} = 1;
|
||||
while (
|
||||
not $self->{conn} = $self->{irc}->newconn(
|
||||
Nick => $self->{registry}->get_value('irc', 'randomize_nick') ? $self->random_nick : $self->{registry}->get_value('irc', 'botnick'),
|
||||
Username => $self->{registry}->get_value('irc', 'username'),
|
||||
Ircname => $self->{registry}->get_value('irc', 'realname'),
|
||||
Server => $server,
|
||||
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;
|
||||
}
|
||||
|
||||
# start timer once connected
|
||||
$self->{timer}->start;
|
||||
$self->{connected} = 1;
|
||||
|
||||
# set up handlers for the IRC engine
|
||||
$self->{conn}->add_default_handler(sub { $self->{irchandlers}->default_handler(@_) }, 1);
|
||||
$self->{conn}->add_handler([ 251,252,253,254,255,302 ], sub { $self->{irchandlers}->on_init(@_) });
|
||||
# start timer once connected
|
||||
$self->{timer}->start;
|
||||
|
||||
# ignore these events
|
||||
$self->{conn}->add_handler(['whoisserver',
|
||||
'whoiscountry',
|
||||
'whoischannels',
|
||||
'whoisidle',
|
||||
'motdstart',
|
||||
'endofmotd',
|
||||
'away',
|
||||
'endofbanlist'], sub {});
|
||||
# set up handlers for the IRC engine
|
||||
$self->{conn}->add_default_handler(sub { $self->{irchandlers}->default_handler(@_) }, 1);
|
||||
$self->{conn}->add_handler([251, 252, 253, 254, 255, 302], sub { $self->{irchandlers}->on_init(@_) });
|
||||
|
||||
# ignore these events
|
||||
$self->{conn}->add_handler(
|
||||
[
|
||||
'whoisserver',
|
||||
'whoiscountry',
|
||||
'whoischannels',
|
||||
'whoisidle',
|
||||
'motdstart',
|
||||
'endofmotd',
|
||||
'away',
|
||||
'endofbanlist'
|
||||
],
|
||||
sub { }
|
||||
);
|
||||
}
|
||||
|
||||
#main loop
|
||||
sub do_one_loop {
|
||||
my $self = shift;
|
||||
$self->{irc}->do_one_loop();
|
||||
$self->{select_handler}->do_select();
|
||||
my $self = shift;
|
||||
$self->{irc}->do_one_loop();
|
||||
$self->{select_handler}->do_select();
|
||||
}
|
||||
|
||||
sub start {
|
||||
my $self = shift;
|
||||
while (1) {
|
||||
$self->connect() if not $self->{connected};
|
||||
$self->do_one_loop() if $self->{connected};
|
||||
}
|
||||
my $self = shift;
|
||||
while (1) {
|
||||
$self->connect() if not $self->{connected};
|
||||
$self->do_one_loop() if $self->{connected};
|
||||
}
|
||||
}
|
||||
|
||||
sub register_signal_handlers {
|
||||
my $self = shift;
|
||||
$SIG{INT} = sub { $self->atexit; exit 0; };
|
||||
my $self = shift;
|
||||
$SIG{INT} = sub { $self->atexit; exit 0; };
|
||||
}
|
||||
|
||||
sub atexit {
|
||||
my $self = shift;
|
||||
$self->{atexit}->execute_all;
|
||||
my $self = shift;
|
||||
$self->{atexit}->execute_all;
|
||||
}
|
||||
|
||||
sub irc_debug_trigger {
|
||||
my ($self, $section, $item, $newvalue) = @_;
|
||||
$self->{irc}->debug($newvalue);
|
||||
$self->{conn}->debug($newvalue) if $self->{connected};
|
||||
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};
|
||||
my ($self, $section, $item, $newvalue) = @_;
|
||||
$self->{conn}->nick($newvalue) if $self->{connected};
|
||||
}
|
||||
|
||||
sub listcmd {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
my $text;
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
my $text;
|
||||
|
||||
my $usage = "Usage: list <modules|commands>";
|
||||
my $usage = "Usage: list <modules|commands>";
|
||||
|
||||
if (not defined $arguments) {
|
||||
return $usage;
|
||||
}
|
||||
if (not defined $arguments) { return $usage; }
|
||||
|
||||
if ($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') . ' ';
|
||||
if ($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;
|
||||
}
|
||||
return $text;
|
||||
}
|
||||
|
||||
if ($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} ";
|
||||
}
|
||||
if ($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 $text;
|
||||
}
|
||||
return $usage;
|
||||
return $usage;
|
||||
}
|
||||
|
||||
sub sl {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
return "Usage: sl <ircd command>" if not length $arguments;
|
||||
$self->{conn}->sl($arguments);
|
||||
return "";
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
return "Usage: sl <ircd command>" if not length $arguments;
|
||||
$self->{conn}->sl($arguments);
|
||||
return "";
|
||||
}
|
||||
|
||||
sub ack_die {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
$self->{logger}->log("$nick!$user\@$host made me exit.\n");
|
||||
$self->atexit();
|
||||
$self->{conn}->privmsg($from, "Good-bye.") if defined $from;
|
||||
$self->{conn}->quit("Departure requested.");
|
||||
exit 0;
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
$self->{logger}->log("$nick!$user\@$host made me exit.\n");
|
||||
$self->atexit();
|
||||
$self->{conn}->privmsg($from, "Good-bye.") if defined $from;
|
||||
$self->{conn}->quit("Departure requested.");
|
||||
exit 0;
|
||||
}
|
||||
|
||||
sub export {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
return "Usage: export <factoids>" if not defined $arguments;
|
||||
return "Usage: export <factoids>" if not defined $arguments;
|
||||
|
||||
if ($arguments =~ /^factoids$/i) {
|
||||
return $self->{factoids}->export_factoids;
|
||||
}
|
||||
if ($arguments =~ /^factoids$/i) { return $self->{factoids}->export_factoids; }
|
||||
}
|
||||
|
||||
sub evalcmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
$self->{logger}->log("[$from] $nick!$user\@$host Evaluating [$arguments]\n");
|
||||
$self->{logger}->log("[$from] $nick!$user\@$host Evaluating [$arguments]\n");
|
||||
|
||||
my $ret = '';
|
||||
my $result = eval $arguments;
|
||||
if ($@) {
|
||||
if (length $result) {
|
||||
$ret .= "[Error: $@] ";
|
||||
} else {
|
||||
$ret .= "Error: $@";
|
||||
my $ret = '';
|
||||
my $result = eval $arguments;
|
||||
if ($@) {
|
||||
if (length $result) { $ret .= "[Error: $@] "; }
|
||||
else { $ret .= "Error: $@"; }
|
||||
$ret =~ s/ at \(eval \d+\) line 1.//;
|
||||
}
|
||||
$ret =~ s/ at \(eval \d+\) line 1.//;
|
||||
}
|
||||
$result = 'Undefined.' if not defined $result;
|
||||
$result = 'No output.' if not length $result;
|
||||
return "/say $ret $result";
|
||||
$result = 'Undefined.' if not defined $result;
|
||||
$result = 'No output.' if not length $result;
|
||||
return "/say $ret $result";
|
||||
}
|
||||
|
||||
sub reload {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
my %reloadables = (
|
||||
'capabilities' => sub {
|
||||
$self->{capabilities}->{caps}->load;
|
||||
return "Capabilities reloaded.";
|
||||
},
|
||||
my %reloadables = (
|
||||
'capabilities' => sub {
|
||||
$self->{capabilities}->{caps}->load;
|
||||
return "Capabilities reloaded.";
|
||||
},
|
||||
|
||||
'commands' => sub {
|
||||
$self->{commands}->{metadata}->load;
|
||||
return "Commands metadata reloaded.";
|
||||
},
|
||||
'commands' => sub {
|
||||
$self->{commands}->{metadata}->load;
|
||||
return "Commands metadata reloaded.";
|
||||
},
|
||||
|
||||
'blacklist' => sub {
|
||||
$self->{blacklist}->clear_blacklist;
|
||||
$self->{blacklist}->load_blacklist;
|
||||
return "Blacklist reloaded.";
|
||||
},
|
||||
'blacklist' => sub {
|
||||
$self->{blacklist}->clear_blacklist;
|
||||
$self->{blacklist}->load_blacklist;
|
||||
return "Blacklist reloaded.";
|
||||
},
|
||||
|
||||
'ban-exemptions' => sub {
|
||||
$self->{antiflood}->{'ban-exemptions'}->clear;
|
||||
$self->{antiflood}->{'ban-exemptions'}->load;
|
||||
return "Ban exemptions reloaded.";
|
||||
},
|
||||
'ban-exemptions' => sub {
|
||||
$self->{antiflood}->{'ban-exemptions'}->clear;
|
||||
$self->{antiflood}->{'ban-exemptions'}->load;
|
||||
return "Ban exemptions reloaded.";
|
||||
},
|
||||
|
||||
'ignores' => sub {
|
||||
$self->{ignorelist}->clear_ignores;
|
||||
$self->{ignorelist}->load_ignores;
|
||||
return "Ignore list reloaded.";
|
||||
},
|
||||
'ignores' => sub {
|
||||
$self->{ignorelist}->clear_ignores;
|
||||
$self->{ignorelist}->load_ignores;
|
||||
return "Ignore list reloaded.";
|
||||
},
|
||||
|
||||
'users' => sub {
|
||||
$self->{users}->load;
|
||||
return "Users reloaded.";
|
||||
},
|
||||
'users' => sub {
|
||||
$self->{users}->load;
|
||||
return "Users reloaded.";
|
||||
},
|
||||
|
||||
'channels' => sub {
|
||||
$self->{channels}->{channels}->load;
|
||||
return "Channels reloaded.";
|
||||
},
|
||||
'channels' => sub {
|
||||
$self->{channels}->{channels}->load;
|
||||
return "Channels reloaded.";
|
||||
},
|
||||
|
||||
'bantimeouts' => sub {
|
||||
$self->{chanops}->{unban_timeout}->clear;
|
||||
$self->{chanops}->{unban_timeout}->load;
|
||||
return "Ban timeouts reloaded.";
|
||||
},
|
||||
'bantimeouts' => sub {
|
||||
$self->{chanops}->{unban_timeout}->clear;
|
||||
$self->{chanops}->{unban_timeout}->load;
|
||||
return "Ban timeouts reloaded.";
|
||||
},
|
||||
|
||||
'mutetimeouts' => sub {
|
||||
$self->{chanops}->{unmute_timeout}->clear;
|
||||
$self->{chanops}->{unmute_timeout}->load;
|
||||
return "Mute timeouts reloaded.";
|
||||
},
|
||||
'mutetimeouts' => sub {
|
||||
$self->{chanops}->{unmute_timeout}->clear;
|
||||
$self->{chanops}->{unmute_timeout}->load;
|
||||
return "Mute timeouts reloaded.";
|
||||
},
|
||||
|
||||
'registry' => sub {
|
||||
$self->{registry}->{registry}->clear;
|
||||
$self->{registry}->load;
|
||||
return "Registry reloaded.";
|
||||
},
|
||||
'registry' => sub {
|
||||
$self->{registry}->{registry}->clear;
|
||||
$self->{registry}->load;
|
||||
return "Registry reloaded.";
|
||||
},
|
||||
|
||||
'factoids' => sub {
|
||||
$self->{factoids}->{factoids}->clear;
|
||||
$self->{factoids}->load_factoids;
|
||||
return "Factoids reloaded.";
|
||||
'factoids' => sub {
|
||||
$self->{factoids}->{factoids}->clear;
|
||||
$self->{factoids}->load_factoids;
|
||||
return "Factoids reloaded.";
|
||||
}
|
||||
);
|
||||
|
||||
if (not length $arguments or not exists $reloadables{$arguments}) {
|
||||
my $usage = 'Usage: reload <';
|
||||
$usage .= join '|', sort keys %reloadables;
|
||||
$usage .= '>';
|
||||
return $usage;
|
||||
}
|
||||
);
|
||||
|
||||
if (not length $arguments or not exists $reloadables{$arguments}) {
|
||||
my $usage = 'Usage: reload <';
|
||||
$usage .= join '|', sort keys %reloadables;
|
||||
$usage .= '>';
|
||||
return $usage;
|
||||
}
|
||||
|
||||
return $reloadables{$arguments}();
|
||||
return $reloadables{$arguments}();
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
222
PBot/Plugins.pm
222
PBot/Plugins.pm
|
|
@ -16,169 +16,157 @@ use feature 'unicode_strings';
|
|||
use File::Basename;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{plugins} = {};
|
||||
$self->{pbot}->{commands}->register(sub { $self->load_cmd(@_) }, "plug", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->unload_cmd(@_) }, "unplug", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->reload_cmd(@_) }, "replug", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->list_cmd(@_) }, "pluglist", 0);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{plugins} = {};
|
||||
$self->{pbot}->{commands}->register(sub { $self->load_cmd(@_) }, "plug", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->unload_cmd(@_) }, "unplug", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->reload_cmd(@_) }, "replug", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->list_cmd(@_) }, "pluglist", 0);
|
||||
}
|
||||
|
||||
sub autoload {
|
||||
my ($self, %conf) = @_;
|
||||
return if $self->{pbot}->{registry}->get_value('plugins', 'noautoload');
|
||||
my ($self, %conf) = @_;
|
||||
return if $self->{pbot}->{registry}->get_value('plugins', 'noautoload');
|
||||
|
||||
my $path = $self->{pbot}->{registry}->get_value('general', 'plugin_dir') // 'Plugins';
|
||||
my $data_dir = $self->{pbot}->{registry}->get_value('general', 'data_dir');
|
||||
my $path = $self->{pbot}->{registry}->get_value('general', 'plugin_dir') // 'Plugins';
|
||||
my $data_dir = $self->{pbot}->{registry}->get_value('general', 'data_dir');
|
||||
|
||||
$self->{pbot}->{logger}->log("Loading plugins ...\n");
|
||||
my $plugin_count = 0;
|
||||
$self->{pbot}->{logger}->log("Loading plugins ...\n");
|
||||
my $plugin_count = 0;
|
||||
|
||||
my $fh;
|
||||
if (not open $fh, "<$data_dir/plugin_autoload") {
|
||||
$self->{pbot}->{logger}->log("warning: file $data_dir/plugin_autoload does not exist; skipping autoloading of Plugins\n");
|
||||
return;
|
||||
}
|
||||
my $fh;
|
||||
if (not open $fh, "<$data_dir/plugin_autoload") {
|
||||
$self->{pbot}->{logger}->log("warning: file $data_dir/plugin_autoload does not exist; skipping autoloading of Plugins\n");
|
||||
return;
|
||||
}
|
||||
|
||||
chomp(my @plugins = <$fh>);
|
||||
close $fh;
|
||||
chomp(my @plugins = <$fh>);
|
||||
close $fh;
|
||||
|
||||
foreach my $plugin (sort @plugins) {
|
||||
$plugin = basename $plugin;
|
||||
$plugin =~ s/.pm$//;
|
||||
foreach my $plugin (sort @plugins) {
|
||||
$plugin = basename $plugin;
|
||||
$plugin =~ s/.pm$//;
|
||||
|
||||
# do not load plugins that begin with a comment
|
||||
next if $plugin =~ m/^\s*#/;
|
||||
# do not load plugins that begin with a comment
|
||||
next if $plugin =~ m/^\s*#/;
|
||||
|
||||
$plugin_count++ if $self->load($plugin, %conf)
|
||||
}
|
||||
$self->{pbot}->{logger}->log("$plugin_count plugin" . ($plugin_count == 1 ? '' : 's') . " loaded.\n");
|
||||
$plugin_count++ if $self->load($plugin, %conf);
|
||||
}
|
||||
$self->{pbot}->{logger}->log("$plugin_count plugin" . ($plugin_count == 1 ? '' : 's') . " loaded.\n");
|
||||
}
|
||||
|
||||
sub load {
|
||||
my ($self, $plugin, %conf) = @_;
|
||||
my ($self, $plugin, %conf) = @_;
|
||||
|
||||
$self->unload($plugin);
|
||||
$self->unload($plugin);
|
||||
|
||||
return if $self->{pbot}->{registry}->get_value('plugins', 'disabled');
|
||||
return if $self->{pbot}->{registry}->get_value('plugins', 'disabled');
|
||||
|
||||
my $path = $self->{pbot}->{registry}->get_value('general', 'plugin_dir') // 'Plugins';
|
||||
my $path = $self->{pbot}->{registry}->get_value('general', 'plugin_dir') // 'Plugins';
|
||||
|
||||
if (not grep { $_ eq $path } @INC) {
|
||||
unshift @INC, $path;
|
||||
}
|
||||
|
||||
$self->{pbot}->{refresher}->{refresher}->refresh_module("$path/$plugin.pm");
|
||||
|
||||
my $ret = eval {
|
||||
require "$path/$plugin.pm";
|
||||
|
||||
if ($@) {
|
||||
chomp $@;
|
||||
$self->{pbot}->{logger}->log("Error loading $plugin: $@\n");
|
||||
return 0;
|
||||
if (not grep { $_ eq $path } @INC) {
|
||||
unshift @INC, $path;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Loading $plugin\n");
|
||||
my $class = "Plugins::$plugin";
|
||||
$self->{plugins}->{$plugin} = $class->new(pbot => $self->{pbot}, %conf);
|
||||
$self->{pbot}->{refresher}->{refresher}->update_cache("$path/$plugin.pm");
|
||||
return 1;
|
||||
};
|
||||
$self->{pbot}->{refresher}->{refresher}->refresh_module("$path/$plugin.pm");
|
||||
|
||||
if ($@) {
|
||||
chomp $@;
|
||||
$self->{pbot}->{logger}->log("Error loading $plugin: $@\n");
|
||||
return 0;
|
||||
}
|
||||
return $ret;
|
||||
my $ret = eval {
|
||||
require "$path/$plugin.pm";
|
||||
|
||||
if ($@) {
|
||||
chomp $@;
|
||||
$self->{pbot}->{logger}->log("Error loading $plugin: $@\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Loading $plugin\n");
|
||||
my $class = "Plugins::$plugin";
|
||||
$self->{plugins}->{$plugin} = $class->new(pbot => $self->{pbot}, %conf);
|
||||
$self->{pbot}->{refresher}->{refresher}->update_cache("$path/$plugin.pm");
|
||||
return 1;
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
chomp $@;
|
||||
$self->{pbot}->{logger}->log("Error loading $plugin: $@\n");
|
||||
return 0;
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my ($self, $plugin) = @_;
|
||||
my ($self, $plugin) = @_;
|
||||
|
||||
if (exists $self->{plugins}->{$plugin}) {
|
||||
eval {
|
||||
$self->{plugins}->{$plugin}->unload;
|
||||
delete $self->{plugins}->{$plugin};
|
||||
};
|
||||
if ($@) {
|
||||
chomp $@;
|
||||
$self->{pbot}->{logger}->log("Warning: got error unloading plugin $plugin: $@\n");
|
||||
if (exists $self->{plugins}->{$plugin}) {
|
||||
eval {
|
||||
$self->{plugins}->{$plugin}->unload;
|
||||
delete $self->{plugins}->{$plugin};
|
||||
};
|
||||
if ($@) {
|
||||
chomp $@;
|
||||
$self->{pbot}->{logger}->log("Warning: got error unloading plugin $plugin: $@\n");
|
||||
}
|
||||
|
||||
my $path = $self->{pbot}->{registry}->get_value('general', 'plugin_dir') // 'Plugins';
|
||||
my $class = $path;
|
||||
$class =~ s,[/\\],::,g;
|
||||
|
||||
$self->{pbot}->{refresher}->{refresher}->unload_module($class . '::' . $plugin);
|
||||
$self->{pbot}->{refresher}->{refresher}->unload_subs("$path/$plugin.pm");
|
||||
|
||||
$self->{pbot}->{logger}->log("Plugin $plugin unloaded.\n");
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $path = $self->{pbot}->{registry}->get_value('general', 'plugin_dir') // 'Plugins';
|
||||
my $class = $path;
|
||||
$class =~ s,[/\\],::,g;
|
||||
|
||||
$self->{pbot}->{refresher}->{refresher}->unload_module($class . '::' . $plugin);
|
||||
$self->{pbot}->{refresher}->{refresher}->unload_subs("$path/$plugin.pm");
|
||||
|
||||
$self->{pbot}->{logger}->log("Plugin $plugin unloaded.\n");
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub reload_cmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
if (not length $arguments) {
|
||||
return "Usage: replug <plugin>";
|
||||
}
|
||||
if (not length $arguments) { return "Usage: replug <plugin>"; }
|
||||
|
||||
my $unload_result = $self->unload_cmd($from, $nick, $user, $host, $arguments);
|
||||
my $load_result = $self->load_cmd($from, $nick, $user, $host, $arguments);
|
||||
my $unload_result = $self->unload_cmd($from, $nick, $user, $host, $arguments);
|
||||
my $load_result = $self->load_cmd($from, $nick, $user, $host, $arguments);
|
||||
|
||||
my $result = "";
|
||||
$result .= "$unload_result " if $unload_result =~ m/^Unloaded/;
|
||||
$result .= $load_result;
|
||||
return $result;
|
||||
my $result = "";
|
||||
$result .= "$unload_result " if $unload_result =~ m/^Unloaded/;
|
||||
$result .= $load_result;
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub load_cmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
if (not length $arguments) {
|
||||
return "Usage: plug <plugin>";
|
||||
}
|
||||
if (not length $arguments) { return "Usage: plug <plugin>"; }
|
||||
|
||||
if ($self->load($arguments)) {
|
||||
return "Loaded $arguments plugin.";
|
||||
} else {
|
||||
return "Plugin $arguments failed to load.";
|
||||
}
|
||||
if ($self->load($arguments)) { return "Loaded $arguments plugin."; }
|
||||
else { return "Plugin $arguments failed to load."; }
|
||||
}
|
||||
|
||||
sub unload_cmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
if (not length $arguments) {
|
||||
return "Usage: unplug <plugin>";
|
||||
}
|
||||
if (not length $arguments) { return "Usage: unplug <plugin>"; }
|
||||
|
||||
if ($self->unload($arguments)) {
|
||||
return "Unloaded $arguments plugin.";
|
||||
} else {
|
||||
return "Plugin $arguments is not loaded.";
|
||||
}
|
||||
if ($self->unload($arguments)) { return "Unloaded $arguments plugin."; }
|
||||
else { return "Plugin $arguments is not loaded."; }
|
||||
}
|
||||
|
||||
sub list_cmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my $result = "Loaded plugins: ";
|
||||
my $count = 0;
|
||||
my $comma = '';
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my $result = "Loaded plugins: ";
|
||||
my $count = 0;
|
||||
my $comma = '';
|
||||
|
||||
foreach my $plugin (sort keys %{ $self->{plugins} }) {
|
||||
$result .= $comma . $plugin;
|
||||
$count++;
|
||||
$comma = ', ';
|
||||
}
|
||||
foreach my $plugin (sort keys %{$self->{plugins}}) {
|
||||
$result .= $comma . $plugin;
|
||||
$count++;
|
||||
$comma = ', ';
|
||||
}
|
||||
|
||||
$result .= 'none' if $count == 0;
|
||||
return $result;
|
||||
$result .= 'none' if $count == 0;
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::ProcessManager;
|
||||
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -17,174 +18,180 @@ use POSIX qw(WNOHANG);
|
|||
use JSON;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->ps_cmd(@_) }, 'ps', 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->kill_cmd(@_) }, 'kill', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-kill');
|
||||
$self->{processes} = {};
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->ps_cmd(@_) }, 'ps', 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->kill_cmd(@_) }, 'kill', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-kill');
|
||||
$self->{processes} = {};
|
||||
|
||||
# automatically reap children processes in background
|
||||
$SIG{CHLD} = sub { my $pid; do { $pid = waitpid(-1, WNOHANG); $self->remove_process($pid) if $pid > 0; } while $pid > 0; };
|
||||
# automatically reap children processes in background
|
||||
$SIG{CHLD} = sub {
|
||||
my $pid; do { $pid = waitpid(-1, WNOHANG); $self->remove_process($pid) if $pid > 0; } while $pid > 0;
|
||||
};
|
||||
}
|
||||
|
||||
sub ps_cmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my @processes;
|
||||
foreach my $pid (sort keys %{$self->{processes}}) {
|
||||
push @processes, "$pid: $self->{processes}->{$pid}->{commands}->[0]";
|
||||
}
|
||||
if (@processes) {
|
||||
return "Running processes: " . join '; ', @processes;
|
||||
} else {
|
||||
return "No running processes.";
|
||||
}
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my @processes;
|
||||
foreach my $pid (sort keys %{$self->{processes}}) { push @processes, "$pid: $self->{processes}->{$pid}->{commands}->[0]"; }
|
||||
if (@processes) { return "Running processes: " . join '; ', @processes; }
|
||||
else { return "No running processes."; }
|
||||
}
|
||||
|
||||
sub kill_cmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "Usage: kill <pids...>";
|
||||
my @pids;
|
||||
while (1) {
|
||||
my $pid = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // last;
|
||||
return "No such pid $pid." if not exists $self->{processes}->{$pid};
|
||||
push @pids, $pid;
|
||||
}
|
||||
return $usage if not @pids;
|
||||
kill 'INT', @pids;
|
||||
return "Killed.";
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "Usage: kill <pids...>";
|
||||
my @pids;
|
||||
while (1) {
|
||||
my $pid = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // last;
|
||||
return "No such pid $pid." if not exists $self->{processes}->{$pid};
|
||||
push @pids, $pid;
|
||||
}
|
||||
return $usage if not @pids;
|
||||
kill 'INT', @pids;
|
||||
return "Killed.";
|
||||
}
|
||||
|
||||
sub add_process {
|
||||
my ($self, $pid, $stuff) = @_;
|
||||
$self->{processes}->{$pid} = $stuff;
|
||||
my ($self, $pid, $stuff) = @_;
|
||||
$self->{processes}->{$pid} = $stuff;
|
||||
}
|
||||
|
||||
sub remove_process {
|
||||
my ($self, $pid) = @_;
|
||||
delete $self->{processes}->{$pid};
|
||||
my ($self, $pid) = @_;
|
||||
delete $self->{processes}->{$pid};
|
||||
}
|
||||
|
||||
sub execute_process {
|
||||
my ($self, $stuff, $subref, $timeout) = @_;
|
||||
$timeout //= 30;
|
||||
my ($self, $stuff, $subref, $timeout) = @_;
|
||||
$timeout //= 30;
|
||||
|
||||
if (not exists $stuff->{commands}) {
|
||||
$stuff->{commands} = [ $stuff->{command} ];
|
||||
}
|
||||
if (not exists $stuff->{commands}) { $stuff->{commands} = [$stuff->{command}]; }
|
||||
|
||||
pipe(my $reader, my $writer);
|
||||
$stuff->{pid} = fork;
|
||||
pipe(my $reader, my $writer);
|
||||
$stuff->{pid} = fork;
|
||||
|
||||
if (not defined $stuff->{pid}) {
|
||||
$self->{pbot}->{logger}->log("Could not fork process: $!\n");
|
||||
close $reader;
|
||||
close $writer;
|
||||
$stuff->{checkflood} = 1;
|
||||
$self->{pbot}->{interpreter}->handle_result($stuff, "/me groans loudly.\n");
|
||||
return;
|
||||
}
|
||||
|
||||
if ($stuff->{pid} == 0) {
|
||||
# child
|
||||
close $reader;
|
||||
|
||||
# don't quit the IRC client when the child dies
|
||||
no warnings;
|
||||
*PBot::IRC::Connection::DESTROY = sub { return; };
|
||||
use warnings;
|
||||
|
||||
# remove atexit handlers
|
||||
$self->{pbot}->{atexit}->unregister_all;
|
||||
|
||||
# execute the provided subroutine, results are stored in $stuff
|
||||
eval {
|
||||
local $SIG{ALRM} = sub { die "PBot::Process `$stuff->{commands}->[0]` timed-out" };
|
||||
alarm $timeout;
|
||||
$subref->($stuff);
|
||||
die if $@;
|
||||
};
|
||||
alarm 0;
|
||||
|
||||
# check for errors
|
||||
if ($@) {
|
||||
$stuff->{result} = $@;
|
||||
$self->{pbot}->{logger}->log("Error executing process: $stuff->{result}\n");
|
||||
$stuff->{result} =~ s/ at PBot.*$//ms;
|
||||
if (not defined $stuff->{pid}) {
|
||||
$self->{pbot}->{logger}->log("Could not fork process: $!\n");
|
||||
close $reader;
|
||||
close $writer;
|
||||
$stuff->{checkflood} = 1;
|
||||
$self->{pbot}->{interpreter}->handle_result($stuff, "/me groans loudly.\n");
|
||||
return;
|
||||
}
|
||||
|
||||
# print $stuff to pipe
|
||||
my $json = encode_json $stuff;
|
||||
print $writer "$json\n";
|
||||
if ($stuff->{pid} == 0) {
|
||||
|
||||
# end child
|
||||
exit 0;
|
||||
} else {
|
||||
# parent
|
||||
close $writer;
|
||||
$self->add_process($stuff->{pid}, $stuff);
|
||||
$self->{pbot}->{select_handler}->add_reader($reader, sub { $self->process_pipe_reader($stuff->{pid}, @_) });
|
||||
# return empty string since reader will handle the output when child is finished
|
||||
return "";
|
||||
}
|
||||
# child
|
||||
close $reader;
|
||||
|
||||
# don't quit the IRC client when the child dies
|
||||
no warnings;
|
||||
*PBot::IRC::Connection::DESTROY = sub { return; };
|
||||
use warnings;
|
||||
|
||||
# remove atexit handlers
|
||||
$self->{pbot}->{atexit}->unregister_all;
|
||||
|
||||
# execute the provided subroutine, results are stored in $stuff
|
||||
eval {
|
||||
local $SIG{ALRM} = sub { die "PBot::Process `$stuff->{commands}->[0]` timed-out" };
|
||||
alarm $timeout;
|
||||
$subref->($stuff);
|
||||
die if $@;
|
||||
};
|
||||
alarm 0;
|
||||
|
||||
# check for errors
|
||||
if ($@) {
|
||||
$stuff->{result} = $@;
|
||||
$self->{pbot}->{logger}->log("Error executing process: $stuff->{result}\n");
|
||||
$stuff->{result} =~ s/ at PBot.*$//ms;
|
||||
}
|
||||
|
||||
# print $stuff to pipe
|
||||
my $json = encode_json $stuff;
|
||||
print $writer "$json\n";
|
||||
|
||||
# end child
|
||||
exit 0;
|
||||
} else {
|
||||
|
||||
# parent
|
||||
close $writer;
|
||||
$self->add_process($stuff->{pid}, $stuff);
|
||||
$self->{pbot}->{select_handler}->add_reader($reader, sub { $self->process_pipe_reader($stuff->{pid}, @_) });
|
||||
|
||||
# return empty string since reader will handle the output when child is finished
|
||||
return "";
|
||||
}
|
||||
}
|
||||
|
||||
sub process_pipe_reader {
|
||||
my ($self, $pid, $buf) = @_;
|
||||
my $stuff = decode_json $buf or do {
|
||||
$self->{pbot}->{logger}->log("Failed to decode bad json: [$buf]\n");
|
||||
return;
|
||||
};
|
||||
my ($self, $pid, $buf) = @_;
|
||||
my $stuff = decode_json $buf or do {
|
||||
$self->{pbot}->{logger}->log("Failed to decode bad json: [$buf]\n");
|
||||
return;
|
||||
};
|
||||
|
||||
if (not defined $stuff->{result} or not length $stuff->{result}) {
|
||||
$self->{pbot}->{logger}->log("No result from process.\n");
|
||||
return;
|
||||
}
|
||||
|
||||
if ($stuff->{referenced}) {
|
||||
return if $stuff->{result} =~ m/(?:no results)/i;
|
||||
}
|
||||
|
||||
if (exists $stuff->{special} and $stuff->{special} eq 'code-factoid') {
|
||||
$stuff->{result} =~ s/\s+$//g;
|
||||
$self->{pbot}->{logger}->log("No text result from code-factoid.\n") and return if not length $stuff->{result};
|
||||
$stuff->{original_keyword} = $stuff->{root_keyword};
|
||||
$stuff->{result} = $self->{pbot}->{factoids}->handle_action($stuff, $stuff->{result});
|
||||
}
|
||||
|
||||
$stuff->{checkflood} = 0;
|
||||
|
||||
if (defined $stuff->{nickoverride}) {
|
||||
$self->{pbot}->{interpreter}->handle_result($stuff, $stuff->{result});
|
||||
} else {
|
||||
# don't override nick if already set
|
||||
if (exists $stuff->{special} and $stuff->{special} ne 'code-factoid' and $self->{pbot}->{factoids}->{factoids}->exists($stuff->{channel}, $stuff->{trigger}, 'add_nick') and $self->{pbot}->{factoids}->{factoids}->get_data($stuff->{channel}, $stuff->{trigger}, 'add_nick') != 0) {
|
||||
$stuff->{nickoverride} = $stuff->{nick};
|
||||
$stuff->{no_nickoverride} = 0;
|
||||
$stuff->{force_nickoverride} = 1;
|
||||
} else {
|
||||
# extract nick-like thing from module result
|
||||
if ($stuff->{result} =~ s/^(\S+): //) {
|
||||
my $nick = $1;
|
||||
if (lc $nick eq "usage") {
|
||||
# put it back on result if it's a usage message
|
||||
$stuff->{result} = "$nick: $stuff->{result}";
|
||||
} else {
|
||||
my $present = $self->{pbot}->{nicklist}->is_present($stuff->{channel}, $nick);
|
||||
if ($present) {
|
||||
# nick is present in channel
|
||||
$stuff->{nickoverride} = $present;
|
||||
} else {
|
||||
# nick not present, put it back on result
|
||||
$stuff->{result} = "$nick: $stuff->{result}";
|
||||
}
|
||||
}
|
||||
}
|
||||
if (not defined $stuff->{result} or not length $stuff->{result}) {
|
||||
$self->{pbot}->{logger}->log("No result from process.\n");
|
||||
return;
|
||||
}
|
||||
$self->{pbot}->{interpreter}->handle_result($stuff, $stuff->{result});
|
||||
}
|
||||
|
||||
my $text = $self->{pbot}->{interpreter}->truncate_result($stuff->{channel}, $self->{pbot}->{registry}->get_value('irc', 'botnick'), 'undef', $stuff->{result}, $stuff->{result}, 0);
|
||||
$self->{pbot}->{antiflood}->check_flood($stuff->{from}, $self->{pbot}->{registry}->get_value('irc', 'botnick'), $self->{pbot}->{registry}->get_value('irc', 'username'), 'pbot', $text, 0, 0, 0);
|
||||
if ($stuff->{referenced}) { return if $stuff->{result} =~ m/(?:no results)/i; }
|
||||
|
||||
if (exists $stuff->{special} and $stuff->{special} eq 'code-factoid') {
|
||||
$stuff->{result} =~ s/\s+$//g;
|
||||
$self->{pbot}->{logger}->log("No text result from code-factoid.\n") and return if not length $stuff->{result};
|
||||
$stuff->{original_keyword} = $stuff->{root_keyword};
|
||||
$stuff->{result} = $self->{pbot}->{factoids}->handle_action($stuff, $stuff->{result});
|
||||
}
|
||||
|
||||
$stuff->{checkflood} = 0;
|
||||
|
||||
if (defined $stuff->{nickoverride}) { $self->{pbot}->{interpreter}->handle_result($stuff, $stuff->{result}); }
|
||||
else {
|
||||
|
||||
# don't override nick if already set
|
||||
if ( exists $stuff->{special}
|
||||
and $stuff->{special} ne 'code-factoid'
|
||||
and $self->{pbot}->{factoids}->{factoids}->exists($stuff->{channel}, $stuff->{trigger}, 'add_nick')
|
||||
and $self->{pbot}->{factoids}->{factoids}->get_data($stuff->{channel}, $stuff->{trigger}, 'add_nick') != 0)
|
||||
{
|
||||
$stuff->{nickoverride} = $stuff->{nick};
|
||||
$stuff->{no_nickoverride} = 0;
|
||||
$stuff->{force_nickoverride} = 1;
|
||||
} else {
|
||||
|
||||
# extract nick-like thing from module result
|
||||
if ($stuff->{result} =~ s/^(\S+): //) {
|
||||
my $nick = $1;
|
||||
if (lc $nick eq "usage") {
|
||||
|
||||
# put it back on result if it's a usage message
|
||||
$stuff->{result} = "$nick: $stuff->{result}";
|
||||
} else {
|
||||
my $present = $self->{pbot}->{nicklist}->is_present($stuff->{channel}, $nick);
|
||||
if ($present) {
|
||||
|
||||
# nick is present in channel
|
||||
$stuff->{nickoverride} = $present;
|
||||
} else {
|
||||
|
||||
# nick not present, put it back on result
|
||||
$stuff->{result} = "$nick: $stuff->{result}";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
$self->{pbot}->{interpreter}->handle_result($stuff, $stuff->{result});
|
||||
}
|
||||
|
||||
my $text = $self->{pbot}->{interpreter}
|
||||
->truncate_result($stuff->{channel}, $self->{pbot}->{registry}->get_value('irc', 'botnick'), 'undef', $stuff->{result}, $stuff->{result}, 0);
|
||||
$self->{pbot}->{antiflood}
|
||||
->check_flood($stuff->{from}, $self->{pbot}->{registry}->get_value('irc', 'botnick'), $self->{pbot}->{registry}->get_value('irc', 'username'), 'pbot', $text, 0, 0, 0);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -18,31 +18,31 @@ use feature 'unicode_strings';
|
|||
use Module::Refresh;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{refresher} = Module::Refresh->new;
|
||||
$self->{pbot}->{commands}->register(sub { $self->refresh(@_) }, "refresh", 1);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{refresher} = Module::Refresh->new;
|
||||
$self->{pbot}->{commands}->register(sub { $self->refresh(@_) }, "refresh", 1);
|
||||
}
|
||||
|
||||
sub refresh {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my $result = eval {
|
||||
if (not $arguments) {
|
||||
$self->{pbot}->{logger}->log("Refreshing all modified modules\n");
|
||||
$self->{refresher}->refresh;
|
||||
return "Refreshed all modified modules.\n";
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("Refreshing module $arguments\n");
|
||||
$self->{refresher}->refresh_module($arguments);
|
||||
$self->{pbot}->{logger}->log("Refreshed module.\n");
|
||||
return "Refreshed module.\n";
|
||||
}
|
||||
};
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my $result = eval {
|
||||
if (not $arguments) {
|
||||
$self->{pbot}->{logger}->log("Refreshing all modified modules\n");
|
||||
$self->{refresher}->refresh;
|
||||
return "Refreshed all modified modules.\n";
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("Refreshing module $arguments\n");
|
||||
$self->{refresher}->refresh_module($arguments);
|
||||
$self->{pbot}->{logger}->log("Refreshed module.\n");
|
||||
return "Refreshed module.\n";
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Error refreshing: $@\n");
|
||||
return $@;
|
||||
}
|
||||
return $result;
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Error refreshing: $@\n");
|
||||
return $@;
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -13,58 +13,56 @@ use warnings; use strict;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
sub new {
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
Carp::croak("Missing pbot reference to " . __FILE__) unless exists $conf{pbot};
|
||||
$self->{pbot} = $conf{pbot};
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
Carp::croak("Missing pbot reference to " . __FILE__) unless exists $conf{pbot};
|
||||
$self->{pbot} = $conf{pbot};
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my $self = shift;
|
||||
$self->{handlers} = [];
|
||||
my $self = shift;
|
||||
$self->{handlers} = [];
|
||||
}
|
||||
|
||||
sub execute_all {
|
||||
my $self = shift;
|
||||
foreach my $func (@{ $self->{handlers} }) {
|
||||
my $result = &{ $func->{subref} }(@_);
|
||||
return $result if defined $result;
|
||||
}
|
||||
return undef;
|
||||
my $self = shift;
|
||||
foreach my $func (@{$self->{handlers}}) {
|
||||
my $result = &{$func->{subref}}(@_);
|
||||
return $result if defined $result;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub execute {
|
||||
my $self = shift;
|
||||
my $ref = shift;
|
||||
Carp::croak("Missing reference parameter to Registerable::execute") if not defined $ref;
|
||||
foreach my $func (@{ $self->{handlers} }) {
|
||||
if ($ref == $func || $ref == $func->{subref}) {
|
||||
return &{ $func->{subref} }(@_);
|
||||
my $self = shift;
|
||||
my $ref = shift;
|
||||
Carp::croak("Missing reference parameter to Registerable::execute") if not defined $ref;
|
||||
foreach my $func (@{$self->{handlers}}) {
|
||||
if ($ref == $func || $ref == $func->{subref}) { return &{$func->{subref}}(@_); }
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub register {
|
||||
my ($self, $subref) = @_;
|
||||
Carp::croak("Must pass subroutine reference to register()") if not defined $subref;
|
||||
my $ref = { subref => $subref };
|
||||
push @{ $self->{handlers} }, $ref;
|
||||
return $ref;
|
||||
my ($self, $subref) = @_;
|
||||
Carp::croak("Must pass subroutine reference to register()") if not defined $subref;
|
||||
my $ref = {subref => $subref};
|
||||
push @{$self->{handlers}}, $ref;
|
||||
return $ref;
|
||||
}
|
||||
|
||||
sub unregister {
|
||||
my ($self, $ref) = @_;
|
||||
Carp::croak("Must pass reference to unregister()") if not defined $ref;
|
||||
@{ $self->{handlers} } = grep { $_ != $ref } @{ $self->{handlers} };
|
||||
my ($self, $ref) = @_;
|
||||
Carp::croak("Must pass reference to unregister()") if not defined $ref;
|
||||
@{$self->{handlers}} = grep { $_ != $ref } @{$self->{handlers}};
|
||||
}
|
||||
|
||||
sub unregister_all {
|
||||
my ($self) = @_;
|
||||
$self->{handlers} = [];
|
||||
my ($self) = @_;
|
||||
$self->{handlers} = [];
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
184
PBot/Registry.pm
184
PBot/Registry.pm
|
|
@ -9,6 +9,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::Registry;
|
||||
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -18,158 +19,141 @@ use Time::HiRes qw(gettimeofday);
|
|||
use PBot::RegistryCommands;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
my $filename = $conf{filename} // Carp::croak("Missing filename reference in " . __FILE__);
|
||||
$self->{registry} = PBot::DualIndexHashObject->new(name => 'Registry', filename => $filename, pbot => $self->{pbot});
|
||||
$self->{triggers} = {};
|
||||
$self->{pbot}->{atexit}->register(sub { $self->save; return; });
|
||||
PBot::RegistryCommands->new(pbot => $self->{pbot});
|
||||
my ($self, %conf) = @_;
|
||||
my $filename = $conf{filename} // Carp::croak("Missing filename reference in " . __FILE__);
|
||||
$self->{registry} = PBot::DualIndexHashObject->new(name => 'Registry', filename => $filename, pbot => $self->{pbot});
|
||||
$self->{triggers} = {};
|
||||
$self->{pbot}->{atexit}->register(sub { $self->save; return; });
|
||||
PBot::RegistryCommands->new(pbot => $self->{pbot});
|
||||
}
|
||||
|
||||
sub load {
|
||||
my $self = shift;
|
||||
$self->{registry}->load;
|
||||
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'));
|
||||
my $self = shift;
|
||||
$self->{registry}->load;
|
||||
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')); }
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub save {
|
||||
my $self = shift;
|
||||
$self->{registry}->save;
|
||||
my $self = shift;
|
||||
$self->{registry}->save;
|
||||
}
|
||||
|
||||
sub add_default {
|
||||
my ($self, $type, $section, $item, $value) = @_;
|
||||
$self->add($type, $section, $item, $value, 1);
|
||||
my ($self, $type, $section, $item, $value) = @_;
|
||||
$self->add($type, $section, $item, $value, 1);
|
||||
}
|
||||
|
||||
sub add {
|
||||
my $self = shift;
|
||||
my ($type, $section, $item, $value, $is_default) = @_;
|
||||
$type = lc $type;
|
||||
my $self = shift;
|
||||
my ($type, $section, $item, $value, $is_default) = @_;
|
||||
$type = lc $type;
|
||||
|
||||
if ($is_default) {
|
||||
return if $self->{registry}->exists($section, $item);
|
||||
}
|
||||
if ($is_default) { return if $self->{registry}->exists($section, $item); }
|
||||
|
||||
if (not $self->{registry}->exists($section, $item)) {
|
||||
my $data = {
|
||||
value => $value,
|
||||
type => $type,
|
||||
};
|
||||
$self->{registry}->add($section, $item, $data, 1);
|
||||
} else {
|
||||
$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;
|
||||
if (not $self->{registry}->exists($section, $item)) {
|
||||
my $data = {
|
||||
value => $value,
|
||||
type => $type,
|
||||
};
|
||||
$self->{registry}->add($section, $item, $data, 1);
|
||||
} else {
|
||||
$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;
|
||||
}
|
||||
|
||||
sub remove {
|
||||
my $self = shift;
|
||||
my ($section, $item) = @_;
|
||||
$self->{registry}->remove($section, $item);
|
||||
my $self = shift;
|
||||
my ($section, $item) = @_;
|
||||
$self->{registry}->remove($section, $item);
|
||||
}
|
||||
|
||||
sub set_default {
|
||||
my ($self, $section, $item, $key, $value) = @_;
|
||||
$self->set($section, $item, $key, $value, 1);
|
||||
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;
|
||||
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) { return if $self->{registry}->exists($section, $item, $key); }
|
||||
|
||||
my $oldvalue = $self->get_value($section, $item, 1) if defined $value;
|
||||
$oldvalue = '' if not defined $oldvalue;
|
||||
my $oldvalue = $self->get_value($section, $item, 1) if defined $value;
|
||||
$oldvalue = '' if not defined $oldvalue;
|
||||
|
||||
my $result = $self->{registry}->set($section, $item, $key, $value, 1);
|
||||
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;
|
||||
$self->save if !$dont_save && $result =~ m/set to/ && not $is_default;
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub unset {
|
||||
my ($self, $section, $item, $key) = @_;
|
||||
$key = lc $key;
|
||||
return $self->{registry}->unset($section, $item, $key);
|
||||
my ($self, $section, $item, $key) = @_;
|
||||
$key = lc $key;
|
||||
return $self->{registry}->unset($section, $item, $key);
|
||||
}
|
||||
|
||||
sub get_value {
|
||||
my ($self, $section, $item, $as_text, $stuff) = @_;
|
||||
$section = lc $section;
|
||||
$item = lc $item;
|
||||
my $key = $item;
|
||||
my ($self, $section, $item, $as_text, $stuff) = @_;
|
||||
$section = lc $section;
|
||||
$item = lc $item;
|
||||
my $key = $item;
|
||||
|
||||
# TODO: use user-metadata for this
|
||||
if (defined $stuff and exists $stuff->{nick}) {
|
||||
my $stuff_nick = lc $stuff->{nick};
|
||||
if ($self->{registry}->exists($section, "$item.nick.$stuff_nick")) {
|
||||
$key = "$item.nick.$stuff_nick";
|
||||
# TODO: use user-metadata for this
|
||||
if (defined $stuff and exists $stuff->{nick}) {
|
||||
my $stuff_nick = lc $stuff->{nick};
|
||||
if ($self->{registry}->exists($section, "$item.nick.$stuff_nick")) { $key = "$item.nick.$stuff_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 ($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'); }
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub get_array_value {
|
||||
my ($self, $section, $item, $index, $stuff) = @_;
|
||||
$section = lc $section;
|
||||
$item = lc $item;
|
||||
my $key = $item;
|
||||
my ($self, $section, $item, $index, $stuff) = @_;
|
||||
$section = lc $section;
|
||||
$item = lc $item;
|
||||
my $key = $item;
|
||||
|
||||
# TODO: use user-metadata for this
|
||||
if (defined $stuff and exists $stuff->{nick}) {
|
||||
my $stuff_nick = lc $stuff->{nick};
|
||||
if ($self->{registry}->exists($section, "$item.nick.$stuff_nick")) {
|
||||
$key = "$item.nick.$stuff_nick";
|
||||
# TODO: use user-metadata for this
|
||||
if (defined $stuff and exists $stuff->{nick}) {
|
||||
my $stuff_nick = lc $stuff->{nick};
|
||||
if ($self->{registry}->exists($section, "$item.nick.$stuff_nick")) { $key = "$item.nick.$stuff_nick"; }
|
||||
}
|
||||
}
|
||||
|
||||
if ($self->{registry}->exists($section, $key)) {
|
||||
if ($self->{registry}->get_data($section, $key, 'type') eq 'array') {
|
||||
my @array = split /\s*,\s*/, $self->{registry}->get_data($section, $key, 'value');
|
||||
return $array[$index >= $#array ? $#array : $index];
|
||||
} else {
|
||||
return $self->{registry}->get_data($section, $key, 'value');
|
||||
if ($self->{registry}->exists($section, $key)) {
|
||||
if ($self->{registry}->get_data($section, $key, 'type') eq 'array') {
|
||||
my @array = split /\s*,\s*/, $self->{registry}->get_data($section, $key, 'value');
|
||||
return $array[$index >= $#array ? $#array : $index];
|
||||
} else {
|
||||
return $self->{registry}->get_data($section, $key, 'value');
|
||||
}
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub add_trigger {
|
||||
my ($self, $section, $item, $subref) = @_;
|
||||
$self->{triggers}->{lc $section}->{lc $item} = $subref;
|
||||
my ($self, $section, $item, $subref) = @_;
|
||||
$self->{triggers}->{lc $section}->{lc $item} = $subref;
|
||||
}
|
||||
|
||||
sub process_trigger {
|
||||
my $self = shift;
|
||||
my ($section, $item) = @_;
|
||||
$section = lc $section;
|
||||
$item = lc $item;
|
||||
if (exists $self->{triggers}->{$section} and exists $self->{triggers}->{$section}->{$item}) {
|
||||
return &{ $self->{triggers}->{$section}->{$item} }(@_);
|
||||
}
|
||||
return undef;
|
||||
my $self = shift;
|
||||
my ($section, $item) = @_;
|
||||
$section = lc $section;
|
||||
$item = lc $item;
|
||||
if (exists $self->{triggers}->{$section} and exists $self->{triggers}->{$section}->{$item}) { return &{$self->{triggers}->{$section}->{$item}}(@_); }
|
||||
return undef;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -14,283 +14,249 @@ use warnings; use strict;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->regset(@_) }, "regset", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->regunset(@_) }, "regunset", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->regshow(@_) }, "regshow", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->regsetmeta(@_) }, "regsetmeta", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->regunsetmeta(@_) }, "regunsetmeta", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->regchange(@_) }, "regchange", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->regfind(@_) }, "regfind", 0);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->regset(@_) }, "regset", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->regunset(@_) }, "regunset", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->regshow(@_) }, "regshow", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->regsetmeta(@_) }, "regsetmeta", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->regunsetmeta(@_) }, "regunsetmeta", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->regchange(@_) }, "regchange", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->regfind(@_) }, "regfind", 0);
|
||||
}
|
||||
|
||||
sub regset {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "Usage: regset <section>.<item> [value]";
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "Usage: regset <section>.<item> [value]";
|
||||
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // return $usage;
|
||||
my ($item, $value);
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
($value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 1);
|
||||
} else {
|
||||
($item, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
}
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // return $usage;
|
||||
my ($item, $value);
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
($value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 1);
|
||||
} else {
|
||||
($item, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{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("$nick!$user\@$host set registry entry [$section] $item => $value\n");
|
||||
return "$section.$item set to $value";
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host set registry entry [$section] $item => $value\n");
|
||||
return "$section.$item set to $value";
|
||||
}
|
||||
|
||||
sub regunset {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "Usage: regunset <section>.<item>";
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "Usage: regunset <section>.<item>";
|
||||
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // return $usage;
|
||||
my $item;
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
} else {
|
||||
($item) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 1);
|
||||
}
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // return $usage;
|
||||
my $item;
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) { ($section, $item) = ($1, $2); }
|
||||
else { ($item) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 1); }
|
||||
|
||||
if (not defined $section or not defined $item) {
|
||||
return $usage;
|
||||
}
|
||||
if (not defined $section or not defined $item) { return $usage; }
|
||||
|
||||
if (not $self->{pbot}->{registry}->{registry}->exits($section)) {
|
||||
return "No such registry section $section.";
|
||||
}
|
||||
if (not $self->{pbot}->{registry}->{registry}->exits($section)) { return "No such registry section $section."; }
|
||||
|
||||
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, $item)) { return "No such item $item in section $section."; }
|
||||
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host removed registry entry $section.$item\n");
|
||||
$self->{pbot}->{registry}->remove($section, $item);
|
||||
return "$section.$item deleted from registry";
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host removed registry entry $section.$item\n");
|
||||
$self->{pbot}->{registry}->remove($section, $item);
|
||||
return "$section.$item deleted from registry";
|
||||
}
|
||||
|
||||
sub regsetmeta {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "Usage: regsetmeta <section>.<item> [key [value]]";
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "Usage: regsetmeta <section>.<item> [key [value]]";
|
||||
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // return $usage;
|
||||
my ($item, $key, $value);
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
($key, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
} else {
|
||||
($item, $key, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3);
|
||||
}
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // return $usage;
|
||||
my ($item, $key, $value);
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
($key, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
} else {
|
||||
($item, $key, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{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);
|
||||
$key = undef if not length $key;
|
||||
$value = undef if not length $value;
|
||||
return $self->{pbot}->{registry}->set($section, $item, $key, $value);
|
||||
}
|
||||
|
||||
sub regunsetmeta {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "Usage: regunsetmeta <section>.<item> <key>";
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "Usage: regunsetmeta <section>.<item> <key>";
|
||||
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // return $usage;
|
||||
my ($item, $key);
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
($key) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 1);
|
||||
} else {
|
||||
($item, $key) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
}
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // return $usage;
|
||||
my ($item, $key);
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
($key) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 1);
|
||||
} else {
|
||||
($item, $key) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
}
|
||||
|
||||
if (not defined $section or not defined $item or not defined $key) {
|
||||
return $usage;
|
||||
}
|
||||
return $self->{pbot}->{registry}->unset($section, $item, $key);
|
||||
if (not defined $section or not defined $item or not defined $key) { return $usage; }
|
||||
return $self->{pbot}->{registry}->unset($section, $item, $key);
|
||||
}
|
||||
|
||||
sub regshow {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $registry = $self->{pbot}->{registry}->{registry};
|
||||
my $usage = "Usage: regshow <section>.<item>";
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $registry = $self->{pbot}->{registry}->{registry};
|
||||
my $usage = "Usage: regshow <section>.<item>";
|
||||
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // return $usage;
|
||||
my $item;
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) {
|
||||
($section, $item) = ($1, $2);
|
||||
} else {
|
||||
($item) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 1);
|
||||
}
|
||||
# support "<section>.<key>" syntax in addition to "<section> <key>"
|
||||
my $section = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // return $usage;
|
||||
my $item;
|
||||
if ($section =~ m/^(.+?)\.(.+)$/) { ($section, $item) = ($1, $2); }
|
||||
else { ($item) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 1); }
|
||||
|
||||
if (not defined $section or not defined $item) {
|
||||
return $usage;
|
||||
}
|
||||
if (not defined $section or not defined $item) { return $usage; }
|
||||
|
||||
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."; }
|
||||
|
||||
if ($registry->get_data($section, $item, 'private')) {
|
||||
return "$section.$item: <private>";
|
||||
}
|
||||
if ($registry->get_data($section, $item, 'private')) { return "$section.$item: <private>"; }
|
||||
|
||||
my $result = "$section.$item: " . $registry->get_data($section, $item, 'value');
|
||||
my $result = "$section.$item: " . $registry->get_data($section, $item, 'value');
|
||||
|
||||
if ($registry->get_data($section, $item, 'type') eq 'array') {
|
||||
$result .= ' [array]';
|
||||
}
|
||||
return $result;
|
||||
if ($registry->get_data($section, $item, 'type') eq 'array') { $result .= ' [array]'; }
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub regfind {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
my $registry = $self->{pbot}->{registry}->{registry};
|
||||
my $usage = "Usage: regfind [-showvalues] [-section section] <regex>";
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
my $registry = $self->{pbot}->{registry}->{registry};
|
||||
my $usage = "Usage: regfind [-showvalues] [-section section] <regex>";
|
||||
|
||||
return $usage if not defined $arguments;
|
||||
return $usage if not defined $arguments;
|
||||
|
||||
my ($section, $showvalues);
|
||||
$section = $1 if $arguments =~ s/-section\s+([^\b\s]+)//i;
|
||||
$showvalues = 1 if $arguments =~ s/-showvalues?//i;
|
||||
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+/ /g;
|
||||
$arguments =~ s/^\s+//;
|
||||
$arguments =~ s/\s+$//;
|
||||
$arguments =~ s/\s+/ /g;
|
||||
|
||||
return $usage if $arguments eq "";
|
||||
return $usage if $arguments eq "";
|
||||
|
||||
$section = lc $section if defined $section;;
|
||||
$section = lc $section if defined $section;
|
||||
|
||||
my ($text, $last_item, $last_section, $i);
|
||||
$last_section = "";
|
||||
$i = 0;
|
||||
eval {
|
||||
use re::engine::RE2 -strict => 1;
|
||||
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';
|
||||
if ($registry->get_data($section_key, $item_key, 'private')) {
|
||||
# do not match on value if private
|
||||
next if $item_key !~ /$arguments/i;
|
||||
} else {
|
||||
next if $registry->get_data($section_key, $item_key, 'value') !~ /$arguments/i and $item_key !~ /$arguments/i;
|
||||
my ($text, $last_item, $last_section, $i);
|
||||
$last_section = "";
|
||||
$i = 0;
|
||||
eval {
|
||||
use re::engine::RE2 -strict => 1;
|
||||
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';
|
||||
if ($registry->get_data($section_key, $item_key, 'private')) {
|
||||
|
||||
# do not match on value if private
|
||||
next if $item_key !~ /$arguments/i;
|
||||
} else {
|
||||
next if $registry->get_data($section_key, $item_key, 'value') !~ /$arguments/i and $item_key !~ /$arguments/i;
|
||||
}
|
||||
|
||||
$i++;
|
||||
|
||||
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");
|
||||
}
|
||||
} else {
|
||||
$text .= " $item_key\n";
|
||||
}
|
||||
$last_item = $item_key;
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
$i++;
|
||||
return "/msg $nick $arguments: $@" if $@;
|
||||
|
||||
if ($section_key ne $last_section) {
|
||||
$text .= "[$section_key]\n";
|
||||
$last_section = $section_key;
|
||||
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 {
|
||||
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]' : '');
|
||||
}
|
||||
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");
|
||||
}
|
||||
} else {
|
||||
$text .= " $item_key\n";
|
||||
}
|
||||
$last_item = $item_key;
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
return "/msg $nick $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 {
|
||||
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]' : '');
|
||||
}
|
||||
} else {
|
||||
return "Found $i registry entries:\n$text" unless $i == 0;
|
||||
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.";
|
||||
}
|
||||
my $sections = (defined $section ? "section $section" : 'any sections');
|
||||
return "No matching registry entries found in $sections.";
|
||||
}
|
||||
}
|
||||
|
||||
sub regchange {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($section, $item, $delim, $tochange, $changeto, $modifier);
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($section, $item, $delim, $tochange, $changeto, $modifier);
|
||||
|
||||
if (defined $arguments) {
|
||||
if ($arguments =~ /^(.+?)\.([^\s]+)\s+s(.)/ or $arguments =~ /^([^\s]+) ([^\s]+)\s+s(.)/) {
|
||||
$section = $1;
|
||||
$item = $2;
|
||||
$delim = $3;
|
||||
if (defined $arguments) {
|
||||
if ($arguments =~ /^(.+?)\.([^\s]+)\s+s(.)/ or $arguments =~ /^([^\s]+) ([^\s]+)\s+s(.)/) {
|
||||
$section = $1;
|
||||
$item = $2;
|
||||
$delim = $3;
|
||||
}
|
||||
|
||||
if ($arguments =~ /$delim(.*?)$delim(.*)$delim(.*)?$/) {
|
||||
$tochange = $1;
|
||||
$changeto = $2;
|
||||
$modifier = $3;
|
||||
}
|
||||
}
|
||||
|
||||
if ($arguments =~ /$delim(.*?)$delim(.*)$delim(.*)?$/) {
|
||||
$tochange = $1;
|
||||
$changeto = $2;
|
||||
$modifier = $3;
|
||||
}
|
||||
}
|
||||
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;
|
||||
|
||||
$section = lc $section;
|
||||
$item = lc $item;
|
||||
my $registry = $self->{pbot}->{registry}->{registry};
|
||||
|
||||
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|) {
|
||||
$self->{pbot}->{logger}->log("($from) $nick!$user\@$host: failed to change $section.$item 's$delim$tochange$delim$changeto$delim$modifier\n");
|
||||
return "/msg $nick Change $section.$item failed.";
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("($from) $nick!$user\@$host: changed $section.$item 's/$tochange/$changeto/\n");
|
||||
$self->{pbot}->{registry}->process_trigger($section, $item, 'value', $registry->get_data($section, $item, 'value'));
|
||||
$self->{pbot}->{registry}->save;
|
||||
return "$section.$item set to " . $registry->get_data($section, $item, 'value');
|
||||
}
|
||||
};
|
||||
return "/msg $nick Failed to change $section.$item: $@" if $@;
|
||||
return $ret;
|
||||
my $ret = eval {
|
||||
use re::engine::RE2 -strict => 1;
|
||||
if (not $registry->get_data($section, $item, 'value') =~ s|$tochange|$changeto|) {
|
||||
$self->{pbot}->{logger}->log("($from) $nick!$user\@$host: failed to change $section.$item 's$delim$tochange$delim$changeto$delim$modifier\n");
|
||||
return "/msg $nick Change $section.$item failed.";
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("($from) $nick!$user\@$host: changed $section.$item 's/$tochange/$changeto/\n");
|
||||
$self->{pbot}->{registry}->process_trigger($section, $item, 'value', $registry->get_data($section, $item, 'value'));
|
||||
$self->{pbot}->{registry}->save;
|
||||
return "$section.$item set to " . $registry->get_data($section, $item, 'value');
|
||||
}
|
||||
};
|
||||
return "/msg $nick Failed to change $section.$item: $@" if $@;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -16,42 +16,41 @@ use feature 'unicode_strings';
|
|||
use Time::HiRes qw(gettimeofday);
|
||||
|
||||
sub new {
|
||||
my ($class, %conf) = @_;
|
||||
my $self = {};
|
||||
$self->{buf} = '';
|
||||
$self->{timestamp} = gettimeofday;
|
||||
return bless $self, $class;
|
||||
my ($class, %conf) = @_;
|
||||
my $self = {};
|
||||
$self->{buf} = '';
|
||||
$self->{timestamp} = gettimeofday;
|
||||
return bless $self, $class;
|
||||
}
|
||||
|
||||
sub log {
|
||||
my $self = shift;
|
||||
$self->{buf} .= shift;
|
||||
# DBI feeds us pieces at a time, so accumulate a complete line
|
||||
# before outputing
|
||||
if ($self->{buf} =~ tr/\n//) {
|
||||
$self->log_message;
|
||||
$self->{buf} = '';
|
||||
}
|
||||
my $self = shift;
|
||||
$self->{buf} .= shift;
|
||||
|
||||
# DBI feeds us pieces at a time, so accumulate a complete line
|
||||
# before outputing
|
||||
if ($self->{buf} =~ tr/\n//) {
|
||||
$self->log_message;
|
||||
$self->{buf} = '';
|
||||
}
|
||||
}
|
||||
|
||||
sub log_message {
|
||||
my $self = shift;
|
||||
my $now = gettimeofday;
|
||||
my $elapsed = $now - $self->{timestamp};
|
||||
if ($elapsed >= 0.100) {
|
||||
$self->{pbot}->{logger}->log("^^^ SLOW SQL ^^^\n");
|
||||
}
|
||||
$elapsed = sprintf '%10.3f', $elapsed;
|
||||
$self->{pbot}->{logger}->log("$elapsed : $self->{buf}");
|
||||
$self->{timestamp} = $now;
|
||||
my $self = shift;
|
||||
my $now = gettimeofday;
|
||||
my $elapsed = $now - $self->{timestamp};
|
||||
if ($elapsed >= 0.100) { $self->{pbot}->{logger}->log("^^^ SLOW SQL ^^^\n"); }
|
||||
$elapsed = sprintf '%10.3f', $elapsed;
|
||||
$self->{pbot}->{logger}->log("$elapsed : $self->{buf}");
|
||||
$self->{timestamp} = $now;
|
||||
}
|
||||
|
||||
sub close {
|
||||
my $self = shift;
|
||||
if ($self->{buf}) {
|
||||
$self->log_message;
|
||||
$self->{buf} = '';
|
||||
}
|
||||
my $self = shift;
|
||||
if ($self->{buf}) {
|
||||
$self->log_message;
|
||||
$self->{buf} = '';
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -15,28 +15,29 @@ use warnings;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
sub PUSHED {
|
||||
my ($class, $mode, $fh) = @_;
|
||||
my $logger;
|
||||
return bless \$logger, $class;
|
||||
my ($class, $mode, $fh) = @_;
|
||||
my $logger;
|
||||
return bless \$logger, $class;
|
||||
}
|
||||
|
||||
sub OPEN {
|
||||
my ($self, $path, $mode, $fh) = @_;
|
||||
# $path is our logger object
|
||||
$$self = $path;
|
||||
return 1;
|
||||
my ($self, $path, $mode, $fh) = @_;
|
||||
|
||||
# $path is our logger object
|
||||
$$self = $path;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub WRITE {
|
||||
my ($self, $buf, $fh) = @_;
|
||||
$$self->log($buf);
|
||||
return length($buf);
|
||||
my ($self, $buf, $fh) = @_;
|
||||
$$self->log($buf);
|
||||
return length($buf);
|
||||
}
|
||||
|
||||
sub CLOSE {
|
||||
my $self = shift;
|
||||
$$self->close();
|
||||
return 0;
|
||||
my $self = shift;
|
||||
$$self->close();
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -11,58 +11,55 @@ use feature 'unicode_strings';
|
|||
use IO::Select;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{select} = IO::Select->new();
|
||||
$self->{readers} = {};
|
||||
$self->{buffers} = {};
|
||||
my ($self, %conf) = @_;
|
||||
$self->{select} = IO::Select->new();
|
||||
$self->{readers} = {};
|
||||
$self->{buffers} = {};
|
||||
}
|
||||
|
||||
sub add_reader {
|
||||
my ($self, $handle, $sub) = @_;
|
||||
$self->{select}->add($handle);
|
||||
$self->{readers}->{$handle} = $sub;
|
||||
$self->{buffers}->{$handle} = "";
|
||||
my ($self, $handle, $sub) = @_;
|
||||
$self->{select}->add($handle);
|
||||
$self->{readers}->{$handle} = $sub;
|
||||
$self->{buffers}->{$handle} = "";
|
||||
}
|
||||
|
||||
sub remove_reader {
|
||||
my ($self, $handle) = @_;
|
||||
$self->{select}->remove($handle);
|
||||
delete $self->{readers}->{$handle};
|
||||
delete $self->{buffers}->{$handle};
|
||||
my ($self, $handle) = @_;
|
||||
$self->{select}->remove($handle);
|
||||
delete $self->{readers}->{$handle};
|
||||
delete $self->{buffers}->{$handle};
|
||||
}
|
||||
|
||||
sub do_select {
|
||||
my ($self) = @_;
|
||||
my $length = 8192;
|
||||
my @ready = $self->{select}->can_read(0);
|
||||
foreach my $fh (@ready) {
|
||||
my $ret = sysread($fh, my $buf, $length);
|
||||
my ($self) = @_;
|
||||
my $length = 8192;
|
||||
my @ready = $self->{select}->can_read(0);
|
||||
foreach my $fh (@ready) {
|
||||
my $ret = sysread($fh, my $buf, $length);
|
||||
|
||||
if (not defined $ret) {
|
||||
$self->{pbot}->{logger}->log("Error with $fh: $!\n");
|
||||
$self->remove_reader($fh);
|
||||
next;
|
||||
if (not defined $ret) {
|
||||
$self->{pbot}->{logger}->log("Error with $fh: $!\n");
|
||||
$self->remove_reader($fh);
|
||||
next;
|
||||
}
|
||||
|
||||
if ($ret == 0) {
|
||||
if (length $self->{buffers}->{$fh}) { $self->{readers}->{$fh}->($self->{buffers}->{$fh}); }
|
||||
$self->remove_reader($fh);
|
||||
next;
|
||||
}
|
||||
|
||||
$self->{buffers}->{$fh} .= $buf;
|
||||
|
||||
if (not exists $self->{readers}->{$fh}) { $self->{pbot}->{logger}->log("Error: no reader for $fh\n"); }
|
||||
else {
|
||||
if ($ret < $length) {
|
||||
$self->{readers}->{$fh}->($self->{buffers}->{$fh});
|
||||
$self->{buffers}->{$fh} = "";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($ret == 0) {
|
||||
if (length $self->{buffers}->{$fh}) {
|
||||
$self->{readers}->{$fh}->($self->{buffers}->{$fh});
|
||||
}
|
||||
$self->remove_reader($fh);
|
||||
next;
|
||||
}
|
||||
|
||||
$self->{buffers}->{$fh} .= $buf;
|
||||
|
||||
if (not exists $self->{readers}->{$fh}) {
|
||||
$self->{pbot}->{logger}->log("Error: no reader for $fh\n");
|
||||
} else {
|
||||
if ($ret < $length) {
|
||||
$self->{readers}->{$fh}->($self->{buffers}->{$fh});
|
||||
$self->{buffers}->{$fh} = "";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -8,51 +8,52 @@ use parent 'PBot::Class';
|
|||
use warnings; use strict;
|
||||
use feature 'unicode_strings';
|
||||
|
||||
use POSIX qw(tcgetpgrp getpgrp); # to check whether process is in background or foreground
|
||||
use POSIX qw(tcgetpgrp getpgrp); # to check whether process is in background or foreground
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
# create implicit bot-admin account for bot
|
||||
my $user = $self->{pbot}->{users}->find_user('.*', '*!stdin@pbot');
|
||||
if (not defined $user or not $self->{pbot}->{capabilities}->userhas($user, 'botowner')) {
|
||||
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
|
||||
$self->{pbot}->{logger}->log("Adding stdin botowner *!stdin\@pbot...\n");
|
||||
$self->{pbot}->{users}->add_user($botnick, '.*', '*!stdin@pbot', 'botowner', undef, 1);
|
||||
$self->{pbot}->{users}->login($botnick, "$botnick!stdin\@pbot", undef);
|
||||
$self->{pbot}->{users}->save;
|
||||
}
|
||||
my ($self, %conf) = @_;
|
||||
|
||||
# used to check whether process is in background or foreground, for stdin reading
|
||||
if (not $self->{pbot}->{registry}->get_value('general', 'daemon')) {
|
||||
open TTY, "</dev/tty" or die $!;
|
||||
$self->{tty_fd} = fileno(TTY);
|
||||
$self->{pbot}->{select_handler}->add_reader(\*STDIN, sub { $self->stdin_reader(@_) });
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("Starting in daemon mode.\n");
|
||||
}
|
||||
# create implicit bot-admin account for bot
|
||||
my $user = $self->{pbot}->{users}->find_user('.*', '*!stdin@pbot');
|
||||
if (not defined $user or not $self->{pbot}->{capabilities}->userhas($user, 'botowner')) {
|
||||
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
|
||||
$self->{pbot}->{logger}->log("Adding stdin botowner *!stdin\@pbot...\n");
|
||||
$self->{pbot}->{users}->add_user($botnick, '.*', '*!stdin@pbot', 'botowner', undef, 1);
|
||||
$self->{pbot}->{users}->login($botnick, "$botnick!stdin\@pbot", undef);
|
||||
$self->{pbot}->{users}->save;
|
||||
}
|
||||
|
||||
# used to check whether process is in background or foreground, for stdin reading
|
||||
if (not $self->{pbot}->{registry}->get_value('general', 'daemon')) {
|
||||
open TTY, "</dev/tty" or die $!;
|
||||
$self->{tty_fd} = fileno(TTY);
|
||||
$self->{pbot}->{select_handler}->add_reader(\*STDIN, sub { $self->stdin_reader(@_) });
|
||||
} else {
|
||||
$self->{pbot}->{logger}->log("Starting in daemon mode.\n");
|
||||
}
|
||||
}
|
||||
|
||||
sub stdin_reader {
|
||||
my ($self, $input) = @_;
|
||||
chomp $input;
|
||||
my ($self, $input) = @_;
|
||||
chomp $input;
|
||||
|
||||
# make sure we're in the foreground first
|
||||
$self->{foreground} = (tcgetpgrp($self->{tty_fd}) == getpgrp()) ? 1 : 0;
|
||||
return if not $self->{foreground};
|
||||
# make sure we're in the foreground first
|
||||
$self->{foreground} = (tcgetpgrp($self->{tty_fd}) == getpgrp()) ? 1 : 0;
|
||||
return if not $self->{foreground};
|
||||
|
||||
$self->{pbot}->{logger}->log("---------------------------------------------\n");
|
||||
$self->{pbot}->{logger}->log("Got STDIN: $input\n");
|
||||
$self->{pbot}->{logger}->log("---------------------------------------------\n");
|
||||
$self->{pbot}->{logger}->log("Got STDIN: $input\n");
|
||||
|
||||
my ($from, $text);
|
||||
my ($from, $text);
|
||||
|
||||
if ($input =~ m/^~([^ ]+)\s+(.*)/) {
|
||||
$from = $1;
|
||||
$text = $self->{pbot}->{registry}->get_value('irc', 'botnick') . " $2";
|
||||
} else {
|
||||
$from = 'stdin@pbot';
|
||||
$text = $self->{pbot}->{registry}->get_value('irc', 'botnick') . " $input";
|
||||
}
|
||||
return $self->{pbot}->{interpreter}->process_line($from, $self->{pbot}->{registry}->get_value('irc', 'botnick'), "stdin", "pbot", $text);
|
||||
if ($input =~ m/^~([^ ]+)\s+(.*)/) {
|
||||
$from = $1;
|
||||
$text = $self->{pbot}->{registry}->get_value('irc', 'botnick') . " $2";
|
||||
} else {
|
||||
$from = 'stdin@pbot';
|
||||
$text = $self->{pbot}->{registry}->get_value('irc', 'botnick') . " $input";
|
||||
}
|
||||
return $self->{pbot}->{interpreter}->process_line($from, $self->{pbot}->{registry}->get_value('irc', 'botnick'), "stdin", "pbot", $text);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
170
PBot/Timer.pm
170
PBot/Timer.pm
|
|
@ -10,6 +10,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::Timer;
|
||||
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -17,135 +18,134 @@ use feature 'unicode_strings';
|
|||
|
||||
our $min_timeout = 1;
|
||||
our $max_seconds = 1000000;
|
||||
our $seconds = 0;
|
||||
our $seconds = 0;
|
||||
our @timer_funcs;
|
||||
|
||||
$SIG{ALRM} = sub {
|
||||
$seconds += $min_timeout;
|
||||
alarm $min_timeout;
|
||||
$seconds += $min_timeout;
|
||||
alarm $min_timeout;
|
||||
|
||||
# call timer func subroutines
|
||||
foreach my $func (@timer_funcs) { &$func; }
|
||||
# call timer func subroutines
|
||||
foreach my $func (@timer_funcs) { &$func; }
|
||||
|
||||
# prevent $seconds over-flow
|
||||
$seconds -= $max_seconds if $seconds > $max_seconds;
|
||||
# prevent $seconds over-flow
|
||||
$seconds -= $max_seconds if $seconds > $max_seconds;
|
||||
};
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
my $timeout = $conf{timeout} // 10;
|
||||
$min_timeout = $timeout if $timeout < $min_timeout;
|
||||
$self->{name} = $conf{name} // "Unnamed $timeout Second Timer";
|
||||
$self->{handlers} = [];
|
||||
$self->{enabled} = 0;
|
||||
# alarm signal handler (poor-man's timer)
|
||||
$self->{timer_func} = sub { on_tick_handler($self) };
|
||||
return $self;
|
||||
my ($self, %conf) = @_;
|
||||
my $timeout = $conf{timeout} // 10;
|
||||
$min_timeout = $timeout if $timeout < $min_timeout;
|
||||
$self->{name} = $conf{name} // "Unnamed $timeout Second Timer";
|
||||
$self->{handlers} = [];
|
||||
$self->{enabled} = 0;
|
||||
|
||||
# alarm signal handler (poor-man's timer)
|
||||
$self->{timer_func} = sub { on_tick_handler($self) };
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub start {
|
||||
my $self = shift;
|
||||
$self->{enabled} = 1;
|
||||
push @timer_funcs, $self->{timer_func};
|
||||
alarm $min_timeout;
|
||||
my $self = shift;
|
||||
$self->{enabled} = 1;
|
||||
push @timer_funcs, $self->{timer_func};
|
||||
alarm $min_timeout;
|
||||
}
|
||||
|
||||
sub stop {
|
||||
my $self = shift;
|
||||
$self->{enabled} = 0;
|
||||
@timer_funcs = grep { $_ != $self->{timer_func} } @timer_funcs;
|
||||
my $self = shift;
|
||||
$self->{enabled} = 0;
|
||||
@timer_funcs = grep { $_ != $self->{timer_func} } @timer_funcs;
|
||||
}
|
||||
|
||||
sub on_tick_handler {
|
||||
my $self = shift;
|
||||
my $elapsed = 0;
|
||||
my $self = shift;
|
||||
my $elapsed = 0;
|
||||
|
||||
if ($self->{enabled}) {
|
||||
if ($#{ $self->{handlers} } > -1) {
|
||||
# call handlers supplied via register() if timeout for each has elapsed
|
||||
foreach my $func (@{ $self->{handlers} }) {
|
||||
if (defined $func->{last}) {
|
||||
$func->{last} -= $max_seconds if $seconds < $func->{last}; # handle wrap-around of $seconds
|
||||
if ($self->{enabled}) {
|
||||
if ($#{$self->{handlers}} > -1) {
|
||||
|
||||
if ($seconds - $func->{last} >= $func->{timeout}) {
|
||||
$func->{last} = $seconds;
|
||||
$elapsed = 1;
|
||||
}
|
||||
# call handlers supplied via register() if timeout for each has elapsed
|
||||
foreach my $func (@{$self->{handlers}}) {
|
||||
if (defined $func->{last}) {
|
||||
$func->{last} -= $max_seconds if $seconds < $func->{last}; # handle wrap-around of $seconds
|
||||
|
||||
if ($seconds - $func->{last} >= $func->{timeout}) {
|
||||
$func->{last} = $seconds;
|
||||
$elapsed = 1;
|
||||
}
|
||||
} else {
|
||||
$func->{last} = $seconds;
|
||||
$elapsed = 1;
|
||||
}
|
||||
|
||||
if ($elapsed) {
|
||||
&{$func->{subref}}($self);
|
||||
$elapsed = 0;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$func->{last} = $seconds;
|
||||
$elapsed = 1;
|
||||
}
|
||||
|
||||
if ($elapsed) {
|
||||
&{ $func->{subref} }($self);
|
||||
$elapsed = 0;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
# call default overridable handler if timeout has elapsed
|
||||
if (defined $self->{last}) {
|
||||
$self->{last} -= $max_seconds if $seconds < $self->{last}; # handle wrap-around
|
||||
# call default overridable handler if timeout has elapsed
|
||||
if (defined $self->{last}) {
|
||||
$self->{last} -= $max_seconds if $seconds < $self->{last}; # handle wrap-around
|
||||
|
||||
if ($seconds - $self->{last} >= $self->{timeout}) {
|
||||
$elapsed = 1;
|
||||
$self->{last} = $seconds;
|
||||
}
|
||||
} else {
|
||||
$elapsed = 1;
|
||||
$self->{last} = $seconds;
|
||||
}
|
||||
if ($seconds - $self->{last} >= $self->{timeout}) {
|
||||
$elapsed = 1;
|
||||
$self->{last} = $seconds;
|
||||
}
|
||||
} else {
|
||||
$elapsed = 1;
|
||||
$self->{last} = $seconds;
|
||||
}
|
||||
|
||||
if ($elapsed) {
|
||||
$self->on_tick();
|
||||
$elapsed = 0;
|
||||
}
|
||||
if ($elapsed) {
|
||||
$self->on_tick();
|
||||
$elapsed = 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# overridable method, executed whenever timeout is triggered
|
||||
sub on_tick {
|
||||
my $self = shift;
|
||||
print "Tick! $self->{name} $self->{timeout} $self->{last} $seconds\n";
|
||||
my $self = shift;
|
||||
print "Tick! $self->{name} $self->{timeout} $self->{last} $seconds\n";
|
||||
}
|
||||
|
||||
sub register {
|
||||
my $self = shift;
|
||||
my ($ref, $timeout, $id) = @_;
|
||||
my $self = shift;
|
||||
my ($ref, $timeout, $id) = @_;
|
||||
|
||||
Carp::croak("Must pass subroutine reference to register()") if not defined $ref;
|
||||
Carp::croak("Must pass subroutine reference to register()") if not defined $ref;
|
||||
|
||||
# TODO: Check if subref already exists in handlers?
|
||||
$timeout = 300 if not defined $timeout; # set default value of 5 minutes if not defined
|
||||
$id = 'timer' if not defined $id;
|
||||
# TODO: Check if subref already exists in handlers?
|
||||
$timeout = 300 if not defined $timeout; # set default value of 5 minutes if not defined
|
||||
$id = 'timer' if not defined $id;
|
||||
|
||||
my $h = { subref => $ref, timeout => $timeout, id => $id };
|
||||
push @{ $self->{handlers} }, $h;
|
||||
my $h = {subref => $ref, timeout => $timeout, id => $id};
|
||||
push @{$self->{handlers}}, $h;
|
||||
|
||||
if ($timeout < $min_timeout) {
|
||||
$min_timeout = $timeout;
|
||||
}
|
||||
if ($timeout < $min_timeout) { $min_timeout = $timeout; }
|
||||
|
||||
if ($self->{enabled}) {
|
||||
alarm $min_timeout;
|
||||
}
|
||||
if ($self->{enabled}) { alarm $min_timeout; }
|
||||
}
|
||||
|
||||
sub unregister {
|
||||
my ($self, $id) = @_;
|
||||
Carp::croak("Must pass timer id to unregister()") if not defined $id;
|
||||
@{ $self->{handlers} } = grep { $_->{id} ne $id } @{ $self->{handlers} };
|
||||
my ($self, $id) = @_;
|
||||
Carp::croak("Must pass timer id to unregister()") if not defined $id;
|
||||
@{$self->{handlers}} = grep { $_->{id} ne $id } @{$self->{handlers}};
|
||||
}
|
||||
|
||||
sub update_interval {
|
||||
my ($self, $id, $interval) = @_;
|
||||
my ($self, $id, $interval) = @_;
|
||||
|
||||
foreach my $h (@{ $self->{handlers} }) {
|
||||
if ($h->{id} eq $id) {
|
||||
$h->{timeout} = $interval;
|
||||
last;
|
||||
foreach my $h (@{$self->{handlers}}) {
|
||||
if ($h->{id} eq $id) {
|
||||
$h->{timeout} = $interval;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
842
PBot/Users.pm
842
PBot/Users.pm
|
|
@ -14,579 +14,553 @@ use warnings; use strict;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{users} = PBot::DualIndexHashObject->new(name => 'Users', filename => $conf{filename}, pbot => $conf{pbot});
|
||||
$self->load;
|
||||
my ($self, %conf) = @_;
|
||||
$self->{users} = PBot::DualIndexHashObject->new(name => 'Users', filename => $conf{filename}, pbot => $conf{pbot});
|
||||
$self->load;
|
||||
|
||||
$self->{pbot}->{commands}->register(sub { $self->logincmd(@_) }, "login", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->logoutcmd(@_) }, "logout", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->useradd(@_) }, "useradd", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->userdel(@_) }, "userdel", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->userset(@_) }, "userset", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->userunset(@_) }, "userunset", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->users(@_) }, "users", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->mycmd(@_) }, "my", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->logincmd(@_) }, "login", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->logoutcmd(@_) }, "logout", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->useradd(@_) }, "useradd", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->userdel(@_) }, "userdel", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->userset(@_) }, "userset", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->userunset(@_) }, "userunset", 1);
|
||||
$self->{pbot}->{commands}->register(sub { $self->users(@_) }, "users", 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->mycmd(@_) }, "my", 0);
|
||||
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-useradd', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-userdel', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-userset', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-userunset', 1);
|
||||
$self->{pbot}->{capabilities}->add('can-modify-admins', undef, 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-useradd', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-userdel', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-userset', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-userunset', 1);
|
||||
$self->{pbot}->{capabilities}->add('can-modify-admins', undef, 1);
|
||||
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.join', sub { $self->on_join(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.join', sub { $self->on_join(@_) });
|
||||
}
|
||||
|
||||
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);
|
||||
($nick, $user, $host) = $self->{pbot}->{irchandlers}->normalize_hostmask($nick, $user, $host);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to);
|
||||
($nick, $user, $host) = $self->{pbot}->{irchandlers}->normalize_hostmask($nick, $user, $host);
|
||||
|
||||
my $u = $self->find_user($channel, "$nick!$user\@$host");
|
||||
my $u = $self->find_user($channel, "$nick!$user\@$host");
|
||||
|
||||
if (defined $u) {
|
||||
if ($self->{pbot}->{chanops}->can_gain_ops($channel)) {
|
||||
my $modes = '+';
|
||||
my $targets = '';
|
||||
if (defined $u) {
|
||||
if ($self->{pbot}->{chanops}->can_gain_ops($channel)) {
|
||||
my $modes = '+';
|
||||
my $targets = '';
|
||||
|
||||
if ($u->{autoop}) {
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host autoop in $channel\n");
|
||||
$modes .= 'o';
|
||||
$targets .= "$nick ";
|
||||
}
|
||||
if ($u->{autoop}) {
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host autoop in $channel\n");
|
||||
$modes .= 'o';
|
||||
$targets .= "$nick ";
|
||||
}
|
||||
|
||||
if ($u->{autovoice}) {
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host autovoice in $channel\n");
|
||||
$modes .= 'v';
|
||||
$targets .= "$nick ";
|
||||
}
|
||||
if ($u->{autovoice}) {
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host autovoice in $channel\n");
|
||||
$modes .= 'v';
|
||||
$targets .= "$nick ";
|
||||
}
|
||||
|
||||
if (length $modes > 1) {
|
||||
$self->{pbot}->{chanops}->add_op_command($channel, "mode $channel $modes $targets");
|
||||
$self->{pbot}->{chanops}->gain_ops($channel);
|
||||
}
|
||||
if (length $modes > 1) {
|
||||
$self->{pbot}->{chanops}->add_op_command($channel, "mode $channel $modes $targets");
|
||||
$self->{pbot}->{chanops}->gain_ops($channel);
|
||||
}
|
||||
}
|
||||
|
||||
if ($u->{autologin}) {
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host autologin to $u->{name} for $channel\n");
|
||||
$u->{loggedin} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
if ($u->{autologin}) {
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host autologin to $u->{name} for $channel\n");
|
||||
$u->{loggedin} = 1;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub add_user {
|
||||
my ($self, $name, $channel, $hostmask, $capabilities, $password, $dont_save) = @_;
|
||||
$channel = '.*' if $channel !~ m/^#/;
|
||||
my ($self, $name, $channel, $hostmask, $capabilities, $password, $dont_save) = @_;
|
||||
$channel = '.*' if $channel !~ m/^#/;
|
||||
|
||||
$capabilities //= 'none';
|
||||
$password //= $self->{pbot}->random_nick(16);
|
||||
$capabilities //= 'none';
|
||||
$password //= $self->{pbot}->random_nick(16);
|
||||
|
||||
my $data = {
|
||||
name => $name,
|
||||
password => $password
|
||||
};
|
||||
my $data = {
|
||||
name => $name,
|
||||
password => $password
|
||||
};
|
||||
|
||||
foreach my $cap (split /\s*,\s*/, lc $capabilities) {
|
||||
next if $cap eq 'none';
|
||||
$data->{$cap} = 1;
|
||||
}
|
||||
foreach my $cap (split /\s*,\s*/, lc $capabilities) {
|
||||
next if $cap eq 'none';
|
||||
$data->{$cap} = 1;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Adding new user (caps: $capabilities): name: $name hostmask: $hostmask channel: $channel\n");
|
||||
$self->{users}->add($channel, $hostmask, $data, $dont_save);
|
||||
return $data;
|
||||
$self->{pbot}->{logger}->log("Adding new user (caps: $capabilities): name: $name hostmask: $hostmask channel: $channel\n");
|
||||
$self->{users}->add($channel, $hostmask, $data, $dont_save);
|
||||
return $data;
|
||||
}
|
||||
|
||||
sub remove_user {
|
||||
my ($self, $channel, $hostmask) = @_;
|
||||
return $self->{users}->remove($channel, $hostmask);
|
||||
my ($self, $channel, $hostmask) = @_;
|
||||
return $self->{users}->remove($channel, $hostmask);
|
||||
}
|
||||
|
||||
sub load {
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
if (@_) { $filename = shift; } else { $filename = $self->{users}->{filename}; }
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
if (@_) { $filename = shift; }
|
||||
else { $filename = $self->{users}->{filename}; }
|
||||
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No users path specified -- skipping loading of users";
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{users}->load;
|
||||
|
||||
my $i = 0;
|
||||
foreach my $channel (sort $self->{users}->get_keys) {
|
||||
foreach my $hostmask (sort $self->{users}->get_keys($channel)) {
|
||||
$i++;
|
||||
my $name = $self->{users}->get_data($channel, $hostmask, 'name');
|
||||
my $password = $self->{users}->get_data($channel, $hostmask, 'password');
|
||||
if (not defined $name or not defined $password) {
|
||||
Carp::croak "A user in $filename is missing critical data\n";
|
||||
}
|
||||
if (not defined $filename) {
|
||||
Carp::carp "No users path specified -- skipping loading of users";
|
||||
return;
|
||||
}
|
||||
}
|
||||
$self->{pbot}->{logger}->log(" $i users loaded.\n");
|
||||
|
||||
$self->{users}->load;
|
||||
|
||||
my $i = 0;
|
||||
foreach my $channel (sort $self->{users}->get_keys) {
|
||||
foreach my $hostmask (sort $self->{users}->get_keys($channel)) {
|
||||
$i++;
|
||||
my $name = $self->{users}->get_data($channel, $hostmask, 'name');
|
||||
my $password = $self->{users}->get_data($channel, $hostmask, 'password');
|
||||
if (not defined $name or not defined $password) { Carp::croak "A user in $filename is missing critical data\n"; }
|
||||
}
|
||||
}
|
||||
$self->{pbot}->{logger}->log(" $i users loaded.\n");
|
||||
}
|
||||
|
||||
sub save {
|
||||
my ($self) = @_;
|
||||
$self->{users}->save;
|
||||
my ($self) = @_;
|
||||
$self->{users}->save;
|
||||
}
|
||||
|
||||
sub find_user_account {
|
||||
my ($self, $channel, $hostmask, $any_channel) = @_;
|
||||
$channel = lc $channel;
|
||||
$hostmask = lc $hostmask;
|
||||
$any_channel //= 0;
|
||||
my ($self, $channel, $hostmask, $any_channel) = @_;
|
||||
$channel = lc $channel;
|
||||
$hostmask = lc $hostmask;
|
||||
$any_channel //= 0;
|
||||
|
||||
my $sort;
|
||||
if ($channel =~ m/^#/) {
|
||||
$sort = sub { $a cmp $b };
|
||||
} else {
|
||||
$sort = sub { $b cmp $a };
|
||||
}
|
||||
|
||||
foreach my $chan (sort $sort $self->{users}->get_keys) {
|
||||
if (($channel !~ m/^#/ and $any_channel) or $channel =~ m/^$chan$/i) {
|
||||
if (not $self->{users}->exists($chan, $hostmask)) {
|
||||
# find hostmask by account name or wildcard
|
||||
foreach my $mask ($self->{users}->get_keys($chan)) {
|
||||
if (lc $self->{users}->get_data($chan, $mask, 'name') eq $hostmask) {
|
||||
return ($chan, $mask);
|
||||
}
|
||||
|
||||
if ($mask =~ /[*?]/) {
|
||||
# contains * or ? so it's converted to a regex
|
||||
my $mask_quoted = quotemeta $mask;
|
||||
$mask_quoted =~ s/\\\*/.*?/g;
|
||||
$mask_quoted =~ s/\\\?/./g;
|
||||
if ($hostmask =~ m/^$mask_quoted$/i) {
|
||||
return ($chan, $mask);
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
return ($chan, $hostmask);
|
||||
}
|
||||
my $sort;
|
||||
if ($channel =~ m/^#/) {
|
||||
$sort = sub { $a cmp $b };
|
||||
} else {
|
||||
$sort = sub { $b cmp $a };
|
||||
}
|
||||
}
|
||||
return (undef, $hostmask);
|
||||
|
||||
foreach my $chan (sort $sort $self->{users}->get_keys) {
|
||||
if (($channel !~ m/^#/ and $any_channel) or $channel =~ m/^$chan$/i) {
|
||||
if (not $self->{users}->exists($chan, $hostmask)) {
|
||||
|
||||
# find hostmask by account name or wildcard
|
||||
foreach my $mask ($self->{users}->get_keys($chan)) {
|
||||
if (lc $self->{users}->get_data($chan, $mask, 'name') eq $hostmask) { return ($chan, $mask); }
|
||||
|
||||
if ($mask =~ /[*?]/) {
|
||||
|
||||
# contains * or ? so it's converted to a regex
|
||||
my $mask_quoted = quotemeta $mask;
|
||||
$mask_quoted =~ s/\\\*/.*?/g;
|
||||
$mask_quoted =~ s/\\\?/./g;
|
||||
if ($hostmask =~ m/^$mask_quoted$/i) { return ($chan, $mask); }
|
||||
}
|
||||
}
|
||||
} else {
|
||||
return ($chan, $hostmask);
|
||||
}
|
||||
}
|
||||
}
|
||||
return (undef, $hostmask);
|
||||
}
|
||||
|
||||
sub find_user {
|
||||
my ($self, $channel, $hostmask, $any_channel) = @_;
|
||||
$any_channel //= 0;
|
||||
($channel, $hostmask) = $self->find_user_account($channel, $hostmask, $any_channel);
|
||||
return undef if not $any_channel and not defined $channel;
|
||||
my ($self, $channel, $hostmask, $any_channel) = @_;
|
||||
$any_channel //= 0;
|
||||
($channel, $hostmask) = $self->find_user_account($channel, $hostmask, $any_channel);
|
||||
return undef if not $any_channel and not defined $channel;
|
||||
|
||||
$channel = '.*' if not defined $channel;
|
||||
$hostmask = '.*' if not defined $hostmask;
|
||||
$hostmask = lc $hostmask;
|
||||
$channel = '.*' if not defined $channel;
|
||||
$hostmask = '.*' if not defined $hostmask;
|
||||
$hostmask = lc $hostmask;
|
||||
|
||||
my $sort;
|
||||
if ($channel =~ m/^#/) {
|
||||
$sort = sub { $a cmp $b };
|
||||
} else {
|
||||
$sort = sub { $b cmp $a };
|
||||
}
|
||||
|
||||
my $user = eval {
|
||||
foreach my $channel_regex (sort $sort $self->{users}->get_keys) {
|
||||
if (($channel !~ m/^#/ and $any_channel) or $channel =~ m/^$channel_regex$/i) {
|
||||
foreach my $hostmask_regex ($self->{users}->get_keys($channel_regex)) {
|
||||
if ($hostmask_regex =~ m/[*?]/) {
|
||||
# contains * or ? so it's converted to a regex
|
||||
my $hostmask_quoted = quotemeta $hostmask_regex;
|
||||
$hostmask_quoted =~ s/\\\*/.*?/g;
|
||||
$hostmask_quoted =~ s/\\\?/./g;
|
||||
if ($hostmask =~ m/^$hostmask_quoted$/i) {
|
||||
return $self->{users}->get_data($channel_regex, $hostmask_regex);
|
||||
}
|
||||
} else {
|
||||
# direct comparison
|
||||
if ($hostmask eq lc $hostmask_regex) {
|
||||
return $self->{users}->get_data($channel_regex, $hostmask_regex);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
my $sort;
|
||||
if ($channel =~ m/^#/) {
|
||||
$sort = sub { $a cmp $b };
|
||||
} else {
|
||||
$sort = sub { $b cmp $a };
|
||||
}
|
||||
return undef;
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Error in find_user parameters: $@\n");
|
||||
}
|
||||
return $user;
|
||||
my $user = eval {
|
||||
foreach my $channel_regex (sort $sort $self->{users}->get_keys) {
|
||||
if (($channel !~ m/^#/ and $any_channel) or $channel =~ m/^$channel_regex$/i) {
|
||||
foreach my $hostmask_regex ($self->{users}->get_keys($channel_regex)) {
|
||||
if ($hostmask_regex =~ m/[*?]/) {
|
||||
|
||||
# contains * or ? so it's converted to a regex
|
||||
my $hostmask_quoted = quotemeta $hostmask_regex;
|
||||
$hostmask_quoted =~ s/\\\*/.*?/g;
|
||||
$hostmask_quoted =~ s/\\\?/./g;
|
||||
if ($hostmask =~ m/^$hostmask_quoted$/i) { return $self->{users}->get_data($channel_regex, $hostmask_regex); }
|
||||
} else {
|
||||
|
||||
# direct comparison
|
||||
if ($hostmask eq lc $hostmask_regex) { return $self->{users}->get_data($channel_regex, $hostmask_regex); }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
};
|
||||
|
||||
if ($@) { $self->{pbot}->{logger}->log("Error in find_user parameters: $@\n"); }
|
||||
return $user;
|
||||
}
|
||||
|
||||
sub find_admin {
|
||||
my ($self, $from, $hostmask) = @_;
|
||||
my $user = $self->find_user($from, $hostmask);
|
||||
return undef if not defined $user;
|
||||
return undef if not $self->{pbot}->{capabilities}->userhas($user, 'admin');
|
||||
return $user;
|
||||
my ($self, $from, $hostmask) = @_;
|
||||
my $user = $self->find_user($from, $hostmask);
|
||||
return undef if not defined $user;
|
||||
return undef if not $self->{pbot}->{capabilities}->userhas($user, 'admin');
|
||||
return $user;
|
||||
}
|
||||
|
||||
sub loggedin {
|
||||
my ($self, $channel, $hostmask) = @_;
|
||||
my $user = $self->find_user($channel, $hostmask);
|
||||
return $user if defined $user and $user->{loggedin};
|
||||
return undef;
|
||||
my ($self, $channel, $hostmask) = @_;
|
||||
my $user = $self->find_user($channel, $hostmask);
|
||||
return $user if defined $user and $user->{loggedin};
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub loggedin_admin {
|
||||
my ($self, $channel, $hostmask) = @_;
|
||||
my $user = $self->loggedin($channel, $hostmask);
|
||||
return $user if defined $user and $self->{pbot}->{capabilities}->userhas($user, 'admin');
|
||||
return undef;
|
||||
my ($self, $channel, $hostmask) = @_;
|
||||
my $user = $self->loggedin($channel, $hostmask);
|
||||
return $user if defined $user and $self->{pbot}->{capabilities}->userhas($user, 'admin');
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub login {
|
||||
my ($self, $channel, $hostmask, $password) = @_;
|
||||
my $user = $self->find_user($channel, $hostmask);
|
||||
my $channel_text = $channel eq '.*' ? '' : " for $channel";
|
||||
my ($self, $channel, $hostmask, $password) = @_;
|
||||
my $user = $self->find_user($channel, $hostmask);
|
||||
my $channel_text = $channel eq '.*' ? '' : " for $channel";
|
||||
|
||||
if (not defined $user) {
|
||||
$self->{pbot}->{logger}->log("Attempt to login non-existent [$channel][$hostmask] failed\n");
|
||||
return "You do not have a user account$channel_text.";
|
||||
}
|
||||
if (not defined $user) {
|
||||
$self->{pbot}->{logger}->log("Attempt to login non-existent [$channel][$hostmask] failed\n");
|
||||
return "You do not have a user account$channel_text.";
|
||||
}
|
||||
|
||||
if (defined $password and $user->{password} ne $password) {
|
||||
$self->{pbot}->{logger}->log("Bad login password for [$channel][$hostmask]\n");
|
||||
return "I don't think so.";
|
||||
}
|
||||
if (defined $password and $user->{password} ne $password) {
|
||||
$self->{pbot}->{logger}->log("Bad login password for [$channel][$hostmask]\n");
|
||||
return "I don't think so.";
|
||||
}
|
||||
|
||||
$user->{loggedin} = 1;
|
||||
$self->{pbot}->{logger}->log("$hostmask logged into $user->{name} ($hostmask)$channel_text.\n");
|
||||
return "Logged into $user->{name} ($hostmask)$channel_text.";
|
||||
$user->{loggedin} = 1;
|
||||
$self->{pbot}->{logger}->log("$hostmask logged into $user->{name} ($hostmask)$channel_text.\n");
|
||||
return "Logged into $user->{name} ($hostmask)$channel_text.";
|
||||
}
|
||||
|
||||
sub logout {
|
||||
my ($self, $channel, $hostmask) = @_;
|
||||
my $user = $self->find_user($channel, $hostmask);
|
||||
delete $user->{loggedin} if defined $user;
|
||||
my ($self, $channel, $hostmask) = @_;
|
||||
my $user = $self->find_user($channel, $hostmask);
|
||||
delete $user->{loggedin} if defined $user;
|
||||
}
|
||||
|
||||
sub get_user_metadata {
|
||||
my ($self, $channel, $hostmask, $key) = @_;
|
||||
my $user = $self->find_user($channel, $hostmask, 1);
|
||||
return $user->{lc $key} if $user;
|
||||
return undef;
|
||||
my ($self, $channel, $hostmask, $key) = @_;
|
||||
my $user = $self->find_user($channel, $hostmask, 1);
|
||||
return $user->{lc $key} if $user;
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub get_loggedin_user_metadata {
|
||||
my ($self, $channel, $hostmask, $key) = @_;
|
||||
my $user = $self->loggedin($channel, $hostmask);
|
||||
return $user->{lc $key} if $user;
|
||||
return undef;
|
||||
my ($self, $channel, $hostmask, $key) = @_;
|
||||
my $user = $self->loggedin($channel, $hostmask);
|
||||
return $user->{lc $key} if $user;
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub logincmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my $channel = $from;
|
||||
return "Usage: login [channel] password" if not $arguments;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my $channel = $from;
|
||||
return "Usage: login [channel] password" if not $arguments;
|
||||
|
||||
if ($arguments =~ m/^([^ ]+)\s+(.+)/) {
|
||||
$channel = $1;
|
||||
$arguments = $2;
|
||||
}
|
||||
if ($arguments =~ m/^([^ ]+)\s+(.+)/) {
|
||||
$channel = $1;
|
||||
$arguments = $2;
|
||||
}
|
||||
|
||||
my ($user_channel, $user_hostmask) = $self->find_user_account($channel, "$nick!$user\@$host");
|
||||
return "/msg $nick You do not have a user account." if not defined $user_channel;
|
||||
my ($user_channel, $user_hostmask) = $self->find_user_account($channel, "$nick!$user\@$host");
|
||||
return "/msg $nick You do not have a user account." if not defined $user_channel;
|
||||
|
||||
my $u = $self->{users}->get_data($user_channel, $user_hostmask);
|
||||
my $channel_text = $user_channel eq '.*' ? '' : " for $user_channel";
|
||||
my $u = $self->{users}->get_data($user_channel, $user_hostmask);
|
||||
my $channel_text = $user_channel eq '.*' ? '' : " for $user_channel";
|
||||
|
||||
if ($u->{loggedin}) {
|
||||
return "/msg $nick You are already logged into $u->{name} ($user_hostmask)$channel_text.";
|
||||
}
|
||||
if ($u->{loggedin}) { return "/msg $nick You are already logged into $u->{name} ($user_hostmask)$channel_text."; }
|
||||
|
||||
my $result = $self->login($user_channel, $user_hostmask, $arguments);
|
||||
return "/msg $nick $result";
|
||||
my $result = $self->login($user_channel, $user_hostmask, $arguments);
|
||||
return "/msg $nick $result";
|
||||
}
|
||||
|
||||
sub logoutcmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
$from = $arguments if length $arguments;
|
||||
my ($user_channel, $user_hostmask) = $self->find_user_account($from, "$nick!$user\@$host");
|
||||
return "/msg $nick You do not have a user account." if not defined $user_channel;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
$from = $arguments if length $arguments;
|
||||
my ($user_channel, $user_hostmask) = $self->find_user_account($from, "$nick!$user\@$host");
|
||||
return "/msg $nick You do not have a user account." if not defined $user_channel;
|
||||
|
||||
my $u = $self->{users}->get_data($user_channel, $user_hostmask);
|
||||
my $channel_text = $user_channel eq '.*' ? '' : " for $user_channel";
|
||||
return "/msg $nick You are not logged into $u->{name} ($user_hostmask)$channel_text." if not $u->{loggedin};
|
||||
my $u = $self->{users}->get_data($user_channel, $user_hostmask);
|
||||
my $channel_text = $user_channel eq '.*' ? '' : " for $user_channel";
|
||||
return "/msg $nick You are not logged into $u->{name} ($user_hostmask)$channel_text." if not $u->{loggedin};
|
||||
|
||||
$self->logout($user_channel, $user_hostmask);
|
||||
return "/msg $nick Logged out of $u->{name} ($user_hostmask)$channel_text.";
|
||||
$self->logout($user_channel, $user_hostmask);
|
||||
return "/msg $nick Logged out of $u->{name} ($user_hostmask)$channel_text.";
|
||||
}
|
||||
|
||||
sub users {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $channel = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $channel = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
|
||||
my $include_global = '';
|
||||
if (not defined $channel) {
|
||||
$channel = $from;
|
||||
$include_global = '.*';
|
||||
} else {
|
||||
$channel = '.*' if $channel !~ /^#/;
|
||||
}
|
||||
|
||||
my $text = "Users: ";
|
||||
my $last_channel = "";
|
||||
my $sep = "";
|
||||
foreach my $chan (sort $self->{users}->get_keys) {
|
||||
next if $from =~ m/^#/ and $chan ne $channel and $chan ne $include_global;
|
||||
next if $from !~ m/^#/ and $channel =~ m/^#/ and $chan ne $channel;
|
||||
|
||||
if ($last_channel ne $chan) {
|
||||
$text .= $sep . ($chan eq ".*" ? "global" : $chan) . ": ";
|
||||
$last_channel = $chan;
|
||||
$sep = "";
|
||||
my $include_global = '';
|
||||
if (not defined $channel) {
|
||||
$channel = $from;
|
||||
$include_global = '.*';
|
||||
} else {
|
||||
$channel = '.*' if $channel !~ /^#/;
|
||||
}
|
||||
|
||||
foreach my $hostmask (sort { return 0 if $a eq '_name' or $b eq '_name'; $self->{users}->get_data($chan, $a, 'name') cmp $self->{users}->get_data($chan, $b, 'name') } $self->{users}->get_keys($chan)) {
|
||||
$text .= $sep;
|
||||
my $has_cap = 0;
|
||||
foreach my $key ($self->{users}->get_keys($chan, $hostmask)) {
|
||||
if ($self->{pbot}->{capabilities}->exists($key)) {
|
||||
$has_cap = 1;
|
||||
last;
|
||||
my $text = "Users: ";
|
||||
my $last_channel = "";
|
||||
my $sep = "";
|
||||
foreach my $chan (sort $self->{users}->get_keys) {
|
||||
next if $from =~ m/^#/ and $chan ne $channel and $chan ne $include_global;
|
||||
next if $from !~ m/^#/ and $channel =~ m/^#/ and $chan ne $channel;
|
||||
|
||||
if ($last_channel ne $chan) {
|
||||
$text .= $sep . ($chan eq ".*" ? "global" : $chan) . ": ";
|
||||
$last_channel = $chan;
|
||||
$sep = "";
|
||||
}
|
||||
}
|
||||
$text .= '+' if $has_cap;
|
||||
$text .= $self->{users}->get_data($chan, $hostmask, 'name');
|
||||
$sep = " ";
|
||||
|
||||
foreach my $hostmask (sort { return 0 if $a eq '_name' or $b eq '_name'; $self->{users}->get_data($chan, $a, 'name') cmp $self->{users}->get_data($chan, $b, 'name') }
|
||||
$self->{users}->get_keys($chan))
|
||||
{
|
||||
$text .= $sep;
|
||||
my $has_cap = 0;
|
||||
foreach my $key ($self->{users}->get_keys($chan, $hostmask)) {
|
||||
if ($self->{pbot}->{capabilities}->exists($key)) {
|
||||
$has_cap = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
$text .= '+' if $has_cap;
|
||||
$text .= $self->{users}->get_data($chan, $hostmask, 'name');
|
||||
$sep = " ";
|
||||
}
|
||||
$sep = "; ";
|
||||
}
|
||||
$sep = "; ";
|
||||
}
|
||||
return $text;
|
||||
return $text;
|
||||
}
|
||||
|
||||
sub useradd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($name, $channel, $hostmask, $capabilities, $password) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 5);
|
||||
$capabilities //= 'none';
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($name, $channel, $hostmask, $capabilities, $password) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 5);
|
||||
$capabilities //= 'none';
|
||||
|
||||
if (not defined $name or not defined $channel or not defined $hostmask) {
|
||||
return "Usage: useradd <account name> <channel> <hostmask> [capabilities [password]]";
|
||||
}
|
||||
if (not defined $name or not defined $channel or not defined $hostmask) { return "Usage: useradd <account name> <channel> <hostmask> [capabilities [password]]"; }
|
||||
|
||||
$channel = '.*' if $channel !~ /^#/;
|
||||
$channel = '.*' if $channel !~ /^#/;
|
||||
|
||||
my $u = $self->{pbot}->{users}->find_user($channel, "$nick!$user\@$host");
|
||||
my $u = $self->{pbot}->{users}->find_user($channel, "$nick!$user\@$host");
|
||||
|
||||
if (not defined $u) {
|
||||
$channel = 'global' if $channel eq '.*';
|
||||
return "You do not have a user account for $channel; cannot add users to that channel.\n";
|
||||
}
|
||||
|
||||
if ($capabilities ne 'none' and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-capabilities')) {
|
||||
return "Your user account does not have the can-modify-capabilities capability. You cannot create user accounts with capabilities.";
|
||||
}
|
||||
|
||||
foreach my $cap (split /\s*,\s*/, lc $capabilities) {
|
||||
next if $cap eq 'none';
|
||||
return "There is no such capability $cap." if not $self->{pbot}->{capabilities}->exists($cap);
|
||||
if (not $self->{pbot}->{capabilities}->userhas($u, $cap)) {
|
||||
return "To set the $cap capability your user account must also have it.";
|
||||
if (not defined $u) {
|
||||
$channel = 'global' if $channel eq '.*';
|
||||
return "You do not have a user account for $channel; cannot add users to that channel.\n";
|
||||
}
|
||||
if ($self->{pbot}->{capabilities}->has($cap, 'admin') and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-admins')) {
|
||||
return "To set the $cap capability your user account must have the can-modify-admins capability.";
|
||||
|
||||
if ($capabilities ne 'none' and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-capabilities')) {
|
||||
return "Your user account does not have the can-modify-capabilities capability. You cannot create user accounts with capabilities.";
|
||||
}
|
||||
}
|
||||
$self->{pbot}->{users}->add_user($name, $channel, $hostmask, $capabilities, $password);
|
||||
return "User added.";
|
||||
|
||||
foreach my $cap (split /\s*,\s*/, lc $capabilities) {
|
||||
next if $cap eq 'none';
|
||||
return "There is no such capability $cap." if not $self->{pbot}->{capabilities}->exists($cap);
|
||||
if (not $self->{pbot}->{capabilities}->userhas($u, $cap)) { return "To set the $cap capability your user account must also have it."; }
|
||||
if ($self->{pbot}->{capabilities}->has($cap, 'admin') and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-admins')) {
|
||||
return "To set the $cap capability your user account must have the can-modify-admins capability.";
|
||||
}
|
||||
}
|
||||
$self->{pbot}->{users}->add_user($name, $channel, $hostmask, $capabilities, $password);
|
||||
return "User added.";
|
||||
}
|
||||
|
||||
sub userdel {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($channel, $hostmask) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($channel, $hostmask) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
|
||||
if (not defined $channel or not defined $hostmask) {
|
||||
return "Usage: userdel <channel> <hostmask or account name>";
|
||||
}
|
||||
if (not defined $channel or not defined $hostmask) { return "Usage: userdel <channel> <hostmask or account name>"; }
|
||||
|
||||
my $u = $self->find_user($channel, "$nick!$user\@$host");
|
||||
my $t = $self->find_user($channel, $hostmask);
|
||||
my $u = $self->find_user($channel, "$nick!$user\@$host");
|
||||
my $t = $self->find_user($channel, $hostmask);
|
||||
|
||||
if ($self->{pbot}->{capabilities}->userhas($t, 'botowner') and not $self->{pbot}->{capabilities}->userhas($u, 'botowner')) {
|
||||
return "Only botowners may delete botowner user accounts.";
|
||||
}
|
||||
if ($self->{pbot}->{capabilities}->userhas($t, 'botowner') and not $self->{pbot}->{capabilities}->userhas($u, 'botowner')) {
|
||||
return "Only botowners may delete botowner user accounts.";
|
||||
}
|
||||
|
||||
if ($self->{pbot}->{capabilities}->userhas($t, 'admin') and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-admins')) {
|
||||
return "To delete admin user accounts your user account must have the can-modify-admins capability.";
|
||||
}
|
||||
if ($self->{pbot}->{capabilities}->userhas($t, 'admin') and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-admins')) {
|
||||
return "To delete admin user accounts your user account must have the can-modify-admins capability.";
|
||||
}
|
||||
|
||||
my ($found_channel, $found_hostmask) = $self->find_user_account($channel, $hostmask);
|
||||
$found_channel = $channel if not defined $found_channel; # let DualIndexHashObject disambiguate
|
||||
return $self->remove_user($found_channel, $found_hostmask);
|
||||
my ($found_channel, $found_hostmask) = $self->find_user_account($channel, $hostmask);
|
||||
$found_channel = $channel if not defined $found_channel; # let DualIndexHashObject disambiguate
|
||||
return $self->remove_user($found_channel, $found_hostmask);
|
||||
}
|
||||
|
||||
sub userset {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
|
||||
if (length $arguments and $stuff->{arglist}[0] !~ m/^(#|\.\*$|global$)/) {
|
||||
$self->{pbot}->{interpreter}->unshift_arg($stuff->{arglist}, $from)
|
||||
}
|
||||
if (length $arguments and $stuff->{arglist}[0] !~ m/^(#|\.\*$|global$)/) { $self->{pbot}->{interpreter}->unshift_arg($stuff->{arglist}, $from) }
|
||||
|
||||
my ($channel, $hostmask, $key, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 4);
|
||||
my ($channel, $hostmask, $key, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 4);
|
||||
|
||||
if (not defined $hostmask) {
|
||||
return "Usage: userset [channel] <hostmask or account name> [key [value]]";
|
||||
}
|
||||
if (not defined $hostmask) { return "Usage: userset [channel] <hostmask or account name> [key [value]]"; }
|
||||
|
||||
my $u = $self->find_user($channel, "$nick!$user\@$host");
|
||||
my $target = $self->find_user($channel, $hostmask);
|
||||
my $u = $self->find_user($channel, "$nick!$user\@$host");
|
||||
my $target = $self->find_user($channel, $hostmask);
|
||||
|
||||
if (not $u) {
|
||||
$channel = 'global' if $channel eq '.*';
|
||||
return "You do not have a user account for $channel; cannot modify their users.";
|
||||
}
|
||||
|
||||
if (not $target) {
|
||||
if ($channel !~ /^#/) {
|
||||
return "There is no user account $hostmask.";
|
||||
} else {
|
||||
return "There is no user account $hostmask for $channel.";
|
||||
if (not $u) {
|
||||
$channel = 'global' if $channel eq '.*';
|
||||
return "You do not have a user account for $channel; cannot modify their users.";
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $value and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-capabilities')) {
|
||||
if ($key =~ m/^can-/i or $self->{pbot}->{capabilities}->exists($key)) {
|
||||
return "The $key metadata requires the can-modify-capabilities capability, which your user account does not have.";
|
||||
if (not $target) {
|
||||
if ($channel !~ /^#/) { return "There is no user account $hostmask."; }
|
||||
else { return "There is no user account $hostmask for $channel."; }
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $value and $self->{pbot}->{capabilities}->userhas($target, 'admin') and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-admins')) {
|
||||
return "To modify admin user accounts your user account must have the can-modify-admins capability.";
|
||||
}
|
||||
if (defined $value and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-capabilities')) {
|
||||
if ($key =~ m/^can-/i or $self->{pbot}->{capabilities}->exists($key)) {
|
||||
return "The $key metadata requires the can-modify-capabilities capability, which your user account does not have.";
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $key and $self->{pbot}->{capabilities}->exists($key) and not $self->{pbot}->{capabilities}->userhas($u, $key)) {
|
||||
return "To set the $key capability your user account must also have it." unless $self->{pbot}->{capabilities}->userhas($u, 'botowner');
|
||||
}
|
||||
if (defined $value and $self->{pbot}->{capabilities}->userhas($target, 'admin') and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-admins')) {
|
||||
return "To modify admin user accounts your user account must have the can-modify-admins capability.";
|
||||
}
|
||||
|
||||
my ($found_channel, $found_hostmask) = $self->find_user_account($channel, $hostmask);
|
||||
$found_channel = $channel if not defined $found_channel; # let DualIndexHashObject disambiguate
|
||||
my $result = $self->{users}->set($found_channel, $found_hostmask, $key, $value);
|
||||
$result =~ s/^password => .*;?$/password => <private>;/m;
|
||||
return $result;
|
||||
if (defined $key and $self->{pbot}->{capabilities}->exists($key) and not $self->{pbot}->{capabilities}->userhas($u, $key)) {
|
||||
return "To set the $key capability your user account must also have it." unless $self->{pbot}->{capabilities}->userhas($u, 'botowner');
|
||||
}
|
||||
|
||||
my ($found_channel, $found_hostmask) = $self->find_user_account($channel, $hostmask);
|
||||
$found_channel = $channel if not defined $found_channel; # let DualIndexHashObject disambiguate
|
||||
my $result = $self->{users}->set($found_channel, $found_hostmask, $key, $value);
|
||||
$result =~ s/^password => .*;?$/password => <private>;/m;
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub userunset {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
|
||||
if (length $arguments and $stuff->{arglist}[0] !~ m/^(#|\.\*$|global$)/) {
|
||||
$self->{pbot}->{interpreter}->unshift_arg($stuff->{arglist}, $from)
|
||||
}
|
||||
if (length $arguments and $stuff->{arglist}[0] !~ m/^(#|\.\*$|global$)/) { $self->{pbot}->{interpreter}->unshift_arg($stuff->{arglist}, $from) }
|
||||
|
||||
my ($channel, $hostmask, $key) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3);
|
||||
my ($channel, $hostmask, $key) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3);
|
||||
|
||||
if (not defined $hostmask) {
|
||||
return "Usage: userunset [channel] <hostmask or account name> <key>";
|
||||
}
|
||||
if (not defined $hostmask) { return "Usage: userunset [channel] <hostmask or account name> <key>"; }
|
||||
|
||||
my $u = $self->find_user($channel, "$nick!$user\@$host");
|
||||
my $target = $self->find_user($channel, $hostmask);
|
||||
my $u = $self->find_user($channel, "$nick!$user\@$host");
|
||||
my $target = $self->find_user($channel, $hostmask);
|
||||
|
||||
if (not $u) {
|
||||
$channel = 'global' if $channel eq '.*';
|
||||
return "You do not have a user account for $channel; cannot modify their users.";
|
||||
}
|
||||
|
||||
if (not $target) {
|
||||
if ($channel !~ /^#/) {
|
||||
return "There is no user account $hostmask.";
|
||||
} else {
|
||||
return "There is no user account $hostmask for $channel.";
|
||||
if (not $u) {
|
||||
$channel = 'global' if $channel eq '.*';
|
||||
return "You do not have a user account for $channel; cannot modify their users.";
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $key and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-capabilities')) {
|
||||
if ($key =~ m/^can-/i or $self->{pbot}->{capabilities}->exists($key)) {
|
||||
return "The $key metadata requires the can-modify-capabilities capability, which your user account does not have.";
|
||||
if (not $target) {
|
||||
if ($channel !~ /^#/) { return "There is no user account $hostmask."; }
|
||||
else { return "There is no user account $hostmask for $channel."; }
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $key and $self->{pbot}->{capabilities}->userhas($target, 'admin') and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-admins')) {
|
||||
return "To modify admin user accounts your user account must have the can-modify-admins capability.";
|
||||
}
|
||||
if (defined $key and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-capabilities')) {
|
||||
if ($key =~ m/^can-/i or $self->{pbot}->{capabilities}->exists($key)) {
|
||||
return "The $key metadata requires the can-modify-capabilities capability, which your user account does not have.";
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $key and $self->{pbot}->{capabilities}->exists($key) and not $self->{pbot}->{capabilities}->userhas($u, $key)) {
|
||||
return "To unset the $key capability your user account must also have it." unless $self->{pbot}->{capabilities}->userhas($u, 'botowner');
|
||||
}
|
||||
if (defined $key and $self->{pbot}->{capabilities}->userhas($target, 'admin') and not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-admins')) {
|
||||
return "To modify admin user accounts your user account must have the can-modify-admins capability.";
|
||||
}
|
||||
|
||||
my ($found_channel, $found_hostmask) = $self->find_user_account($channel, $hostmask);
|
||||
$found_channel = $channel if not defined $found_channel; # let DualIndexHashObject disambiguate
|
||||
return $self->{users}->unset($found_channel, $found_hostmask, $key);
|
||||
if (defined $key and $self->{pbot}->{capabilities}->exists($key) and not $self->{pbot}->{capabilities}->userhas($u, $key)) {
|
||||
return "To unset the $key capability your user account must also have it." unless $self->{pbot}->{capabilities}->userhas($u, 'botowner');
|
||||
}
|
||||
|
||||
my ($found_channel, $found_hostmask) = $self->find_user_account($channel, $hostmask);
|
||||
$found_channel = $channel if not defined $found_channel; # let DualIndexHashObject disambiguate
|
||||
return $self->{users}->unset($found_channel, $found_hostmask, $key);
|
||||
}
|
||||
|
||||
sub mycmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($key, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($key, $value) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2);
|
||||
|
||||
if (defined $value) {
|
||||
$value =~ s/^is\s+//;
|
||||
$value = undef if not length $value;
|
||||
}
|
||||
|
||||
my $channel = $from;
|
||||
my $hostmask = "$nick!$user\@$host";
|
||||
|
||||
my $u = $self->find_user($channel, $hostmask, 1);
|
||||
|
||||
if (not $u) {
|
||||
$channel = '.*';
|
||||
$hostmask = "$nick!$user\@" . $self->{pbot}->{antiflood}->address_to_mask($host);
|
||||
my $name = $nick;
|
||||
|
||||
my ($existing_channel, $existing_hostmask) = $self->find_user_account($channel, $name);
|
||||
if ($existing_hostmask ne lc $name) {
|
||||
# user exists by name
|
||||
return "There is already an user account named $name but its hostmask ($existing_hostmask) does not match your hostmask ($hostmask). Ask an admin for help.";
|
||||
}
|
||||
|
||||
$u = $self->add_user($name, $channel, $hostmask, undef, undef, 1);
|
||||
$u->{loggedin} = 1;
|
||||
$u->{stayloggedin} = 1;
|
||||
$u->{autologin} = 1;
|
||||
$self->save;
|
||||
}
|
||||
|
||||
my $result = '';
|
||||
|
||||
if (defined $key) {
|
||||
$key = lc $key;
|
||||
if (defined $value) {
|
||||
if (not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-capabilities')) {
|
||||
if ($key =~ m/^is-/ or $key =~ m/^can-/ or $self->{pbot}->{capabilities}->exists($key)) {
|
||||
return "The $key metadata requires the can-modify-capabilities capability, which your user account does not have.";
|
||||
}
|
||||
}
|
||||
|
||||
if (not $self->{pbot}->{capabilities}->userhas($u, 'botowner')) {
|
||||
my @disallowed = qw/can-modify-admins botowner can-modify-capabilities/;
|
||||
if (grep { $_ eq $key } @disallowed) {
|
||||
return "The $key metadata requires the botowner capability to set, which your user account does not have.";
|
||||
}
|
||||
}
|
||||
|
||||
if (not $self->{pbot}->{capabilities}->userhas($u, 'admin')) {
|
||||
my @disallowed = qw/name autoop autovoice chanop admin/;
|
||||
if (grep { $_ eq $key } @disallowed) {
|
||||
return "The $key metadata requires the admin capability to set, which your user account does not have.";
|
||||
}
|
||||
}
|
||||
$value =~ s/^is\s+//;
|
||||
$value = undef if not length $value;
|
||||
}
|
||||
} else {
|
||||
$result = "Usage: my <key> [value]; ";
|
||||
}
|
||||
|
||||
my ($found_channel, $found_hostmask) = $self->find_user_account($channel, $hostmask, 1);
|
||||
($found_channel, $found_hostmask) = $self->find_user_account('.*', $hostmask, 1) if not defined $found_channel;
|
||||
return "No user account found in $channel." if not defined $found_channel;
|
||||
$result .= $self->{users}->set($found_channel, $found_hostmask, $key, $value);
|
||||
$result =~ s/^password => .*;?$/password => <private>;/m;
|
||||
return $result;
|
||||
my $channel = $from;
|
||||
my $hostmask = "$nick!$user\@$host";
|
||||
|
||||
my $u = $self->find_user($channel, $hostmask, 1);
|
||||
|
||||
if (not $u) {
|
||||
$channel = '.*';
|
||||
$hostmask = "$nick!$user\@" . $self->{pbot}->{antiflood}->address_to_mask($host);
|
||||
my $name = $nick;
|
||||
|
||||
my ($existing_channel, $existing_hostmask) = $self->find_user_account($channel, $name);
|
||||
if ($existing_hostmask ne lc $name) {
|
||||
|
||||
# user exists by name
|
||||
return "There is already an user account named $name but its hostmask ($existing_hostmask) does not match your hostmask ($hostmask). Ask an admin for help.";
|
||||
}
|
||||
|
||||
$u = $self->add_user($name, $channel, $hostmask, undef, undef, 1);
|
||||
$u->{loggedin} = 1;
|
||||
$u->{stayloggedin} = 1;
|
||||
$u->{autologin} = 1;
|
||||
$self->save;
|
||||
}
|
||||
|
||||
my $result = '';
|
||||
|
||||
if (defined $key) {
|
||||
$key = lc $key;
|
||||
if (defined $value) {
|
||||
if (not $self->{pbot}->{capabilities}->userhas($u, 'can-modify-capabilities')) {
|
||||
if ($key =~ m/^is-/ or $key =~ m/^can-/ or $self->{pbot}->{capabilities}->exists($key)) {
|
||||
return "The $key metadata requires the can-modify-capabilities capability, which your user account does not have.";
|
||||
}
|
||||
}
|
||||
|
||||
if (not $self->{pbot}->{capabilities}->userhas($u, 'botowner')) {
|
||||
my @disallowed = qw/can-modify-admins botowner can-modify-capabilities/;
|
||||
if (grep { $_ eq $key } @disallowed) {
|
||||
return "The $key metadata requires the botowner capability to set, which your user account does not have.";
|
||||
}
|
||||
}
|
||||
|
||||
if (not $self->{pbot}->{capabilities}->userhas($u, 'admin')) {
|
||||
my @disallowed = qw/name autoop autovoice chanop admin/;
|
||||
if (grep { $_ eq $key } @disallowed) {
|
||||
return "The $key metadata requires the admin capability to set, which your user account does not have.";
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$result = "Usage: my <key> [value]; ";
|
||||
}
|
||||
|
||||
my ($found_channel, $found_hostmask) = $self->find_user_account($channel, $hostmask, 1);
|
||||
($found_channel, $found_hostmask) = $self->find_user_account('.*', $hostmask, 1) if not defined $found_channel;
|
||||
return "No user account found in $channel." if not defined $found_channel;
|
||||
$result .= $self->{users}->set($found_channel, $found_hostmask, $key, $value);
|
||||
$result =~ s/^password => .*;?$/password => <private>;/m;
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
package PBot::Utils::Indefinite;
|
||||
|
||||
use 5.010; use warnings;
|
||||
|
||||
use feature 'unicode_strings';
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw/Exporter/;
|
||||
our @ISA = qw/Exporter/;
|
||||
our @EXPORT = qw/prepend_indefinite_article select_indefinite_article/;
|
||||
|
||||
# This module implements A/AN inflexion for nouns...
|
||||
|
|
@ -44,48 +45,47 @@ sub select_indefinite_article {
|
|||
my ($word) = @_;
|
||||
|
||||
# Handle ordinal forms...
|
||||
return "a" if $word =~ $ORDINAL_A;
|
||||
return "an" if $word =~ $ORDINAL_AN;
|
||||
return "a" if $word =~ $ORDINAL_A;
|
||||
return "an" if $word =~ $ORDINAL_AN;
|
||||
|
||||
# Handle special cases...
|
||||
return "an" if $word =~ $EXPLICIT_AN;
|
||||
return "an" if $word =~ $SINGLE_AN;
|
||||
return "a" if $word =~ $SINGLE_A;
|
||||
return "an" if $word =~ $EXPLICIT_AN;
|
||||
return "an" if $word =~ $SINGLE_AN;
|
||||
return "a" if $word =~ $SINGLE_A;
|
||||
|
||||
# Handle abbreviations...
|
||||
return "an" if $word =~ $ABBREV_AN;
|
||||
return "an" if $word =~ /\A [aefhilmnorsx][.-]/xi;
|
||||
return "a" if $word =~ /\A [a-z][.-]/xi;
|
||||
return "an" if $word =~ $ABBREV_AN;
|
||||
return "an" if $word =~ /\A [aefhilmnorsx][.-]/xi;
|
||||
return "a" if $word =~ /\A [a-z][.-]/xi;
|
||||
|
||||
# Handle consonants
|
||||
|
||||
return "a" if $word =~ /\A [^aeiouy] /xi;
|
||||
return "a" if $word =~ /\A [^aeiouy] /xi;
|
||||
|
||||
# Handle special vowel-forms
|
||||
|
||||
return "a" if $word =~ /\A e [uw] /xi;
|
||||
return "a" if $word =~ /\A onc?e \b /xi;
|
||||
return "a" if $word =~ /\A uni (?: [^nmd] | mo) /xi;
|
||||
return "an" if $word =~ /\A ut[th] /xi;
|
||||
return "a" if $word =~ /\A u [bcfhjkqrst] [aeiou] /xi;
|
||||
return "a" if $word =~ /\A e [uw] /xi;
|
||||
return "a" if $word =~ /\A onc?e \b /xi;
|
||||
return "a" if $word =~ /\A uni (?: [^nmd] | mo) /xi;
|
||||
return "an" if $word =~ /\A ut[th] /xi;
|
||||
return "a" if $word =~ /\A u [bcfhjkqrst] [aeiou] /xi;
|
||||
|
||||
# Handle special capitals
|
||||
|
||||
return "a" if $word =~ /\A U [NK] [AIEO]? /x;
|
||||
return "a" if $word =~ /\A U [NK] [AIEO]? /x;
|
||||
|
||||
# Handle vowels
|
||||
|
||||
return "an" if $word =~ /\A [aeiou]/xi;
|
||||
return "an" if $word =~ /\A [aeiou]/xi;
|
||||
|
||||
# Handle Y... (before certain consonants implies (unnaturalized) "I.." sound)
|
||||
return "an" if $word =~ $INITIAL_Y_AN;
|
||||
return "an" if $word =~ $INITIAL_Y_AN;
|
||||
|
||||
# Otherwise, guess "A"
|
||||
return "a";
|
||||
}
|
||||
|
||||
|
||||
1; # Magic true value required at end of module
|
||||
1; # Magic true value required at end of module
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
|
|
|||
|
|
@ -11,43 +11,41 @@ use File::HomeDir;
|
|||
use File::Spec;
|
||||
|
||||
our %default_cache_args = (
|
||||
'namespace' => 'pbot-cached',
|
||||
'cache_root' => File::Spec->catfile(File::HomeDir->my_home, '.cache'),
|
||||
'default_expires_in' => 600
|
||||
'namespace' => 'pbot-cached',
|
||||
'cache_root' => File::Spec->catfile(File::HomeDir->my_home, '.cache'),
|
||||
'default_expires_in' => 600
|
||||
);
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $cache_opt;
|
||||
my %lwp_opt;
|
||||
unless (scalar @_ % 2) {
|
||||
%lwp_opt = @_;
|
||||
$cache_opt = {};
|
||||
for my $key (qw(namespace cache_root default_expires_in)) {
|
||||
$cache_opt->{$key} = delete $lwp_opt{$key} if exists $lwp_opt{$key};
|
||||
my $class = shift;
|
||||
my $cache_opt;
|
||||
my %lwp_opt;
|
||||
unless (scalar @_ % 2) {
|
||||
%lwp_opt = @_;
|
||||
$cache_opt = {};
|
||||
for my $key (qw(namespace cache_root default_expires_in)) { $cache_opt->{$key} = delete $lwp_opt{$key} if exists $lwp_opt{$key}; }
|
||||
} else {
|
||||
$cache_opt = shift || {};
|
||||
%lwp_opt = @_;
|
||||
}
|
||||
} else {
|
||||
$cache_opt = shift || {};
|
||||
%lwp_opt = @_;
|
||||
}
|
||||
my $self = $class->SUPER::new(%lwp_opt);
|
||||
my %cache_args = (%default_cache_args, %$cache_opt);
|
||||
$self->{cache} = Cache::FileCache->new(\%cache_args);
|
||||
return $self
|
||||
my $self = $class->SUPER::new(%lwp_opt);
|
||||
my %cache_args = (%default_cache_args, %$cache_opt);
|
||||
$self->{cache} = Cache::FileCache->new(\%cache_args);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub request {
|
||||
my ($self, @args) = @_;
|
||||
my $request = $args[0];
|
||||
return $self->SUPER::request(@args) if $request->method ne 'GET';
|
||||
my ($self, @args) = @_;
|
||||
my $request = $args[0];
|
||||
return $self->SUPER::request(@args) if $request->method ne 'GET';
|
||||
|
||||
my $uri = $request->uri->as_string;
|
||||
my $cached = $self->{cache}->get($uri);
|
||||
return HTTP::Response->parse($cached) if defined $cached;
|
||||
my $uri = $request->uri->as_string;
|
||||
my $cached = $self->{cache}->get($uri);
|
||||
return HTTP::Response->parse($cached) if defined $cached;
|
||||
|
||||
my $res = $self->SUPER::request(@args);
|
||||
$self->{cache}->set($uri, $res->as_string) if $res->code eq HTTP::Status::RC_OK;
|
||||
return $res;
|
||||
my $res = $self->SUPER::request(@args);
|
||||
$self->{cache}->set($uri, $res->as_string) if $res->code eq HTTP::Status::RC_OK;
|
||||
return $res;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -16,129 +16,127 @@ use DateTime::Format::Flexible;
|
|||
use DateTime::Format::Duration;
|
||||
|
||||
sub new {
|
||||
Carp::croak("Options to " . __FILE__ . " should be key/value pairs, not hash reference") if ref $_[1] eq 'HASH';
|
||||
my ($class, %conf) = @_;
|
||||
my $self = bless {}, $class;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
Carp::croak("Options to " . __FILE__ . " should be key/value pairs, not hash reference") if ref $_[1] eq 'HASH';
|
||||
my ($class, %conf) = @_;
|
||||
my $self = bless {}, $class;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot} = $conf{pbot} // Carp::croak("Missing pbot reference to " . __FILE__);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot} = $conf{pbot} // Carp::croak("Missing pbot reference to " . __FILE__);
|
||||
}
|
||||
|
||||
# expands stuff like "7d3h" to "7 days and 3 hours"
|
||||
sub unconcise {
|
||||
my ($input) = @_;
|
||||
my %word = (y => 'years', w => 'weeks', d => 'days', h => 'hours', m => 'minutes', s => 'seconds');
|
||||
$input =~ s/(\d+)([ywdhms])(?![a-z])/"$1 " . $word{lc $2} . ' and '/ige;
|
||||
$input =~ s/ and $//;
|
||||
return $input;
|
||||
my ($input) = @_;
|
||||
my %word = (y => 'years', w => 'weeks', d => 'days', h => 'hours', m => 'minutes', s => 'seconds');
|
||||
$input =~ s/(\d+)([ywdhms])(?![a-z])/"$1 " . $word{lc $2} . ' and '/ige;
|
||||
$input =~ s/ and $//;
|
||||
return $input;
|
||||
}
|
||||
|
||||
# parses English natural language date strings into seconds
|
||||
# does not accept times or dates in the past
|
||||
sub parsedate {
|
||||
my ($self, $input) = @_;
|
||||
my ($self, $input) = @_;
|
||||
|
||||
my $override ="";
|
||||
my $override = "";
|
||||
TRY_AGAIN:
|
||||
$input = "$override$input" if length $override;
|
||||
$input = "$override$input" if length $override;
|
||||
|
||||
# expand stuff like 7d3h
|
||||
$input = unconcise($input);
|
||||
# expand stuff like 7d3h
|
||||
$input = unconcise($input);
|
||||
|
||||
# some aliases
|
||||
$input =~ s/\bsecs?\b/seconds/g;
|
||||
$input =~ s/\bmins?\b/minutes/g;
|
||||
$input =~ s/\bhrs?\b/hours/g;
|
||||
$input =~ s/\bwks?\b/weeks/g;
|
||||
$input =~ s/\byrs?\b/years/g;
|
||||
# some aliases
|
||||
$input =~ s/\bsecs?\b/seconds/g;
|
||||
$input =~ s/\bmins?\b/minutes/g;
|
||||
$input =~ s/\bhrs?\b/hours/g;
|
||||
$input =~ s/\bwks?\b/weeks/g;
|
||||
$input =~ s/\byrs?\b/years/g;
|
||||
|
||||
# sanitizers
|
||||
$input =~ s/\b(\d+)\s+(am?|pm?)\b/$1$2/; # remove leading spaces from am/pm
|
||||
$input =~ s/ (\d+)(am?|pm?)\b/ $1:00:00$2/; # convert 3pm to 3:00:00pm
|
||||
$input =~ s/ (\d+:\d+)(am?|pm?)\b/ $1:00$2/; # convert 4:20pm to 4:20:00pm
|
||||
$input =~ s/next (jan(?:uary)?|feb(?:ruary)?|mar(?:ch)?|apr(?:il)?|may|june?|july?|aug(?:ust)?|sept(?:ember)?|oct(?:ober)?|nov(?:ember)|dec(?:ember)?) (\d+)(?:st|nd|rd|th)?(.*)/"next $1 and " . ($2 - 1) . " days" . (length $3 ? " and $3" : "")/ie;
|
||||
# sanitizers
|
||||
$input =~ s/\b(\d+)\s+(am?|pm?)\b/$1$2/; # remove leading spaces from am/pm
|
||||
$input =~ s/ (\d+)(am?|pm?)\b/ $1:00:00$2/; # convert 3pm to 3:00:00pm
|
||||
$input =~ s/ (\d+:\d+)(am?|pm?)\b/ $1:00$2/; # convert 4:20pm to 4:20:00pm
|
||||
$input =~
|
||||
s/next (jan(?:uary)?|feb(?:ruary)?|mar(?:ch)?|apr(?:il)?|may|june?|july?|aug(?:ust)?|sept(?:ember)?|oct(?:ober)?|nov(?:ember)|dec(?:ember)?) (\d+)(?:st|nd|rd|th)?(.*)/"next $1 and " . ($2 - 1) . " days" . (length $3 ? " and $3" : "")/ie;
|
||||
|
||||
# split input on "and" or comma, then we'll add up the results
|
||||
# this allows us to parse things like "1 hour and 30 minutes"
|
||||
my @inputs = split /(?:,?\s+and\s+|\s*,\s*|\s+at\s+)/, $input;
|
||||
# split input on "and" or comma, then we'll add up the results
|
||||
# this allows us to parse things like "1 hour and 30 minutes"
|
||||
my @inputs = split /(?:,?\s+and\s+|\s*,\s*|\s+at\s+)/, $input;
|
||||
|
||||
# adjust timezone to user-override if user provides a timezone
|
||||
# we won't know if a timezone was provided until it is parsed
|
||||
my $timezone;
|
||||
my $tz_override = 'UTC';
|
||||
# adjust timezone to user-override if user provides a timezone
|
||||
# we won't know if a timezone was provided until it is parsed
|
||||
my $timezone;
|
||||
my $tz_override = 'UTC';
|
||||
|
||||
ADJUST_TIMEZONE:
|
||||
$timezone = $tz_override;
|
||||
my $now = DateTime->now(time_zone => $timezone);
|
||||
$timezone = $tz_override;
|
||||
my $now = DateTime->now(time_zone => $timezone);
|
||||
|
||||
my $seconds = 0;
|
||||
my ($to, $base);
|
||||
my $seconds = 0;
|
||||
my ($to, $base);
|
||||
|
||||
foreach my $input (@inputs) {
|
||||
return -1 if $input =~ m/forever/i;
|
||||
$input .= ' seconds' if $input =~ m/^\s*\d+\s*$/;
|
||||
foreach my $input (@inputs) {
|
||||
return -1 if $input =~ m/forever/i;
|
||||
$input .= ' seconds' if $input =~ m/^\s*\d+\s*$/;
|
||||
|
||||
# DateTime::Format::Flexible doesn't support seconds, but that's okay;
|
||||
# we can take care of that easily here!
|
||||
if ($input =~ m/^\s*(\d+)\s+seconds$/) {
|
||||
$seconds += $1;
|
||||
next;
|
||||
# DateTime::Format::Flexible doesn't support seconds, but that's okay;
|
||||
# we can take care of that easily here!
|
||||
if ($input =~ m/^\s*(\d+)\s+seconds$/) {
|
||||
$seconds += $1;
|
||||
next;
|
||||
}
|
||||
|
||||
# adjust base
|
||||
if (defined $to) {
|
||||
$base = $to->clone;
|
||||
$base->set_time_zone($timezone);
|
||||
} else {
|
||||
$base = $now;
|
||||
}
|
||||
|
||||
# First, attempt to parse as-is...
|
||||
$to = eval { return DateTime::Format::Flexible->parse_datetime($input, lang => ['en'], base => $base); };
|
||||
|
||||
# If there was an error, then append "from now" and attempt to parse as a relative time...
|
||||
if ($@) {
|
||||
$input .= ' from now';
|
||||
$to = eval { return DateTime::Format::Flexible->parse_datetime($input, lang => ['en'], base => $base); };
|
||||
|
||||
# If there's still an error, it's bad input
|
||||
if ($@) {
|
||||
$@ =~ s/ ${override}from now at PBot.*$//;
|
||||
return (0, $@);
|
||||
}
|
||||
}
|
||||
|
||||
# there was a timezone parsed, set the tz override and try again
|
||||
if ($to->time_zone_short_name ne 'floating' and $to->time_zone_short_name ne 'UTC' and $tz_override eq 'UTC') {
|
||||
$tz_override = $to->time_zone_long_name;
|
||||
$to = undef;
|
||||
goto ADJUST_TIMEZONE;
|
||||
}
|
||||
|
||||
$to->set_time_zone('UTC');
|
||||
$base->set_time_zone('UTC');
|
||||
my $duration = $to->subtract_datetime_absolute($base);
|
||||
|
||||
# If the time is in the past, prepend "tomorrow" or "next" and reparse
|
||||
if ($duration->is_negative) {
|
||||
if ($input =~ m/^\d/) { $override = "tomorrow "; }
|
||||
else { $override = "next "; }
|
||||
$to = undef;
|
||||
goto TRY_AGAIN;
|
||||
}
|
||||
|
||||
# add the seconds from this input chunk
|
||||
$seconds += $duration->seconds;
|
||||
}
|
||||
|
||||
# adjust base
|
||||
if (defined $to) {
|
||||
$base = $to->clone;
|
||||
$base->set_time_zone($timezone);
|
||||
} else {
|
||||
$base = $now;
|
||||
}
|
||||
|
||||
# First, attempt to parse as-is...
|
||||
$to = eval { return DateTime::Format::Flexible->parse_datetime($input, lang => ['en'], base => $base); };
|
||||
|
||||
# If there was an error, then append "from now" and attempt to parse as a relative time...
|
||||
if ($@) {
|
||||
$input .= ' from now';
|
||||
$to = eval { return DateTime::Format::Flexible->parse_datetime($input, lang => ['en'], base => $base); };
|
||||
|
||||
# If there's still an error, it's bad input
|
||||
if ($@) {
|
||||
$@ =~ s/ ${override}from now at PBot.*$//;
|
||||
return (0, $@);
|
||||
}
|
||||
}
|
||||
|
||||
# there was a timezone parsed, set the tz override and try again
|
||||
if ($to->time_zone_short_name ne 'floating' and $to->time_zone_short_name ne 'UTC' and $tz_override eq 'UTC') {
|
||||
$tz_override = $to->time_zone_long_name;
|
||||
$to = undef;
|
||||
goto ADJUST_TIMEZONE;
|
||||
}
|
||||
|
||||
$to->set_time_zone('UTC');
|
||||
$base->set_time_zone('UTC');
|
||||
my $duration = $to->subtract_datetime_absolute($base);
|
||||
|
||||
# If the time is in the past, prepend "tomorrow" or "next" and reparse
|
||||
if ($duration->is_negative) {
|
||||
if ($input =~ m/^\d/) {
|
||||
$override = "tomorrow ";
|
||||
} else {
|
||||
$override = "next ";
|
||||
}
|
||||
$to = undef;
|
||||
goto TRY_AGAIN;
|
||||
}
|
||||
|
||||
# add the seconds from this input chunk
|
||||
$seconds += $duration->seconds;
|
||||
}
|
||||
|
||||
return $seconds;
|
||||
return $seconds;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -1,26 +1,23 @@
|
|||
package PBot::Utils::SafeFilename;
|
||||
|
||||
use 5.010; use warnings;
|
||||
use feature 'unicode_strings';
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw/Exporter/;
|
||||
our @ISA = qw/Exporter/;
|
||||
our @EXPORT = qw/safe_filename/;
|
||||
|
||||
sub safe_filename {
|
||||
my $name = shift;
|
||||
my $safe = '';
|
||||
my $name = shift;
|
||||
my $safe = '';
|
||||
|
||||
while ($name =~ m/(.)/gms) {
|
||||
if ($1 eq '&') {
|
||||
$safe .= '&';
|
||||
} elsif ($1 eq '/') {
|
||||
$safe .= '&fslash;';
|
||||
} else {
|
||||
$safe .= $1;
|
||||
while ($name =~ m/(.)/gms) {
|
||||
if ($1 eq '&') { $safe .= '&'; }
|
||||
elsif ($1 eq '/') { $safe .= '&fslash;'; }
|
||||
else { $safe .= $1; }
|
||||
}
|
||||
}
|
||||
|
||||
return lc $safe;
|
||||
return lc $safe;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -6,35 +6,33 @@ use strict;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw/Exporter/;
|
||||
our @ISA = qw/Exporter/;
|
||||
our @EXPORT = qw/validate_string/;
|
||||
|
||||
use JSON;
|
||||
|
||||
sub validate_string {
|
||||
my ($string, $max_length) = @_;
|
||||
my ($string, $max_length) = @_;
|
||||
|
||||
return $string if not defined $string or not length $string;
|
||||
$max_length = 1024 * 8 if not defined $max_length;
|
||||
return $string if not defined $string or not length $string;
|
||||
$max_length = 1024 * 8 if not defined $max_length;
|
||||
|
||||
eval {
|
||||
my $h = decode_json($string);
|
||||
foreach my $k (keys %$h) {
|
||||
$h->{$k} = substr $h->{$k}, 0, $max_length unless $max_length <= 0;
|
||||
eval {
|
||||
my $h = decode_json($string);
|
||||
foreach my $k (keys %$h) { $h->{$k} = substr $h->{$k}, 0, $max_length unless $max_length <= 0; }
|
||||
$string = encode_json($h);
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
|
||||
# not a json string
|
||||
$string = substr $string, 0, $max_length unless $max_length <= 0;
|
||||
}
|
||||
$string = encode_json($h);
|
||||
};
|
||||
|
||||
# $string =~ s/(\P{PosixGraph})/my $ch = $1; if ($ch =~ m{[\s\x03\x02\x1d\x1f\x16\x0f]}) { $ch } else { sprintf "\\x%02X", ord $ch }/ge;
|
||||
# $string = substr $string, 0, $max_length unless $max_length <= 0;
|
||||
|
||||
if ($@) {
|
||||
# not a json string
|
||||
$string = substr $string, 0, $max_length unless $max_length <= 0;
|
||||
}
|
||||
|
||||
# $string =~ s/(\P{PosixGraph})/my $ch = $1; if ($ch =~ m{[\s\x03\x02\x1d\x1f\x16\x0f]}) { $ch } else { sprintf "\\x%02X", ord $ch }/ge;
|
||||
# $string = substr $string, 0, $max_length unless $max_length <= 0;
|
||||
|
||||
return $string;
|
||||
return $string;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -18,57 +18,51 @@ use LWP::UserAgent;
|
|||
|
||||
# These are set automatically by the misc/update_version script
|
||||
use constant {
|
||||
BUILD_NAME => "PBot",
|
||||
BUILD_REVISION => 3311,
|
||||
BUILD_DATE => "2020-02-15",
|
||||
BUILD_NAME => "PBot",
|
||||
BUILD_REVISION => 3311,
|
||||
BUILD_DATE => "2020-02-15",
|
||||
};
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->version_cmd(@_) }, "version", 0);
|
||||
$self->{last_check} = { timestamp => 0, version => BUILD_REVISION, date => BUILD_DATE };
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->version_cmd(@_) }, "version", 0);
|
||||
$self->{last_check} = {timestamp => 0, version => BUILD_REVISION, date => BUILD_DATE};
|
||||
}
|
||||
|
||||
sub version {
|
||||
return BUILD_NAME . " version " . BUILD_REVISION . " " . BUILD_DATE;
|
||||
}
|
||||
sub version { return BUILD_NAME . " version " . BUILD_REVISION . " " . BUILD_DATE; }
|
||||
|
||||
sub version_cmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
|
||||
my $ratelimit = $self->{pbot}->{registry}->get_value('version', 'check_limit') // 300;
|
||||
my $ratelimit = $self->{pbot}->{registry}->get_value('version', 'check_limit') // 300;
|
||||
|
||||
if (time - $self->{last_check}->{timestamp} >= $ratelimit) {
|
||||
$self->{last_check}->{timestamp} = time;
|
||||
if (time - $self->{last_check}->{timestamp} >= $ratelimit) {
|
||||
$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);
|
||||
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;
|
||||
return "Unable to get version information: " . $response->status_line if not $response->is_success;
|
||||
|
||||
my $text = $response->decoded_content;
|
||||
my ($version, $date) = $text =~ m/^\s+BUILD_REVISION => (\d+).*^\s+BUILD_DATE\s+=> "([^"]+)"/ms;
|
||||
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};
|
||||
}
|
||||
|
||||
$self->{last_check} = { timestamp => time, version => $version, date => $date };
|
||||
}
|
||||
my $target_nick;
|
||||
$target_nick = $self->{pbot}->{nicklist}->is_present_similar($from, $arguments) if length $arguments;
|
||||
|
||||
my $target_nick;
|
||||
$target_nick = $self->{pbot}->{nicklist}->is_present_similar($from, $arguments) if length $arguments;
|
||||
my $result = '/say ';
|
||||
$result .= "$target_nick: " if $target_nick;
|
||||
$result .= $self->version;
|
||||
|
||||
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}!";
|
||||
}
|
||||
return $result;
|
||||
if ($self->{last_check}->{version} > BUILD_REVISION) { $result .= "; new version available: $self->{last_check}->{version} $self->{last_check}->{date}!"; }
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package PBot::WebPaste;
|
||||
|
||||
use parent 'PBot::Class';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -19,56 +20,54 @@ use LWP::UserAgent::Paranoid;
|
|||
use Encode;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
my ($self, %conf) = @_;
|
||||
|
||||
$self->{paste_sites} = [
|
||||
sub { $self->paste_ixio(@_) },
|
||||
];
|
||||
$self->{paste_sites} = [
|
||||
sub { $self->paste_ixio(@_) },
|
||||
];
|
||||
|
||||
$self->{current_site} = 0;
|
||||
$self->{current_site} = 0;
|
||||
}
|
||||
|
||||
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;
|
||||
}
|
||||
return $subref;
|
||||
my ($self) = @_;
|
||||
my $subref = $self->{paste_sites}->[$self->{current_site}];
|
||||
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);
|
||||
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};
|
||||
$text = encode('UTF-8', $text);
|
||||
$text =~ s/(.{120})\s/$1\n/g unless $opts{no_split};
|
||||
$text = encode('UTF-8', $text);
|
||||
|
||||
my $result;
|
||||
for (my $tries = 3; $tries > 0; $tries--) {
|
||||
my $paste_site = $self->get_paste_site;
|
||||
$result = $paste_site->($text);
|
||||
last if $result !~ m/error pasting/;
|
||||
}
|
||||
return $result;
|
||||
my $result;
|
||||
for (my $tries = 3; $tries > 0; $tries--) {
|
||||
my $paste_site = $self->get_paste_site;
|
||||
$result = $paste_site->($text);
|
||||
last if $result !~ m/error pasting/;
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub paste_ixio {
|
||||
my ($self, $text) = @_;
|
||||
my $ua = LWP::UserAgent::Paranoid->new(request_timeout => 10);
|
||||
$ua->agent("Mozilla/5.0");
|
||||
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;
|
||||
my $result = $response->content;
|
||||
$result =~ s/^\s+//;
|
||||
$result =~ s/\s+$//;
|
||||
return $result;
|
||||
my ($self, $text) = @_;
|
||||
my $ua = LWP::UserAgent::Paranoid->new(request_timeout => 10);
|
||||
$ua->agent("Mozilla/5.0");
|
||||
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;
|
||||
my $result = $response->content;
|
||||
$result =~ s/^\s+//;
|
||||
$result =~ s/\s+$//;
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -38,42 +38,42 @@ use Time::Duration qw/duration/;
|
|||
use Time::HiRes qw/gettimeofday/;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->actiontrigger(@_) }, 'actiontrigger', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-actiontrigger', 1);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->actiontrigger(@_) }, 'actiontrigger', 1);
|
||||
$self->{pbot}->{capabilities}->add('admin', 'can-actiontrigger', 1);
|
||||
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->on_action(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.join', sub { $self->on_join(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.part', sub { $self->on_departure(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.quit', sub { $self->on_departure(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.kick', sub { $self->on_kick(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->on_action(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.join', sub { $self->on_join(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.part', sub { $self->on_departure(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.quit', sub { $self->on_departure(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.kick', sub { $self->on_kick(@_) });
|
||||
|
||||
$self->{filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/triggers.sqlite3';
|
||||
$self->{filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/triggers.sqlite3';
|
||||
|
||||
$self->dbi_begin;
|
||||
$self->create_database;
|
||||
$self->dbi_begin;
|
||||
$self->create_database;
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
$self->dbi_end;
|
||||
$self->{pbot}->{commands}->unregister('actiontrigger');
|
||||
$self->{pbot}->{capabilities}->remove('can-actiontrigger');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.caction');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.join');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.part');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.quit');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.kick');
|
||||
my $self = shift;
|
||||
$self->dbi_end;
|
||||
$self->{pbot}->{commands}->unregister('actiontrigger');
|
||||
$self->{pbot}->{capabilities}->remove('can-actiontrigger');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.caction');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.join');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.part');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.quit');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.kick');
|
||||
}
|
||||
|
||||
sub create_database {
|
||||
my $self = shift;
|
||||
return if not $self->{dbh};
|
||||
my $self = shift;
|
||||
return if not $self->{dbh};
|
||||
|
||||
eval {
|
||||
$self->{dbh}->do(<<SQL);
|
||||
eval {
|
||||
$self->{dbh}->do(<<SQL);
|
||||
CREATE TABLE IF NOT EXISTS Triggers (
|
||||
channel TEXT,
|
||||
trigger TEXT,
|
||||
|
|
@ -84,350 +84,331 @@ CREATE TABLE IF NOT EXISTS Triggers (
|
|||
lastused NUMERIC
|
||||
)
|
||||
SQL
|
||||
};
|
||||
};
|
||||
|
||||
$self->{pbot}->{logger}->log("ActionTrigger create database failed: $@") if $@;
|
||||
$self->{pbot}->{logger}->log("ActionTrigger create database failed: $@") if $@;
|
||||
}
|
||||
|
||||
sub dbi_begin {
|
||||
my ($self) = @_;
|
||||
eval {
|
||||
$self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", { RaiseError => 1, PrintError => 0, AutoInactiveDestroy => 1, sqlite_unicode => 1 }) or die $DBI::errstr;
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Error opening ActionTrigger database: $@");
|
||||
return 0;
|
||||
} else {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub dbi_end {
|
||||
my ($self) = @_;
|
||||
return if not $self->{dbh};
|
||||
$self->{dbh}->disconnect;
|
||||
delete $self->{dbh};
|
||||
}
|
||||
|
||||
sub add_trigger {
|
||||
my ($self, $channel, $trigger, $action, $owner, $level, $repeatdelay) = @_;
|
||||
|
||||
return 0 if $self->get_trigger($channel, $trigger);
|
||||
|
||||
eval {
|
||||
my $sth = $self->{dbh}->prepare('INSERT INTO Triggers (channel, trigger, action, owner, level, repeatdelay, lastused) VALUES (?, ?, ?, ?, ?, ?, 0)');
|
||||
$sth->execute(lc $channel, $trigger, $action, $owner, $level, $repeatdelay);
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Add trigger failed: $@");
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub delete_trigger {
|
||||
my ($self, $channel, $trigger) = @_;
|
||||
return 0 if not $self->get_trigger($channel, $trigger);
|
||||
my $sth = $self->{dbh}->prepare('DELETE FROM Triggers WHERE channel = ? AND trigger = ?');
|
||||
$sth->execute(lc $channel, $trigger);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub list_triggers {
|
||||
my ($self, $channel) = @_;
|
||||
|
||||
my $triggers = eval {
|
||||
my $sth;
|
||||
|
||||
if ($channel eq '*') {
|
||||
$sth = $self->{dbh}->prepare('SELECT * FROM Triggers WHERE channel != ?');
|
||||
$channel = 'global';
|
||||
} else {
|
||||
$sth = $self->{dbh}->prepare('SELECT * FROM Triggers WHERE channel = ?');
|
||||
}
|
||||
$sth->execute(lc $channel);
|
||||
return $sth->fetchall_arrayref({});
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("List triggers failed: $@");
|
||||
}
|
||||
|
||||
$triggers = [] if not defined $triggers;
|
||||
return @$triggers;
|
||||
}
|
||||
|
||||
sub update_trigger {
|
||||
my ($self, $channel, $trigger, $data) = @_;
|
||||
|
||||
eval {
|
||||
my $sql = 'UPDATE Triggers SET ';
|
||||
|
||||
my $comma = '';
|
||||
foreach my $key (keys %$data) {
|
||||
$sql .= "$comma$key = ?";
|
||||
$comma = ", ";
|
||||
}
|
||||
|
||||
$sql .= "WHERE trigger = ? AND channel = ?";
|
||||
my $sth = $self->{dbh}->prepare($sql);
|
||||
my $param = 1;
|
||||
foreach my $key (keys %$data) {
|
||||
$sth->bind_param($param++, $data->{$key});
|
||||
}
|
||||
|
||||
$sth->bind_param($param++, $trigger);
|
||||
$sth->bind_param($param, $channel);
|
||||
$sth->execute();
|
||||
};
|
||||
|
||||
$self->{pbot}->{logger}->log("Update trigger $channel/$trigger failed: $@\n") if $@;
|
||||
}
|
||||
|
||||
sub get_trigger {
|
||||
my ($self, $channel, $trigger) = @_;
|
||||
|
||||
my $row = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * FROM Triggers WHERE channel = ? AND trigger = ?');
|
||||
$sth->execute(lc $channel, $trigger);
|
||||
my $row = $sth->fetchrow_hashref();
|
||||
return $row;
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Get trigger failed: $@");
|
||||
return undef;
|
||||
}
|
||||
|
||||
return $row;
|
||||
}
|
||||
|
||||
sub on_kick {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host);
|
||||
my ($victim, $reason) = ($event->{event}->to, $event->{event}->{args}[1]);
|
||||
my $channel = $event->{event}->{args}[0];
|
||||
return 0 if $event->{interpreted};
|
||||
$self->check_trigger($nick, $user, $host, $channel, "KICK $victim $reason");
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_action {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = $event->{event}->{to}[0];
|
||||
return 0 if $event->{interpreted};
|
||||
$msg =~ s/^\/me\s+//;
|
||||
$self->check_trigger($nick, $user, $host, $channel, "ACTION $msg");
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_public {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = $event->{event}->{to}[0];
|
||||
return 0 if $event->{interpreted};
|
||||
$self->check_trigger($nick, $user, $host, $channel, "PRIVMSG $msg");
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_join {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $channel, $args) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to, $event->{event}->args);
|
||||
$channel = lc $channel;
|
||||
$self->check_trigger($nick, $user, $host, $channel, "JOIN");
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_departure {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $channel, $args) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to, $event->{event}->args);
|
||||
$channel = lc $channel;
|
||||
$self->check_trigger($nick, $user, $host, $channel, (uc $event->{event}->type) . " $args");
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub check_trigger {
|
||||
my ($self, $nick, $user, $host, $channel, $text) = @_;
|
||||
return 0 if not $self->{dbh};
|
||||
|
||||
my @triggers = $self->list_triggers($channel);
|
||||
my @globals = $self->list_triggers('global');
|
||||
push @triggers, @globals;
|
||||
|
||||
$text = "$nick!$user\@$host $text";
|
||||
my $now = gettimeofday;
|
||||
|
||||
foreach my $trigger (@triggers) {
|
||||
my ($self) = @_;
|
||||
eval {
|
||||
$trigger->{lastused} = 0 if not defined $trigger->{lastused};
|
||||
$trigger->{repeatdelay} = 0 if not defined $trigger->{repeatdelay};
|
||||
if ($now - $trigger->{lastused} >= $trigger->{repeatdelay} and $text =~ m/$trigger->{trigger}/) {
|
||||
$trigger->{lastused} = $now;
|
||||
my $data = { lastused => $now };
|
||||
$self->update_trigger($trigger->{channel}, $trigger->{trigger}, $data);
|
||||
|
||||
my $action = $trigger->{action};
|
||||
my @stuff = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
|
||||
my $i;
|
||||
map { ++$i; $action =~ s/\$$i/$_/g; } @stuff;
|
||||
|
||||
my $delay = 0;
|
||||
|
||||
my ($n, $u, $h) = $trigger->{owner} =~ /^([^!]+)!([^@]+)\@(.*)$/;
|
||||
my $command = {
|
||||
nick => $n,
|
||||
user => $u,
|
||||
host => $h,
|
||||
command => $action,
|
||||
level => $trigger->{level} // 0
|
||||
};
|
||||
$self->{pbot}->{logger}->log("ActionTrigger: ($channel) $trigger->{trigger} -> $action [$command->{level}]\n");
|
||||
$self->{pbot}->{interpreter}->add_to_command_queue($channel, $command, $delay);
|
||||
}
|
||||
$self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", {RaiseError => 1, PrintError => 0, AutoInactiveDestroy => 1, sqlite_unicode => 1})
|
||||
or die $DBI::errstr;
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Skipping bad trigger $trigger->{trigger}: $@");
|
||||
$self->{pbot}->{logger}->log("Error opening ActionTrigger database: $@");
|
||||
return 0;
|
||||
} else {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub dbi_end {
|
||||
my ($self) = @_;
|
||||
return if not $self->{dbh};
|
||||
$self->{dbh}->disconnect;
|
||||
delete $self->{dbh};
|
||||
}
|
||||
|
||||
sub add_trigger {
|
||||
my ($self, $channel, $trigger, $action, $owner, $level, $repeatdelay) = @_;
|
||||
|
||||
return 0 if $self->get_trigger($channel, $trigger);
|
||||
|
||||
eval {
|
||||
my $sth = $self->{dbh}->prepare('INSERT INTO Triggers (channel, trigger, action, owner, level, repeatdelay, lastused) VALUES (?, ?, ?, ?, ?, ?, 0)');
|
||||
$sth->execute(lc $channel, $trigger, $action, $owner, $level, $repeatdelay);
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Add trigger failed: $@");
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub delete_trigger {
|
||||
my ($self, $channel, $trigger) = @_;
|
||||
return 0 if not $self->get_trigger($channel, $trigger);
|
||||
my $sth = $self->{dbh}->prepare('DELETE FROM Triggers WHERE channel = ? AND trigger = ?');
|
||||
$sth->execute(lc $channel, $trigger);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub list_triggers {
|
||||
my ($self, $channel) = @_;
|
||||
|
||||
my $triggers = eval {
|
||||
my $sth;
|
||||
|
||||
if ($channel eq '*') {
|
||||
$sth = $self->{dbh}->prepare('SELECT * FROM Triggers WHERE channel != ?');
|
||||
$channel = 'global';
|
||||
} else {
|
||||
$sth = $self->{dbh}->prepare('SELECT * FROM Triggers WHERE channel = ?');
|
||||
}
|
||||
$sth->execute(lc $channel);
|
||||
return $sth->fetchall_arrayref({});
|
||||
};
|
||||
|
||||
if ($@) { $self->{pbot}->{logger}->log("List triggers failed: $@"); }
|
||||
|
||||
$triggers = [] if not defined $triggers;
|
||||
return @$triggers;
|
||||
}
|
||||
|
||||
sub update_trigger {
|
||||
my ($self, $channel, $trigger, $data) = @_;
|
||||
|
||||
eval {
|
||||
my $sql = 'UPDATE Triggers SET ';
|
||||
|
||||
my $comma = '';
|
||||
foreach my $key (keys %$data) {
|
||||
$sql .= "$comma$key = ?";
|
||||
$comma = ", ";
|
||||
}
|
||||
|
||||
$sql .= "WHERE trigger = ? AND channel = ?";
|
||||
my $sth = $self->{dbh}->prepare($sql);
|
||||
my $param = 1;
|
||||
foreach my $key (keys %$data) { $sth->bind_param($param++, $data->{$key}); }
|
||||
|
||||
$sth->bind_param($param++, $trigger);
|
||||
$sth->bind_param($param, $channel);
|
||||
$sth->execute();
|
||||
};
|
||||
|
||||
$self->{pbot}->{logger}->log("Update trigger $channel/$trigger failed: $@\n") if $@;
|
||||
}
|
||||
|
||||
sub get_trigger {
|
||||
my ($self, $channel, $trigger) = @_;
|
||||
|
||||
my $row = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * FROM Triggers WHERE channel = ? AND trigger = ?');
|
||||
$sth->execute(lc $channel, $trigger);
|
||||
my $row = $sth->fetchrow_hashref();
|
||||
return $row;
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Get trigger failed: $@");
|
||||
return undef;
|
||||
}
|
||||
|
||||
return $row;
|
||||
}
|
||||
|
||||
sub on_kick {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host);
|
||||
my ($victim, $reason) = ($event->{event}->to, $event->{event}->{args}[1]);
|
||||
my $channel = $event->{event}->{args}[0];
|
||||
return 0 if $event->{interpreted};
|
||||
$self->check_trigger($nick, $user, $host, $channel, "KICK $victim $reason");
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_action {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = $event->{event}->{to}[0];
|
||||
return 0 if $event->{interpreted};
|
||||
$msg =~ s/^\/me\s+//;
|
||||
$self->check_trigger($nick, $user, $host, $channel, "ACTION $msg");
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_public {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = $event->{event}->{to}[0];
|
||||
return 0 if $event->{interpreted};
|
||||
$self->check_trigger($nick, $user, $host, $channel, "PRIVMSG $msg");
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_join {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $channel, $args) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to, $event->{event}->args);
|
||||
$channel = lc $channel;
|
||||
$self->check_trigger($nick, $user, $host, $channel, "JOIN");
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_departure {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $channel, $args) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to, $event->{event}->args);
|
||||
$channel = lc $channel;
|
||||
$self->check_trigger($nick, $user, $host, $channel, (uc $event->{event}->type) . " $args");
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub check_trigger {
|
||||
my ($self, $nick, $user, $host, $channel, $text) = @_;
|
||||
return 0 if not $self->{dbh};
|
||||
|
||||
my @triggers = $self->list_triggers($channel);
|
||||
my @globals = $self->list_triggers('global');
|
||||
push @triggers, @globals;
|
||||
|
||||
$text = "$nick!$user\@$host $text";
|
||||
my $now = gettimeofday;
|
||||
|
||||
foreach my $trigger (@triggers) {
|
||||
eval {
|
||||
$trigger->{lastused} = 0 if not defined $trigger->{lastused};
|
||||
$trigger->{repeatdelay} = 0 if not defined $trigger->{repeatdelay};
|
||||
if ($now - $trigger->{lastused} >= $trigger->{repeatdelay} and $text =~ m/$trigger->{trigger}/) {
|
||||
$trigger->{lastused} = $now;
|
||||
my $data = {lastused => $now};
|
||||
$self->update_trigger($trigger->{channel}, $trigger->{trigger}, $data);
|
||||
|
||||
my $action = $trigger->{action};
|
||||
my @stuff = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
|
||||
my $i;
|
||||
map { ++$i; $action =~ s/\$$i/$_/g; } @stuff;
|
||||
|
||||
my $delay = 0;
|
||||
|
||||
my ($n, $u, $h) = $trigger->{owner} =~ /^([^!]+)!([^@]+)\@(.*)$/;
|
||||
my $command = {
|
||||
nick => $n,
|
||||
user => $u,
|
||||
host => $h,
|
||||
command => $action,
|
||||
level => $trigger->{level} // 0
|
||||
};
|
||||
$self->{pbot}->{logger}->log("ActionTrigger: ($channel) $trigger->{trigger} -> $action [$command->{level}]\n");
|
||||
$self->{pbot}->{interpreter}->add_to_command_queue($channel, $command, $delay);
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) { $self->{pbot}->{logger}->log("Skipping bad trigger $trigger->{trigger}: $@"); }
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub actiontrigger {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
return "Internal error." if not $self->{dbh};
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
return "Internal error." if not $self->{dbh};
|
||||
|
||||
my $command = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
my $result;
|
||||
given ($command) {
|
||||
when ('list') {
|
||||
my $channel = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
if (not defined $channel) {
|
||||
if ($from !~ /^#/) {
|
||||
$channel = 'global';
|
||||
} else {
|
||||
$channel = $from;
|
||||
my $command = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
my $result;
|
||||
given ($command) {
|
||||
when ('list') {
|
||||
my $channel = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
if (not defined $channel) {
|
||||
if ($from !~ /^#/) { $channel = 'global'; }
|
||||
else { $channel = $from; }
|
||||
} elsif ($channel !~ m/^#/ and $channel ne 'global') {
|
||||
return "Invalid channel $channel. Usage: actiontrigger list [#channel or global]";
|
||||
}
|
||||
|
||||
my @triggers = $self->list_triggers($channel);
|
||||
|
||||
if (not @triggers) { $result = "No action triggers set for $channel."; }
|
||||
else {
|
||||
$result = "Triggers for $channel:\n";
|
||||
my $comma = '';
|
||||
foreach my $trigger (@triggers) {
|
||||
$trigger->{level} //= 0;
|
||||
$trigger->{repeatdelay} //= 0;
|
||||
$result .= "$comma$trigger->{trigger} -> $trigger->{action}";
|
||||
$result .= " (level=$trigger->{level})" if $trigger->{level} != 0;
|
||||
$result .= " (repeatdelay=$trigger->{repeatdelay})" if $trigger->{repeatdelay} != 0;
|
||||
$comma = ",\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
} elsif ($channel !~ m/^#/ and $channel ne 'global') {
|
||||
return "Invalid channel $channel. Usage: actiontrigger list [#channel or global]";
|
||||
}
|
||||
|
||||
my @triggers = $self->list_triggers($channel);
|
||||
# TODO: use GetOpt flags instead of positional arguments
|
||||
when ('add') {
|
||||
my $channel;
|
||||
if ($from =~ m/^#/) { $channel = $from; }
|
||||
else {
|
||||
$channel = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
|
||||
if (not @triggers) {
|
||||
$result = "No action triggers set for $channel.";
|
||||
} else {
|
||||
$result = "Triggers for $channel:\n";
|
||||
my $comma = '';
|
||||
foreach my $trigger (@triggers) {
|
||||
$trigger->{level} //= 0;
|
||||
$trigger->{repeatdelay} //= 0;
|
||||
$result .= "$comma$trigger->{trigger} -> $trigger->{action}";
|
||||
$result .= " (level=$trigger->{level})" if $trigger->{level} != 0;
|
||||
$result .= " (repeatdelay=$trigger->{repeatdelay})" if $trigger->{repeatdelay} != 0;
|
||||
$comma = ",\n";
|
||||
if (not defined $channel) {
|
||||
return
|
||||
"To use this command from private message the <channel> argument is required. Usage: actiontrigger add <#channel or global> <level> <repeat delay (in seconds)> <regex trigger> <command>";
|
||||
} elsif ($channel !~ m/^#/ and $channel ne 'global') {
|
||||
return "Invalid channel $channel. Usage: actiontrigger add <#channel or global> <level> <repeat delay (in seconds)> <regex trigger> <command>";
|
||||
}
|
||||
}
|
||||
|
||||
my ($level, $repeatdelay, $trigger, $action) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 4, 0, 1);
|
||||
|
||||
if (not defined $trigger or not defined $action) {
|
||||
if ($from !~ m/^#/) {
|
||||
$result =
|
||||
"To use this command from private message the <channel> argument is required. Usage: actiontrigger add <#channel or global> <level> <repeat delay (in seconds)> <regex trigger> <command>";
|
||||
} else {
|
||||
$result = "Usage: actiontrigger add <level> <repeat delay (in seconds)> <regex trigger> <command>";
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
my $exists = $self->get_trigger($channel, $trigger);
|
||||
|
||||
if (defined $exists) { return "Trigger already exists."; }
|
||||
|
||||
if ($level !~ m/^\d+$/) { return "$nick: Missing level argument?\n"; }
|
||||
|
||||
if ($repeatdelay !~ m/^\d+$/) { return "$nick: Missing repeat delay argument?\n"; }
|
||||
|
||||
if ($level > 0) {
|
||||
my $admin = $self->{pbot}->{users}->find_admin($channel, "$nick!$user\@$host");
|
||||
if (not defined $admin or $level > $admin->{level}) { return "You may not set a level higher than your own."; }
|
||||
}
|
||||
|
||||
if ($self->add_trigger($channel, $trigger, $action, "$nick!$user\@$host", $level, $repeatdelay)) { $result = "Trigger added."; }
|
||||
else { $result = "Failed to add trigger."; }
|
||||
}
|
||||
|
||||
when ('delete') {
|
||||
my $channel;
|
||||
if ($from =~ m/^#/) { $channel = $from; }
|
||||
else {
|
||||
$channel = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
if ($channel !~ m/^#/ and $channel ne 'global') {
|
||||
return "To use this command from private message the <channel> argument is required. Usage: actiontrigger delete <#channel or global> <regex trigger>";
|
||||
}
|
||||
}
|
||||
|
||||
my ($trigger) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 1);
|
||||
|
||||
if (not defined $trigger) {
|
||||
if ($from !~ m/^#/) {
|
||||
$result = "To use this command from private message the <channel> argument is required. Usage: from private message: actiontrigger delete <channel> <regex trigger>";
|
||||
} else {
|
||||
$result = "Usage: actiontrigger delete <regex trigger>";
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
my $exists = $self->get_trigger($channel, $trigger);
|
||||
|
||||
if (not defined $exists) { $result = "No such trigger."; }
|
||||
else {
|
||||
$self->delete_trigger($channel, $trigger);
|
||||
$result = "Trigger deleted.";
|
||||
}
|
||||
}
|
||||
|
||||
default {
|
||||
if ($from !~ m/^#/) {
|
||||
$result =
|
||||
"Usage from private message: actiontrigger list [#channel or global] | actiontrigger add <#channel or global> <level> <repeat delay (in seconds)> <regex trigger> <command> | actiontrigger delete <#channel or global> <regex trigger>";
|
||||
} else {
|
||||
$result =
|
||||
"Usage: actiontrigger list [#channel or global] | actiontrigger add <level> <repeat delay (in seconds)> <regex trigger> <command> | actiontrigger delete <regex>";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# TODO: use GetOpt flags instead of positional arguments
|
||||
when ('add') {
|
||||
my $channel;
|
||||
if ($from =~ m/^#/) {
|
||||
$channel = $from;
|
||||
} else {
|
||||
$channel = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
|
||||
if (not defined $channel) {
|
||||
return "To use this command from private message the <channel> argument is required. Usage: actiontrigger add <#channel or global> <level> <repeat delay (in seconds)> <regex trigger> <command>";
|
||||
} elsif ($channel !~ m/^#/ and $channel ne 'global') {
|
||||
return "Invalid channel $channel. Usage: actiontrigger add <#channel or global> <level> <repeat delay (in seconds)> <regex trigger> <command>";
|
||||
}
|
||||
}
|
||||
|
||||
my ($level, $repeatdelay, $trigger, $action) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 4, 0, 1);
|
||||
|
||||
if (not defined $trigger or not defined $action) {
|
||||
if ($from !~ m/^#/) {
|
||||
$result = "To use this command from private message the <channel> argument is required. Usage: actiontrigger add <#channel or global> <level> <repeat delay (in seconds)> <regex trigger> <command>";
|
||||
} else {
|
||||
$result = "Usage: actiontrigger add <level> <repeat delay (in seconds)> <regex trigger> <command>";
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
my $exists = $self->get_trigger($channel, $trigger);
|
||||
|
||||
if (defined $exists) {
|
||||
return "Trigger already exists.";
|
||||
}
|
||||
|
||||
if ($level !~ m/^\d+$/) {
|
||||
return "$nick: Missing level argument?\n";
|
||||
}
|
||||
|
||||
if ($repeatdelay !~ m/^\d+$/) {
|
||||
return "$nick: Missing repeat delay argument?\n";
|
||||
}
|
||||
|
||||
if ($level > 0) {
|
||||
my $admin = $self->{pbot}->{users}->find_admin($channel, "$nick!$user\@$host");
|
||||
if (not defined $admin or $level > $admin->{level}) {
|
||||
return "You may not set a level higher than your own.";
|
||||
}
|
||||
}
|
||||
|
||||
if ($self->add_trigger($channel, $trigger, $action, "$nick!$user\@$host", $level, $repeatdelay)) {
|
||||
$result = "Trigger added.";
|
||||
} else {
|
||||
$result = "Failed to add trigger.";
|
||||
}
|
||||
}
|
||||
|
||||
when ('delete') {
|
||||
my $channel;
|
||||
if ($from =~ m/^#/) {
|
||||
$channel = $from;
|
||||
} else {
|
||||
$channel = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
if ($channel !~ m/^#/ and $channel ne 'global') {
|
||||
return "To use this command from private message the <channel> argument is required. Usage: actiontrigger delete <#channel or global> <regex trigger>";
|
||||
}
|
||||
}
|
||||
|
||||
my ($trigger) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 1);
|
||||
|
||||
if (not defined $trigger) {
|
||||
if ($from !~ m/^#/) {
|
||||
$result = "To use this command from private message the <channel> argument is required. Usage: from private message: actiontrigger delete <channel> <regex trigger>";
|
||||
} else {
|
||||
$result = "Usage: actiontrigger delete <regex trigger>";
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
my $exists = $self->get_trigger($channel, $trigger);
|
||||
|
||||
if (not defined $exists) {
|
||||
$result = "No such trigger.";
|
||||
} else {
|
||||
$self->delete_trigger($channel, $trigger);
|
||||
$result = "Trigger deleted.";
|
||||
}
|
||||
}
|
||||
|
||||
default {
|
||||
if ($from !~ m/^#/) {
|
||||
$result = "Usage from private message: actiontrigger list [#channel or global] | actiontrigger add <#channel or global> <level> <repeat delay (in seconds)> <regex trigger> <command> | actiontrigger delete <#channel or global> <regex trigger>";
|
||||
} else {
|
||||
$result = "Usage: actiontrigger list [#channel or global] | actiontrigger add <level> <repeat delay (in seconds)> <regex trigger> <command> | actiontrigger delete <regex>";
|
||||
}
|
||||
}
|
||||
}
|
||||
return $result;
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -14,61 +14,62 @@ use warnings; use strict;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiaway', 'bad_nicks', $conf{bad_nicks} // '([[:punct:]](afk|brb|bbl|away|sleep|z+|work|gone|study|out|home|busy|off)[[:punct:]]*$|.+\[.*\]$)');
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiaway', 'bad_actions', $conf{bad_actions} // '^/me (is (away|gone)|.*auto.?away)');
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiaway', 'kick_msg', 'http://sackheads.org/~bnaylor/spew/away_msgs.html');
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}
|
||||
->add_default('text', 'antiaway', 'bad_nicks', $conf{bad_nicks} // '([[:punct:]](afk|brb|bbl|away|sleep|z+|work|gone|study|out|home|busy|off)[[:punct:]]*$|.+\[.*\]$)');
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiaway', 'bad_actions', $conf{bad_actions} // '^/me (is (away|gone)|.*auto.?away)');
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiaway', 'kick_msg', 'http://sackheads.org/~bnaylor/spew/away_msgs.html');
|
||||
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.nick', sub { $self->on_nickchange(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->on_action(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.nick', sub { $self->on_nickchange(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->on_action(@_) });
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.nick');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.caction');
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.nick');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.caction');
|
||||
}
|
||||
|
||||
sub on_nickchange {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $newnick) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $newnick) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
|
||||
my $bad_nicks = $self->{pbot}->{registry}->get_value('antiaway', 'bad_nicks');
|
||||
if ($newnick =~ m/$bad_nicks/i) {
|
||||
my $kick_msg = $self->{pbot}->{registry}->get_value('antiaway', 'kick_msg');
|
||||
my $channels = $self->{pbot}->{nicklist}->get_channels($newnick);
|
||||
foreach my $chan (@$channels) {
|
||||
next if not $self->{pbot}->{chanops}->can_gain_ops($chan);
|
||||
my $bad_nicks = $self->{pbot}->{registry}->get_value('antiaway', 'bad_nicks');
|
||||
if ($newnick =~ m/$bad_nicks/i) {
|
||||
my $kick_msg = $self->{pbot}->{registry}->get_value('antiaway', 'kick_msg');
|
||||
my $channels = $self->{pbot}->{nicklist}->get_channels($newnick);
|
||||
foreach my $chan (@$channels) {
|
||||
next if not $self->{pbot}->{chanops}->can_gain_ops($chan);
|
||||
|
||||
my $u = $self->{pbot}->{users}->loggedin($chan, "$nick!$user\@$host");
|
||||
next if $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted');
|
||||
my $u = $self->{pbot}->{users}->loggedin($chan, "$nick!$user\@$host");
|
||||
next if $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted');
|
||||
|
||||
$self->{pbot}->{logger}->log("$newnick matches bad away nick regex, kicking from $chan\n");
|
||||
$self->{pbot}->{chanops}->add_op_command($chan, "kick $chan $newnick $kick_msg");
|
||||
$self->{pbot}->{chanops}->gain_ops($chan);
|
||||
$self->{pbot}->{logger}->log("$newnick matches bad away nick regex, kicking from $chan\n");
|
||||
$self->{pbot}->{chanops}->add_op_command($chan, "kick $chan $newnick $kick_msg");
|
||||
$self->{pbot}->{chanops}->gain_ops($chan);
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_action {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->{args}[0], $event->{event}->{to}[0]);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->{args}[0], $event->{event}->{to}[0]);
|
||||
|
||||
return 0 if $channel !~ /^#/;
|
||||
return 0 if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
return 0 if $channel !~ /^#/;
|
||||
return 0 if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
|
||||
my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host");
|
||||
return 0 if $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted');
|
||||
my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host");
|
||||
return 0 if $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted');
|
||||
|
||||
my $bad_actions = $self->{pbot}->{registry}->get_value('antiaway', 'bad_actions');
|
||||
if ($msg =~ m/$bad_actions/i) {
|
||||
$self->{pbot}->{logger}->log("$nick $msg matches bad away actions regex, kicking...\n");
|
||||
my $kick_msg = $self->{pbot}->{registry}->get_value('antiaway', 'kick_msg');
|
||||
$self->{pbot}->{chanops}->add_op_command($channel, "kick $channel $nick $kick_msg");
|
||||
$self->{pbot}->{chanops}->gain_ops($channel);
|
||||
}
|
||||
return 0;
|
||||
my $bad_actions = $self->{pbot}->{registry}->get_value('antiaway', 'bad_actions');
|
||||
if ($msg =~ m/$bad_actions/i) {
|
||||
$self->{pbot}->{logger}->log("$nick $msg matches bad away actions regex, kicking...\n");
|
||||
my $kick_msg = $self->{pbot}->{registry}->get_value('antiaway', 'kick_msg');
|
||||
$self->{pbot}->{chanops}->add_op_command($channel, "kick $channel $nick $kick_msg");
|
||||
$self->{pbot}->{chanops}->gain_ops($channel);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package Plugins::AntiKickAutoRejoin;
|
||||
|
||||
use parent 'Plugins::Plugin';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -17,63 +18,60 @@ use Time::HiRes qw/gettimeofday/;
|
|||
use Time::Duration;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('array', 'antikickautorejoin', 'punishment', '30,90,180,300,28800');
|
||||
$self->{pbot}->{registry}->add_default('text', 'antikickautorejoin', 'threshold', '2');
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('array', 'antikickautorejoin', 'punishment', '30,90,180,300,28800');
|
||||
$self->{pbot}->{registry}->add_default('text', 'antikickautorejoin', 'threshold', '2');
|
||||
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.kick', sub { $self->on_kick(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.join', sub { $self->on_join(@_) });
|
||||
$self->{kicks} = {};
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.kick', sub { $self->on_kick(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.join', sub { $self->on_join(@_) });
|
||||
$self->{kicks} = {};
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.kick');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.join');
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.kick');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.join');
|
||||
}
|
||||
|
||||
sub on_kick {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $target, $channel, $reason) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to, $event->{event}->{args}[0], $event->{event}->{args}[1]);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $target, $channel, $reason) =
|
||||
($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to, $event->{event}->{args}[0], $event->{event}->{args}[1]);
|
||||
|
||||
$channel = lc $channel;
|
||||
return 0 if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
return 0 if $reason eq '*BANG!*'; # roulette
|
||||
$channel = lc $channel;
|
||||
return 0 if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
return 0 if $reason eq '*BANG!*'; # roulette
|
||||
|
||||
if (not exists $self->{kicks}->{$channel}
|
||||
or not exists $self->{kicks}->{$channel}->{$target}) {
|
||||
$self->{kicks}->{$channel}->{$target}->{rejoins} = 0;
|
||||
}
|
||||
if (not exists $self->{kicks}->{$channel} or not exists $self->{kicks}->{$channel}->{$target}) { $self->{kicks}->{$channel}->{$target}->{rejoins} = 0; }
|
||||
|
||||
$self->{kicks}->{$channel}->{$target}->{last_kick} = gettimeofday;
|
||||
return 0;
|
||||
$self->{kicks}->{$channel}->{$target}->{last_kick} = gettimeofday;
|
||||
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);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to);
|
||||
|
||||
$channel = lc $channel;
|
||||
return 0 if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host");
|
||||
return 0 if $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted');
|
||||
$channel = lc $channel;
|
||||
return 0 if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host");
|
||||
return 0 if $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted');
|
||||
|
||||
if (exists $self->{kicks}->{$channel}
|
||||
and exists $self->{kicks}->{$channel}->{$nick}) {
|
||||
my $now = gettimeofday;
|
||||
if (exists $self->{kicks}->{$channel} and exists $self->{kicks}->{$channel}->{$nick}) {
|
||||
my $now = gettimeofday;
|
||||
|
||||
if ($now - $self->{kicks}->{$channel}->{$nick}->{last_kick} <= $self->{pbot}->{registry}->get_value('antikickautorejoin', 'threshold')) {
|
||||
my $timeout = $self->{pbot}->{registry}->get_array_value('antikickautorejoin', 'punishment', $self->{kicks}->{$channel}->{$nick}->{rejoins});
|
||||
my $duration = duration($timeout);
|
||||
$duration =~ s/s$//; # hours -> hour, minutes -> minute
|
||||
if ($now - $self->{kicks}->{$channel}->{$nick}->{last_kick} <= $self->{pbot}->{registry}->get_value('antikickautorejoin', 'threshold')) {
|
||||
my $timeout = $self->{pbot}->{registry}->get_array_value('antikickautorejoin', 'punishment', $self->{kicks}->{$channel}->{$nick}->{rejoins});
|
||||
my $duration = duration($timeout);
|
||||
$duration =~ s/s$//; # hours -> hour, minutes -> minute
|
||||
|
||||
$self->{pbot}->{chanops}->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'autorejoining after kick', "*!$user\@$host", $channel, $timeout);
|
||||
$self->{pbot}->{chanops}->add_op_command($channel, "kick $channel $nick $duration ban for auto-rejoining after kick; use this time to think about why you were kicked");
|
||||
$self->{pbot}->{chanops}->gain_ops($channel);
|
||||
$self->{kicks}->{$channel}->{$nick}->{rejoins}++;
|
||||
$self->{pbot}->{chanops}->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'autorejoining after kick', "*!$user\@$host", $channel, $timeout);
|
||||
$self->{pbot}->{chanops}->add_op_command($channel, "kick $channel $nick $duration ban for auto-rejoining after kick; use this time to think about why you were kicked");
|
||||
$self->{pbot}->{chanops}->gain_ops($channel);
|
||||
$self->{kicks}->{$channel}->{$nick}->{rejoins}++;
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package Plugins::AntiNickSpam;
|
||||
|
||||
use parent 'Plugins::Plugin';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -18,73 +19,70 @@ use Time::Duration qw/duration/;
|
|||
use Time::HiRes qw/gettimeofday/;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->on_action(@_) });
|
||||
$self->{nicks} = {};
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->on_action(@_) });
|
||||
$self->{nicks} = {};
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.caction');
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.caction');
|
||||
}
|
||||
|
||||
sub on_action {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = $event->{event}->{to}[0];
|
||||
return 0 if $event->{interpreted};
|
||||
$self->check_flood($nick, $user, $host, $channel, $msg);
|
||||
return 0;
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = $event->{event}->{to}[0];
|
||||
return 0 if $event->{interpreted};
|
||||
$self->check_flood($nick, $user, $host, $channel, $msg);
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub on_public {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = $event->{event}->{to}[0];
|
||||
return 0 if $event->{interpreted};
|
||||
$self->check_flood($nick, $user, $host, $channel, $msg);
|
||||
return 0;
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = $event->{event}->{to}[0];
|
||||
return 0 if $event->{interpreted};
|
||||
$self->check_flood($nick, $user, $host, $channel, $msg);
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub check_flood {
|
||||
my ($self, $nick, $user, $host, $channel, $msg) = @_;
|
||||
return 0 if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
my ($self, $nick, $user, $host, $channel, $msg) = @_;
|
||||
return 0 if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
|
||||
$channel = lc $channel;
|
||||
my @words = split /\s+/, $msg;
|
||||
my @nicks;
|
||||
$channel = lc $channel;
|
||||
my @words = split /\s+/, $msg;
|
||||
my @nicks;
|
||||
|
||||
foreach my $word (@words) {
|
||||
$word =~ s/[:;\+,\.!?\@\%\$]+$//g;
|
||||
if ($self->{pbot}->{nicklist}->is_present($channel, $word) and not grep { $_ eq $word } @nicks) {
|
||||
push @{$self->{nicks}->{$channel}}, [scalar gettimeofday, $word];
|
||||
push @nicks, $word;
|
||||
foreach my $word (@words) {
|
||||
$word =~ s/[:;\+,\.!?\@\%\$]+$//g;
|
||||
if ($self->{pbot}->{nicklist}->is_present($channel, $word) and not grep { $_ eq $word } @nicks) {
|
||||
push @{$self->{nicks}->{$channel}}, [scalar gettimeofday, $word];
|
||||
push @nicks, $word;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$self->clear_old_nicks($channel);
|
||||
$self->clear_old_nicks($channel);
|
||||
|
||||
if (exists $self->{nicks}->{$channel} and @{$self->{nicks}->{$channel}} >= 10) {
|
||||
$self->{pbot}->{logger}->log("Nick spam flood detected in $channel\n");
|
||||
$self->{pbot}->{chanops}->mute_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'nick spam flooding', '$~a', $channel, 60 * 15);
|
||||
}
|
||||
if (exists $self->{nicks}->{$channel} and @{$self->{nicks}->{$channel}} >= 10) {
|
||||
$self->{pbot}->{logger}->log("Nick spam flood detected in $channel\n");
|
||||
$self->{pbot}->{chanops}->mute_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'nick spam flooding', '$~a', $channel, 60 * 15);
|
||||
}
|
||||
}
|
||||
|
||||
sub clear_old_nicks {
|
||||
my ($self, $channel) = @_;
|
||||
my $now = gettimeofday;
|
||||
return if not exists $self->{nicks}->{$channel};
|
||||
my ($self, $channel) = @_;
|
||||
my $now = gettimeofday;
|
||||
return if not exists $self->{nicks}->{$channel};
|
||||
|
||||
while (1) {
|
||||
if (@{$self->{nicks}->{$channel}} and $self->{nicks}->{$channel}->[0]->[0] <= $now - 15) {
|
||||
shift @{$self->{nicks}->{$channel}};
|
||||
} else {
|
||||
last;
|
||||
while (1) {
|
||||
if (@{$self->{nicks}->{$channel}} and $self->{nicks}->{$channel}->[0]->[0] <= $now - 15) { shift @{$self->{nicks}->{$channel}}; }
|
||||
else { last; }
|
||||
}
|
||||
}
|
||||
delete $self->{nicks}->{$channel} if not @{$self->{nicks}->{$channel}};
|
||||
delete $self->{nicks}->{$channel} if not @{$self->{nicks}->{$channel}};
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -16,157 +16,143 @@ use Time::HiRes qw/gettimeofday/;
|
|||
use POSIX qw/strftime/;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiflood', 'antirepeat', $conf{antirepeat} // 1);
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiflood', 'antirepeat_threshold', $conf{antirepeat_threshold} // 2.5);
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiflood', 'antirepeat_match', $conf{antirepeat_match} // 0.5);
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiflood', 'antirepeat_allow_bot', $conf{antirepeat_allow_bot} // 1);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiflood', 'antirepeat', $conf{antirepeat} // 1);
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiflood', 'antirepeat_threshold', $conf{antirepeat_threshold} // 2.5);
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiflood', 'antirepeat_match', $conf{antirepeat_match} // 0.5);
|
||||
$self->{pbot}->{registry}->add_default('text', 'antiflood', 'antirepeat_allow_bot', $conf{antirepeat_allow_bot} // 1);
|
||||
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->on_public(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->on_public(@_) });
|
||||
|
||||
$self->{pbot}->{timer}->register(sub { $self->adjust_offenses }, 60 * 60 * 1, 'antirepeat');
|
||||
$self->{offenses} = {};
|
||||
$self->{pbot}->{timer}->register(sub { $self->adjust_offenses }, 60 * 60 * 1, 'antirepeat');
|
||||
$self->{offenses} = {};
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
$self->{pbot}->{timer}->unregister('antirepeat');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.caction');
|
||||
my $self = shift;
|
||||
$self->{pbot}->{timer}->unregister('antirepeat');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.caction');
|
||||
}
|
||||
|
||||
sub on_public {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = lc $event->{event}->{to}[0];
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = lc $event->{event}->{to}[0];
|
||||
|
||||
($nick, $user, $host) = $self->{pbot}->{irchandlers}->normalize_hostmask($nick, $user, $host);
|
||||
($nick, $user, $host) = $self->{pbot}->{irchandlers}->normalize_hostmask($nick, $user, $host);
|
||||
|
||||
return 0 if not $self->{pbot}->{registry}->get_value('antiflood', 'antirepeat');
|
||||
return 0 if not $self->{pbot}->{registry}->get_value('antiflood', 'antirepeat');
|
||||
|
||||
my $antirepeat = $self->{pbot}->{registry}->get_value($channel, 'antirepeat');
|
||||
return 0 if defined $antirepeat and not $antirepeat;
|
||||
my $antirepeat = $self->{pbot}->{registry}->get_value($channel, 'antirepeat');
|
||||
return 0 if defined $antirepeat and not $antirepeat;
|
||||
|
||||
return 0 if $self->{pbot}->{registry}->get_value($channel, 'dont_enforce_antiflood');
|
||||
return 0 if $self->{pbot}->{registry}->get_value($channel, 'dont_enforce_antiflood');
|
||||
|
||||
return 0 if $channel !~ m/^#/;
|
||||
return 0 if $event->{interpreted};
|
||||
return 0 if $channel !~ m/^#/;
|
||||
return 0 if $event->{interpreted};
|
||||
|
||||
my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host");
|
||||
return 0 if $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted');
|
||||
my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host");
|
||||
return 0 if $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted');
|
||||
|
||||
my $account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
my $account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
|
||||
# don't enforce anti-repeat for unreg spam
|
||||
my $chanmodes = $self->{pbot}->{channels}->get_meta($channel, 'MODE');
|
||||
if (defined $chanmodes and $chanmodes =~ m/z/ and exists $self->{pbot}->{bantracker}->{banlist}->{$channel}->{'+q'}->{'$~a'}) {
|
||||
my $nickserv = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($account);
|
||||
return 0 if not defined $nickserv or not length $nickserv;
|
||||
}
|
||||
|
||||
my $messages = $self->{pbot}->{messagehistory}->{database}->get_recent_messages($account, $channel, 6, $self->{pbot}->{messagehistory}->{MSG_CHAT});
|
||||
|
||||
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
|
||||
|
||||
my $bot_trigger = $self->{pbot}->{registry}->get_value($channel, 'trigger')
|
||||
// $self->{pbot}->{registry}->get_value('general', 'trigger');
|
||||
|
||||
my $allow_bot = $self->{pbot}->{registry}->get_value($channel, 'antirepeat_allow_bot')
|
||||
// $self->{pbot}->{registry}->get_value('antiflood', 'antirepeat_allow_bot');
|
||||
|
||||
my $match = $self->{pbot}->{registry}->get_value($channel, 'antirepeat_match')
|
||||
// $self->{pbot}->{registry}->get_value('antiflood', 'antirepeat_match');
|
||||
|
||||
my %matches;
|
||||
my $now = gettimeofday;
|
||||
|
||||
foreach my $string1 (@$messages) {
|
||||
next if $now - $string1->{timestamp} > 60 * 60 * 2;
|
||||
next if $allow_bot and $string1->{msg} =~ m/^(?:$bot_trigger|$botnick.?)/;
|
||||
$string1->{msg} =~ s/^[^;,:]{1,20}[;,:]//; # remove nick-like prefix if one exists
|
||||
next if length $string1->{msg} <= 5; # allow really short messages since "yep" "ok" etc are so common
|
||||
|
||||
if (exists $self->{offenses}->{$account} and exists $self->{offenses}->{$account}->{$channel}) {
|
||||
next if $self->{offenses}->{$account}->{$channel}->{last_offense} >= $string1->{timestamp};
|
||||
# don't enforce anti-repeat for unreg spam
|
||||
my $chanmodes = $self->{pbot}->{channels}->get_meta($channel, 'MODE');
|
||||
if (defined $chanmodes and $chanmodes =~ m/z/ and exists $self->{pbot}->{bantracker}->{banlist}->{$channel}->{'+q'}->{'$~a'}) {
|
||||
my $nickserv = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($account);
|
||||
return 0 if not defined $nickserv or not length $nickserv;
|
||||
}
|
||||
|
||||
foreach my $string2 (@$messages) {
|
||||
next if $now - $string2->{timestamp} > 60 * 60 * 2;
|
||||
next if $allow_bot and $string2->{msg} =~ m/^(?:$bot_trigger|$botnick.?)/;
|
||||
$string2->{msg} =~ s/^[^;,:]{1,20}[;,:]//; # remove nick-like prefix if one exists
|
||||
next if length $string2->{msg} <= 5; # allow really short messages since "yep" "ok" etc are so common
|
||||
my $messages = $self->{pbot}->{messagehistory}->{database}->get_recent_messages($account, $channel, 6, $self->{pbot}->{messagehistory}->{MSG_CHAT});
|
||||
|
||||
if (exists $self->{offenses}->{$account} and exists $self->{offenses}->{$account}->{$channel}) {
|
||||
next if $self->{offenses}->{$account}->{$channel}->{last_offense} >= $string2->{timestamp};
|
||||
}
|
||||
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
|
||||
|
||||
my $string = lcss(lc $string1->{msg}, lc $string2->{msg});
|
||||
my $bot_trigger = $self->{pbot}->{registry}->get_value($channel, 'trigger') // $self->{pbot}->{registry}->get_value('general', 'trigger');
|
||||
|
||||
if (defined $string) {
|
||||
my $length = length $string;
|
||||
my $length1 = $length / length $string1->{msg};
|
||||
my $length2 = $length / length $string2->{msg};
|
||||
my $allow_bot = $self->{pbot}->{registry}->get_value($channel, 'antirepeat_allow_bot') // $self->{pbot}->{registry}->get_value('antiflood', 'antirepeat_allow_bot');
|
||||
|
||||
if ($length1 >= $match && $length2 >= $match) {
|
||||
$matches{$string}++;
|
||||
my $match = $self->{pbot}->{registry}->get_value($channel, 'antirepeat_match') // $self->{pbot}->{registry}->get_value('antiflood', 'antirepeat_match');
|
||||
|
||||
my %matches;
|
||||
my $now = gettimeofday;
|
||||
|
||||
foreach my $string1 (@$messages) {
|
||||
next if $now - $string1->{timestamp} > 60 * 60 * 2;
|
||||
next if $allow_bot and $string1->{msg} =~ m/^(?:$bot_trigger|$botnick.?)/;
|
||||
$string1->{msg} =~ s/^[^;,:]{1,20}[;,:]//; # remove nick-like prefix if one exists
|
||||
next if length $string1->{msg} <= 5; # allow really short messages since "yep" "ok" etc are so common
|
||||
|
||||
if (exists $self->{offenses}->{$account} and exists $self->{offenses}->{$account}->{$channel}) {
|
||||
next if $self->{offenses}->{$account}->{$channel}->{last_offense} >= $string1->{timestamp};
|
||||
}
|
||||
|
||||
foreach my $string2 (@$messages) {
|
||||
next if $now - $string2->{timestamp} > 60 * 60 * 2;
|
||||
next if $allow_bot and $string2->{msg} =~ m/^(?:$bot_trigger|$botnick.?)/;
|
||||
$string2->{msg} =~ s/^[^;,:]{1,20}[;,:]//; # remove nick-like prefix if one exists
|
||||
next if length $string2->{msg} <= 5; # allow really short messages since "yep" "ok" etc are so common
|
||||
|
||||
if (exists $self->{offenses}->{$account} and exists $self->{offenses}->{$account}->{$channel}) {
|
||||
next if $self->{offenses}->{$account}->{$channel}->{last_offense} >= $string2->{timestamp};
|
||||
}
|
||||
|
||||
my $string = lcss(lc $string1->{msg}, lc $string2->{msg});
|
||||
|
||||
if (defined $string) {
|
||||
my $length = length $string;
|
||||
my $length1 = $length / length $string1->{msg};
|
||||
my $length2 = $length / length $string2->{msg};
|
||||
|
||||
if ($length1 >= $match && $length2 >= $match) { $matches{$string}++; }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $threshold = $self->{pbot}->{registry}->get_value($channel, 'antirepeat_threshold')
|
||||
// $self->{pbot}->{registry}->get_value('antiflood', 'antirepeat_threshold');
|
||||
my $threshold = $self->{pbot}->{registry}->get_value($channel, 'antirepeat_threshold') // $self->{pbot}->{registry}->get_value('antiflood', 'antirepeat_threshold');
|
||||
|
||||
foreach my $match (keys %matches) {
|
||||
if (sqrt $matches{$match} > $threshold) {
|
||||
$self->{offenses}->{$account}->{$channel}->{last_offense} = gettimeofday;
|
||||
$self->{offenses}->{$account}->{$channel}->{last_adjustment} = gettimeofday;
|
||||
$self->{offenses}->{$account}->{$channel}->{offenses}++;
|
||||
foreach my $match (keys %matches) {
|
||||
if (sqrt $matches{$match} > $threshold) {
|
||||
$self->{offenses}->{$account}->{$channel}->{last_offense} = gettimeofday;
|
||||
$self->{offenses}->{$account}->{$channel}->{last_adjustment} = gettimeofday;
|
||||
$self->{offenses}->{$account}->{$channel}->{offenses}++;
|
||||
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host triggered anti-repeat; offense $self->{offenses}->{$account}->{$channel}->{offenses}\n");
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host triggered anti-repeat; offense $self->{offenses}->{$account}->{$channel}->{offenses}\n");
|
||||
|
||||
given ($self->{offenses}->{$account}->{$channel}->{offenses}) {
|
||||
when (1) {
|
||||
$self->{pbot}->{chanops}->add_op_command($channel, "kick $channel $nick Stop repeating yourself");
|
||||
$self->{pbot}->{chanops}->gain_ops($channel);
|
||||
given ($self->{offenses}->{$account}->{$channel}->{offenses}) {
|
||||
when (1) {
|
||||
$self->{pbot}->{chanops}->add_op_command($channel, "kick $channel $nick Stop repeating yourself");
|
||||
$self->{pbot}->{chanops}->gain_ops($channel);
|
||||
}
|
||||
when (2) { $self->{pbot}->{chanops}->ban_user_timed($botnick, 'repeating messages', "*!*\@$host", $channel, 60); }
|
||||
when (3) { $self->{pbot}->{chanops}->ban_user_timed($botnick, 'repeating messages', "*!*\@$host", $channel, 60 * 15); }
|
||||
default { $self->{pbot}->{chanops}->ban_user_timed($botnick, 'repeating messages', "*!*\@$host", $channel, 60 * 60); }
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
when (2) {
|
||||
$self->{pbot}->{chanops}->ban_user_timed($botnick, 'repeating messages', "*!*\@$host", $channel, 60);
|
||||
}
|
||||
when (3) {
|
||||
$self->{pbot}->{chanops}->ban_user_timed($botnick, 'repeating messages', "*!*\@$host", $channel, 60 * 15);
|
||||
}
|
||||
default {
|
||||
$self->{pbot}->{chanops}->ban_user_timed($botnick, 'repeating messages', "*!*\@$host", $channel, 60 * 60);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub adjust_offenses {
|
||||
my $self = shift;
|
||||
my $now = gettimeofday;
|
||||
my $self = shift;
|
||||
my $now = gettimeofday;
|
||||
|
||||
foreach my $account (keys %{ $self->{offenses} }) {
|
||||
foreach my $channel (keys %{ $self->{offenses}->{$account} }) {
|
||||
if ($self->{offenses}->{$account}->{$channel}->{offenses} > 0 and $now - $self->{offenses}->{$account}->{$channel}->{last_adjustment} > 60 * 60 * 3) {
|
||||
$self->{offenses}->{$account}->{$channel}->{offenses}--;
|
||||
foreach my $account (keys %{$self->{offenses}}) {
|
||||
foreach my $channel (keys %{$self->{offenses}->{$account}}) {
|
||||
if ($self->{offenses}->{$account}->{$channel}->{offenses} > 0 and $now - $self->{offenses}->{$account}->{$channel}->{last_adjustment} > 60 * 60 * 3) {
|
||||
$self->{offenses}->{$account}->{$channel}->{offenses}--;
|
||||
|
||||
if ($self->{offenses}->{$account}->{$channel}->{offenses} <= 0) {
|
||||
delete $self->{offenses}->{$account}->{$channel};
|
||||
if (keys %{ $self->{offenses}->{$account} } == 0) {
|
||||
delete $self->{offenses}->{$account};
|
||||
}
|
||||
} else {
|
||||
$self->{offenses}->{$account}->{$channel}->{last_adjustment} = $now;
|
||||
if ($self->{offenses}->{$account}->{$channel}->{offenses} <= 0) {
|
||||
delete $self->{offenses}->{$account}->{$channel};
|
||||
if (keys %{$self->{offenses}->{$account}} == 0) { delete $self->{offenses}->{$account}; }
|
||||
} else {
|
||||
$self->{offenses}->{$account}->{$channel}->{last_adjustment} = $now;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package Plugins::AntiTwitter;
|
||||
|
||||
use parent 'Plugins::Plugin';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -18,72 +19,75 @@ use Time::HiRes qw/gettimeofday/;
|
|||
use Time::Duration qw/duration/;
|
||||
|
||||
use feature 'switch';
|
||||
|
||||
no if $] >= 5.018, warnings => "experimental::smartmatch";
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
$self->{pbot}->{timer}->register(sub { $self->adjust_offenses }, 60 * 60 * 1, 'antitwitter');
|
||||
$self->{offenses} = {};
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
$self->{pbot}->{timer}->register(sub { $self->adjust_offenses }, 60 * 60 * 1, 'antitwitter');
|
||||
$self->{offenses} = {};
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
}
|
||||
|
||||
sub on_public {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $channel, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->{to}[0], $event->{event}->args);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $channel, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->{to}[0], $event->{event}->args);
|
||||
|
||||
return 0 if $event->{interpreted};
|
||||
$channel = lc $channel;
|
||||
return 0 if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
return 0 if $event->{interpreted};
|
||||
$channel = lc $channel;
|
||||
return 0 if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
|
||||
while ($msg =~ m/\B[＠@]([a-z0-9_^{}\-\\\[\]\|]+)/ig) {
|
||||
my $n = $1;
|
||||
if ($self->{pbot}->{nicklist}->is_present_similar($channel, $n, 0.05)) {
|
||||
$self->{offenses}->{$channel}->{$nick}->{offenses}++;
|
||||
$self->{offenses}->{$channel}->{$nick}->{time} = gettimeofday;
|
||||
while ($msg =~ m/\B[＠@]([a-z0-9_^{}\-\\\[\]\|]+)/ig) {
|
||||
my $n = $1;
|
||||
if ($self->{pbot}->{nicklist}->is_present_similar($channel, $n, 0.05)) {
|
||||
$self->{offenses}->{$channel}->{$nick}->{offenses}++;
|
||||
$self->{offenses}->{$channel}->{$nick}->{time} = gettimeofday;
|
||||
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host is a twit. ($self->{offenses}->{$channel}->{$nick}->{offenses} offenses) $channel: $msg\n");
|
||||
$self->{pbot}->{logger}->log("$nick!$user\@$host is a twit. ($self->{offenses}->{$channel}->{$nick}->{offenses} offenses) $channel: $msg\n");
|
||||
|
||||
given ($self->{offenses}->{$channel}->{$nick}->{offenses}) {
|
||||
when (1) {
|
||||
$event->{conn}->privmsg($nick, "Please do not use \@nick to address people. Drop the @ symbol; it's not necessary and it's ugly.");
|
||||
given ($self->{offenses}->{$channel}->{$nick}->{offenses}) {
|
||||
when (1) { $event->{conn}->privmsg($nick, "Please do not use \@nick to address people. Drop the @ symbol; it's not necessary and it's ugly."); }
|
||||
when (2) {
|
||||
$event->{conn}
|
||||
->privmsg($nick, "Please do not use \@nick to address people. Drop the @ symbol; it's not necessary and it's ugly. Doing this again will result in a temporary ban.");
|
||||
}
|
||||
default {
|
||||
my $offenses = $self->{offenses}->{$channel}->{$nick}->{offenses} - 2;
|
||||
my $length = 60 * ($offenses * $offenses + 1);
|
||||
$self->{pbot}->{chanops}->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'using @nick too much', "*!*\@$host", $channel, $length);
|
||||
$self->{pbot}->{chanops}->gain_ops($channel);
|
||||
$length = duration $length;
|
||||
$event->{conn}->privmsg(
|
||||
$nick,
|
||||
"Please do not use \@nick to address people. Drop the @ symbol; it's not necessary and it's ugly. You were warned. You will be allowed to speak again in $length."
|
||||
);
|
||||
}
|
||||
}
|
||||
last;
|
||||
}
|
||||
when (2) {
|
||||
$event->{conn}->privmsg($nick, "Please do not use \@nick to address people. Drop the @ symbol; it's not necessary and it's ugly. Doing this again will result in a temporary ban.");
|
||||
}
|
||||
default {
|
||||
my $offenses = $self->{offenses}->{$channel}->{$nick}->{offenses} - 2;
|
||||
my $length = 60 * ($offenses * $offenses + 1);
|
||||
$self->{pbot}->{chanops}->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'using @nick too much', "*!*\@$host", $channel, $length);
|
||||
$self->{pbot}->{chanops}->gain_ops($channel);
|
||||
$length = duration $length;
|
||||
$event->{conn}->privmsg($nick, "Please do not use \@nick to address people. Drop the @ symbol; it's not necessary and it's ugly. You were warned. You will be allowed to speak again in $length.");
|
||||
}
|
||||
}
|
||||
last;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub adjust_offenses {
|
||||
my $self = shift;
|
||||
my $now = gettimeofday;
|
||||
my $self = shift;
|
||||
my $now = gettimeofday;
|
||||
|
||||
foreach my $channel (keys %{ $self->{offenses} }) {
|
||||
foreach my $nick (keys %{ $self->{offenses}->{$channel} }) {
|
||||
if ($now - $self->{offenses}->{$channel}->{$nick}->{time} >= 60 * 60 * 24 * 7) {
|
||||
if (--$self->{offenses}->{$channel}->{$nick}->{offenses} <= 0) {
|
||||
delete $self->{offenses}->{$channel}->{$nick};
|
||||
delete $self->{offenses}->{$channel} if not keys %{ $self->{offenses}->{$channel} };
|
||||
foreach my $channel (keys %{$self->{offenses}}) {
|
||||
foreach my $nick (keys %{$self->{offenses}->{$channel}}) {
|
||||
if ($now - $self->{offenses}->{$channel}->{$nick}->{time} >= 60 * 60 * 24 * 7) {
|
||||
if (--$self->{offenses}->{$channel}->{$nick}->{offenses} <= 0) {
|
||||
delete $self->{offenses}->{$channel}->{$nick};
|
||||
delete $self->{offenses}->{$channel} if not keys %{$self->{offenses}->{$channel}};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package Plugins::AutoRejoin;
|
||||
|
||||
use parent 'Plugins::Plugin';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -17,57 +18,54 @@ use Time::HiRes qw/gettimeofday/;
|
|||
use Time::Duration;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('array', 'autorejoin', 'rejoin_delay', '900,1800,3600');
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.kick', sub { $self->on_kick(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.part', sub { $self->on_part(@_) });
|
||||
$self->{rejoins} = {};
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('array', 'autorejoin', 'rejoin_delay', '900,1800,3600');
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.kick', sub { $self->on_kick(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.part', sub { $self->on_part(@_) });
|
||||
$self->{rejoins} = {};
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.kick');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.part');
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.kick');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.part');
|
||||
}
|
||||
|
||||
sub rejoin_channel {
|
||||
my ($self, $channel) = @_;
|
||||
$self->{rejoins}->{$channel}->{rejoins} = 0 if not exists $self->{rejoins}->{$channel};
|
||||
my ($self, $channel) = @_;
|
||||
$self->{rejoins}->{$channel}->{rejoins} = 0 if not exists $self->{rejoins}->{$channel};
|
||||
|
||||
my $delay = $self->{pbot}->{registry}->get_array_value($channel, 'rejoin_delay', $self->{rejoins}->{$channel}->{rejoins});
|
||||
$delay = $self->{pbot}->{registry}->get_array_value('autorejoin', 'rejoin_delay', $self->{rejoins}->{$channel}->{rejoins}) if not defined $delay;
|
||||
my $delay = $self->{pbot}->{registry}->get_array_value($channel, 'rejoin_delay', $self->{rejoins}->{$channel}->{rejoins});
|
||||
$delay = $self->{pbot}->{registry}->get_array_value('autorejoin', 'rejoin_delay', $self->{rejoins}->{$channel}->{rejoins}) if not defined $delay;
|
||||
|
||||
$self->{pbot}->{interpreter}->add_botcmd_to_command_queue($channel, "join $channel", $delay);
|
||||
$self->{pbot}->{interpreter}->add_botcmd_to_command_queue($channel, "join $channel", $delay);
|
||||
|
||||
$delay = duration $delay;
|
||||
$self->{pbot}->{logger}->log("Rejoining $channel in $delay.\n");
|
||||
$self->{rejoins}->{$channel}->{last_rejoin} = gettimeofday;
|
||||
$delay = duration $delay;
|
||||
$self->{pbot}->{logger}->log("Rejoining $channel in $delay.\n");
|
||||
$self->{rejoins}->{$channel}->{last_rejoin} = gettimeofday;
|
||||
}
|
||||
|
||||
sub on_kick {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $target, $channel, $reason) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to, $event->{event}->{args}[0], $event->{event}->{args}[1]);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $target, $channel, $reason) =
|
||||
($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to, $event->{event}->{args}[0], $event->{event}->{args}[1]);
|
||||
|
||||
return 0 if not $self->{pbot}->{channels}->is_active($channel);
|
||||
return 0 if $self->{pbot}->{channels}->{channels}->{hash}->{lc $channel}->{noautorejoin};
|
||||
return 0 if not $self->{pbot}->{channels}->is_active($channel);
|
||||
return 0 if $self->{pbot}->{channels}->{channels}->{hash}->{lc $channel}->{noautorejoin};
|
||||
|
||||
if ($target eq $self->{pbot}->{registry}->get_value('irc', 'botnick')) {
|
||||
$self->rejoin_channel($channel);
|
||||
}
|
||||
return 0;
|
||||
if ($target eq $self->{pbot}->{registry}->get_value('irc', 'botnick')) { $self->rejoin_channel($channel); }
|
||||
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);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to);
|
||||
|
||||
return 0 if not $self->{pbot}->{channels}->is_active($channel);
|
||||
return 0 if $self->{pbot}->{channels}->{channels}->{hash}->{lc $channel}->{noautorejoin};
|
||||
return 0 if not $self->{pbot}->{channels}->is_active($channel);
|
||||
return 0 if $self->{pbot}->{channels}->{channels}->{hash}->{lc $channel}->{noautorejoin};
|
||||
|
||||
if ($nick eq $self->{pbot}->{registry}->get_value('irc', 'botnick')) {
|
||||
$self->rejoin_channel($channel);
|
||||
}
|
||||
return 0;
|
||||
if ($nick eq $self->{pbot}->{registry}->get_value('irc', 'botnick')) { $self->rejoin_channel($channel); }
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
1234
Plugins/Connect4.pm
1234
Plugins/Connect4.pm
File diff suppressed because it is too large
Load Diff
1003
Plugins/Counter.pm
1003
Plugins/Counter.pm
File diff suppressed because it is too large
Load Diff
|
|
@ -16,55 +16,54 @@ use feature 'unicode_strings';
|
|||
use Getopt::Long qw(GetOptionsFromString);
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('text', 'date', 'default_timezone', 'UTC');
|
||||
$self->{pbot}->{commands}->register(sub { $self->datecmd(@_) }, "date", 0);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('text', 'date', 'default_timezone', 'UTC');
|
||||
$self->{pbot}->{commands}->register(sub { $self->datecmd(@_) }, "date", 0);
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
$self->{pbot}->{commands}->unregister("date");
|
||||
my $self = shift;
|
||||
$self->{pbot}->{commands}->unregister("date");
|
||||
}
|
||||
|
||||
sub datecmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "date [-u <user account>] [timezone]";
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "date [-u <user account>] [timezone]";
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
|
||||
Getopt::Long::Configure("bundling");
|
||||
Getopt::Long::Configure("bundling");
|
||||
|
||||
my ($user_override, $show_usage);
|
||||
my ($ret, $args) = GetOptionsFromString($arguments,
|
||||
'u=s' => \$user_override,
|
||||
'h' => \$show_usage
|
||||
);
|
||||
my ($user_override, $show_usage);
|
||||
my ($ret, $args) = GetOptionsFromString(
|
||||
$arguments,
|
||||
'u=s' => \$user_override,
|
||||
'h' => \$show_usage
|
||||
);
|
||||
|
||||
return $usage if $show_usage;
|
||||
return "/say $getopt_error -- $usage" if defined $getopt_error;
|
||||
$arguments = "@$args";
|
||||
return $usage if $show_usage;
|
||||
return "/say $getopt_error -- $usage" if defined $getopt_error;
|
||||
$arguments = "@$args";
|
||||
|
||||
my $hostmask = defined $user_override ? $user_override : "$nick!$user\@$host";
|
||||
my $tz_override = $self->{pbot}->{users}->get_user_metadata($from, $hostmask, 'timezone') // '';
|
||||
my $hostmask = defined $user_override ? $user_override : "$nick!$user\@$host";
|
||||
my $tz_override = $self->{pbot}->{users}->get_user_metadata($from, $hostmask, 'timezone') // '';
|
||||
|
||||
my $timezone = $self->{pbot}->{registry}->get_value('date', 'default_timezone') // 'UTC';
|
||||
$timezone = $tz_override if $tz_override;
|
||||
$timezone = $arguments if length $arguments;
|
||||
my $timezone = $self->{pbot}->{registry}->get_value('date', 'default_timezone') // 'UTC';
|
||||
$timezone = $tz_override if $tz_override;
|
||||
$timezone = $arguments if length $arguments;
|
||||
|
||||
if (defined $user_override and not length $tz_override) {
|
||||
return "No timezone set or user account does not exist.";
|
||||
}
|
||||
if (defined $user_override and not length $tz_override) { return "No timezone set or user account does not exist."; }
|
||||
|
||||
my $newstuff = {
|
||||
from => $from, nick => $nick, user => $user, host => $host,
|
||||
command => "date_module $timezone", root_channel => $from, root_keyword => "date_module",
|
||||
keyword => "date_module", arguments => "$timezone"
|
||||
};
|
||||
my $newstuff = {
|
||||
from => $from, nick => $nick, user => $user, host => $host,
|
||||
command => "date_module $timezone", root_channel => $from, root_keyword => "date_module",
|
||||
keyword => "date_module", arguments => "$timezone"
|
||||
};
|
||||
|
||||
$self->{pbot}->{modules}->execute_module($newstuff);
|
||||
$self->{pbot}->{modules}->execute_module($newstuff);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -9,27 +9,28 @@ use warnings; use strict;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
# perform plugin clean-up here
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
my $self = shift;
|
||||
|
||||
# perform plugin clean-up here
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
}
|
||||
|
||||
sub on_public {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
|
||||
if ($event->{interpreted}) {
|
||||
$self->{pbot}->{logger}->log("Message was already handled by the interpreter.\n");
|
||||
if ($event->{interpreted}) {
|
||||
$self->{pbot}->{logger}->log("Message was already handled by the interpreter.\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Example plugin: got message from $nick!$user\@$host: $msg\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("Example plugin: got message from $nick!$user\@$host: $msg\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -14,106 +14,108 @@ use warnings; use strict;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{functions}->register(
|
||||
'title',
|
||||
{
|
||||
desc => 'Title-cases text',
|
||||
usage => 'title <text>',
|
||||
subref => sub { $self->func_title(@_) }
|
||||
}
|
||||
);
|
||||
$self->{pbot}->{functions}->register(
|
||||
'ucfirst',
|
||||
{
|
||||
desc => 'Uppercases first character',
|
||||
usage => 'ucfirst <text>',
|
||||
subref => sub { $self->func_ucfirst(@_) }
|
||||
}
|
||||
);
|
||||
$self->{pbot}->{functions}->register(
|
||||
'uc',
|
||||
{
|
||||
desc => 'Uppercases all characters',
|
||||
usage => 'uc <text>',
|
||||
subref => sub { $self->func_uc(@_) }
|
||||
}
|
||||
);
|
||||
$self->{pbot}->{functions}->register(
|
||||
'lc',
|
||||
{
|
||||
desc => 'Lowercases all characters',
|
||||
usage => 'lc <text>',
|
||||
subref => sub { $self->func_lc(@_) }
|
||||
}
|
||||
);
|
||||
$self->{pbot}->{functions}->register(
|
||||
'unquote',
|
||||
{
|
||||
desc => 'removes unescaped surrounding quotes and strips escapes from escaped quotes',
|
||||
usage => 'unquote <text>',
|
||||
subref => sub { $self->func_unquote(@_) }
|
||||
}
|
||||
);
|
||||
$self->{pbot}->{functions}->register('uri_escape',
|
||||
{
|
||||
desc => 'percent-encode unsafe URI characters',
|
||||
usage => 'uri_escape <text>',
|
||||
subref => sub { $self->func_uri_escape(@_) }
|
||||
}
|
||||
);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{functions}->register(
|
||||
'title',
|
||||
{
|
||||
desc => 'Title-cases text',
|
||||
usage => 'title <text>',
|
||||
subref => sub { $self->func_title(@_) }
|
||||
}
|
||||
);
|
||||
$self->{pbot}->{functions}->register(
|
||||
'ucfirst',
|
||||
{
|
||||
desc => 'Uppercases first character',
|
||||
usage => 'ucfirst <text>',
|
||||
subref => sub { $self->func_ucfirst(@_) }
|
||||
}
|
||||
);
|
||||
$self->{pbot}->{functions}->register(
|
||||
'uc',
|
||||
{
|
||||
desc => 'Uppercases all characters',
|
||||
usage => 'uc <text>',
|
||||
subref => sub { $self->func_uc(@_) }
|
||||
}
|
||||
);
|
||||
$self->{pbot}->{functions}->register(
|
||||
'lc',
|
||||
{
|
||||
desc => 'Lowercases all characters',
|
||||
usage => 'lc <text>',
|
||||
subref => sub { $self->func_lc(@_) }
|
||||
}
|
||||
);
|
||||
$self->{pbot}->{functions}->register(
|
||||
'unquote',
|
||||
{
|
||||
desc => 'removes unescaped surrounding quotes and strips escapes from escaped quotes',
|
||||
usage => 'unquote <text>',
|
||||
subref => sub { $self->func_unquote(@_) }
|
||||
}
|
||||
);
|
||||
$self->{pbot}->{functions}->register(
|
||||
'uri_escape',
|
||||
{
|
||||
desc => 'percent-encode unsafe URI characters',
|
||||
usage => 'uri_escape <text>',
|
||||
subref => sub { $self->func_uri_escape(@_) }
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
$self->{pbot}->{functions}->unregister('title');
|
||||
$self->{pbot}->{functions}->unregister('ucfirst');
|
||||
$self->{pbot}->{functions}->unregister('uc');
|
||||
$self->{pbot}->{functions}->unregister('lc');
|
||||
$self->{pbot}->{functions}->unregister('unquote');
|
||||
$self->{pbot}->{functions}->unregister('uri_escape');
|
||||
my $self = shift;
|
||||
$self->{pbot}->{functions}->unregister('title');
|
||||
$self->{pbot}->{functions}->unregister('ucfirst');
|
||||
$self->{pbot}->{functions}->unregister('uc');
|
||||
$self->{pbot}->{functions}->unregister('lc');
|
||||
$self->{pbot}->{functions}->unregister('unquote');
|
||||
$self->{pbot}->{functions}->unregister('uri_escape');
|
||||
}
|
||||
|
||||
sub func_unquote {
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
$text =~ s/^"(.*?)(?<!\\)"$/$1/ || $text =~ s/^'(.*?)(?<!\\)'$/$1/;
|
||||
$text =~ s/(?<!\\)\\'/'/g;
|
||||
$text =~ s/(?<!\\)\\"/"/g;
|
||||
return $text;
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
$text =~ s/^"(.*?)(?<!\\)"$/$1/ || $text =~ s/^'(.*?)(?<!\\)'$/$1/;
|
||||
$text =~ s/(?<!\\)\\'/'/g;
|
||||
$text =~ s/(?<!\\)\\"/"/g;
|
||||
return $text;
|
||||
}
|
||||
|
||||
sub func_title {
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
$text = ucfirst lc $text;
|
||||
$text =~ s/ (\w)/' ' . uc $1/ge;
|
||||
return $text;
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
$text = ucfirst lc $text;
|
||||
$text =~ s/ (\w)/' ' . uc $1/ge;
|
||||
return $text;
|
||||
}
|
||||
|
||||
sub func_ucfirst {
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
return ucfirst $text;
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
return ucfirst $text;
|
||||
}
|
||||
|
||||
sub func_uc {
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
return uc $text;
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
return uc $text;
|
||||
}
|
||||
|
||||
sub func_lc {
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
return lc $text;
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
return lc $text;
|
||||
}
|
||||
|
||||
use URI::Escape qw/uri_escape_utf8/;
|
||||
|
||||
sub func_uri_escape {
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
return uri_escape_utf8($text);
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
return uri_escape_utf8($text);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -14,51 +14,46 @@ use warnings; use strict;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{functions}->register(
|
||||
'sed',
|
||||
{
|
||||
desc => 'a sed-like stream editor',
|
||||
usage => 'sed s/<regex>/<replacement>/[Pig]; P preserve case; i ignore case; g replace all',
|
||||
subref => sub { $self->func_sed(@_) }
|
||||
}
|
||||
);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{functions}->register(
|
||||
'sed',
|
||||
{
|
||||
desc => 'a sed-like stream editor',
|
||||
usage => 'sed s/<regex>/<replacement>/[Pig]; P preserve case; i ignore case; g replace all',
|
||||
subref => sub { $self->func_sed(@_) }
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
$self->{pbot}->{functions}->unregister('sed');
|
||||
my $self = shift;
|
||||
$self->{pbot}->{functions}->unregister('sed');
|
||||
}
|
||||
|
||||
# near-verbatim insertion of krok's `sed` factoid
|
||||
no warnings;
|
||||
|
||||
sub func_sed {
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
my $self = shift;
|
||||
my $text = "@_";
|
||||
|
||||
if ($text =~ /^s(.)(.*?)(?<!\\)\1(.*?)(?<!\\)\1(\S*)\s+(.*)/p) {
|
||||
my ($a, $r, $g, $m, $t) = ($5,"'\"$3\"'", index($4,"g") != -1, $4, $2);
|
||||
if ($text =~ /^s(.)(.*?)(?<!\\)\1(.*?)(?<!\\)\1(\S*)\s+(.*)/p) {
|
||||
my ($a, $r, $g, $m, $t) = ($5, "'\"$3\"'", index($4, "g") != -1, $4, $2);
|
||||
|
||||
if ($m=~/P/) {
|
||||
$r =~ s/^'"(.*)"'$/$1/;
|
||||
$m=~s/P//g;
|
||||
if ($m =~ /P/) {
|
||||
$r =~ s/^'"(.*)"'$/$1/;
|
||||
$m =~ s/P//g;
|
||||
|
||||
if($g) {
|
||||
$a =~ s|(?$m)($t)|$1=~/^[A-Z][^A-Z]/?ucfirst$r:($1=~/^[A-Z]+$/?uc$r:$r)|gie;
|
||||
} else {
|
||||
$a =~ s|(?$m)($t)|$1=~/^[A-Z][^A-Z]/?ucfirst$r:($1=~/^[A-Z]+$/?uc$r:$r)|ie;
|
||||
}
|
||||
if ($g) { $a =~ s|(?$m)($t)|$1=~/^[A-Z][^A-Z]/?ucfirst$r:($1=~/^[A-Z]+$/?uc$r:$r)|gie; }
|
||||
else { $a =~ s|(?$m)($t)|$1=~/^[A-Z][^A-Z]/?ucfirst$r:($1=~/^[A-Z]+$/?uc$r:$r)|ie; }
|
||||
} else {
|
||||
if ($g) { $a =~ s/(?$m)$t/$r/geee; }
|
||||
else { $a =~ s/(?$m)$t/$r/eee; }
|
||||
}
|
||||
return $a;
|
||||
} else {
|
||||
if ($g) {
|
||||
$a =~ s/(?$m)$t/$r/geee;
|
||||
} else {
|
||||
$a=~s/(?$m)$t/$r/eee;
|
||||
}
|
||||
return "sed: syntax error";
|
||||
}
|
||||
return $a;
|
||||
} else {
|
||||
return "sed: syntax error";
|
||||
}
|
||||
}
|
||||
use warnings;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package Plugins::GoogleSearch;
|
||||
|
||||
use parent 'Plugins::Plugin';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -14,80 +15,80 @@ use WWW::Google::CustomSearch;
|
|||
use HTML::Entities;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('text', 'googlesearch', 'api_key', '');
|
||||
$self->{pbot}->{registry}->add_default('text', 'googlesearch', 'context', '');
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('text', 'googlesearch', 'api_key', '');
|
||||
$self->{pbot}->{registry}->add_default('text', 'googlesearch', 'context', '');
|
||||
|
||||
$self->{pbot}->{registry}->set_default('googlesearch', 'api_key', 'private', 1);
|
||||
$self->{pbot}->{registry}->set_default('googlesearch', 'context', 'private', 1);
|
||||
$self->{pbot}->{registry}->set_default('googlesearch', 'api_key', 'private', 1);
|
||||
$self->{pbot}->{registry}->set_default('googlesearch', 'context', 'private', 1);
|
||||
|
||||
$self->{pbot}->{commands}->register(sub { $self->googlesearch(@_) }, 'google', 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->googlesearch(@_) }, 'google', 0);
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
$self->{pbot}->{commands}->unregister('google');
|
||||
my $self = shift;
|
||||
$self->{pbot}->{commands}->unregister('google');
|
||||
}
|
||||
|
||||
sub googlesearch {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
return "Usage: google [number of results] query\n" if not length $arguments;
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
return "Usage: google [number of results] query\n" if not length $arguments;
|
||||
|
||||
my $matches = 1;
|
||||
$matches = $1 if $arguments =~ s/^-n\s+([0-9]+)\s*//;
|
||||
my $matches = 1;
|
||||
$matches = $1 if $arguments =~ s/^-n\s+([0-9]+)\s*//;
|
||||
|
||||
my $api_key = $self->{pbot}->{registry}->get_value('googlesearch', 'api_key'); # https://developers.google.com/custom-search/v1/overview
|
||||
my $cx = $self->{pbot}->{registry}->get_value('googlesearch', 'context'); # https://cse.google.com/all
|
||||
my $api_key = $self->{pbot}->{registry}->get_value('googlesearch', 'api_key'); # https://developers.google.com/custom-search/v1/overview
|
||||
my $cx = $self->{pbot}->{registry}->get_value('googlesearch', 'context'); # https://cse.google.com/all
|
||||
|
||||
if (not length $api_key) {
|
||||
return "$nick: Registry item googlesearch.api_key is not set. See https://developers.google.com/custom-search/v1/overview to get an API key.";
|
||||
}
|
||||
|
||||
if (not length $cx) {
|
||||
return "$nick: Registry item googlesearch.context is not set. See https://cse.google.com/all to set up a context.";
|
||||
}
|
||||
|
||||
my $engine = WWW::Google::CustomSearch->new(api_key => $api_key, cx => $cx, quotaUser => "$nick!$user\@$host");
|
||||
|
||||
if ($arguments =~ m/(.*)\svs\s(.*)/i) {
|
||||
my ($a, $b) = ($1, $2);
|
||||
my $result1 = $engine->search("\"$a\" -\"$b\"");
|
||||
my $result2 = $engine->search("\"$b\" -\"$a\"");
|
||||
|
||||
if (not defined $result1 or not defined $result1->items or not @{$result1->items}) {
|
||||
return "$nick: No results for $a";
|
||||
if (not length $api_key) {
|
||||
return "$nick: Registry item googlesearch.api_key is not set. See https://developers.google.com/custom-search/v1/overview to get an API key.";
|
||||
}
|
||||
|
||||
if (not defined $result2 or not defined $result2->items or not @{$result2->items}) {
|
||||
return "$nick: No results for $b";
|
||||
if (not length $cx) { return "$nick: Registry item googlesearch.context is not set. See https://cse.google.com/all to set up a context."; }
|
||||
|
||||
my $engine = WWW::Google::CustomSearch->new(api_key => $api_key, cx => $cx, quotaUser => "$nick!$user\@$host");
|
||||
|
||||
if ($arguments =~ m/(.*)\svs\s(.*)/i) {
|
||||
my ($a, $b) = ($1, $2);
|
||||
my $result1 = $engine->search("\"$a\" -\"$b\"");
|
||||
my $result2 = $engine->search("\"$b\" -\"$a\"");
|
||||
|
||||
if (not defined $result1 or not defined $result1->items or not @{$result1->items}) { return "$nick: No results for $a"; }
|
||||
|
||||
if (not defined $result2 or not defined $result2->items or not @{$result2->items}) { return "$nick: No results for $b"; }
|
||||
|
||||
my $title1 = $result1->items->[0]->title;
|
||||
my $title2 = $result2->items->[0]->title;
|
||||
|
||||
utf8::decode $title1;
|
||||
utf8::decode $title2;
|
||||
|
||||
return
|
||||
"$nick: $a: ("
|
||||
. $result1->formattedTotalResults . ") "
|
||||
. decode_entities($title1) . " <"
|
||||
. $result1->items->[0]->link
|
||||
. "> VS $b: ("
|
||||
. $result2->formattedTotalResults . ") "
|
||||
. decode_entities($title2) . " <"
|
||||
. $result2->items->[0]->link . ">";
|
||||
}
|
||||
|
||||
my $title1 = $result1->items->[0]->title;
|
||||
my $title2 = $result2->items->[0]->title;
|
||||
my $result = $engine->search($arguments);
|
||||
|
||||
utf8::decode $title1;
|
||||
utf8::decode $title2;
|
||||
if (not defined $result or not defined $result->items or not @{$result->items}) { return "$nick: No results found"; }
|
||||
|
||||
return "$nick: $a: (" . $result1->formattedTotalResults . ") " . decode_entities($title1) . " <" . $result1->items->[0]->link . "> VS $b: (" . $result2->formattedTotalResults . ") " . decode_entities($title2) . " <" . $result2->items->[0]->link . ">";
|
||||
}
|
||||
my $output = "$nick: (" . $result->formattedTotalResults . " results) ";
|
||||
|
||||
my $result = $engine->search($arguments);
|
||||
|
||||
if (not defined $result or not defined $result->items or not @{$result->items}) {
|
||||
return "$nick: No results found";
|
||||
}
|
||||
|
||||
my $output = "$nick: (" . $result->formattedTotalResults . " results) ";
|
||||
|
||||
my $comma = "";
|
||||
foreach my $item (@{$result->items}) {
|
||||
my $title = $item->title;
|
||||
utf8::decode $title;
|
||||
$output .= $comma . decode_entities($title) . ': <' . $item->link . ">";
|
||||
$comma = " -- ";
|
||||
last if --$matches <= 0;
|
||||
}
|
||||
return $output;
|
||||
my $comma = "";
|
||||
foreach my $item (@{$result->items}) {
|
||||
my $title = $item->title;
|
||||
utf8::decode $title;
|
||||
$output .= $comma . decode_entities($title) . ': <' . $item->link . ">";
|
||||
$comma = " -- ";
|
||||
last if --$matches <= 0;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -14,21 +14,21 @@ use warnings; use strict;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { return $self->magic(@_)}, "mc", 90);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { return $self->magic(@_) }, "mc", 90);
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
$self->{pbot}->{commands}->unregister("mc");
|
||||
my $self = shift;
|
||||
$self->{pbot}->{commands}->unregister("mc");
|
||||
}
|
||||
|
||||
sub magic {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
# do something magical!
|
||||
return "Did something magical.";
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
# do something magical!
|
||||
return "Did something magical.";
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -13,21 +13,21 @@ use feature 'unicode_strings';
|
|||
use Time::Duration qw/duration/;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { return $self->pd(@_)}, "pd", 0);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { return $self->pd(@_) }, "pd", 0);
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
$self->{pbot}->{commands}->unregister("pd");
|
||||
my $self = shift;
|
||||
$self->{pbot}->{commands}->unregister("pd");
|
||||
}
|
||||
|
||||
sub pd {
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($seconds, $error) = $self->{pbot}->{parsedate}->parsedate($arguments);
|
||||
return $error if defined $error;
|
||||
return duration $seconds;
|
||||
my $self = shift;
|
||||
my ($from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($seconds, $error) = $self->{pbot}->{parsedate}->parsedate($arguments);
|
||||
return $error if defined $error;
|
||||
return duration $seconds;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -9,31 +9,31 @@ package Plugins::Plugin;
|
|||
use warnings; use strict;
|
||||
|
||||
sub new {
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
my ($proto, %conf) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless {}, $class;
|
||||
|
||||
if (not exists $conf{pbot}) {
|
||||
my ($package, $filename, $line) = caller(0);
|
||||
my (undef, undef, undef, $subroutine) = caller(1);
|
||||
Carp::croak("Missing pbot reference to " . $class . ", created by $subroutine at $filename:$line");
|
||||
}
|
||||
if (not exists $conf{pbot}) {
|
||||
my ($package, $filename, $line) = caller(0);
|
||||
my (undef, undef, undef, $subroutine) = caller(1);
|
||||
Carp::croak("Missing pbot reference to " . $class . ", created by $subroutine at $filename:$line");
|
||||
}
|
||||
|
||||
$self->{pbot} = $conf{pbot};
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
$self->{pbot} = $conf{pbot};
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($package, $filename, $line) = caller(0);
|
||||
my (undef, undef, undef, $subroutine) = caller(1);
|
||||
Carp::croak("Missing initialize subroutine in $subroutine at $filename:$line");
|
||||
my ($package, $filename, $line) = caller(0);
|
||||
my (undef, undef, undef, $subroutine) = caller(1);
|
||||
Carp::croak("Missing initialize subroutine in $subroutine at $filename:$line");
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my ($package, $filename, $line) = caller(0);
|
||||
my (undef, undef, undef, $subroutine) = caller(1);
|
||||
Carp::croak("Missing unload subroutine in $subroutine at $filename:$line");
|
||||
my ($package, $filename, $line) = caller(0);
|
||||
my (undef, undef, undef, $subroutine) = caller(1);
|
||||
Carp::croak("Missing unload subroutine in $subroutine at $filename:$line");
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package Plugins::Quotegrabs;
|
||||
|
||||
use parent 'Plugins::Plugin';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -18,372 +19,341 @@ use Time::Duration;
|
|||
use Time::HiRes qw(gettimeofday);
|
||||
use Getopt::Long qw(GetOptionsFromArray);
|
||||
|
||||
use Plugins::Quotegrabs::Quotegrabs_SQLite; # use SQLite backend for quotegrabs database
|
||||
use Plugins::Quotegrabs::Quotegrabs_SQLite; # use SQLite backend for quotegrabs database
|
||||
|
||||
#use Plugins::Quotegrabs::Quotegrabs_Hashtable; # use Perl hashtable backend for quotegrabs database
|
||||
use PBot::Utils::ValidateString;
|
||||
|
||||
use POSIX qw(strftime);
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{filename} = $conf{quotegrabs_file} // $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/quotegrabs.sqlite3';
|
||||
my ($self, %conf) = @_;
|
||||
$self->{filename} = $conf{quotegrabs_file} // $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/quotegrabs.sqlite3';
|
||||
|
||||
$self->{database} = Plugins::Quotegrabs::Quotegrabs_SQLite->new(pbot => $self->{pbot}, filename => $self->{filename});
|
||||
#$self->{database} = Plugins::Quotegrabs::Quotegrabs_Hashtable->new(pbot => $self->{pbot}, filename => $self->{filename});
|
||||
$self->{database}->begin();
|
||||
$self->{database} = Plugins::Quotegrabs::Quotegrabs_SQLite->new(pbot => $self->{pbot}, filename => $self->{filename});
|
||||
|
||||
$self->{pbot}->{atexit}->register(sub { $self->{database}->end(); return; });
|
||||
#$self->{database} = Plugins::Quotegrabs::Quotegrabs_Hashtable->new(pbot => $self->{pbot}, filename => $self->{filename});
|
||||
$self->{database}->begin();
|
||||
|
||||
$self->{pbot}->{commands}->register(sub { $self->grab_quotegrab(@_) }, 'grab', 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->show_quotegrab(@_) }, 'getq', 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->delete_quotegrab(@_) }, 'delq', 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->show_random_quotegrab(@_) }, 'rq', 0);
|
||||
$self->{pbot}->{atexit}->register(sub { $self->{database}->end(); return; });
|
||||
|
||||
$self->{pbot}->{commands}->register(sub { $self->grab_quotegrab(@_) }, 'grab', 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->show_quotegrab(@_) }, 'getq', 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->delete_quotegrab(@_) }, 'delq', 0);
|
||||
$self->{pbot}->{commands}->register(sub { $self->show_random_quotegrab(@_) }, 'rq', 0);
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{commands}->unregister('grab');
|
||||
$self->{pbot}->{commands}->unregister('getq');
|
||||
$self->{pbot}->{commands}->unregister('delq');
|
||||
$self->{pbot}->{commands}->unregister('rq');
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{commands}->unregister('grab');
|
||||
$self->{pbot}->{commands}->unregister('getq');
|
||||
$self->{pbot}->{commands}->unregister('delq');
|
||||
$self->{pbot}->{commands}->unregister('rq');
|
||||
}
|
||||
|
||||
sub uniq { my %seen; grep !$seen{$_}++, @_ }
|
||||
|
||||
sub export_quotegrabs {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
$self->{export_path} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/quotegrabs.html';
|
||||
$self->{export_path} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/quotegrabs.html';
|
||||
|
||||
my $quotegrabs = $self->{database}->get_all_quotegrabs();
|
||||
my $quotegrabs = $self->{database}->get_all_quotegrabs();
|
||||
|
||||
my $text;
|
||||
my $table_id = 1;
|
||||
my $had_table = 0;
|
||||
open FILE, "> $self->{export_path}" or return "Could not open export path.";
|
||||
my $time = localtime;
|
||||
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
|
||||
print FILE "<html>\n<head><link href=\"css/blue.css\" rel=\"stylesheet\" type=\"text/css\">\n";
|
||||
print FILE '<script type="text/javascript" src="js/jquery-latest.js"></script>' . "\n";
|
||||
print FILE '<script type="text/javascript" src="js/jquery.tablesorter.js"></script>' . "\n";
|
||||
print FILE '<script type="text/javascript" src="js/picnet.table.filter.min.js"></script>' . "\n";
|
||||
print FILE "</head>\n<body><i>Generated at $time</i><hr><h2>$botnick\'s Quotegrabs</h2>\n";
|
||||
my $i = 0;
|
||||
my $text;
|
||||
my $table_id = 1;
|
||||
my $had_table = 0;
|
||||
open FILE, "> $self->{export_path}" or return "Could not open export path.";
|
||||
my $time = localtime;
|
||||
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
|
||||
print FILE "<html>\n<head><link href=\"css/blue.css\" rel=\"stylesheet\" type=\"text/css\">\n";
|
||||
print FILE '<script type="text/javascript" src="js/jquery-latest.js"></script>' . "\n";
|
||||
print FILE '<script type="text/javascript" src="js/jquery.tablesorter.js"></script>' . "\n";
|
||||
print FILE '<script type="text/javascript" src="js/picnet.table.filter.min.js"></script>' . "\n";
|
||||
print FILE "</head>\n<body><i>Generated at $time</i><hr><h2>$botnick\'s Quotegrabs</h2>\n";
|
||||
my $i = 0;
|
||||
|
||||
my $last_channel = "";
|
||||
foreach my $quotegrab (sort { $$a{channel} cmp $$b{channel} or $$a{nick} cmp $$b{nick} } @$quotegrabs) {
|
||||
if (not $quotegrab->{channel} =~ /^$last_channel$/i) {
|
||||
print FILE "<a href='#" . encode_entities($quotegrab->{channel}) . "'>" . encode_entities($quotegrab->{channel}) . "</a><br>\n";
|
||||
$last_channel = $quotegrab->{channel};
|
||||
}
|
||||
}
|
||||
|
||||
$last_channel = "";
|
||||
foreach my $quotegrab (sort { $$a{channel} cmp $$b{channel} or lc $$a{nick} cmp lc $$b{nick} } @$quotegrabs) {
|
||||
if (not $quotegrab->{channel} =~ /^$last_channel$/i) {
|
||||
print FILE "</tbody>\n</table>\n" if $had_table;
|
||||
print FILE "<a name='" . encode_entities($quotegrab->{channel}) . "'></a>\n";
|
||||
print FILE "<hr><h3>" . encode_entities($quotegrab->{channel}) . "</h3><hr>\n";
|
||||
print FILE "<table border=\"0\" id=\"table$table_id\" class=\"tablesorter\">\n";
|
||||
print FILE "<thead>\n<tr>\n";
|
||||
print FILE "<th>id </th>\n";
|
||||
print FILE "<th>author(s)</th>\n";
|
||||
print FILE "<th>quote</th>\n";
|
||||
print FILE "<th>date</th>\n";
|
||||
print FILE "<th>grabbed by</th>\n";
|
||||
print FILE "</tr>\n</thead>\n<tbody>\n";
|
||||
$had_table = 1;
|
||||
$table_id++;
|
||||
my $last_channel = "";
|
||||
foreach my $quotegrab (sort { $$a{channel} cmp $$b{channel} or $$a{nick} cmp $$b{nick} } @$quotegrabs) {
|
||||
if (not $quotegrab->{channel} =~ /^$last_channel$/i) {
|
||||
print FILE "<a href='#" . encode_entities($quotegrab->{channel}) . "'>" . encode_entities($quotegrab->{channel}) . "</a><br>\n";
|
||||
$last_channel = $quotegrab->{channel};
|
||||
}
|
||||
}
|
||||
|
||||
$last_channel = $quotegrab->{channel};
|
||||
$i++;
|
||||
$last_channel = "";
|
||||
foreach my $quotegrab (sort { $$a{channel} cmp $$b{channel} or lc $$a{nick} cmp lc $$b{nick} } @$quotegrabs) {
|
||||
if (not $quotegrab->{channel} =~ /^$last_channel$/i) {
|
||||
print FILE "</tbody>\n</table>\n" if $had_table;
|
||||
print FILE "<a name='" . encode_entities($quotegrab->{channel}) . "'></a>\n";
|
||||
print FILE "<hr><h3>" . encode_entities($quotegrab->{channel}) . "</h3><hr>\n";
|
||||
print FILE "<table border=\"0\" id=\"table$table_id\" class=\"tablesorter\">\n";
|
||||
print FILE "<thead>\n<tr>\n";
|
||||
print FILE "<th>id </th>\n";
|
||||
print FILE "<th>author(s)</th>\n";
|
||||
print FILE "<th>quote</th>\n";
|
||||
print FILE "<th>date</th>\n";
|
||||
print FILE "<th>grabbed by</th>\n";
|
||||
print FILE "</tr>\n</thead>\n<tbody>\n";
|
||||
$had_table = 1;
|
||||
$table_id++;
|
||||
}
|
||||
|
||||
if ($i % 2) {
|
||||
print FILE "<tr bgcolor=\"#dddddd\">\n";
|
||||
} else {
|
||||
print FILE "<tr>\n";
|
||||
$last_channel = $quotegrab->{channel};
|
||||
$i++;
|
||||
|
||||
if ($i % 2) { print FILE "<tr bgcolor=\"#dddddd\">\n"; }
|
||||
else { print FILE "<tr>\n"; }
|
||||
|
||||
print FILE "<td>" . ($quotegrab->{id}) . "</td>";
|
||||
|
||||
my @nicks = split /\+/, $quotegrab->{nick};
|
||||
$text = join ', ', uniq(@nicks);
|
||||
print FILE "<td>" . encode_entities($text) . "</td>";
|
||||
|
||||
my $nick;
|
||||
$text = $quotegrab->{text};
|
||||
|
||||
if ($text =~ s/^\/me\s+//) { $nick = "* $nicks[0]"; }
|
||||
else { $nick = "<$nicks[0]>"; }
|
||||
|
||||
$text = "<td><b>" . encode_entities($nick) . "</b> " . encode_entities($text) . "</td>\n";
|
||||
print FILE $text;
|
||||
|
||||
print FILE "<td>" . encode_entities(strftime "%Y/%m/%d %a %H:%M:%S", localtime $quotegrab->{timestamp}) . "</td>\n";
|
||||
print FILE "<td>" . encode_entities($quotegrab->{grabbed_by}) . "</td>\n";
|
||||
print FILE "</tr>\n";
|
||||
}
|
||||
|
||||
print FILE "<td>" . ($quotegrab->{id}) . "</td>";
|
||||
|
||||
my @nicks = split /\+/, $quotegrab->{nick};
|
||||
$text = join ', ', uniq(@nicks);
|
||||
print FILE "<td>" . encode_entities($text) . "</td>";
|
||||
|
||||
my $nick;
|
||||
$text = $quotegrab->{text};
|
||||
|
||||
if ($text =~ s/^\/me\s+//) {
|
||||
$nick = "* $nicks[0]";
|
||||
} else {
|
||||
$nick = "<$nicks[0]>";
|
||||
}
|
||||
|
||||
$text = "<td><b>". encode_entities($nick) . "</b> " . encode_entities($text) . "</td>\n";
|
||||
print FILE $text;
|
||||
|
||||
|
||||
print FILE "<td>" . encode_entities(strftime "%Y/%m/%d %a %H:%M:%S", localtime $quotegrab->{timestamp}) . "</td>\n";
|
||||
print FILE "<td>" . encode_entities($quotegrab->{grabbed_by}) . "</td>\n";
|
||||
print FILE "</tr>\n";
|
||||
}
|
||||
|
||||
print FILE "</tbody>\n</table>\n" if $had_table;
|
||||
print FILE "<script type='text/javascript'>\n";
|
||||
$table_id--;
|
||||
print FILE '$(document).ready(function() {' . "\n";
|
||||
while ($table_id > 0) {
|
||||
print FILE '$("#table' . $table_id . '").tablesorter();' . "\n";
|
||||
print FILE '$("#table' . $table_id . '").tableFilter();' . "\n";
|
||||
print FILE "</tbody>\n</table>\n" if $had_table;
|
||||
print FILE "<script type='text/javascript'>\n";
|
||||
$table_id--;
|
||||
}
|
||||
print FILE "});\n";
|
||||
print FILE "</script>\n";
|
||||
print FILE "</body>\n</html>\n";
|
||||
close(FILE);
|
||||
return "$i quotegrabs exported.";
|
||||
print FILE '$(document).ready(function() {' . "\n";
|
||||
while ($table_id > 0) {
|
||||
print FILE '$("#table' . $table_id . '").tablesorter();' . "\n";
|
||||
print FILE '$("#table' . $table_id . '").tableFilter();' . "\n";
|
||||
$table_id--;
|
||||
}
|
||||
print FILE "});\n";
|
||||
print FILE "</script>\n";
|
||||
print FILE "</body>\n</html>\n";
|
||||
close(FILE);
|
||||
return "$i quotegrabs exported.";
|
||||
}
|
||||
|
||||
sub grab_quotegrab {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
if (not defined $from) {
|
||||
$self->{pbot}->{logger}->log("Command missing ~from parameter!\n");
|
||||
return "";
|
||||
}
|
||||
|
||||
if (not defined $arguments or not length $arguments) {
|
||||
return "Usage: grab <nick> [history [channel]] [+ <nick> [history [channel]] ...] -- where [history] is an optional regex argument; e.g., to grab a message containing 'pizza', use `grab nick pizza`; you can chain grabs with + to grab multiple messages";
|
||||
}
|
||||
|
||||
$arguments = lc $arguments;
|
||||
|
||||
my @grabs = split /\s\+\s/, $arguments;
|
||||
|
||||
my ($grab_nick, $grab_history, $channel, $grab_nicks, $grab_text);
|
||||
|
||||
foreach my $grab (@grabs) {
|
||||
($grab_nick, $grab_history, $channel) = $self->{pbot}->{interpreter}->split_line($grab, strip_quotes => 1);
|
||||
|
||||
$grab_history = $nick eq $grab_nick ? 2 : 1 if not defined $grab_history; # skip grab command if grabbing self without arguments
|
||||
$channel = $from if not defined $channel;
|
||||
|
||||
if (not $channel =~ m/^#/) {
|
||||
return "'$channel' is not a valid channel; usage: grab <nick> [[history] channel] (you must specify a history parameter before the channel parameter)";
|
||||
if (not defined $from) {
|
||||
$self->{pbot}->{logger}->log("Command missing ~from parameter!\n");
|
||||
return "";
|
||||
}
|
||||
|
||||
my ($account, $found_nick) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($grab_nick);
|
||||
|
||||
if (not defined $account) {
|
||||
return "I don't know anybody named $grab_nick";
|
||||
if (not defined $arguments or not length $arguments) {
|
||||
return
|
||||
"Usage: grab <nick> [history [channel]] [+ <nick> [history [channel]] ...] -- where [history] is an optional regex argument; e.g., to grab a message containing 'pizza', use `grab nick pizza`; you can chain grabs with + to grab multiple messages";
|
||||
}
|
||||
|
||||
$found_nick =~ s/!.*$//;
|
||||
$arguments = lc $arguments;
|
||||
|
||||
$grab_nick = $found_nick; # convert nick to proper casing
|
||||
my @grabs = split /\s\+\s/, $arguments;
|
||||
|
||||
my $message;
|
||||
my ($grab_nick, $grab_history, $channel, $grab_nicks, $grab_text);
|
||||
|
||||
if ($grab_history =~ /^\d+$/) {
|
||||
# integral history
|
||||
my $max_messages = $self->{pbot}->{messagehistory}->{database}->get_max_messages($account, $channel);
|
||||
if ($grab_history < 1 || $grab_history > $max_messages) {
|
||||
return "Please choose a history between 1 and $max_messages";
|
||||
}
|
||||
foreach my $grab (@grabs) {
|
||||
($grab_nick, $grab_history, $channel) = $self->{pbot}->{interpreter}->split_line($grab, strip_quotes => 1);
|
||||
|
||||
$grab_history--;
|
||||
$grab_history = $nick eq $grab_nick ? 2 : 1 if not defined $grab_history; # skip grab command if grabbing self without arguments
|
||||
$channel = $from if not defined $channel;
|
||||
|
||||
$message = $self->{pbot}->{messagehistory}->{database}->recall_message_by_count($account, $channel, $grab_history, 'grab');
|
||||
if (not $channel =~ m/^#/) {
|
||||
return "'$channel' is not a valid channel; usage: grab <nick> [[history] channel] (you must specify a history parameter before the channel parameter)";
|
||||
}
|
||||
|
||||
my ($account, $found_nick) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($grab_nick);
|
||||
|
||||
if (not defined $account) { return "I don't know anybody named $grab_nick"; }
|
||||
|
||||
$found_nick =~ s/!.*$//;
|
||||
|
||||
$grab_nick = $found_nick; # convert nick to proper casing
|
||||
|
||||
my $message;
|
||||
|
||||
if ($grab_history =~ /^\d+$/) {
|
||||
|
||||
# integral history
|
||||
my $max_messages = $self->{pbot}->{messagehistory}->{database}->get_max_messages($account, $channel);
|
||||
if ($grab_history < 1 || $grab_history > $max_messages) { return "Please choose a history between 1 and $max_messages"; }
|
||||
|
||||
$grab_history--;
|
||||
|
||||
$message = $self->{pbot}->{messagehistory}->{database}->recall_message_by_count($account, $channel, $grab_history, 'grab');
|
||||
} else {
|
||||
|
||||
# regex history
|
||||
$message = $self->{pbot}->{messagehistory}->{database}->recall_message_by_text($account, $channel, $grab_history, 'grab');
|
||||
|
||||
if (not defined $message) { return "No such message for nick $grab_nick in channel $channel containing text '$grab_history'"; }
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("$nick ($from) grabbed <$grab_nick/$channel> $message->{msg}\n");
|
||||
|
||||
if (not defined $grab_nicks) { $grab_nicks = $grab_nick; }
|
||||
else { $grab_nicks .= "+$grab_nick"; }
|
||||
|
||||
my $text = $message->{msg};
|
||||
|
||||
if (not defined $grab_text) { $grab_text = $text; }
|
||||
else {
|
||||
if ($text =~ s/^\/me\s+//) { $grab_text .= " * $grab_nick $text"; }
|
||||
else { $grab_text .= " <$grab_nick> $text"; }
|
||||
}
|
||||
}
|
||||
|
||||
my $quotegrab = {};
|
||||
$quotegrab->{nick} = $grab_nicks;
|
||||
$quotegrab->{channel} = $channel;
|
||||
$quotegrab->{timestamp} = gettimeofday;
|
||||
$quotegrab->{grabbed_by} = "$nick!$user\@$host";
|
||||
$quotegrab->{text} = validate_string($grab_text);
|
||||
$quotegrab->{id} = undef;
|
||||
|
||||
$quotegrab->{id} = $self->{database}->add_quotegrab($quotegrab);
|
||||
|
||||
if (not defined $quotegrab->{id}) { return "Failed to grab quote."; }
|
||||
|
||||
$self->export_quotegrabs();
|
||||
|
||||
my $text = $quotegrab->{text};
|
||||
($grab_nick) = split /\+/, $grab_nicks, 2;
|
||||
|
||||
if ($text =~ s/^(NICKCHANGE)\b/changed nick to/ or $text =~ s/^(KICKED|QUIT)\b/lc "$1"/e or $text =~ s/^(JOIN|PART)\b/lc "$1ed"/e) {
|
||||
|
||||
# fix ugly "[nick] quit Quit: Leaving." messages
|
||||
$text =~ s/^(quit) (.*)/$1 ($2)/;
|
||||
return "Quote grabbed: $quotegrab->{id}: $grab_nick $text";
|
||||
} elsif ($text =~ s/^\/me\s+//) {
|
||||
return "Quote grabbed: $quotegrab->{id}: * $grab_nick $text";
|
||||
} else {
|
||||
# regex history
|
||||
$message = $self->{pbot}->{messagehistory}->{database}->recall_message_by_text($account, $channel, $grab_history, 'grab');
|
||||
|
||||
if (not defined $message) {
|
||||
return "No such message for nick $grab_nick in channel $channel containing text '$grab_history'";
|
||||
}
|
||||
return "Quote grabbed: $quotegrab->{id}: <$grab_nick> $text";
|
||||
}
|
||||
|
||||
$self->{pbot}->{logger}->log("$nick ($from) grabbed <$grab_nick/$channel> $message->{msg}\n");
|
||||
|
||||
if (not defined $grab_nicks) {
|
||||
$grab_nicks = $grab_nick;
|
||||
} else {
|
||||
$grab_nicks .= "+$grab_nick";
|
||||
}
|
||||
|
||||
my $text = $message->{msg};
|
||||
|
||||
if (not defined $grab_text) {
|
||||
$grab_text = $text;
|
||||
} else {
|
||||
if ($text =~ s/^\/me\s+//) {
|
||||
$grab_text .= " * $grab_nick $text";
|
||||
} else {
|
||||
$grab_text .= " <$grab_nick> $text";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $quotegrab = {};
|
||||
$quotegrab->{nick} = $grab_nicks;
|
||||
$quotegrab->{channel} = $channel;
|
||||
$quotegrab->{timestamp} = gettimeofday;
|
||||
$quotegrab->{grabbed_by} = "$nick!$user\@$host";
|
||||
$quotegrab->{text} = validate_string($grab_text);
|
||||
$quotegrab->{id} = undef;
|
||||
|
||||
$quotegrab->{id} = $self->{database}->add_quotegrab($quotegrab);
|
||||
|
||||
if (not defined $quotegrab->{id}) {
|
||||
return "Failed to grab quote.";
|
||||
}
|
||||
|
||||
$self->export_quotegrabs();
|
||||
|
||||
my $text = $quotegrab->{text};
|
||||
($grab_nick) = split /\+/, $grab_nicks, 2;
|
||||
|
||||
if ($text =~ s/^(NICKCHANGE)\b/changed nick to/ or
|
||||
$text =~ s/^(KICKED|QUIT)\b/lc "$1"/e or
|
||||
$text =~ s/^(JOIN|PART)\b/lc "$1ed"/e) {
|
||||
# fix ugly "[nick] quit Quit: Leaving." messages
|
||||
$text =~ s/^(quit) (.*)/$1 ($2)/;
|
||||
return "Quote grabbed: $quotegrab->{id}: $grab_nick $text";
|
||||
} elsif ($text =~ s/^\/me\s+//) {
|
||||
return "Quote grabbed: $quotegrab->{id}: * $grab_nick $text";
|
||||
} else {
|
||||
return "Quote grabbed: $quotegrab->{id}: <$grab_nick> $text";
|
||||
}
|
||||
}
|
||||
|
||||
sub delete_quotegrab {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
my $quotegrab = $self->{database}->get_quotegrab($arguments);
|
||||
my $quotegrab = $self->{database}->get_quotegrab($arguments);
|
||||
|
||||
if (not defined $quotegrab) {
|
||||
return "/msg $nick No quotegrab matching id $arguments found.";
|
||||
}
|
||||
if (not defined $quotegrab) { return "/msg $nick No quotegrab matching id $arguments found."; }
|
||||
|
||||
if (not $self->{pbot}->{users}->loggedin_admin($from, "$nick!$user\@$host") and $quotegrab->{grabbed_by} ne "$nick!$user\@$host") {
|
||||
return "You are not the grabber of this quote.";
|
||||
}
|
||||
if (not $self->{pbot}->{users}->loggedin_admin($from, "$nick!$user\@$host") and $quotegrab->{grabbed_by} ne "$nick!$user\@$host") {
|
||||
return "You are not the grabber of this quote.";
|
||||
}
|
||||
|
||||
$self->{database}->delete_quotegrab($arguments);
|
||||
$self->export_quotegrabs();
|
||||
$self->{database}->delete_quotegrab($arguments);
|
||||
$self->export_quotegrabs();
|
||||
|
||||
my $text = $quotegrab->{text};
|
||||
my $text = $quotegrab->{text};
|
||||
|
||||
my ($first_nick) = split /\+/, $quotegrab->{nick}, 2;
|
||||
my ($first_nick) = split /\+/, $quotegrab->{nick}, 2;
|
||||
|
||||
if ($text =~ s/^\/me\s+//) {
|
||||
return "Deleted $arguments: * $first_nick $text";
|
||||
} else {
|
||||
return "Deleted $arguments: <$first_nick> $text";
|
||||
}
|
||||
if ($text =~ s/^\/me\s+//) { return "Deleted $arguments: * $first_nick $text"; }
|
||||
else { return "Deleted $arguments: <$first_nick> $text"; }
|
||||
}
|
||||
|
||||
sub show_quotegrab {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
my $quotegrab = $self->{database}->get_quotegrab($arguments);
|
||||
my $quotegrab = $self->{database}->get_quotegrab($arguments);
|
||||
|
||||
if (not defined $quotegrab) {
|
||||
return "/msg $nick No quotegrab matching id $arguments found.";
|
||||
}
|
||||
if (not defined $quotegrab) { return "/msg $nick No quotegrab matching id $arguments found."; }
|
||||
|
||||
my $timestamp = $quotegrab->{timestamp};
|
||||
my $ago = ago(gettimeofday - $timestamp);
|
||||
my $text = $quotegrab->{text};
|
||||
my ($first_nick) = split /\+/, $quotegrab->{nick}, 2;
|
||||
my $timestamp = $quotegrab->{timestamp};
|
||||
my $ago = ago(gettimeofday - $timestamp);
|
||||
my $text = $quotegrab->{text};
|
||||
my ($first_nick) = split /\+/, $quotegrab->{nick}, 2;
|
||||
|
||||
if ($text =~ s/^\/me\s+//) {
|
||||
return "$arguments: grabbed by $quotegrab->{grabbed_by} in $quotegrab->{channel} on " . localtime($timestamp) . " [$ago] * $first_nick $text";
|
||||
} else {
|
||||
return "$arguments: grabbed by $quotegrab->{grabbed_by} in $quotegrab->{channel} on " . localtime($timestamp) . " [$ago] <$first_nick> $text";
|
||||
}
|
||||
if ($text =~ s/^\/me\s+//) {
|
||||
return "$arguments: grabbed by $quotegrab->{grabbed_by} in $quotegrab->{channel} on " . localtime($timestamp) . " [$ago] * $first_nick $text";
|
||||
} else {
|
||||
return "$arguments: grabbed by $quotegrab->{grabbed_by} in $quotegrab->{channel} on " . localtime($timestamp) . " [$ago] <$first_nick> $text";
|
||||
}
|
||||
}
|
||||
|
||||
sub show_random_quotegrab {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my @quotes = ();
|
||||
my ($nick_search, $channel_search, $text_search);
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my @quotes = ();
|
||||
my ($nick_search, $channel_search, $text_search);
|
||||
|
||||
if (not defined $from) {
|
||||
$self->{pbot}->{logger}->log("Command missing ~from parameter!\n");
|
||||
return "";
|
||||
}
|
||||
|
||||
my $usage = 'Usage: rq [nick [channel [text]]] [-c <channel>] [-t <text>]';
|
||||
|
||||
if (defined $arguments) {
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
|
||||
my @opt_args = $self->{pbot}->{interpreter}->split_line($arguments, preserve_escapes => 1, strip_quotes => 1);
|
||||
GetOptionsFromArray(\@opt_args,
|
||||
'channel|c=s' => \$channel_search,
|
||||
'text|t=s' => \$text_search);
|
||||
|
||||
return "$getopt_error -- $usage" if defined $getopt_error;
|
||||
|
||||
$nick_search = shift @opt_args;
|
||||
$channel_search = shift @opt_args if not defined $channel_search;
|
||||
$text_search = shift @opt_args if not defined $text_search;
|
||||
|
||||
if ($nick_search =~ m/^#/) {
|
||||
my $tmp = $channel_search;
|
||||
$channel_search = $nick_search;
|
||||
$nick_search = $tmp;
|
||||
if (not defined $from) {
|
||||
$self->{pbot}->{logger}->log("Command missing ~from parameter!\n");
|
||||
return "";
|
||||
}
|
||||
|
||||
if (not defined $channel_search) {
|
||||
$channel_search = $from;
|
||||
}
|
||||
}
|
||||
my $usage = 'Usage: rq [nick [channel [text]]] [-c <channel>] [-t <text>]';
|
||||
|
||||
if (defined $channel_search and $channel_search !~ /^#/) {
|
||||
if ($channel_search eq $nick) {
|
||||
$channel_search = undef;
|
||||
} elsif ($channel_search =~ m/^\./) {
|
||||
# do nothing
|
||||
if (defined $arguments) {
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
|
||||
my @opt_args = $self->{pbot}->{interpreter}->split_line($arguments, preserve_escapes => 1, strip_quotes => 1);
|
||||
GetOptionsFromArray(
|
||||
\@opt_args,
|
||||
'channel|c=s' => \$channel_search,
|
||||
'text|t=s' => \$text_search
|
||||
);
|
||||
|
||||
return "$getopt_error -- $usage" if defined $getopt_error;
|
||||
|
||||
$nick_search = shift @opt_args;
|
||||
$channel_search = shift @opt_args if not defined $channel_search;
|
||||
$text_search = shift @opt_args if not defined $text_search;
|
||||
|
||||
if ($nick_search =~ m/^#/) {
|
||||
my $tmp = $channel_search;
|
||||
$channel_search = $nick_search;
|
||||
$nick_search = $tmp;
|
||||
}
|
||||
|
||||
if (not defined $channel_search) { $channel_search = $from; }
|
||||
}
|
||||
|
||||
if (defined $channel_search and $channel_search !~ /^#/) {
|
||||
if ($channel_search eq $nick) { $channel_search = undef; }
|
||||
elsif ($channel_search =~ m/^\./) {
|
||||
|
||||
# do nothing
|
||||
} else {
|
||||
return "$channel_search is not a valid channel.";
|
||||
}
|
||||
}
|
||||
|
||||
my $quotegrab = $self->{database}->get_random_quotegrab($nick_search, $channel_search, $text_search);
|
||||
|
||||
if (not defined $quotegrab) {
|
||||
my $result = "No quotes grabbed ";
|
||||
|
||||
if (defined $nick_search) { $result .= "for nick $nick_search "; }
|
||||
|
||||
if (defined $channel_search) { $result .= "in channel $channel_search "; }
|
||||
|
||||
if (defined $text_search) { $result .= "matching text '$text_search' "; }
|
||||
|
||||
return $result . "yet ($usage).";
|
||||
}
|
||||
|
||||
my $text = $quotegrab->{text};
|
||||
my ($first_nick) = split /\+/, $quotegrab->{nick}, 2;
|
||||
|
||||
if ($text =~ s/^\/me\s+//) {
|
||||
return "$quotegrab->{id}: " . (($channel_search eq '.*' or $quotegrab->{channel} ne $from) ? "[$quotegrab->{channel}] " : "") . "* $first_nick $text";
|
||||
} else {
|
||||
return "$channel_search is not a valid channel.";
|
||||
return "$quotegrab->{id}: " . (($channel_search eq '.*' or $quotegrab->{channel} ne $from) ? "[$quotegrab->{channel}] " : "") . "<$first_nick> $text";
|
||||
}
|
||||
}
|
||||
|
||||
my $quotegrab = $self->{database}->get_random_quotegrab($nick_search, $channel_search, $text_search);
|
||||
|
||||
if (not defined $quotegrab) {
|
||||
my $result = "No quotes grabbed ";
|
||||
|
||||
if (defined $nick_search) {
|
||||
$result .= "for nick $nick_search ";
|
||||
}
|
||||
|
||||
if (defined $channel_search) {
|
||||
$result .= "in channel $channel_search ";
|
||||
}
|
||||
|
||||
if (defined $text_search) {
|
||||
$result .= "matching text '$text_search' ";
|
||||
}
|
||||
|
||||
return $result . "yet ($usage).";;
|
||||
}
|
||||
|
||||
my $text = $quotegrab->{text};
|
||||
my ($first_nick) = split /\+/, $quotegrab->{nick}, 2;
|
||||
|
||||
if ($text =~ s/^\/me\s+//) {
|
||||
return "$quotegrab->{id}: " . (($channel_search eq '.*' or $quotegrab->{channel} ne $from) ? "[$quotegrab->{channel}] " : "") . "* $first_nick $text";
|
||||
} else {
|
||||
return "$quotegrab->{id}: " . (($channel_search eq '.*' or $quotegrab->{channel} ne $from) ? "[$quotegrab->{channel}] " : "") . "<$first_nick> $text";
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -22,155 +22,145 @@ use Getopt::Long qw(GetOptionsFromString);
|
|||
use POSIX qw(strftime);
|
||||
|
||||
sub new {
|
||||
if (ref($_[1]) eq 'HASH') {
|
||||
Carp::croak("Options to " . __FILE__ . " should be key/value pairs, not hash reference");
|
||||
}
|
||||
if (ref($_[1]) eq 'HASH') { Carp::croak("Options to " . __FILE__ . " should be key/value pairs, not hash reference"); }
|
||||
|
||||
my ($class, %conf) = @_;
|
||||
my ($class, %conf) = @_;
|
||||
|
||||
my $self = bless {}, $class;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
my $self = bless {}, $class;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
my ($self, %conf) = @_;
|
||||
|
||||
$self->{pbot} = delete $conf{pbot} // Carp::croak("Missing pbot reference in " . __FILE__);
|
||||
$self->{filename} = delete $conf{filename};
|
||||
$self->{quotegrabs} = [];
|
||||
$self->{pbot} = delete $conf{pbot} // Carp::croak("Missing pbot reference in " . __FILE__);
|
||||
$self->{filename} = delete $conf{filename};
|
||||
$self->{quotegrabs} = [];
|
||||
}
|
||||
|
||||
sub begin {
|
||||
my $self = shift;
|
||||
$self->load_quotegrabs;
|
||||
my $self = shift;
|
||||
$self->load_quotegrabs;
|
||||
}
|
||||
|
||||
sub end {
|
||||
}
|
||||
sub end { }
|
||||
|
||||
sub load_quotegrabs {
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
|
||||
if (@_) { $filename = shift; } else { $filename = $self->{filename}; }
|
||||
return if not defined $filename;
|
||||
if (@_) { $filename = shift; }
|
||||
else { $filename = $self->{filename}; }
|
||||
return if not defined $filename;
|
||||
|
||||
$self->{pbot}->{logger}->log("Loading quotegrabs from $filename ...\n");
|
||||
$self->{pbot}->{logger}->log("Loading quotegrabs from $filename ...\n");
|
||||
|
||||
open(FILE, "< $filename") or die "Couldn't open $filename: $!\n";
|
||||
my @contents = <FILE>;
|
||||
close(FILE);
|
||||
open(FILE, "< $filename") or die "Couldn't open $filename: $!\n";
|
||||
my @contents = <FILE>;
|
||||
close(FILE);
|
||||
|
||||
my $i = 0;
|
||||
foreach my $line (@contents) {
|
||||
chomp $line;
|
||||
$i++;
|
||||
my ($nick, $channel, $timestamp, $grabbed_by, $text) = split(/\s+/, $line, 5);
|
||||
if (not defined $nick || not defined $channel || not defined $timestamp
|
||||
|| not defined $grabbed_by || not defined $text) {
|
||||
die "Syntax error around line $i of $filename\n";
|
||||
my $i = 0;
|
||||
foreach my $line (@contents) {
|
||||
chomp $line;
|
||||
$i++;
|
||||
my ($nick, $channel, $timestamp, $grabbed_by, $text) = split(/\s+/, $line, 5);
|
||||
if (not defined $nick || not defined $channel || not defined $timestamp || not defined $grabbed_by || not defined $text) {
|
||||
die "Syntax error around line $i of $filename\n";
|
||||
}
|
||||
|
||||
my $quotegrab = {};
|
||||
$quotegrab->{nick} = $nick;
|
||||
$quotegrab->{channel} = $channel;
|
||||
$quotegrab->{timestamp} = $timestamp;
|
||||
$quotegrab->{grabbed_by} = $grabbed_by;
|
||||
$quotegrab->{text} = $text;
|
||||
$quotegrab->{id} = $i + 1;
|
||||
push @{$self->{quotegrabs}}, $quotegrab;
|
||||
}
|
||||
|
||||
my $quotegrab = {};
|
||||
$quotegrab->{nick} = $nick;
|
||||
$quotegrab->{channel} = $channel;
|
||||
$quotegrab->{timestamp} = $timestamp;
|
||||
$quotegrab->{grabbed_by} = $grabbed_by;
|
||||
$quotegrab->{text} = $text;
|
||||
$quotegrab->{id} = $i + 1;
|
||||
push @{ $self->{quotegrabs} }, $quotegrab;
|
||||
}
|
||||
$self->{pbot}->{logger}->log(" $i quotegrabs loaded.\n");
|
||||
$self->{pbot}->{logger}->log("Done.\n");
|
||||
$self->{pbot}->{logger}->log(" $i quotegrabs loaded.\n");
|
||||
$self->{pbot}->{logger}->log("Done.\n");
|
||||
}
|
||||
|
||||
sub save_quotegrabs {
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
my $self = shift;
|
||||
my $filename;
|
||||
|
||||
if (@_) { $filename = shift; } else { $filename = $self->{filename}; }
|
||||
return if not defined $filename;
|
||||
if (@_) { $filename = shift; }
|
||||
else { $filename = $self->{filename}; }
|
||||
return if not defined $filename;
|
||||
|
||||
open(FILE, "> $filename") or die "Couldn't open $filename: $!\n";
|
||||
open(FILE, "> $filename") or die "Couldn't open $filename: $!\n";
|
||||
|
||||
for(my $i = 0; $i <= $#{ $self->{quotegrabs} }; $i++) {
|
||||
my $quotegrab = $self->{quotegrabs}[$i];
|
||||
next if $quotegrab->{timestamp} == 0;
|
||||
print FILE "$quotegrab->{nick} $quotegrab->{channel} $quotegrab->{timestamp} $quotegrab->{grabbed_by} $quotegrab->{text}\n";
|
||||
}
|
||||
for (my $i = 0; $i <= $#{$self->{quotegrabs}}; $i++) {
|
||||
my $quotegrab = $self->{quotegrabs}[$i];
|
||||
next if $quotegrab->{timestamp} == 0;
|
||||
print FILE "$quotegrab->{nick} $quotegrab->{channel} $quotegrab->{timestamp} $quotegrab->{grabbed_by} $quotegrab->{text}\n";
|
||||
}
|
||||
|
||||
close(FILE);
|
||||
close(FILE);
|
||||
}
|
||||
|
||||
sub add_quotegrab {
|
||||
my ($self, $quotegrab) = @_;
|
||||
my ($self, $quotegrab) = @_;
|
||||
|
||||
push @{ $self->{quotegrabs} }, $quotegrab;
|
||||
$self->save_quotegrabs();
|
||||
return $#{ $self->{quotegrabs} } + 1;
|
||||
push @{$self->{quotegrabs}}, $quotegrab;
|
||||
$self->save_quotegrabs();
|
||||
return $#{$self->{quotegrabs}} + 1;
|
||||
}
|
||||
|
||||
sub delete_quotegrab {
|
||||
my ($self, $id) = @_;
|
||||
my ($self, $id) = @_;
|
||||
|
||||
if ($id < 1 || $id > $#{ $self->{quotegrabs} } + 1) {
|
||||
return undef;
|
||||
}
|
||||
if ($id < 1 || $id > $#{$self->{quotegrabs}} + 1) { return undef; }
|
||||
|
||||
splice @{ $self->{quotegrabs} }, $id - 1, 1;
|
||||
splice @{$self->{quotegrabs}}, $id - 1, 1;
|
||||
|
||||
for(my $i = $id - 1; $i <= $#{ $self->{quotegrabs} }; $i++ ) {
|
||||
$self->{quotegrabs}[$i]->{id}--;
|
||||
}
|
||||
for (my $i = $id - 1; $i <= $#{$self->{quotegrabs}}; $i++) { $self->{quotegrabs}[$i]->{id}--; }
|
||||
|
||||
$self->save_quotegrabs();
|
||||
$self->save_quotegrabs();
|
||||
}
|
||||
|
||||
sub get_quotegrab {
|
||||
my ($self, $id) = @_;
|
||||
my ($self, $id) = @_;
|
||||
|
||||
if ($id < 1 || $id > $#{ $self->{quotegrabs} } + 1) {
|
||||
return undef;
|
||||
}
|
||||
if ($id < 1 || $id > $#{$self->{quotegrabs}} + 1) { return undef; }
|
||||
|
||||
return $self->{quotegrabs}[$id - 1];
|
||||
return $self->{quotegrabs}[$id - 1];
|
||||
}
|
||||
|
||||
sub get_random_quotegrab {
|
||||
my ($self, $nick, $channel, $text) = @_;
|
||||
my ($self, $nick, $channel, $text) = @_;
|
||||
|
||||
$nick = '.*' if not defined $nick;
|
||||
$channel = '.*' if not defined $channel;
|
||||
$text = '.*' if not defined $text;
|
||||
$nick = '.*' if not defined $nick;
|
||||
$channel = '.*' if not defined $channel;
|
||||
$text = '.*' if not defined $text;
|
||||
|
||||
my @quotes;
|
||||
my @quotes;
|
||||
|
||||
eval {
|
||||
for(my $i = 0; $i <= $#{ $self->{quotegrabs} }; $i++) {
|
||||
my $hash = $self->{quotegrabs}[$i];
|
||||
if ($hash->{channel} =~ /$channel/i && $hash->{nick} =~ /$nick/i && $hash->{text} =~ /$text/i) {
|
||||
$hash->{id} = $i + 1;
|
||||
push @quotes, $hash;
|
||||
}
|
||||
eval {
|
||||
for (my $i = 0; $i <= $#{$self->{quotegrabs}}; $i++) {
|
||||
my $hash = $self->{quotegrabs}[$i];
|
||||
if ($hash->{channel} =~ /$channel/i && $hash->{nick} =~ /$nick/i && $hash->{text} =~ /$text/i) {
|
||||
$hash->{id} = $i + 1;
|
||||
push @quotes, $hash;
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Error in show_random_quotegrab parameters: $@\n");
|
||||
return undef;
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Error in show_random_quotegrab parameters: $@\n");
|
||||
return undef;
|
||||
}
|
||||
if ($#quotes < 0) { return undef; }
|
||||
|
||||
if ($#quotes < 0) {
|
||||
return undef;
|
||||
}
|
||||
|
||||
return $quotes[int rand($#quotes + 1)];
|
||||
return $quotes[int rand($#quotes + 1)];
|
||||
}
|
||||
|
||||
sub get_all_quotegrabs {
|
||||
my $self = shift;
|
||||
return $self->{quotegrabs};
|
||||
my $self = shift;
|
||||
return $self->{quotegrabs};
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -18,33 +18,31 @@ use DBI;
|
|||
use Carp qw(shortmess);
|
||||
|
||||
sub new {
|
||||
if (ref($_[1]) eq 'HASH') {
|
||||
Carp::croak("Options to " . __FILE__ . " should be key/value pairs, not hash reference");
|
||||
}
|
||||
if (ref($_[1]) eq 'HASH') { Carp::croak("Options to " . __FILE__ . " should be key/value pairs, not hash reference"); }
|
||||
|
||||
my ($class, %conf) = @_;
|
||||
my ($class, %conf) = @_;
|
||||
|
||||
my $self = bless {}, $class;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
my $self = bless {}, $class;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
my ($self, %conf) = @_;
|
||||
|
||||
$self->{pbot} = delete $conf{pbot} // Carp::croak("Missing pbot reference in " . __FILE__);
|
||||
$self->{filename} = delete $conf{filename};
|
||||
$self->{pbot} = delete $conf{pbot} // Carp::croak("Missing pbot reference in " . __FILE__);
|
||||
$self->{filename} = delete $conf{filename};
|
||||
}
|
||||
|
||||
sub begin {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
$self->{pbot}->{logger}->log("Opening quotegrabs SQLite database: $self->{filename}\n");
|
||||
$self->{pbot}->{logger}->log("Opening quotegrabs SQLite database: $self->{filename}\n");
|
||||
|
||||
$self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", { RaiseError => 1, PrintError => 0, sqlite_unicode => 1 }) or die $DBI::errstr;
|
||||
$self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", {RaiseError => 1, PrintError => 0, sqlite_unicode => 1}) or die $DBI::errstr;
|
||||
|
||||
eval {
|
||||
$self->{dbh}->do(<< 'SQL');
|
||||
eval {
|
||||
$self->{dbh}->do(<< 'SQL');
|
||||
CREATE TABLE IF NOT EXISTS Quotegrabs (
|
||||
id INTEGER PRIMARY KEY,
|
||||
nick TEXT,
|
||||
|
|
@ -54,126 +52,126 @@ CREATE TABLE IF NOT EXISTS Quotegrabs (
|
|||
timestamp NUMERIC
|
||||
)
|
||||
SQL
|
||||
};
|
||||
};
|
||||
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
}
|
||||
|
||||
sub end {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
$self->{pbot}->{logger}->log("Closing quotegrabs SQLite database\n");
|
||||
$self->{pbot}->{logger}->log("Closing quotegrabs SQLite database\n");
|
||||
|
||||
if (exists $self->{dbh} and defined $self->{dbh}) {
|
||||
$self->{dbh}->disconnect();
|
||||
delete $self->{dbh};
|
||||
}
|
||||
if (exists $self->{dbh} and defined $self->{dbh}) {
|
||||
$self->{dbh}->disconnect();
|
||||
delete $self->{dbh};
|
||||
}
|
||||
}
|
||||
|
||||
sub add_quotegrab {
|
||||
my ($self, $quotegrab) = @_;
|
||||
my ($self, $quotegrab) = @_;
|
||||
|
||||
my $id = eval {
|
||||
my $sth = $self->{dbh}->prepare('INSERT INTO Quotegrabs VALUES (?, ?, ?, ?, ?, ?)');
|
||||
$sth->bind_param(1, undef);
|
||||
$sth->bind_param(2, $quotegrab->{nick});
|
||||
$sth->bind_param(3, $quotegrab->{channel});
|
||||
$sth->bind_param(4, $quotegrab->{grabbed_by});
|
||||
$sth->bind_param(5, $quotegrab->{text});
|
||||
$sth->bind_param(6, $quotegrab->{timestamp});
|
||||
$sth->execute();
|
||||
my $id = eval {
|
||||
my $sth = $self->{dbh}->prepare('INSERT INTO Quotegrabs VALUES (?, ?, ?, ?, ?, ?)');
|
||||
$sth->bind_param(1, undef);
|
||||
$sth->bind_param(2, $quotegrab->{nick});
|
||||
$sth->bind_param(3, $quotegrab->{channel});
|
||||
$sth->bind_param(4, $quotegrab->{grabbed_by});
|
||||
$sth->bind_param(5, $quotegrab->{text});
|
||||
$sth->bind_param(6, $quotegrab->{timestamp});
|
||||
$sth->execute();
|
||||
|
||||
return $self->{dbh}->sqlite_last_insert_rowid();
|
||||
};
|
||||
return $self->{dbh}->sqlite_last_insert_rowid();
|
||||
};
|
||||
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
return $id;
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
return $id;
|
||||
}
|
||||
|
||||
sub get_quotegrab {
|
||||
my ($self, $id) = @_;
|
||||
my ($self, $id) = @_;
|
||||
|
||||
my $quotegrab = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * FROM Quotegrabs WHERE id == ?');
|
||||
$sth->bind_param(1, $id);
|
||||
$sth->execute();
|
||||
return $sth->fetchrow_hashref();
|
||||
};
|
||||
my $quotegrab = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * FROM Quotegrabs WHERE id == ?');
|
||||
$sth->bind_param(1, $id);
|
||||
$sth->execute();
|
||||
return $sth->fetchrow_hashref();
|
||||
};
|
||||
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
return $quotegrab;
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
return $quotegrab;
|
||||
}
|
||||
|
||||
sub get_random_quotegrab {
|
||||
my ($self, $nick, $channel, $text) = @_;
|
||||
my ($self, $nick, $channel, $text) = @_;
|
||||
|
||||
$nick =~ s/\.?\*\??/%/g if defined $nick;
|
||||
$channel =~ s/\.?\*\??/%/g if defined $channel;
|
||||
$text =~ s/\.?\*\??/%/g if defined $text;
|
||||
$nick =~ s/\.?\*\??/%/g if defined $nick;
|
||||
$channel =~ s/\.?\*\??/%/g if defined $channel;
|
||||
$text =~ s/\.?\*\??/%/g if defined $text;
|
||||
|
||||
$nick =~ s/\./_/g if defined $nick;
|
||||
$channel =~ s/\./_/g if defined $channel;
|
||||
$text =~ s/\./_/g if defined $text;
|
||||
$nick =~ s/\./_/g if defined $nick;
|
||||
$channel =~ s/\./_/g if defined $channel;
|
||||
$text =~ s/\./_/g if defined $text;
|
||||
|
||||
my $quotegrab = eval {
|
||||
my $sql = 'SELECT * FROM Quotegrabs ';
|
||||
my @params;
|
||||
my $where = 'WHERE ';
|
||||
my $and = '';
|
||||
my $quotegrab = eval {
|
||||
my $sql = 'SELECT * FROM Quotegrabs ';
|
||||
my @params;
|
||||
my $where = 'WHERE ';
|
||||
my $and = '';
|
||||
|
||||
if (defined $nick) {
|
||||
$sql .= $where . 'nick LIKE ? ';
|
||||
push @params, "$nick";
|
||||
$where = '';
|
||||
$and = 'AND ';
|
||||
}
|
||||
if (defined $nick) {
|
||||
$sql .= $where . 'nick LIKE ? ';
|
||||
push @params, "$nick";
|
||||
$where = '';
|
||||
$and = 'AND ';
|
||||
}
|
||||
|
||||
if (defined $channel) {
|
||||
$sql .= $where . $and . 'channel LIKE ? ';
|
||||
push @params, $channel;
|
||||
$where = '';
|
||||
$and = 'AND ';
|
||||
}
|
||||
if (defined $channel) {
|
||||
$sql .= $where . $and . 'channel LIKE ? ';
|
||||
push @params, $channel;
|
||||
$where = '';
|
||||
$and = 'AND ';
|
||||
}
|
||||
|
||||
if (defined $text) {
|
||||
$sql .= $where . $and . 'text LIKE ? ';
|
||||
push @params, "%$text%";
|
||||
}
|
||||
if (defined $text) {
|
||||
$sql .= $where . $and . 'text LIKE ? ';
|
||||
push @params, "%$text%";
|
||||
}
|
||||
|
||||
$sql .= 'ORDER BY RANDOM() LIMIT 1';
|
||||
$sql .= 'ORDER BY RANDOM() LIMIT 1';
|
||||
|
||||
my $sth = $self->{dbh}->prepare($sql);
|
||||
$sth->execute(@params);
|
||||
return $sth->fetchrow_hashref();
|
||||
};
|
||||
my $sth = $self->{dbh}->prepare($sql);
|
||||
$sth->execute(@params);
|
||||
return $sth->fetchrow_hashref();
|
||||
};
|
||||
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
return $quotegrab;
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
return $quotegrab;
|
||||
}
|
||||
|
||||
sub get_all_quotegrabs {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
my $quotegrabs = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * from Quotegrabs');
|
||||
$sth->execute();
|
||||
return $sth->fetchall_arrayref({});
|
||||
};
|
||||
my $quotegrabs = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * from Quotegrabs');
|
||||
$sth->execute();
|
||||
return $sth->fetchall_arrayref({});
|
||||
};
|
||||
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
return $quotegrabs;
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
return $quotegrabs;
|
||||
}
|
||||
|
||||
sub delete_quotegrab {
|
||||
my ($self, $id) = @_;
|
||||
my ($self, $id) = @_;
|
||||
|
||||
eval {
|
||||
my $sth = $self->{dbh}->prepare('DELETE FROM Quotegrabs WHERE id == ?');
|
||||
$sth->bind_param(1, $id);
|
||||
$sth->execute();
|
||||
};
|
||||
eval {
|
||||
my $sth = $self->{dbh}->prepare('DELETE FROM Quotegrabs WHERE id == ?');
|
||||
$sth->bind_param(1, $id);
|
||||
$sth->execute();
|
||||
};
|
||||
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -8,116 +8,118 @@ use feature 'unicode_strings';
|
|||
use Time::HiRes qw/gettimeofday/;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
$self->{queue} = [];
|
||||
$self->{notified} = {};
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_queue }, 1, 'RelayUnreg');
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
$self->{queue} = [];
|
||||
$self->{notified} = {};
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_queue }, 1, 'RelayUnreg');
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
$self->{pbot}->{timer}->unregister('RelayUnreg');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
my $self = shift;
|
||||
$self->{pbot}->{timer}->unregister('RelayUnreg');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
}
|
||||
|
||||
sub on_public {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = lc $event->{event}->{to}[0];
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = lc $event->{event}->{to}[0];
|
||||
|
||||
$msg =~ s/^\s+|\s+$//g;
|
||||
return 0 if not length $msg;
|
||||
$msg =~ s/^\s+|\s+$//g;
|
||||
return 0 if not length $msg;
|
||||
|
||||
# exit if channel hasn't muted $~a
|
||||
return 0 if not exists $self->{pbot}->{bantracker}->{banlist}->{$channel}->{'+q'}->{'$~a'};
|
||||
# exit if channel hasn't muted $~a
|
||||
return 0 if not exists $self->{pbot}->{bantracker}->{banlist}->{$channel}->{'+q'}->{'$~a'};
|
||||
|
||||
# exit if channel isn't +z
|
||||
my $chanmodes = $self->{pbot}->{channels}->get_meta($channel, 'MODE');
|
||||
return 0 if not defined $chanmodes or not $chanmodes =~ m/z/;
|
||||
# exit if channel isn't +z
|
||||
my $chanmodes = $self->{pbot}->{channels}->get_meta($channel, 'MODE');
|
||||
return 0 if not defined $chanmodes or not $chanmodes =~ m/z/;
|
||||
|
||||
my $account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
my $nickserv = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($account);
|
||||
my $account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
my $nickserv = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($account);
|
||||
|
||||
# debug
|
||||
# my $nickserv_text = $nickserv ? "is logged into $nickserv" : "is not logged in";
|
||||
# $self->{pbot}->{logger}->log("RelayUnreg: $nick!$user\@$host ($account) $nickserv_text.\n");
|
||||
# debug
|
||||
# my $nickserv_text = $nickserv ? "is logged into $nickserv" : "is not logged in";
|
||||
# $self->{pbot}->{logger}->log("RelayUnreg: $nick!$user\@$host ($account) $nickserv_text.\n");
|
||||
|
||||
# exit if user is identified
|
||||
return 0 if defined $nickserv && length $nickserv;
|
||||
# exit if user is identified
|
||||
return 0 if defined $nickserv && length $nickserv;
|
||||
|
||||
my @filters = (
|
||||
qr{https://bryanostergaard.com/},
|
||||
qr{https://encyclopediadramatica.rs/Freenodegate},
|
||||
qr{https://MattSTrout.com/},
|
||||
qr{Contact me on twitter},
|
||||
qr{At the beginning there was only Chaos},
|
||||
qr{https://williampitcock.com/},
|
||||
qr{Achievement Method},
|
||||
qr{perceived death signal},
|
||||
qr{efnet},
|
||||
qr{https://evestigatorsucks.com},
|
||||
qr{eVestigator},
|
||||
);
|
||||
my @filters = (
|
||||
qr{https://bryanostergaard.com/},
|
||||
qr{https://encyclopediadramatica.rs/Freenodegate},
|
||||
qr{https://MattSTrout.com/},
|
||||
qr{Contact me on twitter},
|
||||
qr{At the beginning there was only Chaos},
|
||||
qr{https://williampitcock.com/},
|
||||
qr{Achievement Method},
|
||||
qr{perceived death signal},
|
||||
qr{efnet},
|
||||
qr{https://evestigatorsucks.com},
|
||||
qr{eVestigator},
|
||||
);
|
||||
|
||||
# don't notify/relay for spammers
|
||||
foreach my $filter (@filters) {
|
||||
if ($msg =~ m/$filter/i) {
|
||||
$self->{pbot}->{logger}->log("RelayUnreg: Ignoring filtered message.\n");
|
||||
return 0;
|
||||
# don't notify/relay for spammers
|
||||
foreach my $filter (@filters) {
|
||||
if ($msg =~ m/$filter/i) {
|
||||
$self->{pbot}->{logger}->log("RelayUnreg: Ignoring filtered message.\n");
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# don't notify/relay for spammers
|
||||
return 0 if $self->{pbot}->{antispam}->is_spam($channel, $msg, 1);
|
||||
# don't notify/relay for spammers
|
||||
return 0 if $self->{pbot}->{antispam}->is_spam($channel, $msg, 1);
|
||||
|
||||
# don't notify/relay if user is voiced
|
||||
return 0 if $self->{pbot}->{nicklist}->get_meta($channel, $nick, '+v');
|
||||
# don't notify/relay if user is voiced
|
||||
return 0 if $self->{pbot}->{nicklist}->get_meta($channel, $nick, '+v');
|
||||
|
||||
unless (exists $self->{notified}->{lc $nick}) {
|
||||
$self->{pbot}->{logger}->log("RelayUnreg: Notifying $nick to register with NickServ in $channel.\n");
|
||||
$event->{conn}->privmsg($nick, "Please register your nick to speak in $channel. See https://freenode.net/kb/answer/registration and https://freenode.net/kb/answer/sasl");
|
||||
$self->{notified}->{lc $nick} = gettimeofday;
|
||||
}
|
||||
unless (exists $self->{notified}->{lc $nick}) {
|
||||
$self->{pbot}->{logger}->log("RelayUnreg: Notifying $nick to register with NickServ in $channel.\n");
|
||||
$event->{conn}->privmsg($nick, "Please register your nick to speak in $channel. See https://freenode.net/kb/answer/registration and https://freenode.net/kb/answer/sasl");
|
||||
$self->{notified}->{lc $nick} = gettimeofday;
|
||||
}
|
||||
|
||||
# don't relay unregistered chat unless enabled
|
||||
return 0 if not $self->{pbot}->{registry}->get_value($channel, 'relay_unregistered_chat');
|
||||
# don't relay unregistered chat unless enabled
|
||||
return 0 if not $self->{pbot}->{registry}->get_value($channel, 'relay_unregistered_chat');
|
||||
|
||||
# add message to delay send queue to see if Sigyn kills them first (or if they leave)
|
||||
$self->{pbot}->{logger}->log("RelayUnreg: Queuing unregistered message for $channel: <$nick> $msg\n");
|
||||
push @{$self->{queue}}, [gettimeofday + 10, $channel, $nick, $user, $host, $msg];
|
||||
# add message to delay send queue to see if Sigyn kills them first (or if they leave)
|
||||
$self->{pbot}->{logger}->log("RelayUnreg: Queuing unregistered message for $channel: <$nick> $msg\n");
|
||||
push @{$self->{queue}}, [gettimeofday + 10, $channel, $nick, $user, $host, $msg];
|
||||
|
||||
return 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub check_queue {
|
||||
my $self = shift;
|
||||
my $now = gettimeofday;
|
||||
my $self = shift;
|
||||
my $now = gettimeofday;
|
||||
|
||||
if (@{$self->{queue}}) {
|
||||
my ($time, $channel, $nick, $user, $host, $msg) = @{$self->{queue}->[0]};
|
||||
if (@{$self->{queue}}) {
|
||||
my ($time, $channel, $nick, $user, $host, $msg) = @{$self->{queue}->[0]};
|
||||
|
||||
if ($now >= $time) {
|
||||
# if nick is still present in channel, send the message
|
||||
if ($self->{pbot}->{nicklist}->is_present($channel, $nick)) {
|
||||
# ensure they're not banned (+z allows us to see +q/+b messages as normal ones)
|
||||
my $banned = $self->{pbot}->{bantracker}->is_banned($nick, $user, $host, $channel);
|
||||
$self->{pbot}->{logger}->log("[RelayUnreg] $nick!$user\@$host $banned->{mode} as $banned->{banmask} in $banned->{channel} by $banned->{owner}, not relaying unregistered message\n") if $banned;
|
||||
$self->{pbot}->{conn}->privmsg($channel, "(unreg) <$nick> $msg") unless $banned;
|
||||
}
|
||||
shift @{$self->{queue}};
|
||||
if ($now >= $time) {
|
||||
|
||||
# if nick is still present in channel, send the message
|
||||
if ($self->{pbot}->{nicklist}->is_present($channel, $nick)) {
|
||||
|
||||
# ensure they're not banned (+z allows us to see +q/+b messages as normal ones)
|
||||
my $banned = $self->{pbot}->{bantracker}->is_banned($nick, $user, $host, $channel);
|
||||
$self->{pbot}->{logger}
|
||||
->log("[RelayUnreg] $nick!$user\@$host $banned->{mode} as $banned->{banmask} in $banned->{channel} by $banned->{owner}, not relaying unregistered message\n")
|
||||
if $banned;
|
||||
$self->{pbot}->{conn}->privmsg($channel, "(unreg) <$nick> $msg") unless $banned;
|
||||
}
|
||||
shift @{$self->{queue}};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# check notification timeouts here too, why not?
|
||||
if (keys %{$self->{notified}}) {
|
||||
my $timeout = gettimeofday - 60 * 15;
|
||||
foreach my $nick (keys %{$self->{notified}}) {
|
||||
if ($self->{notified}->{$nick} <= $timeout) {
|
||||
delete $self->{notified}->{$nick};
|
||||
}
|
||||
# check notification timeouts here too, why not?
|
||||
if (keys %{$self->{notified}}) {
|
||||
my $timeout = gettimeofday - 60 * 15;
|
||||
foreach my $nick (keys %{$self->{notified}}) {
|
||||
if ($self->{notified}->{$nick} <= $timeout) { delete $self->{notified}->{$nick}; }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -17,27 +17,27 @@ use Time::HiRes qw/gettimeofday/;
|
|||
use Getopt::Long qw(GetOptionsFromString);
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->remindme(@_) }, 'remindme', 0);
|
||||
$self->{filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/reminders.sqlite3';
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_reminders(@_) }, 1, 'RemindMe');
|
||||
$self->dbi_begin;
|
||||
$self->create_database;
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->remindme(@_) }, 'remindme', 0);
|
||||
$self->{filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/reminders.sqlite3';
|
||||
$self->{pbot}->{timer}->register(sub { $self->check_reminders(@_) }, 1, 'RemindMe');
|
||||
$self->dbi_begin;
|
||||
$self->create_database;
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
$self->dbi_end;
|
||||
$self->{pbot}->{commands}->unregister('remindme');
|
||||
$self->{pbot}->{timer}->unregister('RemindMe');
|
||||
my $self = shift;
|
||||
$self->dbi_end;
|
||||
$self->{pbot}->{commands}->unregister('remindme');
|
||||
$self->{pbot}->{timer}->unregister('RemindMe');
|
||||
}
|
||||
|
||||
sub create_database {
|
||||
my $self = shift;
|
||||
return if not $self->{dbh};
|
||||
my $self = shift;
|
||||
return if not $self->{dbh};
|
||||
|
||||
eval {
|
||||
$self->{dbh}->do(<<SQL);
|
||||
eval {
|
||||
$self->{dbh}->do(<<SQL);
|
||||
CREATE TABLE IF NOT EXISTS Reminders (
|
||||
id INTEGER PRIMARY KEY,
|
||||
account TEXT,
|
||||
|
|
@ -50,340 +50,305 @@ CREATE TABLE IF NOT EXISTS Reminders (
|
|||
created_by TEXT
|
||||
)
|
||||
SQL
|
||||
};
|
||||
};
|
||||
|
||||
$self->{pbot}->{logger}->log("RemindMe: create database failed: $@") if $@;
|
||||
$self->{pbot}->{logger}->log("RemindMe: create database failed: $@") if $@;
|
||||
}
|
||||
|
||||
sub dbi_begin {
|
||||
my ($self) = @_;
|
||||
eval {
|
||||
$self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", { RaiseError => 1, PrintError => 0, AutoInactiveDestroy => 1, sqlite_unicode => 1 }) or die $DBI::errstr;
|
||||
};
|
||||
my ($self) = @_;
|
||||
eval {
|
||||
$self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", {RaiseError => 1, PrintError => 0, AutoInactiveDestroy => 1, sqlite_unicode => 1})
|
||||
or die $DBI::errstr;
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Error opening RemindMe database: $@");
|
||||
delete $self->{dbh};
|
||||
return 0;
|
||||
} else {
|
||||
return 1;
|
||||
}
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Error opening RemindMe database: $@");
|
||||
delete $self->{dbh};
|
||||
return 0;
|
||||
} else {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub dbi_end {
|
||||
my ($self) = @_;
|
||||
return if not $self->{dbh};
|
||||
$self->{dbh}->disconnect;
|
||||
delete $self->{dbh};
|
||||
my ($self) = @_;
|
||||
return if not $self->{dbh};
|
||||
$self->{dbh}->disconnect;
|
||||
delete $self->{dbh};
|
||||
}
|
||||
|
||||
sub add_reminder {
|
||||
my ($self, $account, $target, $text, $alarm, $duration, $repeat, $owner) = @_;
|
||||
my ($self, $account, $target, $text, $alarm, $duration, $repeat, $owner) = @_;
|
||||
|
||||
eval {
|
||||
my $sth = $self->{dbh}->prepare('INSERT INTO Reminders (account, target, text, alarm, duration, repeat, created_on, created_by) VALUES (?, ?, ?, ?, ?, ?, ?, ?)');
|
||||
$sth->execute($account, $target, $text, $alarm, $duration, $repeat, scalar gettimeofday, $owner);
|
||||
};
|
||||
eval {
|
||||
my $sth = $self->{dbh}->prepare('INSERT INTO Reminders (account, target, text, alarm, duration, repeat, created_on, created_by) VALUES (?, ?, ?, ?, ?, ?, ?, ?)');
|
||||
$sth->execute($account, $target, $text, $alarm, $duration, $repeat, scalar gettimeofday, $owner);
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Add reminder failed: $@");
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Add reminder failed: $@");
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub update_reminder {
|
||||
my ($self, $id, $data) = @_;
|
||||
my ($self, $id, $data) = @_;
|
||||
|
||||
eval {
|
||||
my $sql = 'UPDATE Reminders SET ';
|
||||
|
||||
eval {
|
||||
my $sql = 'UPDATE Reminders SET ';
|
||||
my $comma = '';
|
||||
foreach my $key (keys %$data) {
|
||||
$sql .= "$comma$key = ?";
|
||||
$comma = ', ';
|
||||
}
|
||||
|
||||
my $comma = '';
|
||||
foreach my $key (keys %$data) {
|
||||
$sql .= "$comma$key = ?";
|
||||
$comma = ', ';
|
||||
}
|
||||
$sql .= ' WHERE id = ?';
|
||||
|
||||
$sql .= ' WHERE id = ?';
|
||||
my $sth = $self->{dbh}->prepare($sql);
|
||||
|
||||
my $sth = $self->{dbh}->prepare($sql);
|
||||
my $param = 1;
|
||||
foreach my $key (keys %$data) { $sth->bind_param($param++, $data->{$key}); }
|
||||
|
||||
my $param = 1;
|
||||
foreach my $key (keys %$data) {
|
||||
$sth->bind_param($param++, $data->{$key});
|
||||
}
|
||||
|
||||
$sth->bind_param($param++, $id);
|
||||
$sth->execute();
|
||||
};
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
$sth->bind_param($param++, $id);
|
||||
$sth->execute();
|
||||
};
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
}
|
||||
|
||||
sub get_reminder {
|
||||
my ($self, $id) = @_;
|
||||
my ($self, $id) = @_;
|
||||
|
||||
my $reminder = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * FROM Reminders WHERE id = ?');
|
||||
$sth->execute($id);
|
||||
return $sth->fetchrow_hashref();
|
||||
};
|
||||
my $reminder = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * FROM Reminders WHERE id = ?');
|
||||
$sth->execute($id);
|
||||
return $sth->fetchrow_hashref();
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("List reminders failed: $@");
|
||||
return undef;
|
||||
}
|
||||
return $reminder;
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("List reminders failed: $@");
|
||||
return undef;
|
||||
}
|
||||
return $reminder;
|
||||
}
|
||||
|
||||
sub get_reminders {
|
||||
my ($self, $account) = @_;
|
||||
my ($self, $account) = @_;
|
||||
|
||||
my $reminders = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * FROM Reminders WHERE account = ? ORDER BY id');
|
||||
$sth->execute($account);
|
||||
return $sth->fetchall_arrayref({});
|
||||
};
|
||||
my $reminders = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * FROM Reminders WHERE account = ? ORDER BY id');
|
||||
$sth->execute($account);
|
||||
return $sth->fetchall_arrayref({});
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("List reminders failed: $@");
|
||||
return [];
|
||||
}
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("List reminders failed: $@");
|
||||
return [];
|
||||
}
|
||||
|
||||
return $reminders;
|
||||
return $reminders;
|
||||
}
|
||||
|
||||
sub delete_reminder {
|
||||
my ($self, $id) = @_;
|
||||
return if not $self->{dbh};
|
||||
my ($self, $id) = @_;
|
||||
return if not $self->{dbh};
|
||||
|
||||
eval {
|
||||
my $sth = $self->{dbh}->prepare('DELETE FROM Reminders WHERE id = ?');
|
||||
$sth->execute($id);
|
||||
};
|
||||
eval {
|
||||
my $sth = $self->{dbh}->prepare('DELETE FROM Reminders WHERE id = ?');
|
||||
$sth->execute($id);
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Delete reminder $id failed: $@");
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Delete reminder $id failed: $@");
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub remindme {
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments) = @_;
|
||||
|
||||
if (not $self->{dbh}) {
|
||||
return "Internal error.";
|
||||
}
|
||||
if (not $self->{dbh}) { return "Internal error."; }
|
||||
|
||||
my $usage = "Usage: remindme [-c channel] [-r count] message -t time | remindme -l [nick] | remindme -d id";
|
||||
my $usage = "Usage: remindme [-c channel] [-r count] message -t time | remindme -l [nick] | remindme -d id";
|
||||
|
||||
return $usage if not length $arguments;
|
||||
return $usage if not length $arguments;
|
||||
|
||||
my ($target, $repeat, $text, $alarm, $list_reminders, $delete_id);
|
||||
my ($target, $repeat, $text, $alarm, $list_reminders, $delete_id);
|
||||
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
|
||||
Getopt::Long::Configure ("bundling");
|
||||
Getopt::Long::Configure("bundling");
|
||||
|
||||
$arguments =~ s/(?<!\\)'/\\'/g;
|
||||
my ($ret, $args) = GetOptionsFromString($arguments,
|
||||
'r:i' => \$repeat,
|
||||
't:s' => \$alarm,
|
||||
'c:s' => \$target,
|
||||
'm:s' => \$text,
|
||||
'l:s' => \$list_reminders,
|
||||
'd:i' => \$delete_id);
|
||||
$arguments =~ s/(?<!\\)'/\\'/g;
|
||||
my ($ret, $args) = GetOptionsFromString(
|
||||
$arguments,
|
||||
'r:i' => \$repeat,
|
||||
't:s' => \$alarm,
|
||||
'c:s' => \$target,
|
||||
'm:s' => \$text,
|
||||
'l:s' => \$list_reminders,
|
||||
'd:i' => \$delete_id
|
||||
);
|
||||
|
||||
return "$getopt_error -- $usage" if defined $getopt_error;
|
||||
return "$getopt_error -- $usage" if defined $getopt_error;
|
||||
|
||||
if (defined $list_reminders) {
|
||||
my $nick_override = $list_reminders if length $list_reminders;
|
||||
my $account;
|
||||
if ($nick_override) {
|
||||
my $hostmask;
|
||||
($account, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick_override);
|
||||
if (defined $list_reminders) {
|
||||
my $nick_override = $list_reminders if length $list_reminders;
|
||||
my $account;
|
||||
if ($nick_override) {
|
||||
my $hostmask;
|
||||
($account, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick_override);
|
||||
|
||||
if (not $account) {
|
||||
return "I don't know anybody named $nick_override.";
|
||||
}
|
||||
if (not $account) { return "I don't know anybody named $nick_override."; }
|
||||
|
||||
($nick_override) = $hostmask =~ m/^([^!]+)!/;
|
||||
} else {
|
||||
$account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
}
|
||||
$account = $self->{pbot}->{messagehistory}->{database}->get_ancestor_id($account);
|
||||
($nick_override) = $hostmask =~ m/^([^!]+)!/;
|
||||
} else {
|
||||
$account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
}
|
||||
$account = $self->{pbot}->{messagehistory}->{database}->get_ancestor_id($account);
|
||||
|
||||
my $reminders = $self->get_reminders($account);
|
||||
my $count = 0;
|
||||
my $text = '';
|
||||
my $now = scalar gettimeofday;
|
||||
my $reminders = $self->get_reminders($account);
|
||||
my $count = 0;
|
||||
my $text = '';
|
||||
my $now = scalar gettimeofday;
|
||||
|
||||
foreach my $reminder (@$reminders) {
|
||||
my $duration = concise duration $reminder->{alarm} - $now;
|
||||
$text .= "$reminder->{id}) [in $duration]";
|
||||
$text .= " ($reminder->{repeat} repeats left)" if $reminder->{repeat};
|
||||
$text .= " $reminder->{text}\n";
|
||||
$count++;
|
||||
foreach my $reminder (@$reminders) {
|
||||
my $duration = concise duration $reminder->{alarm} - $now;
|
||||
$text .= "$reminder->{id}) [in $duration]";
|
||||
$text .= " ($reminder->{repeat} repeats left)" if $reminder->{repeat};
|
||||
$text .= " $reminder->{text}\n";
|
||||
$count++;
|
||||
}
|
||||
|
||||
if (not $count) {
|
||||
if ($nick_override) { return "$nick_override has no reminders."; }
|
||||
else { return "You have no reminders."; }
|
||||
}
|
||||
|
||||
$reminders = $count == 1 ? 'reminder' : 'reminders';
|
||||
return "$count $reminders: $text";
|
||||
}
|
||||
|
||||
if (not $count) {
|
||||
if ($nick_override) {
|
||||
return "$nick_override has no reminders.";
|
||||
} else {
|
||||
return "You have no reminders.";
|
||||
}
|
||||
if ($delete_id) {
|
||||
my $admininfo = $self->{pbot}->{users}->loggedin_admin($target ? $target : $from, "$nick!$user\@$host");
|
||||
|
||||
# admins can delete any reminders (perhaps check admin levels against owner level?)
|
||||
if ($admininfo) {
|
||||
if (not $self->get_reminder($delete_id)) { return "Reminder $delete_id does not exist."; }
|
||||
|
||||
if ($self->delete_reminder($delete_id)) { return "Reminder $delete_id deleted."; }
|
||||
else { return "Could not delete reminder $delete_id."; }
|
||||
}
|
||||
|
||||
my $account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
$account = $self->{pbot}->{messagehistory}->{database}->get_ancestor_id($account);
|
||||
my $reminder = $self->get_reminder($delete_id);
|
||||
|
||||
if (not $reminder) { return "Reminder $delete_id does not exist."; }
|
||||
|
||||
if ($reminder->{account} != $account) { return "Reminder $delete_id does not belong to you."; }
|
||||
|
||||
if ($self->delete_reminder($delete_id)) { return "Reminder $delete_id deleted."; }
|
||||
else { return "Could not delete reminder $delete_id."; }
|
||||
}
|
||||
|
||||
$reminders = $count == 1 ? 'reminder' : 'reminders';
|
||||
return "$count $reminders: $text";
|
||||
}
|
||||
$text = join ' ', @$args if not defined $text;
|
||||
|
||||
return "Please specify a point in time for this reminder." if not $alarm;
|
||||
return "Please specify a reminder message." if not $text;
|
||||
|
||||
if ($delete_id) {
|
||||
my $admininfo = $self->{pbot}->{users}->loggedin_admin($target ? $target : $from, "$nick!$user\@$host");
|
||||
|
||||
# admins can delete any reminders (perhaps check admin levels against owner level?)
|
||||
if ($admininfo) {
|
||||
if (not $self->get_reminder($delete_id)) {
|
||||
return "Reminder $delete_id does not exist.";
|
||||
}
|
||||
if ($target) {
|
||||
if (not defined $admininfo) { return "Only admins can create channel reminders."; }
|
||||
|
||||
if ($self->delete_reminder($delete_id)) {
|
||||
return "Reminder $delete_id deleted.";
|
||||
} else {
|
||||
return "Could not delete reminder $delete_id.";
|
||||
}
|
||||
if (not $self->{pbot}->{channels}->is_active($target)) { return "I'm not active in channel $target."; }
|
||||
}
|
||||
|
||||
print "alarm: $alarm\n";
|
||||
|
||||
my ($length, $error) = $self->{pbot}->{parsedate}->parsedate($alarm);
|
||||
|
||||
print "length: $length, error: $error!\n";
|
||||
return $error if $error;
|
||||
|
||||
# I don't know how I feel about enforcing arbitrary time restrictions
|
||||
if ($length > 31536000 * 10) { return "Come on now, I'll be dead by then."; }
|
||||
|
||||
if (not defined $admininfo and $length < 60) { return "Time must be a minimum of 60 seconds."; }
|
||||
|
||||
if (not defined $admininfo and $repeat > 10) { return "You may only set up to 10 repeats."; }
|
||||
|
||||
if ($repeat < 0) { return "Repeats must be 0 or greater."; }
|
||||
|
||||
$alarm = gettimeofday + $length;
|
||||
|
||||
my $account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
$account = $self->{pbot}->{messagehistory}->{database}->get_ancestor_id($account);
|
||||
my $reminder = $self->get_reminder($delete_id);
|
||||
|
||||
if (not $reminder) {
|
||||
return "Reminder $delete_id does not exist.";
|
||||
}
|
||||
|
||||
if ($reminder->{account} != $account) {
|
||||
return "Reminder $delete_id does not belong to you.";
|
||||
}
|
||||
|
||||
if ($self->delete_reminder($delete_id)) {
|
||||
return "Reminder $delete_id deleted.";
|
||||
} else {
|
||||
return "Could not delete reminder $delete_id.";
|
||||
}
|
||||
}
|
||||
|
||||
$text = join ' ', @$args if not defined $text;
|
||||
|
||||
return "Please specify a point in time for this reminder." if not $alarm;
|
||||
return "Please specify a reminder message." if not $text;
|
||||
|
||||
my $admininfo = $self->{pbot}->{users}->loggedin_admin($target ? $target : $from, "$nick!$user\@$host");
|
||||
|
||||
if ($target) {
|
||||
if (not defined $admininfo) {
|
||||
return "Only admins can create channel reminders.";
|
||||
my $reminders = $self->get_reminders($account);
|
||||
if (@$reminders >= 3) { return "You may only set 3 reminders at a time. Use `remindme -d id` to remove a reminder."; }
|
||||
}
|
||||
|
||||
if (not $self->{pbot}->{channels}->is_active($target)) {
|
||||
return "I'm not active in channel $target.";
|
||||
}
|
||||
}
|
||||
|
||||
print "alarm: $alarm\n";
|
||||
|
||||
my ($length, $error) = $self->{pbot}->{parsedate}->parsedate($alarm);
|
||||
|
||||
print "length: $length, error: $error!\n";
|
||||
return $error if $error;
|
||||
|
||||
# I don't know how I feel about enforcing arbitrary time restrictions
|
||||
if ($length > 31536000 * 10) {
|
||||
return "Come on now, I'll be dead by then.";
|
||||
}
|
||||
|
||||
if (not defined $admininfo and $length < 60) {
|
||||
return "Time must be a minimum of 60 seconds.";
|
||||
}
|
||||
|
||||
if (not defined $admininfo and $repeat > 10) {
|
||||
return "You may only set up to 10 repeats.";
|
||||
}
|
||||
|
||||
if ($repeat < 0) {
|
||||
return "Repeats must be 0 or greater.";
|
||||
}
|
||||
|
||||
$alarm = gettimeofday + $length;
|
||||
|
||||
my $account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
$account = $self->{pbot}->{messagehistory}->{database}->get_ancestor_id($account);
|
||||
|
||||
if (not defined $admininfo) {
|
||||
my $reminders = $self->get_reminders($account);
|
||||
if (@$reminders >= 3) {
|
||||
return "You may only set 3 reminders at a time. Use `remindme -d id` to remove a reminder.";
|
||||
}
|
||||
}
|
||||
|
||||
if ($self->add_reminder($account, $target, $text, $alarm, $length, $repeat, "$nick!$user\@$host")) {
|
||||
return "Reminder added.";
|
||||
} else {
|
||||
return "Failed to add reminder.";
|
||||
}
|
||||
if ($self->add_reminder($account, $target, $text, $alarm, $length, $repeat, "$nick!$user\@$host")) { return "Reminder added."; }
|
||||
else { return "Failed to add reminder."; }
|
||||
}
|
||||
|
||||
sub check_reminders {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
return if not $self->{dbh};
|
||||
return if not $self->{dbh};
|
||||
|
||||
my $reminders = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * FROM Reminders WHERE alarm <= ?');
|
||||
$sth->execute(scalar gettimeofday);
|
||||
return $sth->fetchall_arrayref({});
|
||||
};
|
||||
my $reminders = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * FROM Reminders WHERE alarm <= ?');
|
||||
$sth->execute(scalar gettimeofday);
|
||||
return $sth->fetchall_arrayref({});
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Check reminders failed: $@");
|
||||
return;
|
||||
}
|
||||
|
||||
foreach my $reminder (@$reminders) {
|
||||
# ensures we get the current nick of the person
|
||||
my $hostmask = $self->{pbot}->{messagehistory}->{database}->find_most_recent_hostmask($reminder->{account});
|
||||
my ($nick) = $hostmask =~ /^([^!]+)!/;
|
||||
|
||||
# delete this reminder if it's expired by 31 days
|
||||
if (gettimeofday - $reminder->{alarm} >= 86400 * 31) {
|
||||
$self->{pbot}->{logger}->log("Deleting expired reminder: $reminder->{id}) $reminder->{text} set by $reminder->{created_by}\n");
|
||||
$self->delete_reminder($reminder->{id});
|
||||
next;
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Check reminders failed: $@");
|
||||
return;
|
||||
}
|
||||
|
||||
# don't execute this reminder if the person isn't around yet
|
||||
next if not $self->{pbot}->{nicklist}->is_present_any_channel($nick);
|
||||
foreach my $reminder (@$reminders) {
|
||||
|
||||
my $text = "Reminder: $reminder->{text}";
|
||||
my $target = $reminder->{target} // $nick;
|
||||
$self->{pbot}->{conn}->privmsg($target, $text);
|
||||
# ensures we get the current nick of the person
|
||||
my $hostmask = $self->{pbot}->{messagehistory}->{database}->find_most_recent_hostmask($reminder->{account});
|
||||
my ($nick) = $hostmask =~ /^([^!]+)!/;
|
||||
|
||||
$self->{pbot}->{logger}->log("Reminded $target about \"$text\"\n");
|
||||
# delete this reminder if it's expired by 31 days
|
||||
if (gettimeofday - $reminder->{alarm} >= 86400 * 31) {
|
||||
$self->{pbot}->{logger}->log("Deleting expired reminder: $reminder->{id}) $reminder->{text} set by $reminder->{created_by}\n");
|
||||
$self->delete_reminder($reminder->{id});
|
||||
next;
|
||||
}
|
||||
|
||||
if ($reminder->{repeat} > 0) {
|
||||
$reminder->{repeat}--;
|
||||
$reminder->{alarm} = gettimeofday + $reminder->{duration};
|
||||
my $data = { repeat => $reminder->{repeat}, alarm => $reminder->{alarm} };
|
||||
$self->update_reminder($reminder->{id}, $data);
|
||||
} else {
|
||||
$self->delete_reminder($reminder->{id});
|
||||
# don't execute this reminder if the person isn't around yet
|
||||
next if not $self->{pbot}->{nicklist}->is_present_any_channel($nick);
|
||||
|
||||
my $text = "Reminder: $reminder->{text}";
|
||||
my $target = $reminder->{target} // $nick;
|
||||
$self->{pbot}->{conn}->privmsg($target, $text);
|
||||
|
||||
$self->{pbot}->{logger}->log("Reminded $target about \"$text\"\n");
|
||||
|
||||
if ($reminder->{repeat} > 0) {
|
||||
$reminder->{repeat}--;
|
||||
$reminder->{alarm} = gettimeofday + $reminder->{duration};
|
||||
my $data = {repeat => $reminder->{repeat}, alarm => $reminder->{alarm}};
|
||||
$self->update_reminder($reminder->{id}, $data);
|
||||
} else {
|
||||
$self->delete_reminder($reminder->{id});
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -17,171 +17,167 @@ use feature 'unicode_strings';
|
|||
use Storable qw/dclone/;
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->modcmd(@_) }, 'mod', 0);
|
||||
$self->{pbot}->{commands}->set_meta('mod', 'help', 'Provides restricted moderation abilities to voiced users. They can kick/ban/etc only users that are not admins, whitelisted, voiced or opped.');
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->modcmd(@_) }, 'mod', 0);
|
||||
$self->{pbot}->{commands}->set_meta(
|
||||
'mod', 'help',
|
||||
'Provides restricted moderation abilities to voiced users. They can kick/ban/etc only users that are not admins, whitelisted, voiced or opped.'
|
||||
);
|
||||
|
||||
$self->{pbot}->{capabilities}->add('chanmod', 'can-mod', 1);
|
||||
$self->{pbot}->{capabilities}->add('chanmod', 'can-voice', 1);
|
||||
$self->{pbot}->{capabilities}->add('chanmod', 'can-devoice', 1);
|
||||
$self->{pbot}->{capabilities}->add('chanmod', 'can-mod', 1);
|
||||
$self->{pbot}->{capabilities}->add('chanmod', 'can-voice', 1);
|
||||
$self->{pbot}->{capabilities}->add('chanmod', 'can-devoice', 1);
|
||||
|
||||
$self->{commands} = {
|
||||
'help' => { subref => sub { $self->help(@_) }, help => "Provides help about this command. Usage: mod help <mod command>; see also: mod help list" },
|
||||
'list' => { subref => sub { $self->list(@_) }, help => "Lists available mod commands. Usage: mod list" },
|
||||
'kick' => { subref => sub { $self->kick(@_) }, help => "Kicks a nick from the channel. Usage: mod kick <nick>" },
|
||||
'ban' => { subref => sub { $self->ban(@_) }, help => "Bans a nick from the channel. Cannot be used to set a custom banmask. Usage: mod ban <nick>" },
|
||||
'mute' => { subref => sub { $self->mute(@_) }, help => "Mutes a nick in the channel. Usage: mod mute <nick>" },
|
||||
'unban' => { subref => sub { $self->unban(@_) }, help => "Removes bans set by moderators. Cannot remove any other types of bans. Usage: mod unban <nick or mask>" },
|
||||
'unmute' => { subref => sub { $self->unmute(@_) }, help => "Removes mutes set by moderators. Cannot remove any other types of mutes. Usage: mod unmute <nick or mask>" },
|
||||
'kb' => { subref => sub { $self->kb(@_) }, help => "Kickbans a nick from the channel. Cannot be used to set a custom banmask. Usage: mod kb <nick>" },
|
||||
};
|
||||
$self->{commands} = {
|
||||
'help' => {subref => sub { $self->help(@_) }, help => "Provides help about this command. Usage: mod help <mod command>; see also: mod help list"},
|
||||
'list' => {subref => sub { $self->list(@_) }, help => "Lists available mod commands. Usage: mod list"},
|
||||
'kick' => {subref => sub { $self->kick(@_) }, help => "Kicks a nick from the channel. Usage: mod kick <nick>"},
|
||||
'ban' => {subref => sub { $self->ban(@_) }, help => "Bans a nick from the channel. Cannot be used to set a custom banmask. Usage: mod ban <nick>"},
|
||||
'mute' => {subref => sub { $self->mute(@_) }, help => "Mutes a nick in the channel. Usage: mod mute <nick>"},
|
||||
'unban' => {subref => sub { $self->unban(@_) }, help => "Removes bans set by moderators. Cannot remove any other types of bans. Usage: mod unban <nick or mask>"},
|
||||
'unmute' => {subref => sub { $self->unmute(@_) }, help => "Removes mutes set by moderators. Cannot remove any other types of mutes. Usage: mod unmute <nick or mask>"},
|
||||
'kb' => {subref => sub { $self->kb(@_) }, help => "Kickbans a nick from the channel. Cannot be used to set a custom banmask. Usage: mod kb <nick>"},
|
||||
};
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{commands}->unregister('mod');
|
||||
$self->{pbot}->{capabilities}->remove('chanmod');
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{commands}->unregister('mod');
|
||||
$self->{pbot}->{capabilities}->remove('chanmod');
|
||||
}
|
||||
|
||||
sub help {
|
||||
my ($self, $stuff) = @_;
|
||||
my $command = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // 'help';
|
||||
my ($self, $stuff) = @_;
|
||||
my $command = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // 'help';
|
||||
|
||||
if (exists $self->{commands}->{$command}) {
|
||||
return $self->{commands}->{$command}->{help};
|
||||
} else {
|
||||
return "No such mod command '$command'. I can't help you with that.";
|
||||
}
|
||||
if (exists $self->{commands}->{$command}) { return $self->{commands}->{$command}->{help}; }
|
||||
else { return "No such mod command '$command'. I can't help you with that."; }
|
||||
}
|
||||
|
||||
sub list {
|
||||
my ($self, $stuff) = @_;
|
||||
return "Available mod commands: " . join ', ', sort keys %{$self->{commands}};
|
||||
my ($self, $stuff) = @_;
|
||||
return "Available mod commands: " . join ', ', sort keys %{$self->{commands}};
|
||||
}
|
||||
|
||||
sub generic_command {
|
||||
my ($self, $stuff, $command) = @_;
|
||||
my ($self, $stuff, $command) = @_;
|
||||
|
||||
my $channel = $stuff->{from};
|
||||
if ($channel !~ m/^#/) {
|
||||
$channel = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
my $channel = $stuff->{from};
|
||||
if ($channel !~ m/^#/) {
|
||||
$channel = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
|
||||
if (not defined $channel or $channel !~ /^#/) {
|
||||
return "Must specify channel from private message. Usage: mod $command <channel> <nick>";
|
||||
if (not defined $channel or $channel !~ /^#/) { return "Must specify channel from private message. Usage: mod $command <channel> <nick>"; }
|
||||
}
|
||||
}
|
||||
|
||||
return "I do not have OPs for this channel. I cannot do any moderation here."
|
||||
if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
return "Voiced moderation is not enabled for this channel. Use `regset $channel.restrictedmod 1` to enable."
|
||||
if not $self->{pbot}->{registry}->get_value($channel, 'restrictedmod');
|
||||
return "I do not have OPs for this channel. I cannot do any moderation here." if not $self->{pbot}->{chanops}->can_gain_ops($channel);
|
||||
return "Voiced moderation is not enabled for this channel. Use `regset $channel.restrictedmod 1` to enable."
|
||||
if not $self->{pbot}->{registry}->get_value($channel, 'restrictedmod');
|
||||
|
||||
my $hostmask = "$stuff->{nick}!$stuff->{user}\@$stuff->{host}";
|
||||
my $user = $self->{pbot}->{users}->loggedin($channel, $hostmask) // { admin => 0, chanmod => 0};
|
||||
my $voiced = $self->{pbot}->{nicklist}->get_meta($channel, $stuff->{nick}, '+v');
|
||||
my $hostmask = "$stuff->{nick}!$stuff->{user}\@$stuff->{host}";
|
||||
my $user = $self->{pbot}->{users}->loggedin($channel, $hostmask) // {admin => 0, chanmod => 0};
|
||||
my $voiced = $self->{pbot}->{nicklist}->get_meta($channel, $stuff->{nick}, '+v');
|
||||
|
||||
if (not $voiced and not $self->{pbot}->{capabilities}->userhas($user, 'admin')
|
||||
and not $self->{pbot}->{capabilities}->userhas($user, 'chanmod')) {
|
||||
return "You must be voiced (usermode +v) or have the admin or chanmod capability to use this command.";
|
||||
}
|
||||
|
||||
my $target = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
return "Missing target. Usage: mod $command <nick>" if not defined $target;
|
||||
|
||||
if ($command eq 'unban') {
|
||||
my $reason = $self->{pbot}->{chanops}->checkban($channel, $target);
|
||||
if ($reason =~ m/moderator ban/) {
|
||||
$self->{pbot}->{chanops}->unban_user($target, $channel, 1);
|
||||
return "";
|
||||
} else {
|
||||
return "I don't think so. That ban was not set by a moderator.";
|
||||
if (not $voiced and not $self->{pbot}->{capabilities}->userhas($user, 'admin') and not $self->{pbot}->{capabilities}->userhas($user, 'chanmod')) {
|
||||
return "You must be voiced (usermode +v) or have the admin or chanmod capability to use this command.";
|
||||
}
|
||||
} elsif ($command eq 'unmute') {
|
||||
my $reason = $self->{pbot}->{chanops}->checkmute($channel, $target);
|
||||
if ($reason =~ m/moderator mute/) {
|
||||
$self->{pbot}->{chanops}->unmute_user($target, $channel, 1);
|
||||
return "";
|
||||
} else {
|
||||
return "I don't think so. That mute was not set by a moderator.";
|
||||
|
||||
my $target = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist});
|
||||
return "Missing target. Usage: mod $command <nick>" if not defined $target;
|
||||
|
||||
if ($command eq 'unban') {
|
||||
my $reason = $self->{pbot}->{chanops}->checkban($channel, $target);
|
||||
if ($reason =~ m/moderator ban/) {
|
||||
$self->{pbot}->{chanops}->unban_user($target, $channel, 1);
|
||||
return "";
|
||||
} else {
|
||||
return "I don't think so. That ban was not set by a moderator.";
|
||||
}
|
||||
} elsif ($command eq 'unmute') {
|
||||
my $reason = $self->{pbot}->{chanops}->checkmute($channel, $target);
|
||||
if ($reason =~ m/moderator mute/) {
|
||||
$self->{pbot}->{chanops}->unmute_user($target, $channel, 1);
|
||||
return "";
|
||||
} else {
|
||||
return "I don't think so. That mute was not set by a moderator.";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $target_nicklist;
|
||||
if (not $self->{pbot}->{nicklist}->is_present($channel, $target)) {
|
||||
return "$stuff->{nick}: I do not see anybody named $target in this channel.";
|
||||
} else {
|
||||
$target_nicklist = $self->{pbot}->{nicklist}->{nicklist}->{lc $channel}->{lc $target};
|
||||
}
|
||||
my $target_nicklist;
|
||||
if (not $self->{pbot}->{nicklist}->is_present($channel, $target)) { return "$stuff->{nick}: I do not see anybody named $target in this channel."; }
|
||||
else { $target_nicklist = $self->{pbot}->{nicklist}->{nicklist}->{lc $channel}->{lc $target}; }
|
||||
|
||||
my $target_user = $self->{pbot}->{users}->loggedin($channel, $target_nicklist->{hostmask});
|
||||
my $target_user = $self->{pbot}->{users}->loggedin($channel, $target_nicklist->{hostmask});
|
||||
|
||||
if ((defined $target_user and $target_user->{autoop} or $target_user->{autovoice})
|
||||
or $target_nicklist->{'+v'} or $target_nicklist->{'+o'}
|
||||
or $self->{pbot}->{capabilities}->userhas($target_user, 'is-whitelisted')) {
|
||||
return "I don't think so."
|
||||
}
|
||||
if ( (defined $target_user and $target_user->{autoop} or $target_user->{autovoice})
|
||||
or $target_nicklist->{'+v'}
|
||||
or $target_nicklist->{'+o'}
|
||||
or $self->{pbot}->{capabilities}->userhas($target_user, 'is-whitelisted'))
|
||||
{
|
||||
return "I don't think so.";
|
||||
}
|
||||
|
||||
if ($command eq 'kick') {
|
||||
$self->{pbot}->{chanops}->add_op_command($channel, "kick $channel $target Have a nice day!");
|
||||
$self->{pbot}->{chanops}->gain_ops($channel);
|
||||
} elsif ($command eq 'ban') {
|
||||
$self->{pbot}->{chanops}->ban_user_timed("$stuff->{nick}!$stuff->{user}\@$stuff->{host}",
|
||||
"doing something naughty (moderator ban)", $target, $channel, 3600 * 24, 1);
|
||||
} elsif ($command eq 'mute') {
|
||||
$self->{pbot}->{chanops}->mute_user_timed("$stuff->{nick}!$stuff->{user}\@$stuff->{host}",
|
||||
"doing something naughty (moderator mute)", $target, $channel, 3600 * 24, 1);
|
||||
}
|
||||
return "";
|
||||
if ($command eq 'kick') {
|
||||
$self->{pbot}->{chanops}->add_op_command($channel, "kick $channel $target Have a nice day!");
|
||||
$self->{pbot}->{chanops}->gain_ops($channel);
|
||||
} elsif ($command eq 'ban') {
|
||||
$self->{pbot}->{chanops}->ban_user_timed(
|
||||
"$stuff->{nick}!$stuff->{user}\@$stuff->{host}",
|
||||
"doing something naughty (moderator ban)", $target, $channel, 3600 * 24, 1
|
||||
);
|
||||
} elsif ($command eq 'mute') {
|
||||
$self->{pbot}->{chanops}->mute_user_timed(
|
||||
"$stuff->{nick}!$stuff->{user}\@$stuff->{host}",
|
||||
"doing something naughty (moderator mute)", $target, $channel, 3600 * 24, 1
|
||||
);
|
||||
}
|
||||
return "";
|
||||
}
|
||||
|
||||
sub kick {
|
||||
my ($self, $stuff) = @_;
|
||||
return $self->generic_command($stuff, 'kick');
|
||||
my ($self, $stuff) = @_;
|
||||
return $self->generic_command($stuff, 'kick');
|
||||
}
|
||||
|
||||
sub ban {
|
||||
my ($self, $stuff) = @_;
|
||||
return $self->generic_command($stuff, 'ban');
|
||||
my ($self, $stuff) = @_;
|
||||
return $self->generic_command($stuff, 'ban');
|
||||
}
|
||||
|
||||
sub mute {
|
||||
my ($self, $stuff) = @_;
|
||||
return $self->generic_command($stuff, 'mute');
|
||||
my ($self, $stuff) = @_;
|
||||
return $self->generic_command($stuff, 'mute');
|
||||
}
|
||||
|
||||
sub unban {
|
||||
my ($self, $stuff) = @_;
|
||||
return $self->generic_command($stuff, 'unban');
|
||||
my ($self, $stuff) = @_;
|
||||
return $self->generic_command($stuff, 'unban');
|
||||
}
|
||||
|
||||
sub unmute {
|
||||
my ($self, $stuff) = @_;
|
||||
return $self->generic_command($stuff, 'unmute');
|
||||
my ($self, $stuff) = @_;
|
||||
return $self->generic_command($stuff, 'unmute');
|
||||
}
|
||||
|
||||
sub kb {
|
||||
my ($self, $stuff) = @_;
|
||||
my $result = $self->ban(dclone $stuff); # note: using copy of $stuff to preserve $stuff->{arglist} for $self->kick($stuff)
|
||||
return $result if length $result;
|
||||
return $self->kick($stuff);
|
||||
my ($self, $stuff) = @_;
|
||||
my $result = $self->ban(dclone $stuff); # note: using copy of $stuff to preserve $stuff->{arglist} for $self->kick($stuff)
|
||||
return $result if length $result;
|
||||
return $self->kick($stuff);
|
||||
}
|
||||
|
||||
sub modcmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
|
||||
my $command = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // '';
|
||||
$command = lc $command;
|
||||
my $command = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}) // '';
|
||||
$command = lc $command;
|
||||
|
||||
if (grep { $_ eq $command } keys %{$self->{commands}}) {
|
||||
return $self->{commands}->{$command}->{subref}->($stuff);
|
||||
} else {
|
||||
my $commands = join ', ', sort keys %{$self->{commands}};
|
||||
if ($from !~ m/^#/) {
|
||||
return "Usage: mod <channel> <command> [arguments]; commands are: $commands; see `mod help <command>` for more information.";
|
||||
if (grep { $_ eq $command } keys %{$self->{commands}}) {
|
||||
return $self->{commands}->{$command}->{subref}->($stuff);
|
||||
} else {
|
||||
return "Usage: mod <command> [arguments]; commands are: $commands; see `mod help <command>` for more information.";
|
||||
my $commands = join ', ', sort keys %{$self->{commands}};
|
||||
if ($from !~ m/^#/) { return "Usage: mod <channel> <command> [arguments]; commands are: $commands; see `mod help <command>` for more information."; }
|
||||
else { return "Usage: mod <command> [arguments]; commands are: $commands; see `mod help <command>` for more information."; }
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
4959
Plugins/Spinach.pm
4959
Plugins/Spinach.pm
File diff suppressed because it is too large
Load Diff
|
|
@ -18,319 +18,359 @@ use Plugins::Spinach::Stats;
|
|||
use Math::Expression::Evaluator;
|
||||
|
||||
sub new {
|
||||
Carp::croak("Options to " . __FILE__ . " should be key/value pairs, not hash reference") if ref $_[1] eq 'HASH';
|
||||
my ($class, %conf) = @_;
|
||||
my $self = bless {}, $class;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
Carp::croak("Options to " . __FILE__ . " should be key/value pairs, not hash reference") if ref $_[1] eq 'HASH';
|
||||
my ($class, %conf) = @_;
|
||||
my $self = bless {}, $class;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot} = $conf{pbot} // Carp::croak("Missing pbot reference to " . __FILE__);
|
||||
$self->{channel} = $conf{channel} // Carp::croak("Missing channel reference to " . __FILE__);
|
||||
$self->{filename} = $conf{filename} // 'stats.sqlite';
|
||||
$self->{stats} = Plugins::Spinach::Stats->new(pbot => $self->{pbot}, filename => $self->{filename});
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot} = $conf{pbot} // Carp::croak("Missing pbot reference to " . __FILE__);
|
||||
$self->{channel} = $conf{channel} // Carp::croak("Missing channel reference to " . __FILE__);
|
||||
$self->{filename} = $conf{filename} // 'stats.sqlite';
|
||||
$self->{stats} = Plugins::Spinach::Stats->new(pbot => $self->{pbot}, filename => $self->{filename});
|
||||
}
|
||||
|
||||
sub sort_generic {
|
||||
my ($self, $key) = @_;
|
||||
if ($self->{rank_direction} eq '+') {
|
||||
return $b->{$key} <=> $a->{$key};
|
||||
} else {
|
||||
return $a->{$key} <=> $b->{$key};
|
||||
}
|
||||
my ($self, $key) = @_;
|
||||
if ($self->{rank_direction} eq '+') { return $b->{$key} <=> $a->{$key}; }
|
||||
else { return $a->{$key} <=> $b->{$key}; }
|
||||
}
|
||||
|
||||
sub print_generic {
|
||||
my ($self, $key, $player) = @_;
|
||||
return undef if $player->{games_played} == 0;
|
||||
return "$player->{nick}: $player->{$key}";
|
||||
my ($self, $key, $player) = @_;
|
||||
return undef if $player->{games_played} == 0;
|
||||
return "$player->{nick}: $player->{$key}";
|
||||
}
|
||||
|
||||
sub print_avg_score {
|
||||
my ($self, $player) = @_;
|
||||
return undef if $player->{games_played} == 0;
|
||||
my $result = int $player->{avg_score};
|
||||
return "$player->{nick}: $result";
|
||||
my ($self, $player) = @_;
|
||||
return undef if $player->{games_played} == 0;
|
||||
my $result = int $player->{avg_score};
|
||||
return "$player->{nick}: $result";
|
||||
}
|
||||
|
||||
|
||||
sub sort_bad_lies {
|
||||
my ($self) = @_;
|
||||
if ($self->{rank_direction} eq '+') {
|
||||
return $b->{questions_played} - $b->{good_lies} <=> $a->{questions_played} - $a->{good_lies};
|
||||
} else {
|
||||
return $a->{questions_played} - $a->{good_lies} <=> $b->{questions_played} - $b->{good_lies};
|
||||
}
|
||||
my ($self) = @_;
|
||||
if ($self->{rank_direction} eq '+') { return $b->{questions_played} - $b->{good_lies} <=> $a->{questions_played} - $a->{good_lies}; }
|
||||
else { return $a->{questions_played} - $a->{good_lies} <=> $b->{questions_played} - $b->{good_lies}; }
|
||||
}
|
||||
|
||||
sub print_bad_lies {
|
||||
my ($self, $player) = @_;
|
||||
return undef if $player->{games_played} == 0;
|
||||
my $result = $player->{questions_played} - $player->{good_lies};
|
||||
return "$player->{nick}: $result";
|
||||
my ($self, $player) = @_;
|
||||
return undef if $player->{games_played} == 0;
|
||||
my $result = $player->{questions_played} - $player->{good_lies};
|
||||
return "$player->{nick}: $result";
|
||||
}
|
||||
|
||||
sub sort_mentions {
|
||||
my ($self) = @_;
|
||||
if ($self->{rank_direction} eq '+') {
|
||||
return $b->{games_played} - $b->{times_first} - $b->{times_second} - $b->{times_third} <=>
|
||||
$a->{games_played} - $a->{times_first} - $a->{times_second} - $a->{times_third};
|
||||
} else {
|
||||
return $a->{games_played} - $a->{times_first} - $a->{times_second} - $a->{times_third} <=>
|
||||
$b->{games_played} - $b->{times_first} - $b->{times_second} - $b->{times_third};
|
||||
}
|
||||
my ($self) = @_;
|
||||
if ($self->{rank_direction} eq '+') {
|
||||
return $b->{games_played} - $b->{times_first} - $b->{times_second} - $b->{times_third} <=> $a->{games_played} - $a->{times_first} - $a->{times_second} -
|
||||
$a->{times_third};
|
||||
} else {
|
||||
return $a->{games_played} - $a->{times_first} - $a->{times_second} - $a->{times_third} <=> $b->{games_played} - $b->{times_first} - $b->{times_second} -
|
||||
$b->{times_third};
|
||||
}
|
||||
}
|
||||
|
||||
sub print_mentions {
|
||||
my ($self, $player) = @_;
|
||||
return undef if $player->{games_played} == 0;
|
||||
my $result = $player->{games_played} - $player->{times_first} - $player->{times_second} - $player->{times_third};
|
||||
return "$player->{nick}: $result";
|
||||
my ($self, $player) = @_;
|
||||
return undef if $player->{games_played} == 0;
|
||||
my $result = $player->{games_played} - $player->{times_first} - $player->{times_second} - $player->{times_third};
|
||||
return "$player->{nick}: $result";
|
||||
}
|
||||
|
||||
sub sort_expr {
|
||||
my ($self) = @_;
|
||||
my ($self) = @_;
|
||||
|
||||
my $result = eval {
|
||||
my $result_a = $self->{expr}->val({
|
||||
highscore => $a->{high_score},
|
||||
lowscore => $a->{low_score},
|
||||
avgscore => $a->{avg_score},
|
||||
goodlies => $a->{good_lies},
|
||||
badlies => $a->{questions_played} - $a->{good_lies},
|
||||
first => $a->{times_first},
|
||||
second => $a->{times_second},
|
||||
third => $a->{times_third},
|
||||
mentions => $a->{games_played} - $a->{times_first} - $a->{times_second} - $a->{times_third},
|
||||
games => $a->{games_played},
|
||||
questions => $a->{questions_played},
|
||||
goodguesses => $a->{good_guesses},
|
||||
badguesses => $a->{bad_guesses},
|
||||
deceptions => $a->{players_deceived}
|
||||
});
|
||||
my $result = eval {
|
||||
my $result_a = $self->{expr}->val(
|
||||
{
|
||||
highscore => $a->{high_score},
|
||||
lowscore => $a->{low_score},
|
||||
avgscore => $a->{avg_score},
|
||||
goodlies => $a->{good_lies},
|
||||
badlies => $a->{questions_played} - $a->{good_lies},
|
||||
first => $a->{times_first},
|
||||
second => $a->{times_second},
|
||||
third => $a->{times_third},
|
||||
mentions => $a->{games_played} - $a->{times_first} - $a->{times_second} - $a->{times_third},
|
||||
games => $a->{games_played},
|
||||
questions => $a->{questions_played},
|
||||
goodguesses => $a->{good_guesses},
|
||||
badguesses => $a->{bad_guesses},
|
||||
deceptions => $a->{players_deceived}
|
||||
}
|
||||
);
|
||||
|
||||
my $result_b = $self->{expr}->val({
|
||||
highscore => $b->{high_score},
|
||||
lowscore => $b->{low_score},
|
||||
avgscore => $b->{avg_score},
|
||||
goodlies => $b->{good_lies},
|
||||
badlies => $b->{questions_played} - $b->{good_lies},
|
||||
first => $b->{times_first},
|
||||
second => $b->{times_second},
|
||||
third => $b->{times_third},
|
||||
mentions => $b->{games_played} - $b->{times_first} - $b->{times_second} - $b->{times_third},
|
||||
games => $b->{games_played},
|
||||
questions => $b->{questions_played},
|
||||
goodguesses => $b->{good_guesses},
|
||||
badguesses => $b->{bad_guesses},
|
||||
deceptions => $b->{players_deceived}
|
||||
});
|
||||
my $result_b = $self->{expr}->val(
|
||||
{
|
||||
highscore => $b->{high_score},
|
||||
lowscore => $b->{low_score},
|
||||
avgscore => $b->{avg_score},
|
||||
goodlies => $b->{good_lies},
|
||||
badlies => $b->{questions_played} - $b->{good_lies},
|
||||
first => $b->{times_first},
|
||||
second => $b->{times_second},
|
||||
third => $b->{times_third},
|
||||
mentions => $b->{games_played} - $b->{times_first} - $b->{times_second} - $b->{times_third},
|
||||
games => $b->{games_played},
|
||||
questions => $b->{questions_played},
|
||||
goodguesses => $b->{good_guesses},
|
||||
badguesses => $b->{bad_guesses},
|
||||
deceptions => $b->{players_deceived}
|
||||
}
|
||||
);
|
||||
|
||||
if ($self->{rank_direction} eq '+') {
|
||||
return $result_b <=> $result_a;
|
||||
} else {
|
||||
return $result_a <=> $result_b;
|
||||
if ($self->{rank_direction} eq '+') { return $result_b <=> $result_a; }
|
||||
else { return $result_a <=> $result_b; }
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("expr sort error: $@\n");
|
||||
return 0;
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("expr sort error: $@\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
return $result;
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub print_expr {
|
||||
my ($self, $player) = @_;
|
||||
my ($self, $player) = @_;
|
||||
|
||||
return undef if $player->{games_played} == 0;
|
||||
return undef if $player->{games_played} == 0;
|
||||
|
||||
my $result = eval {
|
||||
$self->{expr}->val({
|
||||
highscore => $player->{high_score},
|
||||
lowscore => $player->{low_score},
|
||||
avgscore => $player->{avg_score},
|
||||
goodlies => $player->{good_lies},
|
||||
badlies => $player->{questions_played} - $player->{good_lies},
|
||||
first => $player->{times_first},
|
||||
second => $player->{times_second},
|
||||
third => $player->{times_third},
|
||||
mentions => $player->{games_played} - $player->{times_first} - $player->{times_second} - $player->{times_third},
|
||||
games => $player->{games_played},
|
||||
questions => $player->{questions_played},
|
||||
goodguesses => $player->{good_guesses},
|
||||
badguesses => $player->{bad_guesses},
|
||||
deceptions => $player->{players_deceived}
|
||||
});
|
||||
};
|
||||
my $result = eval {
|
||||
$self->{expr}->val(
|
||||
{
|
||||
highscore => $player->{high_score},
|
||||
lowscore => $player->{low_score},
|
||||
avgscore => $player->{avg_score},
|
||||
goodlies => $player->{good_lies},
|
||||
badlies => $player->{questions_played} - $player->{good_lies},
|
||||
first => $player->{times_first},
|
||||
second => $player->{times_second},
|
||||
third => $player->{times_third},
|
||||
mentions => $player->{games_played} - $player->{times_first} - $player->{times_second} - $player->{times_third},
|
||||
games => $player->{games_played},
|
||||
questions => $player->{questions_played},
|
||||
goodguesses => $player->{good_guesses},
|
||||
badguesses => $player->{bad_guesses},
|
||||
deceptions => $player->{players_deceived}
|
||||
}
|
||||
);
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Error in expr print: $@\n");
|
||||
return undef;
|
||||
}
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Error in expr print: $@\n");
|
||||
return undef;
|
||||
}
|
||||
|
||||
return "$player->{nick}: $result";
|
||||
return "$player->{nick}: $result";
|
||||
}
|
||||
|
||||
sub rank {
|
||||
my ($self, $arguments) = @_;
|
||||
my ($self, $arguments) = @_;
|
||||
|
||||
my %ranks = (
|
||||
highscore => { sort => sub { $self->sort_generic('high_score', @_) }, print => sub { $self->print_generic('high_score', @_) }, title => 'high score' },
|
||||
lowscore => { sort => sub { $self->sort_generic('low_score', @_) }, print => sub { $self->print_generic('low_score', @_) }, title => 'low score' },
|
||||
avgscore => { sort => sub { $self->sort_generic('avg_score', @_) }, print => sub { $self->print_avg_score(@_) }, title => 'average score' },
|
||||
goodlies => { sort => sub { $self->sort_generic('good_lies', @_) }, print => sub { $self->print_generic('good_lies', @_) }, title => 'good lies' },
|
||||
badlies => { sort => sub { $self->sort_bad_lies(@_) }, print => sub { $self->print_bad_lies(@_) }, title => 'bad lies' },
|
||||
first => { sort => sub { $self->sort_generic('times_first', @_) }, print => sub { $self->print_generic('times_first', @_) }, title => 'first place' },
|
||||
second => { sort => sub { $self->sort_generic('times_second', @_) }, print => sub { $self->print_generic('times_second', @_) }, title => 'second place' },
|
||||
third => { sort => sub { $self->sort_generic('times_third', @_) }, print => sub { $self->print_generic('times_third', @_) }, title => 'third place' },
|
||||
mentions => { sort => sub { $self->sort_mentions(@_) }, print => sub { $self->print_mentions(@_) }, title => 'mentions' },
|
||||
games => { sort => sub { $self->sort_generic('games_played', @_) }, print => sub { $self->print_generic('games_played', @_) }, title => 'games played' },
|
||||
questions => { sort => sub { $self->sort_generic('questions_played', @_) }, print => sub { $self->print_generic('questions_played', @_) }, title => 'questions played' },
|
||||
goodguesses => { sort => sub { $self->sort_generic('good_guesses', @_) }, print => sub { $self->print_generic('good_guesses', @_) }, title => 'good guesses' },
|
||||
badguesses => { sort => sub { $self->sort_generic('bad_guesses', @_) }, print => sub { $self->print_generic('bad_guesses', @_) }, title => 'bad guesses' },
|
||||
deceptions => { sort => sub { $self->sort_generic('players_deceived', @_) }, print => sub { $self->print_generic('players_deceived', @_) }, title => 'players deceived' },
|
||||
expr => { sort => sub { $self->sort_expr(@_) }, print => sub { $self->print_expr(@_) }, title => 'expr' },
|
||||
);
|
||||
my %ranks = (
|
||||
highscore => {
|
||||
sort => sub { $self->sort_generic('high_score', @_) },
|
||||
print => sub { $self->print_generic('high_score', @_) },
|
||||
title => 'high score'
|
||||
},
|
||||
lowscore => {
|
||||
sort => sub { $self->sort_generic('low_score', @_) },
|
||||
print => sub { $self->print_generic('low_score', @_) },
|
||||
title => 'low score'
|
||||
},
|
||||
avgscore => {
|
||||
sort => sub { $self->sort_generic('avg_score', @_) },
|
||||
print => sub { $self->print_avg_score(@_) },
|
||||
title => 'average score'
|
||||
},
|
||||
goodlies => {
|
||||
sort => sub { $self->sort_generic('good_lies', @_) },
|
||||
print => sub { $self->print_generic('good_lies', @_) },
|
||||
title => 'good lies'
|
||||
},
|
||||
badlies => {
|
||||
sort => sub { $self->sort_bad_lies(@_) },
|
||||
print => sub { $self->print_bad_lies(@_) },
|
||||
title => 'bad lies'
|
||||
},
|
||||
first => {
|
||||
sort => sub { $self->sort_generic('times_first', @_) },
|
||||
print => sub { $self->print_generic('times_first', @_) },
|
||||
title => 'first place'
|
||||
},
|
||||
second => {
|
||||
sort => sub { $self->sort_generic('times_second', @_) },
|
||||
print => sub { $self->print_generic('times_second', @_) },
|
||||
title => 'second place'
|
||||
},
|
||||
third => {
|
||||
sort => sub { $self->sort_generic('times_third', @_) },
|
||||
print => sub { $self->print_generic('times_third', @_) },
|
||||
title => 'third place'
|
||||
},
|
||||
mentions => {
|
||||
sort => sub { $self->sort_mentions(@_) },
|
||||
print => sub { $self->print_mentions(@_) },
|
||||
title => 'mentions'
|
||||
},
|
||||
games => {
|
||||
sort => sub { $self->sort_generic('games_played', @_) },
|
||||
print => sub { $self->print_generic('games_played', @_) },
|
||||
title => 'games played'
|
||||
},
|
||||
questions => {
|
||||
sort => sub { $self->sort_generic('questions_played', @_) },
|
||||
print => sub { $self->print_generic('questions_played', @_) },
|
||||
title => 'questions played'
|
||||
},
|
||||
goodguesses => {
|
||||
sort => sub { $self->sort_generic('good_guesses', @_) },
|
||||
print => sub { $self->print_generic('good_guesses', @_) },
|
||||
title => 'good guesses'
|
||||
},
|
||||
badguesses => {
|
||||
sort => sub { $self->sort_generic('bad_guesses', @_) },
|
||||
print => sub { $self->print_generic('bad_guesses', @_) },
|
||||
title => 'bad guesses'
|
||||
},
|
||||
deceptions => {
|
||||
sort => sub { $self->sort_generic('players_deceived', @_) },
|
||||
print => sub { $self->print_generic('players_deceived', @_) },
|
||||
title => 'players deceived'
|
||||
},
|
||||
expr => {
|
||||
sort => sub { $self->sort_expr(@_) },
|
||||
print => sub { $self->print_expr(@_) },
|
||||
title => 'expr'
|
||||
},
|
||||
);
|
||||
|
||||
my @order = qw/highscore lowscore avgscore first second third mentions games questions goodlies badlies deceptions goodguesses badguesses expr/;
|
||||
my @order = qw/highscore lowscore avgscore first second third mentions games questions goodlies badlies deceptions goodguesses badguesses expr/;
|
||||
|
||||
if (not $arguments) {
|
||||
my $result = "Usage: rank [-]<keyword> [offset] or rank [-]<nick>; available keywords: ";
|
||||
$result .= join ', ', @order;
|
||||
$result .= ".\n";
|
||||
$result .= "Prefix with a dash to invert sort.\n";
|
||||
return $result;
|
||||
}
|
||||
|
||||
$arguments = lc $arguments;
|
||||
|
||||
if ($arguments =~ s/^([+-])//) {
|
||||
$self->{rank_direction} = $1;
|
||||
} else {
|
||||
$self->{rank_direction} = '+';
|
||||
}
|
||||
|
||||
my $offset = 1;
|
||||
if ($arguments =~ s/\s+(\d+)$//) {
|
||||
$offset = $1;
|
||||
}
|
||||
|
||||
my $opt_arg;
|
||||
if ($arguments =~ /^expr/) {
|
||||
if ($arguments =~ s/^expr (.+)$/expr/) {
|
||||
$opt_arg = $1;
|
||||
} else {
|
||||
return "Usage: spinach rank expr <expression>";
|
||||
if (not $arguments) {
|
||||
my $result = "Usage: rank [-]<keyword> [offset] or rank [-]<nick>; available keywords: ";
|
||||
$result .= join ', ', @order;
|
||||
$result .= ".\n";
|
||||
$result .= "Prefix with a dash to invert sort.\n";
|
||||
return $result;
|
||||
}
|
||||
|
||||
$arguments = lc $arguments;
|
||||
|
||||
if ($arguments =~ s/^([+-])//) { $self->{rank_direction} = $1; }
|
||||
else { $self->{rank_direction} = '+'; }
|
||||
|
||||
my $offset = 1;
|
||||
if ($arguments =~ s/\s+(\d+)$//) { $offset = $1; }
|
||||
|
||||
my $opt_arg;
|
||||
if ($arguments =~ /^expr/) {
|
||||
if ($arguments =~ s/^expr (.+)$/expr/) { $opt_arg = $1; }
|
||||
else { return "Usage: spinach rank expr <expression>"; }
|
||||
}
|
||||
|
||||
if (not exists $ranks{$arguments}) {
|
||||
$self->{stats}->begin;
|
||||
my $player_id = $self->{stats}->get_player_id($arguments, $self->{channel}, 1);
|
||||
my $player_data = $self->{stats}->get_player_data($player_id);
|
||||
|
||||
if (not defined $player_id) {
|
||||
$self->{stats}->end;
|
||||
return "I don't know anybody named $arguments.";
|
||||
}
|
||||
|
||||
my $players = $self->{stats}->get_all_players($self->{channel});
|
||||
my @rankings;
|
||||
|
||||
foreach my $key (@order) {
|
||||
next if $key eq 'expr';
|
||||
my $sort_method = $ranks{$key}->{sort};
|
||||
@$players = sort $sort_method @$players;
|
||||
|
||||
my $rank = 0;
|
||||
my $stats;
|
||||
my $last_value = -1;
|
||||
foreach my $player (@$players) {
|
||||
$stats = $ranks{$key}->{print}->($player);
|
||||
|
||||
if (defined $stats) {
|
||||
my ($value) = $stats =~ /[^:]+:\s+(.*)/;
|
||||
$rank++ if $value ne $last_value;
|
||||
$last_value = $value;
|
||||
} else {
|
||||
$rank++ if lc $player->{nick} eq $arguments;
|
||||
}
|
||||
|
||||
last if lc $player->{nick} eq $arguments;
|
||||
}
|
||||
|
||||
if (not $rank) { push @rankings, "$ranks{key}->{title}: N/A"; }
|
||||
else {
|
||||
if (not $stats) { push @rankings, "$ranks{$key}->{title}: N/A"; }
|
||||
else {
|
||||
$stats =~ s/[^:]+:\s+//;
|
||||
push @rankings, "$ranks{$key}->{title}: #$rank ($stats)";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $result = "$player_data->{nick}'s rankings: ";
|
||||
$result .= join ', ', @rankings;
|
||||
$self->{stats}->end;
|
||||
return $result;
|
||||
}
|
||||
}
|
||||
|
||||
if (not exists $ranks{$arguments}) {
|
||||
$self->{stats}->begin;
|
||||
my $player_id = $self->{stats}->get_player_id($arguments, $self->{channel}, 1);
|
||||
my $player_data = $self->{stats}->get_player_data($player_id);
|
||||
|
||||
if (not defined $player_id) {
|
||||
$self->{stats}->end;
|
||||
return "I don't know anybody named $arguments.";
|
||||
}
|
||||
|
||||
my $players = $self->{stats}->get_all_players($self->{channel});
|
||||
my @rankings;
|
||||
|
||||
foreach my $key (@order) {
|
||||
next if $key eq 'expr';
|
||||
my $sort_method = $ranks{$key}->{sort};
|
||||
@$players = sort $sort_method @$players;
|
||||
|
||||
my $rank = 0;
|
||||
my $stats;
|
||||
my $last_value = -1;
|
||||
foreach my $player (@$players) {
|
||||
$stats = $ranks{$key}->{print}->($player);
|
||||
|
||||
if (defined $stats) {
|
||||
my ($value) = $stats =~ /[^:]+:\s+(.*)/;
|
||||
$rank++ if $value ne $last_value;
|
||||
$last_value = $value;
|
||||
} else {
|
||||
$rank++ if lc $player->{nick} eq $arguments;
|
||||
if ($arguments eq 'expr') {
|
||||
$self->{expr} = eval { Math::Expression::Evaluator->new($opt_arg) };
|
||||
if ($@) {
|
||||
my $error = $@;
|
||||
$error =~ s/ at .*//ms;
|
||||
return "Bad expression: $error";
|
||||
}
|
||||
|
||||
last if lc $player->{nick} eq $arguments;
|
||||
}
|
||||
|
||||
if (not $rank) {
|
||||
push @rankings, "$ranks{key}->{title}: N/A";
|
||||
} else {
|
||||
if (not $stats) {
|
||||
push @rankings, "$ranks{$key}->{title}: N/A";
|
||||
} else {
|
||||
$stats =~ s/[^:]+:\s+//;
|
||||
push @rankings, "$ranks{$key}->{title}: #$rank ($stats)";
|
||||
}
|
||||
}
|
||||
$self->{expr}->optimize;
|
||||
}
|
||||
|
||||
my $sort_method = $ranks{$arguments}->{sort};
|
||||
@$players = sort $sort_method @$players;
|
||||
|
||||
my @ranking;
|
||||
my $rank = 0;
|
||||
my $last_value = -1;
|
||||
foreach my $player (@$players) {
|
||||
my $entry = $ranks{$arguments}->{print}->($player);
|
||||
if (defined $entry) {
|
||||
my ($value) = $entry =~ /[^:]+:\s+(.*)/;
|
||||
$rank++ if $value ne $last_value;
|
||||
$last_value = $value;
|
||||
next if $rank < $offset;
|
||||
push @ranking, "#$rank $entry" if defined $entry;
|
||||
last if scalar @ranking >= 15;
|
||||
}
|
||||
}
|
||||
|
||||
my $result;
|
||||
|
||||
if (not scalar @ranking) {
|
||||
if ($offset > 1) { $result = "No rankings available for $self->{channel} at offset #$offset.\n"; }
|
||||
else { $result = "No rankings available for $self->{channel} yet.\n"; }
|
||||
} else {
|
||||
if ($arguments eq 'expr') { $result = "Rankings for $opt_arg: "; }
|
||||
else { $result = "Rankings for $ranks{$arguments}->{title}: "; }
|
||||
$result .= join ', ', @ranking;
|
||||
}
|
||||
|
||||
my $result = "$player_data->{nick}'s rankings: ";
|
||||
$result .= join ', ', @rankings;
|
||||
$self->{stats}->end;
|
||||
return $result;
|
||||
}
|
||||
|
||||
$self->{stats}->begin;
|
||||
my $players = $self->{stats}->get_all_players($self->{channel});
|
||||
|
||||
if ($arguments eq 'expr') {
|
||||
$self->{expr} = eval { Math::Expression::Evaluator->new($opt_arg) };
|
||||
if ($@) {
|
||||
my $error = $@;
|
||||
$error =~ s/ at .*//ms;
|
||||
return "Bad expression: $error";
|
||||
}
|
||||
$self->{expr}->optimize;
|
||||
}
|
||||
|
||||
my $sort_method = $ranks{$arguments}->{sort};
|
||||
@$players = sort $sort_method @$players;
|
||||
|
||||
my @ranking;
|
||||
my $rank = 0;
|
||||
my $last_value = -1;
|
||||
foreach my $player (@$players) {
|
||||
my $entry = $ranks{$arguments}->{print}->($player);
|
||||
if (defined $entry) {
|
||||
my ($value) = $entry =~ /[^:]+:\s+(.*)/;
|
||||
$rank++ if $value ne $last_value;
|
||||
$last_value = $value;
|
||||
next if $rank < $offset;
|
||||
push @ranking, "#$rank $entry" if defined $entry;
|
||||
last if scalar @ranking >= 15;
|
||||
}
|
||||
}
|
||||
|
||||
my $result;
|
||||
|
||||
if (not scalar @ranking) {
|
||||
if ($offset > 1) {
|
||||
$result = "No rankings available for $self->{channel} at offset #$offset.\n";
|
||||
} else {
|
||||
$result = "No rankings available for $self->{channel} yet.\n";
|
||||
}
|
||||
} else {
|
||||
if ($arguments eq 'expr') {
|
||||
$result = "Rankings for $opt_arg: ";
|
||||
} else {
|
||||
$result = "Rankings for $ranks{$arguments}->{title}: ";
|
||||
}
|
||||
$result .= join ', ', @ranking;
|
||||
}
|
||||
|
||||
$self->{stats}->end;
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -15,27 +15,27 @@ use DBI;
|
|||
use Carp qw(shortmess);
|
||||
|
||||
sub new {
|
||||
my ($class, %conf) = @_;
|
||||
my $self = bless {}, $class;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
my ($class, %conf) = @_;
|
||||
my $self = bless {}, $class;
|
||||
$self->initialize(%conf);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot} = $conf{pbot} // Carp::croak("Missing pbot reference to " . __FILE__);
|
||||
$self->{filename} = $conf{filename} // 'stats.sqlite';
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot} = $conf{pbot} // Carp::croak("Missing pbot reference to " . __FILE__);
|
||||
$self->{filename} = $conf{filename} // 'stats.sqlite';
|
||||
}
|
||||
|
||||
sub begin {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
$self->{pbot}->{logger}->log("Opening Spinach stats SQLite database: $self->{filename}\n");
|
||||
$self->{pbot}->{logger}->log("Opening Spinach stats SQLite database: $self->{filename}\n");
|
||||
|
||||
$self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", { RaiseError => 1, PrintError => 0 }) or die $DBI::errstr;
|
||||
$self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", {RaiseError => 1, PrintError => 0}) or die $DBI::errstr;
|
||||
|
||||
eval {
|
||||
$self->{dbh}->do(<< 'SQL');
|
||||
eval {
|
||||
$self->{dbh}->do(<< 'SQL');
|
||||
CREATE TABLE IF NOT EXISTS Stats (
|
||||
id INTEGER PRIMARY KEY,
|
||||
nick TEXT NOT NULL COLLATE NOCASE,
|
||||
|
|
@ -54,125 +54,122 @@ CREATE TABLE IF NOT EXISTS Stats (
|
|||
bad_guesses INTEGER DEFAULT 0
|
||||
)
|
||||
SQL
|
||||
};
|
||||
};
|
||||
|
||||
$self->{pbot}->{logger}->log("Error creating database: $@\n") if $@;
|
||||
$self->{pbot}->{logger}->log("Error creating database: $@\n") if $@;
|
||||
}
|
||||
|
||||
sub end {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
|
||||
if (exists $self->{dbh} and defined $self->{dbh}) {
|
||||
$self->{pbot}->{logger}->log("Closing stats SQLite database\n");
|
||||
$self->{dbh}->disconnect();
|
||||
delete $self->{dbh};
|
||||
}
|
||||
if (exists $self->{dbh} and defined $self->{dbh}) {
|
||||
$self->{pbot}->{logger}->log("Closing stats SQLite database\n");
|
||||
$self->{dbh}->disconnect();
|
||||
delete $self->{dbh};
|
||||
}
|
||||
}
|
||||
|
||||
sub add_player {
|
||||
my ($self, $id, $nick, $channel) = @_;
|
||||
my ($self, $id, $nick, $channel) = @_;
|
||||
|
||||
eval {
|
||||
my $sth = $self->{dbh}->prepare('INSERT INTO Stats (id, nick, channel) VALUES (?, ?, ?)');
|
||||
$sth->execute($id, $nick, $channel);
|
||||
};
|
||||
eval {
|
||||
my $sth = $self->{dbh}->prepare('INSERT INTO Stats (id, nick, channel) VALUES (?, ?, ?)');
|
||||
$sth->execute($id, $nick, $channel);
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Spinach stats: failed to add new player ($id, $nick $channel): $@\n");
|
||||
return 0;
|
||||
}
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Spinach stats: failed to add new player ($id, $nick $channel): $@\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
return $id;
|
||||
return $id;
|
||||
}
|
||||
|
||||
sub get_player_id {
|
||||
my ($self, $nick, $channel, $dont_create_new) = @_;
|
||||
my ($self, $nick, $channel, $dont_create_new) = @_;
|
||||
|
||||
my ($account_id) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick);
|
||||
$account_id = $self->{pbot}->{messagehistory}->{database}->get_ancestor_id($account_id);
|
||||
my ($account_id) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick);
|
||||
$account_id = $self->{pbot}->{messagehistory}->{database}->get_ancestor_id($account_id);
|
||||
|
||||
return undef if not $account_id;
|
||||
return undef if not $account_id;
|
||||
|
||||
my $id = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT id FROM Stats WHERE id = ? AND channel = ?');
|
||||
$sth->execute($account_id, $channel);
|
||||
my $row = $sth->fetchrow_hashref();
|
||||
return $row->{id};
|
||||
};
|
||||
my $id = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT id FROM Stats WHERE id = ? AND channel = ?');
|
||||
$sth->execute($account_id, $channel);
|
||||
my $row = $sth->fetchrow_hashref();
|
||||
return $row->{id};
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Spinach stats: failed to get player id: $@\n");
|
||||
return undef;
|
||||
}
|
||||
if ($@) {
|
||||
$self->{pbot}->{logger}->log("Spinach stats: failed to get player id: $@\n");
|
||||
return undef;
|
||||
}
|
||||
|
||||
$id = $self->add_player($account_id, $nick, $channel) if not defined $id and not $dont_create_new;
|
||||
return $id;
|
||||
$id = $self->add_player($account_id, $nick, $channel) if not defined $id and not $dont_create_new;
|
||||
return $id;
|
||||
}
|
||||
|
||||
sub get_player_data {
|
||||
my ($self, $id, @columns) = @_;
|
||||
my ($self, $id, @columns) = @_;
|
||||
|
||||
return undef if not $id;
|
||||
return undef if not $id;
|
||||
|
||||
my $player_data = eval {
|
||||
my $sql = 'SELECT ';
|
||||
my $player_data = eval {
|
||||
my $sql = 'SELECT ';
|
||||
|
||||
if (not @columns) {
|
||||
$sql .= '*';
|
||||
} else {
|
||||
my $comma = '';
|
||||
foreach my $column (@columns) {
|
||||
$sql .= "$comma$column";
|
||||
$comma = ', ';
|
||||
}
|
||||
}
|
||||
if (not @columns) { $sql .= '*'; }
|
||||
else {
|
||||
my $comma = '';
|
||||
foreach my $column (@columns) {
|
||||
$sql .= "$comma$column";
|
||||
$comma = ', ';
|
||||
}
|
||||
}
|
||||
|
||||
$sql .= ' FROM Stats WHERE id = ?';
|
||||
my $sth = $self->{dbh}->prepare($sql);
|
||||
$sth->execute($id);
|
||||
return $sth->fetchrow_hashref();
|
||||
};
|
||||
print STDERR $@ if $@;
|
||||
return $player_data;
|
||||
$sql .= ' FROM Stats WHERE id = ?';
|
||||
my $sth = $self->{dbh}->prepare($sql);
|
||||
$sth->execute($id);
|
||||
return $sth->fetchrow_hashref();
|
||||
};
|
||||
print STDERR $@ if $@;
|
||||
return $player_data;
|
||||
}
|
||||
|
||||
sub update_player_data {
|
||||
my ($self, $id, $data) = @_;
|
||||
my ($self, $id, $data) = @_;
|
||||
|
||||
eval {
|
||||
my $sql = 'UPDATE Stats SET ';
|
||||
eval {
|
||||
my $sql = 'UPDATE Stats SET ';
|
||||
|
||||
my $comma = '';
|
||||
foreach my $key (keys %$data) {
|
||||
$sql .= "$comma$key = ?";
|
||||
$comma = ', ';
|
||||
}
|
||||
my $comma = '';
|
||||
foreach my $key (keys %$data) {
|
||||
$sql .= "$comma$key = ?";
|
||||
$comma = ', ';
|
||||
}
|
||||
|
||||
$sql .= ' WHERE id = ?';
|
||||
$sql .= ' WHERE id = ?';
|
||||
|
||||
my $sth = $self->{dbh}->prepare($sql);
|
||||
my $sth = $self->{dbh}->prepare($sql);
|
||||
|
||||
my $param = 1;
|
||||
foreach my $key (keys %$data) {
|
||||
$sth->bind_param($param++, $data->{$key});
|
||||
}
|
||||
my $param = 1;
|
||||
foreach my $key (keys %$data) { $sth->bind_param($param++, $data->{$key}); }
|
||||
|
||||
$sth->bind_param($param, $id);
|
||||
$sth->execute();
|
||||
};
|
||||
print STDERR $@ if $@;
|
||||
$sth->bind_param($param, $id);
|
||||
$sth->execute();
|
||||
};
|
||||
print STDERR $@ if $@;
|
||||
}
|
||||
|
||||
sub get_all_players {
|
||||
my ($self, $channel) = @_;
|
||||
my ($self, $channel) = @_;
|
||||
|
||||
my $players = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * FROM Stats WHERE channel = ?');
|
||||
$sth->execute($channel);
|
||||
return $sth->fetchall_arrayref({});
|
||||
};
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
return $players;
|
||||
my $players = eval {
|
||||
my $sth = $self->{dbh}->prepare('SELECT * FROM Stats WHERE channel = ?');
|
||||
$sth->execute($channel);
|
||||
return $sth->fetchall_arrayref({});
|
||||
};
|
||||
$self->{pbot}->{logger}->log($@) if $@;
|
||||
return $players;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -9,94 +9,90 @@ use Time::Piece;
|
|||
my $self = {};
|
||||
|
||||
sub load_questions {
|
||||
my ($filename) = @_;
|
||||
my ($filename) = @_;
|
||||
|
||||
if (not defined $filename) {
|
||||
$filename = $ENV{HOME} . "/pbot/data/spinach/trivia.json";
|
||||
}
|
||||
if (not defined $filename) { $filename = $ENV{HOME} . "/pbot/data/spinach/trivia.json"; }
|
||||
|
||||
$self->{loaded_filename} = $filename;
|
||||
$self->{loaded_filename} = $filename;
|
||||
|
||||
my $contents = do {
|
||||
open my $fh, '<', $filename or do {
|
||||
print "Spinach: Failed to open $filename: $!\n";
|
||||
return "Failed to load $filename";
|
||||
my $contents = do {
|
||||
open my $fh, '<', $filename or do {
|
||||
print "Spinach: Failed to open $filename: $!\n";
|
||||
return "Failed to load $filename";
|
||||
};
|
||||
local $/;
|
||||
<$fh>;
|
||||
};
|
||||
local $/;
|
||||
<$fh>;
|
||||
};
|
||||
|
||||
$self->{questions} = decode_json $contents;
|
||||
$self->{categories} = ();
|
||||
$self->{questions} = decode_json $contents;
|
||||
$self->{categories} = ();
|
||||
|
||||
my $questions;
|
||||
foreach my $key (keys %{$self->{questions}}) {
|
||||
foreach my $question (@{$self->{questions}->{$key}}) {
|
||||
$question->{category} = uc $question->{category};
|
||||
$self->{categories}{$question->{category}}{$question->{id}} = $question;
|
||||
my $questions;
|
||||
foreach my $key (keys %{$self->{questions}}) {
|
||||
foreach my $question (@{$self->{questions}->{$key}}) {
|
||||
$question->{category} = uc $question->{category};
|
||||
$self->{categories}{$question->{category}}{$question->{id}} = $question;
|
||||
|
||||
if (not exists $question->{seen_timestamp}) {
|
||||
$question->{seen_timestamp} = 0;
|
||||
}
|
||||
if (not exists $question->{seen_timestamp}) { $question->{seen_timestamp} = 0; }
|
||||
|
||||
$questions++;
|
||||
$questions++;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $categories;
|
||||
foreach my $category (sort { keys %{$self->{categories}{$b}} <=> keys %{$self->{categories}{$a}} } keys %{$self->{categories}}) {
|
||||
my $count = keys %{$self->{categories}{$category}};
|
||||
print "Category [$category]: $count\n";
|
||||
$categories++;
|
||||
}
|
||||
my $categories;
|
||||
foreach my $category (sort { keys %{$self->{categories}{$b}} <=> keys %{$self->{categories}{$a}} } keys %{$self->{categories}}) {
|
||||
my $count = keys %{$self->{categories}{$category}};
|
||||
print "Category [$category]: $count\n";
|
||||
$categories++;
|
||||
}
|
||||
|
||||
print "Spinach: Loaded $questions questions in $categories categories.\n";
|
||||
return "Loaded $questions questions in $categories categories.";
|
||||
print "Spinach: Loaded $questions questions in $categories categories.\n";
|
||||
return "Loaded $questions questions in $categories categories.";
|
||||
}
|
||||
|
||||
sub save_questions {
|
||||
my $json = encode_json $self->{questions};
|
||||
my $filename = exists $self->{loaded_filename} ? $self->{loaded_filename} : $self->{questions_filename};
|
||||
open my $fh, '>', $filename or do {
|
||||
print "Failed to open Spinach file $filename: $!\n";
|
||||
return;
|
||||
};
|
||||
print $fh "$json\n";
|
||||
close $fh;
|
||||
my $json = encode_json $self->{questions};
|
||||
my $filename = exists $self->{loaded_filename} ? $self->{loaded_filename} : $self->{questions_filename};
|
||||
open my $fh, '>', $filename or do {
|
||||
print "Failed to open Spinach file $filename: $!\n";
|
||||
return;
|
||||
};
|
||||
print $fh "$json\n";
|
||||
close $fh;
|
||||
}
|
||||
|
||||
load_questions;
|
||||
|
||||
open my $fh, '<', 'seent' or do {
|
||||
print "Failed to open seent file: $!\n";
|
||||
die;
|
||||
print "Failed to open seent file: $!\n";
|
||||
die;
|
||||
};
|
||||
|
||||
my $nr = 0;
|
||||
|
||||
foreach my $line (<$fh>) {
|
||||
++$nr;
|
||||
my ($date, $id) = $line =~ m/^(.*?) :: .*? question:.*?\s(\d+,?\d*)\)/;
|
||||
++$nr;
|
||||
my ($date, $id) = $line =~ m/^(.*?) :: .*? question:.*?\s(\d+,?\d*)\)/;
|
||||
|
||||
if (not defined $date or not defined $id) {
|
||||
print "Parse error at line $nr\n";
|
||||
die;
|
||||
}
|
||||
|
||||
$id =~ s/,//g;
|
||||
|
||||
print "matched [$date] and [$id]\n";
|
||||
|
||||
my $time = Time::Piece->strptime($date, "%a %b %e %H:%M:%S %Y");
|
||||
print "epoch: ", $time->epoch, "\n";
|
||||
|
||||
foreach my $q (@{$self->{questions}->{questions}}) {
|
||||
if ($q->{id} == $id) {
|
||||
print "question: $q->{question}\n";
|
||||
$q->{seen_timestamp} = $time->epoch;
|
||||
last;
|
||||
if (not defined $date or not defined $id) {
|
||||
print "Parse error at line $nr\n";
|
||||
die;
|
||||
}
|
||||
|
||||
$id =~ s/,//g;
|
||||
|
||||
print "matched [$date] and [$id]\n";
|
||||
|
||||
my $time = Time::Piece->strptime($date, "%a %b %e %H:%M:%S %Y");
|
||||
print "epoch: ", $time->epoch, "\n";
|
||||
|
||||
foreach my $q (@{$self->{questions}->{questions}}) {
|
||||
if ($q->{id} == $id) {
|
||||
print "question: $q->{question}\n";
|
||||
$q->{seen_timestamp} = $time->epoch;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
close $fh;
|
||||
|
|
|
|||
|
|
@ -21,87 +21,84 @@ use warnings; use strict;
|
|||
use feature 'unicode_strings';
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->on_public(@_) });
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->on_public(@_) });
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.caction');
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.caction');
|
||||
}
|
||||
|
||||
sub on_public {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = lc $event->{event}->{to}[0];
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my ($nick, $user, $host, $msg) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->args);
|
||||
my $channel = lc $event->{event}->{to}[0];
|
||||
|
||||
($nick, $user, $host) = $self->{pbot}->{irchandlers}->normalize_hostmask($nick, $user, $host);
|
||||
($nick, $user, $host) = $self->{pbot}->{irchandlers}->normalize_hostmask($nick, $user, $host);
|
||||
|
||||
my $nosubs = $self->{pbot}->{registry}->get_value($channel, 'notyposub');
|
||||
return 0 if defined $nosubs and not $nosubs;
|
||||
my $nosubs = $self->{pbot}->{registry}->get_value($channel, 'notyposub');
|
||||
return 0 if defined $nosubs and not $nosubs;
|
||||
|
||||
return 0 if $channel !~ m/^#/;
|
||||
return 0 if $event->{interpreted};
|
||||
return 0 if $channel !~ m/^#/;
|
||||
return 0 if $event->{interpreted};
|
||||
|
||||
if ($msg =~ m/^\s*s([[:punct:]])/) {
|
||||
my $separator = $1;
|
||||
my $sep = quotemeta $separator;
|
||||
if ($msg =~ m/^\s*s${sep}(.*?)(?<!\\)${sep}(.*?)(?<!\\)${sep}([g]*).*$/ or $msg =~ m/^\s*s${sep}(.*?)(?<!\\)${sep}(.*)$/) {
|
||||
my ($regex, $replacement, $modifiers) = ($1, $2, $3);
|
||||
eval {
|
||||
my $rx = qr/$regex/;
|
||||
if ($msg =~ m/^\s*s([[:punct:]])/) {
|
||||
my $separator = $1;
|
||||
my $sep = quotemeta $separator;
|
||||
if ($msg =~ m/^\s*s${sep}(.*?)(?<!\\)${sep}(.*?)(?<!\\)${sep}([g]*).*$/ or $msg =~ m/^\s*s${sep}(.*?)(?<!\\)${sep}(.*)$/) {
|
||||
my ($regex, $replacement, $modifiers) = ($1, $2, $3);
|
||||
eval {
|
||||
|
||||
my $messages = $self->{pbot}->{messagehistory}->{database}->get_recent_messages_from_channel($channel, 50, $self->{pbot}->{messagehistory}->{MSG_CHAT}, 'DESC');
|
||||
my $rx = qr/$regex/;
|
||||
|
||||
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
|
||||
my $messages = $self->{pbot}->{messagehistory}->{database}->get_recent_messages_from_channel($channel, 50, $self->{pbot}->{messagehistory}->{MSG_CHAT}, 'DESC');
|
||||
|
||||
my $bot_trigger = $self->{pbot}->{registry}->get_value($channel, 'trigger')
|
||||
// $self->{pbot}->{registry}->get_value('general', 'trigger');
|
||||
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
|
||||
|
||||
my $ignore_commands = $self->{pbot}->{registry}->get_value($channel, 'typosub_ignore_commands')
|
||||
// $self->{pbot}->{registry}->get_value('typosub', 'ignore_commands') // 1;
|
||||
my $bot_trigger = $self->{pbot}->{registry}->get_value($channel, 'trigger') // $self->{pbot}->{registry}->get_value('general', 'trigger');
|
||||
|
||||
foreach my $message (@$messages) {
|
||||
next if $ignore_commands and $message->{msg} =~ m/^(?:$bot_trigger|$botnick.?)/;
|
||||
next if $message->{msg} =~ m/^\s*s[[:punct:]](.*?)[[:punct:]](.*?)[[:punct:]]?g?\s*$/;
|
||||
my $ignore_commands = $self->{pbot}->{registry}->get_value($channel, 'typosub_ignore_commands') // $self->{pbot}->{registry}->get_value('typosub', 'ignore_commands')
|
||||
// 1;
|
||||
|
||||
if ($message->{msg} =~ /$rx/) {
|
||||
my $hostmask = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_id($message->{id});
|
||||
my ($target) = $hostmask =~ m/([^!]+)/;
|
||||
my $result;
|
||||
if ($nick eq $target) {
|
||||
$result = "$nick meant to say: ";
|
||||
} else {
|
||||
$result = "$nick thinks $target meant to say: ";
|
||||
foreach my $message (@$messages) {
|
||||
next if $ignore_commands and $message->{msg} =~ m/^(?:$bot_trigger|$botnick.?)/;
|
||||
next if $message->{msg} =~ m/^\s*s[[:punct:]](.*?)[[:punct:]](.*?)[[:punct:]]?g?\s*$/;
|
||||
|
||||
if ($message->{msg} =~ /$rx/) {
|
||||
my $hostmask = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_id($message->{id});
|
||||
my ($target) = $hostmask =~ m/([^!]+)/;
|
||||
my $result;
|
||||
if ($nick eq $target) { $result = "$nick meant to say: "; }
|
||||
else { $result = "$nick thinks $target meant to say: "; }
|
||||
my $text = $message->{msg};
|
||||
if ($modifiers =~ m/g/) {
|
||||
$text =~ s/$rx/$replacement/g;
|
||||
my @stuff = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
|
||||
my $i;
|
||||
map { ++$i; $text =~ s/[\$\\]$i/$_/g; } @stuff;
|
||||
} else {
|
||||
$text =~ s/$rx/$replacement/;
|
||||
my @stuff = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
|
||||
my $i;
|
||||
map { ++$i; $text =~ s/[\$\\]$i/$_/g; } @stuff;
|
||||
}
|
||||
$event->{conn}->privmsg($channel, "$result$text");
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
my $error = "Error in `s${separator}${regex}${separator}${replacement}${separator}${modifiers}`: $@";
|
||||
$error =~ s/ at .*$//;
|
||||
$event->{conn}->privmsg($nick, $error);
|
||||
return 0;
|
||||
}
|
||||
my $text = $message->{msg};
|
||||
if ($modifiers =~ m/g/) {
|
||||
$text =~ s/$rx/$replacement/g;
|
||||
my @stuff = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
|
||||
my $i;
|
||||
map { ++$i; $text =~ s/[\$\\]$i/$_/g; } @stuff;
|
||||
} else {
|
||||
$text =~ s/$rx/$replacement/;
|
||||
my @stuff = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
|
||||
my $i;
|
||||
map { ++$i; $text =~ s/[\$\\]$i/$_/g; } @stuff;
|
||||
}
|
||||
$event->{conn}->privmsg($channel, "$result$text");
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
my $error = "Error in `s${separator}${regex}${separator}${replacement}${separator}${modifiers}`: $@";
|
||||
$error =~ s/ at .*$//;
|
||||
$event->{conn}->privmsg($nick, $error);
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
return 0;
|
||||
}
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -13,71 +13,69 @@ use parent 'Plugins::Plugin';
|
|||
use warnings; use strict;
|
||||
use feature 'unicode_strings';
|
||||
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('text', 'general', 'show_url_titles', $conf{show_url_titles} // 1);
|
||||
$self->{pbot}->{registry}->add_default('array', 'general', 'show_url_titles_channels', $conf{show_url_titles_channels} // '.*');
|
||||
$self->{pbot}->{registry}->add_default('array', 'general', 'show_url_titles_ignore_channels', $conf{show_url_titles_ignore_channels} // 'none');
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{registry}->add_default('text', 'general', 'show_url_titles', $conf{show_url_titles} // 1);
|
||||
$self->{pbot}->{registry}->add_default('array', 'general', 'show_url_titles_channels', $conf{show_url_titles_channels} // '.*');
|
||||
$self->{pbot}->{registry}->add_default('array', 'general', 'show_url_titles_ignore_channels', $conf{show_url_titles_ignore_channels} // 'none');
|
||||
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->show_url_titles(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->show_url_titles(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->show_url_titles(@_) });
|
||||
$self->{pbot}->{event_dispatcher}->register_handler('irc.caction', sub { $self->show_url_titles(@_) });
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.caction');
|
||||
my ($self) = @_;
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.public');
|
||||
$self->{pbot}->{event_dispatcher}->remove_handler('irc.caction');
|
||||
}
|
||||
|
||||
sub show_url_titles {
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my $channel = $event->{event}->{to}[0];
|
||||
my ($nick, $user, $host) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host);
|
||||
my $msg = $event->{event}->{args}[0];
|
||||
my ($self, $event_type, $event) = @_;
|
||||
my $channel = $event->{event}->{to}[0];
|
||||
my ($nick, $user, $host) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host);
|
||||
my $msg = $event->{event}->{args}[0];
|
||||
|
||||
return 0 if not $msg =~ m/https?:\/\/[^\s]/;
|
||||
return 0 if $event->{interpreted};
|
||||
return 0 if not $msg =~ m/https?:\/\/[^\s]/;
|
||||
return 0 if $event->{interpreted};
|
||||
|
||||
if ($self->{pbot}->{ignorelist}->check_ignore($nick, $user, $host, $channel)) {
|
||||
my $admin = $self->{pbot}->{users}->loggedin_admin($channel, "$nick!$user\@$host");
|
||||
if (!defined $admin || $admin->{level} < 10) {
|
||||
return 0;
|
||||
if ($self->{pbot}->{ignorelist}->check_ignore($nick, $user, $host, $channel)) {
|
||||
my $admin = $self->{pbot}->{users}->loggedin_admin($channel, "$nick!$user\@$host");
|
||||
if (!defined $admin || $admin->{level} < 10) { return 0; }
|
||||
}
|
||||
}
|
||||
|
||||
# no titles for unidentified users in +z channels
|
||||
my $chanmodes = $self->{pbot}->{channels}->get_meta($channel, 'MODE');
|
||||
if (defined $chanmodes and $chanmodes =~ m/z/) {
|
||||
my $account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
my $nickserv = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($account);
|
||||
return 0 if not defined $nickserv or not length $nickserv;
|
||||
}
|
||||
|
||||
if ($self->{pbot}->{registry}->get_value('general', 'show_url_titles')
|
||||
and not $self->{pbot}->{registry}->get_value($channel, 'no_url_titles')
|
||||
and not grep { $channel =~ /$_/i } $self->{pbot}->{registry}->get_value('general', 'show_url_titles_ignore_channels')
|
||||
and grep { $channel =~ /$_/i } $self->{pbot}->{registry}->get_value('general', 'show_url_titles_channels')) {
|
||||
|
||||
my $count = 0;
|
||||
while ($msg =~ s/(https?:\/\/[^\s]+)//i && ++$count <= 3) {
|
||||
my $url = $1;
|
||||
|
||||
if ($self->{pbot}->{antispam}->is_spam('url', $url)) {
|
||||
$self->{pbot}->{logger}->log("Ignoring spam URL $url\n");
|
||||
next;
|
||||
}
|
||||
|
||||
my $stuff = {
|
||||
from => $channel, nick => $nick, user => $user, host => $host,
|
||||
command => "title $nick $url", root_channel => $channel, root_keyword => "title",
|
||||
keyword => "title", arguments => "$nick $url"
|
||||
};
|
||||
|
||||
$self->{pbot}->{modules}->execute_module($stuff);
|
||||
# no titles for unidentified users in +z channels
|
||||
my $chanmodes = $self->{pbot}->{channels}->get_meta($channel, 'MODE');
|
||||
if (defined $chanmodes and $chanmodes =~ m/z/) {
|
||||
my $account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host);
|
||||
my $nickserv = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($account);
|
||||
return 0 if not defined $nickserv or not length $nickserv;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
|
||||
if ( $self->{pbot}->{registry}->get_value('general', 'show_url_titles')
|
||||
and not $self->{pbot}->{registry}->get_value($channel, 'no_url_titles')
|
||||
and not grep { $channel =~ /$_/i } $self->{pbot}->{registry}->get_value('general', 'show_url_titles_ignore_channels')
|
||||
and grep { $channel =~ /$_/i } $self->{pbot}->{registry}->get_value('general', 'show_url_titles_channels'))
|
||||
{
|
||||
|
||||
my $count = 0;
|
||||
while ($msg =~ s/(https?:\/\/[^\s]+)//i && ++$count <= 3) {
|
||||
my $url = $1;
|
||||
|
||||
if ($self->{pbot}->{antispam}->is_spam('url', $url)) {
|
||||
$self->{pbot}->{logger}->log("Ignoring spam URL $url\n");
|
||||
next;
|
||||
}
|
||||
|
||||
my $stuff = {
|
||||
from => $channel, nick => $nick, user => $user, host => $host,
|
||||
command => "title $nick $url", root_channel => $channel, root_keyword => "title",
|
||||
keyword => "title", arguments => "$nick $url"
|
||||
};
|
||||
|
||||
$self->{pbot}->{modules}->execute_module($stuff);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package Plugins::Weather;
|
||||
|
||||
use parent 'Plugins::Plugin';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -18,107 +19,104 @@ use XML::LibXML;
|
|||
use Getopt::Long qw(GetOptionsFromString);
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->weathercmd(@_) }, "weather", 0);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->weathercmd(@_) }, "weather", 0);
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
$self->{pbot}->{commands}->unregister("weather");
|
||||
my $self = shift;
|
||||
$self->{pbot}->{commands}->unregister("weather");
|
||||
}
|
||||
|
||||
sub weathercmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "Usage: weather [-u <user account>] [location]";
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
my $usage = "Usage: weather [-u <user account>] [location]";
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
|
||||
Getopt::Long::Configure("bundling");
|
||||
Getopt::Long::Configure("bundling");
|
||||
|
||||
my ($user_override, $show_usage);
|
||||
my ($ret, $args) = GetOptionsFromString($arguments,
|
||||
'u=s' => \$user_override,
|
||||
'h' => \$show_usage
|
||||
);
|
||||
my ($user_override, $show_usage);
|
||||
my ($ret, $args) = GetOptionsFromString(
|
||||
$arguments,
|
||||
'u=s' => \$user_override,
|
||||
'h' => \$show_usage
|
||||
);
|
||||
|
||||
return $usage if $show_usage;
|
||||
return "/say $getopt_error -- $usage" if defined $getopt_error;
|
||||
$arguments = "@$args";
|
||||
return $usage if $show_usage;
|
||||
return "/say $getopt_error -- $usage" if defined $getopt_error;
|
||||
$arguments = "@$args";
|
||||
|
||||
my $hostmask = defined $user_override ? $user_override : "$nick!$user\@$host";
|
||||
my $location_override = $self->{pbot}->{users}->get_user_metadata($from, $hostmask, 'location') // '';
|
||||
$arguments = $location_override if not length $arguments;
|
||||
my $hostmask = defined $user_override ? $user_override : "$nick!$user\@$host";
|
||||
my $location_override = $self->{pbot}->{users}->get_user_metadata($from, $hostmask, 'location') // '';
|
||||
$arguments = $location_override if not length $arguments;
|
||||
|
||||
if (defined $user_override and not length $location_override) {
|
||||
return "No location set or user account does not exist.";
|
||||
}
|
||||
if (defined $user_override and not length $location_override) { return "No location set or user account does not exist."; }
|
||||
|
||||
if (not length $arguments) {
|
||||
return $usage;
|
||||
}
|
||||
return $self->get_weather($arguments);
|
||||
if (not length $arguments) { return $usage; }
|
||||
return $self->get_weather($arguments);
|
||||
}
|
||||
|
||||
sub get_weather {
|
||||
my ($self, $location) = @_;
|
||||
|
||||
my %cache_opt = (
|
||||
'namespace' => 'accuweather',
|
||||
'default_expires_in' => 3600
|
||||
);
|
||||
my ($self, $location) = @_;
|
||||
|
||||
my $ua = PBot::Utils::LWPUserAgentCached->new(\%cache_opt, timeout => 10);
|
||||
my $response = $ua->get("http://rss.accuweather.com/rss/liveweather_rss.asp?metric=0&locCode=$location");
|
||||
my %cache_opt = (
|
||||
'namespace' => 'accuweather',
|
||||
'default_expires_in' => 3600
|
||||
);
|
||||
|
||||
my $xml;
|
||||
if ($response->is_success) {
|
||||
$xml = $response->decoded_content;
|
||||
} else {
|
||||
return "Failed to fetch weather data: " . $response->status_line;
|
||||
}
|
||||
my $ua = PBot::Utils::LWPUserAgentCached->new(\%cache_opt, timeout => 10);
|
||||
my $response = $ua->get("http://rss.accuweather.com/rss/liveweather_rss.asp?metric=0&locCode=$location");
|
||||
|
||||
my $dom = XML::LibXML->load_xml(string => $xml);
|
||||
my $xml;
|
||||
|
||||
my $result = '';
|
||||
if ($response->is_success) { $xml = $response->decoded_content; }
|
||||
else { return "Failed to fetch weather data: " . $response->status_line; }
|
||||
|
||||
foreach my $channel ($dom->findnodes('//channel')) {
|
||||
my $title = $channel->findvalue('./title');
|
||||
my $description = $channel->findvalue('./description');
|
||||
my $dom = XML::LibXML->load_xml(string => $xml);
|
||||
|
||||
if ($description eq 'Invalid Location') {
|
||||
return "Location $location not found. Use \"<city>, <country abbrev>\" (e.g. \"paris, fr\") or a US Zip Code or \"<city>, <state abbrev>, US\" (e.g., \"austin, tx, us\").";
|
||||
my $result = '';
|
||||
|
||||
foreach my $channel ($dom->findnodes('//channel')) {
|
||||
my $title = $channel->findvalue('./title');
|
||||
my $description = $channel->findvalue('./description');
|
||||
|
||||
if ($description eq 'Invalid Location') {
|
||||
return
|
||||
"Location $location not found. Use \"<city>, <country abbrev>\" (e.g. \"paris, fr\") or a US Zip Code or \"<city>, <state abbrev>, US\" (e.g., \"austin, tx, us\").";
|
||||
}
|
||||
|
||||
$title =~ s/ - AccuW.*$//;
|
||||
$result .= "Weather for $title: ";
|
||||
}
|
||||
|
||||
$title =~ s/ - AccuW.*$//;
|
||||
$result .= "Weather for $title: ";
|
||||
}
|
||||
foreach my $item ($dom->findnodes('//item')) {
|
||||
my $title = $item->findvalue('./title');
|
||||
my $description = $item->findvalue('./description');
|
||||
|
||||
foreach my $item ($dom->findnodes('//item')) {
|
||||
my $title = $item->findvalue('./title');
|
||||
my $description = $item->findvalue('./description');
|
||||
if ($title =~ m/^Currently:/) {
|
||||
$title = $self->fix_temps($title);
|
||||
$result .= "$title; ";
|
||||
}
|
||||
|
||||
if ($title =~ m/^Currently:/) {
|
||||
$title = $self->fix_temps($title);
|
||||
$result .= "$title; ";
|
||||
if ($title =~ m/Forecast$/) {
|
||||
$description =~ s/ <img.*$//;
|
||||
$description = $self->fix_temps($description);
|
||||
$result .= "Forecast: $description";
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
if ($title =~ m/Forecast$/) {
|
||||
$description =~ s/ <img.*$//;
|
||||
$description = $self->fix_temps($description);
|
||||
$result .= "Forecast: $description";
|
||||
last;
|
||||
}
|
||||
}
|
||||
return $result;
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub fix_temps {
|
||||
my ($self, $text) = @_;
|
||||
$text =~ s|(-?\d+)\s*F|my $f = $1; my $c = ($f - 32 ) * 5 / 9; $c = sprintf("%.1d", $c); "${f}F/${c}C"|eg;
|
||||
return $text;
|
||||
my ($self, $text) = @_;
|
||||
$text =~ s|(-?\d+)\s*F|my $f = $1; my $c = ($f - 32 ) * 5 / 9; $c = sprintf("%.1d", $c); "${f}F/${c}C"|eg;
|
||||
return $text;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
409
Plugins/Wttr.pm
409
Plugins/Wttr.pm
|
|
@ -8,6 +8,7 @@
|
|||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
package Plugins::Wttr;
|
||||
|
||||
use parent 'Plugins::Plugin';
|
||||
|
||||
use warnings; use strict;
|
||||
|
|
@ -15,6 +16,7 @@ use feature 'unicode_strings';
|
|||
use utf8;
|
||||
|
||||
use feature 'switch';
|
||||
|
||||
no if $] >= 5.018, warnings => "experimental::smartmatch";
|
||||
|
||||
use PBot::Utils::LWPUserAgentCached;
|
||||
|
|
@ -23,257 +25,234 @@ use URI::Escape qw/uri_escape_utf8/;
|
|||
use Getopt::Long qw(GetOptionsFromString);
|
||||
|
||||
sub initialize {
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->wttrcmd(@_) }, "wttr", 0);
|
||||
my ($self, %conf) = @_;
|
||||
$self->{pbot}->{commands}->register(sub { $self->wttrcmd(@_) }, "wttr", 0);
|
||||
}
|
||||
|
||||
sub unload {
|
||||
my $self = shift;
|
||||
$self->{pbot}->{commands}->unregister("wttr");
|
||||
my $self = shift;
|
||||
$self->{pbot}->{commands}->unregister("wttr");
|
||||
}
|
||||
|
||||
sub wttrcmd {
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
|
||||
my @wttr_options = (
|
||||
"conditions",
|
||||
"forecast",
|
||||
"feelslike",
|
||||
"uvindex",
|
||||
"visibility",
|
||||
"dewpoint",
|
||||
"heatindex",
|
||||
"cloudcover",
|
||||
"wind",
|
||||
"sunrise|sunset",
|
||||
"moon",
|
||||
"chances",
|
||||
"sunhours",
|
||||
"snowfall",
|
||||
"location",
|
||||
"default",
|
||||
"all",
|
||||
);
|
||||
my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_;
|
||||
|
||||
my $usage = "Usage: wttr [-u <user account>] [location] [" . join(' ', map { "-$_" } @wttr_options) . "]";
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
my @wttr_options = (
|
||||
"conditions",
|
||||
"forecast",
|
||||
"feelslike",
|
||||
"uvindex",
|
||||
"visibility",
|
||||
"dewpoint",
|
||||
"heatindex",
|
||||
"cloudcover",
|
||||
"wind",
|
||||
"sunrise|sunset",
|
||||
"moon",
|
||||
"chances",
|
||||
"sunhours",
|
||||
"snowfall",
|
||||
"location",
|
||||
"default",
|
||||
"all",
|
||||
);
|
||||
|
||||
Getopt::Long::Configure("bundling_override", "ignorecase_always");
|
||||
my $usage = "Usage: wttr [-u <user account>] [location] [" . join(' ', map { "-$_" } @wttr_options) . "]";
|
||||
my $getopt_error;
|
||||
local $SIG{__WARN__} = sub {
|
||||
$getopt_error = shift;
|
||||
chomp $getopt_error;
|
||||
};
|
||||
|
||||
my %options;
|
||||
my ($ret, $args) = GetOptionsFromString($arguments,
|
||||
\%options,
|
||||
'u=s',
|
||||
'h',
|
||||
@wttr_options
|
||||
);
|
||||
Getopt::Long::Configure("bundling_override", "ignorecase_always");
|
||||
|
||||
return "/say $getopt_error -- $usage" if defined $getopt_error;
|
||||
return $usage if exists $options{h};
|
||||
$arguments = "@$args";
|
||||
my %options;
|
||||
my ($ret, $args) = GetOptionsFromString(
|
||||
$arguments,
|
||||
\%options,
|
||||
'u=s',
|
||||
'h',
|
||||
@wttr_options
|
||||
);
|
||||
|
||||
my $hostmask = defined $options{u} ? $options{u} : "$nick!$user\@$host";
|
||||
my $location_override = $self->{pbot}->{users}->get_user_metadata($from, $hostmask, 'location') // '';
|
||||
$arguments = $location_override if not length $arguments;
|
||||
return "/say $getopt_error -- $usage" if defined $getopt_error;
|
||||
return $usage if exists $options{h};
|
||||
$arguments = "@$args";
|
||||
|
||||
if (defined $options{u} and not length $location_override) {
|
||||
return "No location set or user account does not exist.";
|
||||
}
|
||||
my $hostmask = defined $options{u} ? $options{u} : "$nick!$user\@$host";
|
||||
my $location_override = $self->{pbot}->{users}->get_user_metadata($from, $hostmask, 'location') // '';
|
||||
$arguments = $location_override if not length $arguments;
|
||||
|
||||
delete $options{u};
|
||||
if (defined $options{u} and not length $location_override) { return "No location set or user account does not exist."; }
|
||||
|
||||
if (not length $arguments) {
|
||||
return $usage;
|
||||
}
|
||||
delete $options{u};
|
||||
|
||||
$options{default} = 1 if not keys %options;
|
||||
if (not length $arguments) { return $usage; }
|
||||
|
||||
if (defined $options{all}) {
|
||||
%options = ();
|
||||
map { my $opt = $_; $opt =~ s/\|.*$//; $options{$opt} = 1 } @wttr_options;
|
||||
delete $options{all};
|
||||
delete $options{default};
|
||||
}
|
||||
$options{default} = 1 if not keys %options;
|
||||
|
||||
return $self->get_wttr($arguments, %options);
|
||||
if (defined $options{all}) {
|
||||
%options = ();
|
||||
map { my $opt = $_; $opt =~ s/\|.*$//; $options{$opt} = 1 } @wttr_options;
|
||||
delete $options{all};
|
||||
delete $options{default};
|
||||
}
|
||||
|
||||
return $self->get_wttr($arguments, %options);
|
||||
}
|
||||
|
||||
sub get_wttr {
|
||||
my ($self, $location, %options) = @_;
|
||||
|
||||
my %cache_opt = (
|
||||
'namespace' => 'wttr',
|
||||
'default_expires_in' => 3600
|
||||
);
|
||||
my ($self, $location, %options) = @_;
|
||||
|
||||
my $location_uri = uri_escape_utf8 $location;
|
||||
my %cache_opt = (
|
||||
'namespace' => 'wttr',
|
||||
'default_expires_in' => 3600
|
||||
);
|
||||
|
||||
my $ua = PBot::Utils::LWPUserAgentCached->new(\%cache_opt, timeout => 30);
|
||||
my $response = $ua->get("http://wttr.in/$location_uri?format=j1&m");
|
||||
my $location_uri = uri_escape_utf8 $location;
|
||||
|
||||
my $json;
|
||||
if ($response->is_success) {
|
||||
$json = $response->decoded_content;
|
||||
} else {
|
||||
return "Failed to fetch weather data: " . $response->status_line;
|
||||
}
|
||||
my $ua = PBot::Utils::LWPUserAgentCached->new(\%cache_opt, timeout => 30);
|
||||
my $response = $ua->get("http://wttr.in/$location_uri?format=j1&m");
|
||||
|
||||
my $wttr = decode_json $json;
|
||||
my $json;
|
||||
|
||||
# title-case location
|
||||
$location = ucfirst lc $location;
|
||||
$location =~ s/( |\.)(\w)/$1 . uc $2/ge;
|
||||
if ($response->is_success) { $json = $response->decoded_content; }
|
||||
else { return "Failed to fetch weather data: " . $response->status_line; }
|
||||
|
||||
my $result = "Weather for $location: ";
|
||||
my $wttr = decode_json $json;
|
||||
|
||||
my $c = $wttr->{'current_condition'}->[0];
|
||||
my $w = $wttr->{'weather'}->[0];
|
||||
my $h = $w->{'hourly'}->[0];
|
||||
# title-case location
|
||||
$location = ucfirst lc $location;
|
||||
$location =~ s/( |\.)(\w)/$1 . uc $2/ge;
|
||||
|
||||
foreach my $option (sort keys %options) {
|
||||
given ($option) {
|
||||
when ('default') {
|
||||
$result .= "Currently: $c->{'weatherDesc'}->[0]->{'value'}: $c->{'temp_C'}C/$c->{'temp_F'}F; ";
|
||||
$result .= "Forecast: High: $w->{maxtempC}C/$w->{maxtempF}F, Low: $w->{mintempC}C/$w->{mintempF}F; ";
|
||||
$result .= "Condition changes: ";
|
||||
my $result = "Weather for $location: ";
|
||||
|
||||
my $last_condition = $c->{'weatherDesc'}->[0]->{'value'};
|
||||
my $sep = '';
|
||||
my $c = $wttr->{'current_condition'}->[0];
|
||||
my $w = $wttr->{'weather'}->[0];
|
||||
my $h = $w->{'hourly'}->[0];
|
||||
|
||||
foreach my $hour (@{ $w->{'hourly'} }) {
|
||||
my $condition = $hour->{'weatherDesc'}->[0]->{'value'};
|
||||
my $temp = "$hour->{FeelsLikeC}C/$hour->{FeelsLikeF}F";
|
||||
my $time = sprintf "%04d", $hour->{'time'};
|
||||
$time =~ s/(\d{2})$/:$1/;
|
||||
foreach my $option (sort keys %options) {
|
||||
given ($option) {
|
||||
when ('default') {
|
||||
$result .= "Currently: $c->{'weatherDesc'}->[0]->{'value'}: $c->{'temp_C'}C/$c->{'temp_F'}F; ";
|
||||
$result .= "Forecast: High: $w->{maxtempC}C/$w->{maxtempF}F, Low: $w->{mintempC}C/$w->{mintempF}F; ";
|
||||
$result .= "Condition changes: ";
|
||||
|
||||
if ($condition ne $last_condition) {
|
||||
$result .= "$sep$time: $condition ($temp)";
|
||||
$sep = '-> ';
|
||||
$last_condition = $condition;
|
||||
}
|
||||
my $last_condition = $c->{'weatherDesc'}->[0]->{'value'};
|
||||
my $sep = '';
|
||||
|
||||
foreach my $hour (@{$w->{'hourly'}}) {
|
||||
my $condition = $hour->{'weatherDesc'}->[0]->{'value'};
|
||||
my $temp = "$hour->{FeelsLikeC}C/$hour->{FeelsLikeF}F";
|
||||
my $time = sprintf "%04d", $hour->{'time'};
|
||||
$time =~ s/(\d{2})$/:$1/;
|
||||
|
||||
if ($condition ne $last_condition) {
|
||||
$result .= "$sep$time: $condition ($temp)";
|
||||
$sep = '-> ';
|
||||
$last_condition = $condition;
|
||||
}
|
||||
}
|
||||
|
||||
if ($sep eq '') { $result .= $last_condition; }
|
||||
$result .= "; ";
|
||||
}
|
||||
|
||||
when ('conditions') {
|
||||
$result .= "Current conditions: $c->{'weatherDesc'}->[0]->{'value'}: $c->{'temp_C'}C/$c->{'temp_F'}F (Feels like $c->{'FeelsLikeC'}C/$c->{'FeelsLikeF'}F); ";
|
||||
$result .= "Cloud cover: $c->{'cloudcover'}%; Visibility: $c->{'visibility'}km; ";
|
||||
$result .= "Wind: $c->{'windspeedKmph'}kph/$c->{'windspeedMiles'}mph $c->{'winddirDegree'}°/$c->{'winddir16Point'}; ";
|
||||
$result .= "Humidity: $c->{'humidity'}%; Precip: $c->{'precipMM'}mm; Pressure: $c->{'pressure'}hPa; UV Index: $c->{'uvIndex'}; ";
|
||||
}
|
||||
|
||||
when ('forecast') {
|
||||
$result .= "Hourly forecast: ";
|
||||
my ($last_temp, $last_condition, $sep) = ('', '', '');
|
||||
foreach my $hour (@{$wttr->{'weather'}->[0]->{'hourly'}}) {
|
||||
my $temp = "$hour->{FeelsLikeC}C/$hour->{FeelsLikeF}F";
|
||||
my $condition = $hour->{'weatherDesc'}->[0]->{'value'};
|
||||
my $text = '';
|
||||
|
||||
if ($temp ne $last_temp) {
|
||||
$text .= $temp;
|
||||
$last_temp = $temp;
|
||||
}
|
||||
|
||||
if ($condition ne $last_condition) {
|
||||
$text .= ' ' if length $text;
|
||||
$text .= $condition;
|
||||
$last_condition = $condition;
|
||||
}
|
||||
|
||||
if (length $text) {
|
||||
my $time = sprintf "%04d", $hour->{'time'};
|
||||
$time =~ s/(\d{2})$/:$1/;
|
||||
$result .= "$sep $time: $text";
|
||||
$sep = ', ';
|
||||
}
|
||||
}
|
||||
$result .= "; ";
|
||||
}
|
||||
|
||||
when ('chances') {
|
||||
$result .= "Chances of: ";
|
||||
$result .= "Fog: $h->{'chanceoffog'}%, " if $h->{'chanceoffog'};
|
||||
$result .= "Frost: $h->{'chanceoffrost'}%, " if $h->{'chanceoffrost'};
|
||||
$result .= "High temp: $h->{'chanceofhightemp'}%, " if $h->{'chanceofhightemp'};
|
||||
$result .= "Overcast: $h->{'chanceofovercast'}%, " if $h->{'chanceofovercast'};
|
||||
$result .= "Rain: $h->{'chanceofrain'}%, " if $h->{'chanceofrain'};
|
||||
$result .= "Remaining dry: $h->{'chanceofremdry'}%, " if $h->{'chanceofremdry'};
|
||||
$result .= "Snow: $h->{'chanceofsnow'}%, " if $h->{'chanceofsnow'};
|
||||
$result .= "Sunshine: $h->{'chanceofsunshine'}%, " if $h->{'chanceofsunshine'};
|
||||
$result .= "Thunder: $h->{'chanceofthunder'}%, " if $h->{'chanceofthunder'};
|
||||
$result .= "Windy: $h->{'chanceofwindy'}%, " if $h->{'chanceofwindy'};
|
||||
$result =~ s/,\s+$/; /;
|
||||
}
|
||||
|
||||
when ('wind') {
|
||||
$result .= "Wind: $c->{'windspeedKmph'}kph/$c->{'windspeedMiles'}mph $c->{'winddirDegree'}°/$c->{'winddir16Point'}, ";
|
||||
$result .= "gust: $h->{'WindGustKmph'}kph/$h->{'WindGustMiles'}mph, chill: $h->{'WindChillC'}C/$h->{'WindChillF'}F; ";
|
||||
}
|
||||
|
||||
when ('location') {
|
||||
my $l = $wttr->{'request'}->[0];
|
||||
$result .= "Location: $l->{'query'} ($l->{'type'}); ";
|
||||
}
|
||||
|
||||
when ('dewpoint') { $result .= "Dew point: $h->{'DewPointC'}C/$h->{'DewPointF'}F; "; }
|
||||
|
||||
when ('feelslike') { $result .= "Feels like: $h->{'FeelsLikeC'}C/$h->{'FeelsLikeF'}F; "; }
|
||||
|
||||
when ('heatindex') { $result .= "Heat index: $h->{'HeatIndexC'}C/$h->{'HeatIndexF'}F; "; }
|
||||
|
||||
when ('moon') {
|
||||
my $a = $w->{'astronomy'}->[0];
|
||||
$result .= "Moon: phase: $a->{'moon_phase'}, illumination: $a->{'moon_illumination'}%, rise: $a->{'moonrise'}, set: $a->{'moonset'}; ";
|
||||
}
|
||||
|
||||
when ('sunrise') {
|
||||
my $a = $w->{'astronomy'}->[0];
|
||||
$result .= "Sun: rise: $a->{'sunrise'}, set: $a->{'sunset'}; ";
|
||||
}
|
||||
|
||||
when ('sunhours') { $result .= "Hours of sun: $w->{'sunHour'}; "; }
|
||||
|
||||
when ('snowfall') { $result .= "Total snow: $w->{'totalSnow_cm'}cm; "; }
|
||||
|
||||
when ('uvindex') { $result .= "UV Index: $c->{'uvIndex'}; "; }
|
||||
|
||||
when ('visibility') { $result .= "Visibility: $c->{'visibility'}km; "; }
|
||||
|
||||
when ('cloudcover') { $result .= "Cloud cover: $c->{'cloudcover'}%; "; }
|
||||
|
||||
default { $result .= "Option $_ coming soon; " unless lc $_ eq 'u'; }
|
||||
}
|
||||
|
||||
if ($sep eq '') {
|
||||
$result .= $last_condition;
|
||||
}
|
||||
$result .= "; ";
|
||||
}
|
||||
|
||||
when ('conditions') {
|
||||
$result .= "Current conditions: $c->{'weatherDesc'}->[0]->{'value'}: $c->{'temp_C'}C/$c->{'temp_F'}F (Feels like $c->{'FeelsLikeC'}C/$c->{'FeelsLikeF'}F); ";
|
||||
$result .= "Cloud cover: $c->{'cloudcover'}%; Visibility: $c->{'visibility'}km; ";
|
||||
$result .= "Wind: $c->{'windspeedKmph'}kph/$c->{'windspeedMiles'}mph $c->{'winddirDegree'}°/$c->{'winddir16Point'}; ";
|
||||
$result .= "Humidity: $c->{'humidity'}%; Precip: $c->{'precipMM'}mm; Pressure: $c->{'pressure'}hPa; UV Index: $c->{'uvIndex'}; ";
|
||||
}
|
||||
|
||||
when ('forecast') {
|
||||
$result .= "Hourly forecast: ";
|
||||
my ($last_temp, $last_condition, $sep) = ('', '', '');
|
||||
foreach my $hour (@{ $wttr->{'weather'}->[0]->{'hourly'} }) {
|
||||
my $temp = "$hour->{FeelsLikeC}C/$hour->{FeelsLikeF}F";
|
||||
my $condition = $hour->{'weatherDesc'}->[0]->{'value'};
|
||||
my $text = '';
|
||||
|
||||
if ($temp ne $last_temp) {
|
||||
$text .= $temp;
|
||||
$last_temp = $temp;
|
||||
}
|
||||
|
||||
if ($condition ne $last_condition) {
|
||||
$text .= ' ' if length $text;
|
||||
$text .= $condition;
|
||||
$last_condition = $condition;
|
||||
}
|
||||
|
||||
if (length $text) {
|
||||
my $time = sprintf "%04d", $hour->{'time'};
|
||||
$time =~ s/(\d{2})$/:$1/;
|
||||
$result .= "$sep $time: $text";
|
||||
$sep = ', ';
|
||||
}
|
||||
}
|
||||
$result .= "; ";
|
||||
}
|
||||
|
||||
when ('chances') {
|
||||
$result .= "Chances of: ";
|
||||
$result .= "Fog: $h->{'chanceoffog'}%, " if $h->{'chanceoffog'};
|
||||
$result .= "Frost: $h->{'chanceoffrost'}%, " if $h->{'chanceoffrost'};
|
||||
$result .= "High temp: $h->{'chanceofhightemp'}%, " if $h->{'chanceofhightemp'};
|
||||
$result .= "Overcast: $h->{'chanceofovercast'}%, " if $h->{'chanceofovercast'};
|
||||
$result .= "Rain: $h->{'chanceofrain'}%, " if $h->{'chanceofrain'};
|
||||
$result .= "Remaining dry: $h->{'chanceofremdry'}%, " if $h->{'chanceofremdry'};
|
||||
$result .= "Snow: $h->{'chanceofsnow'}%, " if $h->{'chanceofsnow'};
|
||||
$result .= "Sunshine: $h->{'chanceofsunshine'}%, " if $h->{'chanceofsunshine'};
|
||||
$result .= "Thunder: $h->{'chanceofthunder'}%, " if $h->{'chanceofthunder'};
|
||||
$result .= "Windy: $h->{'chanceofwindy'}%, " if $h->{'chanceofwindy'};
|
||||
$result =~ s/,\s+$/; /;
|
||||
}
|
||||
|
||||
when ('wind') {
|
||||
$result .= "Wind: $c->{'windspeedKmph'}kph/$c->{'windspeedMiles'}mph $c->{'winddirDegree'}°/$c->{'winddir16Point'}, ";
|
||||
$result .= "gust: $h->{'WindGustKmph'}kph/$h->{'WindGustMiles'}mph, chill: $h->{'WindChillC'}C/$h->{'WindChillF'}F; ";
|
||||
}
|
||||
|
||||
when ('location') {
|
||||
my $l = $wttr->{'request'}->[0];
|
||||
$result .= "Location: $l->{'query'} ($l->{'type'}); ";
|
||||
}
|
||||
|
||||
when ('dewpoint') {
|
||||
$result .= "Dew point: $h->{'DewPointC'}C/$h->{'DewPointF'}F; ";
|
||||
}
|
||||
|
||||
when ('feelslike') {
|
||||
$result .= "Feels like: $h->{'FeelsLikeC'}C/$h->{'FeelsLikeF'}F; ";
|
||||
}
|
||||
|
||||
when ('heatindex') {
|
||||
$result .= "Heat index: $h->{'HeatIndexC'}C/$h->{'HeatIndexF'}F; ";
|
||||
}
|
||||
|
||||
when ('moon') {
|
||||
my $a = $w->{'astronomy'}->[0];
|
||||
$result .= "Moon: phase: $a->{'moon_phase'}, illumination: $a->{'moon_illumination'}%, rise: $a->{'moonrise'}, set: $a->{'moonset'}; ";
|
||||
}
|
||||
|
||||
when ('sunrise') {
|
||||
my $a = $w->{'astronomy'}->[0];
|
||||
$result .= "Sun: rise: $a->{'sunrise'}, set: $a->{'sunset'}; ";
|
||||
}
|
||||
|
||||
when ('sunhours') {
|
||||
$result .= "Hours of sun: $w->{'sunHour'}; ";
|
||||
}
|
||||
|
||||
when ('snowfall') {
|
||||
$result .= "Total snow: $w->{'totalSnow_cm'}cm; ";
|
||||
}
|
||||
|
||||
when ('uvindex') {
|
||||
$result .= "UV Index: $c->{'uvIndex'}; ";
|
||||
}
|
||||
|
||||
when ('visibility') {
|
||||
$result .= "Visibility: $c->{'visibility'}km; ";
|
||||
}
|
||||
|
||||
when ('cloudcover') {
|
||||
$result .= "Cloud cover: $c->{'cloudcover'}%; ";
|
||||
}
|
||||
|
||||
default {
|
||||
$result .= "Option $_ coming soon; " unless lc $_ eq 'u';
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$result =~ s/;\s+$//;
|
||||
return $result;
|
||||
$result =~ s/;\s+$//;
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
#!/bin/bash
|
||||
perltidy -utf8 -nanl -boc $* -b -bext=/ && perltidy -conv -boc -utf8 -kis -l=170 -vmll -pt=2 -sbt=2 -bt=2 -nsfs -ce -b -bext=/ -nolq -nolc -iscl -nbbc -kgb $*
|
||||
|
|
@ -9,8 +9,8 @@ use Time::Duration;
|
|||
my ($ago) = @ARGV;
|
||||
|
||||
if (not defined $ago) {
|
||||
print "Usage: ago <seconds>\n";
|
||||
exit 0;
|
||||
print "Usage: ago <seconds>\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
print ago_exact($ago), "\n";
|
||||
|
|
|
|||
|
|
@ -16,57 +16,55 @@ my $RESULTS_SPECIFIED = 2;
|
|||
my $search = join ' ', @ARGV;
|
||||
|
||||
if (not length $search) {
|
||||
print "Usage: c11std [-list] [-n#] [-section <section>] [search text] -- 'section' must be in the form of X.YpZ where X and Y are section/chapter and, optionally, pZ is paragraph. If both 'section' and 'search text' are specified, then the search space will be within the specified section. You may use -n # to skip to the #th match. To list only the section numbers containing 'search text', add -list.\n";
|
||||
exit 0;
|
||||
print
|
||||
"Usage: c11std [-list] [-n#] [-section <section>] [search text] -- 'section' must be in the form of X.YpZ where X and Y are section/chapter and, optionally, pZ is paragraph. If both 'section' and 'search text' are specified, then the search space will be within the specified section. You may use -n # to skip to the #th match. To list only the section numbers containing 'search text', add -list.\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my ($section, $paragraph, $section_specified, $paragraph_specified, $match, $list_only, $list_titles);
|
||||
|
||||
$section_specified = 0;
|
||||
$section_specified = 0;
|
||||
$paragraph_specified = 0;
|
||||
|
||||
if ($search =~ s/-section\s*([A-Z0-9\.p]+)//i or $search =~ s/\b([A-Z0-9]+\.[0-9\.p]+)//i) {
|
||||
$section = $1;
|
||||
$section = $1;
|
||||
|
||||
if ($section =~ s/p(\d+)//i) {
|
||||
$paragraph = $1;
|
||||
$paragraph_specified = $USER_SPECIFIED;
|
||||
} else {
|
||||
$paragraph = 1;
|
||||
}
|
||||
if ($section =~ s/p(\d+)//i) {
|
||||
$paragraph = $1;
|
||||
$paragraph_specified = $USER_SPECIFIED;
|
||||
} else {
|
||||
$paragraph = 1;
|
||||
}
|
||||
|
||||
$section = "$section." if $section =~ m/^[A-Z0-9]+$/i;
|
||||
$section = "$section." if $section =~ m/^[A-Z0-9]+$/i;
|
||||
|
||||
$section_specified = 1;
|
||||
$section_specified = 1;
|
||||
}
|
||||
|
||||
if ($search =~ s/-n\s*(\d+)//) {
|
||||
$match = $1;
|
||||
} else {
|
||||
$match = 1;
|
||||
}
|
||||
if ($search =~ s/-n\s*(\d+)//) { $match = $1; }
|
||||
else { $match = 1; }
|
||||
|
||||
if ($search =~ s/-list//i) {
|
||||
$list_only = 1;
|
||||
$list_titles = 1; # Added here instead of removing -titles option
|
||||
$list_only = 1;
|
||||
$list_titles = 1; # Added here instead of removing -titles option
|
||||
}
|
||||
|
||||
if ($search =~ s/-titles//i) {
|
||||
$list_only = 1;
|
||||
$list_titles = 1;
|
||||
$list_only = 1;
|
||||
$list_titles = 1;
|
||||
}
|
||||
|
||||
$search =~ s/^\s+//;
|
||||
$search =~ s/\s+$//;
|
||||
|
||||
if (not defined $section) {
|
||||
$section = "1.";
|
||||
$paragraph = 1;
|
||||
$section = "1.";
|
||||
$paragraph = 1;
|
||||
}
|
||||
|
||||
if ($list_only and not length $search) {
|
||||
print "You must specify some search text to use with -list.\n";
|
||||
exit 0;
|
||||
print "You must specify some search text to use with -list.\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
open FH, "<n1570.out" or die "Could not open n1570: $!";
|
||||
|
|
@ -77,156 +75,150 @@ my $text = join '', @contents;
|
|||
$text =~ s/\r//g;
|
||||
|
||||
my $result;
|
||||
my $found_section = "";
|
||||
my $found_section = "";
|
||||
my $found_section_title = "";
|
||||
my $section_title;
|
||||
my $found_paragraph;
|
||||
my $found = 0;
|
||||
my $found = 0;
|
||||
my $matches = 0;
|
||||
my $this_section;
|
||||
my $comma = "";
|
||||
|
||||
if ($list_only) {
|
||||
$result = "Sections containing '$search':\n ";
|
||||
}
|
||||
if ($list_only) { $result = "Sections containing '$search':\n "; }
|
||||
|
||||
my $qsearch = quotemeta $search;
|
||||
$qsearch =~ s/\\ / /g;
|
||||
$qsearch =~ s/\s+/\\s+/g;
|
||||
|
||||
while ($text =~ m/^\s{0,4}([0-9A-Z]+\.[0-9\.]*)/msg) {
|
||||
$this_section = $1;
|
||||
$this_section = $1;
|
||||
|
||||
print "----------------------------------\n" if $debug >= 2;
|
||||
print "Processing section [$this_section]\n" if $debug;
|
||||
print "----------------------------------\n" if $debug >= 2;
|
||||
print "Processing section [$this_section]\n" if $debug;
|
||||
|
||||
|
||||
if ($section_specified and $this_section !~ m/^$section/i) {
|
||||
print "No section match, skipping.\n" if $debug >= 4;
|
||||
next;
|
||||
}
|
||||
|
||||
my $section_text;
|
||||
|
||||
if ($text =~ m/(.*?)^(?=\s{0,4}(?!FOOTNOTE)[0-9A-Z]+\.)/msg) {
|
||||
$section_text = $1;
|
||||
} else {
|
||||
print "No section text, end of file marker found.\n" if $debug >= 4;
|
||||
last;
|
||||
}
|
||||
|
||||
if ($section =~ /FOOTNOTE/i) {
|
||||
$section_text =~ s/^\s{4}//ms;
|
||||
$section_text =~ s/^\s{4}FOOTNOTE.*//msi;
|
||||
$section_text =~ s/^\d.*//ms;
|
||||
} elsif ($section_text =~ m/(.*?)$/msg) {
|
||||
$section_title = $1 if length $1;
|
||||
$section_title =~ s/^\s+//;
|
||||
$section_title =~ s/\s+$//;
|
||||
}
|
||||
|
||||
print "$this_section [$section_title]\n" if $debug >= 2;
|
||||
|
||||
while ($section_text =~ m/^(\d+)\s(.*?)^(?=\d)/msgic or $section_text =~ m/^(\d+)\s(.*)/msgi) {
|
||||
my $p = $1 ;
|
||||
my $t = $2;
|
||||
|
||||
print "paragraph $p: [$t]\n" if $debug >= 3;
|
||||
|
||||
if ($paragraph_specified == $USER_SPECIFIED and not length $search and $p == $paragraph) {
|
||||
$result = $t if not $found;
|
||||
$found_paragraph = $p;
|
||||
$found_section = $this_section;
|
||||
$found_section_title = $section_title;
|
||||
$found = 1;
|
||||
last;
|
||||
if ($section_specified and $this_section !~ m/^$section/i) {
|
||||
print "No section match, skipping.\n" if $debug >= 4;
|
||||
next;
|
||||
}
|
||||
|
||||
if (length $search) {
|
||||
eval {
|
||||
if ($t =~ m/\b$qsearch\b/mis or $section_title =~ m/\b$qsearch\b/mis) {
|
||||
$matches++;
|
||||
if ($matches >= $match) {
|
||||
if ($list_only) {
|
||||
$result .= sprintf("%s%-15s", $comma, $this_section."p".$p);
|
||||
$result .= " $section_title" if $list_titles;
|
||||
$comma = ",\n ";
|
||||
} else {
|
||||
if (not $found) {
|
||||
$result = $t;
|
||||
$found_section = $this_section;
|
||||
$found_section_title = $section_title;
|
||||
$found_paragraph = $p;
|
||||
$paragraph_specified = $RESULTS_SPECIFIED;
|
||||
}
|
||||
$found = 1;
|
||||
}
|
||||
}
|
||||
my $section_text;
|
||||
|
||||
if ($text =~ m/(.*?)^(?=\s{0,4}(?!FOOTNOTE)[0-9A-Z]+\.)/msg) { $section_text = $1; }
|
||||
else {
|
||||
print "No section text, end of file marker found.\n" if $debug >= 4;
|
||||
last;
|
||||
}
|
||||
|
||||
if ($section =~ /FOOTNOTE/i) {
|
||||
$section_text =~ s/^\s{4}//ms;
|
||||
$section_text =~ s/^\s{4}FOOTNOTE.*//msi;
|
||||
$section_text =~ s/^\d.*//ms;
|
||||
} elsif ($section_text =~ m/(.*?)$/msg) {
|
||||
$section_title = $1 if length $1;
|
||||
$section_title =~ s/^\s+//;
|
||||
$section_title =~ s/\s+$//;
|
||||
}
|
||||
|
||||
print "$this_section [$section_title]\n" if $debug >= 2;
|
||||
|
||||
while ($section_text =~ m/^(\d+)\s(.*?)^(?=\d)/msgic or $section_text =~ m/^(\d+)\s(.*)/msgi) {
|
||||
my $p = $1;
|
||||
my $t = $2;
|
||||
|
||||
print "paragraph $p: [$t]\n" if $debug >= 3;
|
||||
|
||||
if ($paragraph_specified == $USER_SPECIFIED and not length $search and $p == $paragraph) {
|
||||
$result = $t if not $found;
|
||||
$found_paragraph = $p;
|
||||
$found_section = $this_section;
|
||||
$found_section_title = $section_title;
|
||||
$found = 1;
|
||||
last;
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
print "Error in search regex; you may need to escape characters such as *, ?, ., etc.\n";
|
||||
if (length $search) {
|
||||
eval {
|
||||
if ($t =~ m/\b$qsearch\b/mis or $section_title =~ m/\b$qsearch\b/mis) {
|
||||
$matches++;
|
||||
if ($matches >= $match) {
|
||||
if ($list_only) {
|
||||
$result .= sprintf("%s%-15s", $comma, $this_section . "p" . $p);
|
||||
$result .= " $section_title" if $list_titles;
|
||||
$comma = ",\n ";
|
||||
} else {
|
||||
if (not $found) {
|
||||
$result = $t;
|
||||
$found_section = $this_section;
|
||||
$found_section_title = $section_title;
|
||||
$found_paragraph = $p;
|
||||
$paragraph_specified = $RESULTS_SPECIFIED;
|
||||
}
|
||||
$found = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
print "Error in search regex; you may need to escape characters such as *, ?, ., etc.\n";
|
||||
exit 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
last if $found && $paragraph_specified == $USER_SPECIFIED;
|
||||
|
||||
if ($paragraph_specified == $USER_SPECIFIED) {
|
||||
if (length $search) { print "No such text '$search' in paragraph $paragraph of section $section of n1570.\n"; }
|
||||
else { print "No such paragraph $paragraph in section $section of n1570.\n"; }
|
||||
exit 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
last if $found && $paragraph_specified == $USER_SPECIFIED;
|
||||
|
||||
if ($paragraph_specified == $USER_SPECIFIED) {
|
||||
if (length $search) {
|
||||
print "No such text '$search' in paragraph $paragraph of section $section of n1570.\n";
|
||||
} else {
|
||||
print "No such paragraph $paragraph in section $section of n1570.\n";
|
||||
if (defined $section_specified and not length $search) {
|
||||
$found = 1;
|
||||
$found_section = $this_section;
|
||||
$found_section_title = $section_title;
|
||||
$found_paragraph = $paragraph;
|
||||
$result = $section_text;
|
||||
last;
|
||||
}
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if (defined $section_specified and not length $search) {
|
||||
$found = 1;
|
||||
$found_section = $this_section;
|
||||
$found_section_title = $section_title;
|
||||
$found_paragraph = $paragraph;
|
||||
$result = $section_text;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
if (not $found and $comma eq "") {
|
||||
$search =~ s/\\s\+/ /g;
|
||||
if ($section_specified) {
|
||||
print "No such text '$search' found within section '$section' in C11 Draft Standard (n1570).\n" if length $search;
|
||||
print "No such section '$section' in C11 Draft Standard (n1570).\n" if not length $search;
|
||||
exit 0;
|
||||
}
|
||||
$search =~ s/\\s\+/ /g;
|
||||
if ($section_specified) {
|
||||
print "No such text '$search' found within section '$section' in C11 Draft Standard (n1570).\n" if length $search;
|
||||
print "No such section '$section' in C11 Draft Standard (n1570).\n" if not length $search;
|
||||
exit 0;
|
||||
}
|
||||
|
||||
print "No such section '$section' in C11 Draft Standard (n1570).\n" if not length $search;
|
||||
print "No such text '$search' found in C11 Draft Standard (n1570).\n" if length $search;
|
||||
exit 0;
|
||||
print "No such section '$section' in C11 Draft Standard (n1570).\n" if not length $search;
|
||||
print "No such text '$search' found in C11 Draft Standard (n1570).\n" if length $search;
|
||||
exit 0;
|
||||
}
|
||||
|
||||
$result =~ s/$found_section_title// if length $found_section_title;
|
||||
$result =~ s/^\s+//;
|
||||
$result =~ s/\s+$//;
|
||||
|
||||
=cut
|
||||
$result =~ s/\s+/ /g;
|
||||
$result =~ s/[\n\r]/ /g;
|
||||
=cut
|
||||
|
||||
if ($matches > 1 and not $list_only) {
|
||||
print "Displaying $match of $matches matches: ";
|
||||
}
|
||||
if ($matches > 1 and not $list_only) { print "Displaying $match of $matches matches: "; }
|
||||
|
||||
if ($comma eq "") {
|
||||
|
||||
=cut
|
||||
print $found_section;
|
||||
print "p" . $found_paragraph if $paragraph_specified;
|
||||
=cut
|
||||
print "http://www.iso-9899.info/n1570.html\#$found_section";
|
||||
print "p" . $found_paragraph if $paragraph_specified;
|
||||
print "\n\n";
|
||||
print "[", $found_section_title, "]\n\n" if length $found_section_title;
|
||||
|
||||
print "http://www.iso-9899.info/n1570.html\#$found_section";
|
||||
print "p" . $found_paragraph if $paragraph_specified;
|
||||
print "\n\n";
|
||||
print "[", $found_section_title, "]\n\n" if length $found_section_title;
|
||||
}
|
||||
|
||||
$result =~ s/\s*Constraints\s*$//;
|
||||
|
|
|
|||
|
|
@ -17,19 +17,18 @@ my $debug = 0;
|
|||
my $code = join ' ', @ARGV;
|
||||
|
||||
if (not length $code) {
|
||||
print "Usage: english <any C11 code>\n";
|
||||
exit;
|
||||
print "Usage: english <any C11 code>\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
my $output;
|
||||
|
||||
my $force;
|
||||
if ($code =~ s/^-f\s+//) {
|
||||
$force = 1;
|
||||
}
|
||||
if ($code =~ s/^-f\s+//) { $force = 1; }
|
||||
|
||||
my ($has_function, $has_main, $got_nomain);
|
||||
my $prelude_base = "#define _XOPEN_SOURCE 9001\n#define __USE_XOPEN\n#include <stdio.h>\n#include <stdlib.h>\n#include <string.h>\n#include <unistd.h>\n#include <math.h>\n#include <limits.h>\n#include <sys/types.h>\n#include <stdint.h>\n#include <errno.h>\n#include <ctype.h>\n#include <assert.h>\n#include <stdnoreturn.h>\n#include <stdbool.h>\n#include <stdalign.h>\n#include <time.h>\n#include <stddef.h>\n#include <uchar.h>\n#define _Atomic\n#define _Static_assert(a, b)\n\n";
|
||||
my $prelude_base =
|
||||
"#define _XOPEN_SOURCE 9001\n#define __USE_XOPEN\n#include <stdio.h>\n#include <stdlib.h>\n#include <string.h>\n#include <unistd.h>\n#include <math.h>\n#include <limits.h>\n#include <sys/types.h>\n#include <stdint.h>\n#include <errno.h>\n#include <ctype.h>\n#include <assert.h>\n#include <stdnoreturn.h>\n#include <stdbool.h>\n#include <stdalign.h>\n#include <time.h>\n#include <stddef.h>\n#include <uchar.h>\n#define _Atomic\n#define _Static_assert(a, b)\n\n";
|
||||
my $prelude = $prelude_base;
|
||||
|
||||
print "code before: [$code]\n" if $debug;
|
||||
|
|
@ -38,55 +37,47 @@ print "code before: [$code]\n" if $debug;
|
|||
my $new_code = "";
|
||||
|
||||
use constant {
|
||||
NORMAL => 0,
|
||||
DOUBLE_QUOTED => 1,
|
||||
SINGLE_QUOTED => 2,
|
||||
NORMAL => 0,
|
||||
DOUBLE_QUOTED => 1,
|
||||
SINGLE_QUOTED => 2,
|
||||
};
|
||||
|
||||
my $state = NORMAL;
|
||||
my $state = NORMAL;
|
||||
my $escaped = 0;
|
||||
|
||||
while ($code =~ m/(.)/gs) {
|
||||
my $ch = $1;
|
||||
my $ch = $1;
|
||||
|
||||
given ($ch) {
|
||||
when ('\\') {
|
||||
if ($escaped == 0) {
|
||||
$escaped = 1;
|
||||
next;
|
||||
}
|
||||
given ($ch) {
|
||||
when ('\\') {
|
||||
if ($escaped == 0) {
|
||||
$escaped = 1;
|
||||
next;
|
||||
}
|
||||
}
|
||||
|
||||
if ($state == NORMAL) {
|
||||
when ($_ eq '"' and not $escaped) { $state = DOUBLE_QUOTED; }
|
||||
|
||||
when ($_ eq "'" and not $escaped) { $state = SINGLE_QUOTED; }
|
||||
|
||||
when ($_ eq 'n' and $escaped == 1) {
|
||||
$ch = "\n";
|
||||
$escaped = 0;
|
||||
}
|
||||
}
|
||||
|
||||
if ($state == DOUBLE_QUOTED) {
|
||||
when ($_ eq '"' and not $escaped) { $state = NORMAL; }
|
||||
}
|
||||
|
||||
if ($state == SINGLE_QUOTED) {
|
||||
when ($_ eq "'" and not $escaped) { $state = NORMAL; }
|
||||
}
|
||||
}
|
||||
|
||||
if ($state == NORMAL) {
|
||||
when ($_ eq '"' and not $escaped) {
|
||||
$state = DOUBLE_QUOTED;
|
||||
}
|
||||
|
||||
when ($_ eq "'" and not $escaped) {
|
||||
$state = SINGLE_QUOTED;
|
||||
}
|
||||
|
||||
when ($_ eq 'n' and $escaped == 1) {
|
||||
$ch = "\n";
|
||||
$escaped = 0;
|
||||
}
|
||||
}
|
||||
|
||||
if ($state == DOUBLE_QUOTED) {
|
||||
when ($_ eq '"' and not $escaped) {
|
||||
$state = NORMAL;
|
||||
}
|
||||
}
|
||||
|
||||
if ($state == SINGLE_QUOTED) {
|
||||
when ($_ eq "'" and not $escaped) {
|
||||
$state = NORMAL;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$new_code .= '\\' and $escaped = 0 if $escaped;
|
||||
$new_code .= $ch;
|
||||
$new_code .= '\\' and $escaped = 0 if $escaped;
|
||||
$new_code .= $ch;
|
||||
}
|
||||
|
||||
$code = $new_code;
|
||||
|
|
@ -95,69 +86,68 @@ print "code after \\n replacement: [$code]\n" if $debug;
|
|||
|
||||
my $single_quote = 0;
|
||||
my $double_quote = 0;
|
||||
my $parens = 0;
|
||||
my $parens = 0;
|
||||
$escaped = 0;
|
||||
my $cpp = 0; # preprocessor
|
||||
my $cpp = 0; # preprocessor
|
||||
|
||||
while ($code =~ m/(.)/msg) {
|
||||
my $ch = $1;
|
||||
my $pos = pos $code;
|
||||
my $ch = $1;
|
||||
my $pos = pos $code;
|
||||
|
||||
print "adding newlines, ch = [$ch], parens: $parens, cpp: $cpp, single: $single_quote, double: $double_quote, escaped: $escaped, pos: $pos\n" if $debug >= 10;
|
||||
print "adding newlines, ch = [$ch], parens: $parens, cpp: $cpp, single: $single_quote, double: $double_quote, escaped: $escaped, pos: $pos\n" if $debug >= 10;
|
||||
|
||||
if ($ch eq '\\') {
|
||||
$escaped = not $escaped;
|
||||
} elsif ($ch eq '#' and not $cpp and not $escaped and not $single_quote and not $double_quote) {
|
||||
$cpp = 1;
|
||||
if ($ch eq '\\') { $escaped = not $escaped; }
|
||||
elsif ($ch eq '#' and not $cpp and not $escaped and not $single_quote and not $double_quote) {
|
||||
$cpp = 1;
|
||||
|
||||
if ($code =~ m/include\s*[<"]([^>"]*)[>"]/msg) {
|
||||
my $match = $1;
|
||||
$pos = pos $code;
|
||||
substr ($code, $pos, 0) = "\n";
|
||||
pos $code = $pos;
|
||||
$cpp = 0;
|
||||
if ($code =~ m/include\s*[<"]([^>"]*)[>"]/msg) {
|
||||
my $match = $1;
|
||||
$pos = pos $code;
|
||||
substr($code, $pos, 0) = "\n";
|
||||
pos $code = $pos;
|
||||
$cpp = 0;
|
||||
} else {
|
||||
pos $code = $pos;
|
||||
}
|
||||
} elsif ($ch eq '"') {
|
||||
$double_quote = not $double_quote unless $escaped or $single_quote;
|
||||
$escaped = 0;
|
||||
} elsif ($ch eq '(' and not $single_quote and not $double_quote) {
|
||||
$parens++;
|
||||
} elsif ($ch eq ')' and not $single_quote and not $double_quote) {
|
||||
$parens--;
|
||||
$parens = 0 if $parens < 0;
|
||||
} elsif ($ch eq ';' and not $cpp and not $single_quote and not $double_quote and $parens == 0) {
|
||||
if (not substr($code, $pos, 1) =~ m/[\n\r]/) {
|
||||
substr($code, $pos, 0) = "\n";
|
||||
pos $code = $pos + 1;
|
||||
}
|
||||
} elsif ($ch eq "'") {
|
||||
$single_quote = not $single_quote unless $escaped or $double_quote;
|
||||
$escaped = 0;
|
||||
} elsif ($ch eq 'n' and $escaped) {
|
||||
if (not $single_quote and not $double_quote) {
|
||||
print "added newline\n" if $debug >= 10;
|
||||
substr($code, $pos - 2, 2) = "\n";
|
||||
pos $code = $pos;
|
||||
$cpp = 0;
|
||||
}
|
||||
$escaped = 0;
|
||||
} elsif ($ch eq '{' and not $cpp and not $single_quote and not $double_quote) {
|
||||
if (not substr($code, $pos, 1) =~ m/[\n\r]/) {
|
||||
substr($code, $pos, 0) = "\n";
|
||||
pos $code = $pos + 1;
|
||||
}
|
||||
} elsif ($ch eq '}' and not $cpp and not $single_quote and not $double_quote) {
|
||||
if (not substr($code, $pos, 1) =~ m/[\n\r;]/) {
|
||||
substr($code, $pos, 0) = "\n";
|
||||
pos $code = $pos + 1;
|
||||
}
|
||||
} elsif ($ch eq "\n" and $cpp and not $single_quote and not $double_quote) {
|
||||
$cpp = 0;
|
||||
} else {
|
||||
pos $code = $pos;
|
||||
$escaped = 0;
|
||||
}
|
||||
} elsif ($ch eq '"') {
|
||||
$double_quote = not $double_quote unless $escaped or $single_quote;
|
||||
$escaped = 0;
|
||||
} elsif ($ch eq '(' and not $single_quote and not $double_quote) {
|
||||
$parens++;
|
||||
} elsif ($ch eq ')' and not $single_quote and not $double_quote) {
|
||||
$parens--;
|
||||
$parens = 0 if $parens < 0;
|
||||
} elsif ($ch eq ';' and not $cpp and not $single_quote and not $double_quote and $parens == 0) {
|
||||
if (not substr($code, $pos, 1) =~ m/[\n\r]/) {
|
||||
substr ($code, $pos, 0) = "\n";
|
||||
pos $code = $pos + 1;
|
||||
}
|
||||
} elsif ($ch eq "'") {
|
||||
$single_quote = not $single_quote unless $escaped or $double_quote;
|
||||
$escaped = 0;
|
||||
} elsif ($ch eq 'n' and $escaped) {
|
||||
if (not $single_quote and not $double_quote) {
|
||||
print "added newline\n" if $debug >= 10;
|
||||
substr ($code, $pos - 2, 2) = "\n";
|
||||
pos $code = $pos;
|
||||
$cpp = 0;
|
||||
}
|
||||
$escaped = 0;
|
||||
} elsif ($ch eq '{' and not $cpp and not $single_quote and not $double_quote) {
|
||||
if (not substr($code, $pos, 1) =~ m/[\n\r]/) {
|
||||
substr ($code, $pos, 0) = "\n";
|
||||
pos $code = $pos + 1;
|
||||
}
|
||||
} elsif ($ch eq '}' and not $cpp and not $single_quote and not $double_quote) {
|
||||
if (not substr($code, $pos, 1) =~ m/[\n\r;]/) {
|
||||
substr ($code, $pos, 0) = "\n";
|
||||
pos $code = $pos + 1;
|
||||
}
|
||||
} elsif ($ch eq "\n" and $cpp and not $single_quote and not $double_quote) {
|
||||
$cpp = 0;
|
||||
} else {
|
||||
$escaped = 0;
|
||||
}
|
||||
}
|
||||
|
||||
print "code after \\n additions: [$code]\n" if $debug;
|
||||
|
|
@ -168,11 +158,8 @@ $white_code =~ s/(?:\"((?:\\\"|(?!\").)*)\")/'"' . ('-' x length $1) . '"'/ge;
|
|||
$white_code =~ s/(?:\'((?:\\\'|(?!\').)*)\')/"'" . ('-' x length $1) . "'"/ge;
|
||||
|
||||
my $precode;
|
||||
if ($white_code =~ m/#include/) {
|
||||
$precode = $code;
|
||||
} else {
|
||||
$precode = $prelude . $code;
|
||||
}
|
||||
if ($white_code =~ m/#include/) { $precode = $code; }
|
||||
else { $precode = $prelude . $code; }
|
||||
$code = '';
|
||||
my $warn_unterminated_define = 0;
|
||||
|
||||
|
|
@ -181,117 +168,111 @@ print "--- precode: [$precode]\n" if $debug;
|
|||
my $lang = 'C89';
|
||||
|
||||
if ($lang eq 'C89' or $lang eq 'C99' or $lang eq 'C11' or $lang eq 'C++') {
|
||||
my $prelude = '';
|
||||
while ($precode =~ s/^\s*(#.*\n{1,2})//g) {
|
||||
$prelude .= $1;
|
||||
}
|
||||
my $prelude = '';
|
||||
while ($precode =~ s/^\s*(#.*\n{1,2})//g) { $prelude .= $1; }
|
||||
|
||||
if ($precode =~ m/^\s*(#.*)/ms) {
|
||||
my $line = $1;
|
||||
if ($precode =~ m/^\s*(#.*)/ms) {
|
||||
my $line = $1;
|
||||
|
||||
if ($line !~ m/\n/) {
|
||||
$warn_unterminated_define = 1;
|
||||
if ($line !~ m/\n/) { $warn_unterminated_define = 1; }
|
||||
}
|
||||
}
|
||||
|
||||
print "*** prelude: [$prelude]\n precode: [$precode]\n" if $debug;
|
||||
print "*** prelude: [$prelude]\n precode: [$precode]\n" if $debug;
|
||||
|
||||
my $preprecode = $precode;
|
||||
my $preprecode = $precode;
|
||||
|
||||
# white-out contents of quoted literals
|
||||
$preprecode =~ s/(?:\"((?:\\\"|(?!\").)*)\")/'"' . ('-' x length $1) . '"'/ge;
|
||||
$preprecode =~ s/(?:\'((?:\\\'|(?!\').)*)\')/"'" . ('-' x length $1) . "'"/ge;
|
||||
# white-out contents of quoted literals
|
||||
$preprecode =~ s/(?:\"((?:\\\"|(?!\").)*)\")/'"' . ('-' x length $1) . '"'/ge;
|
||||
$preprecode =~ s/(?:\'((?:\\\'|(?!\').)*)\')/"'" . ('-' x length $1) . "'"/ge;
|
||||
|
||||
# strip C and C++ style comments
|
||||
if ($lang eq 'C89') {
|
||||
$preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs;
|
||||
$preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse;
|
||||
} else {
|
||||
$preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse;
|
||||
$preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs;
|
||||
}
|
||||
|
||||
print "preprecode: [$preprecode]\n" if $debug;
|
||||
|
||||
print "looking for functions, has main: $has_main\n" if $debug >= 2;
|
||||
|
||||
my $func_regex = qr/^([ *\w]+)\s+([ ()*\w]+)\s*\(([^;{]*)\s*\)\s*({.*|<%.*|\?\?<.*)/ims;
|
||||
|
||||
# look for potential functions to extract
|
||||
while ($preprecode =~ /$func_regex/ms) {
|
||||
my ($pre_ret, $pre_ident, $pre_params, $pre_potential_body) = ($1, $2, $3, $4);
|
||||
|
||||
print "looking for functions, found [$pre_ret][$pre_ident][$pre_params][$pre_potential_body], has main: $has_main\n" if $debug >= 1;
|
||||
|
||||
# find the pos at which this function lives, for extracting from precode
|
||||
$preprecode =~ m/(\Q$pre_ret\E\s+\Q$pre_ident\E\s*\(\s*\Q$pre_params\E\s*\)\s*\Q$pre_potential_body\E)/g;
|
||||
my $extract_pos = (pos $preprecode) - (length $1);
|
||||
|
||||
# now that we have the pos, substitute out the extracted potential function from preprecode
|
||||
$preprecode =~ s/$func_regex//ms;
|
||||
|
||||
# create tmpcode object that starts from extract pos, to skip any quoted code
|
||||
my $tmpcode = substr($precode, $extract_pos);
|
||||
print "tmpcode: [$tmpcode]\n" if $debug;
|
||||
|
||||
$precode = substr($precode, 0, $extract_pos);
|
||||
print "precode: [$precode]\n" if $debug;
|
||||
|
||||
$tmpcode =~ m/$func_regex/ms;
|
||||
my ($ret, $ident, $params, $potential_body) = ($1, $2, $3, $4);
|
||||
|
||||
print "1st extract: [$ret][$ident][$params][$potential_body]\n" if $debug;
|
||||
|
||||
$ret =~ s/^\s+//;
|
||||
$ret =~ s/\s+$//;
|
||||
|
||||
if (not length $ret or $ret eq "else" or $ret eq "while" or $ret eq "if" or $ret eq "for" or $ident eq "for" or $ident eq "while" or $ident eq "if") {
|
||||
$precode .= "$ret $ident ($params) $potential_body";
|
||||
next;
|
||||
# strip C and C++ style comments
|
||||
if ($lang eq 'C89') {
|
||||
$preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs;
|
||||
$preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse;
|
||||
} else {
|
||||
$tmpcode =~ s/$func_regex//ms;
|
||||
$preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse;
|
||||
$preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs;
|
||||
}
|
||||
|
||||
$potential_body =~ s/^\s*<%/{/ms;
|
||||
$potential_body =~ s/%>\s*$/}/ms;
|
||||
$potential_body =~ s/^\s*\?\?</{/ms;
|
||||
$potential_body =~ s/\?\?>$/}/ms;
|
||||
print "preprecode: [$preprecode]\n" if $debug;
|
||||
|
||||
my @extract = extract_bracketed($potential_body, '{}');
|
||||
my $body;
|
||||
if (not defined $extract[0]) {
|
||||
if ($debug == 0) {
|
||||
print "error: unmatched brackets\n";
|
||||
print "looking for functions, has main: $has_main\n" if $debug >= 2;
|
||||
|
||||
my $func_regex = qr/^([ *\w]+)\s+([ ()*\w]+)\s*\(([^;{]*)\s*\)\s*({.*|<%.*|\?\?<.*)/ims;
|
||||
|
||||
# look for potential functions to extract
|
||||
while ($preprecode =~ /$func_regex/ms) {
|
||||
my ($pre_ret, $pre_ident, $pre_params, $pre_potential_body) = ($1, $2, $3, $4);
|
||||
|
||||
print "looking for functions, found [$pre_ret][$pre_ident][$pre_params][$pre_potential_body], has main: $has_main\n" if $debug >= 1;
|
||||
|
||||
# find the pos at which this function lives, for extracting from precode
|
||||
$preprecode =~ m/(\Q$pre_ret\E\s+\Q$pre_ident\E\s*\(\s*\Q$pre_params\E\s*\)\s*\Q$pre_potential_body\E)/g;
|
||||
my $extract_pos = (pos $preprecode) - (length $1);
|
||||
|
||||
# now that we have the pos, substitute out the extracted potential function from preprecode
|
||||
$preprecode =~ s/$func_regex//ms;
|
||||
|
||||
# create tmpcode object that starts from extract pos, to skip any quoted code
|
||||
my $tmpcode = substr($precode, $extract_pos);
|
||||
print "tmpcode: [$tmpcode]\n" if $debug;
|
||||
|
||||
$precode = substr($precode, 0, $extract_pos);
|
||||
print "precode: [$precode]\n" if $debug;
|
||||
|
||||
$tmpcode =~ m/$func_regex/ms;
|
||||
my ($ret, $ident, $params, $potential_body) = ($1, $2, $3, $4);
|
||||
|
||||
print "1st extract: [$ret][$ident][$params][$potential_body]\n" if $debug;
|
||||
|
||||
$ret =~ s/^\s+//;
|
||||
$ret =~ s/\s+$//;
|
||||
|
||||
if (not length $ret or $ret eq "else" or $ret eq "while" or $ret eq "if" or $ret eq "for" or $ident eq "for" or $ident eq "while" or $ident eq "if") {
|
||||
$precode .= "$ret $ident ($params) $potential_body";
|
||||
next;
|
||||
} else {
|
||||
print "error: unmatched brackets for function '$ident';\n";
|
||||
print "body: [$potential_body]\n";
|
||||
$tmpcode =~ s/$func_regex//ms;
|
||||
}
|
||||
exit;
|
||||
} else {
|
||||
$body = $extract[0];
|
||||
$preprecode .= $extract[1];
|
||||
$precode .= $extract[1];
|
||||
|
||||
$potential_body =~ s/^\s*<%/{/ms;
|
||||
$potential_body =~ s/%>\s*$/}/ms;
|
||||
$potential_body =~ s/^\s*\?\?</{/ms;
|
||||
$potential_body =~ s/\?\?>$/}/ms;
|
||||
|
||||
my @extract = extract_bracketed($potential_body, '{}');
|
||||
my $body;
|
||||
if (not defined $extract[0]) {
|
||||
if ($debug == 0) { print "error: unmatched brackets\n"; }
|
||||
else {
|
||||
print "error: unmatched brackets for function '$ident';\n";
|
||||
print "body: [$potential_body]\n";
|
||||
}
|
||||
exit;
|
||||
} else {
|
||||
$body = $extract[0];
|
||||
$preprecode .= $extract[1];
|
||||
$precode .= $extract[1];
|
||||
}
|
||||
|
||||
print "final extract: [$ret][$ident][$params][$body]\n" if $debug;
|
||||
$code .= "$ret $ident($params) $body\n\n";
|
||||
$has_main = 1 if $ident =~ m/^\s*\(?\s*main\s*\)?\s*$/;
|
||||
$has_function = 1;
|
||||
}
|
||||
|
||||
print "final extract: [$ret][$ident][$params][$body]\n" if $debug;
|
||||
$code .= "$ret $ident($params) $body\n\n";
|
||||
$has_main = 1 if $ident =~ m/^\s*\(?\s*main\s*\)?\s*$/;
|
||||
$has_function = 1;
|
||||
}
|
||||
$precode =~ s/^\s+//;
|
||||
$precode =~ s/\s+$//;
|
||||
|
||||
$precode =~ s/^\s+//;
|
||||
$precode =~ s/\s+$//;
|
||||
$precode =~ s/^{(.*)}$/$1/s;
|
||||
|
||||
$precode =~ s/^{(.*)}$/$1/s;
|
||||
|
||||
if (not $has_main and not $got_nomain) {
|
||||
$code = "$prelude\n$code" . "int main(void) {\n$precode\n;\n}\n";
|
||||
} else {
|
||||
print "code: [$code]; precode: [$precode]\n" if $debug;
|
||||
$code = "$prelude\n$precode\n\n$code\n";
|
||||
}
|
||||
if (not $has_main and not $got_nomain) { $code = "$prelude\n$code" . "int main(void) {\n$precode\n;\n}\n"; }
|
||||
else {
|
||||
print "code: [$code]; precode: [$precode]\n" if $debug;
|
||||
$code = "$prelude\n$precode\n\n$code\n";
|
||||
}
|
||||
} else {
|
||||
$code = $precode;
|
||||
$code = $precode;
|
||||
}
|
||||
|
||||
print "after func extract, code: [$code]\n" if $debug;
|
||||
|
|
@ -314,86 +295,91 @@ print $fh $code;
|
|||
close $fh;
|
||||
|
||||
#my ($ret, $result) = execute(10, "gcc -std=c89 -pedantic -Werror -Wno-unused -fsyntax-only -fno-diagnostics-show-option -fno-diagnostics-show-caret code.c");
|
||||
my ($ret, $result) = execute(10, "gcc -std=c11 -pedantic -Werror -Wno-implicit -Wno-unused -fsyntax-only -fno-diagnostics-show-option -fno-diagnostics-show-caret code.c");
|
||||
my ($ret, $result) =
|
||||
execute(10, "gcc -std=c11 -pedantic -Werror -Wno-implicit -Wno-unused -fsyntax-only -fno-diagnostics-show-option -fno-diagnostics-show-caret code.c");
|
||||
|
||||
if (not $force and $ret != 0) {
|
||||
$output = $result;
|
||||
$output = $result;
|
||||
|
||||
#print STDERR "output: [$output]\n";
|
||||
#print STDERR "output: [$output]\n";
|
||||
|
||||
$output =~ s/\s*In file included from\s+.*?:\d+:\d+:\s*//g;
|
||||
$output =~ s/code\.c:\d+:\d+://g;
|
||||
$output =~ s/code\.c://g;
|
||||
$output =~ s/error=edantic/error=pedantic/g;
|
||||
$output =~ s/(\d+:\d+:\s*)*cc1: all warnings being treated as errors//;
|
||||
$output =~ s/(\d+:\d+:\s*)* \(first use in this function\)//g;
|
||||
$output =~ s/(\d+:\d+:\s*)*error: \(Each undeclared identifier is reported only once.*?\)//msg;
|
||||
$output =~ s/(\d+:\d+:\s*)*ld: warning: cannot find entry symbol _start; defaulting to [^ ]+//;
|
||||
#$output =~ s/(\d+:\d+:\s*)*error: (.*?) error/error: $1; error/msg;
|
||||
$output =~ s/(\d+:\d+:\s*)*\/tmp\/.*\.o://g;
|
||||
$output =~ s/(\d+:\d+:\s*)*collect2: ld returned \d+ exit status//g;
|
||||
$output =~ s/\(\.text\+[^)]+\)://g;
|
||||
$output =~ s/\[ In/[In/;
|
||||
$output =~ s/(\d+:\d+:\s*)*warning: Can't read pathname for load map: Input.output error.//g;
|
||||
my $left_quote = chr(226) . chr(128) . chr(152);
|
||||
my $right_quote = chr(226) . chr(128) . chr(153);
|
||||
$output =~ s/$left_quote/'/msg;
|
||||
$output =~ s/$right_quote/'/msg;
|
||||
$output =~ s/`/'/msg;
|
||||
$output =~ s/\t/ /g;
|
||||
$output =~ s/(\d+:\d+:\s*)*\s*In function .main.:\s*//g;
|
||||
$output =~ s/(\d+:\d+:\s*)*warning: unknown conversion type character 'b' in format \[-Wformat\]\s+(\d+:\d+:\s*)*warning: too many arguments for format \[-Wformat-extra-args\]/info: %b is a candide extension/g;
|
||||
$output =~ s/(\d+:\d+:\s*)*warning: unknown conversion type character 'b' in format \[-Wformat\]//g;
|
||||
$output =~ s/\s\(core dumped\)/./;
|
||||
# $output =~ s/\[\s+/[/g;
|
||||
$output =~ s/ \[enabled by default\]//g;
|
||||
$output =~ s/initializer\s+warning: \(near/initializer (near/g;
|
||||
$output =~ s/(\d+:\d+:\s*)*note: each undeclared identifier is reported only once for each function it appears in//g;
|
||||
$output =~ s/\(gdb\)//g;
|
||||
$output =~ s/", '\\(\d{3})' <repeats \d+ times>,? ?"/\\$1/g;
|
||||
$output =~ s/, '\\(\d{3})' <repeats \d+ times>\s*//g;
|
||||
$output =~ s/(\\000)+/\\0/g;
|
||||
$output =~ s/\\0[^">']+/\\0/g;
|
||||
$output =~ s/= (\d+) '\\0'/= $1/g;
|
||||
$output =~ s/\\0"/"/g;
|
||||
$output =~ s/"\\0/"/g;
|
||||
$output =~ s/\.\.\.>/>/g;
|
||||
# $output =~ s/(\\\d{3})+//g;
|
||||
$output =~ s/<\s*included at \/home\/compiler\/>\s*//g;
|
||||
$output =~ s/\s*compilation terminated due to -Wfatal-errors\.//g;
|
||||
$output =~ s/^======= Backtrace.*\[vsyscall\]\s*$//ms;
|
||||
$output =~ s/glibc detected \*\*\* \/home\/compiler\/code: //;
|
||||
$output =~ s/: \/home\/compiler\/code terminated//;
|
||||
$output =~ s/<Defined at \/home\/compiler\/>/<Defined at \/home\/compiler\/code.c:0>/g;
|
||||
$output =~ s/\s*In file included from\s+\/usr\/include\/.*?:\d+:\d+:\s*/, /g;
|
||||
$output =~ s/\s*collect2: error: ld returned 1 exit status//g;
|
||||
$output =~ s/In function\s*`main':\s*\/home\/compiler\/ undefined reference to/error: undefined reference to/g;
|
||||
$output =~ s/\/home\/compiler\///g;
|
||||
$output =~ s/compilation terminated.//;
|
||||
$output =~ s/<'(.*)' = char>/<'$1' = int>/g;
|
||||
$output =~ s/= (-?\d+) ''/= $1/g;
|
||||
$output =~ s/, <incomplete sequence >//g;
|
||||
$output =~ s/\s*error: expected ';' before 'return'//g;
|
||||
$output =~ s/^\s+//;
|
||||
$output =~ s/\s+$//;
|
||||
$output =~ s/error: ISO C forbids nested functions\s+//g;
|
||||
$output =~ s/\s*note: this is the location of the previous definition//g;
|
||||
$output =~ s/\s*note: use option -std=c99 or -std=gnu99 to compile your code//g;
|
||||
$output =~ s/\s*\(declared at .*?\)//g;
|
||||
$output =~ s/, note: declared here//g;
|
||||
$output =~ s#/usr/include/.*?.h:\d+:\d+:/##g;
|
||||
$output =~ s/\s*error: storage size of.*?isn't known\s*//g;
|
||||
$output =~ s/; did you mean '.*?'\?//g;
|
||||
$output =~ s/\s*In file included from\s+.*?:\d+:\d+:\s*//g;
|
||||
$output =~ s/code\.c:\d+:\d+://g;
|
||||
$output =~ s/code\.c://g;
|
||||
$output =~ s/error=edantic/error=pedantic/g;
|
||||
$output =~ s/(\d+:\d+:\s*)*cc1: all warnings being treated as errors//;
|
||||
$output =~ s/(\d+:\d+:\s*)* \(first use in this function\)//g;
|
||||
$output =~ s/(\d+:\d+:\s*)*error: \(Each undeclared identifier is reported only once.*?\)//msg;
|
||||
$output =~ s/(\d+:\d+:\s*)*ld: warning: cannot find entry symbol _start; defaulting to [^ ]+//;
|
||||
|
||||
# don't error about undeclared objects
|
||||
$output =~ s/error: '[^']+' undeclared\s*//g;
|
||||
#$output =~ s/(\d+:\d+:\s*)*error: (.*?) error/error: $1; error/msg;
|
||||
$output =~ s/(\d+:\d+:\s*)*\/tmp\/.*\.o://g;
|
||||
$output =~ s/(\d+:\d+:\s*)*collect2: ld returned \d+ exit status//g;
|
||||
$output =~ s/\(\.text\+[^)]+\)://g;
|
||||
$output =~ s/\[ In/[In/;
|
||||
$output =~ s/(\d+:\d+:\s*)*warning: Can't read pathname for load map: Input.output error.//g;
|
||||
my $left_quote = chr(226) . chr(128) . chr(152);
|
||||
my $right_quote = chr(226) . chr(128) . chr(153);
|
||||
$output =~ s/$left_quote/'/msg;
|
||||
$output =~ s/$right_quote/'/msg;
|
||||
$output =~ s/`/'/msg;
|
||||
$output =~ s/\t/ /g;
|
||||
$output =~ s/(\d+:\d+:\s*)*\s*In function .main.:\s*//g;
|
||||
$output =~
|
||||
s/(\d+:\d+:\s*)*warning: unknown conversion type character 'b' in format \[-Wformat\]\s+(\d+:\d+:\s*)*warning: too many arguments for format \[-Wformat-extra-args\]/info: %b is a candide extension/g;
|
||||
$output =~ s/(\d+:\d+:\s*)*warning: unknown conversion type character 'b' in format \[-Wformat\]//g;
|
||||
$output =~ s/\s\(core dumped\)/./;
|
||||
|
||||
if (length $output) {
|
||||
print "$output\n";
|
||||
exit 0;
|
||||
} else {
|
||||
$output = undef;
|
||||
}
|
||||
# $output =~ s/\[\s+/[/g;
|
||||
$output =~ s/ \[enabled by default\]//g;
|
||||
$output =~ s/initializer\s+warning: \(near/initializer (near/g;
|
||||
$output =~ s/(\d+:\d+:\s*)*note: each undeclared identifier is reported only once for each function it appears in//g;
|
||||
$output =~ s/\(gdb\)//g;
|
||||
$output =~ s/", '\\(\d{3})' <repeats \d+ times>,? ?"/\\$1/g;
|
||||
$output =~ s/, '\\(\d{3})' <repeats \d+ times>\s*//g;
|
||||
$output =~ s/(\\000)+/\\0/g;
|
||||
$output =~ s/\\0[^">']+/\\0/g;
|
||||
$output =~ s/= (\d+) '\\0'/= $1/g;
|
||||
$output =~ s/\\0"/"/g;
|
||||
$output =~ s/"\\0/"/g;
|
||||
$output =~ s/\.\.\.>/>/g;
|
||||
|
||||
# $output =~ s/(\\\d{3})+//g;
|
||||
$output =~ s/<\s*included at \/home\/compiler\/>\s*//g;
|
||||
$output =~ s/\s*compilation terminated due to -Wfatal-errors\.//g;
|
||||
$output =~ s/^======= Backtrace.*\[vsyscall\]\s*$//ms;
|
||||
$output =~ s/glibc detected \*\*\* \/home\/compiler\/code: //;
|
||||
$output =~ s/: \/home\/compiler\/code terminated//;
|
||||
$output =~ s/<Defined at \/home\/compiler\/>/<Defined at \/home\/compiler\/code.c:0>/g;
|
||||
$output =~ s/\s*In file included from\s+\/usr\/include\/.*?:\d+:\d+:\s*/, /g;
|
||||
$output =~ s/\s*collect2: error: ld returned 1 exit status//g;
|
||||
$output =~ s/In function\s*`main':\s*\/home\/compiler\/ undefined reference to/error: undefined reference to/g;
|
||||
$output =~ s/\/home\/compiler\///g;
|
||||
$output =~ s/compilation terminated.//;
|
||||
$output =~ s/<'(.*)' = char>/<'$1' = int>/g;
|
||||
$output =~ s/= (-?\d+) ''/= $1/g;
|
||||
$output =~ s/, <incomplete sequence >//g;
|
||||
$output =~ s/\s*error: expected ';' before 'return'//g;
|
||||
$output =~ s/^\s+//;
|
||||
$output =~ s/\s+$//;
|
||||
$output =~ s/error: ISO C forbids nested functions\s+//g;
|
||||
$output =~ s/\s*note: this is the location of the previous definition//g;
|
||||
$output =~ s/\s*note: use option -std=c99 or -std=gnu99 to compile your code//g;
|
||||
$output =~ s/\s*\(declared at .*?\)//g;
|
||||
$output =~ s/, note: declared here//g;
|
||||
$output =~ s#/usr/include/.*?.h:\d+:\d+:/##g;
|
||||
$output =~ s/\s*error: storage size of.*?isn't known\s*//g;
|
||||
$output =~ s/; did you mean '.*?'\?//g;
|
||||
|
||||
# don't error about undeclared objects
|
||||
$output =~ s/error: '[^']+' undeclared\s*//g;
|
||||
|
||||
if (length $output) {
|
||||
print "$output\n";
|
||||
exit 0;
|
||||
} else {
|
||||
$output = undef;
|
||||
}
|
||||
}
|
||||
|
||||
$code =~ s/^\Q$prelude_base\E\s*//;
|
||||
|
|
@ -405,55 +391,49 @@ close $fh;
|
|||
$output = `./c2eng.pl code2eng.c` if not defined $output;
|
||||
|
||||
if (not $has_function and not $has_main) {
|
||||
$output =~ s/Let .main. be a function taking no arguments and returning int.\s*When called, the function will.\s*(do nothing.)?//i;
|
||||
$output =~ s/\s*Return 0.\s*End of function .main..\s*//;
|
||||
$output =~ s/\s*Finally, return 0.$//;
|
||||
$output =~ s/\s*and then return 0.$/./;
|
||||
$output =~ s/\s*Do nothing.\s*$//;
|
||||
$output =~ s/^\s*(.)/\U$1/;
|
||||
$output =~ s/\.\s+(\S)/. \U$1/g;
|
||||
$output =~ s/Let .main. be a function taking no arguments and returning int.\s*When called, the function will.\s*(do nothing.)?//i;
|
||||
$output =~ s/\s*Return 0.\s*End of function .main..\s*//;
|
||||
$output =~ s/\s*Finally, return 0.$//;
|
||||
$output =~ s/\s*and then return 0.$/./;
|
||||
$output =~ s/\s*Do nothing.\s*$//;
|
||||
$output =~ s/^\s*(.)/\U$1/;
|
||||
$output =~ s/\.\s+(\S)/. \U$1/g;
|
||||
} elsif ($has_function and not $has_main) {
|
||||
$output =~ s/\s*Let `main` be a function taking no arguments and returning int.\s*When called, the function will do nothing.//;
|
||||
$output =~ s/\s*Finally, return 0.$//;
|
||||
$output =~ s/\s*and then return 0.$/./;
|
||||
$output =~ s/\s*Let `main` be a function taking no arguments and returning int.\s*When called, the function will do nothing.//;
|
||||
$output =~ s/\s*Finally, return 0.$//;
|
||||
$output =~ s/\s*and then return 0.$/./;
|
||||
}
|
||||
|
||||
$output =~ s/\s+/ /;
|
||||
if (not $output) {
|
||||
$output = "Does not compute; I only understand valid C11 code.\n";
|
||||
}
|
||||
if (not $output) { $output = "Does not compute; I only understand valid C11 code.\n"; }
|
||||
|
||||
print "$output\n";
|
||||
|
||||
sub execute {
|
||||
my $timeout = shift @_;
|
||||
my ($cmdline) = @_;
|
||||
my $timeout = shift @_;
|
||||
my ($cmdline) = @_;
|
||||
|
||||
my ($ret, $result);
|
||||
my ($ret, $result);
|
||||
|
||||
($ret, $result) = eval {
|
||||
my $result = '';
|
||||
($ret, $result) = eval {
|
||||
my $result = '';
|
||||
|
||||
my $pid = open(my $fh, '-|', "$cmdline 2>&1");
|
||||
my $pid = open(my $fh, '-|', "$cmdline 2>&1");
|
||||
|
||||
local $SIG{ALRM} = sub { kill 'TERM', $pid; die "$result [Timed-out]\n"; };
|
||||
alarm($timeout);
|
||||
local $SIG{ALRM} = sub { kill 'TERM', $pid; die "$result [Timed-out]\n"; };
|
||||
alarm($timeout);
|
||||
|
||||
while (my $line = <$fh>) {
|
||||
$result .= $line;
|
||||
}
|
||||
while (my $line = <$fh>) { $result .= $line; }
|
||||
|
||||
close $fh;
|
||||
my $ret = $? >> 8;
|
||||
alarm 0;
|
||||
return ($ret, $result);
|
||||
};
|
||||
|
||||
close $fh;
|
||||
my $ret = $? >> 8;
|
||||
alarm 0;
|
||||
|
||||
if ($@ =~ /Timed-out/) { return (-1, $@); }
|
||||
|
||||
return ($ret, $result);
|
||||
};
|
||||
|
||||
alarm 0;
|
||||
|
||||
if ($@ =~ /Timed-out/) {
|
||||
return (-1, $@);
|
||||
}
|
||||
|
||||
return ($ret, $result);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -16,57 +16,55 @@ my $RESULTS_SPECIFIED = 2;
|
|||
my $search = join ' ', @ARGV;
|
||||
|
||||
if (not length $search) {
|
||||
print "Usage: c99std [-list] [-n#] [-section <section>] [search text] -- 'section' must be in the form of X.YpZ where X and Y are section/chapter and, optionally, pZ is paragraph. If both 'section' and 'search text' are specified, then the search space will be within the specified section. You may use -n # to skip to the #th match. To list only the section numbers containing 'search text', add -list.\n";
|
||||
exit 0;
|
||||
print
|
||||
"Usage: c99std [-list] [-n#] [-section <section>] [search text] -- 'section' must be in the form of X.YpZ where X and Y are section/chapter and, optionally, pZ is paragraph. If both 'section' and 'search text' are specified, then the search space will be within the specified section. You may use -n # to skip to the #th match. To list only the section numbers containing 'search text', add -list.\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my ($section, $paragraph, $section_specified, $paragraph_specified, $match, $list_only, $list_titles);
|
||||
|
||||
$section_specified = 0;
|
||||
$section_specified = 0;
|
||||
$paragraph_specified = 0;
|
||||
|
||||
if ($search =~ s/-section\s*([A-Z0-9\.p]+)//i or $search =~ s/\b([A-Z0-9]+\.[0-9\.p]+)//i) {
|
||||
$section = $1;
|
||||
$section = $1;
|
||||
|
||||
if ($section =~ s/p(\d+)//i) {
|
||||
$paragraph = $1;
|
||||
$paragraph_specified = $USER_SPECIFIED;
|
||||
} else {
|
||||
$paragraph = 1;
|
||||
}
|
||||
if ($section =~ s/p(\d+)//i) {
|
||||
$paragraph = $1;
|
||||
$paragraph_specified = $USER_SPECIFIED;
|
||||
} else {
|
||||
$paragraph = 1;
|
||||
}
|
||||
|
||||
$section = "$section." if $section =~ m/^[A-Z0-9]+$/i;
|
||||
$section = "$section." if $section =~ m/^[A-Z0-9]+$/i;
|
||||
|
||||
$section_specified = 1;
|
||||
$section_specified = 1;
|
||||
}
|
||||
|
||||
if ($search =~ s/-n\s*(\d+)//) {
|
||||
$match = $1;
|
||||
} else {
|
||||
$match = 1;
|
||||
}
|
||||
if ($search =~ s/-n\s*(\d+)//) { $match = $1; }
|
||||
else { $match = 1; }
|
||||
|
||||
if ($search =~ s/-list//i) {
|
||||
$list_only = 1;
|
||||
$list_titles = 1; # Added here instead of removing -titles option
|
||||
$list_only = 1;
|
||||
$list_titles = 1; # Added here instead of removing -titles option
|
||||
}
|
||||
|
||||
if ($search =~ s/-titles//i) {
|
||||
$list_only = 1;
|
||||
$list_titles = 1;
|
||||
$list_only = 1;
|
||||
$list_titles = 1;
|
||||
}
|
||||
|
||||
$search =~ s/^\s+//;
|
||||
$search =~ s/\s+$//;
|
||||
|
||||
if (not defined $section) {
|
||||
$section = "1.";
|
||||
$paragraph = 1;
|
||||
$section = "1.";
|
||||
$paragraph = 1;
|
||||
}
|
||||
|
||||
if ($list_only and not length $search) {
|
||||
print "You must specify some search text to use with -list.\n";
|
||||
exit 0;
|
||||
print "You must specify some search text to use with -list.\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
open FH, "<n1256.out" or die "Could not open n1256: $!";
|
||||
|
|
@ -77,151 +75,144 @@ my $text = join '', @contents;
|
|||
$text =~ s/\r//g;
|
||||
|
||||
my $result;
|
||||
my $found_section = "";
|
||||
my $found_section = "";
|
||||
my $found_section_title = "";
|
||||
my $section_title;
|
||||
my $found_paragraph;
|
||||
my $found = 0;
|
||||
my $found = 0;
|
||||
my $matches = 0;
|
||||
my $this_section;
|
||||
my $comma = "";
|
||||
|
||||
if ($list_only) {
|
||||
$result = "Sections containing '$search':\n ";
|
||||
}
|
||||
if ($list_only) { $result = "Sections containing '$search':\n "; }
|
||||
|
||||
my $qsearch = quotemeta $search;
|
||||
$qsearch =~ s/\\ / /g;
|
||||
$qsearch =~ s/\s+/\\s+/g;
|
||||
|
||||
while ($text =~ m/^\s{0,4}([0-9A-Z]+\.[0-9\.]*)/msg) {
|
||||
$this_section = $1;
|
||||
$this_section = $1;
|
||||
|
||||
print "----------------------------------\n" if $debug >= 2;
|
||||
print "Processing section [$this_section]\n" if $debug;
|
||||
print "----------------------------------\n" if $debug >= 2;
|
||||
print "Processing section [$this_section]\n" if $debug;
|
||||
|
||||
if ($section_specified and $this_section !~ m/^$section/i) {
|
||||
print "No section match, skipping.\n" if $debug >= 4;
|
||||
next;
|
||||
}
|
||||
|
||||
my $section_text;
|
||||
|
||||
if ($text =~ m/(.*?)^(?=\s{0,4}(?!FOOTNOTE)[0-9A-Z]+\.)/msg) {
|
||||
$section_text = $1;
|
||||
} else {
|
||||
print "No section text, end of file marker found.\n" if $debug >= 4;
|
||||
last;
|
||||
}
|
||||
|
||||
if ($section =~ /FOOTNOTE/i) {
|
||||
$section_text =~ s/^\s{4}//ms;
|
||||
$section_text =~ s/^\s{4}FOOTNOTE.*//msi;
|
||||
$section_text =~ s/^\d.*//ms;
|
||||
} elsif ($section_text =~ m/(.*?)$/msg) {
|
||||
$section_title = $1 if length $1;
|
||||
$section_title =~ s/^\s+//;
|
||||
$section_title =~ s/\s+$//;
|
||||
}
|
||||
|
||||
print "$this_section [$section_title]\n" if $debug >= 2;
|
||||
|
||||
while ($section_text =~ m/^(\d+)\s(.*?)^(?=\d)/msgic or $section_text =~ m/^(\d+)\s(.*)/msgi) {
|
||||
my $p = $1 ;
|
||||
my $t = $2;
|
||||
|
||||
print "paragraph $p: [$t]\n" if $debug >= 3;
|
||||
|
||||
if ($paragraph_specified == $USER_SPECIFIED and not length $search and $p == $paragraph) {
|
||||
$result = $t if not $found;
|
||||
$found_paragraph = $p;
|
||||
$found_section = $this_section;
|
||||
$found_section_title = $section_title;
|
||||
$found = 1;
|
||||
last;
|
||||
if ($section_specified and $this_section !~ m/^$section/i) {
|
||||
print "No section match, skipping.\n" if $debug >= 4;
|
||||
next;
|
||||
}
|
||||
|
||||
if (length $search) {
|
||||
eval {
|
||||
if ($t =~ m/\b$qsearch\b/mis or $section_title =~ m/\b$qsearch\b/mis) {
|
||||
$matches++;
|
||||
if ($matches >= $match) {
|
||||
if ($list_only) {
|
||||
$result .= sprintf("%s%-15s", $comma, $this_section."p".$p);
|
||||
$result .= " $section_title" if $list_titles;
|
||||
$comma = ",\n ";
|
||||
} else {
|
||||
if (not $found) {
|
||||
$result = $t;
|
||||
$found_section = $this_section;
|
||||
$found_section_title = $section_title;
|
||||
$found_paragraph = $p;
|
||||
$paragraph_specified = $RESULTS_SPECIFIED;
|
||||
}
|
||||
$found = 1;
|
||||
}
|
||||
}
|
||||
my $section_text;
|
||||
|
||||
if ($text =~ m/(.*?)^(?=\s{0,4}(?!FOOTNOTE)[0-9A-Z]+\.)/msg) { $section_text = $1; }
|
||||
else {
|
||||
print "No section text, end of file marker found.\n" if $debug >= 4;
|
||||
last;
|
||||
}
|
||||
|
||||
if ($section =~ /FOOTNOTE/i) {
|
||||
$section_text =~ s/^\s{4}//ms;
|
||||
$section_text =~ s/^\s{4}FOOTNOTE.*//msi;
|
||||
$section_text =~ s/^\d.*//ms;
|
||||
} elsif ($section_text =~ m/(.*?)$/msg) {
|
||||
$section_title = $1 if length $1;
|
||||
$section_title =~ s/^\s+//;
|
||||
$section_title =~ s/\s+$//;
|
||||
}
|
||||
|
||||
print "$this_section [$section_title]\n" if $debug >= 2;
|
||||
|
||||
while ($section_text =~ m/^(\d+)\s(.*?)^(?=\d)/msgic or $section_text =~ m/^(\d+)\s(.*)/msgi) {
|
||||
my $p = $1;
|
||||
my $t = $2;
|
||||
|
||||
print "paragraph $p: [$t]\n" if $debug >= 3;
|
||||
|
||||
if ($paragraph_specified == $USER_SPECIFIED and not length $search and $p == $paragraph) {
|
||||
$result = $t if not $found;
|
||||
$found_paragraph = $p;
|
||||
$found_section = $this_section;
|
||||
$found_section_title = $section_title;
|
||||
$found = 1;
|
||||
last;
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
print "Error in search regex; you may need to escape characters such as *, ?, ., etc.\n";
|
||||
if (length $search) {
|
||||
eval {
|
||||
if ($t =~ m/\b$qsearch\b/mis or $section_title =~ m/\b$qsearch\b/mis) {
|
||||
$matches++;
|
||||
if ($matches >= $match) {
|
||||
if ($list_only) {
|
||||
$result .= sprintf("%s%-15s", $comma, $this_section . "p" . $p);
|
||||
$result .= " $section_title" if $list_titles;
|
||||
$comma = ",\n ";
|
||||
} else {
|
||||
if (not $found) {
|
||||
$result = $t;
|
||||
$found_section = $this_section;
|
||||
$found_section_title = $section_title;
|
||||
$found_paragraph = $p;
|
||||
$paragraph_specified = $RESULTS_SPECIFIED;
|
||||
}
|
||||
$found = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
print "Error in search regex; you may need to escape characters such as *, ?, ., etc.\n";
|
||||
exit 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
last if $found && $paragraph_specified == $USER_SPECIFIED;
|
||||
|
||||
if ($paragraph_specified == $USER_SPECIFIED) {
|
||||
if (length $search) { print "No such text '$search' found within paragraph $paragraph of section $section of n1256.\n"; }
|
||||
else { print "No such paragraph $paragraph in section $section of n1256.\n"; }
|
||||
exit 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
last if $found && $paragraph_specified == $USER_SPECIFIED;
|
||||
|
||||
if ($paragraph_specified == $USER_SPECIFIED) {
|
||||
if (length $search) {
|
||||
print "No such text '$search' found within paragraph $paragraph of section $section of n1256.\n";
|
||||
} else {
|
||||
print "No such paragraph $paragraph in section $section of n1256.\n";
|
||||
if (defined $section_specified and not length $search) {
|
||||
$found = 1;
|
||||
$found_section = $this_section;
|
||||
$found_section_title = $section_title;
|
||||
$found_paragraph = $paragraph;
|
||||
$result = $section_text;
|
||||
last;
|
||||
}
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if (defined $section_specified and not length $search) {
|
||||
$found = 1;
|
||||
$found_section = $this_section;
|
||||
$found_section_title = $section_title;
|
||||
$found_paragraph = $paragraph;
|
||||
$result = $section_text;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
if (not $found and $comma eq "") {
|
||||
$search =~ s/\\s\+/ /g;
|
||||
if ($section_specified) {
|
||||
print "No such text '$search' found within section '$section' in C99 Draft Standard (n1256).\n" if length $search;
|
||||
print "No such section '$section' in C99 Draft Standard (n1256).\n" if not length $search;
|
||||
exit 0;
|
||||
}
|
||||
$search =~ s/\\s\+/ /g;
|
||||
if ($section_specified) {
|
||||
print "No such text '$search' found within section '$section' in C99 Draft Standard (n1256).\n" if length $search;
|
||||
print "No such section '$section' in C99 Draft Standard (n1256).\n" if not length $search;
|
||||
exit 0;
|
||||
}
|
||||
|
||||
print "No such section '$section' in C99 Draft Standard (n1256).\n" if not length $search;
|
||||
print "No such text '$search' found in C99 Draft Standard (n1256).\n" if length $search;
|
||||
exit 0;
|
||||
print "No such section '$section' in C99 Draft Standard (n1256).\n" if not length $search;
|
||||
print "No such text '$search' found in C99 Draft Standard (n1256).\n" if length $search;
|
||||
exit 0;
|
||||
}
|
||||
|
||||
$result =~ s/$found_section_title// if length $found_section_title;
|
||||
$result =~ s/^\s+//;
|
||||
$result =~ s/\s+$//;
|
||||
|
||||
=cut
|
||||
$result =~ s/\s+/ /g;
|
||||
$result =~ s/[\n\r]/ /g;
|
||||
=cut
|
||||
|
||||
if ($matches > 1 and not $list_only) {
|
||||
print "Displaying $match of $matches matches: ";
|
||||
}
|
||||
if ($matches > 1 and not $list_only) { print "Displaying $match of $matches matches: "; }
|
||||
|
||||
if ($comma eq "") {
|
||||
print "http://www.iso-9899.info/n1256.html\#$found_section";
|
||||
print "p" . $found_paragraph if $paragraph_specified;
|
||||
print "\n\n";
|
||||
print "[", $found_section_title, "]\n\n" if length $found_section_title;
|
||||
print "http://www.iso-9899.info/n1256.html\#$found_section";
|
||||
print "p" . $found_paragraph if $paragraph_specified;
|
||||
print "\n\n";
|
||||
print "[", $found_section_title, "]\n\n" if length $found_section_title;
|
||||
}
|
||||
|
||||
$result =~ s/\s*Constraints\s*$//;
|
||||
|
|
|
|||
|
|
@ -8,10 +8,10 @@
|
|||
|
||||
my $command = join(' ', @ARGV);
|
||||
|
||||
my @args = split(' ', $command); # because @ARGV may be one quoted argument
|
||||
my @args = split(' ', $command); # because @ARGV may be one quoted argument
|
||||
if (@args < 2) {
|
||||
print "Usage: cdecl <explain|declare|cast|set|...> <code>, see http://linux.die.net/man/1/cdecl (Don't use this command. Use `english` instead.)\n";
|
||||
die;
|
||||
print "Usage: cdecl <explain|declare|cast|set|...> <code>, see http://linux.die.net/man/1/cdecl (Don't use this command. Use `english` instead.)\n";
|
||||
die;
|
||||
}
|
||||
|
||||
$command = quotemeta($command);
|
||||
|
|
@ -23,5 +23,6 @@ chomp $result;
|
|||
$result =~ s/\n/, /g;
|
||||
|
||||
print $result;
|
||||
print " (Don't use this command. It can only handle C90 declarations -- poorly. Use `english` instead, which can translate any complete C11 code.)" if $result =~ m/^declare/;
|
||||
print " (Don't use this command. It can only handle C90 declarations -- poorly. Use `english` instead, which can translate any complete C11 code.)"
|
||||
if $result =~ m/^declare/;
|
||||
print "\n";
|
||||
|
|
|
|||
|
|
@ -4,9 +4,9 @@
|
|||
# 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/.
|
||||
|
||||
my $match = 1;
|
||||
my $match = 1;
|
||||
my $matches = 0;
|
||||
my $found = 0;
|
||||
my $found = 0;
|
||||
|
||||
print "Usage: faq [match #] <search regex>\n" and exit 0 if not defined $ARGV[0];
|
||||
|
||||
|
|
@ -20,8 +20,8 @@ $query =~ s/\[/\\[/g;
|
|||
$query =~ s/\]/\\]/g;
|
||||
|
||||
if ($query =~ /^(\d+)\.\*\?/) {
|
||||
$match = $1;
|
||||
$query =~ s/^\d+\.\*\?//;
|
||||
$match = $1;
|
||||
$query =~ s/^\d+\.\*\?//;
|
||||
}
|
||||
|
||||
open(FILE, "< cfaq-questions.html") or print "Can't open cfaq-questions.html: $!" and exit 1;
|
||||
|
|
@ -31,51 +31,51 @@ close(FILE);
|
|||
my ($heading, $question_full, $question_link, $question_number, $question_text, $result);
|
||||
|
||||
foreach my $line (@contents) {
|
||||
if ($line =~ m/^<H4>(.*?)<\/H4>/) {
|
||||
$heading = $1;
|
||||
next;
|
||||
}
|
||||
|
||||
if ($line =~ m/<p><a href="(.*?)" rel=subdocument>(.*?)<\/a>/) {
|
||||
($question_link, $question_number) = ($1, $2);
|
||||
|
||||
if (defined $question_full) {
|
||||
if ($question_full =~ m/$query/i) {
|
||||
$matches++;
|
||||
$found = 1;
|
||||
if ($match == $matches) {
|
||||
$question_text =~ s/\s+/ /g;
|
||||
$result = $question_text;
|
||||
}
|
||||
}
|
||||
if ($line =~ m/^<H4>(.*?)<\/H4>/) {
|
||||
$heading = $1;
|
||||
next;
|
||||
}
|
||||
|
||||
$question_full = "$question_number $question_link ";
|
||||
$question_text = "http://c-faq.com/$question_link - $heading, $question_number: ";
|
||||
next;
|
||||
}
|
||||
if ($line =~ m/<p><a href="(.*?)" rel=subdocument>(.*?)<\/a>/) {
|
||||
($question_link, $question_number) = ($1, $2);
|
||||
|
||||
if (defined $question_full) {
|
||||
$line =~ s/[\n\r]/ /g;
|
||||
$line =~ s/(<pre>|<\/pre>|<TT>|<\/TT>|<\/a>|<br>)//g;
|
||||
$line =~ s/<a href=".*?">//g;
|
||||
$line =~ s/ / /g;
|
||||
$line =~ s/&/&/g;
|
||||
$line =~ s/</</g;
|
||||
$line =~ s/>/>/g;
|
||||
if (defined $question_full) {
|
||||
if ($question_full =~ m/$query/i) {
|
||||
$matches++;
|
||||
$found = 1;
|
||||
if ($match == $matches) {
|
||||
$question_text =~ s/\s+/ /g;
|
||||
$result = $question_text;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$question_full .= $line;
|
||||
$question_text .= $line;
|
||||
}
|
||||
$question_full = "$question_number $question_link ";
|
||||
$question_text = "http://c-faq.com/$question_link - $heading, $question_number: ";
|
||||
next;
|
||||
}
|
||||
|
||||
if (defined $question_full) {
|
||||
$line =~ s/[\n\r]/ /g;
|
||||
$line =~ s/(<pre>|<\/pre>|<TT>|<\/TT>|<\/a>|<br>)//g;
|
||||
$line =~ s/<a href=".*?">//g;
|
||||
$line =~ s/ / /g;
|
||||
$line =~ s/&/&/g;
|
||||
$line =~ s/</</g;
|
||||
$line =~ s/>/>/g;
|
||||
|
||||
$question_full .= $line;
|
||||
$question_text .= $line;
|
||||
}
|
||||
}
|
||||
|
||||
if ($found == 1) {
|
||||
print "But there are $matches results...\n" and exit if ($match > $matches);
|
||||
print "But there are $matches results...\n" and exit if ($match > $matches);
|
||||
|
||||
print "$matches results, displaying #$match: " if ($matches > 1);
|
||||
print "$matches results, displaying #$match: " if ($matches > 1);
|
||||
|
||||
print "$result\n";
|
||||
print "$result\n";
|
||||
} else {
|
||||
$query =~ s/\.\*\?/ /g;
|
||||
print "No FAQs match $query\n";
|
||||
$query =~ s/\.\*\?/ /g;
|
||||
print "No FAQs match $query\n";
|
||||
}
|
||||
|
|
|
|||
|
|
@ -17,13 +17,14 @@ use Text::Balanced qw(extract_codeblock);
|
|||
|
||||
my @languages = qw/C C++ D Haskell Lua OCaml PHP Perl Python Ruby Scheme Tcl/;
|
||||
|
||||
my %preludes = ( 'C' => "#include <stdio.h>\n#include <stdlib.h>\n#include <string.h>\n",
|
||||
'C++' => "#include <iostream>\n#include <cstdio>\n",
|
||||
);
|
||||
my %preludes = (
|
||||
'C' => "#include <stdio.h>\n#include <stdlib.h>\n#include <string.h>\n",
|
||||
'C++' => "#include <iostream>\n#include <cstdio>\n",
|
||||
);
|
||||
|
||||
if ($#ARGV <= 0) {
|
||||
print "Usage: cc [-lang=<language>] <code>\n";
|
||||
exit 0;
|
||||
print "Usage: cc [-lang=<language>] <code>\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my $nick = shift @ARGV;
|
||||
|
|
@ -42,22 +43,22 @@ $show_url = 1 if $code =~ s/-showurl//i;
|
|||
|
||||
my $found = 0;
|
||||
foreach my $l (@languages) {
|
||||
if (uc $lang eq uc $l) {
|
||||
$lang = $l;
|
||||
$found = 1;
|
||||
last;
|
||||
}
|
||||
if (uc $lang eq uc $l) {
|
||||
$lang = $l;
|
||||
$found = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
if (not $found) {
|
||||
print "$nick: Invalid language '$lang'. Supported languages are: @languages\n";
|
||||
exit 0;
|
||||
print "$nick: Invalid language '$lang'. Supported languages are: @languages\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my $ua = LWP::UserAgent->new();
|
||||
|
||||
$ua->agent("Mozilla/5.0");
|
||||
push @{ $ua->requests_redirectable }, 'POST';
|
||||
push @{$ua->requests_redirectable}, 'POST';
|
||||
|
||||
$code =~ s/#include <([^>]+)>/\n#include <$1>\n/g;
|
||||
$code =~ s/#([^ ]+) (.*?)\\n/\n#$1 $2\n/g;
|
||||
|
|
@ -67,65 +68,60 @@ my $precode = $preludes{$lang} . $code;
|
|||
$code = '';
|
||||
|
||||
if ($lang eq "C" or $lang eq "C++") {
|
||||
my $has_main = 0;
|
||||
my $has_main = 0;
|
||||
|
||||
my $prelude = '';
|
||||
$prelude = "$1$2" if $precode =~ s/^\s*(#.*)(#.*?[>\n])//s;
|
||||
my $prelude = '';
|
||||
$prelude = "$1$2" if $precode =~ s/^\s*(#.*)(#.*?[>\n])//s;
|
||||
|
||||
while ($precode =~ s/([ a-zA-Z0-9_*\[\]]+)\s+([a-zA-Z0-9_*]+)\s*\((.*?)\)\s*({.*)//) {
|
||||
my ($ret, $ident, $params, $potential_body) = ($1, $2, $3, $4);
|
||||
while ($precode =~ s/([ a-zA-Z0-9_*\[\]]+)\s+([a-zA-Z0-9_*]+)\s*\((.*?)\)\s*({.*)//) {
|
||||
my ($ret, $ident, $params, $potential_body) = ($1, $2, $3, $4);
|
||||
|
||||
my @extract = extract_codeblock($potential_body, '{}');
|
||||
my $body;
|
||||
if (not defined $extract[0]) {
|
||||
$output .= "<pre>error: unmatched brackets for function '$ident'; </pre>";
|
||||
$body = $extract[1];
|
||||
} else {
|
||||
$body = $extract[0];
|
||||
$precode .= $extract[1];
|
||||
my @extract = extract_codeblock($potential_body, '{}');
|
||||
my $body;
|
||||
if (not defined $extract[0]) {
|
||||
$output .= "<pre>error: unmatched brackets for function '$ident'; </pre>";
|
||||
$body = $extract[1];
|
||||
} else {
|
||||
$body = $extract[0];
|
||||
$precode .= $extract[1];
|
||||
}
|
||||
$code .= "$ret $ident($params) $body\n\n";
|
||||
$has_main = 1 if $ident eq 'main';
|
||||
}
|
||||
$code .= "$ret $ident($params) $body\n\n";
|
||||
$has_main = 1 if $ident eq 'main';
|
||||
}
|
||||
|
||||
$precode =~ s/^\s+//;
|
||||
$precode =~ s/\s+$//;
|
||||
$precode =~ s/^\s+//;
|
||||
$precode =~ s/\s+$//;
|
||||
|
||||
if (not $has_main) {
|
||||
$code = "$prelude\n\n$code\n\nint main(int argc, char **argv) { $precode\n;\n return 0;}\n";
|
||||
} else {
|
||||
$code = "$prelude\n\n$precode\n\n$code\n";
|
||||
}
|
||||
if (not $has_main) { $code = "$prelude\n\n$code\n\nint main(int argc, char **argv) { $precode\n;\n return 0;}\n"; }
|
||||
else { $code = "$prelude\n\n$precode\n\n$code\n"; }
|
||||
} else {
|
||||
$code = $precode;
|
||||
$code = $precode;
|
||||
}
|
||||
|
||||
if ($lang eq "C" or $lang eq "C++") {
|
||||
# $code = pretty($code);
|
||||
|
||||
# $code = pretty($code);
|
||||
}
|
||||
|
||||
$code =~ s/^\s+//;
|
||||
$code =~ s/\s+$//;
|
||||
|
||||
my %post = ( 'lang' => $lang, 'code' => $code, 'private' => 'True', 'run' => 'True', 'submit' => 'Submit' );
|
||||
my %post = ('lang' => $lang, 'code' => $code, 'private' => 'True', 'run' => 'True', 'submit' => 'Submit');
|
||||
my $response = $ua->post("http://codepad.org", \%post);
|
||||
|
||||
if (not $response->is_success) {
|
||||
print "There was an error compiling the code.\n";
|
||||
die $response->status_line;
|
||||
print "There was an error compiling the code.\n";
|
||||
die $response->status_line;
|
||||
}
|
||||
|
||||
my $text = $response->decoded_content;
|
||||
my $url = $response->request->uri;
|
||||
my $url = $response->request->uri;
|
||||
|
||||
# remove line numbers
|
||||
$text =~ s/<a style="" name="output-line-\d+">\d+<\/a>//g;
|
||||
|
||||
if ($text =~ /<span class="heading">Output:<\/span>.+?<div class="code">(.*)<\/div>.+?<\/table>/si) {
|
||||
$output .= "$1";
|
||||
} else {
|
||||
$output .= "<pre>No output.</pre>";
|
||||
}
|
||||
if ($text =~ /<span class="heading">Output:<\/span>.+?<div class="code">(.*)<\/div>.+?<\/table>/si) { $output .= "$1"; }
|
||||
else { $output .= "<pre>No output.</pre>"; }
|
||||
|
||||
$output = decode_entities($output);
|
||||
$output = HTML::FormatText->new->format(parse_html($output));
|
||||
|
|
@ -141,24 +137,19 @@ print FILE localtime() . "\n";
|
|||
print FILE "$nick: [ $url ] $output\n\n";
|
||||
close FILE;
|
||||
|
||||
if ($show_url) {
|
||||
print "$nick: [ $url ] $output\n";
|
||||
} else {
|
||||
print "$nick: $output\n";
|
||||
}
|
||||
if ($show_url) { print "$nick: [ $url ] $output\n"; }
|
||||
else { print "$nick: $output\n"; }
|
||||
|
||||
sub pretty {
|
||||
my $code = join '', @_;
|
||||
my $result;
|
||||
my $code = join '', @_;
|
||||
my $result;
|
||||
|
||||
my $pid = open2(\*IN, \*OUT, 'astyle -Upf');
|
||||
print OUT "$code\n";
|
||||
close OUT;
|
||||
while (my $line = <IN>) {
|
||||
$result .= $line;
|
||||
}
|
||||
close IN;
|
||||
waitpid($pid, 0);
|
||||
return $result;
|
||||
my $pid = open2(\*IN, \*OUT, 'astyle -Upf');
|
||||
print OUT "$code\n";
|
||||
close OUT;
|
||||
while (my $line = <IN>) { $result .= $line; }
|
||||
close IN;
|
||||
waitpid($pid, 0);
|
||||
return $result;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -16,32 +16,29 @@ use IO::Socket::INET;
|
|||
use JSON;
|
||||
|
||||
my $sock = IO::Socket::INET->new(
|
||||
PeerAddr => '192.168.0.42',
|
||||
PeerPort => 9000,
|
||||
Proto => 'tcp');
|
||||
PeerAddr => '192.168.0.42',
|
||||
PeerPort => 9000,
|
||||
Proto => 'tcp'
|
||||
);
|
||||
|
||||
if (not defined $sock) {
|
||||
print "Fatal error compiling: $!; try again later\n";
|
||||
die $!;
|
||||
print "Fatal error compiling: $!; try again later\n";
|
||||
die $!;
|
||||
}
|
||||
|
||||
my $json = join ' ', @ARGV;
|
||||
my $h = decode_json $json;
|
||||
my $h = decode_json $json;
|
||||
|
||||
$h->{code} =~ s/\s*}\s*$//;
|
||||
|
||||
my $lang = $h->{lang} // "c11";
|
||||
if ($code =~ s/-lang=([^ ]+)//) {
|
||||
$lang = lc $1;
|
||||
}
|
||||
if ($code =~ s/-lang=([^ ]+)//) { $lang = lc $1; }
|
||||
|
||||
$h->{lang} = $lang;
|
||||
$json = encode_json $h;
|
||||
|
||||
print $sock "$json\n";
|
||||
|
||||
while (my $line = <$sock>) {
|
||||
print "$line";
|
||||
}
|
||||
while (my $line = <$sock>) { print "$line"; }
|
||||
|
||||
close $sock;
|
||||
|
|
|
|||
|
|
@ -16,30 +16,27 @@ use IO::Socket;
|
|||
use JSON;
|
||||
|
||||
my $sock = IO::Socket::INET->new(
|
||||
PeerAddr => '127.0.0.1',
|
||||
PeerPort => 9000,
|
||||
Proto => 'tcp');
|
||||
PeerAddr => '127.0.0.1',
|
||||
PeerPort => 9000,
|
||||
Proto => 'tcp'
|
||||
);
|
||||
|
||||
if(not defined $sock) {
|
||||
print "Fatal error compiling: $!; try again later\n";
|
||||
die $!;
|
||||
if (not defined $sock) {
|
||||
print "Fatal error compiling: $!; try again later\n";
|
||||
die $!;
|
||||
}
|
||||
|
||||
my $json = join ' ', @ARGV;
|
||||
my $h = decode_json $json;
|
||||
my $h = decode_json $json;
|
||||
my $lang = $h->{lang} // "c11";
|
||||
|
||||
if ($h->{code} =~ s/-lang=([^ ]+)//) {
|
||||
$lang = lc $1;
|
||||
}
|
||||
if ($h->{code} =~ s/-lang=([^ ]+)//) { $lang = lc $1; }
|
||||
|
||||
$h->{lang} = $lang;
|
||||
$json = encode_json $h;
|
||||
|
||||
print $sock "$json\n";
|
||||
|
||||
while(my $line = <$sock>) {
|
||||
print "$line";
|
||||
}
|
||||
while (my $line = <$sock>) { print "$line"; }
|
||||
|
||||
close $sock;
|
||||
|
|
|
|||
|
|
@ -10,73 +10,63 @@ use LWP::Simple;
|
|||
|
||||
my ($defint, $phrase, $text, $entry, $entries, $i);
|
||||
|
||||
if ($#ARGV < 0)
|
||||
{
|
||||
print "What phrase would you like to define?\n";
|
||||
die;
|
||||
if ($#ARGV < 0) {
|
||||
print "What phrase would you like to define?\n";
|
||||
die;
|
||||
}
|
||||
|
||||
$phrase = join("%20", @ARGV);
|
||||
|
||||
$entry = 1;
|
||||
|
||||
if ($phrase =~ m/([0-9]+)%20(.*)/)
|
||||
{
|
||||
$entry = $1;
|
||||
$phrase = $2;
|
||||
if ($phrase =~ m/([0-9]+)%20(.*)/) {
|
||||
$entry = $1;
|
||||
$phrase = $2;
|
||||
}
|
||||
|
||||
$text = get("http://dictionary.reference.com/browse/$phrase");
|
||||
|
||||
$phrase =~ s/\%20/ /g;
|
||||
|
||||
if ($text =~ m/no dictionary results/i)
|
||||
{
|
||||
print "No entry found for '$phrase'. ";
|
||||
if ($text =~ m/no dictionary results/i) {
|
||||
print "No entry found for '$phrase'. ";
|
||||
|
||||
if ($text =~ m/Did you mean <a class.*?>(.*?)<\/a>/g) {
|
||||
print "Did you mean '$1'? Alternate suggestions: ";
|
||||
|
||||
if ($text =~ m/Did you mean <a class.*?>(.*?)<\/a>/g)
|
||||
{
|
||||
print "Did you mean '$1'? Alternate suggestions: ";
|
||||
|
||||
$i = 90;
|
||||
$comma = "";
|
||||
while ($text =~ m/<div id="spellSuggestWrapper"><li .*?><a href=.*?>(.*?)<\/a>/g && $i > 0)
|
||||
{
|
||||
print "$comma$1";
|
||||
$i--;
|
||||
$comma = ", ";
|
||||
$i = 90;
|
||||
$comma = "";
|
||||
while ($text =~ m/<div id="spellSuggestWrapper"><li .*?><a href=.*?>(.*?)<\/a>/g && $i > 0) {
|
||||
print "$comma$1";
|
||||
$i--;
|
||||
$comma = ", ";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# if ($text =~ m/Encyclopedia suggestions:/g)
|
||||
# {
|
||||
# print "Suggestions: ";
|
||||
#
|
||||
# $i = 30;
|
||||
# while ($text =~ m/<a href=".*?\/search\?r=13&q=.*?>(.*?)<\/a>/g
|
||||
# && $i > 0)
|
||||
# {
|
||||
# print "$1, ";
|
||||
# $i--;
|
||||
# }
|
||||
# }
|
||||
# if ($text =~ m/Encyclopedia suggestions:/g)
|
||||
# {
|
||||
# print "Suggestions: ";
|
||||
#
|
||||
# $i = 30;
|
||||
# while ($text =~ m/<a href=".*?\/search\?r=13&q=.*?>(.*?)<\/a>/g
|
||||
# && $i > 0)
|
||||
# {
|
||||
# print "$1, ";
|
||||
# $i--;
|
||||
# }
|
||||
# }
|
||||
|
||||
print "\n";
|
||||
exit 0;
|
||||
print "\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if ($text =~ m/- (.*?) dictionary result/g)
|
||||
{
|
||||
$entries = $1;
|
||||
}
|
||||
if ($text =~ m/- (.*?) dictionary result/g) { $entries = $1; }
|
||||
|
||||
$entries = 1 if (not defined $entries);
|
||||
|
||||
if ($entry > $entries)
|
||||
{
|
||||
print "No entry found for $phrase.\n";
|
||||
exit 0;
|
||||
if ($entry > $entries) {
|
||||
print "No entry found for $phrase.\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
print "$phrase: ";
|
||||
|
|
@ -85,40 +75,36 @@ $i = $entry;
|
|||
|
||||
$defint = "";
|
||||
|
||||
my $quote = chr(226) . chr(128) . chr(156);
|
||||
my $quote = chr(226) . chr(128) . chr(156);
|
||||
my $quote2 = chr(226) . chr(128) . chr(157);
|
||||
my $dash = chr(226) . chr(128) . chr(147);
|
||||
my $dash = chr(226) . chr(128) . chr(147);
|
||||
|
||||
while ($i <= $entries)
|
||||
{
|
||||
if ($text =~ m/<td>(.*?)<\/td>/gs)
|
||||
{
|
||||
$defint = $1;
|
||||
}
|
||||
while ($i <= $entries) {
|
||||
if ($text =~ m/<td>(.*?)<\/td>/gs) { $defint = $1; }
|
||||
|
||||
# and now for some fugly beautifying regexps...
|
||||
# and now for some fugly beautifying regexps...
|
||||
|
||||
$defint =~ s/$quote/"/g;
|
||||
$defint =~ s/$quote2/"/g;
|
||||
$defint =~ s/$dash/-/g;
|
||||
$defint =~ s/<b>Pronun.*?<BR>//gsi;
|
||||
$defint =~ s/<.*?>//gsi;
|
||||
$defint =~ s/\ \;/ /gi;
|
||||
$defint =~ s/\&.*?\;//g;
|
||||
$defint =~ s/\r\n//gs;
|
||||
$defint =~ s/\( P \)//gs;
|
||||
$defint =~ s/\s+/ /gs;
|
||||
$defint =~ s/$quote/"/g;
|
||||
$defint =~ s/$quote2/"/g;
|
||||
$defint =~ s/$dash/-/g;
|
||||
$defint =~ s/<b>Pronun.*?<BR>//gsi;
|
||||
$defint =~ s/<.*?>//gsi;
|
||||
$defint =~ s/\ \;/ /gi;
|
||||
$defint =~ s/\&.*?\;//g;
|
||||
$defint =~ s/\r\n//gs;
|
||||
$defint =~ s/\( P \)//gs;
|
||||
$defint =~ s/\s+/ /gs;
|
||||
|
||||
if ($defint =~ /interfaceflash/) {
|
||||
$i++;
|
||||
next;
|
||||
}
|
||||
|
||||
$i++ and next if $defint eq " ";
|
||||
|
||||
print "$i) $defint ";
|
||||
|
||||
if ($defint =~ /interfaceflash/) {
|
||||
$i++;
|
||||
next;
|
||||
}
|
||||
|
||||
$i++ and next if $defint eq " ";
|
||||
|
||||
print "$i) $defint ";
|
||||
|
||||
$i++;
|
||||
}
|
||||
|
||||
print "\n";
|
||||
|
|
|
|||
|
|
@ -10,36 +10,31 @@ use Games::Dice qw/roll roll_array/;
|
|||
|
||||
my ($result, $rolls, $show);
|
||||
|
||||
if ($#ARGV <0)
|
||||
{
|
||||
print "Usage: roll [-show] <dice roll>; e.g.: roll 3d6+1. To see all individual dice rolls, add -show.\n";
|
||||
die;
|
||||
if ($#ARGV < 0) {
|
||||
print "Usage: roll [-show] <dice roll>; e.g.: roll 3d6+1. To see all individual dice rolls, add -show.\n";
|
||||
die;
|
||||
}
|
||||
|
||||
$rolls = join("", @ARGV);
|
||||
|
||||
if ($rolls =~ s/\s*-show\s*//) {
|
||||
$show = 1;
|
||||
}
|
||||
if ($rolls =~ s/\s*-show\s*//) { $show = 1; }
|
||||
|
||||
if ($rolls =~ m/^\s*(\d+)d\d+(?:\+?-?\d+)?\s*$/) {
|
||||
if ($1 > 100) {
|
||||
print "Sorry, maximum of 100 rolls.\n";
|
||||
die;
|
||||
}
|
||||
if ($1 > 100) {
|
||||
print "Sorry, maximum of 100 rolls.\n";
|
||||
die;
|
||||
}
|
||||
} else {
|
||||
print "Usage: roll [-show] <dice roll>; e.g.: roll 3d6+1. To see all individual dice rolls, add -show.\n";
|
||||
die;
|
||||
print "Usage: roll [-show] <dice roll>; e.g.: roll 3d6+1. To see all individual dice rolls, add -show.\n";
|
||||
die;
|
||||
}
|
||||
|
||||
if ($show) {
|
||||
my @results = roll_array $rolls;
|
||||
$result = 0;
|
||||
foreach my $n (@results) {
|
||||
$result += $n;
|
||||
}
|
||||
print "/me rolled $rolls for @results totaling $result.\n";
|
||||
my @results = roll_array $rolls;
|
||||
$result = 0;
|
||||
foreach my $n (@results) { $result += $n; }
|
||||
print "/me rolled $rolls for @results totaling $result.\n";
|
||||
} else {
|
||||
$result = roll $rolls;
|
||||
print "/me rolled $rolls for $result.\n";
|
||||
$result = roll $rolls;
|
||||
print "/me rolled $rolls for $result.\n";
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
|
||||
if 0; # not running under some shell
|
||||
=cut
|
||||
|
||||
#
|
||||
# dict - perl DICT client (for accessing network dictionary servers)
|
||||
#
|
||||
|
|
@ -26,9 +27,9 @@ $VERSION = sprintf("%d.%d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/);
|
|||
#-----------------------------------------------------------------------
|
||||
# Global variables
|
||||
#-----------------------------------------------------------------------
|
||||
my $PROGRAM; # The name we're running as, minus path
|
||||
my $config; # Config object (AppConfig::Std)
|
||||
my $dict; # Dictionary object (Net::Dict)
|
||||
my $PROGRAM; # The name we're running as, minus path
|
||||
my $config; # Config object (AppConfig::Std)
|
||||
my $dict; # Dictionary object (Net::Dict)
|
||||
|
||||
initialise();
|
||||
|
||||
|
|
@ -43,17 +44,14 @@ list_databases() if $config->dbs;
|
|||
list_strategies() if $config->strats;
|
||||
=cut
|
||||
|
||||
if ($config->database) {
|
||||
$dict->setDicts($config->database);
|
||||
} else {
|
||||
$dict->setDicts('wn');
|
||||
}
|
||||
if ($config->database) { $dict->setDicts($config->database); }
|
||||
else { $dict->setDicts('wn'); }
|
||||
|
||||
#-----------------------------------------------------------------------
|
||||
# Perform define or match, if a word or pattern was given
|
||||
#-----------------------------------------------------------------------
|
||||
if (@ARGV > 0)
|
||||
{
|
||||
if (@ARGV > 0) {
|
||||
|
||||
=cut
|
||||
if ($config->match)
|
||||
{
|
||||
|
|
@ -62,13 +60,17 @@ if (@ARGV > 0)
|
|||
else
|
||||
{
|
||||
=cut
|
||||
define_word(join ' ', @ARGV);
|
||||
|
||||
define_word(join ' ', @ARGV);
|
||||
|
||||
=cut
|
||||
}
|
||||
=cut
|
||||
|
||||
} else {
|
||||
print "Usage: dict [-d database] [-n start from definition number] [-t abbreviation of word class type (n]oun, v]erb, adv]erb, adj]ective, etc)] [-search <regex> for definitions matching <regex>] <word>\n";
|
||||
exit 0;
|
||||
print
|
||||
"Usage: dict [-d database] [-n start from definition number] [-t abbreviation of word class type (n]oun, v]erb, adv]erb, adj]ective, etc)] [-search <regex> for definitions matching <regex>] <word>\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
exit 0;
|
||||
|
|
@ -80,116 +82,100 @@ exit 0;
|
|||
# Look up definition(s) for the specified word.
|
||||
#
|
||||
#=======================================================================
|
||||
sub define_word
|
||||
{
|
||||
my $word = shift;
|
||||
my $eref;
|
||||
my $entry;
|
||||
my ($db, $def);
|
||||
sub define_word {
|
||||
my $word = shift;
|
||||
my $eref;
|
||||
my $entry;
|
||||
my ($db, $def);
|
||||
|
||||
$eref = $dict->define($word);
|
||||
|
||||
$eref = $dict->define($word);
|
||||
if (@$eref == 0) { _no_definitions($word); }
|
||||
else {
|
||||
foreach $entry (@$eref) {
|
||||
($db, $def) = @$entry;
|
||||
|
||||
if (@$eref == 0)
|
||||
{
|
||||
_no_definitions($word);
|
||||
}
|
||||
else
|
||||
{
|
||||
foreach $entry (@$eref)
|
||||
{
|
||||
($db, $def) = @$entry;
|
||||
my $defs = dict_hash($def);
|
||||
print "$defs->{word}: ";
|
||||
|
||||
my $defs = dict_hash($def);
|
||||
print "$defs->{word}: ";
|
||||
my $comma = '';
|
||||
my $def_type = $config->def_type;
|
||||
my $def_contains = $config->def_contains;
|
||||
|
||||
my $comma = '';
|
||||
my $def_type = $config->def_type;
|
||||
my $def_contains = $config->def_contains;
|
||||
# normalize '*' to '.*'
|
||||
$def_type =~ s/\.\*/*/g;
|
||||
$def_type =~ s/\*/.*/g;
|
||||
|
||||
# normalize '*' to '.*'
|
||||
$def_type =~ s/\.\*/*/g;
|
||||
$def_type =~ s/\*/.*/g;
|
||||
# normalize '*' to '.*'
|
||||
$def_contains =~ s/\.\*/*/g;
|
||||
$def_contains =~ s/\*/.*/g;
|
||||
|
||||
# normalize '*' to '.*'
|
||||
$def_contains =~ s/\.\*/*/g;
|
||||
$def_contains =~ s/\*/.*/g;
|
||||
my $defined = 0;
|
||||
|
||||
my $defined = 0;
|
||||
eval {
|
||||
foreach my $type (keys %$defs) {
|
||||
next if $type eq 'word';
|
||||
next unless $type =~ m/$def_type/i;
|
||||
print "$comma$type: " if length $type;
|
||||
foreach my $number (sort { $a <=> $b } keys %{$defs->{$type}}) {
|
||||
next unless $number >= $config->def_number;
|
||||
next unless $defs->{$type}{$number} =~ m/$def_contains/i;
|
||||
print "$comma" unless $number == 1;
|
||||
print "$number) $defs->{$type}{$number}";
|
||||
$comma = ",\n\n";
|
||||
$defined = 1;
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
eval {
|
||||
foreach my $type (keys %$defs) {
|
||||
next if $type eq 'word';
|
||||
next unless $type =~ m/$def_type/i;
|
||||
print "$comma$type: " if length $type;
|
||||
foreach my $number (sort { $a <=> $b } keys %{ $defs->{$type} }) {
|
||||
next unless $number >= $config->def_number;
|
||||
next unless $defs->{$type}{$number} =~ m/$def_contains/i;
|
||||
print "$comma" unless $number == 1;
|
||||
print "$number) $defs->{$type}{$number}";
|
||||
$comma = ",\n\n";
|
||||
$defined = 1;
|
||||
}
|
||||
if ($@) {
|
||||
print "Error in -t parameter. Use v, n, *, etc.\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if (not $defined && $def_type ne '*') {
|
||||
my $types = '';
|
||||
$comma = '';
|
||||
foreach my $type (sort keys %$defs) {
|
||||
next if $type eq 'word';
|
||||
$types .= "$comma$type";
|
||||
$comma = ', ';
|
||||
}
|
||||
if (length $types) { print "no `$def_type` definition found; available definitions: $types.\n"; }
|
||||
else { print "no definition found.\n"; }
|
||||
} elsif (not $defined) {
|
||||
print "no definition found.\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
print "Error in -t parameter. Use v, n, *, etc.\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if (not $defined && $def_type ne '*') {
|
||||
my $types = '';
|
||||
$comma = '';
|
||||
foreach my $type (sort keys %$defs) {
|
||||
next if $type eq 'word';
|
||||
$types .= "$comma$type";
|
||||
$comma = ', ';
|
||||
}
|
||||
if (length $types) {
|
||||
print "no `$def_type` definition found; available definitions: $types.\n";
|
||||
} else {
|
||||
print "no definition found.\n";
|
||||
}
|
||||
} elsif (not $defined) {
|
||||
print "no definition found.\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub dict_hash {
|
||||
my $def = shift;
|
||||
my $defs = {};
|
||||
my $def = shift;
|
||||
my $defs = {};
|
||||
|
||||
$def =~ s/{([^}]+)}/$1/g;
|
||||
$def =~ s/{([^}]+)}/$1/g;
|
||||
|
||||
my @lines = split /[\n\r]/, $def;
|
||||
my @lines = split /[\n\r]/, $def;
|
||||
|
||||
$defs->{word} = shift @lines;
|
||||
$defs->{word} = shift @lines;
|
||||
|
||||
my ($type, $number, $text) = ('', 1, '');
|
||||
my ($type, $number, $text) = ('', 1, '');
|
||||
|
||||
foreach my $line (@lines) {
|
||||
$line =~ s/^\s+//;
|
||||
$line =~ s/\s+$//;
|
||||
$line =~ s/\s+/ /g;
|
||||
foreach my $line (@lines) {
|
||||
$line =~ s/^\s+//;
|
||||
$line =~ s/\s+$//;
|
||||
$line =~ s/\s+/ /g;
|
||||
|
||||
if ($line =~ m/^([a-z]+) (\d+): (.*)/i) {
|
||||
($type, $number, $text) = ($1, $2, $3);
|
||||
}
|
||||
elsif ($line =~ m/^(\d+): (.*)/i) {
|
||||
($number, $text) = ($1, $2);
|
||||
}
|
||||
else {
|
||||
$text = $line;
|
||||
if ($line =~ m/^([a-z]+) (\d+): (.*)/i) { ($type, $number, $text) = ($1, $2, $3); }
|
||||
elsif ($line =~ m/^(\d+): (.*)/i) { ($number, $text) = ($1, $2); }
|
||||
else { $text = $line; }
|
||||
|
||||
$text = " $text" if exists $defs->{$type}{$number};
|
||||
$defs->{$type}{$number} .= $text;
|
||||
}
|
||||
|
||||
$text = " $text" if exists $defs->{$type}{$number};
|
||||
$defs->{$type}{$number} .= $text;
|
||||
}
|
||||
|
||||
return $defs;
|
||||
return $defs;
|
||||
}
|
||||
|
||||
#=======================================================================
|
||||
|
|
@ -202,34 +188,25 @@ sub dict_hash {
|
|||
# it, etc.
|
||||
#
|
||||
#=======================================================================
|
||||
sub _no_definitions
|
||||
{
|
||||
sub _no_definitions {
|
||||
my $word = shift;
|
||||
|
||||
my %strategies;
|
||||
my %words;
|
||||
my $strategy;
|
||||
|
||||
|
||||
%strategies = $dict->strategies;
|
||||
if (!exists($strategies{'lev'}) && !exists($strategies{'soundex'}))
|
||||
{
|
||||
if (!exists($strategies{'lev'}) && !exists($strategies{'soundex'})) {
|
||||
print "no definition found for \"$word\"\n";
|
||||
return;
|
||||
}
|
||||
|
||||
$strategy = exists $strategies{'lev'} ? 'lev' : 'soundex';
|
||||
foreach my $entry (@{ $dict->match($word, $strategy) })
|
||||
{
|
||||
$words{$entry->[1]}++;
|
||||
}
|
||||
if (keys %words == 0)
|
||||
{
|
||||
foreach my $entry (@{$dict->match($word, $strategy)}) { $words{$entry->[1]}++; }
|
||||
if (keys %words == 0) {
|
||||
print "no definition found for \"$word\", ",
|
||||
"and no similar words found\n";
|
||||
}
|
||||
else
|
||||
{
|
||||
"and no similar words found\n";
|
||||
} else {
|
||||
print "no definition found for \"$word\" - perhaps you meant: ", join(', ', keys %words), "\n";
|
||||
}
|
||||
}
|
||||
|
|
@ -242,28 +219,18 @@ sub _no_definitions
|
|||
# with the -strategy switch.
|
||||
#
|
||||
#=======================================================================
|
||||
sub match_word
|
||||
{
|
||||
sub match_word {
|
||||
my $word = shift;
|
||||
my $eref;
|
||||
my $entry;
|
||||
my ($db, $match);
|
||||
|
||||
|
||||
unless ($config->strategy)
|
||||
{
|
||||
die "you must specify -strategy when using -match\n";
|
||||
}
|
||||
unless ($config->strategy) { die "you must specify -strategy when using -match\n"; }
|
||||
$eref = $dict->match($word, $config->strategy);
|
||||
|
||||
if (@$eref == 0)
|
||||
{
|
||||
print "no matches for \"$word\"\n";
|
||||
}
|
||||
else
|
||||
{
|
||||
foreach $entry (@$eref)
|
||||
{
|
||||
if (@$eref == 0) { print "no matches for \"$word\"\n"; }
|
||||
else {
|
||||
foreach $entry (@$eref) {
|
||||
($db, $match) = @$entry;
|
||||
print "$db : $match\n";
|
||||
}
|
||||
|
|
@ -278,11 +245,9 @@ sub match_word
|
|||
# DICT server.
|
||||
#
|
||||
#=======================================================================
|
||||
sub list_databases
|
||||
{
|
||||
sub list_databases {
|
||||
my %dbs = $dict->dbs();
|
||||
|
||||
|
||||
tabulate_hash(\%dbs, 'Database', 'Description');
|
||||
}
|
||||
|
||||
|
|
@ -294,11 +259,9 @@ sub list_databases
|
|||
# by the DICT server.
|
||||
#
|
||||
#=======================================================================
|
||||
sub list_strategies
|
||||
{
|
||||
sub list_strategies {
|
||||
my %strats = $dict->strategies();
|
||||
|
||||
|
||||
tabulate_hash(\%strats, 'Strategy', 'Description');
|
||||
}
|
||||
|
||||
|
|
@ -314,14 +277,11 @@ sub list_strategies
|
|||
# credits, etc.
|
||||
#
|
||||
#=======================================================================
|
||||
sub show_db_info
|
||||
{
|
||||
sub show_db_info {
|
||||
my $db = shift;
|
||||
my %dbs = $dict->dbs();
|
||||
|
||||
|
||||
if (not exists $dbs{$config->info})
|
||||
{
|
||||
if (not exists $dbs{$config->info}) {
|
||||
print " dictionary \"$db\" not known\n";
|
||||
return;
|
||||
}
|
||||
|
|
@ -336,8 +296,8 @@ sub show_db_info
|
|||
# check config file and command-line
|
||||
#
|
||||
#=======================================================================
|
||||
sub initialise
|
||||
{
|
||||
sub initialise {
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
# Initialise misc global variables
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -346,16 +306,20 @@ sub initialise
|
|||
#-------------------------------------------------------------------
|
||||
# Create AppConfig::Std, define parameters, and parse command-line
|
||||
#-------------------------------------------------------------------
|
||||
$config = AppConfig::Std->new({ CASE => 1 })
|
||||
|| die "failed to create AppConfig::Std: $!\n";
|
||||
$config = AppConfig::Std->new({CASE => 1}) || die "failed to create AppConfig::Std: $!\n";
|
||||
|
||||
$config->define('host', { ARGCOUNT => 1, ALIAS => 'h' });
|
||||
$config->define('port', { ARGCOUNT => 1, ALIAS => 'p',
|
||||
DEFAULT => 2628 });
|
||||
$config->define('database', { ARGCOUNT => 1, ALIAS => 'd' });
|
||||
$config->define('def_number', { ARGCOUNT => 1, ALIAS => 'n', DEFAULT => 1 });
|
||||
$config->define('def_type', { ARGCOUNT => 1, ALIAS => 't', DEFAULT => '*'});
|
||||
$config->define('def_contains', { ARGCOUNT => 1, ALIAS => 'search', DEFAULT => '*'});
|
||||
$config->define('host', {ARGCOUNT => 1, ALIAS => 'h'});
|
||||
$config->define(
|
||||
'port',
|
||||
{
|
||||
ARGCOUNT => 1, ALIAS => 'p',
|
||||
DEFAULT => 2628
|
||||
}
|
||||
);
|
||||
$config->define('database', {ARGCOUNT => 1, ALIAS => 'd'});
|
||||
$config->define('def_number', {ARGCOUNT => 1, ALIAS => 'n', DEFAULT => 1});
|
||||
$config->define('def_type', {ARGCOUNT => 1, ALIAS => 't', DEFAULT => '*'});
|
||||
$config->define('def_contains', {ARGCOUNT => 1, ALIAS => 'search', DEFAULT => '*'});
|
||||
|
||||
=cut
|
||||
$config->define('match', { ARGCOUNT => 0, ALIAS => 'm' });
|
||||
|
|
@ -363,10 +327,15 @@ sub initialise
|
|||
$config->define('strategy', { ARGCOUNT => 1, ALIAS => 's' });
|
||||
$config->define('strats', { ARGCOUNT => 0, ALIAS => 'S' });
|
||||
=cut
|
||||
$config->define('client', { ARGCOUNT => 1, ALIAS => 'c',
|
||||
DEFAULT => "$PROGRAM $VERSION ".
|
||||
"[using Net::Dict $Net::Dict::VERSION]",
|
||||
});
|
||||
|
||||
$config->define(
|
||||
'client',
|
||||
{
|
||||
ARGCOUNT => 1, ALIAS => 'c',
|
||||
DEFAULT => "$PROGRAM $VERSION " . "[using Net::Dict $Net::Dict::VERSION]",
|
||||
}
|
||||
);
|
||||
|
||||
=cut
|
||||
$config->define('info', { ARGCOUNT => 1, ALIAS => 'i' });
|
||||
$config->define('serverinfo', { ARGCOUNT => 0, ALIAS => 'I' });
|
||||
|
|
@ -374,8 +343,9 @@ sub initialise
|
|||
=cut
|
||||
|
||||
if (not $config->args(\@ARGV)) {
|
||||
print "Usage: dict [-d database] [-n start from definition number] [-t abbreviation of word class type (n]oun, v]erb, adv]erb, adj]ective, etc)] [-search <regex> for definitions matching <regex>] <word>\n";
|
||||
exit;
|
||||
print
|
||||
"Usage: dict [-d database] [-n start from definition number] [-t abbreviation of word class type (n]oun, v]erb, adv]erb, adj]ective, etc)] [-search <regex> for definitions matching <regex>] <word>\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -388,12 +358,12 @@ sub initialise
|
|||
#-------------------------------------------------------------------
|
||||
# Create connection to DICT server
|
||||
#-------------------------------------------------------------------
|
||||
$dict = Net::Dict->new($config->host,
|
||||
Port => $config->port,
|
||||
Client => $config->client,
|
||||
Debug => $config->debug,
|
||||
)
|
||||
|| die "failed to create Net::Dict: $!\n";
|
||||
$dict = Net::Dict->new(
|
||||
$config->host,
|
||||
Port => $config->port,
|
||||
Client => $config->client,
|
||||
Debug => $config->debug,
|
||||
) || die "failed to create Net::Dict: $!\n";
|
||||
}
|
||||
|
||||
#=======================================================================
|
||||
|
|
@ -404,8 +374,8 @@ sub initialise
|
|||
# of databases and strategies.
|
||||
#
|
||||
#=======================================================================
|
||||
sub tabulate_hash
|
||||
{
|
||||
sub tabulate_hash {
|
||||
|
||||
my $hashref = shift;
|
||||
my $keytitle = shift;
|
||||
my $value_title = shift;
|
||||
|
|
@ -413,29 +383,21 @@ sub tabulate_hash
|
|||
my $width = length $keytitle;
|
||||
my ($key, $value);
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
# Find the length of the longest key, so we can right align
|
||||
# the column of keys
|
||||
#-------------------------------------------------------------------
|
||||
foreach $key (keys %$hashref)
|
||||
{
|
||||
$width = length($key) if length($key) > $width;
|
||||
}
|
||||
foreach $key (keys %$hashref) { $width = length($key) if length($key) > $width; }
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
# print out keys and values in a basic ascii formatted table view
|
||||
#-------------------------------------------------------------------
|
||||
printf(" %${width}s $value_title\n", $keytitle);
|
||||
print ' ', '-' x $width, ' ', '-' x (length $value_title), "\n";
|
||||
while (($key, $value) = each %$hashref)
|
||||
{
|
||||
printf(" %${width}s : $value\n", $key);
|
||||
}
|
||||
while (($key, $value) = each %$hashref) { printf(" %${width}s : $value\n", $key); }
|
||||
print "\n";
|
||||
}
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
|
|
|||
|
|
@ -15,14 +15,14 @@ use LWP::UserAgent;
|
|||
|
||||
my $debug = 0;
|
||||
|
||||
my $USE_LOCAL = defined $ENV{'CC_LOCAL'};
|
||||
my $USE_LOCAL = defined $ENV{'CC_LOCAL'};
|
||||
|
||||
my $output = "";
|
||||
my $output = "";
|
||||
my $nooutput = 'No output.';
|
||||
|
||||
if ($#ARGV < 0) {
|
||||
print "Usage: expand <code>\n";
|
||||
exit 0;
|
||||
print "Usage: expand <code>\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my $code = join ' ', @ARGV;
|
||||
|
|
@ -35,55 +35,47 @@ print " code: [$code]\n" if $debug;
|
|||
my $new_code = "";
|
||||
|
||||
use constant {
|
||||
NORMAL => 0,
|
||||
DOUBLE_QUOTED => 1,
|
||||
SINGLE_QUOTED => 2,
|
||||
NORMAL => 0,
|
||||
DOUBLE_QUOTED => 1,
|
||||
SINGLE_QUOTED => 2,
|
||||
};
|
||||
|
||||
my $state = NORMAL;
|
||||
my $state = NORMAL;
|
||||
my $escaped = 0;
|
||||
|
||||
while ($code =~ m/(.)/gs) {
|
||||
my $ch = $1;
|
||||
my $ch = $1;
|
||||
|
||||
given ($ch) {
|
||||
when ('\\') {
|
||||
if ($escaped == 0) {
|
||||
$escaped = 1;
|
||||
next;
|
||||
}
|
||||
given ($ch) {
|
||||
when ('\\') {
|
||||
if ($escaped == 0) {
|
||||
$escaped = 1;
|
||||
next;
|
||||
}
|
||||
}
|
||||
|
||||
if ($state == NORMAL) {
|
||||
when ($_ eq '"' and not $escaped) { $state = DOUBLE_QUOTED; }
|
||||
|
||||
when ($_ eq "'" and not $escaped) { $state = SINGLE_QUOTED; }
|
||||
|
||||
when ($_ eq 'n' and $escaped == 1) {
|
||||
$ch = "\n";
|
||||
$escaped = 0;
|
||||
}
|
||||
}
|
||||
|
||||
if ($state == DOUBLE_QUOTED) {
|
||||
when ($_ eq '"' and not $escaped) { $state = NORMAL; }
|
||||
}
|
||||
|
||||
if ($state == SINGLE_QUOTED) {
|
||||
when ($_ eq "'" and not $escaped) { $state = NORMAL; }
|
||||
}
|
||||
}
|
||||
|
||||
if ($state == NORMAL) {
|
||||
when ($_ eq '"' and not $escaped) {
|
||||
$state = DOUBLE_QUOTED;
|
||||
}
|
||||
|
||||
when ($_ eq "'" and not $escaped) {
|
||||
$state = SINGLE_QUOTED;
|
||||
}
|
||||
|
||||
when ($_ eq 'n' and $escaped == 1) {
|
||||
$ch = "\n";
|
||||
$escaped = 0;
|
||||
}
|
||||
}
|
||||
|
||||
if ($state == DOUBLE_QUOTED) {
|
||||
when ($_ eq '"' and not $escaped) {
|
||||
$state = NORMAL;
|
||||
}
|
||||
}
|
||||
|
||||
if ($state == SINGLE_QUOTED) {
|
||||
when ($_ eq "'" and not $escaped) {
|
||||
$state = NORMAL;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$new_code .= '\\' and $escaped = 0 if $escaped;
|
||||
$new_code .= $ch;
|
||||
$new_code .= '\\' and $escaped = 0 if $escaped;
|
||||
$new_code .= $ch;
|
||||
}
|
||||
|
||||
$code = $new_code;
|
||||
|
|
@ -92,69 +84,68 @@ print "code after \\n replacement: [$code]\n" if $debug;
|
|||
|
||||
my $single_quote = 0;
|
||||
my $double_quote = 0;
|
||||
my $parens = 0;
|
||||
my $escaped = 0;
|
||||
my $cpp = 0; # preprocessor
|
||||
my $parens = 0;
|
||||
my $escaped = 0;
|
||||
my $cpp = 0; # preprocessor
|
||||
|
||||
while ($code =~ m/(.)/msg) {
|
||||
my $ch = $1;
|
||||
my $pos = pos $code;
|
||||
my $ch = $1;
|
||||
my $pos = pos $code;
|
||||
|
||||
print "adding newlines, ch = [$ch], parens: $parens, cpp: $cpp, single: $single_quote, double: $double_quote, escaped: $escaped, pos: $pos\n" if $debug >= 10;
|
||||
print "adding newlines, ch = [$ch], parens: $parens, cpp: $cpp, single: $single_quote, double: $double_quote, escaped: $escaped, pos: $pos\n" if $debug >= 10;
|
||||
|
||||
if ($ch eq '\\') {
|
||||
$escaped = not $escaped;
|
||||
} elsif ($ch eq '#' and not $cpp and not $escaped and not $single_quote and not $double_quote) {
|
||||
$cpp = 1;
|
||||
if ($ch eq '\\') { $escaped = not $escaped; }
|
||||
elsif ($ch eq '#' and not $cpp and not $escaped and not $single_quote and not $double_quote) {
|
||||
$cpp = 1;
|
||||
|
||||
if ($code =~ m/include\s*[<"]([^>"]*)[>"]/msg) {
|
||||
my $match = $1;
|
||||
$pos = pos $code;
|
||||
substr ($code, $pos, 0) = "\n";
|
||||
pos $code = $pos;
|
||||
$cpp = 0;
|
||||
if ($code =~ m/include\s*[<"]([^>"]*)[>"]/msg) {
|
||||
my $match = $1;
|
||||
$pos = pos $code;
|
||||
substr($code, $pos, 0) = "\n";
|
||||
pos $code = $pos;
|
||||
$cpp = 0;
|
||||
} else {
|
||||
pos $code = $pos;
|
||||
}
|
||||
} elsif ($ch eq '"') {
|
||||
$double_quote = not $double_quote unless $escaped or $single_quote;
|
||||
$escaped = 0;
|
||||
} elsif ($ch eq '(' and not $single_quote and not $double_quote) {
|
||||
$parens++;
|
||||
} elsif ($ch eq ')' and not $single_quote and not $double_quote) {
|
||||
$parens--;
|
||||
$parens = 0 if $parens < 0;
|
||||
} elsif ($ch eq ';' and not $cpp and not $single_quote and not $double_quote and $parens == 0) {
|
||||
if (not substr($code, $pos, 1) =~ m/[\n\r]/) {
|
||||
substr($code, $pos, 0) = "\n";
|
||||
pos $code = $pos + 1;
|
||||
}
|
||||
} elsif ($ch eq "'") {
|
||||
$single_quote = not $single_quote unless $escaped or $double_quote;
|
||||
$escaped = 0;
|
||||
} elsif ($ch eq 'n' and $escaped) {
|
||||
if (not $single_quote and not $double_quote) {
|
||||
print "added newline\n" if $debug >= 10;
|
||||
substr($code, $pos - 2, 2) = "\n";
|
||||
pos $code = $pos;
|
||||
$cpp = 0;
|
||||
}
|
||||
$escaped = 0;
|
||||
} elsif ($ch eq '{' and not $cpp and not $single_quote and not $double_quote) {
|
||||
if (not substr($code, $pos, 1) =~ m/[\n\r]/) {
|
||||
substr($code, $pos, 0) = "\n";
|
||||
pos $code = $pos + 1;
|
||||
}
|
||||
} elsif ($ch eq '}' and not $cpp and not $single_quote and not $double_quote) {
|
||||
if (not substr($code, $pos, 1) =~ m/[\n\r;]/) {
|
||||
substr($code, $pos, 0) = "\n";
|
||||
pos $code = $pos + 1;
|
||||
}
|
||||
} elsif ($ch eq "\n" and $cpp and not $single_quote and not $double_quote) {
|
||||
$cpp = 0;
|
||||
} else {
|
||||
pos $code = $pos;
|
||||
$escaped = 0;
|
||||
}
|
||||
} elsif ($ch eq '"') {
|
||||
$double_quote = not $double_quote unless $escaped or $single_quote;
|
||||
$escaped = 0;
|
||||
} elsif ($ch eq '(' and not $single_quote and not $double_quote) {
|
||||
$parens++;
|
||||
} elsif ($ch eq ')' and not $single_quote and not $double_quote) {
|
||||
$parens--;
|
||||
$parens = 0 if $parens < 0;
|
||||
} elsif ($ch eq ';' and not $cpp and not $single_quote and not $double_quote and $parens == 0) {
|
||||
if (not substr($code, $pos, 1) =~ m/[\n\r]/) {
|
||||
substr ($code, $pos, 0) = "\n";
|
||||
pos $code = $pos + 1;
|
||||
}
|
||||
} elsif ($ch eq "'") {
|
||||
$single_quote = not $single_quote unless $escaped or $double_quote;
|
||||
$escaped = 0;
|
||||
} elsif ($ch eq 'n' and $escaped) {
|
||||
if (not $single_quote and not $double_quote) {
|
||||
print "added newline\n" if $debug >= 10;
|
||||
substr ($code, $pos - 2, 2) = "\n";
|
||||
pos $code = $pos;
|
||||
$cpp = 0;
|
||||
}
|
||||
$escaped = 0;
|
||||
} elsif ($ch eq '{' and not $cpp and not $single_quote and not $double_quote) {
|
||||
if (not substr($code, $pos, 1) =~ m/[\n\r]/) {
|
||||
substr ($code, $pos, 0) = "\n";
|
||||
pos $code = $pos + 1;
|
||||
}
|
||||
} elsif ($ch eq '}' and not $cpp and not $single_quote and not $double_quote) {
|
||||
if (not substr($code, $pos, 1) =~ m/[\n\r;]/) {
|
||||
substr ($code, $pos, 0) = "\n";
|
||||
pos $code = $pos + 1;
|
||||
}
|
||||
} elsif ($ch eq "\n" and $cpp and not $single_quote and not $double_quote) {
|
||||
$cpp = 0;
|
||||
} else {
|
||||
$escaped = 0;
|
||||
}
|
||||
}
|
||||
|
||||
print "code after \\n additions: [$code]\n" if $debug;
|
||||
|
|
@ -170,110 +161,107 @@ print "--- precode: [$precode]\n" if $debug;
|
|||
|
||||
my $has_main = 0;
|
||||
if ($lang eq 'C89' or $lang eq 'C99' or $lang eq 'C11' or $lang eq 'C++') {
|
||||
my $prelude = '';
|
||||
while ($precode =~ s/^\s*(#.*\n{1,2})//g) {
|
||||
$prelude .= $1;
|
||||
}
|
||||
my $prelude = '';
|
||||
while ($precode =~ s/^\s*(#.*\n{1,2})//g) { $prelude .= $1; }
|
||||
|
||||
print "*** prelude: [$prelude]\n precode: [$precode]\n" if $debug;
|
||||
print "*** prelude: [$prelude]\n precode: [$precode]\n" if $debug;
|
||||
|
||||
my $preprecode = $precode;
|
||||
my $preprecode = $precode;
|
||||
|
||||
# white-out contents of quoted literals
|
||||
$preprecode =~ s/(?:\"((?:\\\"|(?!\").)*)\")/'"' . ('-' x length $1) . '"'/ge;
|
||||
$preprecode =~ s/(?:\'((?:\\\'|(?!\').)*)\')/"'" . ('-' x length $1) . "'"/ge;
|
||||
# white-out contents of quoted literals
|
||||
$preprecode =~ s/(?:\"((?:\\\"|(?!\").)*)\")/'"' . ('-' x length $1) . '"'/ge;
|
||||
$preprecode =~ s/(?:\'((?:\\\'|(?!\').)*)\')/"'" . ('-' x length $1) . "'"/ge;
|
||||
|
||||
# strip C and C++ style comments
|
||||
if ($lang eq 'C89' or $args =~ m/-std=(gnu89|c89)/i) {
|
||||
$preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs;
|
||||
$preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse;
|
||||
} else {
|
||||
$preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse;
|
||||
$preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs;
|
||||
}
|
||||
|
||||
print "preprecode: [$preprecode]\n" if $debug;
|
||||
|
||||
print "looking for functions, has main: $has_main\n" if $debug >= 2;
|
||||
|
||||
my $func_regex = qr/^([ *\w]+)\s+([*\w]+)\s*\(([^;{]*)\s*\)\s*({.*|<%.*|\?\?<.*)/ims;
|
||||
|
||||
# look for potential functions to extract
|
||||
while ($preprecode =~ /$func_regex/ms) {
|
||||
my ($pre_ret, $pre_ident, $pre_params, $pre_potential_body) = ($1, $2, $3, $4);
|
||||
|
||||
print "looking for functions, found [$pre_ret][$pre_ident][$pre_params][$pre_potential_body], has main: $has_main\n" if $debug >= 1;
|
||||
|
||||
# find the pos at which this function lives, for extracting from precode
|
||||
$preprecode =~ m/(\Q$pre_ret\E\s+\Q$pre_ident\E\s*\(\s*\Q$pre_params\E\s*\)\s*\Q$pre_potential_body\E)/g;
|
||||
my $extract_pos = (pos $preprecode) - (length $1);
|
||||
|
||||
# now that we have the pos, substitute out the extracted potential function from preprecode
|
||||
$preprecode =~ s/$func_regex//ms;
|
||||
|
||||
# create tmpcode object that starts from extract pos, to skip any quoted code
|
||||
my $tmpcode = substr($precode, $extract_pos);
|
||||
print "tmpcode: [$tmpcode]\n" if $debug;
|
||||
|
||||
$precode = substr($precode, 0, $extract_pos);
|
||||
print "precode: [$precode]\n" if $debug;
|
||||
|
||||
$tmpcode =~ m/$func_regex/ms;
|
||||
my ($ret, $ident, $params, $potential_body) = ($1, $2, $3, $4);
|
||||
|
||||
print "1st extract: [$ret][$ident][$params][$potential_body]\n" if $debug;
|
||||
|
||||
$ret =~ s/^\s+//;
|
||||
$ret =~ s/\s+$//;
|
||||
|
||||
if (not length $ret or $ret eq "else" or $ret eq "while" or $ret eq "if" or $ret eq "for" or $ident eq "for" or $ident eq "while" or $ident eq "if") {
|
||||
$precode .= "$ret $ident ($params) $potential_body";
|
||||
next;
|
||||
# strip C and C++ style comments
|
||||
if ($lang eq 'C89' or $args =~ m/-std=(gnu89|c89)/i) {
|
||||
$preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs;
|
||||
$preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse;
|
||||
} else {
|
||||
$tmpcode =~ s/$func_regex//ms;
|
||||
$preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse;
|
||||
$preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs;
|
||||
}
|
||||
|
||||
$potential_body =~ s/^\s*<%/{/ms;
|
||||
$potential_body =~ s/%>\s*$/}/ms;
|
||||
$potential_body =~ s/^\s*\?\?</{/ms;
|
||||
$potential_body =~ s/\?\?>$/}/ms;
|
||||
print "preprecode: [$preprecode]\n" if $debug;
|
||||
|
||||
my @extract = extract_bracketed($potential_body, '{}');
|
||||
my $body;
|
||||
if (not defined $extract[0]) {
|
||||
if ($debug == 0) {
|
||||
print "error: unmatched brackets\n";
|
||||
print "looking for functions, has main: $has_main\n" if $debug >= 2;
|
||||
|
||||
my $func_regex = qr/^([ *\w]+)\s+([*\w]+)\s*\(([^;{]*)\s*\)\s*({.*|<%.*|\?\?<.*)/ims;
|
||||
|
||||
# look for potential functions to extract
|
||||
while ($preprecode =~ /$func_regex/ms) {
|
||||
my ($pre_ret, $pre_ident, $pre_params, $pre_potential_body) = ($1, $2, $3, $4);
|
||||
|
||||
print "looking for functions, found [$pre_ret][$pre_ident][$pre_params][$pre_potential_body], has main: $has_main\n" if $debug >= 1;
|
||||
|
||||
# find the pos at which this function lives, for extracting from precode
|
||||
$preprecode =~ m/(\Q$pre_ret\E\s+\Q$pre_ident\E\s*\(\s*\Q$pre_params\E\s*\)\s*\Q$pre_potential_body\E)/g;
|
||||
my $extract_pos = (pos $preprecode) - (length $1);
|
||||
|
||||
# now that we have the pos, substitute out the extracted potential function from preprecode
|
||||
$preprecode =~ s/$func_regex//ms;
|
||||
|
||||
# create tmpcode object that starts from extract pos, to skip any quoted code
|
||||
my $tmpcode = substr($precode, $extract_pos);
|
||||
print "tmpcode: [$tmpcode]\n" if $debug;
|
||||
|
||||
$precode = substr($precode, 0, $extract_pos);
|
||||
print "precode: [$precode]\n" if $debug;
|
||||
|
||||
$tmpcode =~ m/$func_regex/ms;
|
||||
my ($ret, $ident, $params, $potential_body) = ($1, $2, $3, $4);
|
||||
|
||||
print "1st extract: [$ret][$ident][$params][$potential_body]\n" if $debug;
|
||||
|
||||
$ret =~ s/^\s+//;
|
||||
$ret =~ s/\s+$//;
|
||||
|
||||
if (not length $ret or $ret eq "else" or $ret eq "while" or $ret eq "if" or $ret eq "for" or $ident eq "for" or $ident eq "while" or $ident eq "if") {
|
||||
$precode .= "$ret $ident ($params) $potential_body";
|
||||
next;
|
||||
} else {
|
||||
print "error: unmatched brackets for function '$ident';\n";
|
||||
print "body: [$potential_body]\n";
|
||||
$tmpcode =~ s/$func_regex//ms;
|
||||
}
|
||||
exit;
|
||||
} else {
|
||||
$body = $extract[0];
|
||||
$preprecode .= $extract[1];
|
||||
$precode .= $extract[1];
|
||||
|
||||
$potential_body =~ s/^\s*<%/{/ms;
|
||||
$potential_body =~ s/%>\s*$/}/ms;
|
||||
$potential_body =~ s/^\s*\?\?</{/ms;
|
||||
$potential_body =~ s/\?\?>$/}/ms;
|
||||
|
||||
my @extract = extract_bracketed($potential_body, '{}');
|
||||
my $body;
|
||||
if (not defined $extract[0]) {
|
||||
if ($debug == 0) { print "error: unmatched brackets\n"; }
|
||||
else {
|
||||
print "error: unmatched brackets for function '$ident';\n";
|
||||
print "body: [$potential_body]\n";
|
||||
}
|
||||
exit;
|
||||
} else {
|
||||
$body = $extract[0];
|
||||
$preprecode .= $extract[1];
|
||||
$precode .= $extract[1];
|
||||
}
|
||||
|
||||
print "final extract: [$ret][$ident][$params][$body]\n" if $debug;
|
||||
$code .= "$ret $ident($params) $body\n\n";
|
||||
$has_main = 1 if $ident eq 'main';
|
||||
}
|
||||
|
||||
print "final extract: [$ret][$ident][$params][$body]\n" if $debug;
|
||||
$code .= "$ret $ident($params) $body\n\n";
|
||||
$has_main = 1 if $ident eq 'main';
|
||||
}
|
||||
$precode =~ s/^\s+//;
|
||||
$precode =~ s/\s+$//;
|
||||
|
||||
$precode =~ s/^\s+//;
|
||||
$precode =~ s/\s+$//;
|
||||
$precode =~ s/^{(.*)}$/$1/s;
|
||||
|
||||
$precode =~ s/^{(.*)}$/$1/s;
|
||||
|
||||
if (not $has_main) {
|
||||
$code = "$prelude\n$code" . "int main(void) {\n$precode\n}\n";
|
||||
$nooutput = "No warnings, errors or output.";
|
||||
} else {
|
||||
print "code: [$code]; precode: [$precode]\n" if $debug;
|
||||
$code = "$prelude\n$precode\n\n$code\n";
|
||||
$nooutput = "No warnings, errors or output.";
|
||||
}
|
||||
if (not $has_main) {
|
||||
$code = "$prelude\n$code" . "int main(void) {\n$precode\n}\n";
|
||||
$nooutput = "No warnings, errors or output.";
|
||||
} else {
|
||||
print "code: [$code]; precode: [$precode]\n" if $debug;
|
||||
$code = "$prelude\n$precode\n\n$code\n";
|
||||
$nooutput = "No warnings, errors or output.";
|
||||
}
|
||||
} else {
|
||||
$code = $precode;
|
||||
$code = $precode;
|
||||
}
|
||||
|
||||
print "after func extract, code: [$code]\n" if $debug;
|
||||
|
|
@ -300,8 +288,8 @@ $result =~ s/\s+/ /gm;
|
|||
print "result: [$result]\n" if $debug;
|
||||
|
||||
if (not $has_main) {
|
||||
$result =~ s/\s*int main\(void\) \{//;
|
||||
$result =~ s/\s*\}\s*$//;
|
||||
$result =~ s/\s*int main\(void\) \{//;
|
||||
$result =~ s/\s*\}\s*$//;
|
||||
}
|
||||
|
||||
$output = length $result ? $result : $nooutput;
|
||||
|
|
@ -309,40 +297,35 @@ $output = length $result ? $result : $nooutput;
|
|||
print "$output\n";
|
||||
|
||||
sub execute {
|
||||
my $timeout = shift @_;
|
||||
my ($cmdline) = @_;
|
||||
my $timeout = shift @_;
|
||||
my ($cmdline) = @_;
|
||||
|
||||
my ($ret, $result);
|
||||
my ($ret, $result);
|
||||
|
||||
($ret, $result) = eval {
|
||||
print "eval\n" if $debug;
|
||||
($ret, $result) = eval {
|
||||
print "eval\n" if $debug;
|
||||
|
||||
my $result = '';
|
||||
my $result = '';
|
||||
|
||||
my $pid = open(my $fh, '-|', "$cmdline 2>&1");
|
||||
my $pid = open(my $fh, '-|', "$cmdline 2>&1");
|
||||
|
||||
local $SIG{ALRM} = sub { print "Time out\n" if $debug; kill 'TERM', $pid; die "$result [Timed-out]\n"; };
|
||||
alarm($timeout);
|
||||
local $SIG{ALRM} = sub { print "Time out\n" if $debug; kill 'TERM', $pid; die "$result [Timed-out]\n"; };
|
||||
alarm($timeout);
|
||||
|
||||
while (my $line = <$fh>) {
|
||||
$result .= $line;
|
||||
}
|
||||
while (my $line = <$fh>) { $result .= $line; }
|
||||
|
||||
close $fh;
|
||||
my $ret = $? >> 8;
|
||||
close $fh;
|
||||
my $ret = $? >> 8;
|
||||
alarm 0;
|
||||
return ($ret, $result);
|
||||
};
|
||||
|
||||
print "done eval\n" if $debug;
|
||||
alarm 0;
|
||||
|
||||
if ($@ =~ /Timed-out/) { return (-1, $@); }
|
||||
|
||||
print "[$ret, $result]\n" if $debug;
|
||||
return ($ret, $result);
|
||||
};
|
||||
|
||||
print "done eval\n" if $debug;
|
||||
alarm 0;
|
||||
|
||||
if ($@ =~ /Timed-out/) {
|
||||
return (-1, $@);
|
||||
}
|
||||
|
||||
print "[$ret, $result]\n" if $debug;
|
||||
return ($ret, $result);
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -13,14 +13,13 @@ my ($text, $t);
|
|||
my $ua = LWP::UserAgent->new;
|
||||
$ua->agent("Mozilla/5.0");
|
||||
|
||||
my %post = ( 'number' => '4', 'collection[]' => '20thcent' );
|
||||
my %post = ('number' => '4', 'collection[]' => '20thcent');
|
||||
|
||||
my $response = $ua->post("http://www.quotationspage.com/random.php3", \%post);
|
||||
|
||||
if (not $response->is_success)
|
||||
{
|
||||
print "Couldn't get quote information.\n";
|
||||
die;
|
||||
if (not $response->is_success) {
|
||||
print "Couldn't get quote information.\n";
|
||||
die;
|
||||
}
|
||||
|
||||
$text = $response->content;
|
||||
|
|
@ -28,9 +27,9 @@ $text = $response->content;
|
|||
$text =~ m/<dt class="quote"><a.*?>(.*?)<\/a>.*?<dd class="author"><div.*?><a.*?>.*?<b>(.*?)<\/b>/g;
|
||||
$t = "\"$1\" -- $2.";
|
||||
|
||||
my $quote = chr(226) . chr(128) . chr(156);
|
||||
my $quote = chr(226) . chr(128) . chr(156);
|
||||
my $quote2 = chr(226) . chr(128) . chr(157);
|
||||
my $dash = chr(226) . chr(128) . chr(147);
|
||||
my $dash = chr(226) . chr(128) . chr(147);
|
||||
|
||||
$t =~ s/<[^>]+>//g;
|
||||
$t =~ s/<\/[^>]+>//g;
|
||||
|
|
|
|||
|
|
@ -12,20 +12,18 @@ use LWP::UserAgent;
|
|||
my ($defint, $phrase, $text, $entry, $entries, $i);
|
||||
my @defs;
|
||||
|
||||
if ($#ARGV < 0)
|
||||
{
|
||||
print "What phrase would you like to define?\n";
|
||||
die;
|
||||
if ($#ARGV < 0) {
|
||||
print "What phrase would you like to define?\n";
|
||||
die;
|
||||
}
|
||||
|
||||
$phrase = join("+", @ARGV);
|
||||
|
||||
$entry = 1;
|
||||
|
||||
if ($phrase =~ m/([0-9]+)\+(.*)/)
|
||||
{
|
||||
$entry = $1;
|
||||
$phrase = $2;
|
||||
if ($phrase =~ m/([0-9]+)\+(.*)/) {
|
||||
$entry = $1;
|
||||
$phrase = $2;
|
||||
}
|
||||
|
||||
my $ua = LWP::UserAgent->new;
|
||||
|
|
@ -33,29 +31,22 @@ $ua->agent("howdy");
|
|||
my $response = $ua->get("http://www.google.com/search?q=define:$phrase");
|
||||
$phrase =~ s/\+/ /g;
|
||||
|
||||
if (not $response->is_success) {
|
||||
exit(1);
|
||||
}
|
||||
if (not $response->is_success) { exit(1); }
|
||||
|
||||
$text = $response->content;
|
||||
if ($text =~ m/No definitions were found/i)
|
||||
{
|
||||
print "No entry found for '$phrase'. ";
|
||||
print "\n";
|
||||
exit 1;
|
||||
if ($text =~ m/No definitions were found/i) {
|
||||
print "No entry found for '$phrase'. ";
|
||||
print "\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
print "$phrase: ";
|
||||
|
||||
$i = $entry;
|
||||
|
||||
while ($i <= $entry + 5)
|
||||
{
|
||||
if ($text =~ m/<li>(.*?)<br>/gs)
|
||||
{
|
||||
push @defs, $1;
|
||||
}
|
||||
$i++;
|
||||
while ($i <= $entry + 5) {
|
||||
if ($text =~ m/<li>(.*?)<br>/gs) { push @defs, $1; }
|
||||
$i++;
|
||||
}
|
||||
|
||||
my %uniq = map { $_ => 1 } @defs;
|
||||
|
|
@ -63,27 +54,27 @@ my %uniq = map { $_ => 1 } @defs;
|
|||
|
||||
my $comma = "";
|
||||
|
||||
for($i = 1; $i <= $#defs + 1; $i++) {
|
||||
for ($i = 1; $i <= $#defs + 1; $i++) {
|
||||
|
||||
# and now for some fugly beautifying regexps...
|
||||
# and now for some fugly beautifying regexps...
|
||||
|
||||
my $quote = chr(226) . chr(128) . chr(156);
|
||||
my $quote2 = chr(226) . chr(128) . chr(157);
|
||||
my $dash = chr(226) . chr(128) . chr(147);
|
||||
my $quote = chr(226) . chr(128) . chr(156);
|
||||
my $quote2 = chr(226) . chr(128) . chr(157);
|
||||
my $dash = chr(226) . chr(128) . chr(147);
|
||||
|
||||
$_ = $defs[$i-1];
|
||||
$_ = $defs[$i - 1];
|
||||
|
||||
s/$quote/"/g;
|
||||
s/$quote2/"/g;
|
||||
s/$dash/-/g;
|
||||
s/<b>Pronun.*?<BR>//gsi;
|
||||
s/<.*?>//gsi;
|
||||
s/\ \;/ /gi;
|
||||
s/\&.*?\;//g;
|
||||
s/\r\n//gs;
|
||||
s/\( P \)//gs;
|
||||
s/\s+/ /gs;
|
||||
s/$quote/"/g;
|
||||
s/$quote2/"/g;
|
||||
s/$dash/-/g;
|
||||
s/<b>Pronun.*?<BR>//gsi;
|
||||
s/<.*?>//gsi;
|
||||
s/\ \;/ /gi;
|
||||
s/\&.*?\;//g;
|
||||
s/\r\n//gs;
|
||||
s/\( P \)//gs;
|
||||
s/\s+/ /gs;
|
||||
|
||||
print "$i) $_$comma";
|
||||
$comma = ", ";
|
||||
print "$i) $_$comma";
|
||||
$comma = ", ";
|
||||
}
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue